[Ada] Ada_2020 AI12-0220 Pre/Postconditions on Access_To_Subprogram types

2020-06-17  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch3.adb (Analyze_Full_Type_Declaration): For an
	access_to_subprogram declaration that has aspect specifications,
	call Build_Access_ Subprogram_Wrapper at once, so that pre- and
	postcondition aspects are analyzed in the context of a
	subprogram declaration.
	(Build_Access_Subprogram_Wrapper): Examine aspect specifications
	of an Access_To_Subprogram declaration. If pre- or
	postconditions are declared for it, create declaration for
	subprogram wrapper and add the corresponding aspect
	specifications to it. Replace occurrences of the type name by
	that of the generated subprogram, so that attributes 'Old and
	'Result can appear in a postcondition.
	* exp_ch3.adb (Build_Access_Subprogram_Wrapper_Body): Moved
	here from sem_prag.adb.
	* exp_ch3.ads (Build_Access_Subprogram_Wrapper_Body): Visible
	subprogram.
	* sem_prag.adb (Build_Access_Subprogram_Wrapper / _Body): Moved
	to sem_ch3.adb and exp_ch3.adb.

1 files changed, 72 insertions, 0 deletions

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index b207a1f..6e1e625 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -515,6 +515,78 @@ package body Exp_Ch3 is
       end loop;
    end Adjust_Discriminants;
 
+   ------------------------------------------
+   -- Build_Access_Subprogram_Wrapper_Body --
+   ------------------------------------------
+
+   procedure Build_Access_Subprogram_Wrapper_Body
+     (Decl : Node_Id;
+      New_Decl : Node_Id)
+   is
+      Loc       : constant Source_Ptr := Sloc (Decl);
+      Actuals   : constant List_Id := New_List;
+      Type_Def  : constant Node_Id := Type_Definition (Decl);
+      Type_Id   : constant Entity_Id := Defining_Identifier (Decl);
+      Spec_Node : constant Node_Id :=
+        New_Copy_Tree (Specification (New_Decl));
+
+      Act       : Node_Id;
+      Body_Node : Node_Id;
+      Call_Stmt : Node_Id;
+      Ptr       : Entity_Id;
+   begin
+      if not Expander_Active then
+         return;
+      end if;
+
+      Set_Defining_Unit_Name (Spec_Node,
+        Make_Defining_Identifier
+          (Loc, Chars (Defining_Unit_Name (Spec_Node))));
+
+      --  Create List of actuals for indirect call. The last
+      --  parameter of the subprogram is the access value itself.
+
+      Act := First (Parameter_Specifications (Spec_Node));
+
+      while Present (Act) loop
+         Append_To (Actuals,
+           Make_Identifier (Loc, Chars (Defining_Identifier (Act))));
+         Next (Act);
+         exit when Act = Last (Parameter_Specifications (Spec_Node));
+      end loop;
+
+      Ptr :=
+        Defining_Identifier
+          (Last (Parameter_Specifications (Spec_Node)));
+
+      if Nkind (Type_Def) = N_Access_Procedure_Definition then
+         Call_Stmt := Make_Procedure_Call_Statement (Loc,
+           Name =>
+              Make_Explicit_Dereference
+                (Loc, New_Occurrence_Of (Ptr, Loc)),
+           Parameter_Associations => Actuals);
+      else
+         Call_Stmt := Make_Simple_Return_Statement (Loc,
+           Expression =>
+             Make_Function_Call (Loc,
+           Name => Make_Explicit_Dereference
+                    (Loc, New_Occurrence_Of (Ptr, Loc)),
+           Parameter_Associations => Actuals));
+      end if;
+
+      Body_Node := Make_Subprogram_Body (Loc,
+        Specification => Spec_Node,
+        Declarations  => New_List,
+        Handled_Statement_Sequence =>
+          Make_Handled_Sequence_Of_Statements (Loc,
+            Statements    => New_List (Call_Stmt)));
+
+      --  Place body in list of freeze actions for the type.
+
+      Ensure_Freeze_Node (Type_Id);
+      Append_Freeze_Actions (Type_Id, New_List (Body_Node));
+   end Build_Access_Subprogram_Wrapper_Body;
+
    ---------------------------
    -- Build_Array_Init_Proc --
    ---------------------------