From: Ed Schonberg Date: Mon, 18 Apr 2016 09:52:22 +0000 (+0000) Subject: sem_ch6.adb (Analyze_Expression_Function): Set Inlined flag on the entity of a subpro... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=88fa9a245cc307a62d119797dfcd9422425f2f45;p=gcc.git sem_ch6.adb (Analyze_Expression_Function): Set Inlined flag on the entity of a subprogram declaration that is completed by... 2016-04-18 Ed Schonberg * sem_ch6.adb (Analyze_Expression_Function): Set Inlined flag on the entity of a subprogram declaration that is completed by an expression function. 2016-04-18 Ed Schonberg * sem_util.adb (Is_Current_Instance): A entity given by a subtype declaration can appear in an aspect specification for a dynamic predicate, and a pragma for aspect Predicate_Failure. * exp_util.adb (Replace_Subtype_References): Replace current occurrences of the subtype to which a dynamic predicate applies, byt the expression that triggers a predicate check. Needed to implement new aspect Predicate_Failure. From-SVN: r235107 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 35f45896584..c9d9ba05a85 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2016-04-18 Ed Schonberg + + * sem_ch6.adb (Analyze_Expression_Function): Set Inlined flag + on the entity of a subprogram declaration that is completed by + an expression function. + +2016-04-18 Ed Schonberg + + * sem_util.adb (Is_Current_Instance): A entity given by a subtype + declaration can appear in an aspect specification for a dynamic + predicate, and a pragma for aspect Predicate_Failure. + * exp_util.adb (Replace_Subtype_References): Replace current + occurrences of the subtype to which a dynamic predicate applies, + byt the expression that triggers a predicate check. Needed to + implement new aspect Predicate_Failure. + 2016-04-18 Arnaud Charlet * a-intsig.ads, a-intsig.adb: Removed, no longer used. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 55836e102ef..2bed3f64c9d 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -46,6 +46,7 @@ with Rident; use Rident; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; @@ -6503,9 +6504,38 @@ package body Exp_Util is (Typ : Entity_Id; Expr : Node_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (Expr); - Arg_List : List_Id; - Nam : Name_Id; + 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. + + -------------------------------- + -- 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 + + Loc : constant Source_Ptr := Sloc (Expr); + Arg_List : List_Id; + Fail_Expr : Node_Id; + Nam : Name_Id; + + -- Start of processing for Make_Predicate_Check begin -- If predicate checks are suppressed, then return a null statement. For @@ -6540,12 +6570,19 @@ package body Exp_Util is 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); + Append_To (Arg_List, Make_Pragma_Argument_Association (Loc, - Expression => - New_Copy_Tree - (Expression (Find_Aspect (Typ, Aspect_Predicate_Failure))))); + Expression => Fail_Expr)); end if; return diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 9474ef57af5..7f424791e6f 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -362,7 +362,7 @@ package body Sem_Ch6 is Set_Is_Inlined (Prev); -- If the expression function is a completion, the previous declaration - -- must come from source. We know already that appears in the current + -- must come from source. We know already that it appears in the current -- scope. The entity itself may be internally created if within a body -- to be inlined. @@ -371,6 +371,7 @@ package body Sem_Ch6 is and then not Is_Formal_Subprogram (Prev) then Set_Has_Completion (Prev, False); + Set_Is_Inlined (Prev); -- An expression function that is a completion freezes the -- expression. This means freezing the return type, and if it is @@ -411,7 +412,6 @@ package body Sem_Ch6 is -- Not clear that the backend can inline it in this case ??? if Has_Completion (Prev) then - Set_Is_Inlined (Prev); -- The formals of the expression function are body formals, -- and do not appear in the ali file, which will only contain diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f100a0764c0..7bfe72455b9 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -11574,6 +11574,23 @@ package body Sem_Util is and then Defining_Entity (P) = Typ then return True; + + -- A subtype name may appear in an aspect specification for a + -- Predicate_Failure aspect, for which we do not construct a + -- wrapper procedure. The subtype will be replaced by the + -- expression being tested when the corresponding predicate + -- check is expanded. + + elsif Nkind (P) = N_Aspect_Specification + and then Nkind (Parent (P)) = N_Subtype_Declaration + then + return True; + + elsif Nkind (P) = N_Pragma + and then + Get_Pragma_Id (Pragma_Name (P)) = Pragma_Predicate_Failure + then + return True; end if; P := Parent (P);