-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, 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- --
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
+with Exp_Ch6; use Exp_Ch6;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
-- 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
-- array of characters is expected. This procedure simply rewrites the
-- string as an aggregate, prior to resolution.
+ ---------------------------------
+ -- Delta aggregate processing --
+ ---------------------------------
+
+ procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id);
+
------------------------
-- Array_Aggr_Subtype --
------------------------
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
-- unless the expression covers a single component, or the
-- expander is inactive.
- -- In SPARK mode, expressions that can perform side-effects will
+ -- In SPARK mode, expressions that can perform side effects will
-- be recognized by the gnat2why back-end, and the whole
-- subprogram will be ignored. So semantic analysis can be
-- performed safely.
-- 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.
-
- if No (Scope (Id)) then
- Enter_Name (Id);
- Set_Etype (Id, Index_Typ);
- Set_Ekind (Id, E_Variable);
- Set_Scope (Id, Ent);
+ -- 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);
+ 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
-----------------------------
procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Base : constant Node_Id := Expression (N);
+ 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;
+
+ Analyze_And_Resolve (Base, Typ);
+
+ if Is_Array_Type (Typ) then
+ Resolve_Delta_Array_Aggregate (N, Typ);
+ else
+ Resolve_Delta_Record_Aggregate (N, Typ);
+ end if;
+
+ Set_Etype (N, Typ);
+ end Resolve_Delta_Aggregate;
+
+ -----------------------------------
+ -- Resolve_Delta_Array_Aggregate --
+ -----------------------------------
+
+ procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id) is
Deltas : constant List_Id := Component_Associations (N);
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Index_Type : Entity_Id;
+
+ begin
+ Index_Type := Etype (First_Index (Typ));
+
+ Assoc := First (Deltas);
+ while Present (Assoc) loop
+ if Nkind (Assoc) = N_Iterated_Component_Association then
+ Choice := First (Choice_List (Assoc));
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Others_Choice then
+ Error_Msg_N
+ ("others not allowed in delta aggregate", Choice);
+
+ else
+ Analyze_And_Resolve (Choice, Index_Type);
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ declare
+ Id : constant Entity_Id := Defining_Identifier (Assoc);
+ Ent : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Loop, Current_Scope, Sloc (Assoc), 'L');
+
+ begin
+ Set_Etype (Ent, Standard_Void_Type);
+ Set_Parent (Ent, Assoc);
+
+ if No (Scope (Id)) then
+ Enter_Name (Id);
+ Set_Etype (Id, Index_Type);
+ Set_Ekind (Id, E_Variable);
+ Set_Scope (Id, Ent);
+ end if;
+
+ Push_Scope (Ent);
+ Analyze_And_Resolve
+ (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ));
+ End_Scope;
+ end;
+
+ else
+ Choice := First (Choice_List (Assoc));
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Others_Choice then
+ Error_Msg_N
+ ("others not allowed in delta aggregate", Choice);
+
+ else
+ Analyze (Choice);
+
+ if Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ then
+ -- Choice covers a range of values
+
+ if Base_Type (Entity (Choice)) /=
+ Base_Type (Index_Type)
+ then
+ Error_Msg_NE
+ ("choice does mat match index type of",
+ Choice, Typ);
+ end if;
+ else
+ Resolve (Choice, Index_Type);
+ end if;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ));
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end Resolve_Delta_Array_Aggregate;
+
+ ------------------------------------
+ -- Resolve_Delta_Record_Aggregate --
+ ------------------------------------
+
+ 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
+ -- specified variant components of the delta.
+
function Get_Component_Type (Nam : Node_Id) return Entity_Id;
+ -- Locate component with a given name and return its type. If none found
+ -- report error.
+
+ function Nested_In (V1 : Node_Id; V2 : Node_Id) return Boolean;
+ -- Determine whether variant V1 is within variant V2
+
+ function Variant_Depth (N : Node_Id) return Integer;
+ -- Determine the distance of a variant to the enclosing type
+ -- declaration.
+
+ --------------------
+ -- Check_Variant --
+ --------------------
+
+ procedure Check_Variant (Id : Entity_Id) is
+ Comp : Entity_Id;
+ Comp_Variant : Node_Id;
+
+ begin
+ if not Has_Discriminants (Typ) then
+ return;
+ end if;
+
+ Comp := First_Entity (Typ);
+ while Present (Comp) loop
+ exit when Chars (Comp) = Chars (Id);
+ Next_Component (Comp);
+ end loop;
+
+ -- Find the variant, if any, whose component list includes the
+ -- component declaration.
+
+ Comp_Variant := Parent (Parent (List_Containing (Parent (Comp))));
+ if Nkind (Comp_Variant) = N_Variant then
+ if No (Variant) then
+ Variant := Comp_Variant;
+ Comp_Ref := Comp;
+
+ elsif Variant /= Comp_Variant then
+ declare
+ D1 : constant Integer := Variant_Depth (Variant);
+ D2 : constant Integer := Variant_Depth (Comp_Variant);
+
+ begin
+ if D1 = D2
+ or else
+ (D1 > D2 and then not Nested_In (Variant, Comp_Variant))
+ 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);
+
+ -- Otherwise retain the deeper variant for subsequent tests
+
+ elsif D2 > D1 then
+ Variant := Comp_Variant;
+ end if;
+ end;
+ end if;
+ end if;
+ end Check_Variant;
------------------------
-- Get_Component_Type --
begin
Comp := First_Entity (Typ);
-
while Present (Comp) loop
if Chars (Comp) = Chars (Nam) then
if Ekind (Comp) = E_Discriminant then
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);
return Any_Type;
end Get_Component_Type;
- -- Local variables
-
- Assoc : Node_Id;
- Choice : Node_Id;
- Comp_Type : Entity_Id;
- Index_Type : Entity_Id;
+ ---------------
+ -- Nested_In --
+ ---------------
- -- Start of processing for Resolve_Delta_Aggregate
+ function Nested_In (V1, V2 : Node_Id) return Boolean is
+ Par : Node_Id;
- begin
- if not Is_Composite_Type (Typ) then
- Error_Msg_N ("not a composite type", N);
- end if;
+ begin
+ Par := Parent (V1);
+ while Nkind (Par) /= N_Full_Type_Declaration loop
+ if Par = V2 then
+ return True;
+ end if;
- Analyze_And_Resolve (Base, Typ);
+ Par := Parent (Par);
+ end loop;
- if Is_Array_Type (Typ) then
- Index_Type := Etype (First_Index (Typ));
- Assoc := First (Deltas);
- while Present (Assoc) loop
- if Nkind (Assoc) = N_Iterated_Component_Association then
- Choice := First (Choice_List (Assoc));
- while Present (Choice) loop
- if Nkind (Choice) = N_Others_Choice then
- Error_Msg_N
- ("others not allowed in delta aggregate", Choice);
+ return False;
+ end Nested_In;
- else
- Analyze_And_Resolve (Choice, Index_Type);
- end if;
+ -------------------
+ -- Variant_Depth --
+ -------------------
- Next (Choice);
- end loop;
+ function Variant_Depth (N : Node_Id) return Integer is
+ Depth : Integer;
+ Par : Node_Id;
- declare
- Id : constant Entity_Id := Defining_Identifier (Assoc);
- Ent : constant Entity_Id :=
- New_Internal_Entity
- (E_Loop, Current_Scope, Sloc (Assoc), 'L');
+ begin
+ Depth := 0;
+ Par := Parent (N);
+ while Nkind (Par) /= N_Full_Type_Declaration loop
+ Depth := Depth + 1;
+ Par := Parent (Par);
+ end loop;
- begin
- Set_Etype (Ent, Standard_Void_Type);
- Set_Parent (Ent, Assoc);
-
- if No (Scope (Id)) then
- Enter_Name (Id);
- Set_Etype (Id, Index_Type);
- Set_Ekind (Id, E_Variable);
- Set_Scope (Id, Ent);
- end if;
+ return Depth;
+ end Variant_Depth;
- Push_Scope (Ent);
- Analyze_And_Resolve
- (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ));
- End_Scope;
- end;
+ -- Local variables
- else
- Choice := First (Choice_List (Assoc));
- while Present (Choice) loop
- if Nkind (Choice) = N_Others_Choice then
- Error_Msg_N
- ("others not allowed in delta aggregate", Choice);
+ Deltas : constant List_Id := Component_Associations (N);
- else
- Analyze (Choice);
- if Is_Entity_Name (Choice)
- and then Is_Type (Entity (Choice))
- then
- -- Choice covers a range of values.
- if Base_Type (Entity (Choice)) /=
- Base_Type (Index_Type)
- then
- Error_Msg_NE
- ("choice does mat match index type of",
- Choice, Typ);
- end if;
- else
- Resolve (Choice, Index_Type);
- end if;
- end if;
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Comp_Type : Entity_Id := Empty; -- init to avoid warning
- Next (Choice);
- end loop;
+ -- Start of processing for Resolve_Delta_Record_Aggregate
- Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ));
- end if;
+ begin
+ Variant := Empty;
- Next (Assoc);
- end loop;
+ Assoc := First (Deltas);
+ while Present (Assoc) loop
+ Choice := First (Choice_List (Assoc));
+ while Present (Choice) loop
+ Comp_Type := Get_Component_Type (Choice);
- else
- Assoc := First (Deltas);
- while Present (Assoc) loop
- Choice := First (Choice_List (Assoc));
- while Present (Choice) loop
- Comp_Type := Get_Component_Type (Choice);
- Next (Choice);
- end loop;
+ if Comp_Type /= Any_Type then
+ Check_Variant (Choice);
+ end if;
- Analyze_And_Resolve (Expression (Assoc), Comp_Type);
- Next (Assoc);
+ Next (Choice);
end loop;
- end if;
- Set_Etype (N, Typ);
- end Resolve_Delta_Aggregate;
+ pragma Assert (Present (Comp_Type));
+ Analyze_And_Resolve (Expression (Assoc), Comp_Type);
+ Next (Assoc);
+ end loop;
+ end Resolve_Delta_Record_Aggregate;
---------------------------------
-- Resolve_Extension_Aggregate --
-- Verify that the type of the ancestor part is a non-private ancestor
-- of the expected type, which must be a type extension.
+ procedure Transform_BIP_Assignment (Typ : Entity_Id);
+ -- For an extension aggregate whose ancestor part is a build-in-place
+ -- call returning a nonlimited type, this is used to transform the
+ -- assignment to the ancestor part to use a temp.
+
----------------------------
-- Valid_Limited_Ancestor --
----------------------------
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;
return False;
end Valid_Ancestor_Type;
+ ------------------------------
+ -- Transform_BIP_Assignment --
+ ------------------------------
+
+ procedure Transform_BIP_Assignment (Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', A);
+ Obj_Decl : constant Node_Id :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => A,
+ Has_Init_Expression => True);
+ begin
+ Set_Etype (Def_Id, Typ);
+ Set_Ancestor_Part (N, New_Occurrence_Of (Def_Id, Loc));
+ Insert_Action (N, Obj_Decl);
+ end Transform_BIP_Assignment;
+
-- Start of processing for Resolve_Extension_Aggregate
begin
Get_First_Interp (A, I, It);
while Present (It.Typ) loop
- -- Only consider limited interpretations in the Ada 2005 case
+ -- Consider limited interpretations if Ada 2005 or higher
if Is_Tagged_Type (It.Typ)
and then (Ada_Version >= Ada_2005
Error_Msg_N ("ancestor part must be statically tagged", A);
else
+ -- We are using the build-in-place protocol, but we can't build
+ -- in place, because we need to call the function before
+ -- allocating the aggregate. Could do better for null
+ -- extensions, and maybe for nondiscriminated types.
+ -- This is wrong for limited, but those were wrong already.
+
+ if not Is_Limited_View (A_Type)
+ and then Is_Build_In_Place_Function_Call (A)
+ then
+ Transform_BIP_Assignment (A_Type);
+ end if;
+
Resolve_Record_Aggregate (N, Typ);
end if;
end if;
--
-- This variable is updated as a side effect of function Get_Value.
- Box_Node : Node_Id;
+ Box_Node : Node_Id := Empty;
Is_Box_Present : Boolean := False;
Others_Box : Integer := 0;
-- Ada 2005 (AI-287): Variables used in case of default initialization
-- An error message is emitted if the components taking their value from
-- the others choice do not have same type.
- function New_Copy_Tree_And_Copy_Dimensions
- (Source : Node_Id;
- Map : Elist_Id := No_Elist;
- New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty) return Node_Id;
- -- Same as New_Copy_Tree (defined in Sem_Util), except that this routine
- -- also copies the dimensions of Source to the returned node.
-
procedure Propagate_Discriminants
(Aggr : Node_Id;
Assoc_List : List_Id);
-- Parent pointer of Expr is not set then Expr was produced with a
-- New_Copy_Tree or some such.
+ procedure Rewrite_Range (Root_Type : Entity_Id; Rge : Node_Id);
+ -- Rewrite a range node Rge when its bounds refer to non-stored
+ -- discriminants from Root_Type, to replace them with the stored
+ -- discriminant values. This is required in GNATprove mode, and is
+ -- adopted in all modes to avoid special-casing GNATprove mode.
+
---------------------
-- Add_Association --
---------------------
-- This is redundant if the others_choice covers only
-- one component (small optimization possible???), but
-- indispensable otherwise, because each one must be
- -- expanded individually to preserve side-effects.
+ -- expanded individually to preserve side effects.
-- Ada 2005 (AI-287): In case of default initialization
-- of components, we duplicate the corresponding default
-- 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;
return Expr;
end Get_Value;
- ---------------------------------------
- -- New_Copy_Tree_And_Copy_Dimensions --
- ---------------------------------------
-
- function New_Copy_Tree_And_Copy_Dimensions
- (Source : Node_Id;
- Map : Elist_Id := No_Elist;
- New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty) return Node_Id
- is
- New_Copy : constant Node_Id :=
- New_Copy_Tree (Source, Map, New_Sloc, New_Scope);
-
- begin
- -- Move the dimensions of Source to New_Copy
-
- Copy_Dimensions (Source, New_Copy);
- return New_Copy;
- end New_Copy_Tree_And_Copy_Dimensions;
-
-----------------------------
-- Propagate_Discriminants --
-----------------------------
-- expansion is delayed until the enclosing aggregate is expanded
-- into assignments. In that case, do not generate checks on the
-- expression, because they will be generated later, and will other-
- -- wise force a copy (to remove side-effects) that would leave a
+ -- wise force a copy (to remove side effects) that would leave a
-- dynamic-sized aggregate in the code, something that gigi cannot
-- handle.
-- 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);
Add_Association (New_C, New_Expr, New_Assoc_List);
end Resolve_Aggr_Expr;
+ -------------------
+ -- Rewrite_Range --
+ -------------------
+
+ procedure Rewrite_Range (Root_Type : Entity_Id; Rge : Node_Id) is
+ procedure Rewrite_Bound
+ (Bound : Node_Id;
+ Disc : Entity_Id;
+ Expr_Disc : Node_Id);
+ -- Rewrite a bound of the range Bound, when it is equal to the
+ -- non-stored discriminant Disc, into the stored discriminant
+ -- value Expr_Disc.
+
+ -------------------
+ -- Rewrite_Bound --
+ -------------------
+
+ procedure Rewrite_Bound
+ (Bound : Node_Id;
+ Disc : Entity_Id;
+ Expr_Disc : Node_Id)
+ is
+ begin
+ 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;
+ end Rewrite_Bound;
+
+ -- Local variables
+
+ Low, High : Node_Id;
+ Disc : Entity_Id;
+ Expr_Disc : Elmt_Id;
+
+ -- Start of processing for Rewrite_Range
+
+ begin
+ if Has_Discriminants (Root_Type) and then Nkind (Rge) = N_Range then
+ Low := Low_Bound (Rge);
+ High := High_Bound (Rge);
+
+ Disc := First_Discriminant (Root_Type);
+ Expr_Disc := First_Elmt (Stored_Constraint (Etype (N)));
+ while Present (Disc) loop
+ Rewrite_Bound (Low, Disc, Node (Expr_Disc));
+ Rewrite_Bound (High, Disc, Node (Expr_Disc));
+ Next_Discriminant (Disc);
+ Next_Elmt (Expr_Disc);
+ end loop;
+ end if;
+ end Rewrite_Range;
+
-- Local variables
Components : constant Elist_Id := New_Elmt_List;
-- Components is the list of the record components whose value must be
-- provided in the aggregate. This list does include discriminants.
- Expr : Node_Id;
Component : Entity_Id;
Component_Elmt : Elmt_Id;
+ Expr : Node_Id;
Positional_Expr : Node_Id;
-- Start of processing for Resolve_Record_Aggregate
begin
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
- if List_Length (Choices (Assoc)) > 1 then
- Check_SPARK_05_Restriction
- ("component association in record aggregate must "
- & "contain a single choice", Assoc);
- end if;
+ if Nkind (Assoc) = N_Iterated_Component_Association then
+ Error_Msg_N
+ ("iterated component association can only appear in an "
+ & "array aggregate", N);
+ raise Unrecoverable_Error;
- if Nkind (First (Choices (Assoc))) = N_Others_Choice then
- Check_SPARK_05_Restriction
- ("record aggregate cannot contain OTHERS", Assoc);
+ else
+ if List_Length (Choices (Assoc)) > 1 then
+ Check_SPARK_05_Restriction
+ ("component association in record aggregate must "
+ & "contain a single choice", Assoc);
+ end if;
+
+ if Nkind (First (Choices (Assoc))) = N_Others_Choice then
+ Check_SPARK_05_Restriction
+ ("record aggregate cannot contain OTHERS", Assoc);
+ end if;
end if;
Assoc := Next (Assoc);
New_Scope => Current_Scope,
New_Sloc => Sloc (N));
+ -- As the type of the copied default expression may refer
+ -- to discriminants of the record type declaration, these
+ -- non-stored discriminants need to be rewritten into stored
+ -- discriminant values for the aggregate. This is required
+ -- in GNATprove mode, and is adopted in all modes to avoid
+ -- special-casing GNATprove mode.
+
+ if Is_Array_Type (Etype (Expr)) then
+ declare
+ Rec_Typ : constant Entity_Id := Scope (Component);
+ -- Root record type whose discriminants may be used as
+ -- bounds in range nodes.
+
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Index : Node_Id;
+
+ begin
+ -- Rewrite the range nodes occurring in the indexes
+ -- and their types.
+
+ Index := First_Index (Etype (Expr));
+ while Present (Index) loop
+ Rewrite_Range (Rec_Typ, Index);
+ Rewrite_Range
+ (Rec_Typ, Scalar_Range (Etype (Index)));
+
+ Next_Index (Index);
+ end loop;
+
+ -- Rewrite the range nodes occurring as aggregate
+ -- bounds and component associations.
+
+ 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;
+
Add_Association
(Component => Component,
Expr => Expr,
projects / thirdparty / gcc.git / blobdiff