mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-01 20:21:12 +08:00
Code Issues Packages Projects Releases Wiki Activity

exp_aggr.adb: Update comments.

Browse Source 
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.

From-SVN: r213286
This commit is contained in:
Robert Dewar 2014-07-30 14:32:24 +00:00 committed by Arnaud Charlet
parent 2b4c962d78
commit 41a58113f8
12 changed files with 229 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gcc/ada/ChangeLog
View File

@ -1,3 +1,34 @@
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.

48
gcc/ada/a-cbhase.adb
View File

@ -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;

6
gcc/ada/a-cbhase.ads
View File

@ -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

7
gcc/ada/a-chtgbo.adb
View File

@ -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";

7
gcc/ada/a-chtgbo.ads
View File

@ -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

71
gcc/ada/cstand.adb
View File

@ -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 --
--------------------

11
gcc/ada/exp_aggr.adb
View File

@ -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;

35
gcc/ada/exp_attr.adb
View File

@ -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;
--------------

11
gcc/ada/exp_ch3.adb
View File

@ -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

78
gcc/ada/sem_ch3.adb
View File

@ -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;

10
gcc/ada/sem_ch3.ads
View File

@ -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;

14
gcc/ada/sem_eval.adb
View File

@ -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;