[Ada] Crash in tagged type constructor with task components

2020-06-18  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_ch6.adb (BIP_Suffix_Kind, Is_Build_In_Place_Entity): Move
	declarations...
	* exp_ch6.ads: Here.
	* exp_util.adb (Is_Secondary_Stack_BIP_Func_Call): Do not rely
	on the name of the scope to locate the extra formal BIPalloc
	since they are copied when the pointer type associated with
	dispatching calls is built; rely on routines
	Is_Build_In_Place_Entity and BIP_Suffix_Kind.
	* exp_disp.adb (Expand_Dispatching_Call): Set the scope of the
	first extra formal of the internally built pointer type.
	* sem_ch3.adb (Derive_Subprogram): Do not inherit extra formals
	from a limited interface parent since limitedness is not
	inherited in such case (AI-419) and this affects the extra
	formals.
	* sprint.adb (Write_Itype): Output extra formals of subprogram
	types.

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 00a0aef0631586d9144563a68daf875e9d338417..3562193afc73701d6bc57028b2db65bc63ade01e 100644 (file)
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -156,9 +156,6 @@ package body Exp_Ch6 is
    --  level is known not to be statically deeper than the result type of the
    --  function.
 
-   function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind;
-   --  Ada 2005 (AI-318-02): Returns the kind of the given extra formal.
-
    function Caller_Known_Size
      (Func_Call   : Node_Id;
       Result_Subt : Entity_Id) return Boolean;
@@ -285,9 +282,6 @@ package body Exp_Ch6 is
    --  Insert the Post_Call list previously produced by routine Expand_Actuals
    --  or Expand_Call_Helper into the tree.
 
-   function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean;
-   --  Ada 2005 (AI-318-02): Returns True if E is a BIP entity.
-
    procedure Replace_Renaming_Declaration_Id
       (New_Decl  : Node_Id;
        Orig_Decl : Node_Id);

diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads
index 1c30219cbada67783e9abf991391eae8900af216..69b19090102ba257703b9ce9394b2a145dfb177e 100644 (file)
--- a/gcc/ada/exp_ch6.ads
+++ b/gcc/ada/exp_ch6.ads
@@ -102,6 +102,9 @@ package Exp_Ch6 is
    --  Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names
    --  for build-in-place formal parameters of the given kind.
 
+   function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind;
+   --  Ada 2005 (AI-318-02): Returns the kind of the given BIP extra formal.
+
    function Build_In_Place_Formal
      (Func : Entity_Id;
       Kind : BIP_Formal_Kind) return Entity_Id;
@@ -117,6 +120,9 @@ package Exp_Ch6 is
    --  The returned node is the root of the procedure body which will replace
    --  the original function body, which is not needed for the C program.
 
+   function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean;
+   --  Ada 2005 (AI-318-02): Returns True if E is a BIP entity.
+
    function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean;
    --  Ada 2005 (AI-318-02): Returns True if functions returning the type use
    --  build-in-place protocols. For inherently limited types, this must be

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 65d5b2a37aa6208cc59420767bd1d25f7f954dbc..89f206ed09ff2653ad4611b21497fc3951dca15f 100644 (file)
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1081,6 +1081,7 @@ package body Exp_Disp is
          then
             Old_Formal := Extra_Formal (Last_Formal);
             New_Formal := New_Copy (Old_Formal);
+            Set_Scope (New_Formal, Subp_Typ);
 
             Set_Extra_Formal (Last_Formal, New_Formal);
             Set_Extra_Formals (Subp_Typ, New_Formal);

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 537f0fc2490b4809d52c320d21707b8af0834028..d93788b8e5ba884183293a5976ac3f84ca338ef7 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -8829,7 +8829,6 @@ package body Exp_Util is
    --------------------------------------
 
    function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
-      Alloc_Nam : Name_Id := No_Name;
       Actual    : Node_Id;
       Call      : Node_Id := Expr;
       Formal    : Node_Id;
@@ -8856,20 +8855,10 @@ package body Exp_Util is
                Formal := Selector_Name (Param);
                Actual := Explicit_Actual_Parameter (Param);
 
