with Sem_Aux; use Sem_Aux;
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;
with Style; use Style;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
with Uintp; use Uintp;
package body Sem_Aggr is
This_Range : constant Node_Id := Aggregate_Bounds (N);
-- The aggregate range node of this specific sub-aggregate
- This_Low : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
+ This_Low : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
This_High : constant Node_Id := High_Bound (Aggregate_Bounds (N));
-- The aggregate bounds of this specific sub-aggregate
-----------------------
procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (N);
Aggr_Subtyp : Entity_Id;
-- The actual aggregate subtype. This is not necessarily the same as Typ
-- which is the subtype of the context in which the aggregate was found.
+ Others_Box : Boolean := False;
+ -- Set to True if N represents a simple aggregate with only
+ -- (others => <>), not nested as part of another aggregate.
+
+ function Within_Aggregate (N : Node_Id) return Boolean;
+ -- Return True if N is part of an N_Aggregate
+
+ ----------------------
+ -- Within_Aggregate --
+ ----------------------
+
+ function Within_Aggregate (N : Node_Id) return Boolean is
+ P : Node_Id := Parent (N);
+ begin
+ while Present (P) loop
+ if Nkind (P) = N_Aggregate then
+ return True;
+ end if;
+
+ P := Parent (P);
+ end loop;
+
+ return False;
+ end Within_Aggregate;
+
+ -- Start of processing for Resolve_Aggregate
+
begin
-- Ignore junk empty aggregate resulting from parser error
and then Present (Component_Associations (N))
then
declare
- Comp : Node_Id;
+ Comp : Node_Id;
+ First_Comp : Boolean := True;
begin
Comp := First (Component_Associations (N));
while Present (Comp) loop
if Box_Present (Comp) then
+ if First_Comp
+ and then No (Expressions (N))
+ and then Nkind (First (Choices (Comp))) = N_Others_Choice
+ and then not Within_Aggregate (N)
+ then
+ Others_Box := True;
+ end if;
+
Insert_Actions (N, Freeze_Entity (Typ, N));
exit;
end if;
+ First_Comp := False;
Next (Comp);
end loop;
end;
if not Support_Aggregates_On_Target
and then Comes_From_Source (N)
- and then (not Known_Static_Esize (Typ) or else Esize (Typ) > 64)
+ and then (not Known_Static_Esize (Typ)
+ or else Esize (Typ) > System_Max_Integer_Size)
then
Error_Msg_CRT ("aggregate", N);
end if;
elsif Is_Array_Type (Typ) and then Null_Record_Present (N) then
Error_Msg_N ("null record forbidden in array aggregate", N);
+ elsif Present (Find_Aspect (Typ, Aspect_Aggregate))
+ and then Ekind (Typ) /= E_Record_Type
+ and then Ada_Version >= Ada_2020
+ then
+ Resolve_Container_Aggregate (N, Typ);
+
elsif Is_Record_Type (Typ) then
Resolve_Record_Aggregate (N, Typ);
if Nkind (Parent (N)) = N_Assignment_Statement
or else Inside_Init_Proc
or else (Is_Constrained (Typ)
- and then Nkind_In (Parent (N),
- N_Parameter_Association,
- N_Function_Call,
- N_Procedure_Call_Statement,
- N_Generic_Association,
- N_Formal_Object_Declaration,
- N_Simple_Return_Statement,
- N_Object_Declaration,
- N_Component_Declaration,
- N_Parameter_Specification,
- N_Qualified_Expression,
- N_Reference,
- N_Aggregate,
- N_Extension_Aggregate,
- N_Component_Association,
- N_Case_Expression_Alternative,
- N_If_Expression,
- N_Expression_With_Actions))
+ and then Nkind (Parent (N)) in
+ N_Parameter_Association
+ | N_Function_Call
+ | N_Procedure_Call_Statement
+ | N_Generic_Association
+ | N_Formal_Object_Declaration
+ | N_Simple_Return_Statement
+ | N_Object_Declaration
+ | N_Component_Declaration
+ | N_Parameter_Specification
+ | N_Qualified_Expression
+ | N_Reference
+ | N_Aggregate
+ | N_Extension_Aggregate
+ | N_Component_Association
+ | N_Case_Expression_Alternative
+ | N_If_Expression
+ | N_Expression_With_Actions)
then
Aggr_Resolved :=
Resolve_Array_Aggregate
Set_Analyzed (N);
end if;
+ if Warn_On_No_Value_Assigned
+ and then Others_Box
+ and then not Is_Fully_Initialized_Type (Etype (N))
+ then
+ Error_Msg_N ("?v?aggregate not fully initialized", N);
+ end if;
+
Check_Function_Writable_Actuals (N);
end Resolve_Aggregate;
if Is_Character_Type (Component_Typ)
and then No (Next_Index (Nxt_Ind))
- and then Nkind_In (Expr, N_String_Literal, N_Operator_Symbol)
+ and then Nkind (Expr) in N_String_Literal | N_Operator_Symbol
then
-- A string literal used in a multidimensional array
-- aggregate in place of the final one-dimensional
Index_Typ : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (N);
+ Id : constant Entity_Id := Defining_Identifier (N);
+
+ -----------------------
+ -- Remove_References --
+ -----------------------
+
+ function Remove_Ref (N : Node_Id) return Traverse_Result;
+ -- Remove references to the entity Id after analysis, so it can be
+ -- properly reanalyzed after construct is expanded into a loop.
+
+ function Remove_Ref (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Identifier
+ and then Present (Entity (N))
+ and then Entity (N) = Id
+ then
+ Set_Entity (N, Empty);
+ Set_Etype (N, Empty);
+ end if;
+ Set_Analyzed (N, False);
+ return OK;
+ end Remove_Ref;
+
+ procedure Remove_References is new Traverse_Proc (Remove_Ref);
+
+ -- Local variables
Choice : Node_Id;
Dummy : Boolean;
Ent : Entity_Id;
Expr : Node_Id;
- Id : Entity_Id;
+
+ -- Start of processing for Resolve_Iterated_Component_Association
begin
-- An element iterator specification cannot appear in
Set_Etype (Ent, Standard_Void_Type);
Set_Parent (Ent, Parent (N));
Push_Scope (Ent);
- Id :=
- Make_Defining_Identifier (Loc,
- Chars => Chars (Defining_Identifier (N)));
-- Insert and decorate the index variable in the current scope.
-- The expression has to be analyzed once the index 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.
+ -- directly visible.
Enter_Name (Id);
Set_Etype (Id, Index_Typ);
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.
+ -- Analyze expression without expansion, to verify legality.
+ -- When generating code, we then remove references to the index
+ -- variable, because the expression will be analyzed anew after
+ -- rewritting as a loop with a new index variable; when not
+ -- generating code we leave the analyzed expression as it is.
+
+ Expr := Expression (N);
- Expr := New_Copy_Tree (Expression (N));
- Dummy := Resolve_Aggr_Expr (Expr, False);
+ Expander_Mode_Save_And_Set (False);
+ Dummy := Resolve_Aggr_Expr (Expr, Single_Elmt => False);
+ Expander_Mode_Restore;
+
+ if Operating_Mode /= Check_Semantics then
+ Remove_References (Expr);
+ end if;
-- An iterated_component_association may appear in a nested
-- aggregate for a multidimensional structure: preserve the bounds
-- computed for the expression, as well as the anonymous array
-- type generated for it; both are needed during array expansion.
- -- This does not work for more than two levels of nesting. ???
if Nkind (Expr) = N_Aggregate then
Set_Aggregate_Bounds (Expression (N), Aggregate_Bounds (Expr));
if Ada_Version = Ada_83
and then Assoc /= First (Component_Associations (N))
- and then Nkind_In (Parent (N), N_Assignment_Statement,
- N_Object_Declaration)
+ and then Nkind (Parent (N)) in
+ N_Assignment_Statement | N_Object_Declaration
then
Error_Msg_N
("(Ada 83) illegal context for OTHERS choice", N);
if Others_Present and then not Others_Allowed then
Error_Msg_N
("OTHERS choice not allowed here",
- First (Choices (First (Component_Associations (N)))));
+ First (Choice_List (First (Component_Associations (N)))));
return Failure;
end if;
return Failure;
end if;
+ -- ??? Checks for dynamically tagged expressions below will
+ -- be only applied to iterated_component_association after
+ -- expansion; in particular, errors might not be reported when
+ -- -gnatc switch is used.
+
elsif Nkind (Assoc) = N_Iterated_Component_Association then
- null; -- handled above, in a loop context.
+ null; -- handled above, in a loop context
elsif not Resolve_Aggr_Expr
(Expression (Assoc), Single_Elmt => Single_Choice)
-- In order to diagnose the semantic error we create a duplicate
-- tree to analyze it and perform the check.
- else
+ elsif Nkind (Assoc) /= N_Iterated_Component_Association then
declare
Save_Analysis : constant Boolean := Full_Analysis;
Expr : constant Node_Id :=
---------------------------------
procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id) is
- procedure Resolve_Iterated_Component_Association
+ procedure Resolve_Iterated_Association
(Comp : Node_Id;
Key_Type : Entity_Id;
Elmt_Type : Entity_Id);
- -- Resolve choices and expression in an iterated component association.
+ -- Resolve choices and expression in an iterated component association
+ -- or an iterated element association, which has a key_expression.
-- 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
New_Indexed_Subp : Node_Id := Empty;
Assign_Indexed_Subp : Node_Id := Empty;
- --------------------------------------------
- -- Resolve_Iterated_Component_Association --
- --------------------------------------------
+ ----------------------------------
+ -- Resolve_Iterated_Association --
+ ----------------------------------
- procedure Resolve_Iterated_Component_Association
+ procedure Resolve_Iterated_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;
+ Choice : Node_Id;
+ Ent : Entity_Id;
+ Expr : Node_Id;
+ Key_Expr : Node_Id;
+ Id : Entity_Id;
+ Id_Name : Name_Id;
+ Iter : Node_Id;
+ Typ : Entity_Id := Empty;
begin
- if Present (Iterator_Specification (Comp)) then
- Error_Msg_N ("element iterator ins aggregate Forthcoming", N);
- return;
- end if;
+ -- 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.
+
+ if Nkind (Comp) = N_Iterated_Element_Association then
+ if Present (Loop_Parameter_Specification (Comp)) then
+ Analyze_Loop_Parameter_Specification
+ (Loop_Parameter_Specification (Comp));
+ Id_Name := Chars (Defining_Identifier
+ (Loop_Parameter_Specification (Comp)));
+ else
+ Iter := Copy_Separate_Tree (Iterator_Specification (Comp));
+ Analyze (Iter);
+ Typ := Etype (Defining_Identifier (Iter));
+ Id_Name := Chars (Defining_Identifier
+ (Iterator_Specification (Comp)));
+ end if;
- Choice := First (Discrete_Choices (Comp));
+ -- Key expression must have the type of the key. We analyze
+ -- a copy of the original expression, because it will be
+ -- reanalyzed and copied as needed during expansion of the
+ -- corresponding loop.
- while Present (Choice) loop
- Analyze (Choice);
+ Key_Expr := Key_Expression (Comp);
+ Analyze_And_Resolve (New_Copy_Tree (Key_Expr), Key_Type);
- -- Choice can be a subtype name, a range, or an expression
+ 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));
- if Is_Entity_Name (Choice)
- and then Is_Type (Entity (Choice))
- and then Base_Type (Entity (Choice)) = Base_Type (Key_Type)
- then
- null;
+ else
+ Choice := First (Discrete_Choices (Comp));
- elsif Present (Key_Type) then
- Analyze_And_Resolve (Choice, Key_Type);
+ while Present (Choice) loop
+ Analyze (Choice);
- 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 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);
- 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
-- 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);
Expr := New_Copy_Tree (Expression (Comp));
Preanalyze_And_Resolve (Expr, Elmt_Type);
End_Scope;
- end Resolve_Iterated_Component_Association;
+
+ end Resolve_Iterated_Association;
begin
pragma Assert (Nkind (Asp) = N_Aggregate);
Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
New_Indexed_Subp, Assign_Indexed_Subp);
- if Present (Add_Unnamed_Subp) then
+ if Present (Add_Unnamed_Subp)
+ and then No (New_Indexed_Subp)
+ then
declare
Elmt_Type : constant Entity_Id :=
Etype (Next_Formal
& "for unnamed container aggregate", Comp);
return;
else
- Resolve_Iterated_Component_Association
+ Resolve_Iterated_Association
(Comp, Empty, Elmt_Type);
end if;
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) = N_Iterated_Component_Association then
- Resolve_Iterated_Component_Association
+ 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
- Error_Msg_N ("indexed aggregates are forthcoming", N);
+ -- 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;
Assoc : Node_Id;
Choice : Node_Id;
+ Expr : Node_Id;
begin
Assoc := First (Deltas);
begin
Set_Etype (Ent, Standard_Void_Type);
Set_Parent (Ent, Assoc);
+ Push_Scope (Ent);
if No (Scope (Id)) then
- Enter_Name (Id);
Set_Etype (Id, Index_Type);
Set_Ekind (Id, E_Variable);
Set_Scope (Id, Ent);
end if;
+ Enter_Name (Id);
- Push_Scope (Ent);
- Analyze_And_Resolve
- (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ));
+ -- 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;
Base_Type (Index_Type)
then
Error_Msg_NE
- ("choice does mat match index type of",
+ ("choice does not match index type of &",
Choice, Typ);
end if;
else
-- 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_In (Anc, N_Aggregate,
- N_Extension_Aggregate,
- N_Function_Call)
+ elsif Nkind (Anc) in N_Aggregate
+ | N_Extension_Aggregate
+ | N_Function_Call
then
return True;
if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
- -- AI05-0115: if the ancestor part is a subtype mark, the ancestor
- -- must not have unknown discriminants.
-
- if Has_Unknown_Discriminants (Entity (A)) then
+ -- AI05-0115: If the ancestor part is a subtype mark, the ancestor
+ -- must not have unknown discriminants. To catch cases where the
+ -- aggregate occurs at a place where the full view of the ancestor
+ -- type is visible and doesn't have unknown discriminants, but the
+ -- aggregate type was derived from a partial view that has unknown
+ -- discriminants, we check whether the aggregate type has unknown
+ -- discriminants (unknown discriminants were inherited), along
+ -- with checking that the partial view of the ancestor has unknown
+ -- discriminants. (It might be sufficient to replace the entire
+ -- condition with Has_Unknown_Discriminants (Typ), but that might
+ -- miss some cases, not clear, and causes error changes in some tests
+ -- such as class-wide cases, that aren't clearly improvements. ???)
+
+ if Has_Unknown_Discriminants (Entity (A))
+ or else (Has_Unknown_Discriminants (Typ)
+ and then Partial_View_Has_Unknown_Discr (Entity (A)))
+ then
Error_Msg_NE
("aggregate not available for type& whose ancestor "
& "has unknown discriminants", N, Typ);
-- Copy the expression so that it is resolved
-- independently for each component, This is needed
- -- for accessibility checks on compoents of anonymous
+ -- for accessibility checks on components of anonymous
-- access types, even in compile_only mode.
if not Inside_A_Generic then
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
begin
return
- (Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate)
+ (Nkind (Expr) in N_Aggregate | N_Extension_Aggregate
and then Present (Etype (Expr))
and then Is_Record_Type (Etype (Expr))
and then Expansion_Delayed (Expr))
end if;
-- Ada 2012: If component is scalar with default value, use it
+ -- by converting it to Ctyp, so that subtype constraints are
+ -- checked.
elsif Is_Scalar_Type (Ctyp)
and then Has_Default_Aspect (Ctyp)
then
- Add_Association
- (Component => Component,
- Expr =>
- Default_Aspect_Value
- (First_Subtype (Underlying_Type (Ctyp))),
- Assoc_List => New_Assoc_List);
+ declare
+ Conv : constant Node_Id :=
+ Convert_To
+ (Typ => Ctyp,
+ Expr =>
+ New_Copy_Tree
+ (Default_Aspect_Value
+ (First_Subtype (Underlying_Type (Ctyp)))));
+
+ begin
+ Analyze_And_Resolve (Conv, Ctyp);
+ Add_Association
+ (Component => Component,
+ Expr => Conv,
+ Assoc_List => New_Assoc_List);
+ end;
elsif Has_Non_Null_Base_Init_Proc (Ctyp)
or else not Expander_Active
projects / gcc.git / blobdiff