[Ada] Handling of anonymous access to protected subprograms.

[Arnaud Charlet]

Minor fixes to handle properly instances of anonymous access to subprograms
that can appear as return results in function specifications, both in
declarations and bodies.
Examples of use in ACATS test C3A0018.

2008-08-04  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb:
	(Replace_Anonymous_Access_To_Protected_Subprogram): Handle properly an
	anonymous access to protected subprogram that is the return type of the
	specification of a subprogram body.

	* sem_ch6.adb:
	(Analyze_Subprogram_Body): if the return type is an anonymous access to
	subprogram, freeze it now to prevent access anomalies in the back-end.

	* exp_ch9.adb: Minor code cleanup.
	Make sure that new declarations are inserted into the tree before
	analysis (from code reading).

-------------- next part --------------
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 138610)
+++ sem_ch3.adb	(working copy)
@@ -1056,7 +1056,6 @@
                                    N_Object_Renaming_Declaration,
                                    N_Formal_Object_Declaration,
                                    N_Formal_Type_Declaration,
-                                   N_Formal_Object_Declaration,
                                    N_Task_Type_Declaration,
                                    N_Protected_Type_Declaration))
       loop
@@ -4476,9 +4475,17 @@
 
       Mark_Rewrite_Insertion (Decl);
 
-      --  Insert the new declaration in the nearest enclosing scope
+      --  Insert the new declaration in the nearest enclosing scope. If the
+      --  node is a body and N is its return type, the declaration belongs in
+      --  the enclosing scope.
 
       P := Parent (N);
+      if Nkind (P) = N_Subprogram_Body
+        and then Nkind (N) = N_Function_Specification
+      then
+         P := Parent (P);
+      end if;
+
       while Present (P) and then not Has_Declarations (P) loop
          P := Parent (P);
       end loop;
@@ -4521,13 +4528,13 @@
 
       Mark_Rewrite_Insertion (Comp);
 
-      --  Temporarily remove the current scope from the stack to add the new
-      --  declarations to the enclosing scope
-
       if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) then
          Analyze (Decl);
 
       else
+         --  Temporarily remove the current scope (record or subprogram) from
+         --  the stack to add the new declarations to the enclosing scope.
+
          Scope_Stack.Decrement_Last;
          Analyze (Decl);
          Set_Is_Itype (Anon);
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb	(revision 138518)
+++ exp_ch9.adb	(working copy)
@@ -4733,9 +4733,9 @@
       Def1   : Node_Id;
 
    begin
-      --  Create access to protected subprogram with full signature
+      --  Create access to subprogram with full signature
 
-      if Nkind (Type_Definition (N)) = N_Access_Function_Definition then
+      if Etype (D_T) /= Standard_Void_Type then
          Def1 :=
            Make_Access_Function_Definition (Loc,
              Parameter_Specifications => P_List,
@@ -4753,8 +4753,8 @@
           Defining_Identifier => D_T2,
           Type_Definition => Def1);
 
+      Insert_After (N, Decl1);
       Analyze (Decl1);
-      Insert_After (N, Decl1);
 
       --  Create Equivalent_Type, a record with two components for an access to
       --  object and an access to subprogram.
@@ -4786,8 +4786,8 @@
                 Make_Component_List (Loc,
                   Component_Items => Comps)));
 
+      Insert_After (Decl1, Decl2);
       Analyze (Decl2);
-      Insert_After (Decl1, Decl2);
       Set_Equivalent_Type (T, E_T);
    end Expand_Access_Protected_Subprogram_Type;
 
@@ -7062,6 +7062,7 @@
    procedure Expand_N_Protected_Body (N : Node_Id) is
       Loc          : constant Source_Ptr := Sloc (N);
       Pid          : constant Entity_Id  := Corresponding_Spec (N);
+
       Current_Node : Node_Id;
       Disp_Op_Body : Node_Id;
       New_Op_Body  : Node_Id;
@@ -7070,6 +7071,9 @@
       Op_Decl      : Node_Id;
       Op_Id        : Entity_Id;
 
+      Chain        : Entity_Id := Empty;
+      --  Finalization chain that may be attached to new body
+
       function Build_Dispatching_Subprogram_Body
         (N        : Node_Id;
          Pid      : Node_Id;
@@ -7203,13 +7207,13 @@
                   --  entity is not further elaborated, and so the chain
                   --  properly belongs to the newly created subprogram body.
 
-                  if Present
-                    (Finalization_Chain_Entity (Defining_Entity (Op_Body)))
-                  then
+                  Chain :=
+                    Finalization_Chain_Entity (Defining_Entity (Op_Body));
+
+                  if Present (Chain) then
                      Set_Finalization_Chain_Entity
                        (Protected_Body_Subprogram
-                         (Corresponding_Spec (Op_Body)),
-                       Finalization_Chain_Entity (Defining_Entity (Op_Body)));
+                         (Corresponding_Spec (Op_Body)), Chain);
                      Set_Analyzed
                          (Handled_Statement_Sequence (New_Op_Body), False);
                   end if;
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 138610)
+++ sem_ch6.adb	(working copy)
@@ -663,9 +663,9 @@
             --  Analyze_Object_Declaration; we treat it as a normal
             --  object declaration.
 
+            Set_Is_Return_Object (Defining_Identifier (Obj_Decl));
             Analyze (Obj_Decl);
 
-            Set_Is_Return_Object (Defining_Identifier (Obj_Decl));
             Check_Return_Subtype_Indication (Obj_Decl);
 
             if Present (HSS) then
@@ -1804,12 +1804,19 @@
             --  the body that depends on the subprogram having been frozen,
             --  such as uses of extra formals), so we force it to be frozen
             --  here. Same holds if the body and spec are compilation units.
+            --  Finally, if the return type is an anonymous access to protected
+            --  subprogram, it must be frozen before the body because its
+            --  expansion has generated an equivalent type that is used when
+            --  elaborating the body.
 
             if No (Spec_Id) then
                Freeze_Before (N, Body_Id);
 
             elsif Nkind (Parent (N)) = N_Compilation_Unit then
                Freeze_Before (N, Spec_Id);
+
+            elsif Is_Access_Subprogram_Type (Etype (Body_Id)) then
+               Freeze_Before (N, Etype (Body_Id));
             end if;
 
          else