@@ -6889,12 +6889,69 @@ package body Exp_Aggr is
New_Indexed_Subp : Node_Id := Empty;
Assign_Indexed_Subp : Node_Id := Empty;
+ procedure Expand_Iterated_Component (Comp : Node_Id);
+
Aggr_Code : constant List_Id := New_List;
Temp : constant Entity_Id := Make_Temporary (Loc, 'C', N);
+ Comp : Node_Id;
Decl : Node_Id;
Init_Stat : Node_Id;
+ -------------------------------
+ -- Expand_Iterated_Component --
+ -------------------------------
+
+ procedure Expand_Iterated_Component (Comp : Node_Id) is
+ Expr : constant Node_Id := Expression (Comp);
+ Loop_Id : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (Comp)));
+
+ L_Range : Node_Id;
+ L_Iteration_Scheme : Node_Id;
+ Loop_Stat : Node_Id;
+ Stats : List_Id;
+
+ begin
+ L_Range := Relocate_Node (First (Discrete_Choices (Comp)));
+ L_Iteration_Scheme :=
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Loop_Id,
+ Discrete_Subtype_Definition => L_Range));
+
+ -- Build insertion statement. for a positional aggregate only
+ -- the expression is needed. For a named aggregate the loop
+ -- variable, whose type is that of the key, is an additional
+ -- parameter for the insertion operation.
+
+ if Present (Add_Unnamed_Subp) then
+ Stats := New_List
+ (Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Entity (Add_Unnamed_Subp), Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Copy_Tree (Expr))));
+ else
+ Stats := New_List
+ (Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Entity (Add_Named_Subp), Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Occurrence_Of (Loop_Id, Loc),
+ New_Copy_Tree (Expr))));
+ end if;
+
+ Loop_Stat := Make_Implicit_Loop_Statement
+ (Node => N,
+ Identifier => Empty,
+ Iteration_Scheme => L_Iteration_Scheme,
+ Statements => Stats);
+ Append (Loop_Stat, Aggr_Code);
+ end Expand_Iterated_Component;
+
begin
Parse_Aspect_Aggregate (Asp,
Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
@@ -6905,7 +6962,7 @@ package body Exp_Aggr is
Object_Definition => New_Occurrence_Of (Typ, Loc));
Insert_Action (N, Decl);
- if Ekind (Entity (Empty_Subp)) = E_Constant then
+ if Ekind (Entity (Empty_Subp)) = E_Function then
Init_Stat := Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Temp, Loc),
Expression => Make_Function_Call (Loc,
@@ -6919,24 +6976,70 @@ package body Exp_Aggr is
-- First case: positional aggregate
- if Present (Expressions (N)) then
+ if Present (Add_Unnamed_Subp) then
+ if Present (Expressions (N)) then
+ declare
+ Insert : constant Entity_Id := Entity (Add_Unnamed_Subp);
+ Comp : Node_Id;
+ Stat : Node_Id;
+
+ begin
+ Comp := First (Expressions (N));
+ while Present (Comp) loop
+ Stat := Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Insert, Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Copy_Tree (Comp)));
+ Append (Stat, Aggr_Code);
+ Next (Comp);
+ end loop;
+ end;
+ end if;
+
+ -- iterated component associations may be present.
+
+ Comp := First (Component_Associations (N));
+ while Present (Comp) loop
+ Expand_Iterated_Component (Comp);
+ Next (Comp);
+ end loop;
+
+ elsif Present (Add_Named_Subp) then
declare
- Insert : constant Entity_Id := Entity (Add_Unnamed_Subp);
- Comp : Node_Id;
+ Insert : constant Entity_Id := Entity (Add_Named_Subp);
Stat : Node_Id;
+ Key : Node_Id;
begin
- Comp := First (Expressions (N));
+ Comp := First (Component_Associations (N));
+
+ -- Each component association may contain several choices,
+ -- generate an insertion statement for each.
+
while Present (Comp) loop
- Stat := Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Insert, Loc),
- Parameter_Associations =>
- New_List (New_Occurrence_Of (Temp, Loc),
- New_Copy_Tree (Comp)));
- Append (Stat, Aggr_Code);
+ if Nkind (Comp) = N_Iterated_Component_Association then
+ Expand_Iterated_Component (Comp);
+ else
+ Key := First (Choices (Comp));
+
+ while Present (Key) loop
+ Stat := Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Insert, Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Copy_Tree (Key),
+ New_Copy_Tree (Expression (Comp))));
+ Append (Stat, Aggr_Code);
+
+ Next (Key);
+ end loop;
+ end if;
+
Next (Comp);
end loop;
end;
end if;
+
Insert_Actions (N, Aggr_Code);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, Typ);
@@ -2644,6 +2644,18 @@ package body Sem_Aggr is
---------------------------------
procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ procedure Resolve_Iterated_Component_Association
+ (Comp : Node_Id;
+ Key_Type : Entity_Id;
+ Elmt_Type : Entity_Id);
+ -- Resolve choices and expression in an iterated component
+ -- association. This is similar but not identical to the handling
+ -- of this construct in an array aggregate.
+ -- For a named container, the type of each choice must be compatible
+ -- with the key type. For a positional container the choice must be
+ -- a subtype indication or an iterator specification that determines
+ -- an element type.
+
Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate);
Empty_Subp : Node_Id := Empty;
@@ -2652,41 +2664,176 @@ package body Sem_Aggr is
New_Indexed_Subp : Node_Id := Empty;
Assign_Indexed_Subp : Node_Id := Empty;
+ --------------------------------------------
+ -- Resolve_Iterated_Component_Association --
+ --------------------------------------------
+
+ procedure Resolve_Iterated_Component_Association
+ (Comp : Node_Id;
+ Key_Type : Entity_Id;
+ Elmt_Type : Entity_Id)
+ is
+ Choice : Node_Id;
+ Ent : Entity_Id;
+ Expr : Node_Id;
+ Id : Entity_Id;
+ Typ : Entity_Id;
+
+ begin
+ if Present (Iterator_Specification (Comp)) then
+ Error_Msg_N ("element iterator ins aggregate Forthcoming", N);
+ return;
+ end if;
+
+ 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;
+
+ -- Create a scope in which to introduce an index, which is usually
+ -- visible in the expression for the component, and needed for its
+ -- analysis.
+
+ 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);
+ Id :=
+ Make_Defining_Identifier (Sloc (Comp),
+ Chars => Chars (Defining_Identifier (Comp)));
+
+ -- 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
+ 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_Component_Association;
+
begin
- if Nkind (Asp) /= N_Aggregate then
- pragma Assert (False);
- return;
- else
- Set_Etype (N, Typ);
- Parse_Aspect_Aggregate (Asp,
- Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
- New_Indexed_Subp, Assign_Indexed_Subp);
+ pragma Assert (Nkind (Asp) = N_Aggregate);
- if Present (Add_Unnamed_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
+ Set_Etype (N, Typ);
+ Parse_Aspect_Aggregate (Asp,
+ Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
+ New_Indexed_Subp, Assign_Indexed_Subp);
- Comp := First (Expressions (N));
+ if Present (Add_Unnamed_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
- Analyze_And_Resolve (Comp, Elmt_Type);
+ if Nkind (Comp) /=
+ N_Iterated_Component_Association
+ then
+ Error_Msg_N ("illegal component association "
+ & "for unnamed container aggregate", Comp);
+ return;
+ else
+ Resolve_Iterated_Component_Association
+ (Comp, Empty, Elmt_Type);
+ end if;
+
Next (Comp);
end loop;
- else
+ end;
+ end if;
+ end;
- -- Empty aggregate, to be replaced by Empty during
- -- expansion.
- null;
+ 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);
+ Next (Choice);
+ end loop;
+
+ Analyze_And_Resolve (Expression (Comp), Elmt_Type);
+
+ elsif Nkind (Comp) = N_Iterated_Component_Association then
+ Resolve_Iterated_Component_Association
+ (Comp, Key_Type, Elmt_Type);
end if;
- end;
- else
- Error_Msg_N ("indexed aggregates are forthcoming", N);
- end if;
+
+ Next (Comp);
+ end loop;
+ end;
+ else
+ Error_Msg_N ("indexed aggregates are forthcoming", N);
end if;
end Resolve_Container_Aggregate;