@@ -2720,15 +2720,20 @@ package body Checks is
---------------------------
procedure Apply_Predicate_Check
- (N : Node_Id;
- Typ : Entity_Id;
- Fun : Entity_Id := Empty)
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Deref : Boolean := False;
+ Fun : Entity_Id := Empty)
is
- Par : Node_Id;
- S : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Check_Disabled : constant Boolean :=
+ not Predicate_Enabled (Typ)
+ or else not Predicate_Check_In_Scope (N);
+
+ Expr : Node_Id;
+ Par : Node_Id;
+ S : Entity_Id;
- Check_Disabled : constant Boolean := not Predicate_Enabled (Typ)
- or else not Predicate_Check_In_Scope (N);
begin
S := Current_Scope;
while Present (S) and then not Is_Subprogram (S) loop
@@ -2757,7 +2762,7 @@ package body Checks is
if not Check_Disabled then
Insert_Action (N,
- Make_Raise_Storage_Error (Sloc (N),
+ Make_Raise_Storage_Error (Loc,
Reason => SE_Infinite_Recursion));
return;
end if;
@@ -2824,19 +2829,9 @@ package body Checks is
Par := Parent (Par);
end if;
- -- For an entity of the type, generate a call to the predicate
- -- function, unless its type is an actual subtype, which is not
- -- visible outside of the enclosing subprogram.
-
- if Is_Entity_Name (N)
- and then not Is_Actual_Subtype (Typ)
- then
- Insert_Action (N,
- Make_Predicate_Check
- (Typ, New_Occurrence_Of (Entity (N), Sloc (N))));
- return;
+ -- Try to avoid creating a temporary if the expression is an aggregate
- elsif Nkind (N) in N_Aggregate | N_Extension_Aggregate then
+ if Nkind (N) in N_Aggregate | N_Extension_Aggregate then
-- If the expression is an aggregate in an assignment, apply the
-- check to the LHS after the assignment, rather than create a
@@ -2851,27 +2846,6 @@ package body Checks is
(Typ, Duplicate_Subexpr (Name (Par))));
return;
- -- Similarly, if the expression is a qualified aggregate in an
- -- allocator, apply the check to the dereference of the access
- -- value, rather than create a temporary. This is necessary for
- -- inherently limited types, for which the temporary is illegal.
-
- elsif Nkind (Par) = N_Allocator then
- declare
- Deref : constant Node_Id :=
- Make_Explicit_Dereference (Sloc (N),
- Prefix => Duplicate_Subexpr (Par));
-
- begin
- -- This is required by Predicate_Check_In_Scope ???
-
- Preserve_Comes_From_Source (Deref, N);
-
- Insert_Action_After (Parent (Par),
- Make_Predicate_Check (Typ, Deref));
- return;
- end;
-
-- Similarly, if the expression is an aggregate in an object
-- declaration, apply it to the object after the declaration.
@@ -2892,21 +2866,36 @@ package body Checks is
then
Insert_Action_After (Par,
Make_Predicate_Check (Typ,
- New_Occurrence_Of (Defining_Identifier (Par), Sloc (N))));
+ New_Occurrence_Of (Defining_Identifier (Par), Loc)));
return;
end if;
end if;
end if;
- -- If the expression is not an entity it may have side effects,
- -- and the following call will create an object declaration for
- -- it. We disable checks during its analysis, to prevent an
- -- infinite recursion.
+ -- For an entity of the type, generate a call to the predicate
+ -- function, unless its type is an actual subtype, which is not
+ -- visible outside of the enclosing subprogram.
- Insert_Action (N,
- Make_Predicate_Check
- (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks);
+ if Is_Entity_Name (N) and then not Is_Actual_Subtype (Typ) then
+ Expr := New_Occurrence_Of (Entity (N), Loc);
+
+ -- If the expression is not an entity, it may have side effects
+
+ else
+ Expr := Duplicate_Subexpr (N);
+ end if;
+
+ -- Make the dereference if requested
+
+ if Deref then
+ Expr := Make_Explicit_Dereference (Loc, Prefix => Expr);
+ end if;
+
+ -- Disable checks to prevent an infinite recursion
+
+ Insert_Action
+ (N, Make_Predicate_Check (Typ, Expr), Suppress => All_Checks);
end Apply_Predicate_Check;
-----------------------
@@ -256,13 +256,14 @@ package Checks is
-- results.
procedure Apply_Predicate_Check
- (N : Node_Id;
- Typ : Entity_Id;
- Fun : Entity_Id := Empty);
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Deref : Boolean := False;
+ Fun : Entity_Id := Empty);
-- N is an expression to which a predicate check may need to be applied for
- -- Typ, if Typ has a predicate function. When N is an actual in a call, Fun
- -- is the function being called, which is used to generate a better warning
- -- if the call leads to an infinite recursion.
+ -- Typ if Typ has a predicate function, after dereference if Deref is True.
+ -- When N is an actual in a call, Fun is the function being called, which
+ -- is used to generate a warning if the call leads to infinite recursion.
procedure Apply_Type_Conversion_Checks (N : Node_Id);
-- N is an N_Type_Conversion node. A type conversion actually involves
@@ -563,8 +563,6 @@ package body Exp_Ch4 is
DesigT : constant Entity_Id := Designated_Type (PtrT);
Special_Return : constant Boolean := For_Special_Return_Object (N);
- -- Local variables
-
Adj_Call : Node_Id;
Aggr_In_Place : Boolean;
Node : Node_Id;
@@ -577,8 +575,6 @@ package body Exp_Ch4 is
TagR : Node_Id := Empty;
-- Target reference for tag assignment
- -- Start of processing for Expand_Allocator_Expression
-
begin
-- Handle call to C++ constructor
@@ -598,7 +594,15 @@ package body Exp_Ch4 is
Apply_Constraint_Check (Exp, T, No_Sliding => True);
- Apply_Predicate_Check (Exp, T);
+ Aggr_In_Place := Is_Delayed_Aggregate (Exp);
+
+ -- If the expression is an aggregate to be built in place, then we need
+ -- to delay applying predicate checks, because this would result in the
+ -- creation of a temporary, which is illegal for limited types,
+
+ if not Aggr_In_Place then
+ Apply_Predicate_Check (Exp, T);
+ end if;
-- Check that any anonymous access discriminants are suitable
-- for use in an allocator.
@@ -659,8 +663,6 @@ package body Exp_Ch4 is
return;
end if;
- Aggr_In_Place := Is_Delayed_Aggregate (Exp);
-
-- Case of tagged type or type requiring finalization
if Is_Tagged_Type (T) or else Needs_Finalization (T) then
@@ -972,6 +974,10 @@ package body Exp_Ch4 is
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
+ if Aggr_In_Place then
+ Apply_Predicate_Check (N, T, Deref => True);
+ end if;
+
-- Ada 2005 (AI-251): Displace the pointer to reference the record
-- component containing the secondary dispatch table of the interface
-- type.
@@ -1012,6 +1018,10 @@ package body Exp_Ch4 is
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
+ if Aggr_In_Place then
+ Apply_Predicate_Check (N, T, Deref => True);
+ end if;
+
elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then
Install_Null_Excluding_Check (Exp);
@@ -4735,7 +4735,7 @@ package body Sem_Res is
-- leads to an infinite recursion.
if Predicate_Tests_On_Arguments (Nam) then
- Apply_Predicate_Check (A, F_Typ, Nam);
+ Apply_Predicate_Check (A, F_Typ, Fun => Nam);
end if;
-- Apply required constraint checks