From: Eric Botcazou <ebotcazou@gcc.gnu.org>
Date: Fri, 26 Dec 2025 09:44:57 +0000 (+0100)
Subject: Ada: Fix illegal Aggregate aspect not rejected
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=5cdb2a59308c9539b23e945c7f5f48743520e476;p=thirdparty%2Fgcc.git

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 a4c97cd05f0..04f9efc66c5 100644
--- 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
index 00000000000..50677de750b
--- /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;