+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.
+
+2010-06-21 Emmanuel Briot <briot@adacore.com>
+
+ * s-regpat.adb (Compile): Fix handling of big patterns.
+
+2010-06-21 Robert Dewar <dewar@adacore.com>
+
+ * a-tifiio.adb: Minor reformatting.
+
2010-06-21 Pascal Obry <obry@adacore.com>
* prj-nmsc.adb (Search_Directories): Use the non-translated directory
Fore : Integer;
Aft : Field;
Exp : Field);
- -- Actual output function, used internally by all other Put routines
+ -- Actual output function, used internally by all other Put routines.
-- The formal Fore is an Integer, not a Field, because the routine is
-- also called from the version of Put that performs I/O to a string,
-- where the starting position depends on the size of the String, and
-- 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:
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,
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;
-------------------------
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;
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;
-------------------------
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;
-
+ if Indx > 0 then
+ Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx)));
else
- N := Scalar_Range (E);
+ Exprs := No_List;
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;
- else
- Bound := HB;
- 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;
-----------------
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;
------------------------
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;
------------------
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
procedure Link_Operand_Tail (P, Val : Pointer) is
begin
- if Program (P) = BRANCH then
+ if P <= PM.Size and then Program (P) = BRANCH then
Link_Tail (Operand (P), Val);
end if;
end Link_Operand_Tail;
Offset : Pointer;
begin
- if Emit_Ptr > PM.Size then
- return;
- end if;
-
-- Find last node
Scan := P;
- loop
+ while Scan <= PM.Size loop
Temp := Get_Next (Program, Scan);
exit when Temp = Scan;
Scan := Temp;
Link_Tail (IP, Ender);
- if Have_Branch then
+ if Have_Branch and then Emit_Ptr <= PM.Size then
-- Hook the tails of the branches to the closing node
-- 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
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 --
-----------------------
else
Fold_Uint (N, Expr_Value (Lo_Bound), Static);
end if;
+ else
+ Check_Concurrent_Discriminant (Lo_Bound);
end if;
end First_Attr;
else
Fold_Uint (N, Expr_Value (Hi_Bound), Static);
end if;
+ else
+ Check_Concurrent_Discriminant (Hi_Bound);
end if;
end Last;
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;
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;
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
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 :=
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 --
-------------------------------------
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;
-- 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
projects / thirdparty / gcc.git / commitdiff
