@@ -6614,8 +6614,6 @@ package body Exp_Aggr is
Temp : constant Entity_Id := Make_Temporary (Loc, 'C', N);
Comp : Node_Id;
- Decl : Node_Id;
- Default : Node_Id;
Init_Stat : Node_Id;
Siz : Int;
@@ -6623,7 +6621,15 @@ package body Exp_Aggr is
-- static and requires a dynamic evaluation.
Siz_Decl : Node_Id;
Siz_Exp : Node_Id := Empty;
- Count_Type : Entity_Id;
+
+ -- These variables are used to determine the smallest and largest
+ -- choice values. Choice_Lo and Choice_Hi are passed to the New_Indexed
+ -- function, for allocating an indexed aggregate object.
+
+ Choice_Lo : Node_Id := Empty;
+ Choice_Hi : Node_Id := Empty;
+ Int_Choice_Lo : Int;
+ Int_Choice_Hi : Int;
Is_Indexed_Aggregate : Boolean := False;
@@ -6649,6 +6655,14 @@ package body Exp_Aggr is
-- given either by a loop parameter specification or an iterator
-- specification.
+ function Expand_Range_Component
+ (Rng : Node_Id;
+ Expr : Node_Id;
+ Insert_Op : Entity_Id) return Node_Id;
+ -- Transform a component association with a range into an explicit loop
+ -- that calls the appropriate operation Insert_Op to add the value of
+ -- Expr to each container element with an index in the range.
+
--------------------
-- Aggregate_Size --
--------------------
@@ -6668,16 +6682,32 @@ package body Exp_Aggr is
--------------------
procedure Add_Range_Size is
+ Range_Int_Lo : Int;
+ Range_Int_Hi : Int;
+
begin
-- The bounds of the discrete range are integers or enumeration
-- literals
if Nkind (Lo) = N_Integer_Literal then
- Siz := Siz + UI_To_Int (Intval (Hi))
- - UI_To_Int (Intval (Lo)) + 1;
+ Range_Int_Lo := UI_To_Int (Intval (Lo));
+ Range_Int_Hi := UI_To_Int (Intval (Hi));
+
else
- Siz := Siz + UI_To_Int (Enumeration_Pos (Hi))
- - UI_To_Int (Enumeration_Pos (Lo)) + 1;
+ Range_Int_Lo := UI_To_Int (Enumeration_Pos (Lo));
+ Range_Int_Hi := UI_To_Int (Enumeration_Pos (Hi));
+ end if;
+
+ Siz := Siz + Range_Int_Hi - Range_Int_Lo + 1;
+
+ if No (Choice_Lo) or else Range_Int_Lo < Int_Choice_Lo then
+ Choice_Lo := Lo;
+ Int_Choice_Lo := Range_Int_Lo;
+ end if;
+
+ if No (Choice_Hi) or else Range_Int_Hi > Int_Choice_Hi then
+ Choice_Hi := Hi;
+ Int_Choice_Hi := Range_Int_Hi;
end if;
end Add_Range_Size;
@@ -6736,6 +6766,8 @@ package body Exp_Aggr is
Hi := High_Bound (Choice);
Add_Range_Size;
+ -- Choice is subtype_mark; add range based on its bounds
+
elsif Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))
then
@@ -6748,6 +6780,15 @@ package body Exp_Aggr is
New_Copy_Tree (Lo),
New_Copy_Tree (Hi)));
+ -- Choice is a single discrete value
+
+ elsif Is_Discrete_Type (Etype (Choice)) then
+ Lo := Choice;
+ Hi := Choice;
+ Add_Range_Size;
+
+ -- Choice is a single value of some nondiscrete type
+
else
-- Single choice (syntax excludes a subtype
-- indication).
@@ -6812,10 +6853,8 @@ package body Exp_Aggr is
return Siz;
-- The possibility of having multiple associations with nonstatic
- -- ranges (plus static ranges) means that in general we really
- -- should be accumulating a sum of the various sizes. The current
- -- code can end up overwriting Siz_Exp on subsequent associations
- -- (plus won't account for associations with static ranges). ???
+ -- ranges (plus static ranges) means that in general we have to
+ -- accumulate a sum of the various sizes.
else
Temp_Siz_Exp :=
@@ -6827,6 +6866,12 @@ package body Exp_Aggr is
Right_Opnd =>
Make_Integer_Literal (Loc, 1));
+ -- Capture the nonstatic bounds, for later use in passing on
+ -- the call to New_Indexed.
+
+ Choice_Lo := Lo;
+ Choice_Hi := Hi;
+
-- Include this nonstatic length in the total length being
-- accumulated in Siz_Exp.
@@ -6939,6 +6984,8 @@ package body Exp_Aggr is
L_Iteration_Scheme :=
Make_Iteration_Scheme (Loc,
Iterator_Specification => Iterator_Specification (Comp));
+ Set_Defining_Identifier
+ (Iterator_Specification (L_Iteration_Scheme), Loop_Id);
else
-- Loop_Parameter_Specification is parsed with a choice list.
@@ -7004,6 +7051,45 @@ package body Exp_Aggr is
end Expand_Iterated_Component;
+ ----------------------------
+ -- Expand_Range_Component --
+ ----------------------------
+
+ function Expand_Range_Component
+ (Rng : Node_Id;
+ Expr : Node_Id;
+ Insert_Op : Entity_Id) return Node_Id
+ is
+ Loop_Id : constant Entity_Id :=
+ Make_Temporary (Loc, 'T');
+
+ L_Iteration_Scheme : Node_Id;
+ Stats : List_Id;
+
+ begin
+ L_Iteration_Scheme :=
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Loop_Id,
+ Discrete_Subtype_Definition => New_Copy_Tree (Rng)));
+
+ Stats := New_List
+ (Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Insert_Op, Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Occurrence_Of (Loop_Id, Loc),
+ New_Copy_Tree (Expr))));
+
+ return Make_Implicit_Loop_Statement
+ (Node => N,
+ Identifier => Empty,
+ Iteration_Scheme => L_Iteration_Scheme,
+ Statements => Stats);
+ end Expand_Range_Component;
+
-- Start of processing for Expand_Container_Aggregate
begin
@@ -7013,34 +7099,9 @@ package body Exp_Aggr is
-- Determine whether this is an indexed aggregate (see RM 4.3.5(25/5))
- if Present (New_Indexed_Subp) then
- if No (Add_Unnamed_Subp) then
- Is_Indexed_Aggregate := True;
-
- else
- declare
- Comp_Assns : constant List_Id := Component_Associations (N);
- Comp_Assn : Node_Id;
-
- begin
- if not Is_Empty_List (Comp_Assns) then
-
- -- It suffices to look at the first association to determine
- -- whether the aggregate is an indexed aggregate.
-
- Comp_Assn := First (Comp_Assns);
-
- if Nkind (Comp_Assn) = N_Component_Association
- or else
- (Nkind (Comp_Assn) = N_Iterated_Component_Association
- and then Present (Defining_Identifier (Comp_Assn)))
- then
- Is_Indexed_Aggregate := True;
- end if;
- end if;
- end;
- end if;
- end if;
+ Is_Indexed_Aggregate
+ := Sem_Aggr.Is_Indexed_Aggregate
+ (N, Add_Unnamed_Subp, New_Indexed_Subp);
-- The constructor for bounded containers is a function with
-- a parameter that sets the size of the container. If the
@@ -7049,35 +7110,50 @@ package body Exp_Aggr is
Siz := Aggregate_Size;
- ---------------------
- -- Empty function --
- ---------------------
-
- if Ekind (Entity (Empty_Subp)) = E_Function
- and then Present (First_Formal (Entity (Empty_Subp)))
- then
- Default := Default_Value (First_Formal (Entity (Empty_Subp)));
+ declare
+ Count_Type : Entity_Id := Standard_Natural;
+ Default : Node_Id := Empty;
+ Empty_First_Formal : constant Entity_Id
+ := First_Formal (Entity (Empty_Subp));
+ Param_List : List_Id;
- -- If aggregate size is not static, we can use default value
- -- of formal parameter for allocation. We assume that this
- -- (implementation-dependent) value is static, even though
- -- the AI does not require it.
+ begin
+ -- If aggregate size is not static, we use the default value of the
+ -- Empty operation's formal parameter for the allocation. We assume
+ -- that this (implementation-dependent) value is static, even though
+ -- the AI does not require it.
+
+ if Present (Empty_First_Formal) then
+ Default := Default_Value (Empty_First_Formal);
+ Count_Type := Etype (Empty_First_Formal);
+ end if;
- -- Create declaration for size: a constant literal in the simple
- -- case, an expression if iterated component associations may be
- -- involved, the default otherwise.
+ -- Create an object initialized by the aggregate's determined size
+ -- (number of elements): a constant literal in the simple case, an
+ -- expression if iterated component associations may be involved,
+ -- and the default otherwise.
- Count_Type := Etype (First_Formal (Entity (Empty_Subp)));
if Siz = -1 then
- if No (Siz_Exp) then
+ if No (Siz_Exp)
+ and Present (Default)
+ then
Siz := UI_To_Int (Intval (Default));
Siz_Exp := Make_Integer_Literal (Loc, Siz);
- else
+ elsif Present (Siz_Exp) then
Siz_Exp := Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Count_Type, Loc),
Expression => Siz_Exp);
+
+ -- If the length isn't known and there's not a default, then use
+ -- zero for the initial container length.
+
+ else
+ Siz_Exp := Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Count_Type, Loc),
+ Expression => Make_Integer_Literal (Loc, 0));
end if;
else
@@ -7100,21 +7176,30 @@ package body Exp_Aggr is
Entity (Assign_Indexed_Subp);
Index_Type : constant Entity_Id :=
Etype (Next_Formal (First_Formal (Insert)));
- Index : Node_Id;
begin
- Index := Make_Op_Add (Loc,
- Left_Opnd => New_Copy_Tree (Type_Low_Bound (Index_Type)),
- Right_Opnd =>
- Make_Op_Subtract (Loc,
- Left_Opnd => Make_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Index_Type, Loc),
- Expression =>
- New_Occurrence_Of
- (Defining_Identifier (Siz_Decl),
- Loc)),
- Right_Opnd => Make_Integer_Literal (Loc, 1)));
+ if No (Choice_Lo) then
+ pragma Assert (No (Choice_Hi));
+
+ Choice_Lo := New_Copy_Tree (Type_Low_Bound (Index_Type));
+
+ Choice_Hi := Make_Op_Add (Loc,
+ Left_Opnd => New_Copy_Tree (Type_Low_Bound (Index_Type)),
+ Right_Opnd =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd => Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Index_Type, Loc),
+ Expression =>
+ New_Occurrence_Of
+ (Defining_Identifier (Siz_Decl),
+ Loc)),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)));
+
+ else
+ Choice_Lo := New_Copy_Tree (Choice_Lo);
+ Choice_Hi := New_Copy_Tree (Choice_Hi);
+ end if;
Init_Stat :=
Make_Object_Declaration (Loc,
@@ -7124,52 +7209,33 @@ package body Exp_Aggr is
Name =>
New_Occurrence_Of (Entity (New_Indexed_Subp), Loc),
Parameter_Associations =>
- New_List (
- New_Copy_Tree (Type_Low_Bound (Index_Type)),
- Index)));
+ New_List (Choice_Lo, Choice_Hi)));
end;
- -- Otherwise we generate a call to the Empty operation, passing
- -- the determined number of elements as saved in Siz_Decl.
+ -- Otherwise we generate a call to the Empty function, passing the
+ -- determined number of elements as saved in Siz_Decl if the function
+ -- has a formal parameter, and otherwise making a parameterless call.
else
+ if Present (Empty_First_Formal) then
+ Param_List :=
+ New_List
+ (New_Occurrence_Of (Defining_Identifier (Siz_Decl), Loc));
+ else
+ Param_List := No_List;
+ end if;
+
Init_Stat :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Make_Function_Call (Loc,
Name => New_Occurrence_Of (Entity (Empty_Subp), Loc),
- Parameter_Associations =>
- New_List
- (New_Occurrence_Of
- (Defining_Identifier (Siz_Decl), Loc))));
+ Parameter_Associations => Param_List));
end if;
Append (Init_Stat, Aggr_Code);
-
- -- The container will grow dynamically. Create a declaration for
- -- the object, and initialize it from a call to the parameterless
- -- Empty function.
-
- else
- pragma Assert (Ekind (Entity (Empty_Subp)) = E_Function);
-
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition => New_Occurrence_Of (Typ, Loc));
-
- Insert_Action (N, Decl);
-
- -- The Empty entity is a parameterless function
-
- Init_Stat := Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Temp, Loc),
- Expression => Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Entity (Empty_Subp), Loc)));
-
- Append (Init_Stat, Aggr_Code);
- end if;
+ end;
-- Report warning on infinite recursion if an empty container aggregate
-- appears in the return statement of its Empty function.
@@ -7192,24 +7258,88 @@ package body Exp_Aggr is
-- Positional aggregate --
---------------------------
- -- If the aggregate is positional the aspect must include
- -- an Add_Unnamed subprogram.
+ -- If the aggregate is positional, then the aspect must include
+ -- an Add_Unnamed or Assign_Indexed procedure.
- if Present (Add_Unnamed_Subp) then
+ if not Is_Null_Aggregate (N)
+ and then
+ (Present (Add_Unnamed_Subp) or else Present (Assign_Indexed_Subp))
+ then
if Present (Expressions (N)) then
declare
- Insert : constant Entity_Id := Entity (Add_Unnamed_Subp);
+ Insert : constant Entity_Id :=
+ (if Is_Indexed_Aggregate
+ then Entity (Assign_Indexed_Subp)
+ else Entity (Add_Unnamed_Subp));
Comp : Node_Id;
Stat : Node_Id;
+ Param_List : List_Id;
+ Key_Type : Entity_Id;
+ Key_Index : Entity_Id;
begin
+ -- For an indexed aggregate, use Etype of the Assign_Indexed
+ -- procedure's second formal as the key type, and declare an
+ -- index object of that type, which will iterate over the key
+ -- type values while traversing the component associations.
+
+ if Is_Indexed_Aggregate then
+ Key_Type :=
+ Etype (Next_Formal
+ (First_Formal (Entity (Assign_Indexed_Subp))));
+
+ Key_Index := Make_Temporary (Loc, 'I', N);
+
+ Append_To (Aggr_Code,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Key_Index,
+ Object_Definition =>
+ New_Occurrence_Of (Key_Type, Loc)));
+ end if;
+
Comp := First (Expressions (N));
while Present (Comp) loop
+ if Is_Indexed_Aggregate then
+
+ -- Generate an assignment to set the first key value of
+ -- the key index object from the key type's lower bound.
+
+ if Comp = First (Expressions (N)) then
+ Append_To (Aggr_Code,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Key_Index, Loc),
+ Expression =>
+ New_Copy (Type_Low_Bound (Key_Type))));
+
+ -- Generate an assignment to increment the key value
+ -- for the subsequent component assignments.
+
+ else
+ Append_To (Aggr_Code,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Key_Index, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Key_Type, Loc),
+ Attribute_Name => Name_Succ,
+ Expressions => New_List (
+ New_Occurrence_Of (Key_Index, Loc)))));
+ end if;
+
+ Param_List :=
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Occurrence_Of (Key_Index, Loc),
+ New_Copy_Tree (Comp));
+ else
+ Param_List :=
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Copy_Tree (Comp));
+ end if;
+
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)));
+ Parameter_Associations => Param_List);
Append (Stat, Aggr_Code);
Next (Comp);
end loop;
@@ -7221,7 +7351,9 @@ package body Exp_Aggr is
elsif not Is_Indexed_Aggregate then
Comp := First (Component_Associations (N));
while Present (Comp) loop
- if Nkind (Comp) = N_Iterated_Component_Association then
+ if Nkind (Comp) = N_Iterated_Component_Association
+ or else Nkind (Comp) = N_Iterated_Element_Association
+ then
Expand_Iterated_Component (Comp);
end if;
Next (Comp);
@@ -7252,12 +7384,23 @@ package body Exp_Aggr is
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))));
+ if Nkind (Key) = N_Range then
+
+ -- Create loop for the specified range, with copies of
+ -- the expression.
+
+ Stat := Expand_Range_Component
+ (Key, Expression (Comp), Insert);
+
+ else
+ 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))));
+ end if;
+
Append (Stat, Aggr_Code);
Next (Key);
@@ -7285,57 +7428,11 @@ package body Exp_Aggr is
and then not Is_Empty_List (Component_Associations (N))
then
declare
-
- function Expand_Range_Component
- (Rng : Node_Id;
- Expr : Node_Id) return Node_Id;
- -- Transform a component association with a range into an
- -- explicit loop. If the choice is a subtype name, it is
- -- rewritten as a range with the corresponding bounds, which
- -- are known to be static.
-
+ Insert : constant Entity_Id := Entity (Assign_Indexed_Subp);
Comp : Node_Id;
Stat : Node_Id;
Key : Node_Id;
- ----------------------------
- -- Expand_Range_Component --
- ----------------------------
-
- function Expand_Range_Component
- (Rng : Node_Id;
- Expr : Node_Id) return Node_Id
- is
- Loop_Id : constant Entity_Id :=
- Make_Temporary (Loc, 'T');
-
- L_Iteration_Scheme : Node_Id;
- Stats : List_Id;
-
- begin
- L_Iteration_Scheme :=
- Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Loop_Id,
- Discrete_Subtype_Definition => New_Copy_Tree (Rng)));
-
- Stats := New_List
- (Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (Entity (Assign_Indexed_Subp), Loc),
- Parameter_Associations =>
- New_List (New_Occurrence_Of (Temp, Loc),
- New_Occurrence_Of (Loop_Id, Loc),
- New_Copy_Tree (Expr))));
-
- return Make_Implicit_Loop_Statement
- (Node => N,
- Identifier => Empty,
- Iteration_Scheme => L_Iteration_Scheme,
- Statements => Stats);
- end Expand_Range_Component;
-
begin
pragma Assert (No (Expressions (N)));
@@ -7357,20 +7454,20 @@ package body Exp_Aggr is
elsif Nkind (Key) = N_Range then
- -- Create loop for tne specified range,
+ -- Create loop for the specified range,
-- with copies of the expression.
Stat :=
- Expand_Range_Component (Key, Expression (Comp));
+ Expand_Range_Component
+ (Key, Expression (Comp), Insert);
else
Stat := Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of
- (Entity (Assign_Indexed_Subp), Loc),
- Parameter_Associations =>
- New_List (New_Occurrence_Of (Temp, Loc),
- New_Copy_Tree (Key),
- New_Copy_Tree (Expression (Comp))));
+ Name => New_Occurrence_Of (Insert, Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Temp, Loc),
+ New_Copy_Tree (Key),
+ New_Copy_Tree (Expression (Comp))));
end if;
Append (Stat, Aggr_Code);
@@ -7384,10 +7481,11 @@ package body Exp_Aggr is
-- positional insertion procedure.
if No (Iterator_Specification (Comp)) then
- Add_Named_Subp := Assign_Indexed_Subp;
Add_Unnamed_Subp := Empty;
end if;
+ Add_Named_Subp := Assign_Indexed_Subp;
+
Expand_Iterated_Component (Comp);
end if;
@@ -49,6 +49,7 @@ with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch5; use Sem_Ch5;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Dim; use Sem_Dim;
@@ -58,7 +59,6 @@ with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
-with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stringt; use Stringt;
@@ -781,6 +781,102 @@ package body Sem_Aggr is
end if;
end Is_Deep_Choice;
+ --------------------------
+ -- Is_Indexed_Aggregate --
+ --------------------------
+
+ function Is_Indexed_Aggregate
+ (N : N_Aggregate_Id;
+ Add_Unnamed : Node_Id;
+ New_Indexed : Node_Id) return Boolean
+ is
+ begin
+ if Present (New_Indexed)
+ and then not Is_Null_Aggregate (N)
+ then
+ if No (Add_Unnamed) then
+ return True;
+
+ else
+ declare
+ Comp_Assns : constant List_Id := Component_Associations (N);
+ Comp_Assn : Node_Id;
+
+ begin
+ if not Is_Empty_List (Comp_Assns) then
+
+ -- It suffices to look at the first association to determine
+ -- whether the aggregate is an indexed aggregate.
+
+ Comp_Assn := First (Comp_Assns);
+
+ -- Test for the component association being either:
+ --
+ -- 1) an N_Component_Association node, in which case there
+ -- is a list of choices (the "key choices");
+ --
+ -- or else:
+ --
+ -- 2) an N_Iterated_Component_Association node that has
+ -- a Defining_Identifier, in which case it has
+ -- Discrete_Choices that effectively make it
+ -- equivalent to a Loop_Parameter_Specification;
+ --
+ -- or else:
+ --
+ -- 3) an N_Iterated_Element_Association node with
+ -- a Loop_Parameter_Specification with a discrete
+ -- subtype or range.
+ --
+ -- This basically corresponds to the definition of indexed
+ -- aggregates (in RM22 4.3.5(25/5)), but the GNAT tree
+ -- representation doesn't always directly match the RM
+ -- syntax for various reasons.
+
+ if Nkind (Comp_Assn) = N_Component_Association
+ or else
+ (Nkind (Comp_Assn) = N_Iterated_Component_Association
+ and then Present (Defining_Identifier (Comp_Assn)))
+ then
+ return True;
+
+ -- In the case of an iterated_element_association with a
+ -- loop_parameter_specification, we have to look deeper to
+ -- confirm that it is not actually an iterator_specification
+ -- masquerading as a loop_parameter_specification. Those can
+ -- share syntax (for example, having the iterator of form
+ -- "for C in <function-call>") and a rewrite into an
+ -- iterator_specification can happen later.
+
+ elsif Nkind (Comp_Assn) = N_Iterated_Element_Association
+ and then Present (Loop_Parameter_Specification (Comp_Assn))
+ then
+ declare
+ Loop_Parm_Spec : constant Node_Id :=
+ Loop_Parameter_Specification (Comp_Assn);
+ Discr_Subt_Defn : constant Node_Id :=
+ Discrete_Subtype_Definition (Loop_Parm_Spec);
+ begin
+ if Nkind (Discr_Subt_Defn) = N_Range
+ or else
+ Nkind (Discr_Subt_Defn) = N_Subtype_Indication
+ or else
+ (Is_Entity_Name (Discr_Subt_Defn)
+ and then
+ Is_Type (Entity (Discr_Subt_Defn)))
+ then
+ return True;
+ end if;
+ end;
+ end if;
+ end if;
+ end;
+ end if;
+ end if;
+
+ return False;
+ end Is_Indexed_Aggregate;
+
-------------------------
-- Is_Others_Aggregate --
-------------------------
@@ -3227,22 +3323,23 @@ package body Sem_Aggr is
Key_Type : Entity_Id;
Elmt_Type : Entity_Id)
is
- Loc : constant Source_Ptr := Sloc (N);
- Choice : Node_Id;
- Copy : Node_Id;
- Ent : Entity_Id;
- Expr : Node_Id;
- Key_Expr : Node_Id;
- Id : Entity_Id;
- Id_Name : Name_Id;
- Typ : Entity_Id := Empty;
+ Loc : constant Source_Ptr := Sloc (N);
+ Choice : Node_Id;
+ Copy : Node_Id;
+ Ent : Entity_Id;
+ Expr : Node_Id;
+ Key_Expr : Node_Id := Empty;
+ Id : Entity_Id;
+ Id_Name : Name_Id;
+ Typ : Entity_Id := Empty;
+ Loop_Param_Id : Entity_Id := Empty;
begin
Error_Msg_Ada_2022_Feature ("iterated component", Loc);
-- If this is an Iterated_Element_Association then either a
-- an Iterator_Specification or a Loop_Parameter specification
- -- is present. In both cases a Key_Expression is present.
+ -- is present.
if Nkind (Comp) = N_Iterated_Element_Association then
@@ -3258,18 +3355,27 @@ package body Sem_Aggr is
if Present (Loop_Parameter_Specification (Comp)) then
Copy := Copy_Separate_Tree (Comp);
+ Set_Parent (Copy, Parent (Comp));
Analyze
(Loop_Parameter_Specification (Copy));
- Id_Name := Chars (Defining_Identifier
- (Loop_Parameter_Specification (Comp)));
+ if Present (Iterator_Specification (Copy)) then
+ Loop_Param_Id :=
+ Defining_Identifier (Iterator_Specification (Copy));
+ else
+ Loop_Param_Id :=
+ Defining_Identifier (Loop_Parameter_Specification (Copy));
+ end if;
+
+ Id_Name := Chars (Loop_Param_Id);
else
Copy := Copy_Separate_Tree (Iterator_Specification (Comp));
Analyze (Copy);
- Id_Name := Chars (Defining_Identifier
- (Iterator_Specification (Comp)));
+ Loop_Param_Id := Defining_Identifier (Copy);
+
+ Id_Name := Chars (Loop_Param_Id);
end if;
-- Key expression must have the type of the key. We preanalyze
@@ -3278,10 +3384,12 @@ package body Sem_Aggr is
-- corresponding loop.
Key_Expr := Key_Expression (Comp);
- Preanalyze_And_Resolve (New_Copy_Tree (Key_Expr), Key_Type);
+ if Present (Key_Expr) then
+ Preanalyze_And_Resolve (New_Copy_Tree (Key_Expr), Key_Type);
+ end if;
End_Scope;
- Typ := Key_Type;
+ Typ := Etype (Loop_Param_Id);
elsif Present (Iterator_Specification (Comp)) then
-- Create a temporary scope to avoid some modifications from
@@ -3294,9 +3402,12 @@ package body Sem_Aggr is
Set_Parent (Ent, Parent (Comp));
Push_Scope (Ent);
- Copy := Copy_Separate_Tree (Iterator_Specification (Comp));
- Id_Name :=
- Chars (Defining_Identifier (Iterator_Specification (Comp)));
+ Copy := Copy_Separate_Tree (Iterator_Specification (Comp));
+
+ Loop_Param_Id :=
+ Defining_Identifier (Iterator_Specification (Comp));
+
+ Id_Name := Chars (Loop_Param_Id);
Preanalyze (Copy);
@@ -3307,28 +3418,58 @@ package body Sem_Aggr is
else
Choice := First (Discrete_Choices (Comp));
- while Present (Choice) loop
- Analyze (Choice);
+ -- This is an N_Component_Association with a Defining_Identifier
+ -- and Discrete_Choice_List, but the latter can only have a single
+ -- choice, as it's a stand-in for a Loop_Parameter_Specification
+ -- (or possibly even an Iterator_Specification, see below).
- -- Choice can be a subtype name, a range, or an expression
+ pragma Assert (No (Next (Choice)));
- if Is_Entity_Name (Choice)
- and then Is_Type (Entity (Choice))
- and then Base_Type (Entity (Choice)) = Base_Type (Key_Type)
- then
- null;
+ Analyze (Choice);
- elsif Present (Key_Type) then
- Analyze_And_Resolve (Choice, Key_Type);
- Typ := Key_Type;
- else
- Typ := Etype (Choice); -- assume unique for now
- end if;
+ -- Choice can be a subtype name, a range, or an expression
- Next (Choice);
- end loop;
+ if Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ and then Base_Type (Entity (Choice)) = Base_Type (Key_Type)
+ then
+ null;
+
+ elsif Nkind (Choice) = N_Function_Call then
+ declare
+ I_Spec : constant Node_Id :=
+ Make_Iterator_Specification (Sloc (N),
+ Defining_Identifier =>
+ Relocate_Node (Defining_Identifier (Comp)),
+ Name => New_Copy_Tree (Choice),
+ Reverse_Present => False,
+ Iterator_Filter => Empty,
+ Subtype_Indication => Empty);
+ begin
+ Set_Iterator_Specification (Comp, I_Spec);
+ Set_Defining_Identifier (Comp, Empty);
+
+ Analyze_Iterator_Specification
+ (Iterator_Specification (Comp));
+
+ Resolve_Iterated_Association (Comp, Key_Type, Elmt_Type);
+ -- Recursive call to expand association as iterator_spec
+
+ return;
+ end;
+
+ elsif Present (Key_Type) then
+ Analyze_And_Resolve (Choice, Key_Type);
+ Typ := Key_Type;
+
+ else
+ Typ := Etype (Choice); -- assume unique for now
+ end if;
+
+ Loop_Param_Id :=
+ Defining_Identifier (Comp);
- Id_Name := Chars (Defining_Identifier (Comp));
+ Id_Name := Chars (Loop_Param_Id);
end if;
-- Create a scope in which to introduce an index, which is usually
@@ -3358,6 +3499,21 @@ package body Sem_Aggr is
Set_Scope (Id, Ent);
Set_Referenced (Id);
+ -- Check for violation of 4.3.5(27/5)
+
+ if No (Key_Expr)
+ and then Present (Key_Type)
+ and then
+ (Is_Indexed_Aggregate (N, Add_Unnamed_Subp, New_Indexed_Subp)
+ or else Present (Add_Named_Subp))
+ and then Base_Type (Key_Type) /= Base_Type (Typ)
+ then
+ Error_Msg_Node_2 := Key_Type;
+ Error_Msg_NE
+ ("loop parameter type & must be same as key type & " &
+ "(RM22 4.3.5(27))", Loop_Param_Id, Typ);
+ end if;
+
-- 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
@@ -3409,15 +3565,16 @@ package body Sem_Aggr is
Comp : Node_Id := First (Component_Associations (N));
begin
while Present (Comp) loop
- if Nkind (Comp) /=
- N_Iterated_Component_Association
+ if Nkind (Comp) in
+ N_Iterated_Component_Association |
+ N_Iterated_Element_Association
then
+ Resolve_Iterated_Association
+ (Comp, Empty, Elmt_Type);
+ else
Error_Msg_N ("illegal component association "
& "for unnamed container aggregate", Comp);
return;
- else
- Resolve_Iterated_Association
- (Comp, Empty, Elmt_Type);
end if;
Next (Comp);
@@ -3463,10 +3620,6 @@ package body Sem_Aggr is
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;
@@ -3535,7 +3688,9 @@ package body Sem_Aggr is
Next (Choice);
end loop;
- Analyze_And_Resolve (Expression (Comp), Comp_Type);
+ if not Box_Present (Comp) then
+ Analyze_And_Resolve (Expression (Comp), Comp_Type);
+ end if;
elsif Nkind (Comp) in
N_Iterated_Component_Association |
@@ -3543,6 +3698,56 @@ package body Sem_Aggr is
then
Resolve_Iterated_Association
(Comp, Index_Type, Comp_Type);
+
+ -- Check the legality rule of RM22 4.3.5(28/5). Note that
+ -- Is_Indexed_Aggregate can change its status (to False)
+ -- as a result of calling Resolve_Iterated_Association,
+ -- due to possible expansion of iterator_specifications
+ -- there.
+
+ if Is_Indexed_Aggregate
+ (N, Add_Unnamed_Subp, New_Indexed_Subp)
+ then
+ if Nkind (Comp) = N_Iterated_Element_Association then
+ if Present (Loop_Parameter_Specification (Comp))
+ then
+ if Present (Iterator_Filter
+ (Loop_Parameter_Specification (Comp)))
+ then
+ Error_Msg_N
+ ("iterator filter not allowed " &
+ "in indexed aggregate (RM22 4.3.5(28))",
+ Iterator_Filter
+ (Loop_Parameter_Specification (Comp)));
+ return;
+
+ elsif Present (Key_Expression (Comp)) then
+ Error_Msg_N
+ ("key expression not allowed " &
+ "in indexed aggregate (RM22 4.3.5(28))",
+ Key_Expression (Comp));
+ return;
+ end if;
+
+ elsif Present (Iterator_Specification (Comp)) then
+ Error_Msg_N
+ ("iterator specification not allowed " &
+ "in indexed aggregate (RM22 4.3.5(28))",
+ Iterator_Specification (Comp));
+ return;
+ end if;
+
+ elsif Nkind (Comp) = N_Iterated_Component_Association
+ and then Present (Iterator_Specification (Comp))
+ then
+ Error_Msg_N
+ ("iterator specification not allowed " &
+ "in indexed aggregate (RM22 4.3.5(28))",
+ Iterator_Specification (Comp));
+ return;
+ end if;
+ end if;
+
Num_Choices := Num_Choices + 1;
end if;
@@ -3569,67 +3774,44 @@ package body Sem_Aggr is
begin
Comp := First (Component_Associations (N));
while Present (Comp) loop
- if Nkind (Comp) = N_Iterated_Element_Association then
- if Present
- (Loop_Parameter_Specification (Comp))
- then
- if Present (Iterator_Filter
- (Loop_Parameter_Specification (Comp)))
- then
- Error_Msg_N
- ("iterator filter not allowed " &
- "in indexed aggregate", Comp);
- return;
-
- elsif Present (Key_Expression
- (Loop_Parameter_Specification (Comp)))
- then
- Error_Msg_N
- ("key expression not allowed " &
- "in indexed aggregate", Comp);
- return;
- end if;
- end if;
- else
- -- If Nkind is N_Iterated_Component_Association,
- -- this corresponds to an iterator_specification
- -- with a loop_parameter_specification, and we
- -- have to pick up Discrete_Choices. In this case
- -- there will be just one "choice", which will
- -- typically be a range.
+ -- If Nkind is N_Iterated_Component_Association,
+ -- this corresponds to an iterator_specification
+ -- with a loop_parameter_specification, and we
+ -- have to pick up Discrete_Choices. In this case
+ -- there will be just one "choice", which will
+ -- typically be a range.
- if Nkind (Comp) = N_Iterated_Component_Association
- then
- Choice := First (Discrete_Choices (Comp));
+ if Nkind (Comp) = N_Iterated_Component_Association
+ then
+ Choice := First (Discrete_Choices (Comp));
- -- Case where there's a list of choices
+ -- Case where there's a list of choices
- else
- Choice := First (Choices (Comp));
- end if;
+ else
+ Choice := First (Choices (Comp));
+ end if;
- while Present (Choice) loop
- Get_Index_Bounds (Choice, Lo, Hi);
- Table (No_Choice).Choice := Choice;
- Table (No_Choice).Lo := Lo;
- Table (No_Choice).Hi := Hi;
+ while Present (Choice) loop
+ Get_Index_Bounds (Choice, Lo, Hi);
+ Table (No_Choice).Choice := Choice;
+ Table (No_Choice).Lo := Lo;
+ Table (No_Choice).Hi := Hi;
- -- Verify staticness of value or range
+ -- Verify staticness of value or range
- if not Is_Static_Expression (Lo)
- or else not Is_Static_Expression (Hi)
- then
- Error_Msg_N
- ("nonstatic expression for index " &
- "for indexed aggregate", Choice);
- return;
- end if;
+ if not Is_Static_Expression (Lo)
+ or else not Is_Static_Expression (Hi)
+ then
+ Error_Msg_N
+ ("nonstatic expression for index " &
+ "for indexed aggregate", Choice);
+ return;
+ end if;
- No_Choice := No_Choice + 1;
- Next (Choice);
- end loop;
- end if;
+ No_Choice := No_Choice + 1;
+ Next (Choice);
+ end loop;
Next (Comp);
end loop;
@@ -27,6 +27,7 @@
-- part of Sem_Res, but is split off since the aggregate code is so complex.
with Einfo.Entities; use Einfo.Entities;
+with Sinfo.Nodes; use Sinfo.Nodes;
with Types; use Types;
package Sem_Aggr is
@@ -44,6 +45,21 @@ package Sem_Aggr is
-- WARNING: There is a matching C declaration of this subprogram in fe.h
+ function Is_Indexed_Aggregate
+ (N : N_Aggregate_Id;
+ Add_Unnamed : Node_Id;
+ New_Indexed : Node_Id) return Boolean;
+ -- Returns True if N satisfies the criteria for being an indexed aggregate,
+ -- that is, N is a container aggregate whose type has an Aggregate aspect
+ -- that specifies a New_Indexed operation (it's Present), the aggregate
+ -- is not a null aggregate, and either the type doesn't specify Add_Unnamed
+ -- or there is a component association that is an N_Component_Association
+ -- or is an N_Iterated_Component_Association with a Defining_Identifier.
+ -- Returns False otherwise. The actuals for the Add_Unnamed and New_Indexed
+ -- formals must be nodes that are names denoting the subprograms specified
+ -- for those operations in the Aggregate aspect of the aggregate's type,
+ -- or else Empty if the operation was not specified.
+
function Is_Null_Aggregate (N : Node_Id) return Boolean;
-- Returns True for a "[]" aggregate (an Ada 2022 feature), even after
-- it has been transformed by expansion. Returns False otherwise.