-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- expressions allowed for a limited component association (namely, an
-- aggregate, function call, or <> notation). Report error for violations.
-- Expression is also OK in an instance or inlining context, because we
- -- have already pre-analyzed and it is known to be type correct.
+ -- have already preanalyzed and it is known to be type correct.
procedure Check_Qualified_Aggregate (Level : Nat; Expr : Node_Id);
-- Given aggregate Expr, check that sub-aggregates of Expr that are nested
Set_Etype (Itype, Base_Type (Typ));
Set_Has_Alignment_Clause (Itype, Has_Alignment_Clause (Typ));
Set_Is_Aliased (Itype, Is_Aliased (Typ));
+ Set_Is_Independent (Itype, Is_Independent (Typ));
Set_Depends_On_Private (Itype, Depends_On_Private (Typ));
Copy_Suppress_Status (Index_Check, Typ, Itype);
Set_Is_Constrained (Itype, True);
Set_Is_Internal (Itype, True);
+ if Has_Predicates (Typ) then
+ Set_Has_Predicates (Itype);
+
+ -- If the base type has a predicate, capture the predicated parent
+ -- or the existing predicate function for SPARK use.
+
+ if Present (Predicate_Function (Typ)) then
+ Set_Predicate_Function (Itype, Predicate_Function (Typ));
+
+ elsif Is_Itype (Typ) then
+ Set_Predicated_Parent (Itype, Predicated_Parent (Typ));
+
+ else
+ Set_Predicated_Parent (Itype, Typ);
+ end if;
+ end if;
+
-- A simple optimization: purely positional aggregates of static
-- components should be passed to gigi unexpanded whenever possible, and
-- regardless of the staticness of the bounds themselves. Subsequent
-------------------------
function Is_Others_Aggregate (Aggr : Node_Id) return Boolean is
+ Assoc : constant List_Id := Component_Associations (Aggr);
+
begin
return No (Expressions (Aggr))
- and then
- Nkind (First (Choice_List (First (Component_Associations (Aggr))))) =
- N_Others_Choice;
+ and then Nkind (First (Choice_List (First (Assoc)))) = N_Others_Choice;
end Is_Others_Aggregate;
+ -------------------------
+ -- Is_Single_Aggregate --
+ -------------------------
+
+ function Is_Single_Aggregate (Aggr : Node_Id) return Boolean is
+ Assoc : constant List_Id := Component_Associations (Aggr);
+
+ begin
+ return No (Expressions (Aggr))
+ and then No (Next (First (Assoc)))
+ and then No (Next (First (Choice_List (First (Assoc)))));
+ end Is_Single_Aggregate;
+
----------------------------
-- Is_Top_Level_Aggregate --
----------------------------
procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Pkind : constant Node_Kind := Nkind (Parent (N));
Aggr_Subtyp : Entity_Id;
-- The actual aggregate subtype. This is not necessarily the same as Typ
-- If the aggregate has box-initialized components, its type must be
-- frozen so that initialization procedures can properly be called
- -- in the resolution that follows. The replacement of boxes with
+ -- in the resolution that follows. The replacement of boxes with
-- initialization calls is properly an expansion activity but it must
-- be done during resolution.
-- permit it, or the aggregate type is unconstrained, an OTHERS
-- choice is not allowed (except that it is always allowed on the
-- right-hand side of an assignment statement; in this case the
- -- constrainedness of the type doesn't matter).
+ -- constrainedness of the type doesn't matter, because an array
+ -- object is always constrained).
-- If expansion is disabled (generic context, or semantics-only
-- mode) actual subtypes cannot be constructed, and the type of an
-- object may be its unconstrained nominal type. However, if the
- -- context is an assignment, we assume that OTHERS is allowed,
- -- because the target of the assignment will have a constrained
- -- subtype when fully compiled.
+ -- context is an assignment statement, OTHERS is allowed, because
+ -- the target of the assignment will have a constrained subtype
+ -- when fully compiled. Ditto if the context is an initialization
+ -- procedure where a component may have a predicate function that
+ -- carries the base type.
-- Note that there is no node for Explicit_Actual_Parameter.
-- To test for this context we therefore have to test for node
Set_Etype (N, Aggr_Typ); -- May be overridden later on
- if Pkind = N_Assignment_Statement
+ if Nkind (Parent (N)) = N_Assignment_Statement
+ or else Inside_Init_Proc
or else (Is_Constrained (Typ)
- and then
- (Pkind = N_Parameter_Association or else
- Pkind = N_Function_Call or else
- Pkind = N_Procedure_Call_Statement or else
- Pkind = N_Generic_Association or else
- Pkind = N_Formal_Object_Declaration or else
- Pkind = N_Simple_Return_Statement or else
- Pkind = N_Object_Declaration or else
- Pkind = N_Component_Declaration or else
- Pkind = N_Parameter_Specification or else
- Pkind = N_Qualified_Expression or else
- Pkind = N_Reference or else
- Pkind = N_Aggregate or else
- Pkind = N_Extension_Aggregate or else
- Pkind = N_Component_Association))
+ 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))
then
Aggr_Resolved :=
Resolve_Array_Aggregate
-- component assignments. If the expression covers several components
-- the analysis and the predicate check take place later.
- if Present (Predicate_Function (Component_Typ))
+ if Has_Predicates (Component_Typ)
and then Analyzed (Expr)
then
Apply_Predicate_Check (Expr, Component_Typ);
(N : Node_Id;
Index_Typ : Entity_Id)
is
- Id : constant Entity_Id := Defining_Identifier (N);
Loc : constant Source_Ptr := Sloc (N);
Choice : Node_Id;
Dummy : Boolean;
Ent : Entity_Id;
+ Expr : Node_Id;
+ Id : Entity_Id;
begin
Choice := First (Discrete_Choices (N));
Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L');
Set_Etype (Ent, Standard_Void_Type);
Set_Parent (Ent, Parent (N));
+ Push_Scope (Ent);
+ Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (N)));
- -- Decorate the index variable in the current scope. The association
- -- may have several choices, each one leading to a loop, so we create
- -- this variable only once to prevent homonyms in this scope.
+ -- 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.
- if No (Scope (Id)) then
- Enter_Name (Id);
- Set_Etype (Id, Index_Typ);
- Set_Ekind (Id, E_Variable);
- Set_Scope (Id, Ent);
- Set_Referenced (Id);
+ 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.
+
+ Expr := New_Copy_Tree (Expression (N));
+ Dummy := Resolve_Aggr_Expr (Expr, False);
+
+ -- 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));
+ Set_Etype (Expression (N), Etype (Expr));
end if;
- Push_Scope (Ent);
- Dummy := Resolve_Aggr_Expr (Expression (N), False);
End_Scope;
end Resolve_Iterated_Component_Association;
-- If the subtype has a static predicate, replace the
-- original choice with the list of individual values
- -- covered by the predicate. Do not perform this
- -- transformation if we need to preserve the source
- -- for ASIS use.
+ -- covered by the predicate.
-- This should be deferred to expansion time ???
- if Present (Static_Discrete_Predicate (E))
- and then not ASIS_Mode
- then
+ if Present (Static_Discrete_Predicate (E)) then
Delete_Choice := True;
New_Cs := New_List;
if Lo_Dup > Hi_Dup then
null;
- -- Otherwise place proper message. Because
- -- of the missing expansion of subtypes with
- -- predicates in ASIS mode, do not report
- -- spurious overlap errors.
-
- elsif ASIS_Mode
- and then
- ((Is_Type (Entity (Table (J).Choice))
- and then Has_Predicates
- (Entity (Table (J).Choice)))
- or else
- (Is_Type (Entity (Table (K).Choice))
- and then Has_Predicates
- (Entity (Table (K).Choice))))
- then
- null;
+ -- Otherwise place proper message
else
-- We place message on later choice, with a
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 -gnatX", N);
+ end if;
+
if not Is_Composite_Type (Typ) then
Error_Msg_N ("not a composite type", N);
end if;
-- Resolve_Delta_Record_Aggregate --
------------------------------------
- procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ 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
procedure Check_Variant (Id : Entity_Id) is
Comp : Entity_Id;
- Comp_Ref : Entity_Id;
Comp_Variant : Node_Id;
- Variant : Node_Id;
begin
if not Has_Discriminants (Typ) then
return;
end if;
- Variant := Empty;
-
Comp := First_Entity (Typ);
while Present (Comp) loop
exit when Chars (Comp) = Chars (Id);
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);
return Etype (Comp);
end if;
- Comp := Next_Entity (Comp);
+ Next_Entity (Comp);
end loop;
Error_Msg_NE ("type& has no component with this name", Nam, Typ);
Assoc : Node_Id;
Choice : Node_Id;
- Comp_Type : 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));
Next (Choice);
end loop;
+ pragma Assert (Present (Comp_Type));
Analyze_And_Resolve (Expression (Assoc), Comp_Type);
Next (Assoc);
end loop;
elsif Nkind (Anc) = N_Qualified_Expression then
return Valid_Limited_Ancestor (Expression (Anc));
+ elsif Nkind (Anc) = N_Raise_Expression then
+ return True;
+
else
return False;
end if;
then
return True;
+ -- The parent type may be a raise expression (which is legal in
+ -- any expression context).
+
+ elsif A_Type = Raise_Type then
+ A_Type := Etype (Imm_Type);
+ return True;
+
else
Imm_Type := Etype (Base_Type (Imm_Type));
end if;
-- access types, even in compile_only mode.
if not Inside_A_Generic then
-
- -- In ASIS mode, preanalyze the expression in an
- -- others association before making copies for
- -- separate resolution and accessibility checks.
- -- This ensures that the type of the expression is
- -- available to ASIS in all cases, in particular if
- -- the expression is itself an aggregate.
-
- if ASIS_Mode then
- Preanalyze_And_Resolve (Expression (Assoc), Typ);
- end if;
-
return
New_Copy_Tree_And_Copy_Dimensions
(Expression (Assoc));
-
else
return Expression (Assoc);
end if;
-- because the aggegate might not be expanded into individual
-- component assignments.
- if Present (Predicate_Function (Expr_Type))
+ if Has_Predicates (Expr_Type)
and then Analyzed (Expr)
then
Apply_Predicate_Check (Expr, Expr_Type);
Expr_Disc : Node_Id)
is
begin
- if Nkind (Bound) = N_Identifier
- and then Entity (Bound) = Disc
+ if Nkind (Bound) /= N_Identifier then
+ return;
+ end if;
+
+ -- We expect either the discriminant or the discriminal
+
+ if Entity (Bound) = Disc
+ or else (Ekind (Entity (Bound)) = E_In_Parameter
+ and then Discriminal_Link (Entity (Bound)) = Disc)
then
Rewrite (Bound, New_Copy_Tree (Expr_Disc));
end if;
-- Start of processing for Rewrite_Range
begin
- if Has_Discriminants (Root_Type)
- and then Nkind (Rge) = N_Range
- then
+ if Has_Discriminants (Root_Type) and then Nkind (Rge) = N_Range then
Low := Low_Bound (Rge);
High := High_Bound (Rge);
-- Root record type whose discriminants may be used as
-- bounds in range nodes.
- Index : Node_Id;
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Index : Node_Id;
begin
-- Rewrite the range nodes occurring in the indexes
end loop;
-- Rewrite the range nodes occurring as aggregate
- -- bounds.
+ -- bounds and component associations.
- if Nkind (Expr) = N_Aggregate
- and then Present (Aggregate_Bounds (Expr))
- then
- Rewrite_Range (Rec_Typ, Aggregate_Bounds (Expr));
+ if Nkind (Expr) = N_Aggregate then
+ if Present (Aggregate_Bounds (Expr)) then
+ Rewrite_Range (Rec_Typ, Aggregate_Bounds (Expr));
+ end if;
+
+ if Present (Component_Associations (Expr)) then
+ Assoc := First (Component_Associations (Expr));
+ while Present (Assoc) loop
+ Choice := First (Choices (Assoc));
+ while Present (Choice) loop
+ Rewrite_Range (Rec_Typ, Choice);
+
+ Next (Choice);
+ end loop;
+
+ Next (Assoc);
+ end loop;
+ end if;
end if;
end;
end if;
projects / thirdparty / gcc.git / blobdiff