+ elsif Present (Iterator_Specification (Comp)) then
+ Iter := Copy_Separate_Tree (Iterator_Specification (Comp));
+ Id_Name := Chars (Defining_Identifier (Comp));
+ Analyze (Iter);
+ Typ := Etype (Defining_Identifier (Iter));
+
+ else
+ Choice := First (Discrete_Choices (Comp));
+
+ while Present (Choice) loop
+ Analyze (Choice);
+
+ -- Choice can be a subtype name, a range, or an expression
+
+ if Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ and then Base_Type (Entity (Choice)) = Base_Type (Key_Type)
+ then
+ null;
+
+ elsif Present (Key_Type) then
+ Analyze_And_Resolve (Choice, Key_Type);
+
+ else
+ Typ := Etype (Choice); -- assume unique for now
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ Id_Name := Chars (Defining_Identifier (Comp));
+ end if;
+
+ -- Create a scope in which to introduce an index, which is usually
+ -- visible in the expression for the component, and needed for its
+ -- analysis.
+
+ Id := Make_Defining_Identifier (Sloc (Comp), Id_Name);
+ Ent := New_Internal_Entity (E_Loop, Current_Scope, Sloc (Comp), 'L');
+ Set_Etype (Ent, Standard_Void_Type);
+ Set_Parent (Ent, Parent (Comp));
+ Push_Scope (Ent);
+
+ -- Insert and decorate the loop variable in the current scope.
+ -- The expression has to be analyzed once the loop variable is
+ -- directly visible. Mark the variable as referenced to prevent
+ -- spurious warnings, given that subsequent uses of its name in the
+ -- expression will reference the internal (synonym) loop variable.
+
+ Enter_Name (Id);
+
+ if No (Key_Type) then
+ pragma Assert (Present (Typ));
+ Set_Etype (Id, Typ);
+ else
+ Set_Etype (Id, Key_Type);
+ end if;
+
+ Set_Ekind (Id, E_Variable);
+ Set_Scope (Id, Ent);
+ Set_Referenced (Id);
+
+ -- Analyze a copy of the expression, to verify legality. We use
+ -- a copy because the expression will be analyzed anew when the
+ -- enclosing aggregate is expanded, and the construct is rewritten
+ -- as a loop with a new index variable.
+
+ Expr := New_Copy_Tree (Expression (Comp));
+ Preanalyze_And_Resolve (Expr, Elmt_Type);
+ End_Scope;
+
+ end Resolve_Iterated_Association;
+
+ begin
+ pragma Assert (Nkind (Asp) = N_Aggregate);
+
+ Set_Etype (N, Typ);
+ Parse_Aspect_Aggregate (Asp,
+ Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
+ New_Indexed_Subp, Assign_Indexed_Subp);
+
+ 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;