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;
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;
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);
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;
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);
+
+ Expander_Mode_Save_And_Set (False);
+ Dummy := Resolve_Aggr_Expr (Expr, Single_Elmt => False);
+ Expander_Mode_Restore;
- Expr := New_Copy_Tree (Expression (N));
- Dummy := Resolve_Aggr_Expr (Expr, False);
+ 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 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;
- Iter : Node_Id;
- Typ : Entity_Id := Empty;
+ 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
- Iter := Copy_Separate_Tree (Iterator_Specification (Comp));
+ -- 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;
+
+ -- 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.
+
+ Key_Expr := Key_Expression (Comp);
+ Analyze_And_Resolve (New_Copy_Tree (Key_Expr), Key_Type);
+
+ 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));
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
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);
& "for unnamed container aggregate", Comp);
return;
else
- Resolve_Iterated_Component_Association
+ Resolve_Iterated_Association
(Comp, Empty, Elmt_Type);
end if;
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;
end;
else
- -- Indexed Aggregate. Both positional and indexed component
- -- can be present. Choices must be static values or ranges
- -- with static bounds.
+ -- 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 :=
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
Analyze_And_Resolve (Expression (Comp), Comp_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, Index_Type, Comp_Type);
end if;
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
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);
projects / gcc.git / blobdiff