From: Steve Baird Date: Tue, 5 Apr 2022 00:52:11 +0000 (-0700) Subject: [Ada] Fix bug in handling of Predicate_Failure aspect X-Git-Tag: basepoints/gcc-14~6559 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=55a11c7e345dd06d6975fe8f4dc0e11ecbb581ff;p=thirdparty%2Fgcc.git [Ada] Fix bug in handling of Predicate_Failure aspect The run-time behavior of the Ada 2022 Predicate_Failure aspect was incorrectly implemented. This could cause incorrect exception messages at execution time in the case of a predicate check failure, as demonstrated by ACATS test C324006. In addition, a new attribute (Predicate_Expression) is defined in order to improve the FE/SPARK interface. gcc/ada/ * einfo-utils.ads, einfo-utils.adb: Delete Predicate_Function_M function and Set_Predicate_Function_M procedure. * einfo.ads: Delete comments for Is_Predicate_Function_M and Predicate_Function_M functions. Add comment for new Predicate_Expression function. Update comment describing predicate functions. * exp_util.ads, exp_util.adb (Make_Predicate_Call): Replace Mem formal parameter with Static_Mem and Dynamic_Mem formals. (Make_Predicate_Check): Delete Add_Failure_Expression and call to it. * exp_ch4.adb (Expand_N_In.Predicate_Check): Update Make_Predicate_Call call to match profile change. * gen_il-fields.ads: Delete Is_Predicate_Function_M field, add Predicate_Expression field. * gen_il-gen-gen_entities.adb: Delete Is_Predicate_Function_M use, add Predicate_Expression use. * sem_ch13.adb (Build_Predicate_Functions): Rename as singular, not plural; we no longer build a Predicate_M function. Delete Predicate_M references. Add new Boolean parameter for predicate functions when needed. Restructure body of generated predicate functions to implement required Predicate_Failure behavior and to set new Predicate_Expression attribute. Remove special treatment of raise expressions within predicate expressions. * sem_util.ads (Predicate_Failure_Expression, Predicate_Function_Needs_Membership_Parameter): New functions. * sem_util.adb (Is_Current_Instance): Fix bugs which caused wrong result. (Is_Current_Instance_Reference_In_Type_Aspect): Delete Is_Predicate_Function_M reference. (Predicate_Failure_Expression): New function. (Propagate_Predicate_Attributes): Delete Is_Predicate_Function_M references. --- diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index cf61ec7de28..48a1bce817d 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -2390,53 +2390,6 @@ package body Einfo.Utils is return Empty; end Predicate_Function; - -------------------------- - -- Predicate_Function_M -- - -------------------------- - - function Predicate_Function_M (Id : E) return E is - Subp_Elmt : Elmt_Id; - Subp_Id : Entity_Id; - Subps : Elist_Id; - Typ : Entity_Id; - - begin - pragma Assert (Is_Type (Id)); - - -- If type is private and has a completion, predicate may be defined on - -- the full view. - - if Is_Private_Type (Id) - and then - (not Has_Predicates (Id) or else No (Subprograms_For_Type (Id))) - and then Present (Full_View (Id)) - then - Typ := Full_View (Id); - - else - Typ := Id; - end if; - - Subps := Subprograms_For_Type (Typ); - - if Present (Subps) then - Subp_Elmt := First_Elmt (Subps); - while Present (Subp_Elmt) loop - Subp_Id := Node (Subp_Elmt); - - if Ekind (Subp_Id) = E_Function - and then Is_Predicate_Function_M (Subp_Id) - then - return Subp_Id; - end if; - - Next_Elmt (Subp_Elmt); - end loop; - end if; - - return Empty; - end Predicate_Function_M; - ------------------------- -- Present_In_Rep_Item -- ------------------------- @@ -2879,43 +2832,6 @@ package body Einfo.Utils is end loop; end Set_Predicate_Function; - ------------------------------ - -- Set_Predicate_Function_M -- - ------------------------------ - - procedure Set_Predicate_Function_M (Id : E; V : E) is - Subp_Elmt : Elmt_Id; - Subp_Id : Entity_Id; - Subps : Elist_Id; - - begin - pragma Assert (Is_Type (Id) and then Has_Predicates (Id)); - - Subps := Subprograms_For_Type (Id); - - if No (Subps) then - Subps := New_Elmt_List; - Set_Subprograms_For_Type (Id, Subps); - end if; - - Subp_Elmt := First_Elmt (Subps); - Prepend_Elmt (V, Subps); - - -- Check for a duplicate predication function - - while Present (Subp_Elmt) loop - Subp_Id := Node (Subp_Elmt); - - if Ekind (Subp_Id) = E_Function - and then Is_Predicate_Function_M (Subp_Id) - then - raise Program_Error; - end if; - - Next_Elmt (Subp_Elmt); - end loop; - end Set_Predicate_Function_M; - ----------------- -- Size_Clause -- ----------------- diff --git a/gcc/ada/einfo-utils.ads b/gcc/ada/einfo-utils.ads index f914de7cc83..d830c8da259 100644 --- a/gcc/ada/einfo-utils.ads +++ b/gcc/ada/einfo-utils.ads @@ -437,14 +437,12 @@ package Einfo.Utils is function Invariant_Procedure (Id : E) return E; function Partial_Invariant_Procedure (Id : E) return E; function Predicate_Function (Id : E) return E; - function Predicate_Function_M (Id : E) return E; procedure Set_DIC_Procedure (Id : E; V : E); procedure Set_Partial_DIC_Procedure (Id : E; V : E); procedure Set_Invariant_Procedure (Id : E; V : E); procedure Set_Partial_Invariant_Procedure (Id : E; V : E); procedure Set_Predicate_Function (Id : E; V : E); - procedure Set_Predicate_Function_M (Id : E; V : E); --------------- -- Iterators -- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 3f990c3b831..b0601a9648d 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3106,11 +3106,6 @@ package Einfo is -- Present in functions and procedures. Set for generated predicate -- functions. --- Is_Predicate_Function_M --- Present in functions and procedures. Set for special version of --- predicate function generated for use in membership tests, where --- raise expressions are transformed to return False. - -- Is_Preelaborated -- Defined in all entities, set in E_Package and E_Generic_Package -- entities to which a pragma Preelaborate is applied, and also in @@ -4010,8 +4005,9 @@ package Einfo is -- Defined in all types. Set for types for which (Has_Predicates is True) -- and for which a predicate procedure has been built that tests that the -- specified predicates are True. Contains the entity for the function --- which takes a single argument of the given type, and returns True if --- the predicate holds and False if it does not. +-- which takes a single argument of the given type (and sometimes an +-- additional Boolean parameter), and returns True if the predicate +-- holds and False if it does not. -- -- Note: flag Has_Predicate does not imply that Predicate_Function is set -- to a non-empty entity; this happens, for example, for itypes created @@ -4024,11 +4020,14 @@ package Einfo is -- Note: the reason this is marked as a synthesized attribute is that the -- way this is stored is as an element of the Subprograms_For_Type field. --- Predicate_Function_M (synthesized) --- Defined in all types. Present only if Predicate_Function is present, --- and only if the predicate function has Raise_Expression nodes. It --- is the special version created for membership tests, where if one of --- these raise expressions is executed, the result is to return False. +-- Predicate_Expression +-- Defined on functions. For the defining identifier of the subprogram +-- declaration (not of the subprogram body) of a predicate function, +-- yields the expression for the noninherited portion of the given +-- predicate (except in the case where the inherited portion is +-- non-empty and the non-inherited portion is empty, in which case the +-- expression for the inherited portion is returned). Otherwise yields +-- empty. -- Predicated_Parent -- Defined on itypes created by subtype indications, when the parent @@ -5115,7 +5114,6 @@ package Einfo is -- Partial_DIC_Procedure (synth) -- Partial_Invariant_Procedure (synth) -- Predicate_Function (synth) - -- Predicate_Function_M (synth) -- Root_Type (synth) -- Size_Clause (synth) @@ -5591,7 +5589,6 @@ package Einfo is -- Is_Machine_Code_Subprogram (non-generic case only) -- Is_Partial_Invariant_Procedure (non-generic case only) -- Is_Predicate_Function (non-generic case only) - -- Is_Predicate_Function_M (non-generic case only) -- Is_Primitive -- Is_Primitive_Wrapper (non-generic case only) -- Is_Private_Descendant @@ -5956,7 +5953,6 @@ package Einfo is -- Is_Partial_DIC_Procedure (synth) (non-generic case only) -- Is_Partial_Invariant_Procedure (non-generic case only) -- Is_Predicate_Function (non-generic case only) - -- Is_Predicate_Function_M (non-generic case only) -- Is_Primitive -- Is_Primitive_Wrapper (non-generic case only) -- Is_Private_Descendant diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 14e9b0e508e..9e86b4d81a5 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6962,7 +6962,9 @@ package body Exp_Ch4 is and then Nkind (Rop) /= N_Range then if not In_Range_Check then - R_Op := Make_Predicate_Call (Rtyp, Lop, Mem => True); + -- Indicate via Static_Mem parameter that this predicate + -- evaluation is for a membership test. + R_Op := Make_Predicate_Call (Rtyp, Lop, Static_Mem => True); else R_Op := New_Occurrence_Of (Standard_True, Loc); end if; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 31a2d5c3165..290c3805627 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -9927,9 +9927,10 @@ package body Exp_Util is -- Ghost mode. function Make_Predicate_Call - (Typ : Entity_Id; - Expr : Node_Id; - Mem : Boolean := False) return Node_Id + (Typ : Entity_Id; + Expr : Node_Id; + Static_Mem : Boolean := False; + Dynamic_Mem : Node_Id := Empty) return Node_Id is Loc : constant Source_Ptr := Sloc (Expr); @@ -9937,9 +9938,9 @@ package body Exp_Util is Saved_IGR : constant Node_Id := Ignored_Ghost_Region; -- Save the Ghost-related attributes to restore on exit - Call : Node_Id; - Func_Id : Entity_Id; - + Call : Node_Id; + Func_Id : Entity_Id; + Param_Assocs : List_Id; begin Func_Id := Predicate_Function (Typ); pragma Assert (Present (Func_Id)); @@ -9949,12 +9950,6 @@ package body Exp_Util is Set_Ghost_Mode (Typ); - -- Call special membership version if requested and available - - if Mem and then Present (Predicate_Function_M (Typ)) then - Func_Id := Predicate_Function_M (Typ); - end if; - -- Case of calling normal predicate function -- If the type is tagged, the expression may be class-wide, in which @@ -9964,18 +9959,26 @@ package body Exp_Util is -- extensions are involved. if Is_Tagged_Type (Typ) then - Call := - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Func_Id, Loc), - Parameter_Associations => - New_List (OK_Convert_To (Typ, Relocate_Node (Expr)))); + Param_Assocs := New_List (OK_Convert_To (Typ, Relocate_Node (Expr))); else - Call := - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Func_Id, Loc), - Parameter_Associations => New_List (Relocate_Node (Expr))); + Param_Assocs := New_List (Relocate_Node (Expr)); end if; + if Predicate_Function_Needs_Membership_Parameter (Typ) then + -- Pass in parameter indicating whether this call is for a + -- membership test. + Append ((if Present (Dynamic_Mem) + then Dynamic_Mem + else New_Occurrence_Of + (Boolean_Literals (Static_Mem), Loc)), + Param_Assocs); + end if; + + Call := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Func_Id, Loc), + Parameter_Associations => Param_Assocs); + Restore_Ghost_Region (Saved_GM, Saved_IGR); return Call; @@ -9991,161 +9994,6 @@ package body Exp_Util is is Loc : constant Source_Ptr := Sloc (Expr); - procedure Add_Failure_Expression (Args : List_Id); - -- Add the failure expression of pragma Predicate_Failure (if any) to - -- list Args. - - ---------------------------- - -- Add_Failure_Expression -- - ---------------------------- - - procedure Add_Failure_Expression (Args : List_Id) is - function Failure_Expression return Node_Id; - pragma Inline (Failure_Expression); - -- Find aspect or pragma Predicate_Failure that applies to type Typ - -- and return its expression. Return Empty if no such annotation is - -- available. - - function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean; - pragma Inline (Is_OK_PF_Aspect); - -- Determine whether aspect Asp is a suitable Predicate_Failure - -- aspect that applies to type Typ. - - function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean; - pragma Inline (Is_OK_PF_Pragma); - -- Determine whether pragma Prag is a suitable Predicate_Failure - -- pragma that applies to type Typ. - - procedure Replace_Subtype_Reference (N : Node_Id); - -- Replace the current instance of type Typ denoted by N with - -- expression Expr. - - ------------------------ - -- Failure_Expression -- - ------------------------ - - function Failure_Expression return Node_Id is - Item : Node_Id; - - begin - -- The management of the rep item chain involves "inheritance" of - -- parent type chains. If a parent [sub]type is already subject to - -- pragma Predicate_Failure, then the pragma will also appear in - -- the chain of the child [sub]type, which in turn may possess a - -- pragma of its own. Avoid order-dependent issues by inspecting - -- the rep item chain directly. Note that routine Get_Pragma may - -- return a parent pragma. - - Item := First_Rep_Item (Typ); - while Present (Item) loop - - -- Predicate_Failure appears as an aspect - - if Nkind (Item) = N_Aspect_Specification - and then Is_OK_PF_Aspect (Item) - then - return Expression (Item); - - -- Predicate_Failure appears as a pragma - - elsif Nkind (Item) = N_Pragma - and then Is_OK_PF_Pragma (Item) - then - return - Get_Pragma_Arg - (Next (First (Pragma_Argument_Associations (Item)))); - end if; - - Next_Rep_Item (Item); - end loop; - - return Empty; - end Failure_Expression; - - --------------------- - -- Is_OK_PF_Aspect -- - --------------------- - - function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean is - begin - -- To qualify, the aspect must apply to the type subjected to the - -- predicate check. - - return - Chars (Identifier (Asp)) = Name_Predicate_Failure - and then Present (Entity (Asp)) - and then Entity (Asp) = Typ; - end Is_OK_PF_Aspect; - - --------------------- - -- Is_OK_PF_Pragma -- - --------------------- - - function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean is - Args : constant List_Id := Pragma_Argument_Associations (Prag); - Typ_Arg : Node_Id; - - begin - -- Nothing to do when the pragma does not denote Predicate_Failure - - if Pragma_Name (Prag) /= Name_Predicate_Failure then - return False; - - -- Nothing to do when the pragma lacks arguments, in which case it - -- is illegal. - - elsif Is_Empty_List (Args) then - return False; - end if; - - Typ_Arg := Get_Pragma_Arg (First (Args)); - - -- To qualify, the local name argument of the pragma must denote - -- the type subjected to the predicate check. - - return - Is_Entity_Name (Typ_Arg) - and then Present (Entity (Typ_Arg)) - and then Entity (Typ_Arg) = Typ; - end Is_OK_PF_Pragma; - - -------------------------------- - -- Replace_Subtype_Reference -- - -------------------------------- - - procedure Replace_Subtype_Reference (N : Node_Id) is - begin - Rewrite (N, New_Copy_Tree (Expr)); - end Replace_Subtype_Reference; - - procedure Replace_Subtype_References is - new Replace_Type_References_Generic (Replace_Subtype_Reference); - - -- Local variables - - PF_Expr : constant Node_Id := Failure_Expression; - Expr : Node_Id; - - -- Start of processing for Add_Failure_Expression - - begin - if Present (PF_Expr) then - - -- Replace any occurrences of the current instance of the type - -- with the object subjected to the predicate check. - - Expr := New_Copy_Tree (PF_Expr); - Replace_Subtype_References (Expr, Typ); - - -- The failure expression appears as the third argument of the - -- Check pragma. - - Append_To (Args, - Make_Pragma_Argument_Association (Loc, - Expression => Expr)); - end if; - end Add_Failure_Expression; - -- Local variables Args : List_Id; @@ -10188,8 +10036,6 @@ package body Exp_Util is -- If the subtype is subject to pragma Predicate_Failure, add the -- failure expression as an additional parameter. - Add_Failure_Expression (Args); - return Make_Pragma (Loc, Chars => Name_Check, @@ -14339,7 +14185,6 @@ package body Exp_Util is elsif Get_TSS_Name (S) /= TSS_Null and then not Is_Predicate_Function (S) - and then not Is_Predicate_Function_M (S) then return False; end if; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index f3456b3f455..464f66f7420 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -876,13 +876,19 @@ package Exp_Util is -- expression Expr. Expr is passed as an actual parameter in the call. function Make_Predicate_Call - (Typ : Entity_Id; - Expr : Node_Id; - Mem : Boolean := False) return Node_Id; + (Typ : Entity_Id; + Expr : Node_Id; + Static_Mem : Boolean := False; + Dynamic_Mem : Node_Id := Empty) return Node_Id; -- Typ is a type with Predicate_Function set. This routine builds a call to -- this function passing Expr as the argument, and returns it unanalyzed. - -- If Mem is set True, this is the special call for the membership case, - -- and the function called is the Predicate_Function_M if present. + -- If the callee takes a second parameter (as determined by + -- Sem_Util.Predicate_Function_Needs_Membership_Parameter), then the + -- actual parameter is determined by the two Mem parameters. + -- If Dynamic_Mem is nonempty, then Dynamic_Mem is the actual parameter. + -- Otherwise, the value of the Static_Mem parameter is passed in as + -- a Boolean literal. It is an error if Dynamic_Mem is nonempty but + -- the callee does not take a second parameter. function Make_Predicate_Check (Typ : Entity_Id; diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index eedae64ed33..878755bf34e 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -756,7 +756,6 @@ package Gen_IL.Fields is Is_Partial_Invariant_Procedure, Is_Potentially_Use_Visible, Is_Predicate_Function, - Is_Predicate_Function_M, Is_Preelaborated, Is_Primitive, Is_Primitive_Wrapper, @@ -851,6 +850,7 @@ package Gen_IL.Fields is Partial_View_Has_Unknown_Discr, Pending_Access_Types, Postconditions_Proc, + Predicate_Expression, Prev_Entity, Prival, Prival_Link, diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 5b8603b85b0..89d86594c52 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -1031,7 +1031,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Invariant_Procedure, Flag), Sm (Is_Partial_Invariant_Procedure, Flag), Sm (Is_Predicate_Function, Flag), - Sm (Is_Predicate_Function_M, Flag), Sm (Is_Primitive_Wrapper, Flag), Sm (Is_Private_Primitive, Flag), Sm (LSP_Subprogram, Node_Id), @@ -1039,6 +1038,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Next_Inlined_Subprogram, Node_Id), Sm (Original_Protected_Subprogram, Node_Id), Sm (Postconditions_Proc, Node_Id), + Sm (Predicate_Expression, Node_Id), Sm (Protected_Subprogram, Node_Id), Sm (Protection_Object, Node_Id), Sm (Related_Expression, Node_Id), @@ -1080,7 +1080,6 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Null_Init_Proc, Flag), Sm (Is_Partial_Invariant_Procedure, Flag), Sm (Is_Predicate_Function, Flag), - Sm (Is_Predicate_Function_M, Flag), Sm (Is_Primitive_Wrapper, Flag), Sm (Is_Private_Primitive, Flag), Sm (Is_Valued_Procedure, Flag), diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 8bd0c866fd4..54f32a2fc49 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -133,7 +133,7 @@ package body Sem_Ch13 is -- may be before the freeze point of the type. The predicate expression is -- preanalyzed at this point, to catch visibility errors. - procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id); + procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id); -- If Typ has predicates (indicated by Has_Predicates being set for Typ), -- then either there are pragma Predicate entries on the rep chain for the -- type (note that Predicate aspects are converted to pragma Predicate), or @@ -141,9 +141,7 @@ package body Sem_Ch13 is -- This procedure builds body for the Predicate function that tests these -- predicates. N is the freeze node for the type. The spec of the function -- is inserted before the freeze node, and the body of the function is - -- inserted after the freeze node. If the predicate expression has a least - -- one Raise_Expression, then this procedure also builds the M version of - -- the predicate function for use in membership tests. + -- inserted after the freeze node. procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id); -- Called if both Storage_Pool and Storage_Size attribute definition @@ -9462,10 +9460,7 @@ package body Sem_Ch13 is declare Ent : constant Entity_Id := Entity (Name (Exp)); begin - if Is_Predicate_Function (Ent) - or else - Is_Predicate_Function_M (Ent) - then + if Is_Predicate_Function (Ent) then return Stat_Pred (Etype (First_Formal (Ent)), Static); end if; end; @@ -10006,11 +10001,11 @@ package body Sem_Ch13 is return Prag; end Build_Export_Import_Pragma; - ------------------------------- - -- Build_Predicate_Functions -- - ------------------------------- + ------------------------------ + -- Build_Predicate_Function -- + ------------------------------ - -- The functions that are constructed here have the form: + -- The function constructed here has the form: -- function typPredicate (Ixxx : typ) return Boolean is -- begin @@ -10021,6 +10016,18 @@ package body Sem_Ch13 is -- and then exp1 and then exp2 and then ...; -- end typPredicate; + -- If Predicate_Function_Needs_Membership_Parameter is true, then this + -- function takes an additional boolean parameter; the parameter + -- indicates whether the predicate evaluation is part of a membership + -- test. This parameter is used in two cases: 1) It is passed along + -- if another predicate function is called and that predicate function + -- expects to be passed a boolean parameter. 2) If the Predicate_Failure + -- aspect is directly specified for typ, then we replace the return + -- expression described above with + -- (if then True + -- elsif For_Membership_Test then False + -- else (raise Assertion_Error + -- with )) -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that -- this is the point at which these expressions get analyzed, providing the -- required delay, and typ1, typ2, are entities from which predicates are @@ -10033,26 +10040,17 @@ package body Sem_Ch13 is -- Note that Sem_Eval.Real_Or_String_Static_Predicate_Matches depends on -- the form of this return expression. - -- If the expression has at least one Raise_Expression, then we also build - -- the typPredicateM version of the function, in which any occurrence of a - -- Raise_Expression is converted to "return False". - -- WARNING: This routine manages Ghost regions. Return statements must be -- replaced by gotos which jump to the end of the routine and restore the -- Ghost mode. - procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is + procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is Loc : constant Source_Ptr := Sloc (Typ); Expr : Node_Id; -- This is the expression for the result of the function. It is -- is build by connecting the component predicates with AND THEN. - Expr_M : Node_Id := Empty; -- init to avoid warning - -- This is the corresponding return expression for the Predicate_M - -- function. It differs in that raise expressions are marked for - -- special expansion (see Process_REs). - Object_Name : Name_Id; -- Name for argument of Predicate procedure. Note that we use the same -- name for both predicate functions. That way the reference within the @@ -10061,18 +10059,15 @@ package body Sem_Ch13 is Object_Entity : Entity_Id; -- Entity for argument of Predicate procedure - Object_Entity_M : Entity_Id; - -- Entity for argument of separate Predicate procedure when exceptions - -- are present in expression. - FDecl : Node_Id; -- The function declaration SId : Entity_Id; -- Its entity - Raise_Expression_Present : Boolean := False; - -- Set True if Expr has at least one Raise_Expression + Ancestor_Predicate_Function_Called : Boolean := False; + -- Does this predicate function include a call to the + -- predication function of an ancestor subtype? procedure Add_Condition (Cond : Node_Id); -- Append Cond to Expr using "and then" (or just copy Cond to Expr if @@ -10088,19 +10083,11 @@ package body Sem_Ch13 is -- Includes a call to the predicate function for type T in Expr if -- Predicate_Function (T) is non-empty. - function Process_RE (N : Node_Id) return Traverse_Result; - -- Used in Process REs, tests if node N is a raise expression, and if - -- so, marks it to be converted to return False. - - procedure Process_REs is new Traverse_Proc (Process_RE); - -- Marks any raise expressions in Expr_M to return False - - function Test_RE (N : Node_Id) return Traverse_Result; - -- Used in Test_REs, tests one node for being a raise expression, and if - -- so sets Raise_Expression_Present True. - - procedure Test_REs is new Traverse_Proc (Test_RE); - -- Tests to see if Expr contains any raise expressions + procedure Replace_Current_Instance_References + (N : Node_Id; Typ, New_Entity : Entity_Id); + -- Replace all references to Typ in the tree rooted at N with + -- references to Param. [New_Entity will be a formal parameter of a + -- predicate function.] -------------- -- Add_Call -- @@ -10116,16 +10103,34 @@ package body Sem_Ch13 is -- Build the call to the predicate function of T. The type may be -- derived, so use an unchecked conversion for the actual. - Exp := - Make_Predicate_Call - (Typ => T, - Expr => - Unchecked_Convert_To (T, - Make_Identifier (Loc, Object_Name))); + declare + Dynamic_Mem : Node_Id := Empty; + Second_Formal : constant Entity_Id := + Next_Entity (Object_Entity); + begin + -- Some predicate functions require a second parameter; + -- If one predicate function calls another and the second + -- requires two parameters, then the first should also + -- take two parameters (so that the first function has + -- something to pass to the second function). + if Predicate_Function_Needs_Membership_Parameter (T) then + pragma Assert (Present (Second_Formal)); + Dynamic_Mem := New_Occurrence_Of (Second_Formal, Loc); + end if; + + Exp := + Make_Predicate_Call + (Typ => T, + Expr => + Unchecked_Convert_To (T, + Make_Identifier (Loc, Object_Name)), + Dynamic_Mem => Dynamic_Mem); + end; -- "and"-in the call to evolving expression Add_Condition (Exp); + Ancestor_Predicate_Function_Called := True; -- Output info message on inheritance if required. Note we do not -- give this information for generic actual types, since it is @@ -10182,32 +10187,6 @@ package body Sem_Ch13 is ------------------- procedure Add_Predicate (Prag : Node_Id) is - procedure Replace_Type_Reference (N : Node_Id); - -- Replace a single occurrence N of the subtype name with a - -- reference to the formal of the predicate function. N can be an - -- identifier referencing the subtype, or a selected component, - -- representing an appropriately qualified occurrence of the - -- subtype name. - - procedure Replace_Type_References is - new Replace_Type_References_Generic (Replace_Type_Reference); - -- Traverse an expression changing every occurrence of an - -- identifier whose name matches the name of the subtype with a - -- reference to the formal parameter of the predicate function. - - ---------------------------- - -- Replace_Type_Reference -- - ---------------------------- - - procedure Replace_Type_Reference (N : Node_Id) is - begin - Rewrite (N, Make_Identifier (Sloc (N), Object_Name)); - -- Use the Sloc of the usage name, not the defining name - - Set_Etype (N, Typ); - Set_Entity (N, Object_Entity); - end Replace_Type_Reference; - -- Local variables Asp : constant Node_Id := Corresponding_Aspect (Prag); @@ -10236,20 +10215,25 @@ package body Sem_Ch13 is if Entity (Arg1) = Typ or else Full_View (Entity (Arg1)) = Typ then - Replace_Type_References (Arg2, Typ); + declare + Arg2_Copy : constant Node_Id := New_Copy_Tree (Arg2); + begin + Replace_Current_Instance_References + (Arg2_Copy, Typ => Typ, New_Entity => Object_Entity); - -- If the predicate pragma comes from an aspect, replace the - -- saved expression because we need the subtype references - -- replaced for the calls to Preanalyze_Spec_Expression in - -- Check_Aspect_At_xxx routines. + -- If the predicate pragma comes from an aspect, replace the + -- saved expression because we need the subtype references + -- replaced for the calls to Preanalyze_Spec_Expression in + -- Check_Aspect_At_xxx routines. - if Present (Asp) then - Set_Entity (Identifier (Asp), New_Copy_Tree (Arg2)); - end if; + if Present (Asp) then + Set_Entity (Identifier (Asp), New_Copy_Tree (Arg2_Copy)); + end if; - -- "and"-in the Arg2 condition to evolving expression + -- "and"-in the Arg2 condition to evolving expression - Add_Condition (Relocate_Node (Arg2)); + Add_Condition (Arg2_Copy); + end; end if; end Add_Predicate; @@ -10303,33 +10287,34 @@ package body Sem_Ch13 is end loop; end Add_Predicates; - ---------------- - -- Process_RE -- - ---------------- + ----------------------------------------- + -- Replace_Current_Instance_References -- + ----------------------------------------- - function Process_RE (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Raise_Expression then - Set_Convert_To_Return_False (N); - return Skip; - else - return OK; - end if; - end Process_RE; + procedure Replace_Current_Instance_References + (N : Node_Id; Typ, New_Entity : Entity_Id) + is + Root : Node_Id renames N; - ------------- - -- Test_RE -- - ------------- + procedure Replace_One_Reference (N : Node_Id); + -- Actual parameter for Replace_Type_References_Generic instance - function Test_RE (N : Node_Id) return Traverse_Result is + --------------------------- + -- Replace_One_Reference -- + --------------------------- + + procedure Replace_One_Reference (N : Node_Id) is + pragma Assert (In_Subtree (N, Root => Root)); + begin + Rewrite (N, New_Occurrence_Of (New_Entity, Sloc (N))); + -- Use the Sloc of the usage name, not the defining name + end Replace_One_Reference; + + procedure Replace_Type_References is + new Replace_Type_References_Generic (Replace_One_Reference); begin - if Nkind (N) = N_Raise_Expression then - Raise_Expression_Present := True; - return Abandon; - else - return OK; - end if; - end Test_RE; + Replace_Type_References (N, Typ); + end Replace_Current_Instance_References; -- Local variables @@ -10337,7 +10322,7 @@ package body Sem_Ch13 is Saved_IGR : constant Node_Id := Ignored_Ghost_Region; -- Save the Ghost-related attributes to restore on exit - -- Start of processing for Build_Predicate_Functions + -- Start of processing for Build_Predicate_Function begin -- Return if already built, if type does not have predicates, @@ -10399,8 +10384,7 @@ package body Sem_Ch13 is Defining_Identifier (First (Parameter_Specifications (Specification (FDecl)))); - Object_Name := Chars (Object_Entity); - Object_Entity_M := Make_Defining_Identifier (Loc, Chars => Object_Name); + Object_Name := Chars (Object_Entity); -- Add predicates for ancestor if present. These must come before the -- ones for the current type, as required by AI12-0071-1. @@ -10432,25 +10416,6 @@ package body Sem_Ch13 is if Present (Expr) then - -- Test for raise expression present - - Test_REs (Expr); - - -- If raise expression is present, capture a copy of Expr for use - -- in building the predicateM function version later on. For this - -- copy we replace references to Object_Entity by Object_Entity_M. - - if Raise_Expression_Present then - declare - Map : constant Elist_Id := New_Elmt_List; - - begin - Append_Elmt (Object_Entity, Map); - Append_Elmt (Object_Entity_M, Map); - Expr_M := New_Copy_Tree (Expr, Map => Map); - end; - end if; - -- Build the main predicate function declare @@ -10468,27 +10433,179 @@ package body Sem_Ch13 is -- Build function body - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SIdB, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Object_Name), - Parameter_Type => - New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); - - FBody := - Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => Expr)))); + declare + Param_Specs : constant List_Id := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Object_Name), + Parameter_Type => + New_Occurrence_Of (Typ, Loc))); + begin + -- if Spec has 2 parameters, then body should too + if Present (Next_Entity (Object_Entity)) then + Append (Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier + (Loc, Chars (Next_Entity (Object_Entity))), + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc)), + Param_Specs); + end if; + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SIdB, + Parameter_Specifications => Param_Specs, + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + end; + + -- The Predicate_Expression attribute is used by SPARK. + -- + -- If Ancestor_Predicate_Function_Called is True, then + -- we try to exclude that call to the ancestor's + -- predicate function by calling Right_Opnd. + -- The call is not excluded in the case where + -- it is not "and"ed with anything else (so we don't have + -- an N_And_Then node). This exclusion is required if the + -- Predicate_Failure aspect is specified for Typ because + -- in that case we are going to drop the N_And_Then node + -- on the floor. Otherwise, it is a question of what is + -- most convenient for SPARK. + + Set_Predicate_Expression + (SId, (if Ancestor_Predicate_Function_Called + and then Nkind (Expr) = N_And_Then + then Right_Opnd (Expr) + else Expr)); + + declare + Result_Expr : Node_Id := Expr; + PF_Expr : Node_Id := Predicate_Failure_Expression + (Typ, Inherited_OK => False); + PF_Expr_Copy : Node_Id; + Second_Formal : constant Entity_Id := + Next_Entity (Object_Entity); + begin + if Present (PF_Expr) then + pragma Assert (Present (Second_Formal)); + + -- This is an ugly hack to cope with an ugly situation. + -- PF_Expr may have children whose Parent attribute + -- does not point back to PF_Expr. If we pass such a + -- tree to New_Copy_Tree, then it does not make a deep + -- copy. But we need a deep copy. So we need to find a + -- tree for which New_Copy_Tree *will* make a deep copy. + + declare + function Check_Node_Parent (Parent_Node, Node : Node_Id) + return Traverse_Result; + function Check_Node_Parent (Parent_Node, Node : Node_Id) + return Traverse_Result is + begin + if Parent_Node = PF_Expr + and then not Is_List_Member (Node) + then + pragma Assert + (Nkind (PF_Expr) = Nkind (Parent (Node))); + + -- We need PF_Expr to be a node for which + -- New_Copy_Tree will make a deep copy. + PF_Expr := Parent (Node); + return Abandon; + end if; + return OK; + end Check_Node_Parent; + procedure Check_Parentage is + new Traverse_Proc_With_Parent (Check_Node_Parent); + begin + Check_Parentage (PF_Expr); + PF_Expr_Copy := New_Copy_Tree (PF_Expr); + end; + + -- Current instance uses need to have their Entity + -- fields set so that Replace_Current_Instance_References + -- can find them. So we preanalyze. Just for purposes of + -- calls to Is_Current_Instance during this preanalysis, + -- we set the Parent field. + Set_Parent (PF_Expr_Copy, Parent (PF_Expr)); + Preanalyze (PF_Expr_Copy); + Set_Parent (PF_Expr_Copy, Empty); + + Replace_Current_Instance_References + (PF_Expr_Copy, Typ => Typ, New_Entity => Object_Entity); + + if Ancestor_Predicate_Function_Called then + -- If the call to an ancestor predicate function + -- returns False, we do not want to raise an + -- exception here. Our Predicate_Failure aspect does + -- not apply in that case. So we have to build a + -- more complicated result expression: + -- (if not Ancestor_Predicate_Function (...) then False + -- elsif Noninherited_Predicates (...) then True + -- elsif Is_Membership_Test then False + -- else (raise Assertion_Error with PF text)) + + declare + Ancestor_Call : constant Node_Id := + Left_Opnd (Result_Expr); + Local_Preds : constant Node_Id := + Right_Opnd (Result_Expr); + begin + Result_Expr := + Make_If_Expression (Loc, + Expressions => New_List ( + Make_Op_Not (Loc, Ancestor_Call), + New_Occurrence_Of (Standard_False, Loc), + Make_If_Expression (Loc, + Is_Elsif => True, + Expressions => New_List ( + Local_Preds, + New_Occurrence_Of (Standard_True, Loc), + Make_If_Expression (Loc, + Is_Elsif => True, + Expressions => New_List ( + New_Occurrence_Of (Second_Formal, Loc), + New_Occurrence_Of (Standard_False, Loc), + Make_Raise_Expression (Loc, + New_Occurrence_Of (RTE + (RE_Assert_Failure), Loc), + PF_Expr_Copy))))))); + end; + + else + -- Build a conditional expression: + -- (if then True + -- elsif Is_Membership_Test then False + -- else (raise Assertion_Error with PF text)) + + Result_Expr := + Make_If_Expression (Loc, + Expressions => New_List ( + Result_Expr, + New_Occurrence_Of (Standard_True, Loc), + Make_If_Expression (Loc, + Is_Elsif => True, + Expressions => New_List ( + New_Occurrence_Of (Second_Formal, Loc), + New_Occurrence_Of (Standard_False, Loc), + Make_Raise_Expression (Loc, + New_Occurrence_Of (RTE + (RE_Assert_Failure), Loc), + PF_Expr_Copy))))); + end if; + end if; + + FBody := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Result_Expr)))); + end; -- The declaration has been analyzed when created, and placed -- after type declaration. Insert body itself after freeze node, @@ -10559,121 +10676,6 @@ package body Sem_Ch13 is end if; end; - -- Test for raise expressions present and if so build M version - - if Raise_Expression_Present then - declare - SId : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "PredicateM")); - -- The entity for the function spec - - SIdB : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "PredicateM")); - -- The entity for the function body - - Spec : Node_Id; - FBody : Node_Id; - FDecl : Node_Id; - BTemp : Entity_Id; - - CRec_Typ : Entity_Id; - -- The corresponding record type of Full_Typ - - Full_Typ : Entity_Id; - -- The full view of Typ - - Priv_Typ : Entity_Id; - -- The partial view of Typ - - UFull_Typ : Entity_Id; - -- The underlying full view of Full_Typ - - begin - -- Mark any raise expressions for special expansion - - Process_REs (Expr_M); - - -- Build function declaration - - Mutate_Ekind (SId, E_Function); - Set_Is_Predicate_Function_M (SId); - Set_Predicate_Function_M (Typ, SId); - - -- Obtain all views of the input type - - Get_Views (Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ); - - -- Associate the predicate function with all views - - Propagate_Predicate_Attributes (Priv_Typ, From_Typ => Typ); - Propagate_Predicate_Attributes (Full_Typ, From_Typ => Typ); - Propagate_Predicate_Attributes (UFull_Typ, From_Typ => Typ); - Propagate_Predicate_Attributes (CRec_Typ, From_Typ => Typ); - - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Object_Entity_M, - Parameter_Type => New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); - - FDecl := - Make_Subprogram_Declaration (Loc, - Specification => Spec); - - -- Build function body - - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SIdB, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Object_Name), - Parameter_Type => - New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); - - -- Build the body, we declare the boolean expression before - -- doing the return, because we are not really confident of - -- what happens if a return appears within a return. - - BTemp := - Make_Temporary (Loc, 'B'); - - FBody := - Make_Subprogram_Body (Loc, - Specification => Spec, - - Declarations => New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => BTemp, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loc), - Expression => Expr_M)), - - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => New_Occurrence_Of (BTemp, Loc))))); - - -- Insert declaration before freeze node and body after - - Insert_Before_And_Analyze (N, FDecl); - Insert_After_And_Analyze (N, FBody); - - -- Should quantified expressions be handled here as well ??? - end; - end if; - -- See if we have a static predicate. Note that the answer may be -- yes even if we have an explicit Dynamic_Predicate present. @@ -10766,7 +10768,7 @@ package body Sem_Ch13 is end if; Restore_Ghost_Region (Saved_GM, Saved_IGR); - end Build_Predicate_Functions; + end Build_Predicate_Function; ------------------------------------------ -- Build_Predicate_Function_Declaration -- @@ -10835,15 +10837,28 @@ package body Sem_Ch13 is Propagate_Predicate_Attributes (UFull_Typ, From_Typ => Typ); Propagate_Predicate_Attributes (CRec_Typ, From_Typ => Typ); - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => Func_Id, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Temporary (Loc, 'I'), - Parameter_Type => New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); + declare + Param_Specs : constant List_Id := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Temporary (Loc, 'I'), + Parameter_Type => New_Occurrence_Of (Typ, Loc))); + begin + if Predicate_Function_Needs_Membership_Parameter (Typ) then + -- Add Boolean-valued For_Membership_Test param + Append (Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Temporary (Loc, 'M'), + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc)), + Param_Specs); + end if; + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Func_Id, + Parameter_Specifications => Param_Specs, + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + end; Func_Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); @@ -13107,7 +13122,7 @@ package body Sem_Ch13 is end if; end; - Build_Predicate_Functions (E, N); + Build_Predicate_Function (E, N); end if; -- If type has delayed aspects, this is where we do the preanalysis at diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c306e2779a4..0a809154296 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -16892,6 +16892,8 @@ package body Sem_Util is elsif Nkind (P) = N_Aspect_Specification and then Nkind (Parent (P)) = N_Subtype_Declaration + and then Underlying_Type (Defining_Identifier (Parent (P))) = + Underlying_Type (Typ) then return True; @@ -16899,7 +16901,14 @@ package body Sem_Util is and then Get_Pragma_Id (P) in Pragma_Predicate | Pragma_Predicate_Failure then - return True; + declare + Arg : constant Entity_Id := + Entity (Expression (Get_Argument (P))); + begin + if Underlying_Type (Arg) = Underlying_Type (Typ) then + return True; + end if; + end; end if; P := Parent (P); @@ -16933,7 +16942,6 @@ package body Sem_Util is and then Ekind (Scope (Entity (N))) in E_Function | E_Procedure and then (Is_Predicate_Function (Scope (Entity (N))) - or else Is_Predicate_Function_M (Scope (Entity (N))) or else Is_Invariant_Procedure (Scope (Entity (N))) or else Is_Partial_Invariant_Procedure (Scope (Entity (N))) or else Is_DIC_Procedure (Scope (Entity (N)))); @@ -26539,6 +26547,69 @@ package body Sem_Util is and then not Predicate_Checks_Suppressed (Empty); end Predicate_Enabled; + ---------------------------------- + -- Predicate_Failure_Expression -- + ---------------------------------- + + function Predicate_Failure_Expression + (Typ : Entity_Id; Inherited_OK : Boolean) return Node_Id + is + PF_Aspect : constant Node_Id := + Find_Aspect (Typ, Aspect_Predicate_Failure); + begin + -- Check for Predicate_Failure aspect specification via an + -- aspect_specification (as opposed to via a pragma). + + if Present (PF_Aspect) then + if Inherited_OK or else Entity (PF_Aspect) = Typ then + return Expression (PF_Aspect); + else + return Empty; + end if; + end if; + + -- Check for Predicate_Failure aspect specification via a pragma. + + declare + Rep_Item : Node_Id := First_Rep_Item (Typ); + begin + while Present (Rep_Item) loop + if Nkind (Rep_Item) = N_Pragma + and then Get_Pragma_Id (Rep_Item) = Pragma_Predicate_Failure + then + declare + Arg1 : constant Node_Id := + Get_Pragma_Arg + (First (Pragma_Argument_Associations (Rep_Item))); + Arg2 : constant Node_Id := + Get_Pragma_Arg + (Next (First (Pragma_Argument_Associations (Rep_Item)))); + begin + if Inherited_OK or else + (Nkind (Arg1) in N_Has_Entity + and then Entity (Arg1) = Typ) + then + return Arg2; + end if; + end; + end if; + + Next_Rep_Item (Rep_Item); + end loop; + end; + + -- If we are interested in an inherited Predicate_Failure aspect + -- and we have an ancestor to inherit from, then recursively check + -- for that case. + + if Inherited_OK and then Present (Nearest_Ancestor (Typ)) then + return Predicate_Failure_Expression (Nearest_Ancestor (Typ), + Inherited_OK => True); + end if; + + return Empty; + end Predicate_Failure_Expression; + ---------------------------------- -- Predicate_Tests_On_Arguments -- ---------------------------------- @@ -26574,9 +26645,7 @@ package body Sem_Util is -- would cause infinite recursion. elsif Ekind (Subp) = E_Function - and then (Is_Predicate_Function (Subp) - or else - Is_Predicate_Function_M (Subp)) + and then Is_Predicate_Function (Subp) then return False; @@ -27029,9 +27098,7 @@ package body Sem_Util is (Typ : Entity_Id; From_Typ : Entity_Id) is - Pred_Func : Entity_Id; - Pred_Func_M : Entity_Id; - + Pred_Func : Entity_Id; begin if Present (Typ) and then Present (From_Typ) then pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); @@ -27044,7 +27111,6 @@ package body Sem_Util is end if; Pred_Func := Predicate_Function (From_Typ); - Pred_Func_M := Predicate_Function_M (From_Typ); -- The setting of the attributes is intentionally conservative. This -- prevents accidental clobbering of enabled attributes. @@ -27056,10 +27122,6 @@ package body Sem_Util is if Present (Pred_Func) and then No (Predicate_Function (Typ)) then Set_Predicate_Function (Typ, Pred_Func); end if; - - if Present (Pred_Func_M) and then No (Predicate_Function_M (Typ)) then - Set_Predicate_Function_M (Typ, Pred_Func_M); - end if; end if; end Propagate_Predicate_Attributes; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 1eca815c9d6..7038f1188ba 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2930,6 +2930,26 @@ package Sem_Util is -- Typ, taking into account Predicates_Ignored and -- Predicate_Checks_Suppressed. + function Predicate_Failure_Expression + (Typ : Entity_Id; Inherited_OK : Boolean) return Node_Id; + -- If the given type or subtype is subject to a Predicate_Failure + -- aspect specification, then returns the specified expression. + -- Otherwise, if Inherited_OK is False then returns Empty. + -- Otherwise, if Typ denotes a subtype or a derived type then + -- returns the result of recursing on the ancestor subtype. + -- Otherwise, returns Empty. + + function Predicate_Function_Needs_Membership_Parameter (Typ : Entity_Id) + return Boolean is + (Present (Predicate_Failure_Expression (Typ, Inherited_OK => True))); + -- The predicate function for some, but not all, subtypes needs to + -- know whether the predicate is being evaluated as part of a membership + -- test. The predicate function for such a subtype takes an additional + -- boolean to convey this information. This function returns True if this + -- additional parameter is needed. More specifically, this function + -- returns true if the Predicate_Failure aspect is specified for the + -- given subtype or for any of its "ancestor" subtypes. + function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean; -- Subp is the entity for a subprogram call. This function returns True if -- predicate tests are required for the arguments in this call (this is the