This patch updates the implementation of Ada2020 delta aggregates, so they can be used in the context of a private extension of a record type.
Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ 2017-11-08 Ed Schonberg <schonb...@adacore.com> * sem_ch4.adb (Analyze_Aggregate): For Ada2020 delta aggregates, use the type of the base of the construct to determine the type (or candidate interpretations) of the delta aggregate. This allows the construct to appear in a context that expects a private extension. * sem_res.adb (Resolve): Handle properly a delta aggregate with an overloaded base. gcc/testsuite/ 2017-11-08 Ed Schonberg <schonb...@adacore.com> * gnat.dg/delta_aggr.adb: New testcase.
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;