-- --
-- 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- --
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;
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
-- The node of the choice
end record;
- type Case_Table_Type is array (Nat range <>) of Case_Bounds;
- -- Table type used by Check_Case_Choices procedure. Entry zero is not
- -- used (reserved for the sort). Real entries start at one.
+ type Case_Table_Type is array (Pos range <>) of Case_Bounds;
+ -- Table type used by Check_Case_Choices procedure
-----------------------
-- Local Subprograms --
-- 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.
-
- procedure Check_Qualified_Aggregate (Level : Nat; Expr : Node_Id);
- -- Given aggregate Expr, check that sub-aggregates of Expr that are nested
- -- at Level are qualified. If Level = 0, this applies to Expr directly.
- -- Only issue errors in formal verification mode.
-
- function Is_Top_Level_Aggregate (Expr : Node_Id) return Boolean;
- -- Return True of Expr is an aggregate not contained directly in another
- -- aggregate.
+ -- have already preanalyzed and it is known to be type correct.
------------------------------------------------------
-- Subprograms used for RECORD AGGREGATE Processing --
--
-- Once this new Component_Association_List is built and all the semantic
-- checks performed, the original aggregate subtree is replaced with the
- -- new named record aggregate just built. Note that subtree substitution is
- -- performed with Rewrite so as to be able to retrieve the original
- -- aggregate.
+ -- new named record aggregate just built. This new record aggregate has no
+ -- positional associations, so its Expressions field is set to No_List.
+ -- Note that subtree substitution is performed with Rewrite so as to be
+ -- able to retrieve the original aggregate.
--
-- The aggregate subtree manipulation performed by Resolve_Record_Aggregate
-- yields the aggregate format expected by Gigi. Typically, this kind of
-- misspelling of one of the components of the Assoc_List. This is called
-- by Resolve_Aggr_Expr after producing an invalid component error message.
- procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id);
- -- An optimization: determine whether a discriminated subtype has a static
- -- constraint, and contains array components whose length is also static,
- -- either because they are constrained by the discriminant, or because the
- -- original component bounds are static.
-
-----------------------------------------------------
-- Subprograms used for ARRAY AGGREGATE Processing --
-----------------------------------------------------
-- 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 --
------------------------
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
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
end if;
end Check_Expr_OK_In_Limited_Aggregate;
- -------------------------------
- -- Check_Qualified_Aggregate --
- -------------------------------
-
- procedure Check_Qualified_Aggregate (Level : Nat; Expr : Node_Id) is
- Comp_Expr : Node_Id;
- Comp_Assn : Node_Id;
-
- begin
- if Level = 0 then
- if Nkind (Parent (Expr)) /= N_Qualified_Expression then
- Check_SPARK_05_Restriction ("aggregate should be qualified", Expr);
- end if;
-
- else
- Comp_Expr := First (Expressions (Expr));
- while Present (Comp_Expr) loop
- if Nkind (Comp_Expr) = N_Aggregate then
- Check_Qualified_Aggregate (Level - 1, Comp_Expr);
- end if;
-
- Comp_Expr := Next (Comp_Expr);
- end loop;
-
- Comp_Assn := First (Component_Associations (Expr));
- while Present (Comp_Assn) loop
- Comp_Expr := Expression (Comp_Assn);
-
- if Nkind (Comp_Expr) = N_Aggregate then
- Check_Qualified_Aggregate (Level - 1, Comp_Expr);
- end if;
-
- Comp_Assn := Next (Comp_Assn);
- end loop;
- end if;
- end Check_Qualified_Aggregate;
-
- ----------------------------------------
- -- Check_Static_Discriminated_Subtype --
- ----------------------------------------
-
- procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id) is
- Disc : constant Entity_Id := First_Discriminant (T);
- Comp : Entity_Id;
- Ind : Entity_Id;
-
- begin
- if Has_Record_Rep_Clause (T) then
- return;
-
- elsif Present (Next_Discriminant (Disc)) then
- return;
-
- elsif Nkind (V) /= N_Integer_Literal then
- return;
- end if;
-
- Comp := First_Component (T);
- while Present (Comp) loop
- if Is_Scalar_Type (Etype (Comp)) then
- null;
-
- elsif Is_Private_Type (Etype (Comp))
- and then Present (Full_View (Etype (Comp)))
- and then Is_Scalar_Type (Full_View (Etype (Comp)))
- then
- null;
-
- elsif Is_Array_Type (Etype (Comp)) then
- if Is_Bit_Packed_Array (Etype (Comp)) then
- return;
- end if;
-
- Ind := First_Index (Etype (Comp));
- while Present (Ind) loop
- if Nkind (Ind) /= N_Range
- or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal
- or else Nkind (High_Bound (Ind)) /= N_Integer_Literal
- then
- return;
- end if;
-
- Next_Index (Ind);
- end loop;
-
- else
- return;
- end if;
-
- Next_Component (Comp);
- end loop;
-
- -- On exit, all components have statically known sizes
-
- Set_Size_Known_At_Compile_Time (T);
- end Check_Static_Discriminated_Subtype;
-
-------------------------
-- Is_Others_Aggregate --
-------------------------
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_Top_Level_Aggregate --
- ----------------------------
+ -------------------------
+ -- Is_Single_Aggregate --
+ -------------------------
+
+ function Is_Single_Aggregate (Aggr : Node_Id) return Boolean is
+ Assoc : constant List_Id := Component_Associations (Aggr);
- function Is_Top_Level_Aggregate (Expr : Node_Id) return Boolean is
begin
- return Nkind (Parent (Expr)) /= N_Aggregate
- and then (Nkind (Parent (Expr)) /= N_Component_Association
- or else Nkind (Parent (Parent (Expr))) /= N_Aggregate);
- end Is_Top_Level_Aggregate;
+ return No (Expressions (Aggr))
+ and then No (Next (First (Assoc)))
+ and then No (Next (First (Choice_List (First (Assoc)))));
+ end Is_Single_Aggregate;
--------------------------------
-- Make_String_Into_Aggregate --
-----------------------
procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Pkind : constant Node_Kind := Nkind (Parent (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
-- 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.
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;
end if;
- -- An unqualified aggregate is restricted in SPARK to:
-
- -- An aggregate item inside an aggregate for a multi-dimensional array
-
- -- An expression being assigned to an unconstrained array, but only if
- -- the aggregate specifies a value for OTHERS only.
-
- if Nkind (Parent (N)) = N_Qualified_Expression then
- if Is_Array_Type (Typ) then
- Check_Qualified_Aggregate (Number_Dimensions (Typ), N);
- else
- Check_Qualified_Aggregate (1, N);
- end if;
- else
- if Is_Array_Type (Typ)
- and then Nkind (Parent (N)) = N_Assignment_Statement
- and then not Is_Constrained (Etype (Name (Parent (N))))
- then
- if not Is_Others_Aggregate (N) then
- Check_SPARK_05_Restriction
- ("array aggregate should have only OTHERS", N);
- end if;
-
- elsif Is_Top_Level_Aggregate (N) then
- Check_SPARK_05_Restriction ("aggregate should be qualified", N);
-
- -- The legality of this unqualified aggregate is checked by calling
- -- Check_Qualified_Aggregate from one of its enclosing aggregate,
- -- unless one of these already causes an error to be issued.
-
- else
- null;
- end if;
- end if;
-
-- Check for aggregates not allowed in configurable run-time mode.
-- We allow all cases of aggregates that do not come from source, since
-- these are all assumed to be small (e.g. bounds of a string literal).
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);
-- 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 (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
-- 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.
-- If an aggregate component has a type with predicates, an explicit
-- predicate check must be applied, as for an assignment statement,
- -- because the aggegate might not be expanded into individual
+ -- because the aggregate might not be expanded into individual
-- 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);
+ 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;
+
+ -- Start of processing for Resolve_Iterated_Component_Association
begin
+ -- An element iterator specification cannot appear in
+ -- an array aggregate because it does not provide index
+ -- values for the association. This must be a semantic
+ -- check because the parser cannot tell whether this is
+ -- an array aggregate or a container aggregate.
+
+ if Present (Iterator_Specification (N)) then
+ Error_Msg_N ("container element Iterator cannot appear "
+ & "in an array aggregate", N);
+ return;
+ end if;
+
Choice := First (Discrete_Choices (N));
while Present (Choice) loop
Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L');
Set_Etype (Ent, Standard_Void_Type);
Set_Parent (Ent, Parent (N));
+ Push_Scope (Ent);
- -- 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.
+ -- directly visible.
+
+ Enter_Name (Id);
+ Set_Etype (Id, Index_Typ);
+ Set_Ekind (Id, E_Variable);
+ Set_Scope (Id, Ent);
+
+ -- 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);
- 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);
+ 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.
+
+ 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 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 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 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;
-- if a choice in an aggregate is a subtype indication these
-- denote the lowest and highest values of the subtype
- Table : Case_Table_Type (0 .. Case_Table_Size);
- -- Used to sort all the different choice values. Entry zero is
- -- reserved for sorting purposes.
+ Table : Case_Table_Type (1 .. Case_Table_Size);
+ -- Used to sort all the different choice values
Single_Choice : Boolean;
-- Set to true every time there is a single discrete choice in a
-- bounds of the array aggregate are within range.
Set_Do_Range_Check (Choice, False);
-
- -- In SPARK, the choice must be static
-
- if not (Is_OK_Static_Expression (Choice)
- or else (Nkind (Choice) = N_Range
- and then Is_OK_Static_Range (Choice)))
- then
- Check_SPARK_05_Restriction
- ("choice should be static", Choice);
- end if;
end if;
-- If we could not resolve the discrete choice stop here
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)
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
-- 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 :=
return Success;
end Resolve_Array_Aggregate;
- -----------------------------
- -- Resolve_Delta_Aggregate --
- -----------------------------
+ ---------------------------------
+ -- Resolve_Container_Aggregate --
+ ---------------------------------
- procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Base : constant Node_Id := Expression (N);
- Deltas : constant List_Id := Component_Associations (N);
+ procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ procedure Resolve_Iterated_Association
+ (Comp : Node_Id;
+ Key_Type : Entity_Id;
+ Elmt_Type : Entity_Id);
+ -- 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
+ -- with the key type. For a positional container, the choice must be
+ -- a subtype indication or an iterator specification that determines
+ -- an element type.
+
+ Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate);
+
+ Empty_Subp : Node_Id := Empty;
+ Add_Named_Subp : Node_Id := Empty;
+ Add_Unnamed_Subp : Node_Id := Empty;
+ New_Indexed_Subp : Node_Id := Empty;
+ Assign_Indexed_Subp : Node_Id := Empty;
+
+ ----------------------------------
+ -- Resolve_Iterated_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;
+ Key_Expr : Node_Id;
+ Id : Entity_Id;
+ Id_Name : Name_Id;
+ Iter : Node_Id;
+ Typ : Entity_Id := Empty;
- function Get_Component_Type (Nam : Node_Id) return Entity_Id;
+ begin
+ -- 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;
- ------------------------
- -- Get_Component_Type --
- ------------------------
+ -- 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.
- function Get_Component_Type (Nam : Node_Id) return Entity_Id is
- Comp : Entity_Id;
+ Key_Expr := Key_Expression (Comp);
+ Analyze_And_Resolve (New_Copy_Tree (Key_Expr), Key_Type);
- begin
- Comp := First_Entity (Typ);
+ 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));
- while Present (Comp) loop
- if Chars (Comp) = Chars (Nam) then
- if Ekind (Comp) = E_Discriminant then
- Error_Msg_N ("delta cannot apply to discriminant", Nam);
+ else
+ Choice := First (Discrete_Choices (Comp));
+
+ while Present (Choice) loop
+ Analyze (Choice);
+
+ -- Choice can be a subtype name, a range, or an expression
+
+ 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;
- return Etype (Comp);
- end if;
+ Next (Choice);
+ end loop;
- Comp := Next_Entity (Comp);
- end loop;
+ Id_Name := Chars (Defining_Identifier (Comp));
+ end if;
- Error_Msg_NE ("type& has no component with this name", Nam, Typ);
- return Any_Type;
- end Get_Component_Type;
+ -- Create a scope in which to introduce an index, which is usually
+ -- visible in the expression for the component, and needed for its
+ -- analysis.
- -- Local variables
+ 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);
- Assoc : Node_Id;
- Choice : Node_Id;
- Comp_Type : Entity_Id;
- Index_Type : Entity_Id;
+ -- Insert and decorate the loop variable in the current scope.
+ -- The expression has to be analyzed once the loop 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.
- -- Start of processing for Resolve_Delta_Aggregate
+ Enter_Name (Id);
- begin
- if not Is_Composite_Type (Typ) then
- Error_Msg_N ("not a composite type", N);
- end if;
+ if No (Key_Type) then
+ pragma Assert (Present (Typ));
+ Set_Etype (Id, Typ);
+ else
+ Set_Etype (Id, Key_Type);
+ end if;
- Analyze_And_Resolve (Base, Typ);
+ Set_Ekind (Id, E_Variable);
+ Set_Scope (Id, Ent);
+ Set_Referenced (Id);
- 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);
+ -- 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.
- else
- Analyze_And_Resolve (Choice, Index_Type);
- end if;
+ Expr := New_Copy_Tree (Expression (Comp));
+ Preanalyze_And_Resolve (Expr, Elmt_Type);
+ End_Scope;
- Next (Choice);
- end loop;
+ end Resolve_Iterated_Association;
- declare
- Id : constant Entity_Id := Defining_Identifier (Assoc);
- Ent : constant Entity_Id :=
- New_Internal_Entity
- (E_Loop, Current_Scope, Sloc (Assoc), 'L');
+ begin
+ pragma Assert (Nkind (Asp) = N_Aggregate);
- 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;
+ Set_Etype (N, Typ);
+ Parse_Aspect_Aggregate (Asp,
+ Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
+ New_Indexed_Subp, Assign_Indexed_Subp);
- Push_Scope (Ent);
- Analyze_And_Resolve
- (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ));
- End_Scope;
- end;
+ if Present (Add_Unnamed_Subp)
+ and then No (New_Indexed_Subp)
+ then
+ declare
+ Elmt_Type : constant Entity_Id :=
+ Etype (Next_Formal
+ (First_Formal (Entity (Add_Unnamed_Subp))));
+ Comp : Node_Id;
- 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);
+ begin
+ if Present (Expressions (N)) then
+ -- positional aggregate
- else
- Analyze (Choice);
- if Is_Entity_Name (Choice)
- and then Is_Type (Entity (Choice))
+ Comp := First (Expressions (N));
+ while Present (Comp) loop
+ Analyze_And_Resolve (Comp, Elmt_Type);
+ Next (Comp);
+ end loop;
+ end if;
+
+ -- Empty aggregate, to be replaced by Empty during
+ -- expansion, or iterated component association.
+
+ if Present (Component_Associations (N)) then
+ declare
+ Comp : Node_Id := First (Component_Associations (N));
+ begin
+ while Present (Comp) loop
+ if Nkind (Comp) /=
+ N_Iterated_Component_Association
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;
+ Error_Msg_N ("illegal component association "
+ & "for unnamed container aggregate", Comp);
+ return;
else
- Resolve (Choice, Index_Type);
+ Resolve_Iterated_Association
+ (Comp, Empty, Elmt_Type);
end if;
- end if;
-
- Next (Choice);
- end loop;
- Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ));
+ Next (Comp);
+ end loop;
+ end;
end if;
+ end;
- Next (Assoc);
- end loop;
+ elsif Present (Add_Named_Subp) then
+ declare
+ -- Retrieves types of container, key, and element from the
+ -- specified insertion procedure.
- 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;
+ Container : constant Entity_Id :=
+ First_Formal (Entity (Add_Named_Subp));
+ Key_Type : constant Entity_Id := Etype (Next_Formal (Container));
+ Elmt_Type : constant Entity_Id :=
+ Etype (Next_Formal (Next_Formal (Container)));
+ Comp : Node_Id;
+ Choice : Node_Id;
- Analyze_And_Resolve (Expression (Assoc), Comp_Type);
- Next (Assoc);
- end loop;
+ begin
+ Comp := First (Component_Associations (N));
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Component_Association then
+ Choice := First (Choices (Comp));
+
+ 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) 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
+ -- 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;
+
+ -----------------------------
+ -- Resolve_Delta_Aggregate --
+ -----------------------------
+
+ procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ 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 -gnat2020", 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);
+ Index_Type : constant Entity_Id := Etype (First_Index (Typ));
+
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Expr : Node_Id;
+
+ begin
+ 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);
+ Push_Scope (Ent);
+
+ if No (Scope (Id)) then
+ Set_Etype (Id, Index_Type);
+ Set_Ekind (Id, E_Variable);
+ Set_Scope (Id, Ent);
+ end if;
+ Enter_Name (Id);
+
+ -- 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;
+
+ 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 not 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 (Nam : Node_Id) return Entity_Id;
+ -- Locate component with a given name and return it. If none found then
+ -- report error and return Empty.
+
+ 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 --
+ -------------------
+
+ function Get_Component (Nam : Node_Id) return Entity_Id is
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Entity (Typ);
+ while Present (Comp) loop
+ if Chars (Comp) = Chars (Nam) then
+ if Ekind (Comp) = E_Discriminant then
+ Error_Msg_N ("delta cannot apply to discriminant", Nam);
+ end if;
+
+ return Comp;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+
+ Error_Msg_NE ("type& has no component with this name", Nam, Typ);
+ return Empty;
+ end Get_Component;
+
+ ---------------
+ -- Nested_In --
+ ---------------
+
+ function Nested_In (V1, V2 : Node_Id) return Boolean is
+ Par : Node_Id;
+
+ begin
+ Par := Parent (V1);
+ while Nkind (Par) /= N_Full_Type_Declaration loop
+ if Par = V2 then
+ return True;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return False;
+ end Nested_In;
+
+ -------------------
+ -- Variant_Depth --
+ -------------------
+
+ function Variant_Depth (N : Node_Id) return Integer is
+ Depth : Integer;
+ Par : Node_Id;
+
+ begin
+ Depth := 0;
+ Par := Parent (N);
+ while Nkind (Par) /= N_Full_Type_Declaration loop
+ Depth := Depth + 1;
+ Par := Parent (Par);
+ end loop;
+
+ return Depth;
+ end Variant_Depth;
+
+ -- Local variables
+
+ Deltas : constant List_Id := Component_Associations (N);
+
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Comp : 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));
+ while Present (Choice) loop
+ Comp := Get_Component (Choice);
+
+ if Present (Comp) then
+ Check_Variant (Choice);
+
+ Comp_Type := Etype (Comp);
+
+ -- Decorate the component reference by setting its entity and
+ -- type, as otherwise backends like GNATprove would have to
+ -- rediscover this information by themselves.
+
+ Set_Entity (Choice, Comp);
+ Set_Etype (Choice, Comp_Type);
+ else
+ Comp_Type := Any_Type;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ 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 --
----------------------------
-- 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;
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
Analyze (A);
Check_Parameterless_Call (A);
- -- In SPARK, the ancestor part cannot be a type mark
-
if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
- Check_SPARK_05_Restriction ("ancestor part cannot be a type mark", A);
- -- AI05-0115: if the ancestor part is a subtype mark, the ancestor
- -- must not have unknown discriminants.
-
- if Has_Unknown_Discriminants (Root_Type (Typ)) 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);
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;
Box_Node : Node_Id := Empty;
Is_Box_Present : Boolean := False;
- Others_Box : Integer := 0;
+ Others_Box : Natural := 0;
-- Ada 2005 (AI-287): Variables used in case of default initialization
-- to provide a functionality similar to Others_Etype. Box_Present
-- indicates that the component takes its default initialization;
-- of the ancestor.
function Get_Value
- (Compon : Node_Id;
+ (Compon : Entity_Id;
From : List_Id;
Consider_Others_Choice : Boolean := False) return Node_Id;
-- Given a record component stored in parameter Compon, this function
-- If this is a box association the expression is missing, so use the
-- Sloc of the aggregate itself for the new association.
+ pragma Assert (Present (Expr) xor Is_Box_Present);
+
if Present (Expr) then
Loc := Sloc (Expr);
else
---------------
function Get_Value
- (Compon : Node_Id;
+ (Compon : Entity_Id;
From : List_Id;
Consider_Others_Choice : Boolean := False) return Node_Id
is
-- 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
-- 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
-
- -- 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;
is
Loc : constant Source_Ptr := Sloc (N);
- Needs_Box : Boolean := False;
-
procedure Process_Component (Comp : Entity_Id);
-- Add one component with a box association to the inner aggregate,
-- and recurse if component is itself composite.
begin
if Is_Record_Type (T) and then Has_Discriminants (T) then
- New_Aggr := Make_Aggregate (Loc, New_List, New_List);
+ New_Aggr := Make_Aggregate (Loc, No_List, New_List);
Set_Etype (New_Aggr, T);
Add_Association
Add_Discriminant_Values (New_Aggr, Assoc_List);
Propagate_Discriminants (New_Aggr, Assoc_List);
+ Build_Constrained_Itype
+ (New_Aggr, T, Component_Associations (New_Aggr));
else
- Needs_Box := True;
+ Add_Association
+ (Comp, Empty, Component_Associations (Aggr),
+ Is_Box_Present => True);
end if;
end Process_Component;
Next_Component (Comp);
end loop;
end if;
-
- if Needs_Box then
- Append_To (Component_Associations (Aggr),
- Make_Component_Association (Loc,
- Choices => New_List (Make_Others_Choice (Loc)),
- Expression => Empty,
- Box_Present => True));
- end if;
end 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.
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))
-- If an aggregate component has a type with predicates, an explicit
-- predicate check must be applied, as for an assignment statement,
- -- because the aggegate might not be expanded into individual
+ -- because the aggregate 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);
if Present (Component_Associations (N))
and then Present (First (Component_Associations (N)))
then
- if Present (Expressions (N)) then
- Check_SPARK_05_Restriction
- ("named association cannot follow positional one",
- First (Choices (First (Component_Associations (N)))));
- end if;
-
declare
Assoc : Node_Id;
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
if Nkind (Assoc) = N_Iterated_Component_Association then
- Error_Msg_N ("iterated component association can only "
- & "appear in an array aggregate", N);
+ Error_Msg_N
+ ("iterated component association can only appear in an "
+ & "array aggregate", N);
raise Unrecoverable_Error;
-
- 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);
+ Next (Assoc);
end loop;
end;
end if;
-- AI05-0115: if the ancestor part is a subtype mark, the ancestor
-- must not have unknown discriminants.
+ -- ??? We are not checking any subtype mark here and this code is not
+ -- exercised by any test, so it's likely wrong (in particular
+ -- we should not use Root_Type here but the subtype mark, if any),
+ -- and possibly not needed.
if Is_Derived_Type (Typ)
and then Has_Unknown_Discriminants (Root_Type (Typ))
-- STEP 4: Set the Etype of the record aggregate
- -- ??? This code is pretty much a copy of Sem_Ch3.Build_Subtype. That
- -- routine should really be exported in sem_util or some such and used
- -- in sem_ch3 and here rather than have a copy of the code which is a
- -- maintenance nightmare.
-
- -- ??? Performance WARNING. The current implementation creates a new
- -- itype for all aggregates whose base type is discriminated. This means
- -- that for record aggregates nested inside an array aggregate we will
- -- create a new itype for each record aggregate if the array component
- -- type has discriminants. For large aggregates this may be a problem.
- -- What should be done in this case is to reuse itypes as much as
- -- possible.
-
if Has_Discriminants (Typ)
or else (Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ)))
then
- Build_Constrained_Itype : declare
- Constrs : constant List_Id := New_List;
- Loc : constant Source_Ptr := Sloc (N);
- Def_Id : Entity_Id;
- Indic : Node_Id;
- New_Assoc : Node_Id;
- Subtyp_Decl : Node_Id;
-
- begin
- New_Assoc := First (New_Assoc_List);
- while Present (New_Assoc) loop
- Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc)));
- Next (New_Assoc);
- end loop;
-
- if Has_Unknown_Discriminants (Typ)
- and then Present (Underlying_Record_View (Typ))
- then
- Indic :=
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Underlying_Record_View (Typ), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => Constrs));
- else
- Indic :=
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Base_Type (Typ), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => Constrs));
- end if;
-
- Def_Id := Create_Itype (Ekind (Typ), N);
-
- Subtyp_Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Subtype_Indication => Indic);
- Set_Parent (Subtyp_Decl, Parent (N));
-
- -- Itypes must be analyzed with checks off (see itypes.ads)
-
- Analyze (Subtyp_Decl, Suppress => All_Checks);
-
- Set_Etype (N, Def_Id);
- Check_Static_Discriminated_Subtype
- (Def_Id, Expression (First (New_Assoc_List)));
- end Build_Constrained_Itype;
-
+ Build_Constrained_Itype (N, Typ, New_Assoc_List);
else
Set_Etype (N, Typ);
end if;
-- 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;
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
Expr : Node_Id;
begin
- Expr := Make_Aggregate (Loc, New_List, New_List);
+ Expr := Make_Aggregate (Loc, No_List, New_List);
Set_Etype (Expr, Ctyp);
-- If the enclosing type has discriminants, they have
Propagate_Discriminants
(Expr, Component_Associations (Expr));
+ Build_Constrained_Itype
+ (Expr, Ctyp, Component_Associations (Expr));
+
else
declare
Comp : Entity_Id;
projects / gcc.git / blobdiff