[Ada] Crash in tagged type constructor with task components

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

gcc/ada/

	* exp_disp.adb (Expand_Dispatching_Call): Add missing decoration
	of attribute Extra_Accessibility_Of_Result.
	* freeze.adb (Check_Extra_Formals): No check required if
	expansion is disabled; Adding check on
	Extra_Accessibilty_Of_Result.
	(Freeze_Subprogram): Fix decoration of
	Extra_Accessibility_Of_Result.
	* sem_ch3.adb (Derive_Subprogram): Fix decoration of
	Extra_Accessibility_Of_Result

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 1585998df32ec96a90b9deddb9c543950d3c8979..65d5b2a37aa6208cc59420767bd1d25f7f954dbc 100644 (file)
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1085,12 +1085,26 @@ package body Exp_Disp is
             Set_Extra_Formal (Last_Formal, New_Formal);
             Set_Extra_Formals (Subp_Typ, New_Formal);
 
+            if Ekind (Subp) = E_Function
+              and then Present (Extra_Accessibility_Of_Result (Subp))
+              and then Extra_Accessibility_Of_Result (Subp) = Old_Formal
+            then
+               Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal);
+            end if;
+
             Old_Formal := Extra_Formal (Old_Formal);
             while Present (Old_Formal) loop
                Set_Extra_Formal (New_Formal, New_Copy (Old_Formal));
                New_Formal := Extra_Formal (New_Formal);
                Set_Scope (New_Formal, Subp_Typ);
 
+               if Ekind (Subp) = E_Function
+                 and then Present (Extra_Accessibility_Of_Result (Subp))
+                 and then Extra_Accessibility_Of_Result (Subp) = Old_Formal
+               then
+                  Set_Extra_Accessibility_Of_Result (Subp_Typ, New_Formal);
+               end if;
+
                Old_Formal := Extra_Formal (Old_Formal);
             end loop;
          end if;

diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 4862c7df084816b335d123fa3b1b860fe9628d8a..57b48941c37cad0c073e5c00adf522522528a6dd 100644 (file)
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -8718,6 +8718,14 @@ package body Freeze is
          Has_Extra_Formals : Boolean := False;
 
       begin
+         --  No check required if expansion is disabled because extra
+         --  formals are only generated when we are generating code.
+         --  See Create_Extra_Formals.
+
+         if not Expander_Active then
+            return True;
+         end if;
+
          --  Check attribute Extra_Formal: if available it must be set only
          --  in the last formal of E
 
@@ -8735,6 +8743,15 @@ package body Freeze is
             Next_Formal (Formal);
          end loop;
 
+         --  Check attribute Extra_Accessibility_Of_Result
+
+         if Ekind_In (E, E_Function, E_Subprogram_Type)
+           and then Needs_Result_Accessibility_Level (E)
+           and then No (Extra_Accessibility_Of_Result (E))
+         then
+            return False;
+         end if;
+
          --  Check attribute Extra_Formals: if E has extra formals then this
          --  attribute must must point to the first extra formal of E.
 
@@ -8897,14 +8914,16 @@ package body Freeze is
             --  still unset (and must be set now).
 
             if Present (Alias (E))
+              and then Is_Frozen (Ultimate_Alias (E))
               and then Present (Extra_Formals (Ultimate_Alias (E)))
               and then Last_Formal (Ultimate_Alias (E)) = Last_Formal (E)
             then
-               pragma Assert (Is_Frozen (Ultimate_Alias (E)));
-               pragma Assert (No (First_Formal (Ultimate_Alias (E)))
-                 or else
-                   Present (Extra_Formal (Last_Formal (Ultimate_Alias (E)))));
                Set_Extra_Formals (E, Extra_Formals (Ultimate_Alias (E)));
+
+               if Ekind (E) = E_Function then
+                  Set_Extra_Accessibility_Of_Result (E,
+                    Extra_Accessibility_Of_Result (Ultimate_Alias (E)));
+               end if;
             else
                Create_Extra_Formals (E);
             end if;

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 6e0cfe2b8a8ab0284463717e158b3186dd39b205..78de3885a158b1bc0e922d5d28be3ad33a08d057 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -15563,6 +15563,11 @@ package body Sem_Ch3 is
 
       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));
+      end if;
+
       --  If this derivation corresponds to a tagged generic actual, then
       --  primitive operations rename those of the actual. Otherwise the
       --  primitive operations rename those of the parent type, If the parent