diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 12038bf56b5..b605eca8317 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,24 @@ +2014-05-21 Bob Duff + + * 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 + + * 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 + + * g-table.adb, g-dyntab.adb (Reallocate): Fix possible overflow in + computing new table size. + 2014-05-21 Robert Dewar * einfo.ads: Minor reformatting. diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb index 634bbbbb4e8..e5e41c927a0 100644 --- a/gcc/ada/g-dyntab.adb +++ b/gcc/ada/g-dyntab.adb @@ -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; diff --git a/gcc/ada/g-table.adb b/gcc/ada/g-table.adb index 9b3692bbe06..e12e84f7578 100644 --- a/gcc/ada/g-table.adb +++ b/gcc/ada/g-table.adb @@ -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; diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 2d9c61865d9..78d682b36b6 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -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. diff --git a/gcc/ada/s-arit64.adb b/gcc/ada/s-arit64.adb index d41fc92ed43..51b05f9a235 100644 --- a/gcc/ada/s-arit64.adb +++ b/gcc/ada/s-arit64.adb @@ -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; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c8ef01aa0e2..f5a507401a0 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a981960ae48..13e74daf952 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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