diff options
| -rw-r--r-- | gcc/ada/checks.adb | 87 | ||||
| -rw-r--r-- | gcc/ada/checks.ads | 13 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 2 |
4 files changed, 63 insertions, 63 deletions
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 14e82f2..d59d44f 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -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; ----------------------- diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 64f0809..8fd3802 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -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 diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e708ed3..99be96d 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 8e5d351..c684075 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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 |