+ if Present (Add_Unnamed_Subp)
+ and then No (New_Indexed_Subp)
+ then
+ declare
+ Elmt_Type : constant Entity_Id :=
+ Etype (Next_Formal
+ (First_Formal (Entity (Add_Unnamed_Subp))));
+ Comp : Node_Id;
+
+ begin
+ if Present (Expressions (N)) then
+ -- positional aggregate
+
+ Comp := First (Expressions (N));
+ while Present (Comp) loop
+ Analyze_And_Resolve (Comp, Elmt_Type);
+ Next (Comp);
+ end loop;
+ end if;
+
+ -- Empty aggregate, to be replaced by Empty during
+ -- expansion, or iterated component association.
+
+ if Present (Component_Associations (N)) then
+ declare
+ Comp : Node_Id := First (Component_Associations (N));
+ begin
+ while Present (Comp) loop
+ if Nkind (Comp) /=
+ N_Iterated_Component_Association
+ then
+ Error_Msg_N ("illegal component association "
+ & "for unnamed container aggregate", Comp);
+ return;
+ else
+ Resolve_Iterated_Association
+ (Comp, Empty, Elmt_Type);
+ end if;
+
+ Next (Comp);
+ end loop;
+ end;
+ end if;
+ end;
+
+ elsif Present (Add_Named_Subp) then
+ declare
+ -- Retrieves types of container, key, and element from the
+ -- specified insertion procedure.
+
+ Container : constant Entity_Id :=
+ First_Formal (Entity (Add_Named_Subp));
+ Key_Type : constant Entity_Id := Etype (Next_Formal (Container));
+ Elmt_Type : constant Entity_Id :=
+ Etype (Next_Formal (Next_Formal (Container)));
+ Comp : Node_Id;
+ Choice : Node_Id;
+
+ begin
+ Comp := First (Component_Associations (N));
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Component_Association then
+ Choice := First (Choices (Comp));
+
+ while Present (Choice) loop
+ Analyze_And_Resolve (Choice, Key_Type);
+ if not Is_Static_Expression (Choice) then
+ Error_Msg_N ("Choice must be static", Choice);
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ Analyze_And_Resolve (Expression (Comp), Elmt_Type);
+
+ elsif Nkind (Comp) in
+ N_Iterated_Component_Association |
+ N_Iterated_Element_Association
+ then
+ Resolve_Iterated_Association
+ (Comp, Key_Type, Elmt_Type);
+ end if;
+
+ Next (Comp);
+ end loop;
+ end;
+
+ else
+ -- Indexed Aggregate. Positional or indexed component
+ -- can be present, but not both. Choices must be static
+ -- values or ranges with static bounds.
+
+ declare
+ Container : constant Entity_Id :=
+ First_Formal (Entity (Assign_Indexed_Subp));
+ Index_Type : constant Entity_Id := Etype (Next_Formal (Container));
+ Comp_Type : constant Entity_Id :=
+ Etype (Next_Formal (Next_Formal (Container)));
+ Comp : Node_Id;
+ Choice : Node_Id;
+
+ begin
+ if Present (Expressions (N)) then
+ Comp := First (Expressions (N));
+ while Present (Comp) loop
+ Analyze_And_Resolve (Comp, Comp_Type);
+ Next (Comp);
+ end loop;
+ end if;
+
+ if Present (Component_Associations (N)) then
+ if Present (Expressions (N)) then
+ Error_Msg_N ("Container aggregate cannot be "
+ & "both positional and named", N);
+ return;
+ end if;
+
+ Comp := First (Expressions (N));
+
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Component_Association then
+ Choice := First (Choices (Comp));
+
+ while Present (Choice) loop
+ Analyze_And_Resolve (Choice, Index_Type);
+ Next (Choice);
+ end loop;
+
+ Analyze_And_Resolve (Expression (Comp), Comp_Type);
+
+ elsif Nkind (Comp) in
+ N_Iterated_Component_Association |
+ N_Iterated_Element_Association
+ then
+ Resolve_Iterated_Association
+ (Comp, Index_Type, Comp_Type);
+ end if;
+
+ Next (Comp);
+ end loop;
+ end if;
+ end;
+ end if;
+ end Resolve_Container_Aggregate;
+
+ -----------------------------
+ -- Resolve_Delta_Aggregate --
+ -----------------------------
+
+ procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ Base : constant Node_Id := Expression (N);
+
+ begin
+ if Ada_Version < Ada_2020 then
+ Error_Msg_N ("delta_aggregate is an Ada 202x feature", N);
+ Error_Msg_N ("\compile with -gnat2020", N);
+ end if;
+
+ 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);
+ Index_Type : constant Entity_Id := Etype (First_Index (Typ));
+
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Expr : Node_Id;
+
+ begin
+ 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);
+
+ else
+ Analyze_And_Resolve (Choice, Index_Type);
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ declare
+ Id : constant Entity_Id := Defining_Identifier (Assoc);
+ Ent : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Loop, Current_Scope, Sloc (Assoc), 'L');
+
+ begin
+ Set_Etype (Ent, Standard_Void_Type);
+ Set_Parent (Ent, Assoc);
+ Push_Scope (Ent);
+
+ if No (Scope (Id)) then
+ Set_Etype (Id, Index_Type);
+ Set_Ekind (Id, E_Variable);
+ Set_Scope (Id, Ent);
+ end if;
+ Enter_Name (Id);
+
+ -- Resolve a copy of the expression, after setting
+ -- its parent properly to preserve its context.
+
+ Expr := New_Copy_Tree (Expression (Assoc));
+ Set_Parent (Expr, Assoc);
+ Analyze_And_Resolve (Expr, Component_Type (Typ));
+ End_Scope;
+ end;
+
+ 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);
+
+ 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 not match index type of &",
+ Choice, Typ);
+ end if;
+ else
+ Resolve (Choice, Index_Type);
+ end if;
+ end if;
+
+ 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
+
+ -- Variables used to verify that discriminant-dependent components
+ -- appear in the same variant.
+
+ Comp_Ref : Entity_Id := Empty; -- init to avoid warning
+ Variant : Node_Id;
+
+ 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.
+
+ function Get_Component (Nam : Node_Id) return Entity_Id;
+ -- Locate component with a given name and return it. If none found then
+ -- report error and return Empty.
+
+ function Nested_In (V1 : Node_Id; V2 : Node_Id) return Boolean;
+ -- Determine whether variant V1 is within variant V2
+
+ 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
+ D1 : constant Integer := Variant_Depth (Variant);
+ D2 : constant Integer := Variant_Depth (Comp_Variant);
+
+ begin
+ 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
+ pragma Assert (Present (Comp_Ref));
+ Error_Msg_Node_2 := Comp_Ref;
+ Error_Msg_NE
+ ("& and & appear in different variants", Id, Comp);
+
+ -- Otherwise retain the deeper variant for subsequent tests
+
+ elsif D2 > D1 then
+ Variant := Comp_Variant;
+ end if;
+ end;
+ end if;
+ end if;
+ end Check_Variant;
+
+ -------------------
+ -- Get_Component --
+ -------------------
+
+ function Get_Component (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 Comp;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+
+ Error_Msg_NE ("type& has no component with this name", Nam, Typ);
+ return Empty;
+ end Get_Component;
+
+ ---------------
+ -- Nested_In --
+ ---------------
+
+ 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;
+
+ return False;
+ end Nested_In;
+
+ -------------------
+ -- 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;
+
+ -- Local variables
+
+ Deltas : constant List_Id := Component_Associations (N);
+
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Comp : Entity_Id;
+ Comp_Type : Entity_Id := Empty; -- init to avoid warning
+
+ -- 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 := Get_Component (Choice);
+
+ if Present (Comp) then
+ Check_Variant (Choice);
+
+ Comp_Type := Etype (Comp);
+
+ -- Decorate the component reference by setting its entity and
+ -- type, as otherwise backends like GNATprove would have to
+ -- rediscover this information by themselves.
+
+ Set_Entity (Choice, Comp);
+ Set_Etype (Choice, Comp_Type);
+ else
+ Comp_Type := Any_Type;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ pragma Assert (Present (Comp_Type));
+ Analyze_And_Resolve (Expression (Assoc), Comp_Type);
+ Next (Assoc);
+ end loop;
+ end Resolve_Delta_Record_Aggregate;
+
+ ---------------------------------
+ -- Resolve_Extension_Aggregate --
+ ---------------------------------
+
+ -- There are two cases to consider:
+
+ -- a) If the ancestor part is a type mark, the components needed are the
+ -- difference between the components of the expected type and the
+ -- components of the given type mark.
+
+ -- b) If the ancestor part is an expression, it must be unambiguous, and
+ -- once we have its type we can also compute the needed components as in
+ -- the previous case. In both cases, if the ancestor type is not the
+ -- immediate ancestor, we have to build this ancestor recursively.
+
+ -- In both cases, discriminants of the ancestor type do not play a role in
+ -- the resolution of the needed components, because inherited discriminants
+ -- cannot be used in a type extension. As a result we can compute
+ -- independently the list of components of the ancestor type and of the
+ -- expected type.
+
+ procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ A : constant Node_Id := Ancestor_Part (N);
+ A_Type : Entity_Id;
+ I : Interp_Index;
+ It : Interp;
+
+ function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean;
+ -- If the type is limited, verify that the ancestor part is a legal
+ -- expression (aggregate or function call, including 'Input)) that does
+ -- not require a copy, as specified in 7.5(2).
+
+ function Valid_Ancestor_Type return Boolean;
+ -- Verify that the type of the ancestor part is a non-private ancestor
+ -- of the expected type, which must be a type extension.
+
+ procedure Transform_BIP_Assignment (Typ : Entity_Id);
+ -- For an extension aggregate whose ancestor part is a build-in-place
+ -- call returning a nonlimited type, this is used to transform the
+ -- assignment to the ancestor part to use a temp.
+
+ ----------------------------
+ -- Valid_Limited_Ancestor --
+ ----------------------------
+
+ function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean is
+ begin
+ if Is_Entity_Name (Anc) and then Is_Type (Entity (Anc)) then
+ return True;
+
+ -- The ancestor must be a call or an aggregate, but a call may
+ -- have been expanded into a temporary, so check original node.
+
+ elsif Nkind (Anc) in N_Aggregate
+ | N_Extension_Aggregate
+ | N_Function_Call
+ then
+ return True;
+
+ elsif Nkind (Original_Node (Anc)) = N_Function_Call then
+ return True;
+
+ elsif Nkind (Anc) = N_Attribute_Reference
+ and then Attribute_Name (Anc) = Name_Input
+ then
+ return True;
+
+ elsif Nkind (Anc) = N_Qualified_Expression then
+ return Valid_Limited_Ancestor (Expression (Anc));
+
+ elsif Nkind (Anc) = N_Raise_Expression then
+ return True;
+
+ else
+ return False;
+ end if;
+ end Valid_Limited_Ancestor;
+
+ -------------------------
+ -- Valid_Ancestor_Type --
+ -------------------------
+
+ function Valid_Ancestor_Type return Boolean is
+ Imm_Type : Entity_Id;
+
+ begin
+ Imm_Type := Base_Type (Typ);
+ while Is_Derived_Type (Imm_Type) loop
+ if Etype (Imm_Type) = Base_Type (A_Type) then
+ return True;
+
+ -- The base type of the parent type may appear as a private
+ -- extension if it is declared as such in a parent unit of the
+ -- current one. For consistency of the subsequent analysis use
+ -- the partial view for the ancestor part.
+
+ elsif Is_Private_Type (Etype (Imm_Type))
+ and then Present (Full_View (Etype (Imm_Type)))
+ and then Base_Type (A_Type) = Full_View (Etype (Imm_Type))
+ then
+ A_Type := Etype (Imm_Type);
+ return True;
+
+ -- The parent type may be a private extension. The aggregate is
+ -- legal if the type of the aggregate is an extension of it that
+ -- is not a private extension.
+
+ elsif Is_Private_Type (A_Type)
+ and then not Is_Private_Type (Imm_Type)
+ and then Present (Full_View (A_Type))
+ and then Base_Type (Full_View (A_Type)) = Etype (Imm_Type)
+ then
+ return True;
+
+ -- The parent type may be a raise expression (which is legal in
+ -- any expression context).
+
+ elsif A_Type = Raise_Type then
+ A_Type := Etype (Imm_Type);
+ return True;
+
+ else