From 806312986f95213e4321f4a282ff1738fe72c1ea Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Thu, 11 Jan 2018 08:51:39 +0000 Subject: [PATCH] [Ada] Different runtime behavior of Predicate_Failure This patch corrects the generation of predicate checks to handle the case where Predicate_Failure appears as a pragma. ------------ -- Source -- ------------ -- main.adb with Ada.Assertions; use Ada.Assertions; with Ada.Exceptions; use Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; procedure Main is subtype Even_Asp is Integer with Predicate => Even_Asp mod 2 = 0, Predicate_Failure => "Even_Asp failed"; subtype Even_Prag is Integer with Predicate => Even_Prag mod 2 = 0; pragma Predicate_Failure (Even_Prag, "Even_Prag failed"); begin begin declare Val : constant Even_Asp := 1; begin Put_Line ("ERROR: Even_Asp: did not fail"); end; exception when AE : Assertion_Error => Put_Line (Exception_Message (AE)); when others => Put_Line ("ERROR: Even_Asp: raised unexpected error"); end; begin declare Val : constant Even_Prag := 3; begin Put_Line ("ERROR: Even_Prag: did not fail"); end; exception when AE : Assertion_Error => Put_Line (Exception_Message (AE)); when others => Put_Line ("ERROR: Even_Prag: raised unexpected error"); end; end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q main.adb $ ./main Even_Asp failed Even_Prag failed 2018-01-11 Hristian Kirtchev gcc/ada/ * exp_util.adb (Add_Failure_Expression): New routine. (Make_Predicate_Check): Reimplement the handling of Predicate_Failure. * sem_util.adb (Is_Current_Instance): Code cleanup. From-SVN: r256493 --- gcc/ada/ChangeLog | 6 ++ gcc/ada/exp_util.adb | 198 +++++++++++++++++++++++++++++++++++-------- gcc/ada/sem_util.adb | 7 +- 3 files changed, 171 insertions(+), 40 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8ff1a1364a4..7b55c1065fd 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2018-01-11 Hristian Kirtchev + + * exp_util.adb (Add_Failure_Expression): New routine. + (Make_Predicate_Check): Reimplement the handling of Predicate_Failure. + * sem_util.adb (Is_Current_Instance): Code cleanup. + 2018-01-11 Patrick Bernardi * libgnat/s-parame*.adb, libgnat/s-parame*.ads: Remove unneeded diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 058bfe4658b..dea89c4d102 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -9310,36 +9310,172 @@ package body Exp_Util is (Typ : Entity_Id; Expr : Node_Id) return Node_Id is - procedure Replace_Subtype_Reference (N : Node_Id); - -- Replace current occurrences of the subtype to which a dynamic - -- predicate applies, by the expression that triggers a predicate - -- check. This is needed for aspect Predicate_Failure, for which - -- we do not generate a wrapper procedure, but simply modify the - -- expression for the pragma of the predicate check. + Loc : constant Source_Ptr := Sloc (Expr); - -------------------------------- - -- Replace_Subtype_Reference -- - -------------------------------- + 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; + + Item := 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 No (Args) or else 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)); + + -- We want to treat the node as if it comes from source, so that + -- ASIS will not ignore it. + + Set_Comes_From_Source (N, True); + 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 - procedure Replace_Subtype_Reference (N : Node_Id) is begin - Rewrite (N, New_Copy_Tree (Expr)); + if Present (PF_Expr) then - -- We want to treat the node as if it comes from source, so - -- that ASIS will not ignore it. + -- Replace any occurrences of the current instance of the type + -- with the object subjected to the predicate check. - Set_Comes_From_Source (N, True); - end Replace_Subtype_Reference; + Expr := New_Copy_Tree (PF_Expr); + Replace_Subtype_References (Expr, Typ); - procedure Replace_Subtype_References is - new Replace_Type_References_Generic (Replace_Subtype_Reference); + -- 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 - Loc : constant Source_Ptr := Sloc (Expr); - Arg_List : List_Id; - Fail_Expr : Node_Id; - Nam : Name_Id; + Args : List_Id; + Nam : Name_Id; -- Start of processing for Make_Predicate_Check @@ -9370,31 +9506,21 @@ package body Exp_Util is Nam := Name_Predicate; end if; - Arg_List := New_List ( + Args := New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Identifier (Loc, Nam)), Make_Pragma_Argument_Association (Loc, Expression => Make_Predicate_Call (Typ, Expr))); - -- If subtype has Predicate_Failure defined, add the correponding - -- expression as an additional pragma parameter, after replacing - -- current instances with the expression being checked. - - if Has_Aspect (Typ, Aspect_Predicate_Failure) then - Fail_Expr := - New_Copy_Tree - (Expression (Find_Aspect (Typ, Aspect_Predicate_Failure))); - Replace_Subtype_References (Fail_Expr, Typ); + -- If the subtype is subject to pragma Predicate_Failure, add the + -- failure expression as an additional parameter. - Append_To (Arg_List, - Make_Pragma_Argument_Association (Loc, - Expression => Fail_Expr)); - end if; + Add_Failure_Expression (Args); return Make_Pragma (Loc, Chars => Name_Check, - Pragma_Argument_Associations => Arg_List); + Pragma_Argument_Associations => Args); end Make_Predicate_Check; ---------------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c1e16e3037a..bd0d4584ba4 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -13318,8 +13318,8 @@ package body Sem_Util is begin -- Simplest case: entity is a concurrent type and we are currently - -- inside the body. This will eventually be expanded into a - -- call to Self (for tasks) or _object (for protected objects). + -- inside the body. This will eventually be expanded into a call to + -- Self (for tasks) or _object (for protected objects). if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then return True; @@ -13350,8 +13350,7 @@ package body Sem_Util is return True; elsif Nkind (P) = N_Pragma - and then - Get_Pragma_Id (P) = Pragma_Predicate_Failure + and then Get_Pragma_Id (P) = Pragma_Predicate_Failure then return True; end if; -- 2.30.2