+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.
-- --
-- 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- --
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;
-- --
-- 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- --
----------------
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);
- 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)
+ -- 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.
- Length := Integer'Max
- (Length * (100 + Table_Increment) / 100,
- Length + 10);
+ while Max < Last_Val loop
+ 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;
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.
-----------------------
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
-- 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
function To_Neg_Int (A : Uns64) return Int64 is
R : constant Int64 := -To_Int (A);
-
begin
if R <= 0 then
return R;
function To_Pos_Int (A : Uns64) return Int64 is
R : constant Int64 := To_Int (A);
-
begin
if R >= 0 then
return R;
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 --
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);
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);
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);
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)).
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);
elsif N = Name_Off then
return Off;
- -- Any other argument is erroneous
+ -- Any other argument is illegal
else
raise Program_Error;
(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;
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
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;
-- 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)
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
projects / platform / upstream / linaro-gcc.git / commitdiff