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

From-SVN: r138650

diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 2a91413d57016711006c075f4e141e9dde58428f..53de7a0e9d5c474f0fd91f57aec1868f0d15aad8 100644 (file)
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -4733,9 +4733,9 @@ package body Exp_Ch9 is
       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 @@ package body Exp_Ch9 is
           Defining_Identifier => D_T2,
           Type_Definition => Def1);
 
-      Analyze (Decl1);
       Insert_After (N, Decl1);
+      Analyze (Decl1);
 
       --  Create Equivalent_Type, a record with two components for an access to
       --  object and an access to subprogram.
@@ -4786,8 +4786,8 @@ package body Exp_Ch9 is
                 Make_Component_List (Loc,
                   Component_Items => Comps)));
 
-      Analyze (Decl2);
       Insert_After (Decl1, Decl2);
+      Analyze (Decl2);
       Set_Equivalent_Type (T, E_T);
    end Expand_Access_Protected_Subprogram_Type;
 
@@ -7062,6 +7062,7 @@ package body Exp_Ch9 is
    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 @@ package body Exp_Ch9 is
       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 @@ package body Exp_Ch9 is
                   --  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;

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 307b6a158b6cebeecb726a410ed89d3c8d6f1635..44cd6c65e035524e0d9482e57f5d5fdacf07e550 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -1056,7 +1056,6 @@ package body Sem_Ch3 is
                                    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 @@ package body Sem_Ch3 is
 
       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 @@ package body Sem_Ch3 is
 
       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);

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index ea1a21ed1781b10dfef4d19bd7957304c4762ef0..1e84b266745f48f711311f0ae6d204d2a784c5f7 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -663,9 +663,9 @@ package body Sem_Ch6 is
             --  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 @@ package body Sem_Ch6 is
             --  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