OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2014-05-21  Bob Duff  <duff@adacore.com>

	* sem_util.adb (Is_Dependent_Component_Of_Mutable_Object):
	This was returning False if the Object is a constant view. Fix
	it to return True in that case, because it might be a view of
	a variable.
	(Has_Discriminant_Dependent_Constraint): Fix latent
	bug; this function was crashing when passed a discriminant.

2014-05-21  Robert Dewar  <dewar@adacore.com>

	* gnat_ugn.texi: Remove misplaced section that is now obsolete.
	* s-arit64.adb: Minor code reorganization.
	* sem_prag.adb: Minor comment fix (remove erroneous use of the
	term erroneous).

2014-05-21  Robert Dewar  <dewar@adacore.com>

	* g-table.adb, g-dyntab.adb (Reallocate): Fix possible overflow in
	computing new table size.

From-SVN: r210690
This commit is contained in:
Arnaud Charlet 2014-05-21 12:52:48 +02:00
parent 2735b82d09
commit 6413dd8180
7 changed files with 126 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
gcc/ada/ChangeLog
View File

@ -1,3 +1,24 @@
2014-05-21 Bob Duff <duff@adacore.com>
* sem_util.adb (Is_Dependent_Component_Of_Mutable_Object):
This was returning False if the Object is a constant view. Fix
it to return True in that case, because it might be a view of
a variable.
(Has_Discriminant_Dependent_Constraint): Fix latent
bug; this function was crashing when passed a discriminant.
2014-05-21 Robert Dewar <dewar@adacore.com>
* gnat_ugn.texi: Remove misplaced section that is now obsolete.
* s-arit64.adb: Minor code reorganization.
* sem_prag.adb: Minor comment fix (remove erroneous use of the
term erroneous).
2014-05-21 Robert Dewar <dewar@adacore.com>
* g-table.adb, g-dyntab.adb (Reallocate): Fix possible overflow in
computing new table size.
2014-05-21 Robert Dewar <dewar@adacore.com>
* einfo.ads: Minor reformatting.

