[Ada] Implementation of AI12-0127 : delta aggregate

Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb	(revision 254542)
+++ sem_ch4.adb	(working copy)
@@ -414,12 +414,44 @@ 
    -----------------------
 
    --  Most of the analysis of Aggregates requires that the type be known,
-   --  and is therefore put off until resolution.
+   --  and is therefore put off until resolution of the context.
+   --  Delta aggregates have a base component that determines the type of the
+   --  enclosing aggregate so its type can be ascertained earlier. This also
+   --  allows delta aggregates to appear in the context of a record type with
+   --  a private extension, as per the latest update of AI2-0127.
 
    procedure Analyze_Aggregate (N : Node_Id) is
    begin
       if No (Etype (N)) then
-         Set_Etype (N, Any_Composite);
+         if Nkind (N) = N_Delta_Aggregate then
+            declare
+               Base : constant Node_Id := Expression (N);
+               I  : Interp_Index;
+               It : Interp;
+
+            begin
+               Analyze (Base);
+
+               --  If the base is overloaded, propagate interpretations
+               --  to the enclosing aggregate.
+
+               if Is_Overloaded (Base) then
+                  Get_First_Interp (Base, I, It);
+                  Set_Etype (N, Any_Type);
+
+                  while Present (It.Nam) loop
+                     Add_One_Interp (N, It.Typ, It.Typ);
+                     Get_Next_Interp (I, It);
+                  end loop;
+
+               else
+                  Set_Etype (N, Etype (Base));
+               end if;
+            end;
+
+         else
+            Set_Etype (N, Any_Composite);
+         end if;
       end if;
    end Analyze_Aggregate;
 
Index: sem_res.adb
===================================================================
--- sem_res.adb	(revision 254542)
+++ sem_res.adb	(working copy)
@@ -2439,15 +2439,13 @@ 
                   Set_Entity (N, Seen);
                   Generate_Reference (Seen, N);
 
-               elsif Nkind (N) = N_Case_Expression then
+               elsif Nkind_In (N, N_Case_Expression,
+                                  N_Character_Literal,
+                                  N_If_Expression,
+                                  N_Delta_Aggregate)
+               then
                   Set_Etype (N, Expr_Type);
 
-               elsif Nkind (N) = N_Character_Literal then
-                  Set_Etype (N, Expr_Type);
-
-               elsif Nkind (N) = N_If_Expression then
-                  Set_Etype (N, Expr_Type);
-
                --  AI05-0139-2: Expression is overloaded because type has
                --  implicit dereference. If type matches context, no implicit
                --  dereference is involved.
Index: ../testsuite/gnat.dg/delta_aggr.adb
===================================================================
--- ../testsuite/gnat.dg/delta_aggr.adb	(revision 0)
+++ ../testsuite/gnat.dg/delta_aggr.adb	(revision 0)
@@ -0,0 +1,51 @@ 
+--  { dg-do compile }
+--  { dg-options "-gnat2020" }
+
+procedure Delta_Aggr is
+   type T1 is tagged record
+      F1, F2, F3 : Integer := 0;
+   end record;
+
+   function Make (X : Integer)  return T1 is
+   begin
+      return (10, 20, 30);
+   end Make;
+
+   package Pkg is
+      type T2 is new T1 with private;
+      X, Y : constant T2;
+      function Make (X : Integer) return T2;
+   private
+      type T2 is new T1 with
+         record
+            F4 : Integer := 0;
+         end record;
+      X : constant T2 := (0, 0, 0, 0);
+      Y : constant T2 := (1, 2, 0, 0);
+   end Pkg;
+
+   package body Pkg is
+      function Make (X : Integer) return T2 is
+      begin
+         return (X, X ** 2, X ** 3, X ** 4);
+      end Make;
+   end Pkg;
+
+   use Pkg;
+
+   Z : T2 := (Y with delta F1 => 111);
+
+   -- a legal delta aggregate whose type is a private extension
+   pragma Assert (Y = (X with delta F1 => 1, F2 => 2));
+   pragma assert (Y.F2 = X.F1);
+
+begin
+   Z := (X with delta F1 => 1);
+
+   --  The base of the delta aggregate can be overloaded, in which case
+   --  the candidate interpretations for the aggregate are those of the
+   --  base, to be resolved from context.
+
+   Z := (Make (2) with delta F1 => 1);
+   null;
+end Delta_Aggr;