From 41a58113f8e2d6bc4bd52e168e7079053cda5eb9 Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Wed, 30 Jul 2014 14:32:24 +0000 Subject: [PATCH] exp_aggr.adb: Update comments. 2014-07-30 Robert Dewar * exp_aggr.adb: Update comments. * a-chtgbo.adb, a-chtgbo.ads, a-cbhase.adb, a-cbhase.ads: Minor reformatting. 2014-07-30 Robert Dewar * 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 * 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. From-SVN: r213286 --- gcc/ada/ChangeLog | 31 ++++++++++++++++++ gcc/ada/a-cbhase.adb | 48 +++++++++++++-------------- gcc/ada/a-cbhase.ads | 6 ++-- gcc/ada/a-chtgbo.adb | 7 ++-- gcc/ada/a-chtgbo.ads | 7 ++-- gcc/ada/cstand.adb | 71 ++++++++++++++++++---------------------- gcc/ada/exp_aggr.adb | 11 +++---- gcc/ada/exp_attr.adb | 35 +++++++++++++++++++- gcc/ada/exp_ch3.adb | 11 +++++-- gcc/ada/sem_ch3.adb | 78 ++++++++++++++++++++++++++++++++++++++++---- gcc/ada/sem_ch3.ads | 10 ++++-- gcc/ada/sem_eval.adb | 14 +++++--- 12 files changed, 229 insertions(+), 100 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 96e883dd9e5..fea05ae35f1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2014-07-30 Robert Dewar + + * exp_aggr.adb: Update comments. + * a-chtgbo.adb, a-chtgbo.ads, a-cbhase.adb, a-cbhase.ads: Minor + reformatting. + +2014-07-30 Robert Dewar + + * 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 + + * 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 * clean.adb: Minor reformatting. diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb index 65cf7f7d788..dbf234bf3f2 100644 --- a/gcc/ada/a-cbhase.adb +++ b/gcc/ada/a-cbhase.adb @@ -1,4 +1,4 @@ -------------------------------------------------------------------------------- +------------------------------------------------------------------------------ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- @@ -762,8 +762,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is 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; @@ -1649,11 +1648,11 @@ package body Ada.Containers.Bounded_Hashed_Sets is 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); ------------------------ @@ -1786,7 +1785,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is 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; @@ -1865,15 +1864,14 @@ package body Ada.Containers.Bounded_Hashed_Sets is 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; @@ -1898,13 +1896,13 @@ package body Ada.Containers.Bounded_Hashed_Sets is 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; diff --git a/gcc/ada/a-cbhase.ads b/gcc/ada/a-cbhase.ads index 551e84133c0..619aec9debc 100644 --- a/gcc/ada/a-cbhase.ads +++ b/gcc/ada/a-cbhase.ads @@ -456,12 +456,10 @@ package Ada.Containers.Bounded_Hashed_Sets is 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 diff --git a/gcc/ada/a-chtgbo.adb b/gcc/ada/a-chtgbo.adb index 38f95002254..d114bc8bb04 100644 --- a/gcc/ada/a-chtgbo.adb +++ b/gcc/ada/a-chtgbo.adb @@ -86,9 +86,9 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is -------------------------- 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; @@ -106,6 +106,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is 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"; diff --git a/gcc/ada/a-chtgbo.ads b/gcc/ada/a-chtgbo.ads index 719fae94ef5..5019154205d 100644 --- a/gcc/ada/a-chtgbo.ads +++ b/gcc/ada/a-chtgbo.ads @@ -85,10 +85,9 @@ package Ada.Containers.Hash_Tables.Generic_Bounded_Operations is -- 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 diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 0bb0d84c670..f24bf79f266 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -151,6 +151,10 @@ package body CStand is (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 @@ -1204,30 +1208,27 @@ package body CStand is -- 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); @@ -1237,18 +1238,16 @@ package body CStand is 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); @@ -1257,34 +1256,30 @@ package body CStand is 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); @@ -1296,83 +1291,72 @@ package body CStand is 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); @@ -1879,6 +1863,13 @@ package body CStand is 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 -- -------------------- diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index b6602503f43..5ff1421db16 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4012,11 +4012,10 @@ package body Exp_Aggr is -- 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. @@ -4087,7 +4086,7 @@ package body Exp_Aggr is 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; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index f8cfd4ca93a..43051fae1a6 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2872,11 +2872,28 @@ package body Exp_Attr is 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; --------------- @@ -3535,8 +3552,24 @@ package body Exp_Attr is 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; -------------- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index b9c7c99c294..c928247e628 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -3234,7 +3234,7 @@ package body Exp_Ch3 is 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; @@ -5844,9 +5844,14 @@ package body Exp_Ch3 is 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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 0a1bfd93b94..473d2cf899b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -12390,7 +12390,7 @@ package body Sem_Ch3 is 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 @@ -19018,9 +19018,10 @@ package body Sem_Ch3 is 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; @@ -19142,8 +19143,71 @@ package body Sem_Ch3 is -- 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 @@ -20567,7 +20631,7 @@ package body Sem_Ch3 is -- 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; diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index a0465802b10..dedf943ed59 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -264,9 +264,10 @@ package Sem_Ch3 is 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 @@ -279,6 +280,9 @@ package Sem_Ch3 is -- 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; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 9a83ca577ef..62421896565 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -1240,16 +1240,22 @@ package body Sem_Eval is 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; -- 2.30.2