17
gcc/ada/g-dyntab.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2013, AdaCore --
-- Copyright (C) 2000-2014, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -187,13 +187,24 @@ package body GNAT.Dynamic_Tables is
begin
if T.P.Max < T.P.Last_Val then
-- Now increment table length until it is sufficiently large. Use
-- the increment value or 10, which ever is larger (the reason
-- for the use of 10 here is to ensure that the table does really
-- increase in size (which would not be the case for a table of
-- length 10 increased by 3% for instance). Do the intermediate
-- calculation in Long_Long_Integer to avoid overflow.
while T.P.Max < T.P.Last_Val loop
New_Length := T.P.Length * (100 + Table_Increment) / 100;
New_Length :=
Integer
(Long_Long_Integer (T.P.Length) *
(100 + Long_Long_Integer (Table_Increment)) / 100);
if New_Length > T.P.Length then
T.P.Length := New_Length;
else
T.P.Length := T.P.Length + 1;
T.P.Length := T.P.Length + 10;
end if;
T.P.Max := Min + T.P.Length - 1;

24
gcc/ada/g-table.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2013, AdaCore --
-- Copyright (C) 1998-2014, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -196,21 +196,25 @@ package body GNAT.Table is
----------------
procedure Reallocate is
New_Size : size_t;
New_Size : size_t;
New_Length : Long_Long_Integer;
begin
if Max < Last_Val then
pragma Assert (not Locked);
-- Now increment table length until it is sufficiently large. Use
-- the increment value or 10, which ever is larger (the reason
-- for the use of 10 here is to ensure that the table does really
-- increase in size (which would not be the case for a table of
-- length 10 increased by 3% for instance). Do the intermediate
-- calculation in Long_Long_Integer to avoid overflow.
while Max < Last_Val loop
-- Increase length using the table increment factor, but make
-- sure that we add at least ten elements (this avoids a loop
-- for silly small increment values)
Length := Integer'Max
(Length * (100 + Table_Increment) / 100,
Length + 10);
New_Length :=
Long_Long_Integer (Length) *
(100 + Long_Long_Integer (Table_Increment)) / 100;
Length := Integer'Max (Integer (New_Length), Length + 10);
Max := Min + Length - 1;
end loop;
end if;

5
gcc/ada/gnat_ugn.texi
View File

@ -8369,11 +8369,6 @@ limit, then a message is output and the bind is abandoned.
A value of zero means that no limit is enforced. The equal
sign is optional.
@ifset unw
Furthermore, under Windows, the sources pointed to by the libraries path
set in the registry are not searched for.
@end ifset
@item ^-n^/NOMAIN^
@cindex @option{^-n^/NOMAIN^} (@command{gnatbind})
No main program.

18
gcc/ada/s-arit64.adb
View File

@ -49,22 +49,17 @@ package body System.Arith_64 is
-----------------------
function "+" (A, B : Uns32) return Uns64 is (Uns64 (A) + Uns64 (B));
function "+" (A : Uns64; B : Uns32) return Uns64 is
(A + Uns64 (B));
pragma Inline ("+");
function "+" (A : Uns64; B : Uns32) return Uns64 is (A + Uns64 (B));
-- Length doubling additions
function "*" (A, B : Uns32) return Uns64 is (Uns64 (A) * Uns64 (B));
pragma Inline ("*");
-- Length doubling multiplication
function "/" (A : Uns64; B : Uns32) return Uns64 is (A / Uns64 (B));
pragma Inline ("/");
-- Length doubling division
function "&" (Hi, Lo : Uns32) return Uns64 is
(Shift_Left (Uns64 (Hi), 32) or Uns64 (Lo));
pragma Inline ("&");
-- Concatenate hi, lo values to form 64-bit result
function "abs" (X : Int64) return Uns64 is
@ -73,35 +68,32 @@ package body System.Arith_64 is
-- the expression of the Else, because it overflows for X = Int64'First.
function "rem" (A : Uns64; B : Uns32) return Uns64 is (A rem Uns64 (B));
pragma Inline ("rem");
-- Length doubling remainder
function Le3 (X1, X2, X3 : Uns32; Y1, Y2, Y3 : Uns32) return Boolean;
-- Determines if 96 bit value X1&X2&X3 <= Y1&Y2&Y3
function Lo (A : Uns64) return Uns32 is (Uns32 (A and 16#FFFF_FFFF#));
pragma Inline (Lo);
-- Low order half of 64-bit value
function Hi (A : Uns64) return Uns32 is (Uns32 (Shift_Right (A, 32)));
pragma Inline (Hi);
-- High order half of 64-bit value
procedure Sub3 (X1, X2, X3 : in out Uns32; Y1, Y2, Y3 : Uns32);
-- Computes X1&X2&X3 := X1&X2&X3 - Y1&Y1&Y3 with mod 2**96 wrap
function To_Neg_Int (A : Uns64) return Int64;
function To_Neg_Int (A : Uns64) return Int64 with Inline;
-- Convert to negative integer equivalent. If the input is in the range
-- 0 .. 2 ** 63, then the corresponding negative signed integer (obtained
-- by negating the given value) is returned, otherwise constraint error
-- is raised.
function To_Pos_Int (A : Uns64) return Int64;
function To_Pos_Int (A : Uns64) return Int64 with Inline;
-- Convert to positive integer equivalent. If the input is in the range
-- 0 .. 2 ** 63-1, then the corresponding non-negative signed integer is
-- returned, otherwise constraint error is raised.
procedure Raise_Error;
procedure Raise_Error with Inline;
pragma No_Return (Raise_Error);
-- Raise constraint error with appropriate message
@ -586,7 +578,6 @@ package body System.Arith_64 is
function To_Neg_Int (A : Uns64) return Int64 is
R : constant Int64 := -To_Int (A);
begin
if R <= 0 then
return R;
@ -601,7 +592,6 @@ package body System.Arith_64 is
function To_Pos_Int (A : Uns64) return Int64 is
R : constant Int64 := To_Int (A);
begin
if R >= 0 then
return R;

21
gcc/ada/sem_prag.adb
View File

@ -1239,7 +1239,7 @@ package body Sem_Prag is
Is_Input : Boolean)
is
procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id);
-- Emit an error concerning the erroneous usage of an item
-- Emit an error concerning the illegal usage of an item
-----------------
-- Usage_Error --
@ -1783,10 +1783,11 @@ package body Sem_Prag is
Is_Last => Clause = Last_Clause);
end if;
-- Do not normalize an erroneous clause because the inputs
-- and/or outputs may denote illegal items. Normalization is
-- disabled in ASIS mode as it alters the tree by introducing
-- new nodes similar to expansion.
-- Do not normalize a clause if errors were detected (count
-- of Serious_Errors has increased) because the inputs and/or
-- outputs may denote illegal items. Normalization is disabled
-- in ASIS mode as it alters the tree by introducing new nodes
-- similar to expansion.
if Serious_Errors_Detected = Errors and then not ASIS_Mode then
Normalize_Clause (Clause);
@ -2288,7 +2289,7 @@ package body Sem_Prag is
raise Program_Error;
end if;
-- Any other attempt to declare a global item is erroneous
-- Any other attempt to declare a global item is illegal
else
Error_Msg_N ("malformed global list", List);
@ -4700,7 +4701,7 @@ package body Sem_Prag is
Prag := Stmt;
-- A non-pragma is separating the group from the
-- current pragma, the placement is erroneous.
-- current pragma, the placement is illegal.
else
Grouping_Error (Prag);
@ -10584,7 +10585,7 @@ package body Sem_Prag is
then
Analyze_External_Option (Opt);
-- When an erroneous option Part_Of is without a parent
-- When an illegal option Part_Of is without a parent
-- state, it appears in the list of expression of the
-- aggregate rather than the component associations
-- (SPARK RM 7.1.4(9)).
@ -10627,7 +10628,7 @@ package body Sem_Prag is
Next (Opt);
end loop;
-- Any other attempt to declare a state is erroneous
-- Any other attempt to declare a state is illegal
else
Error_Msg_N ("malformed abstract state declaration", State);
@ -25515,7 +25516,7 @@ package body Sem_Prag is
elsif N = Name_Off then
return Off;
-- Any other argument is erroneous
-- Any other argument is illegal
else
raise Program_Error;

98
gcc/ada/sem_util.adb
View File

@ -7300,39 +7300,46 @@ package body Sem_Util is
(Comp : Entity_Id) return Boolean
is
Comp_Decl : constant Node_Id := Parent (Comp);
Subt_Indic : constant Node_Id :=
Subtype_Indication (Component_Definition (Comp_Decl));
Subt_Indic : Node_Id;
Constr : Node_Id;
Assn : Node_Id;
begin
if Nkind (Subt_Indic) = N_Subtype_Indication then
Constr := Constraint (Subt_Indic);
-- Discriminants can't depend on discriminants
if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
Assn := First (Constraints (Constr));
while Present (Assn) loop
case Nkind (Assn) is
when N_Subtype_Indication |
N_Range |
N_Identifier
=>
if Depends_On_Discriminant (Assn) then
return True;
end if;
if Ekind (Comp) = E_Discriminant then
return False;
when N_Discriminant_Association =>
if Depends_On_Discriminant (Expression (Assn)) then
return True;
end if;
else
Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
when others =>
null;
if Nkind (Subt_Indic) = N_Subtype_Indication then
Constr := Constraint (Subt_Indic);
end case;
if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
Assn := First (Constraints (Constr));
while Present (Assn) loop
case Nkind (Assn) is
when N_Subtype_Indication |
N_Range |
N_Identifier
=>
if Depends_On_Discriminant (Assn) then
return True;
end if;
Next (Assn);
end loop;
when N_Discriminant_Association =>
if Depends_On_Discriminant (Expression (Assn)) then
return True;
end if;
when others =>
null;
end case;
Next (Assn);
end loop;
end if;
end if;
end if;
@ -9740,11 +9747,6 @@ package body Sem_Util is
function Is_Dependent_Component_Of_Mutable_Object
(Object : Node_Id) return Boolean
is
P : Node_Id;
Prefix_Type : Entity_Id;
P_Aliased : Boolean := False;
Comp : Entity_Id;
function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
-- Returns True if and only if Comp is declared within a variant part
@ -9759,17 +9761,41 @@ package body Sem_Util is
return Nkind (Parent (Comp_List)) = N_Variant;
end Is_Declared_Within_Variant;
P : Node_Id;
Prefix_Type : Entity_Id;
P_Aliased : Boolean := False;
Comp : Entity_Id;
Deref : Node_Id := Object;
-- Dereference node, in something like X.all.Y(2)
-- Start of processing for Is_Dependent_Component_Of_Mutable_Object
begin
if Is_Variable (Object) then
-- Find the dereference node if any
while Nkind_In (Deref, N_Indexed_Component,
N_Selected_Component,
N_Slice)
loop
Deref := Prefix (Deref);
end loop;
-- Ada 2005: If we have a component or slice of a dereference,
-- something like X.all.Y (2), and the type of X is access-to-constant,
-- Is_Variable will return False, because it is indeed a constant
-- view. But it might be a view of a variable object, so we want the
-- following condition to be True in that case.
if Is_Variable (Object)
or else (Ada_Version >= Ada_2005
and then Nkind (Deref) = N_Explicit_Dereference)
then
if Nkind (Object) = N_Selected_Component then
P := Prefix (Object);
Prefix_Type := Etype (P);
if Is_Entity_Name (P) then
if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
Prefix_Type := Base_Type (Prefix_Type);
end if;
@ -9801,10 +9827,10 @@ package body Sem_Util is
-- the dereferenced case, since the access value might denote an
-- unconstrained aliased object, whereas in Ada 95 the designated
-- object is guaranteed to be constrained. A worst-case assumption
-- has to apply in Ada 2005 because we can't tell at compile time
-- whether the object is "constrained by its initial value"
-- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
-- semantic rules -- these rules are acknowledged to need fixing).
-- has to apply in Ada 2005 because we can't tell at compile
-- time whether the object is "constrained by its initial value"
-- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
-- rules (these rules are acknowledged to need fixing).
if Ada_Version < Ada_2005 then
if Is_Access_Type (Prefix_Type)
@ -9813,7 +9839,7 @@ package body Sem_Util is
return False;
end if;
elsif Ada_Version >= Ada_2005 then
else pragma Assert (Ada_Version >= Ada_2005);
if Is_Access_Type (Prefix_Type) then
-- If the access type is pool-specific, and there is no