===================================================================
@@ -30,7 +30,6 @@ with Errout; use Errout;
with Exp_Ch9; use Exp_Ch9;
with Elists; use Elists;
with Freeze; use Freeze;
-with Itypes; use Itypes;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nlists; use Nlists;
@@ -167,73 +166,6 @@ package body Sem_Ch9 is
Kind : Entity_Kind;
Task_Nam : Entity_Id;
- -----------------------
- -- Actual_Index_Type --
- -----------------------
-
- function Actual_Index_Type (E : Entity_Id) return Entity_Id;
- -- If the bounds of an entry family depend on task discriminants, create
- -- a new index type where a discriminant is replaced by the local
- -- variable that renames it in the task body.
-
- -----------------------
- -- Actual_Index_Type --
- -----------------------
-
- function Actual_Index_Type (E : Entity_Id) return Entity_Id is
- Typ : constant Entity_Id := Entry_Index_Type (E);
- Lo : constant Node_Id := Type_Low_Bound (Typ);
- Hi : constant Node_Id := Type_High_Bound (Typ);
- New_T : Entity_Id;
-
- function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
- -- If bound is discriminant reference, replace with corresponding
- -- local variable of the same name.
-
- -----------------------------
- -- Actual_Discriminant_Ref --
- -----------------------------
-
- function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
- Typ : constant Entity_Id := Etype (Bound);
- Ref : Node_Id;
- begin
- if not Is_Entity_Name (Bound)
- or else Ekind (Entity (Bound)) /= E_Discriminant
- then
- return Bound;
- else
- Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound)));
- Analyze (Ref);
- Resolve (Ref, Typ);
- return Ref;
- end if;
- end Actual_Discriminant_Ref;
-
- -- Start of processing for Actual_Index_Type
-
- begin
- if not Has_Discriminants (Task_Nam)
- or else (not Is_Entity_Name (Lo)
- and then not Is_Entity_Name (Hi))
- then
- return Entry_Index_Type (E);
- else
- New_T := Create_Itype (Ekind (Typ), N);
- Set_Etype (New_T, Base_Type (Typ));
- Set_Size_Info (New_T, Typ);
- Set_RM_Size (New_T, RM_Size (Typ));
- Set_Scalar_Range (New_T,
- Make_Range (Sloc (N),
- Low_Bound => Actual_Discriminant_Ref (Lo),
- High_Bound => Actual_Discriminant_Ref (Hi)));
-
- return New_T;
- end if;
- end Actual_Index_Type;
-
- -- Start of processing for Analyze_Accept_Statement
-
begin
Tasking_Used := True;
@@ -370,7 +302,7 @@ package body Sem_Ch9 is
Error_Msg_N ("missing entry index in accept for entry family", N);
else
Analyze_And_Resolve (Index, Entry_Index_Type (E));
- Apply_Range_Check (Index, Actual_Index_Type (E));
+ Apply_Range_Check (Index, Entry_Index_Type (E));
end if;
elsif Present (Index) then
===================================================================
@@ -6249,7 +6249,8 @@ package body Checks is
-- Expr > Typ'Last
function Get_E_First_Or_Last
- (E : Entity_Id;
+ (Loc : Source_Ptr;
+ E : Entity_Id;
Indx : Nat;
Nam : Name_Id) return Node_Id;
-- Returns expression to compute:
@@ -6320,7 +6321,7 @@ package body Checks is
Duplicate_Subexpr_No_Checks (Expr)),
Right_Opnd =>
Convert_To (Base_Type (Typ),
- Get_E_First_Or_Last (Typ, 0, Name_First))),
+ Get_E_First_Or_Last (Loc, Typ, 0, Name_First))),
Right_Opnd =>
Make_Op_Gt (Loc,
@@ -6330,7 +6331,7 @@ package body Checks is
Right_Opnd =>
Convert_To
(Base_Type (Typ),
- Get_E_First_Or_Last (Typ, 0, Name_Last))));
+ Get_E_First_Or_Last (Loc, Typ, 0, Name_Last))));
end Discrete_Expr_Cond;
-------------------------
@@ -6368,7 +6369,8 @@ package body Checks is
Right_Opnd =>
Convert_To
- (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First)));
+ (Base_Type (Typ),
+ Get_E_First_Or_Last (Loc, Typ, 0, Name_First)));
if Base_Type (Typ) = Typ then
return Left_Opnd;
@@ -6403,7 +6405,7 @@ package body Checks is
Right_Opnd =>
Convert_To
(Base_Type (Typ),
- Get_E_First_Or_Last (Typ, 0, Name_Last)));
+ Get_E_First_Or_Last (Loc, Typ, 0, Name_Last)));
return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
end Discrete_Range_Cond;
@@ -6413,115 +6415,23 @@ package body Checks is
-------------------------
function Get_E_First_Or_Last
- (E : Entity_Id;
+ (Loc : Source_Ptr;
+ E : Entity_Id;
Indx : Nat;
Nam : Name_Id) return Node_Id
is
- N : Node_Id;
- LB : Node_Id;
- HB : Node_Id;
- Bound : Node_Id;
-
+ Exprs : List_Id;
begin
- if Is_Array_Type (E) then
- N := First_Index (E);
-
- for J in 2 .. Indx loop
- Next_Index (N);
- end loop;
-
- else
- N := Scalar_Range (E);
- end if;
-
- if Nkind (N) = N_Subtype_Indication then
- LB := Low_Bound (Range_Expression (Constraint (N)));
- HB := High_Bound (Range_Expression (Constraint (N)));
-
- elsif Is_Entity_Name (N) then
- LB := Type_Low_Bound (Etype (N));
- HB := Type_High_Bound (Etype (N));
-
- else
- LB := Low_Bound (N);
- HB := High_Bound (N);
- end if;
-
- if Nam = Name_First then
- Bound := LB;
+ if Indx > 0 then
+ Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx)));
else
- Bound := HB;
+ Exprs := No_List;
end if;
- if Nkind (Bound) = N_Identifier
- and then Ekind (Entity (Bound)) = E_Discriminant
- then
- -- If this is a task discriminant, and we are the body, we must
- -- retrieve the corresponding body discriminal. This is another
- -- consequence of the early creation of discriminals, and the
- -- need to generate constraint checks before their declarations
- -- are made visible.
-
- if Is_Concurrent_Record_Type (Scope (Entity (Bound))) then
- declare
- Tsk : constant Entity_Id :=
- Corresponding_Concurrent_Type
- (Scope (Entity (Bound)));
- Disc : Entity_Id;
-
- begin
- if In_Open_Scopes (Tsk)
- and then Has_Completion (Tsk)
- then
- -- Find discriminant of original task, and use its
- -- current discriminal, which is the renaming within
- -- the task body.
-
- Disc := First_Discriminant (Tsk);
- while Present (Disc) loop
- if Chars (Disc) = Chars (Entity (Bound)) then
- Set_Scope (Discriminal (Disc), Tsk);
- return New_Occurrence_Of (Discriminal (Disc), Loc);
- end if;
-
- Next_Discriminant (Disc);
- end loop;
-
- -- That loop should always succeed in finding a matching
- -- entry and returning. Fatal error if not.
-
- raise Program_Error;
-
- else
- return
- New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
- end if;
- end;
- else
- return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
- end if;
-
- elsif Nkind (Bound) = N_Identifier
- and then Ekind (Entity (Bound)) = E_In_Parameter
- and then not Inside_Init_Proc
- then
- return Get_Discriminal (E, Bound);
-
- elsif Nkind (Bound) = N_Integer_Literal then
- return Make_Integer_Literal (Loc, Intval (Bound));
-
- -- Case of a bound rewritten to an N_Raise_Constraint_Error node
- -- because it is an out-of-range value. Duplicate_Subexpr cannot be
- -- called on this node because an N_Raise_Constraint_Error is not
- -- side effect free, and we may not assume that we are in the proper
- -- context to remove side effects on it at the point of reference.
-
- elsif Nkind (Bound) = N_Raise_Constraint_Error then
- return New_Copy_Tree (Bound);
-
- else
- return Duplicate_Subexpr_No_Checks (Bound);
- end if;
+ return Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (E, Loc),
+ Attribute_Name => Nam,
+ Expressions => Exprs);
end Get_E_First_Or_Last;
-----------------
@@ -6568,13 +6478,17 @@ package body Checks is
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Lt (Loc,
- Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
- Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
+ Left_Opnd =>
+ Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
+ Right_Opnd =>
+ Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
Right_Opnd =>
Make_Op_Gt (Loc,
- Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
- Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
+ Left_Opnd =>
+ Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
+ Right_Opnd =>
+ Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
end Range_E_Cond;
------------------------
@@ -6591,12 +6505,17 @@ package body Checks is
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Ne (Loc,
- Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
- Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
+ Left_Opnd =>
+ Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
+ Right_Opnd =>
+ Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
+
Right_Opnd =>
Make_Op_Ne (Loc,
- Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
- Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
+ Left_Opnd =>
+ Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
+ Right_Opnd =>
+ Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
end Range_Equal_E_Cond;
------------------
@@ -6613,13 +6532,17 @@ package body Checks is
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Lt (Loc,
- Left_Opnd => Get_N_First (Expr, Indx),
- Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
+ Left_Opnd =>
+ Get_N_First (Expr, Indx),
+ Right_Opnd =>
+ Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
Right_Opnd =>
Make_Op_Gt (Loc,
- Left_Opnd => Get_N_Last (Expr, Indx),
- Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
+ Left_Opnd =>
+ Get_N_Last (Expr, Indx),
+ Right_Opnd =>
+ Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
end Range_N_Cond;
-- Start of processing for Selected_Range_Checks
===================================================================
@@ -3062,6 +3062,37 @@ package body Sem_Util is
Call := Empty;
end Find_Actual;
+ ---------------------------
+ -- Find_Body_Discriminal --
+ ---------------------------
+
+ function Find_Body_Discriminal
+ (Spec_Discriminant : Entity_Id) return Entity_Id
+ is
+ pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
+ Tsk : constant Entity_Id :=
+ Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
+ Disc : Entity_Id;
+ begin
+ -- Find discriminant of original concurrent type, and use its current
+ -- discriminal, which is the renaming within the task/protected body.
+
+ Disc := First_Discriminant (Tsk);
+ while Present (Disc) loop
+ if Chars (Disc) = Chars (Spec_Discriminant) then
+ Set_Scope (Discriminal (Disc), Tsk);
+ return Discriminal (Disc);
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+
+ -- That loop should always succeed in finding a matching entry and
+ -- returning. Fatal error if not.
+
+ raise Program_Error;
+ end Find_Body_Discriminal;
+
-------------------------------------
-- Find_Corresponding_Discriminant --
-------------------------------------
===================================================================
@@ -329,11 +329,11 @@ package Sem_Util is
function Find_Corresponding_Discriminant
(Id : Node_Id;
Typ : Entity_Id) return Entity_Id;
- -- Because discriminants may have different names in a generic unit
- -- and in an instance, they are resolved positionally when possible.
- -- A reference to a discriminant carries the discriminant that it
- -- denotes when analyzed. Subsequent uses of this id on a different
- -- type denote the discriminant at the same position in this new type.
+ -- Because discriminants may have different names in a generic unit and in
+ -- an instance, they are resolved positionally when possible. A reference
+ -- to a discriminant carries the discriminant that it denotes when
+ -- analyzed. Subsequent uses of this id on a different type denotes the
+ -- discriminant at the same position in this new type.
procedure Find_Overlaid_Entity
(N : Node_Id;
@@ -355,6 +355,12 @@ package Sem_Util is
-- Determine the alternative chosen, so that the code of non-selected
-- alternatives, and the warnings that may apply to them, are removed.
+ function Find_Body_Discriminal
+ (Spec_Discriminant : Entity_Id) return Entity_Id;
+ -- Given a discriminant of the record type that implements a task or
+ -- protected type, return the discriminal of the corresponding discriminant
+ -- of the actual concurrent type.
+
function First_Actual (Node : Node_Id) return Node_Id;
-- Node is an N_Function_Call or N_Procedure_Call_Statement node. The
-- result returned is the first actual parameter in declaration order
===================================================================
@@ -5929,7 +5929,8 @@ package body Sem_Res is
and then In_Open_Scopes (Tsk)
and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement
then
- return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
+ return New_Occurrence_Of
+ (Find_Body_Discriminal (Entity (Bound)), Loc);
else
Ref :=
===================================================================
@@ -4811,6 +4811,12 @@ package body Sem_Attr is
-- Computes Aft value for current attribute prefix (used by Aft itself
-- and also by Width for computing the Width of a fixed point type).
+ procedure Check_Concurrent_Discriminant (Bound : Node_Id);
+ -- If Bound is a reference to a discriminant of a task or protected type
+ -- occurring within the object's body, rewrite attribute reference into
+ -- a reference to the corresponding discriminal. Use for the expansion
+ -- of checks against bounds of entry family index subtypes.
+
procedure Check_Expressions;
-- In case where the attribute is not foldable, the expressions, if
-- any, of the attribute, are in a non-static context. This procedure
@@ -4895,6 +4901,33 @@ package body Sem_Attr is
return Result;
end Aft_Value;
+ -----------------------------------
+ -- Check_Concurrent_Discriminant --
+ -----------------------------------
+
+ procedure Check_Concurrent_Discriminant (Bound : Node_Id) is
+ Tsk : Entity_Id;
+ -- The concurrent (task or protected) type
+ begin
+ if Nkind (Bound) = N_Identifier
+ and then Ekind (Entity (Bound)) = E_Discriminant
+ and then Is_Concurrent_Record_Type (Scope (Entity (Bound)))
+ then
+ Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound)));
+ if In_Open_Scopes (Tsk)
+ and then Has_Completion (Tsk)
+ then
+ -- Find discriminant of original concurrent type, and use
+ -- its current discriminal, which is the renaming within
+ -- the task/protected body.
+
+ Rewrite (N,
+ New_Occurrence_Of
+ (Find_Body_Discriminal (Entity (Bound)), Loc));
+ end if;
+ end if;
+ end Check_Concurrent_Discriminant;
+
-----------------------
-- Check_Expressions --
-----------------------
@@ -5982,6 +6015,8 @@ package body Sem_Attr is
else
Fold_Uint (N, Expr_Value (Lo_Bound), Static);
end if;
+ else
+ Check_Concurrent_Discriminant (Lo_Bound);
end if;
end First_Attr;
@@ -6170,6 +6205,8 @@ package body Sem_Attr is
else
Fold_Uint (N, Expr_Value (Hi_Bound), Static);
end if;
+ else
+ Check_Concurrent_Discriminant (Hi_Bound);
end if;
end Last;
This change reorganizes the circuitry involved in the retrieval of the bounds of various ranges for the purpose of generating range checks. This circuitry would previously fail in two different ways: - returning an expression that had changed value since the point where that value was captured for elaboration of a slice; - returning the wrong entity for a bound of an entry family. We know rely on the established general circuitry for bounds retrieval consisting in the expansion of the 'First and 'Last attributes to reliably retrieve these bounds. The following test case must compile cleanly and display "A" when executed: $ gnatmake -q const_slice_with_var_bound $ ./const_slice_with_var_bound A with Ada.Text_IO; use Ada.Text_IO; procedure Const_Slice_With_Var_Bound is type R is record S : String (1 .. 2); L : Integer; end record; type A_R is access all R; procedure P (X : A_R) is Sl : constant String := X.S (X.S'First .. X.L); J : constant Natural := 1; begin X.L := 0; Put_Line (Sl (1 .. J)); end P; My_R : aliased R := ("AB", 2); begin P (My_R'Access); end Const_Slice_With_Var_Bound; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-21 Thomas Quinot <quinot@adacore.com> * sem_ch9.adb, checks.adb, sem_util.adb, sem_util.ads, sem_res.adb, sem_attr.adb (Get_E_First_Or_Last): Use attribute references on E to extract bounds, to ensure that we get the proper captured values, rather than an expression that may have changed value since the point where the subtype was elaborated. (Find_Body_Discriminal): New utility subprogram to share code between... (Eval_Attribute): For the case of a subtype bound that references a discriminant of the current concurrent type, insert appropriate discriminal reference. (Resolve_Entry.Actual_Index_Type.Actual_Discriminant_Ref): For a requeue to an entry in a family in the current task, use corresponding body discriminal. (Analyze_Accept_Statement): Rely on expansion of attribute references to insert proper discriminal references in range check for entry in family.