===================================================================
@@ -418,6 +418,13 @@
-- array of characters is expected. This procedure simply rewrites the
-- string as an aggregate, prior to resolution.
+ ---------------------------------
+ -- Delta aggregate processing --
+ ---------------------------------
+
+ procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id);
+
------------------------
-- Array_Aggr_Subtype --
------------------------
@@ -2759,143 +2766,278 @@
procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is
Base : constant Node_Id := Expression (N);
+
+ begin
+ if not Is_Composite_Type (Typ) then
+ Error_Msg_N ("not a composite type", N);
+ end if;
+
+ Analyze_And_Resolve (Base, Typ);
+
+ if Is_Array_Type (Typ) then
+ Resolve_Delta_Array_Aggregate (N, Typ);
+ else
+ Resolve_Delta_Record_Aggregate (N, Typ);
+ end if;
+
+ Set_Etype (N, Typ);
+ end Resolve_Delta_Aggregate;
+
+ -----------------------------------
+ -- Resolve_Delta_Array_Aggregate --
+ -----------------------------------
+
+ procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id) is
Deltas : constant List_Id := Component_Associations (N);
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Index_Type : Entity_Id;
- function Get_Component_Type (Nam : Node_Id) return Entity_Id;
+ begin
+ Index_Type := Etype (First_Index (Typ));
+ Assoc := First (Deltas);
+ while Present (Assoc) loop
+ if Nkind (Assoc) = N_Iterated_Component_Association then
+ Choice := First (Choice_List (Assoc));
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Others_Choice then
+ Error_Msg_N
+ ("others not allowed in delta aggregate", Choice);
- ------------------------
- -- Get_Component_Type --
- ------------------------
+ else
+ Analyze_And_Resolve (Choice, Index_Type);
+ end if;
- function Get_Component_Type (Nam : Node_Id) return Entity_Id is
- Comp : Entity_Id;
+ Next (Choice);
+ end loop;
- begin
- Comp := First_Entity (Typ);
+ declare
+ Id : constant Entity_Id := Defining_Identifier (Assoc);
+ Ent : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Loop, Current_Scope, Sloc (Assoc), 'L');
- while Present (Comp) loop
- if Chars (Comp) = Chars (Nam) then
- if Ekind (Comp) = E_Discriminant then
- Error_Msg_N ("delta cannot apply to discriminant", Nam);
+ begin
+ Set_Etype (Ent, Standard_Void_Type);
+ Set_Parent (Ent, Assoc);
+
+ if No (Scope (Id)) then
+ Enter_Name (Id);
+ Set_Etype (Id, Index_Type);
+ Set_Ekind (Id, E_Variable);
+ Set_Scope (Id, Ent);
end if;
- return Etype (Comp);
- end if;
+ Push_Scope (Ent);
+ Analyze_And_Resolve
+ (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ));
+ End_Scope;
+ end;
- Comp := Next_Entity (Comp);
- end loop;
+ else
+ Choice := First (Choice_List (Assoc));
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Others_Choice then
+ Error_Msg_N
+ ("others not allowed in delta aggregate", Choice);
- Error_Msg_NE ("type& has no component with this name", Nam, Typ);
- return Any_Type;
- end Get_Component_Type;
+ else
+ Analyze (Choice);
+ if Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ then
+ -- Choice covers a range of values.
+ if Base_Type (Entity (Choice)) /=
+ Base_Type (Index_Type)
+ then
+ Error_Msg_NE
+ ("choice does mat match index type of",
+ Choice, Typ);
+ end if;
+ else
+ Resolve (Choice, Index_Type);
+ end if;
+ end if;
- -- Local variables
+ Next (Choice);
+ end loop;
+ Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ));
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end Resolve_Delta_Array_Aggregate;
+
+ ------------------------------------
+ -- Resolve_Delta_Record_Aggregate --
+ ------------------------------------
+
+ procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ Deltas : constant List_Id := Component_Associations (N);
Assoc : Node_Id;
Choice : Node_Id;
Comp_Type : Entity_Id;
- Index_Type : Entity_Id;
- -- Start of processing for Resolve_Delta_Aggregate
+ -- Variables used to verify that discriminant-dependent components
+ -- appear in the same variant.
- begin
- if not Is_Composite_Type (Typ) then
- Error_Msg_N ("not a composite type", N);
- end if;
+ Variant : Node_Id;
+ Comp_Ref : Entity_Id;
- Analyze_And_Resolve (Base, Typ);
+ procedure Check_Variant (Id : Entity_Id);
+ -- If a given component of the delta aggregate appears in a variant
+ -- part, verify that it is within the same variant as that of previous
+ -- specified variant components of the delta.
- if Is_Array_Type (Typ) then
- Index_Type := Etype (First_Index (Typ));
- Assoc := First (Deltas);
- while Present (Assoc) loop
- if Nkind (Assoc) = N_Iterated_Component_Association then
- Choice := First (Choice_List (Assoc));
- while Present (Choice) loop
- if Nkind (Choice) = N_Others_Choice then
- Error_Msg_N
- ("others not allowed in delta aggregate", Choice);
+ function Nested_In (V1, V2 : Node_Id) return Boolean;
+ -- Determine whether variant V1 is within variant V2.
- else
- Analyze_And_Resolve (Choice, Index_Type);
- end if;
+ function Get_Component_Type (Nam : Node_Id) return Entity_Id;
+ -- Locate component with a given name and return its type. If none
+ -- found report error.
- Next (Choice);
- end loop;
+ function Variant_Depth (N : Node_Id) return Integer;
+ -- Determine the distance of a variant to the enclosing type
+ -- declaration.
+ --------------------
+ -- Check_Variant --
+ --------------------
+
+ procedure Check_Variant (Id : Entity_Id) is
+ Comp : Entity_Id;
+ Comp_Variant : Node_Id;
+
+ begin
+ if not Has_Discriminants (Typ) then
+ return;
+ end if;
+
+ Comp := First_Entity (Typ);
+ while Present (Comp) loop
+ exit when Chars (Comp) = Chars (Id);
+ Next_Component (Comp);
+ end loop;
+
+ -- Find the variant, if any, whose component list includes the
+ -- component declaration.
+
+ Comp_Variant := Parent (Parent (List_Containing (Parent (Comp))));
+ if Nkind (Comp_Variant) = N_Variant then
+ if No (Variant) then
+ Variant := Comp_Variant;
+ Comp_Ref := Comp;
+
+ elsif Variant /= Comp_Variant then
declare
- Id : constant Entity_Id := Defining_Identifier (Assoc);
- Ent : constant Entity_Id :=
- New_Internal_Entity
- (E_Loop, Current_Scope, Sloc (Assoc), 'L');
+ D1 : constant Integer := Variant_Depth (Variant);
+ D2 : constant Integer := Variant_Depth (Comp_Variant);
begin
- Set_Etype (Ent, Standard_Void_Type);
- Set_Parent (Ent, Assoc);
+ if D1 = D2
+ or else
+ (D1 > D2 and then not Nested_In (Variant, Comp_Variant))
+ or else
+ (D2 > D1 and then not Nested_In (Comp_Variant, Variant))
+ then
+ Error_Msg_Node_2 := Comp_Ref;
+ Error_Msg_NE
+ ("& and & appear in different variants", Id, Comp);
- if No (Scope (Id)) then
- Enter_Name (Id);
- Set_Etype (Id, Index_Type);
- Set_Ekind (Id, E_Variable);
- Set_Scope (Id, Ent);
+ -- Otherwise retain the deeper variant for subsequent tests
+
+ elsif D2 > D1 then
+ Variant := Comp_Variant;
end if;
-
- Push_Scope (Ent);
- Analyze_And_Resolve
- (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ));
- End_Scope;
end;
+ end if;
+ end if;
+ end Check_Variant;
- else
- Choice := First (Choice_List (Assoc));
- while Present (Choice) loop
- if Nkind (Choice) = N_Others_Choice then
- Error_Msg_N
- ("others not allowed in delta aggregate", Choice);
+ ---------------
+ -- Nested_In --
+ ---------------
- else
- Analyze (Choice);
- if Is_Entity_Name (Choice)
- and then Is_Type (Entity (Choice))
- then
- -- Choice covers a range of values.
- if Base_Type (Entity (Choice)) /=
- Base_Type (Index_Type)
- then
- Error_Msg_NE
- ("choice does mat match index type of",
- Choice, Typ);
- end if;
- else
- Resolve (Choice, Index_Type);
- end if;
- end if;
+ function Nested_In (V1, V2 : Node_Id) return Boolean is
+ Par : Node_Id;
+ begin
+ Par := Parent (V1);
+ while Nkind (Par) /= N_Full_Type_Declaration loop
+ if Par = V2 then
+ return True;
+ end if;
+ Par := Parent (Par);
+ end loop;
- Next (Choice);
- end loop;
+ return False;
+ end Nested_In;
- Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ));
+ -------------------
+ -- Variant_Depth --
+ -------------------
+
+ function Variant_Depth (N : Node_Id) return Integer is
+ Depth : Integer;
+ Par : Node_Id;
+ begin
+ Depth := 0;
+ Par := Parent (N);
+ while Nkind (Par) /= N_Full_Type_Declaration loop
+ Depth := Depth + 1;
+ Par := Parent (Par);
+ end loop;
+
+ return Depth;
+ end Variant_Depth;
+
+ ------------------------
+ -- Get_Component_Type --
+ ------------------------
+
+ function Get_Component_Type (Nam : Node_Id) return Entity_Id is
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Entity (Typ);
+
+ while Present (Comp) loop
+ if Chars (Comp) = Chars (Nam) then
+ if Ekind (Comp) = E_Discriminant then
+ Error_Msg_N ("delta cannot apply to discriminant", Nam);
+ end if;
+
+ return Etype (Comp);
end if;
- Next (Assoc);
+ Comp := Next_Entity (Comp);
end loop;
- else
- Assoc := First (Deltas);
- while Present (Assoc) loop
- Choice := First (Choice_List (Assoc));
- while Present (Choice) loop
- Comp_Type := Get_Component_Type (Choice);
- Next (Choice);
- end loop;
+ Error_Msg_NE ("type& has no component with this name", Nam, Typ);
+ return Any_Type;
+ end Get_Component_Type;
- Analyze_And_Resolve (Expression (Assoc), Comp_Type);
- Next (Assoc);
+ -- Start of processing for Resolve_Delta_Record_Aggregate
+
+ begin
+ Variant := Empty;
+ Assoc := First (Deltas);
+
+ while Present (Assoc) loop
+ Choice := First (Choice_List (Assoc));
+ while Present (Choice) loop
+ Comp_Type := Get_Component_Type (Choice);
+ if Comp_Type /= Any_Type then
+ Check_Variant (Choice);
+ end if;
+
+ Next (Choice);
end loop;
- end if;
- Set_Etype (N, Typ);
- end Resolve_Delta_Aggregate;
+ Analyze_And_Resolve (Expression (Assoc), Comp_Type);
+ Next (Assoc);
+ end loop;
+ end Resolve_Delta_Record_Aggregate;
---------------------------------
-- Resolve_Extension_Aggregate --
This patch updates the implementation of Ada2020 delta aggregatesa to conform to the latest version of AI12-0127. this patch adds checks to reject statically delta aggregates that specify values for components that appear in different variants of a record type. Compiling test2.adb in Ada2020 mode must yield: test2.adb:31:51: "F3" and "F4" appear in different variants test2.adb:32:51: "F3" and "F2" appear in different variants test2.adb:33:39: "F3" and "F2" appear in different variants test2.adb:34:39: type subtype of "T" has no component with this name --- procedure Test2 is type T (Disc1, Disc2 : Boolean := True) is record F1 : Integer; case Disc1 is when False => F4 : Float; case Disc2 is when False => null; when True => F2 : Integer; end case; when True => case Disc2 is when False => null; when True => F3 : Integer; end case; end case; end record; procedure Munge (X : in out T) is begin -- illegal aggregate; F2 and F3 are declared within (albeit not -- immediately within) different variants of the same variant -- part. X := (X with delta F2 => 123, F1 => 456); -- OK X := (X with delta F2 => 123, F4 => 3.14); -- OK X := (X with delta F4 => 3.14, F2 => 444, F3 => 0); -- ERROR X := (X with delta F2 => 314, F4 => 4.44, F3 => 0); -- ERROR X := (X with delta F2 => 123, F3 => 456); -- ERROR X := (X with delta F2 => 123, F5 => 456); -- ERROR end Munge; X : T; begin Munge (X); end Test2; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-11-08 Ed Schonberg <schonberg@adacore.com> * sem_aggr.adb (Resolve_Delta_Aggregate): Divide into the following separate procedures. (Resolve_Delta_Array_Aggregate): Previous code form Resolve_Delta_Aggregate. (Resolve_Delta_Record_Aggregate): Extend previous code to cover latest ARG decisions on the legality rules for delta aggregates for records: in the case of a variant record, components from different variants cannot be specified in the delta aggregate, and this must be checked statically.