[Ada] Revert "Enforce matching of extra formals"

This reverts commit 51abc0cc8691daecd7cec8372e4988e9f3f1913c.

1 files changed, 86 insertions, 17 deletions

diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 3adc255..52858e2 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -4979,7 +4979,6 @@ package body Freeze is
               and then Convention (Desig) /= Convention_Protected
             then
                Set_Is_Frozen (Desig);
-               Create_Extra_Formals (Desig);
             end if;
          end Check_Itype;
 
@@ -8238,7 +8237,7 @@ package body Freeze is
             if Present (Nam)
               and then Ekind (Nam) = E_Function
               and then Nkind (Parent (N)) = N_Function_Call
-              and then not Has_Foreign_Convention (Nam)
+              and then Convention (Nam) = Convention_Ada
             then
                Create_Extra_Formals (Nam);
             end if;
@@ -9845,11 +9844,77 @@ package body Freeze is
    -----------------------
 
    procedure Freeze_Subprogram (E : Entity_Id) is
+      function Check_Extra_Formals (E : Entity_Id) return Boolean;
+      --  Return True if the decoration of the attributes associated with extra
+      --  formals are properly set.
 
       procedure Set_Profile_Convention (Subp_Id : Entity_Id);
       --  Set the conventions of all anonymous access-to-subprogram formals and
       --  result subtype of subprogram Subp_Id to the convention of Subp_Id.
 
+      -------------------------
+      -- Check_Extra_Formals --
+      -------------------------
+
+      function Check_Extra_Formals (E : Entity_Id) return Boolean is
+         Last_Formal       : Entity_Id := Empty;
+         Formal            : Entity_Id;
+         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
+         --  on the last formal of E.
+
+         Formal := First_Formal (E);
+         while Present (Formal) loop
+            if Present (Extra_Formal (Formal)) then
+               if Has_Extra_Formals then
+                  return False;
+               end if;
+
+               Has_Extra_Formals := True;
+            end if;
+
+            Last_Formal := Formal;
+            Next_Formal (Formal);
+         end loop;
+
+         --  Check attribute Extra_Accessibility_Of_Result
+
+         if Ekind (E) in 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 point to the first extra formal of E.
+
+         if Has_Extra_Formals then
+            return Present (Extra_Formals (E))
+              and then Present (Extra_Formal (Last_Formal))
+              and then Extra_Formal (Last_Formal) = Extra_Formals (E);
+
+         --  When E has no formals, the first extra formal is available through
+         --  the Extra_Formals attribute.
+
+         elsif Present (Extra_Formals (E)) then
+            return No (First_Formal (E));
+
+         else
+            return True;
+         end if;
+      end Check_Extra_Formals;
+
       ----------------------------
       -- Set_Profile_Convention --
       ----------------------------
@@ -9988,26 +10053,30 @@ package body Freeze is
       --  that we know the convention.
 
       if not Has_Foreign_Convention (E) then
+         if No (Extra_Formals (E)) then
 
-         --  Extra formals of dispatching operations are added later by
-         --  Expand_Freeze_Record_Type, which also adds extra formals to
-         --  internal entities built to handle interface types.
+            --  Extra formals are shared by derived subprograms; therefore, if
+            --  the ultimate alias of E has been frozen before E then the extra
+            --  formals have been added, but the attribute Extra_Formals is
+            --  still unset (and must be set now).
 
-         if not Is_Dispatching_Operation (E) then
-            Create_Extra_Formals (E);
+            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
+               Set_Extra_Formals (E, Extra_Formals (Ultimate_Alias (E)));
 
-            pragma Assert
-              ((Ekind (E) = E_Subprogram_Type
-                  and then Extra_Formals_OK (E))
-               or else
-                 (Is_Subprogram (E)
-                   and then Extra_Formals_OK (E)
-                   and then
-                     (No (Overridden_Operation (E))
-                       or else Extra_Formals_Match_OK (E,
-                                 Ultimate_Alias (Overridden_Operation (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;
          end if;
 
+         pragma Assert (Check_Extra_Formals (E));
          Set_Mechanisms (E);
 
          --  If this is convention Ada and a Valued_Procedure, that's odd