+2014-07-30 Robert Dewar <dewar@adacore.com>
+
+ * exp_aggr.adb: Update comments.
+ * a-chtgbo.adb, a-chtgbo.ads, a-cbhase.adb, a-cbhase.ads: Minor
+ reformatting.
+
+2014-07-30 Robert Dewar <dewar@adacore.com>
+
+ * cstand.adb (New_Standard_Entity): New version takes name
+ string to call Make_Name.
+ (Create_Standard): Use this routine to set name before setting other
+ fields.
+
+2014-07-30 Robert Dewar <dewar@adacore.com>
+
+ * exp_attr.adb (Expand_Attribute, case First): Rewrite simple
+ entity reference.
+ (Expand_Attribute, case Last): Ditto.
+ * exp_ch3.adb (Constrain_Index): New calling sequence for
+ Process_Range_Expr_In_Decl.
+ (Expand_N_Object_Declaration): Avoid setting Is_Known_Valid in one
+ problematical case.
+ * sem_ch3.adb (Constrain_Index): New calling sequence for
+ Process_Range_Expr_In_Decl.
+ (Set_Scalar_Range_For_Subtype): ditto.
+ (Process_Range_Expr_In_Decl): Create constants to hold bounds for
+ subtype.
+ * sem_ch3.ads (Process_Range_Expr_In_Decl): Add Subtyp parameter.
+ * sem_eval.adb (Compile_Time_Compare): Make sure we use base
+ types if we are not assuming no invalid values.
+
2014-07-30 Robert Dewar <dewar@adacore.com>
* clean.adb: Minor reformatting.
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
- raise Program_Error with
- "attempt to insert element already in set";
+ raise Program_Error with "attempt to insert element already in set";
end if;
end Insert;
package Key_Keys is
new Hash_Tables.Generic_Bounded_Keys
- (HT_Types => HT_Types,
- Next => Next,
- Set_Next => Set_Next,
- Key_Type => Key_Type,
- Hash => Hash,
+ (HT_Types => HT_Types,
+ Next => Next,
+ Set_Next => Set_Next,
+ Key_Type => Key_Type,
+ Hash => Hash,
Equivalent_Keys => Equivalent_Key_Node);
------------------------
if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash
then
HT_Ops.Delete_Node_At_Index
- (Control.Container.all, Control.Index, Control.Old_Pos.Node);
+ (Control.Container.all, Control.Index, Control.Old_Pos.Node);
raise Program_Error with "key not preserved in reference";
end if;
begin
return R : constant Reference_Type :=
- (Element => N.Element'Unrestricted_Access,
- Control =>
- (Controlled with
- Container'Unrestricted_Access,
- Index =>
- Key_Keys.Index (Container, Key (Position)),
- Old_Pos => Position,
- Old_Hash => Hash (Key (Position))))
- do
+ (Element => N.Element'Unrestricted_Access,
+ Control =>
+ (Controlled with
+ Container'Unrestricted_Access,
+ Index => Key_Keys.Index (Container, Key (Position)),
+ Old_Pos => Position,
+ Old_Hash => Hash (Key (Position))))
+ do
B := B + 1;
L := L + 1;
end return;
begin
return R : constant Reference_Type :=
- (Element => Container.Nodes (Node).Element'Unrestricted_Access,
- Control =>
- (Controlled with
- Container'Unrestricted_Access,
- Index => Key_Keys.Index (Container, Key),
- Old_Pos => P,
- Old_Hash => Hash (Key)))
+ (Element => Container.Nodes (Node).Element'Unrestricted_Access,
+ Control =>
+ (Controlled with
+ Container'Unrestricted_Access,
+ Index => Key_Keys.Index (Container, Key),
+ Old_Pos => P,
+ Old_Hash => Hash (Key)))
do
B := B + 1;
L := L + 1;
Old_Hash : Hash_Type;
end record;
- overriding procedure
- Adjust (Control : in out Reference_Control_Type);
+ overriding procedure Adjust (Control : in out Reference_Control_Type);
pragma Inline (Adjust);
- overriding procedure
- Finalize (Control : in out Reference_Control_Type);
+ overriding procedure Finalize (Control : in out Reference_Control_Type);
pragma Inline (Finalize);
type Reference_Type (Element : not null access Element_Type) is record
--------------------------
procedure Delete_Node_At_Index
- (HT : in out Hash_Table_Type'Class;
- Indx : Hash_Type;
- X : Count_Type)
+ (HT : in out Hash_Table_Type'Class;
+ Indx : Hash_Type;
+ X : Count_Type)
is
Prev : Count_Type;
Curr : Count_Type;
HT.Length := HT.Length - 1;
return;
end if;
+
if HT.Length = 1 then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
-- table is busy.
procedure Delete_Node_At_Index
- (HT : in out Hash_Table_Type'Class;
- Indx : Hash_Type;
- X : Count_Type);
-
+ (HT : in out Hash_Table_Type'Class;
+ Indx : Hash_Type;
+ X : Count_Type);
-- Delete a node whose bucket position is known. extracted from following
-- subprogram, but also used directly to remove a node whose element has
-- been modified through a key_preserving reference: in that case we cannot
(New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id;
-- Builds a new entity for Standard
+ function New_Standard_Entity (S : String) return Entity_Id;
+ -- Builds a new entity for Standard with Nkind = N_Defining_Identifier,
+ -- and Chars of this defining identifier set to the given string S.
+
procedure Print_Standard;
-- Print representation of package Standard if switch set
-- filled out to minimize problems with cascaded errors (for example,
-- Any_Integer is given reasonable and consistent type and size values)
- Any_Type := New_Standard_Entity;
+ Any_Type := New_Standard_Entity ("any type");
Decl := New_Node (N_Full_Type_Declaration, Stloc);
Set_Defining_Identifier (Decl, Any_Type);
Set_Scope (Any_Type, Standard_Standard);
Build_Signed_Integer_Type (Any_Type, Standard_Integer_Size);
- Make_Name (Any_Type, "any type");
- Any_Id := New_Standard_Entity;
+ Any_Id := New_Standard_Entity ("any id");
Set_Ekind (Any_Id, E_Variable);
Set_Scope (Any_Id, Standard_Standard);
Set_Etype (Any_Id, Any_Type);
Init_Esize (Any_Id);
Init_Alignment (Any_Id);
- Make_Name (Any_Id, "any id");
- Any_Access := New_Standard_Entity;
+ Any_Access := New_Standard_Entity ("an access type");
Set_Ekind (Any_Access, E_Access_Type);
Set_Scope (Any_Access, Standard_Standard);
Set_Etype (Any_Access, Any_Access);
Init_Size (Any_Access, System_Address_Size);
Set_Elem_Alignment (Any_Access);
- Make_Name (Any_Access, "an access type");
- Any_Character := New_Standard_Entity;
+ Any_Character := New_Standard_Entity ("a character type");
Set_Ekind (Any_Character, E_Enumeration_Type);
Set_Scope (Any_Character, Standard_Standard);
Set_Etype (Any_Character, Any_Character);
Init_RM_Size (Any_Character, 8);
Set_Elem_Alignment (Any_Character);
Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character));
- Make_Name (Any_Character, "a character type");
- Any_Array := New_Standard_Entity;
+ Any_Array := New_Standard_Entity ("an array type");
Set_Ekind (Any_Array, E_Array_Type);
Set_Scope (Any_Array, Standard_Standard);
Set_Etype (Any_Array, Any_Array);
Set_Component_Type (Any_Array, Any_Character);
Init_Size_Align (Any_Array);
- Make_Name (Any_Array, "an array type");
Make_Dummy_Index (Any_Array);
- Any_Boolean := New_Standard_Entity;
+ Any_Boolean := New_Standard_Entity ("a boolean type");
Set_Ekind (Any_Boolean, E_Enumeration_Type);
Set_Scope (Any_Boolean, Standard_Standard);
Set_Etype (Any_Boolean, Standard_Boolean);
Set_Elem_Alignment (Any_Boolean);
Set_Is_Unsigned_Type (Any_Boolean);
Set_Scalar_Range (Any_Boolean, Scalar_Range (Standard_Boolean));
- Make_Name (Any_Boolean, "a boolean type");
- Any_Composite := New_Standard_Entity;
+ Any_Composite := New_Standard_Entity ("a composite type");
Set_Ekind (Any_Composite, E_Array_Type);
Set_Scope (Any_Composite, Standard_Standard);
Set_Etype (Any_Composite, Any_Composite);
Set_Component_Size (Any_Composite, Uint_0);
Set_Component_Type (Any_Composite, Standard_Integer);
Init_Size_Align (Any_Composite);
- Make_Name (Any_Composite, "a composite type");
- Any_Discrete := New_Standard_Entity;
+ Any_Discrete := New_Standard_Entity ("a discrete type");
Set_Ekind (Any_Discrete, E_Signed_Integer_Type);
Set_Scope (Any_Discrete, Standard_Standard);
Set_Etype (Any_Discrete, Any_Discrete);
Init_Size (Any_Discrete, Standard_Integer_Size);
Set_Elem_Alignment (Any_Discrete);
- Make_Name (Any_Discrete, "a discrete type");
- Any_Fixed := New_Standard_Entity;
+ Any_Fixed := New_Standard_Entity ("a fixed-point type");
Set_Ekind (Any_Fixed, E_Ordinary_Fixed_Point_Type);
Set_Scope (Any_Fixed, Standard_Standard);
Set_Etype (Any_Fixed, Any_Fixed);
Init_Size (Any_Fixed, Standard_Integer_Size);
Set_Elem_Alignment (Any_Fixed);
- Make_Name (Any_Fixed, "a fixed-point type");
- Any_Integer := New_Standard_Entity;
+ Any_Integer := New_Standard_Entity ("an integer type");
Set_Ekind (Any_Integer, E_Signed_Integer_Type);
Set_Scope (Any_Integer, Standard_Standard);
Set_Etype (Any_Integer, Standard_Long_Long_Integer);
Typ => Base_Type (Standard_Integer),
Lb => Uint_0,
Hb => Intval (High_Bound (Scalar_Range (Standard_Integer))));
- Make_Name (Any_Integer, "an integer type");
- Any_Modular := New_Standard_Entity;
+ Any_Modular := New_Standard_Entity ("a modular type");
Set_Ekind (Any_Modular, E_Modular_Integer_Type);
Set_Scope (Any_Modular, Standard_Standard);
Set_Etype (Any_Modular, Standard_Long_Long_Integer);
Init_Size (Any_Modular, Standard_Long_Long_Integer_Size);
Set_Elem_Alignment (Any_Modular);
Set_Is_Unsigned_Type (Any_Modular);
- Make_Name (Any_Modular, "a modular type");
- Any_Numeric := New_Standard_Entity;
+ Any_Numeric := New_Standard_Entity ("a numeric type");
Set_Ekind (Any_Numeric, E_Signed_Integer_Type);
Set_Scope (Any_Numeric, Standard_Standard);
Set_Etype (Any_Numeric, Standard_Long_Long_Integer);
Init_Size (Any_Numeric, Standard_Long_Long_Integer_Size);
Set_Elem_Alignment (Any_Numeric);
- Make_Name (Any_Numeric, "a numeric type");
- Any_Real := New_Standard_Entity;
+ Any_Real := New_Standard_Entity ("a real type");
Set_Ekind (Any_Real, E_Floating_Point_Type);
Set_Scope (Any_Real, Standard_Standard);
Set_Etype (Any_Real, Standard_Long_Long_Float);
Init_Size (Any_Real,
UI_To_Int (Esize (Standard_Long_Long_Float)));
Set_Elem_Alignment (Any_Real);
- Make_Name (Any_Real, "a real type");
- Any_Scalar := New_Standard_Entity;
+ Any_Scalar := New_Standard_Entity ("a scalar type");
Set_Ekind (Any_Scalar, E_Signed_Integer_Type);
Set_Scope (Any_Scalar, Standard_Standard);
Set_Etype (Any_Scalar, Any_Scalar);
Init_Size (Any_Scalar, Standard_Integer_Size);
Set_Elem_Alignment (Any_Scalar);
- Make_Name (Any_Scalar, "a scalar type");
- Any_String := New_Standard_Entity;
+ Any_String := New_Standard_Entity ("a string type");
Set_Ekind (Any_String, E_Array_Type);
Set_Scope (Any_String, Standard_Standard);
Set_Etype (Any_String, Any_String);
Set_Component_Type (Any_String, Any_Character);
Init_Size_Align (Any_String);
- Make_Name (Any_String, "a string type");
Make_Dummy_Index (Any_String);
- Raise_Type := New_Standard_Entity;
+ Raise_Type := New_Standard_Entity ("raise type");
Decl := New_Node (N_Full_Type_Declaration, Stloc);
Set_Defining_Identifier (Decl, Raise_Type);
Set_Scope (Raise_Type, Standard_Standard);
Build_Signed_Integer_Type (Raise_Type, Standard_Integer_Size);
- Make_Name (Raise_Type, "any type");
- Standard_Integer_8 := New_Standard_Entity;
+ Standard_Integer_8 := New_Standard_Entity ("integer_8");
Decl := New_Node (N_Full_Type_Declaration, Stloc);
Set_Defining_Identifier (Decl, Standard_Integer_8);
- Make_Name (Standard_Integer_8, "integer_8");
Set_Scope (Standard_Integer_8, Standard_Standard);
Build_Signed_Integer_Type (Standard_Integer_8, 8);
- Standard_Integer_16 := New_Standard_Entity;
+ Standard_Integer_16 := New_Standard_Entity ("integer_16");
Decl := New_Node (N_Full_Type_Declaration, Stloc);
Set_Defining_Identifier (Decl, Standard_Integer_16);
- Make_Name (Standard_Integer_16, "integer_16");
Set_Scope (Standard_Integer_16, Standard_Standard);
Build_Signed_Integer_Type (Standard_Integer_16, 16);
- Standard_Integer_32 := New_Standard_Entity;
+ Standard_Integer_32 := New_Standard_Entity ("integer_32");
Decl := New_Node (N_Full_Type_Declaration, Stloc);
Set_Defining_Identifier (Decl, Standard_Integer_32);
- Make_Name (Standard_Integer_32, "integer_32");
Set_Scope (Standard_Integer_32, Standard_Standard);
Build_Signed_Integer_Type (Standard_Integer_32, 32);
- Standard_Integer_64 := New_Standard_Entity;
+ Standard_Integer_64 := New_Standard_Entity ("integer_64");
Decl := New_Node (N_Full_Type_Declaration, Stloc);
Set_Defining_Identifier (Decl, Standard_Integer_64);
- Make_Name (Standard_Integer_64, "integer_64");
Set_Scope (Standard_Integer_64, Standard_Standard);
Build_Signed_Integer_Type (Standard_Integer_64, 64);
return E;
end New_Standard_Entity;
+ function New_Standard_Entity (S : String) return Entity_Id is
+ Ent : constant Entity_Id := New_Standard_Entity;
+ begin
+ Make_Name (Ent, S);
+ return Ent;
+ end New_Standard_Entity;
+
--------------------
-- Print_Standard --
--------------------
-- 4. The component size is a multiple of Storage_Unit
- -- 5. The component size is exactly Storage_Unit or the expression is
- -- an integer whose unsigned value is the binary concatenation of
- -- K times its remainder modulo 2**Storage_Unit.
-
- -- What on earth does 5 mean, incomprehensible???
+ -- 5. The component size is Storage_Unit or the value is of the form
+ -- M * (1 + A**1 + A**2 + .. A**(K-1)) where A = 2**(Storage_Unit)
+ -- and M in 1 .. A-1. This can also be viewed as K occurrences of
+ -- the 8-bit value M, concatenated together.
-- The ultimate goal is to generate a call to a fast memset routine
-- specifically optimized for the target.
Value := Value - Expr_Value (Type_Low_Bound (Ctyp));
end if;
- -- 0 and -1 immediately satisfy check #4
+ -- 0 and -1 immediately satisfy check #5
if Value = Uint_0 or else Value = Uint_Minus_1 then
return True;
Rewrite (N,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
- Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
+ Prefix =>
+ New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
Analyze_And_Resolve (N, Typ);
+ -- For access type, apply access check as needed
+
elsif Is_Access_Type (Ptyp) then
Apply_Access_Check (N);
+
+ -- For scalar type, if low bound is a reference to an entity, just
+ -- replace with a direct reference. Note that we can only have a
+ -- reference to a constant entity at this stage, anything else would
+ -- have already been rewritten.
+
+ elsif Is_Scalar_Type (Ptyp) then
+ declare
+ Lo : constant Node_Id := Type_Low_Bound (Ptyp);
+ begin
+ if Is_Entity_Name (Lo) then
+ Rewrite (N, New_Occurrence_Of (Entity (Lo), Loc));
+ end if;
+ end;
end if;
---------------
Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
Analyze_And_Resolve (N, Typ);
+ -- For access type, apply access check as needed
+
elsif Is_Access_Type (Ptyp) then
Apply_Access_Check (N);
+
+ -- For scalar type, if low bound is a reference to an entity, just
+ -- replace with a direct reference. Note that we can only have a
+ -- reference to a constant entity at this stage, anything else would
+ -- have already been rewritten.
+
+ elsif Is_Scalar_Type (Ptyp) then
+ declare
+ Hi : constant Node_Id := Type_High_Bound (Ptyp);
+ begin
+ if Is_Entity_Name (Hi) then
+ Rewrite (N, New_Occurrence_Of (Entity (Hi), Loc));
+ end if;
+ end;
end if;
--------------
begin
if Nkind (S) = N_Range then
- Process_Range_Expr_In_Decl (S, T, Check_List);
+ Process_Range_Expr_In_Decl (S, T, Check_List => Check_List);
end if;
end Constrain_Index;
return;
-- For discrete types, set the Is_Known_Valid flag if the
- -- initializing value is known to be valid.
+ -- initializing value is known to be valid. Only do this for
+ -- source assignments, since otherwise we can end up turning
+ -- on the known valid flag prematurely from inserted code.
- elsif Is_Discrete_Type (Typ) and then Expr_Known_Valid (Expr) then
+ elsif Comes_From_Source (N)
+ and then Is_Discrete_Type (Typ)
+ and then Expr_Known_Valid (Expr)
+ then
Set_Is_Known_Valid (Def_Id);
elsif Is_Access_Type (Typ) then
Set_Etype (S, T);
R := S;
- Process_Range_Expr_In_Decl (R, T, Empty_List);
+ Process_Range_Expr_In_Decl (R, T);
if not Error_Posted (S)
and then
procedure Process_Range_Expr_In_Decl
(R : Node_Id;
T : Entity_Id;
- Check_List : List_Id := Empty_List;
- R_Check_Off : Boolean := False;
- In_Iter_Schm : Boolean := False)
+ Subtyp : Entity_Id := Empty;
+ Check_List : List_Id := Empty_List;
+ R_Check_Off : Boolean := False;
+ In_Iter_Schm : Boolean := False)
is
Lo, Hi : Node_Id;
R_Checks : Check_Result;
-- not supposed to occur, e.g. on default parameters of a call.
if Expander_Active or GNATprove_Mode then
- Force_Evaluation (Lo);
- Force_Evaluation (Hi);
+
+ -- If no subtype name, then just call Force_Evaluation to
+ -- create declarations as needed to deal with side effects.
+ -- Also ignore calls from within a record type, where we
+ -- have possible scoping issues.
+
+ if No (Subtyp) or else Is_Record_Type (Current_Scope) then
+ Force_Evaluation (Lo);
+ Force_Evaluation (Hi);
+
+ -- If a subtype is given, then we capture the bounds if they
+ -- are not known at compile time, using constant identifiers
+ -- xxxL and xxxH where xxx is the name of the subtype. No need
+ -- to do that if they are already references to constants.
+
+ -- Historical note: We used to just do Force_Evaluation calls
+ -- in all cases, but it is better to capture the bounds with
+ -- proper non-serialized names, since these will be accesse
+ -- from other units, and hence may be public, and also we can
+ -- then expand 'First and 'Last references to be references to
+ -- these special names.
+
+ else
+ if not Compile_Time_Known_Value (Lo)
+ and then not (Is_Entity_Name (Lo)
+ and then Is_Constant_Object (Entity (Lo)))
+ then
+ declare
+ Loc : constant Source_Ptr := Sloc (Lo);
+ Lov : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Subtyp), 'L'));
+ begin
+ Insert_Action (R,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Lov,
+ Object_Definition =>
+ New_Occurrence_Of (Base_Type (T), Loc),
+ Constant_Present => True,
+ Expression => Relocate_Node (Lo)));
+ Rewrite (Lo, New_Occurrence_Of (Lov, Loc));
+ end;
+ end if;
+
+ if not Compile_Time_Known_Value (Hi)
+ and then not (Is_Entity_Name (Hi)
+ and then Is_Constant_Object (Entity (Hi)))
+ then
+ declare
+ Loc : constant Source_Ptr := Sloc (Hi);
+ Hiv : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Subtyp), 'H'));
+ begin
+ Insert_Action (R,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Hiv,
+ Object_Definition =>
+ New_Occurrence_Of (Base_Type (T), Loc),
+ Constant_Present => True,
+ Expression => Relocate_Node (Hi)));
+ Rewrite (Hi, New_Occurrence_Of (Hiv, Loc));
+ end;
+ end if;
+ end if;
end if;
-- We use a flag here instead of suppressing checks on the
-- catch possible premature use in the bounds themselves.
Set_Ekind (Def_Id, E_Void);
- Process_Range_Expr_In_Decl (R, Subt);
+ Process_Range_Expr_In_Decl (R, Subt, Subtyp => Def_Id);
Set_Ekind (Def_Id, Kind);
end Set_Scalar_Range_For_Subtype;
procedure Process_Range_Expr_In_Decl
(R : Node_Id;
T : Entity_Id;
- Check_List : List_Id := Empty_List;
- R_Check_Off : Boolean := False;
- In_Iter_Schm : Boolean := False);
+ Subtyp : Entity_Id := Empty;
+ Check_List : List_Id := Empty_List;
+ R_Check_Off : Boolean := False;
+ In_Iter_Schm : Boolean := False);
-- Process a range expression that appears in a declaration context. The
-- range is analyzed and resolved with the base type of the given type, and
-- an appropriate check for expressions in non-static contexts made on the
-- package. R_Check_Off is set to True when the call to Range_Check is to
-- be skipped. In_Iter_Schm is True if Process_Range_Expr_In_Decl is called
-- on the discrete subtype definition in an iteration scheme.
+ --
+ -- If Subtyp is given, then the range is for the named subtype Subtyp, and
+ -- in this case the bounds are captured if necessary using this name.
function Process_Subtype
(S : Node_Id;
return Unknown;
end if;
- -- Replace types by base types for the case of entities which are not
+ -- Replace types by base types for the case of values which are not
-- known to have valid representations. This takes care of properly
-- dealing with invalid representations.
- if not Assume_Valid and then not Assume_No_Invalid_Values then
- if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then
+ if not Assume_Valid then
+ if not (Is_Entity_Name (L)
+ and then (Is_Known_Valid (Entity (L))
+ or else Assume_No_Invalid_Values))
+ then
Ltyp := Underlying_Type (Base_Type (Ltyp));
end if;
- if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then
+ if not (Is_Entity_Name (R)
+ and then (Is_Known_Valid (Entity (R))
+ or else Assume_No_Invalid_Values))
+ then
Rtyp := Underlying_Type (Base_Type (Rtyp));
end if;
end if;
projects / gcc.git / commitdiff