[Ada] Internal cleanups in handling of subtype bounds
Arnaud Charlet
charlet@adacore.com
Wed Jul 30 14:34:00 GMT 2014
This change causes subtype bounds to be captured in special constant
variables xxxL and xxxH, avoiding troublesome cases where the call to
Force_Evaluation generated serialized temporaries that got referenced
publicly. It also means that First/Last can be expanded out in more
cases.
No functional test required, since no functional effect, but the
following test:
1. procedure FLastX (Q, S : in out Integer) is
2. subtype R is Integer range 5 .. 10;
3. subtype T is Integer range Q .. S;
4. M : Integer;
5. begin
6. Q := Q + S;
7. S := S + Q;
8. M := R'First;
9. M := R'Last;
10. M := T'First;
11. M := T'Last;
12. end;
generates the following expanded code, showing the changes:
procedure flastx (q : in out integer; s : in out integer) is
subtype flastx__r is integer range 5 .. 10;
tL : constant integer := q;
tH : constant integer := s;
subtype flastx__t is integer range tL .. tH;
m : integer;
begin
q := q + s;
s := s + q;
m := 5;
m := 10;
m := tL;
m := tH;
return;
end flastx;
Tested on x86_64-pc-linux-gnu, committed on trunk
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.
-------------- next part --------------
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 213284)
+++ sem_ch3.adb (working copy)
@@ -12390,7 +12390,7 @@
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 @@
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 @@
-- 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 @@
-- 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;
Index: sem_ch3.ads
===================================================================
--- sem_ch3.ads (revision 213284)
+++ sem_ch3.ads (working copy)
@@ -264,9 +264,10 @@
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. 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;
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 213263)
+++ exp_attr.adb (working copy)
@@ -2872,11 +2872,28 @@
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 @@
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;
--------------
Index: sem_eval.adb
===================================================================
--- sem_eval.adb (revision 213264)
+++ sem_eval.adb (working copy)
@@ -1240,16 +1240,22 @@
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;
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 213263)
+++ exp_ch3.adb (working copy)
@@ -3234,7 +3234,7 @@
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 @@
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
More information about the Gcc-patches
mailing list