[Ada] Transform_Function_Array issues

gcc/ada/

	* exp_ch6.adb (Build_Procedure_Body_Form): Adjust, the
	declaration of the procedure form is now insert before the
	original function body rather than after.
	(Expand_N_Subprogram_Declaration): Deal with private types whose
	full views are arrays.
	* exp_unst.adb (Unnest_Subprogram): Deal with private types.
	(Needs_Fat_Pointer): Code cleanup.
	* freeze.adb (Freeze_Subprogram): Ditto.
	* exp_util.adb (Build_Procedure_Form): Insert the procedure form
	decl before and not after.
	* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Build missing
	spec when needed for Transform_Function_Array.
	* sem_util.adb (Get_Fullest_View): Deal with null entity.

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 955049f421015d7b8de0ce2d1eafdc04d5def673..0a5fbccec820ee515b618c9ff0d18428ed8ee4f7 100644 (file)
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -883,9 +883,8 @@ package body Exp_Ch6 is
    is
       Loc : constant Source_Ptr := Sloc (Func_Body);
 
-      Proc_Decl : constant Node_Id   :=
-                    Next (Unit_Declaration_Node (Func_Id));
-      --  It is assumed that the next node following the declaration of the
+      Proc_Decl : constant Node_Id := Prev (Unit_Declaration_Node (Func_Id));
+      --  It is assumed that the node before the declaration of the
       --  corresponding subprogram spec is the declaration of the procedure
       --  form.
 
@@ -6571,6 +6570,7 @@ package body Exp_Ch6 is
       Prot_Bod  : Node_Id;
       Prot_Decl : Node_Id;
       Prot_Id   : Entity_Id;
+      Typ       : Entity_Id;
 
    begin
       --  Deal with case of protected subprogram. Do not generate protected
@@ -6645,10 +6645,12 @@ package body Exp_Ch6 is
       --  are not needed by the C generator (and this also produces cleaner
       --  output).
 
+      Typ := Get_Fullest_View (Etype (Subp));
+
       if Transform_Function_Array
         and then Nkind (Specification (N)) = N_Function_Specification
-        and then Is_Array_Type (Etype (Subp))
-        and then Is_Constrained (Etype (Subp))
+        and then Is_Array_Type (Typ)
+        and then Is_Constrained (Typ)
         and then not Is_Unchecked_Conversion_Instance (Subp)
       then
          Build_Procedure_Form (N);

diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb
index e0f2bd1c6c007c06bd5fa16641cce33692e75b77..ee2cf8113dc90e443a3659dd4cebbb251b4a0b5d 100644 (file)
--- a/gcc/ada/exp_unst.adb
+++ b/gcc/ada/exp_unst.adb
@@ -251,13 +251,8 @@ package body Exp_Unst is
    -----------------------
 
    function Needs_Fat_Pointer (E : Entity_Id) return Boolean is
-      Typ : Entity_Id := Etype (E);
-
+      Typ : constant Entity_Id := Get_Fullest_View (Etype (E));
    begin
-      if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
-         Typ := Full_View (Typ);
-      end if;
-
       return Is_Array_Type (Typ) and then not Is_Constrained (Typ);
    end Needs_Fat_Pointer;
 
@@ -898,6 +893,8 @@ package body Exp_Unst is
                      DT     : Boolean := False;
                      Formal : Node_Id;
                      Subp   : Entity_Id;
+                     F_Type : Entity_Id;
+                     A_Type : Entity_Id;
 
                   begin
                      if Nkind (Name (N)) = N_Explicit_Dereference then
@@ -908,12 +905,16 @@ package body Exp_Unst is
 
                      Actual := First_Actual (N);
                      Formal := First_Formal_With_Extras (Subp);
+
                      while Present (Actual) loop
-                        if Is_Array_Type (Etype (Formal))
-                          and then not Is_Constrained (Etype (Formal))
-                          and then Is_Constrained (Etype (Actual))
+                        F_Type := Get_Fullest_View (Etype (Formal));
+                        A_Type := Get_Fullest_View (Etype (Actual));
+
+                        if Is_Array_Type (F_Type)
+                          and then not Is_Constrained (F_Type)
+                          and then Is_Constrained (A_Type)
                         then
-                           Check_Static_Type (Etype (Actual), Empty, DT);
+                           Check_Static_Type (A_Type, Empty, DT);
                         end if;
 
                         Next_Actual (Actual);

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 21098b7c057b0e4705e684416ba9d1a1d80db2dd..bcfedfb32bd886aab278fa423b58d08ad23d4921 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -3994,9 +3994,11 @@ package body Exp_Util is
           Out_Present         => True,
           Parameter_Type      => New_Occurrence_Of (Etype (Subp), Loc)));
 
