sem_ch6.adb (Analyze_Expression_Function): Set Inlined flag on the entity of a…

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  <schonberg@adacore.com>

	* 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  <schonberg@adacore.com>

	* 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

gcc/ada/ChangeLog

+2016-04-18  Ed Schonberg  <schonberg@adacore.com>
+
+	* 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  <schonberg@adacore.com>
+
+	* 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  <charlet@adacore.com>
 
 	* a-intsig.ads, a-intsig.adb: Removed, no longer used.

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

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

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);