-               --  Construct the name of formal BIPalloc. It is much easier to
-               --  extract the name of the function using an arbitrary formal's
-               --  scope rather than the Name field of Call.
-
-               if Alloc_Nam = No_Name and then Present (Entity (Formal)) then
-                  Alloc_Nam :=
-                    New_External_Name
-                      (Chars (Scope (Entity (Formal))),
-                       BIP_Formal_Suffix (BIP_Alloc_Form));
-               end if;
-
                --  A match for BIPalloc => 2 has been found
 
-               if Chars (Formal) = Alloc_Nam
+               if Is_Build_In_Place_Entity (Formal)
+                 and then BIP_Suffix_Kind (Formal) = BIP_Alloc_Form
                  and then Nkind (Actual) = N_Integer_Literal
                  and then Intval (Actual) = Uint_2
                then

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 04060baa11e25128ca7f4651232ac15857711928..8bb62c7a60a00af4b682c989d66bacc04b6ecdcb 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -15539,6 +15539,15 @@ package body Sem_Ch3 is
       while Present (Formal) loop
          New_Formal := New_Copy (Formal);
 
+         --  Extra formals are not inherited from a limited interface parent
+         --  since limitedness is not inherited in such case (AI-419) and this
+         --  affects the extra formals.
+
+         if Is_Limited_Interface (Parent_Type) then
+            Set_Extra_Formal (New_Formal, Empty);
+            Set_Extra_Accessibility (New_Formal, Empty);
+         end if;
+
          --  Normally we do not go copying parents, but in the case of
          --  formals, we need to link up to the declaration (which is the
          --  parameter specification), and it is fine to link up to the
@@ -15558,14 +15567,19 @@ package body Sem_Ch3 is
       end loop;
 
       --  Extra formals are shared between the parent subprogram and the
-      --  derived subprogram (implicit in the above copy of formals), and
-      --  hence we must inherit also the reference to the first extra formal.
+      --  derived subprogram (implicit in the above copy of formals), unless
+      --  the parent type is a limited interface type; hence we must inherit
+      --  also the reference to the first extra formal. When the parent type is
+      --  an interface the extra formals will be added when the subprogram is
+      --  frozen (see Freeze.Freeze_Subprogram).
 
-      Set_Extra_Formals (New_Subp, Extra_Formals (Parent_Subp));
+      if not Is_Limited_Interface (Parent_Type) then
+         Set_Extra_Formals (New_Subp, Extra_Formals (Parent_Subp));
 
-      if Ekind (New_Subp) = E_Function then
-         Set_Extra_Accessibility_Of_Result (New_Subp,
-           Extra_Accessibility_Of_Result (Parent_Subp));
+         if Ekind (New_Subp) = E_Function then
+            Set_Extra_Accessibility_Of_Result (New_Subp,
+              Extra_Accessibility_Of_Result (Parent_Subp));
+         end if;
       end if;
 
       --  If this derivation corresponds to a tagged generic actual, then

diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index f177981de70f7478b6012e3d68f019b7084285d5..7bfa5017019537599af6676485689b51966535e0 100644 (file)
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -4489,6 +4489,43 @@ package body Sprint is
                               Write_Str (", ");
                            end loop;
 
+                           if Present (Extra_Formals (Typ)) then
+                              Param := Extra_Formals (Typ);
+
+                              while Present (Param) loop
+                                 Write_Str (", ");
+                                 Write_Id (Param);
+                                 Write_Str (" : ");
+                                 Write_Id (Etype (Param));
+
+                                 Param := Extra_Formal (Param);
+                              end loop;
+                           end if;
+
+                           Write_Char (')');
+                        end;
+
+                     elsif Present (Extra_Formals (Typ)) then
+                        declare
+                           Param : Entity_Id;
+
+                        begin
+                           Write_Str (" (");
+
+                           Param := Extra_Formals (Typ);
+
+                           while Present (Param) loop
+                              Write_Id (Param);
+                              Write_Str (" : ");
+                              Write_Id (Etype (Param));
+
+                              if Present (Extra_Formal (Param)) then
+                                 Write_Str (", ");
+                              end if;
+
+                              Param := Extra_Formal (Param);
+                           end loop;
+
                            Write_Char (')');
                         end;
                      end if;