-      --  The new procedure declaration is inserted immediately after the
-      --  function declaration. The processing in Build_Procedure_Body_Form
-      --  relies on this order.
+      --  The new procedure declaration is inserted before the function
+      --  declaration. The processing in Build_Procedure_Body_Form relies on
+      --  this order. Note that we insert before because in the case of a
+      --  function body with no separate spec, we do not want to insert the
+      --  new spec after the body which will later get rewritten.
 
       Proc_Decl :=
         Make_Subprogram_Declaration (Loc,
@@ -4006,7 +4008,7 @@ package body Exp_Util is
                 Make_Defining_Identifier (Loc, Chars (Subp)),
               Parameter_Specifications => Proc_Formals));
 
-      Insert_After_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl);
+      Insert_Before_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl);
 
       --  Entity of procedure must remain invisible so that it does not
       --  overload subsequent references to the original function.

diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 098b117cf840c27771049521ca85ee2b0414a980..b877b441de8b032e086c43d4030b674526f46a2c 100644 (file)
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -9225,10 +9225,12 @@ package body Freeze is
          Check_Overriding_Indicator (E, Empty, Is_Primitive (E));
       end if;
 
+      Retype := Get_Fullest_View (Etype (E));
+
       if Transform_Function_Array
         and then Nkind (Parent (E)) = N_Function_Specification
-        and then Is_Array_Type (Etype (E))
-        and then Is_Constrained (Etype (E))
+        and then Is_Array_Type (Retype)
+        and then Is_Constrained (Retype)
         and then not Is_Unchecked_Conversion_Instance (E)
         and then not Rewritten_For_C (E)
       then

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 35e13a5750a3489a85236410dc04dc941b8f37b9..9aff0f591938297f2bde93e239ffd9bd0534fe3d 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -4401,22 +4401,46 @@ package body Sem_Ch6 is
 
       if Expander_Active
         and then Transform_Function_Array
-        and then Present (Spec_Id)
-        and then Ekind (Spec_Id) = E_Function
         and then Nkind (N) /= N_Subprogram_Body_Stub
-        and then Rewritten_For_C (Spec_Id)
       then
-         Set_Has_Completion (Spec_Id);
+         declare
+            S         : constant Entity_Id :=
+                          (if Present (Spec_Id)
+                           then Spec_Id
+                           else Defining_Unit_Name (Specification (N)));
+            Proc_Body : Node_Id;
 
-         Rewrite (N, Build_Procedure_Body_Form (Spec_Id, N));
-         Analyze (N);
+         begin
+            if Ekind (S) = E_Function and then Rewritten_For_C (S) then
+               Set_Has_Completion (S);
+               Proc_Body := Build_Procedure_Body_Form (S, N);
 
-         --  The entity for the created procedure must remain invisible, so it
-         --  does not participate in resolution of subsequent references to the
-         --  function.
+               if Present (Spec_Id) then
+                  Rewrite (N, Proc_Body);
+                  Analyze (N);
 
-         Set_Is_Immediately_Visible (Corresponding_Spec (N), False);
-         goto Leave;
+                  --  The entity for the created procedure must remain
+                  --  invisible, so it does not participate in resolution of
+                  --  subsequent references to the function.
+
+                  Set_Is_Immediately_Visible (Corresponding_Spec (N), False);
+
+               --  If we do not have a separate spec for N, build one and
+               --  insert the new body right after.
+
+               else
+                  Rewrite (N,
+                    Make_Subprogram_Declaration (Loc,
+                      Specification => Relocate_Node (Specification (N))));
+                  Analyze (N);
+                  Insert_After_And_Analyze (N, Proc_Body);
+                  Set_Is_Immediately_Visible
+                    (Corresponding_Spec (Proc_Body), False);
+               end if;
+
+               goto Leave;
+            end if;
+         end;
       end if;
 
       --  If a separate spec is present, then deal with freezing issues

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 063860af48c42075426a6f985054707386030c37..c695cbc5266b6f77139d395b976245a49368a5a4 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -10589,6 +10589,12 @@ package body Sem_Util is
    function Get_Fullest_View
      (E : Entity_Id; Include_PAT : Boolean := True) return Entity_Id is
    begin
+      --  Prevent cascaded errors
+
+      if No (E) then
+         return E;
+      end if;
+
       --  Strictly speaking, the recursion below isn't necessary, but
       --  it's both simplest and safest.