Ada: Fix illegal Aggregate aspect not rejected

The Ada 2022 RM is adamant that the names specified in the Aggregate aspect
must denote "exactly one" subprogram, in other words that it is illegal to
use names that denote more than one subprogram in the Aggregate aspect.

gcc/ada/
	PR ada/123289
	* sem_ch13.adb (Resolve_Aspect_Aggregate.Resolve_Operation): Give
	an error if the operation's name denotes more than one subprogram.

gcc/testsuite/
	* gnat.dg/specs/aggr9.ads: New test.

diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index a4c97cd05f01f4d69a94dfbd938175b51b993be1..04f9efc66c55bf8b3b12f7753fa3fc99c1bd8179 100644 (file)
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -18234,15 +18234,12 @@ package body Sem_Ch13 is
       -----------------------
 
       procedure Resolve_Operation (Subp_Id : Node_Id) is
-         Subp : Entity_Id;
-
          I  : Interp_Index;
          It : Interp;
 
       begin
          if not Is_Overloaded (Subp_Id) then
-            Subp := Entity (Subp_Id);
-            if not Pred (Subp) then
+            if not Pred (Entity (Subp_Id)) then
                Error_Msg_NE
                  ("improper aggregate operation for&", Subp_Id, Typ);
             end if;
@@ -18252,9 +18249,21 @@ package body Sem_Ch13 is
             Get_First_Interp (Subp_Id, I, It);
             while Present (It.Nam) loop
                if Pred (It.Nam) then
+                  if Present (Entity (Subp_Id)) then
+                     --  ??? Cope with the obsolete renaming of Append_Vector
+                     --  in Ada.Containers.Vectors retained for compatibility.
+
+                     if No (Alias (Entity (Subp_Id)))
+                       and then No (Alias (It.Nam))
+                     then
+                        Error_Msg_N
+                          ("& must denote exactly one subprogram", Subp_Id);
+                     end if;
+
+                     exit;
+                  end if;
                   Set_Is_Overloaded (Subp_Id, False);
                   Set_Entity (Subp_Id, It.Nam);
-                  exit;
                end if;
 
                Get_Next_Interp (I, It);

diff --git a/gcc/testsuite/gnat.dg/specs/aggr9.ads b/gcc/testsuite/gnat.dg/specs/aggr9.ads
new file mode 100644 (file)
index 0000000..50677de
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/aggr9.ads
@@ -0,0 +1,26 @@
+-- PR ada/123289
+-- { dg-do compile }
+-- { dg-options "-gnat2022" }
+
+package Aggr9 is
+
+   type JSON_Value is tagged null record;
+   type JSON_Object is new JSON_Value with null record
+     with Aggregate => (Empty => Empty, Add_Named => Insert); -- { dg-error "exactly one" }
+   type JSON_Integer is new JSON_Value with null record
+     with Integer_Literal => From_Universal_Image;
+
+   function Empty return JSON_Object
+   is (null record);
+
+   procedure Insert
+      (O : in out JSON_Object; Key : String; Value : JSON_Integer'Class)
+   is null;
+
+   procedure Insert (O : in out JSON_Object; Key : String; Value : String)
+   is null;
+
+   function From_Universal_Image (Value : String) return JSON_Integer
+   is (null record);
+
+end Aggr9;