-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, 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 Nlists; use Nlists;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
-- 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 --
-----------------------------------------------------
-- is set in Resolve_Array_Aggregate but the aggregate is not
-- immediately replaced with a raise CE. In fact, Array_Aggr_Subtype must
-- first construct the proper itype for the aggregate (Gigi needs
- -- this). After constructing the proper itype we will eventually replace
+ -- this). After constructing the proper itype we will eventually replace
-- the top-level aggregate with a raise CE (done in Resolve_Aggregate).
-- Of course in cases such as:
--
-- (in this particular case the bounds will be 1 .. 2).
procedure Make_String_Into_Aggregate (N : Node_Id);
- -- A string literal can appear in a context in which a one dimensional
+ -- A string literal can appear in a context in which a one dimensional
-- 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 --
------------------------
else
if Compile_Time_Known_Value (This_Low) then
if not Compile_Time_Known_Value (Aggr_Low (Dim)) then
- Aggr_Low (Dim) := This_Low;
+ Aggr_Low (Dim) := This_Low;
elsif Expr_Value (This_Low) /= Expr_Value (Aggr_Low (Dim)) then
Set_Raises_Constraint_Error (N);
if Compile_Time_Known_Value (This_High) then
if not Compile_Time_Known_Value (Aggr_High (Dim)) then
- Aggr_High (Dim) := This_High;
+ Aggr_High (Dim) := This_High;
elsif
Expr_Value (This_High) /= Expr_Value (Aggr_High (Dim))
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
begin
-- All the components of List are matched against Component and a count
- -- is maintained of possible misspellings. When at the end of the the
+ -- is maintained of possible misspellings. When at the end of the
-- analysis there are one or two (not more) possible misspellings,
- -- these misspellings will be suggested as possible correction.
+ -- these misspellings will be suggested as possible corrections.
Component_Elmt := First_Elmt (Elements);
while Nr_Of_Suggestions <= Max_Suggestions
case Nr_Of_Suggestions is
when 1 => Suggestion_1 := Node (Component_Elmt);
when 2 => Suggestion_2 := Node (Component_Elmt);
- when others => exit;
+ when others => null;
end case;
end if;
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 (Choices (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));
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.
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).
elsif Is_Array_Type (Typ) then
- -- First a special test, for the case of a positional aggregate
- -- of characters which can be replaced by a string literal.
+ -- First a special test, for the case of a positional aggregate of
+ -- characters which can be replaced by a string literal.
- -- Do not perform this transformation if this was a string literal to
- -- start with, whose components needed constraint checks, or if the
- -- component type is non-static, because it will require those checks
- -- and be transformed back into an aggregate.
+ -- Do not perform this transformation if this was a string literal
+ -- to start with, whose components needed constraint checks, or if
+ -- the component type is non-static, because it will require those
+ -- checks and be transformed back into an aggregate. If the index
+ -- type is not Integer the aggregate may represent a user-defined
+ -- string type but the context might need the original type so we
+ -- do not perform the transformation at this point.
if Number_Dimensions (Typ) = 1
and then Is_Standard_Character_Type (Component_Type (Typ))
and then not Is_Bit_Packed_Array (Typ)
and then Nkind (Original_Node (Parent (N))) /= N_String_Literal
and then Is_OK_Static_Subtype (Component_Type (Typ))
+ and then Base_Type (Etype (First_Index (Typ))) =
+ Base_Type (Standard_Integer)
then
declare
Expr : Node_Id;
-- 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))
- then
- Aggr_Resolved :=
- Resolve_Array_Aggregate
- (N,
- Index => First_Index (Aggr_Typ),
- Index_Constr => First_Index (Typ),
- Component_Typ => Component_Type (Typ),
- Others_Allowed => True);
-
- elsif not Expander_Active
- and then Pkind = N_Assignment_Statement
+ and then Nkind_In (Parent (N),
+ N_Parameter_Association,
+ N_Function_Call,
+ N_Procedure_Call_Statement,
+ N_Generic_Association,
+ N_Formal_Object_Declaration,
+ N_Simple_Return_Statement,
+ N_Object_Declaration,
+ N_Component_Declaration,
+ N_Parameter_Specification,
+ N_Qualified_Expression,
+ N_Reference,
+ N_Aggregate,
+ N_Extension_Aggregate,
+ N_Component_Association,
+ N_Case_Expression_Alternative,
+ N_If_Expression,
+ N_Expression_With_Actions))
then
Aggr_Resolved :=
Resolve_Array_Aggregate
Index_Constr => First_Index (Typ),
Component_Typ => Component_Type (Typ),
Others_Allowed => True);
-
else
Aggr_Resolved :=
Resolve_Array_Aggregate
Index_Base_High : constant Node_Id := Type_High_Bound (Index_Base);
-- Ditto for the base type
+ Others_Present : Boolean := False;
+
+ Nb_Choices : Nat := 0;
+ -- Contains the overall number of named choices in this sub-aggregate
+
function Add (Val : Uint; To : Node_Id) return Node_Id;
-- Creates a new expression node where Val is added to expression To.
-- Tries to constant fold whenever possible. To must be an already
-- N_Component_Association node as Expr, since there is no Expression in
-- that case, and we need a Sloc for the error message.
+ procedure Resolve_Iterated_Component_Association
+ (N : Node_Id;
+ Index_Typ : Entity_Id);
+ -- For AI12-061
+
---------
-- Add --
---------
-- 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
- -- component assignments.
+ -- component assignments. If the expression covers several components
+ -- the analysis and the predicate check take place later.
- if Present (Predicate_Function (Component_Typ)) then
+ if Has_Predicates (Component_Typ)
+ and then Analyzed (Expr)
+ then
Apply_Predicate_Check (Expr, Component_Typ);
end if;
return Resolution_OK;
end Resolve_Aggr_Expr;
- -- Variables local to Resolve_Array_Aggregate
+ --------------------------------------------
+ -- Resolve_Iterated_Component_Association --
+ --------------------------------------------
+
+ procedure Resolve_Iterated_Component_Association
+ (N : Node_Id;
+ Index_Typ : Entity_Id)
+ is
+ 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));
+
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Others_Choice then
+ Others_Present := True;
+
+ else
+ 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 (Index_Typ)
+ then
+ null;
+
+ else
+ Analyze_And_Resolve (Choice, Index_Typ);
+ end if;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ -- Create a scope in which to introduce an index, which is usually
+ -- visible in the expression for the component, and needed for its
+ -- analysis.
+
+ 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)));
+
+ -- 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.
+
+ 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;
+
+ End_Scope;
+ end Resolve_Iterated_Component_Association;
+
+ -- Local variables
Assoc : Node_Id;
Choice : Node_Id;
Expr : Node_Id;
Discard : Node_Id;
- Delete_Choice : Boolean;
- -- Used when replacing a subtype choice with predicate by a list
-
Aggr_Low : Node_Id := Empty;
Aggr_High : Node_Id := Empty;
-- The actual low and high bounds of this sub-aggregate
+ Case_Table_Size : Nat;
+ -- Contains the size of the case table needed to sort aggregate choices
+
Choices_Low : Node_Id := Empty;
Choices_High : Node_Id := Empty;
-- The lowest and highest discrete choices values for a named aggregate
+ Delete_Choice : Boolean;
+ -- Used when replacing a subtype choice with predicate by a list
+
Nb_Elements : Uint := Uint_0;
-- The number of elements in a positional aggregate
- Others_Present : Boolean := False;
-
- Nb_Choices : Nat := 0;
- -- Contains the overall number of named choices in this sub-aggregate
-
Nb_Discrete_Choices : Nat := 0;
-- The overall number of discrete choices (not counting others choice)
- Case_Table_Size : Nat;
- -- Contains the size of the case table needed to sort aggregate choices
-
-- Start of processing for Resolve_Array_Aggregate
begin
if Present (Component_Associations (N)) then
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
- Choice := First (Choices (Assoc));
+ if Nkind (Assoc) = N_Iterated_Component_Association then
+ Resolve_Iterated_Component_Association (Assoc, Index_Typ);
+ end if;
+
+ Choice := First (Choice_List (Assoc));
Delete_Choice := False;
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Others_Present := True;
- if Choice /= First (Choices (Assoc))
+ if Choice /= First (Choice_List (Assoc))
or else Present (Next (Choice))
then
Error_Msg_N
-- If the subtype has a static predicate, replace the
-- original choice with the list of individual values
-- covered by the predicate.
+ -- This should be deferred to expansion time ???
if Present (Static_Discrete_Predicate (E)) then
Delete_Choice := True;
then
Error_Msg_N
("named association cannot follow positional association",
- First (Choices (First (Component_Associations (N)))));
+ First (Choice_List (First (Component_Associations (N)))));
return Failure;
end if;
end if;
Step_2 : declare
+ function Empty_Range (A : Node_Id) return Boolean;
+ -- If an association covers an empty range, some warnings on the
+ -- expression of the association can be disabled.
+
+ -----------------
+ -- Empty_Range --
+ -----------------
+
+ function Empty_Range (A : Node_Id) return Boolean is
+ R : constant Node_Id := First (Choices (A));
+ begin
+ return No (Next (R))
+ and then Nkind (R) = N_Range
+ and then Compile_Time_Compare
+ (Low_Bound (R), High_Bound (R), False) = GT;
+ end Empty_Range;
+
+ -- Local variables
+
Low : Node_Id;
High : Node_Id;
-- Denote the lowest and highest values in an aggregate choice
-- 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
Errors_Posted_On_Choices : Boolean := False;
-- Keeps track of whether any choices have semantic errors
- function Empty_Range (A : Node_Id) return Boolean;
- -- If an association covers an empty range, some warnings on the
- -- expression of the association can be disabled.
-
- -----------------
- -- Empty_Range --
- -----------------
-
- function Empty_Range (A : Node_Id) return Boolean is
- R : constant Node_Id := First (Choices (A));
- begin
- return No (Next (R))
- and then Nkind (R) = N_Range
- and then Compile_Time_Compare
- (Low_Bound (R), High_Bound (R), False) = GT;
- end Empty_Range;
-
-- Start of processing for Step_2
begin
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
Prev_Nb_Discrete_Choices := Nb_Discrete_Choices;
- Choice := First (Choices (Assoc));
+ Choice := First (Choice_List (Assoc));
+
loop
Analyze (Choice);
-- 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;
+ if not (All_Composite_Constraints_Static (Low)
+ and then All_Composite_Constraints_Static (High)
+ and then All_Composite_Constraints_Static (S_Low)
+ and then All_Composite_Constraints_Static (S_High))
+ then
+ Check_Restriction (No_Dynamic_Sized_Objects, Choice);
+ end if;
+
Nb_Discrete_Choices := Nb_Discrete_Choices + 1;
Table (Nb_Discrete_Choices).Lo := Low;
Table (Nb_Discrete_Choices).Hi := High;
return Failure;
end if;
+ elsif Nkind (Assoc) = N_Iterated_Component_Association then
+ null; -- handled above, in a loop context.
+
elsif not Resolve_Aggr_Expr
(Expression (Assoc), Single_Elmt => Single_Choice)
then
Set_Parent (Expr, Parent (Expression (Assoc)));
Analyze (Expr);
+ -- Compute its dimensions now, rather than at the end of
+ -- resolution, because in the case of multidimensional
+ -- aggregates subsequent expansion may lead to spurious
+ -- errors.
+
+ Check_Expression_Dimensions (Expr, Component_Typ);
+
-- If the expression is a literal, propagate this info
-- to the expression in the association, to enable some
-- optimizations downstream.
if Others_Present then
Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
+ -- Abandon processing if either bound is already signalled as
+ -- an error (prevents junk cascaded messages and blow ups).
+
+ if Nkind (Aggr_Low) = N_Error
+ or else
+ Nkind (Aggr_High) = N_Error
+ then
+ return False;
+ end if;
+
-- No others clause present
else
if Others_Allowed then
Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
+ -- Abandon processing if either bound is already signalled
+ -- as an error (stop junk cascaded messages and blow ups).
+
+ if Nkind (Aggr_Low) = N_Error
+ or else
+ Nkind (Aggr_High) = N_Error
+ then
+ return False;
+ end if;
+
-- If others allowed, and no others present, then the array
-- should cover all index values. If it does not, we will
-- get a length check warning, but there is two cases where
return Success;
end Resolve_Array_Aggregate;
- ---------------------------------
- -- Resolve_Extension_Aggregate --
- ---------------------------------
+ -----------------------------
+ -- Resolve_Delta_Aggregate --
+ -----------------------------
- -- There are two cases to consider:
+ procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ Base : constant Node_Id := Expression (N);
- -- a) If the ancestor part is a type mark, the components needed are the
- -- difference between the components of the expected type and the
- -- components of the given type mark.
+ 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;
- -- b) If the ancestor part is an expression, it must be unambiguous, and
- -- once we have its type we can also compute the needed components as in
- -- the previous case. In both cases, if the ancestor type is not the
- -- immediate ancestor, we have to build this ancestor recursively.
+ if not Is_Composite_Type (Typ) then
+ Error_Msg_N ("not a composite type", N);
+ end if;
- -- In both cases, discriminants of the ancestor type do not play a role in
- -- the resolution of the needed components, because inherited discriminants
- -- cannot be used in a type extension. As a result we can compute
- -- independently the list of components of the ancestor type and of the
- -- expected type.
+ Analyze_And_Resolve (Base, Typ);
- procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id) is
- A : constant Node_Id := Ancestor_Part (N);
- A_Type : Entity_Id;
- I : Interp_Index;
- It : Interp;
+ if Is_Array_Type (Typ) then
+ Resolve_Delta_Array_Aggregate (N, Typ);
+ else
+ Resolve_Delta_Record_Aggregate (N, Typ);
+ end if;
- function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean;
- -- If the type is limited, verify that the ancestor part is a legal
- -- expression (aggregate or function call, including 'Input)) that does
- -- not require a copy, as specified in 7.5(2).
+ Set_Etype (N, Typ);
+ end Resolve_Delta_Aggregate;
- function Valid_Ancestor_Type return Boolean;
- -- Verify that the type of the ancestor part is a non-private ancestor
- -- of the expected type, which must be a type extension.
+ -----------------------------------
+ -- Resolve_Delta_Array_Aggregate --
+ -----------------------------------
- ----------------------------
- -- Valid_Limited_Ancestor --
- ----------------------------
+ procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ Deltas : constant List_Id := Component_Associations (N);
- function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean is
- begin
- if Is_Entity_Name (Anc) and then Is_Type (Entity (Anc)) then
- return True;
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Index_Type : Entity_Id;
- -- The ancestor must be a call or an aggregate, but a call may
- -- have been expanded into a temporary, so check original node.
+ begin
+ Index_Type := Etype (First_Index (Typ));
- elsif Nkind_In (Anc, N_Aggregate,
- N_Extension_Aggregate,
- N_Function_Call)
- then
- return True;
+ 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);
- elsif Nkind (Original_Node (Anc)) = N_Function_Call then
- return True;
+ else
+ Analyze_And_Resolve (Choice, Index_Type);
+ end if;
- elsif Nkind (Anc) = N_Attribute_Reference
- and then Attribute_Name (Anc) = Name_Input
- then
+ 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 (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 --
+ ---------------------------------
+
+ -- There are two cases to consider:
+
+ -- a) If the ancestor part is a type mark, the components needed are the
+ -- difference between the components of the expected type and the
+ -- components of the given type mark.
+
+ -- b) If the ancestor part is an expression, it must be unambiguous, and
+ -- once we have its type we can also compute the needed components as in
+ -- the previous case. In both cases, if the ancestor type is not the
+ -- immediate ancestor, we have to build this ancestor recursively.
+
+ -- In both cases, discriminants of the ancestor type do not play a role in
+ -- the resolution of the needed components, because inherited discriminants
+ -- cannot be used in a type extension. As a result we can compute
+ -- independently the list of components of the ancestor type and of the
+ -- expected type.
+
+ procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ A : constant Node_Id := Ancestor_Part (N);
+ A_Type : Entity_Id;
+ I : Interp_Index;
+ It : Interp;
+
+ function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean;
+ -- If the type is limited, verify that the ancestor part is a legal
+ -- expression (aggregate or function call, including 'Input)) that does
+ -- not require a copy, as specified in 7.5(2).
+
+ function Valid_Ancestor_Type return Boolean;
+ -- 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 --
+ ----------------------------
+
+ function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean is
+ begin
+ if Is_Entity_Name (Anc) and then Is_Type (Entity (Anc)) then
+ return True;
+
+ -- 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)
+ then
+ return True;
+
+ elsif Nkind (Original_Node (Anc)) = N_Function_Call then
+ return True;
+
+ elsif Nkind (Anc) = N_Attribute_Reference
+ and then Attribute_Name (Anc) = Name_Input
+ 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;
if Etype (Imm_Type) = Base_Type (A_Type) then
return True;
- -- The base type of the parent type may appear as a private
+ -- The base type of the parent type may appear as a private
-- extension if it is declared as such in a parent unit of the
-- current one. For consistency of the subsequent analysis use
-- the partial view for the ancestor part.
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
+ if Has_Unknown_Discriminants (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;
else
- Error_Msg_N ("no unique type for this aggregate", A);
+ Error_Msg_N ("no unique type for this aggregate", A);
end if;
Check_Function_Writable_Actuals (N);
------------------------------
procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Assoc : Node_Id;
- -- N_Component_Association node belonging to the input aggregate N
-
- Expr : Node_Id;
- Positional_Expr : Node_Id;
- Component : Entity_Id;
- Component_Elmt : Elmt_Id;
-
- 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.
-
New_Assoc_List : constant List_Id := New_List;
- New_Assoc : Node_Id;
-- New_Assoc_List is the newly built list of N_Component_Association
- -- nodes. New_Assoc is one such N_Component_Association node in it.
- -- Note that while Assoc and New_Assoc contain the same kind of nodes,
- -- they are used to iterate over two different N_Component_Association
- -- lists.
+ -- nodes.
Others_Etype : Entity_Id := Empty;
-- This variable is used to save the Etype of the last record component
--
-- This variable is updated as a side effect of function Get_Value.
+ Box_Node : Node_Id := Empty;
Is_Box_Present : Boolean := False;
- Others_Box : Boolean := False;
+ 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;
- -- Others_Box indicates that at least one component takes its default
- -- initialization. Similar to Others_Etype, they are also updated as a
- -- side effect of function Get_Value.
+ -- Others_Box counts the number of components of the current aggregate
+ -- (which may be a sub-aggregate of a larger one) that are default-
+ -- initialized. A value of One indicates that an others_box is present.
+ -- Any larger value indicates that the others_box is not redundant.
+ -- These variables, similar to Others_Etype, are also updated as a side
+ -- effect of function Get_Value. Box_Node is used to place a warning on
+ -- a redundant others_box.
procedure Add_Association
(Component : Entity_Id;
-- either New_Assoc_List, or the association being built for an inner
-- aggregate.
- function Discr_Present (Discr : Entity_Id) return Boolean;
+ procedure Add_Discriminant_Values
+ (New_Aggr : Node_Id;
+ Assoc_List : List_Id);
+ -- The constraint to a component may be given by a discriminant of the
+ -- enclosing type, in which case we have to retrieve its value, which is
+ -- part of the enclosing aggregate. Assoc_List provides the discriminant
+ -- associations of the current type or of some enclosing record.
+
+ function Discriminant_Present (Input_Discr : Entity_Id) return Boolean;
-- If aggregate N is a regular aggregate this routine will return True.
- -- Otherwise, if N is an extension aggregate, Discr is a discriminant
- -- whose value may already have been specified by N's ancestor part.
- -- This routine checks whether this is indeed the case and if so returns
- -- False, signaling that no value for Discr should appear in N's
- -- aggregate part. Also, in this case, the routine appends to
- -- New_Assoc_List the discriminant value specified in the ancestor part.
+ -- Otherwise, if N is an extension aggregate, then Input_Discr denotes
+ -- a discriminant whose value may already have been specified by N's
+ -- ancestor part. This routine checks whether this is indeed the case
+ -- and if so returns False, signaling that no value for Input_Discr
+ -- should appear in N's aggregate part. Also, in this case, the routine
+ -- appends to New_Assoc_List the discriminant value specified in the
+ -- ancestor part.
--
-- If the aggregate is in a context with expansion delayed, it will be
-- reanalyzed. The inherited discriminant values must not be reinserted
-- present on first analysis to build the proper subtype indications.
-- The flag Inherited_Discriminant is used to prevent the re-insertion.
+ function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id;
+ -- AI05-0115: Find earlier ancestor in the derivation chain that is
+ -- derived from private view Typ. Whether the aggregate is legal depends
+ -- on the current visibility of the type as well as that of the parent
+ -- of the ancestor.
+
function Get_Value
- (Compon : Node_Id;
+ (Compon : Entity_Id;
From : List_Id;
- Consider_Others_Choice : Boolean := False)
- return Node_Id;
+ Consider_Others_Choice : Boolean := False) return Node_Id;
-- Given a record component stored in parameter Compon, this function
-- returns its value as it appears in the list From, which is a list
-- of N_Component_Association nodes.
-- 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);
+ -- Nested components may themselves be discriminated types constrained
+ -- by outer discriminants, whose values must be captured before the
+ -- aggregate is expanded into assignments.
- procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id);
+ procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id);
-- Analyzes and resolves expression Expr against the Etype of the
-- Component. This routine also applies all appropriate checks to Expr.
-- It finally saves a Expr in the newly created association list that
-- 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 --
---------------------
Assoc_List : List_Id;
Is_Box_Present : Boolean := False)
is
- Loc : Source_Ptr;
Choice_List : constant List_Id := New_List;
- New_Assoc : Node_Id;
+ Loc : Source_Ptr;
begin
- -- If this is a box association the expression is missing, so
- -- use the Sloc of the aggregate itself for the new association.
+ -- 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);
Loc := Sloc (N);
end if;
- Append (New_Occurrence_Of (Component, Loc), Choice_List);
- New_Assoc :=
+ Append_To (Choice_List, New_Occurrence_Of (Component, Loc));
+
+ Append_To (Assoc_List,
Make_Component_Association (Loc,
Choices => Choice_List,
Expression => Expr,
- Box_Present => Is_Box_Present);
- Append (New_Assoc, Assoc_List);
+ Box_Present => Is_Box_Present));
end Add_Association;
- -------------------
- -- Discr_Present --
- -------------------
+ -----------------------------
+ -- Add_Discriminant_Values --
+ -----------------------------
+
+ procedure Add_Discriminant_Values
+ (New_Aggr : Node_Id;
+ Assoc_List : List_Id)
+ is
+ Assoc : Node_Id;
+ Discr : Entity_Id;
+ Discr_Elmt : Elmt_Id;
+ Discr_Val : Node_Id;
+ Val : Entity_Id;
+
+ begin
+ Discr := First_Discriminant (Etype (New_Aggr));
+ Discr_Elmt := First_Elmt (Discriminant_Constraint (Etype (New_Aggr)));
+ while Present (Discr_Elmt) loop
+ Discr_Val := Node (Discr_Elmt);
+
+ -- If the constraint is given by a discriminant then it is a
+ -- discriminant of an enclosing record, and its value has already
+ -- been placed in the association list.
+
+ if Is_Entity_Name (Discr_Val)
+ and then Ekind (Entity (Discr_Val)) = E_Discriminant
+ then
+ Val := Entity (Discr_Val);
+
+ Assoc := First (Assoc_List);
+ while Present (Assoc) loop
+ if Present (Entity (First (Choices (Assoc))))
+ and then Entity (First (Choices (Assoc))) = Val
+ then
+ Discr_Val := Expression (Assoc);
+ exit;
+ end if;
- function Discr_Present (Discr : Entity_Id) return Boolean is
+ Next (Assoc);
+ end loop;
+ end if;
+
+ Add_Association
+ (Discr, New_Copy_Tree (Discr_Val),
+ Component_Associations (New_Aggr));
+
+ -- If the discriminant constraint is a current instance, mark the
+ -- current aggregate so that the self-reference can be expanded
+ -- later. The constraint may refer to the subtype of aggregate, so
+ -- use base type for comparison.
+
+ if Nkind (Discr_Val) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (Discr_Val))
+ and then Is_Type (Entity (Prefix (Discr_Val)))
+ and then Base_Type (Etype (N)) = Entity (Prefix (Discr_Val))
+ then
+ Set_Has_Self_Reference (N);
+ end if;
+
+ Next_Elmt (Discr_Elmt);
+ Next_Discriminant (Discr);
+ end loop;
+ end Add_Discriminant_Values;
+
+ --------------------------
+ -- Discriminant_Present --
+ --------------------------
+
+ function Discriminant_Present (Input_Discr : Entity_Id) return Boolean is
Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate;
+ Ancestor_Is_Subtyp : Boolean;
+
Loc : Source_Ptr;
Ancestor : Node_Id;
+ Ancestor_Typ : Entity_Id;
Comp_Assoc : Node_Id;
+ Discr : Entity_Id;
Discr_Expr : Node_Id;
-
- Ancestor_Typ : Entity_Id;
+ Discr_Val : Elmt_Id := No_Elmt;
Orig_Discr : Entity_Id;
- D : Entity_Id;
- D_Val : Elmt_Id := No_Elmt; -- stop junk warning
-
- Ancestor_Is_Subtyp : Boolean;
begin
if Regular_Aggr then
-- Now look to see if Discr was specified in the ancestor part
if Ancestor_Is_Subtyp then
- D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
+ Discr_Val :=
+ First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
end if;
- Orig_Discr := Original_Record_Component (Discr);
+ Orig_Discr := Original_Record_Component (Input_Discr);
- D := First_Discriminant (Ancestor_Typ);
- while Present (D) loop
+ Discr := First_Discriminant (Ancestor_Typ);
+ while Present (Discr) loop
-- If Ancestor has already specified Disc value then insert its
-- value in the final aggregate.
- if Original_Record_Component (D) = Orig_Discr then
+ if Original_Record_Component (Discr) = Orig_Discr then
if Ancestor_Is_Subtyp then
- Discr_Expr := New_Copy_Tree (Node (D_Val));
+ Discr_Expr := New_Copy_Tree (Node (Discr_Val));
else
Discr_Expr :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Ancestor),
- Selector_Name => New_Occurrence_Of (Discr, Loc));
+ Selector_Name => New_Occurrence_Of (Input_Discr, Loc));
end if;
- Resolve_Aggr_Expr (Discr_Expr, Discr);
+ Resolve_Aggr_Expr (Discr_Expr, Input_Discr);
Set_Inherited_Discriminant (Last (New_Assoc_List));
return False;
end if;
- Next_Discriminant (D);
+ Next_Discriminant (Discr);
if Ancestor_Is_Subtyp then
- Next_Elmt (D_Val);
+ Next_Elmt (Discr_Val);
end if;
end loop;
return True;
- end Discr_Present;
+ end Discriminant_Present;
+
+ ---------------------------
+ -- Find_Private_Ancestor --
+ ---------------------------
+
+ function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id is
+ Par : Entity_Id;
+
+ begin
+ Par := Typ;
+ loop
+ if Has_Private_Ancestor (Par)
+ and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
+ then
+ return Par;
+
+ elsif not Is_Derived_Type (Par) then
+ return Empty;
+
+ else
+ Par := Etype (Base_Type (Par));
+ end if;
+ end loop;
+ end Find_Private_Ancestor;
---------------
-- Get_Value --
---------------
function Get_Value
- (Compon : Node_Id;
+ (Compon : Entity_Id;
From : List_Id;
- Consider_Others_Choice : Boolean := False)
- return Node_Id
+ Consider_Others_Choice : Boolean := False) return Node_Id
is
Typ : constant Entity_Id := Etype (Compon);
Assoc : Node_Id;
-- 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
-- checks when the default includes function calls.
if Box_Present (Assoc) then
- Others_Box := True;
+ Others_Box := Others_Box + 1;
Is_Box_Present := True;
if Expander_Active then
null;
else
Error_Msg_N
- ("components in OTHERS choice must "
- & "have same type", Selector_Name);
+ ("components in OTHERS choice must have same "
+ & "type", Selector_Name);
end if;
end if;
Others_Etype := Typ;
- -- Copy expression so that it is resolved
+ -- Copy the expression so that it is resolved
-- independently for each component, This is needed
-- for accessibility checks on compoents 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;
return Expr;
end Get_Value;
- ---------------------------------------
- -- New_Copy_Tree_And_Copy_Dimensions --
- ---------------------------------------
+ -----------------------------
+ -- Propagate_Discriminants --
+ -----------------------------
- 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
+ procedure Propagate_Discriminants
+ (Aggr : Node_Id;
+ Assoc_List : List_Id)
is
- New_Copy : constant Node_Id :=
- New_Copy_Tree (Source, Map, New_Sloc, New_Scope);
+ Loc : constant Source_Ptr := Sloc (N);
+
+ procedure Process_Component (Comp : Entity_Id);
+ -- Add one component with a box association to the inner aggregate,
+ -- and recurse if component is itself composite.
+
+ -----------------------
+ -- Process_Component --
+ -----------------------
+
+ procedure Process_Component (Comp : Entity_Id) is
+ T : constant Entity_Id := Etype (Comp);
+ New_Aggr : Node_Id;
+
+ begin
+ if Is_Record_Type (T) and then Has_Discriminants (T) then
+ New_Aggr := Make_Aggregate (Loc, No_List, New_List);
+ Set_Etype (New_Aggr, T);
+
+ Add_Association
+ (Comp, New_Aggr, Component_Associations (Aggr));
+
+ -- Collect discriminant values and recurse
+
+ Add_Discriminant_Values (New_Aggr, Assoc_List);
+ Propagate_Discriminants (New_Aggr, Assoc_List);
+
+ Build_Constrained_Itype
+ (New_Aggr, T, Component_Associations (New_Aggr));
+ else
+ Add_Association
+ (Comp, Empty, Component_Associations (Aggr),
+ Is_Box_Present => True);
+ end if;
+ end Process_Component;
+
+ -- Local variables
+
+ Aggr_Type : constant Entity_Id := Base_Type (Etype (Aggr));
+ Components : constant Elist_Id := New_Elmt_List;
+ Def_Node : constant Node_Id :=
+ Type_Definition (Declaration_Node (Aggr_Type));
+
+ Comp : Node_Id;
+ Comp_Elmt : Elmt_Id;
+ Errors : Boolean;
+
+ -- Start of processing for Propagate_Discriminants
begin
- -- Move the dimensions of Source to New_Copy
+ -- The component type may be a variant type. Collect the components
+ -- that are ruled by the known values of the discriminants. Their
+ -- values have already been inserted into the component list of the
+ -- current aggregate.
+
+ if Nkind (Def_Node) = N_Record_Definition
+ and then Present (Component_List (Def_Node))
+ and then Present (Variant_Part (Component_List (Def_Node)))
+ then
+ Gather_Components (Aggr_Type,
+ Component_List (Def_Node),
+ Governed_By => Component_Associations (Aggr),
+ Into => Components,
+ Report_Errors => Errors);
+
+ Comp_Elmt := First_Elmt (Components);
+ while Present (Comp_Elmt) loop
+ if Ekind (Node (Comp_Elmt)) /= E_Discriminant then
+ Process_Component (Node (Comp_Elmt));
+ end if;
+
+ Next_Elmt (Comp_Elmt);
+ end loop;
+
+ -- No variant part, iterate over all components
- Copy_Dimensions (Source, New_Copy);
- return New_Copy;
- end New_Copy_Tree_And_Copy_Dimensions;
+ else
+ Comp := First_Component (Etype (Aggr));
+ while Present (Comp) loop
+ Process_Component (Comp);
+ Next_Component (Comp);
+ end loop;
+ end if;
+ end Propagate_Discriminants;
-----------------------
-- Resolve_Aggr_Expr --
-----------------------
- procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is
- Expr_Type : Entity_Id := Empty;
- New_C : Entity_Id := Component;
- New_Expr : Node_Id;
-
+ procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id) is
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean;
-- If the expression is an aggregate (possibly qualified) then its
-- 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.
+ ---------------------------
+ -- Has_Expansion_Delayed --
+ ---------------------------
+
+ function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
+ begin
+ return
+ (Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate)
+ and then Present (Etype (Expr))
+ and then Is_Record_Type (Etype (Expr))
+ and then Expansion_Delayed (Expr))
+ or else
+ (Nkind (Expr) = N_Qualified_Expression
+ and then Has_Expansion_Delayed (Expression (Expr)));
+ end Has_Expansion_Delayed;
+
+ -- Local variables
+
+ Expr_Type : Entity_Id := Empty;
+ New_C : Entity_Id := Component;
+ New_Expr : Node_Id;
+
Relocate : Boolean;
-- Set to True if the resolved Expr node needs to be relocated when
-- attached to the newly created association list. This node need not
-- aggregate and hence it needs to be relocated when moved over to
-- the new association list.
- ---------------------------
- -- Has_Expansion_Delayed --
- ---------------------------
-
- function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
- Kind : constant Node_Kind := Nkind (Expr);
- begin
- return (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)
- and then Present (Etype (Expr))
- and then Is_Record_Type (Etype (Expr))
- and then Expansion_Delayed (Expr))
- or else (Kind = N_Qualified_Expression
- and then Has_Expansion_Delayed (Expression (Expr)));
- end Has_Expansion_Delayed;
-
-- Start of processing for Resolve_Aggr_Expr
begin
-- because the aggegate might not be expanded into individual
-- component assignments.
- if Present (Predicate_Function (Expr_Type)) then
+ if Has_Predicates (Expr_Type)
+ and then Analyzed (Expr)
+ then
Apply_Predicate_Check (Expr, Expr_Type);
end if;
Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed);
end if;
+ -- Add association Component => Expr if the caller requests it
+
if Relocate then
New_Expr := Relocate_Node (Expr);
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.
+
+ Component : Entity_Id;
+ Component_Elmt : Elmt_Id;
+ Expr : Node_Id;
+ Positional_Expr : Node_Id;
+
-- Start of processing for Resolve_Record_Aggregate
begin
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;
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 (First (Choices (Assoc))) = N_Others_Choice then
- Check_SPARK_05_Restriction
- ("record aggregate cannot contain OTHERS", Assoc);
+ 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;
end if;
- Assoc := Next (Assoc);
+ Next (Assoc);
end loop;
end;
end if;
-- STEP 2: Verify aggregate structure
Step_2 : declare
- Selector_Name : Node_Id;
+ Assoc : Node_Id;
Bad_Aggregate : Boolean := False;
+ Selector_Name : Node_Id;
begin
if Present (Component_Associations (N)) then
-- any component.
elsif Box_Present (Assoc) then
- Others_Box := True;
+ Others_Box := 1;
+ Box_Node := Assoc;
end if;
else
-- 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))
-- First find the discriminant values in the positional components
while Present (Discrim) and then Present (Positional_Expr) loop
- if Discr_Present (Discrim) then
+ if Discriminant_Present (Discrim) then
Resolve_Aggr_Expr (Positional_Expr, Discrim);
-- Ada 2005 (AI-231)
while Present (Discrim) loop
Expr := Get_Value (Discrim, Component_Associations (N), True);
- if not Discr_Present (Discrim) then
+ if not Discriminant_Present (Discrim) then
if Present (Expr) then
Error_Msg_NE
("more than one value supplied for discriminant &",
-- 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
- Loc : constant Source_Ptr := Sloc (N);
- Indic : Node_Id;
- Subtyp_Decl : Node_Id;
- Def_Id : Entity_Id;
-
- C : constant List_Id := New_List;
-
- begin
- New_Assoc := First (New_Assoc_List);
- while Present (New_Assoc) loop
- Append (Duplicate_Subexpr (Expression (New_Assoc)), To => C);
- 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, C));
- else
- Indic :=
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Base_Type (Typ), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc, C));
- 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;
-- STEP 5: Get remaining components according to discriminant values
Step_5 : declare
+ Dnode : Node_Id;
+ Errors_Found : Boolean := False;
Record_Def : Node_Id;
Parent_Typ : Entity_Id;
- Root_Typ : Entity_Id;
Parent_Typ_List : Elist_Id;
Parent_Elmt : Elmt_Id;
- Errors_Found : Boolean := False;
- Dnode : Node_Id;
-
- function Find_Private_Ancestor return Entity_Id;
- -- AI05-0115: Find earlier ancestor in the derivation chain that is
- -- derived from a private view. Whether the aggregate is legal
- -- depends on the current visibility of the type as well as that
- -- of the parent of the ancestor.
-
- ---------------------------
- -- Find_Private_Ancestor --
- ---------------------------
-
- function Find_Private_Ancestor return Entity_Id is
- Par : Entity_Id;
-
- begin
- Par := Typ;
- loop
- if Has_Private_Ancestor (Par)
- and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
- then
- return Par;
-
- elsif not Is_Derived_Type (Par) then
- return Empty;
-
- else
- Par := Etype (Base_Type (Par));
- end if;
- end loop;
- end Find_Private_Ancestor;
-
- -- Start of processing for Step_5
+ Root_Typ : Entity_Id;
begin
if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
else
- -- AI05-0115: check legality of aggregate for type with
- -- aa private ancestor.
+ -- AI05-0115: check legality of aggregate for type with a
+ -- private ancestor.
Root_Typ := Root_Type (Typ);
if Has_Private_Ancestor (Typ) then
declare
Ancestor : constant Entity_Id :=
- Find_Private_Ancestor;
+ Find_Private_Ancestor (Typ);
Ancestor_Unit : constant Entity_Id :=
- Cunit_Entity (Get_Source_Unit (Ancestor));
+ Cunit_Entity
+ (Get_Source_Unit (Ancestor));
Parent_Unit : constant Entity_Id :=
- Cunit_Entity
- (Get_Source_Unit (Base_Type (Etype (Ancestor))));
+ Cunit_Entity (Get_Source_Unit
+ (Base_Type (Etype (Ancestor))));
begin
-- Check whether we are in a scope that has full view
-- over the private ancestor and its parent. This can
-- object of the aggregate.
if Present (Parent (Component))
- and then
- Nkind (Parent (Component)) = N_Component_Declaration
+ and then Nkind (Parent (Component)) = N_Component_Declaration
and then Present (Expression (Parent (Component)))
then
Expr :=
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,
elsif Present (Underlying_Type (Ctyp))
and then Is_Access_Type (Underlying_Type (Ctyp))
then
- if not Is_Private_Type (Ctyp) then
- Expr := Make_Null (Sloc (N));
- Set_Etype (Expr, Ctyp);
- Add_Association
- (Component => Component,
- Expr => Expr,
- Assoc_List => New_Assoc_List);
-
-- If the component's type is private with an access type as
-- its underlying type then we have to create an unchecked
-- conversion to satisfy type checking.
- else
+ if Is_Private_Type (Ctyp) then
declare
Qual_Null : constant Node_Id :=
Make_Qualified_Expression (Sloc (N),
Subtype_Mark =>
New_Occurrence_Of
(Underlying_Type (Ctyp), Sloc (N)),
- Expression => Make_Null (Sloc (N)));
+ Expression => Make_Null (Sloc (N)));
Convert_Null : constant Node_Id :=
Unchecked_Convert_To
Expr => Convert_Null,
Assoc_List => New_Assoc_List);
end;
+
+ -- Otherwise the component type is non-private
+
+ else
+ Expr := Make_Null (Sloc (N));
+ Set_Etype (Expr, Ctyp);
+
+ Add_Association
+ (Component => Component,
+ Expr => Expr,
+ Assoc_List => New_Assoc_List);
end if;
-- Ada 2012: If component is scalar with default value, use it
then
Add_Association
(Component => Component,
- Expr => Default_Aspect_Value
- (First_Subtype (Underlying_Type (Ctyp))),
+ Expr =>
+ Default_Aspect_Value
+ (First_Subtype (Underlying_Type (Ctyp))),
Assoc_List => New_Assoc_List);
elsif Has_Non_Null_Base_Init_Proc (Ctyp)
-- for the rest, if other components are present.
-- The type of the aggregate is the known subtype of
- -- the component. The capture of discriminants must
- -- be recursive because subcomponents may be constrained
+ -- the component. The capture of discriminants must be
+ -- recursive because subcomponents may be constrained
-- (transitively) by discriminants of enclosing types.
-- For a private type with discriminants, a call to the
-- initialization procedure will be generated, and no
Loc : constant Source_Ptr := Sloc (N);
Expr : Node_Id;
- procedure Add_Discriminant_Values
- (New_Aggr : Node_Id;
- Assoc_List : List_Id);
- -- The constraint to a component may be given by a
- -- discriminant of the enclosing type, in which case
- -- we have to retrieve its value, which is part of the
- -- enclosing aggregate. Assoc_List provides the
- -- discriminant associations of the current type or
- -- of some enclosing record.
-
- procedure Propagate_Discriminants
- (Aggr : Node_Id;
- Assoc_List : List_Id);
- -- Nested components may themselves be discriminated
- -- types constrained by outer discriminants, whose
- -- values must be captured before the aggregate is
- -- expanded into assignments.
-
- -----------------------------
- -- Add_Discriminant_Values --
- -----------------------------
-
- procedure Add_Discriminant_Values
- (New_Aggr : Node_Id;
- Assoc_List : List_Id)
- is
- Assoc : Node_Id;
- Discr : Entity_Id;
- Discr_Elmt : Elmt_Id;
- Discr_Val : Node_Id;
- Val : Entity_Id;
-
- begin
- Discr := First_Discriminant (Etype (New_Aggr));
- Discr_Elmt :=
- First_Elmt
- (Discriminant_Constraint (Etype (New_Aggr)));
- while Present (Discr_Elmt) loop
- Discr_Val := Node (Discr_Elmt);
-
- -- If the constraint is given by a discriminant
- -- it is a discriminant of an enclosing record,
- -- and its value has already been placed in the
- -- association list.
-
- if Is_Entity_Name (Discr_Val)
- and then
- Ekind (Entity (Discr_Val)) = E_Discriminant
- then
- Val := Entity (Discr_Val);
-
- Assoc := First (Assoc_List);
- while Present (Assoc) loop
- if Present
- (Entity (First (Choices (Assoc))))
- and then
- Entity (First (Choices (Assoc))) = Val
- then
- Discr_Val := Expression (Assoc);
- exit;
- end if;
-
- Next (Assoc);
- end loop;
- end if;
-
- Add_Association
- (Discr, New_Copy_Tree (Discr_Val),
- Component_Associations (New_Aggr));
-
- -- If the discriminant constraint is a current
- -- instance, mark the current aggregate so that
- -- the self-reference can be expanded later.
- -- The constraint may refer to the subtype of
- -- aggregate, so use base type for comparison.
-
- if Nkind (Discr_Val) = N_Attribute_Reference
- and then Is_Entity_Name (Prefix (Discr_Val))
- and then Is_Type (Entity (Prefix (Discr_Val)))
- and then Base_Type (Etype (N)) =
- Entity (Prefix (Discr_Val))
- then
- Set_Has_Self_Reference (N);
- end if;
-
- Next_Elmt (Discr_Elmt);
- Next_Discriminant (Discr);
- end loop;
- end Add_Discriminant_Values;
-
- -----------------------------
- -- Propagate_Discriminants --
- -----------------------------
-
- procedure Propagate_Discriminants
- (Aggr : Node_Id;
- Assoc_List : List_Id)
- is
- Aggr_Type : constant Entity_Id :=
- Base_Type (Etype (Aggr));
- Def_Node : constant Node_Id :=
- Type_Definition
- (Declaration_Node (Aggr_Type));
-
- Comp : Node_Id;
- Comp_Elmt : Elmt_Id;
- Components : constant Elist_Id := New_Elmt_List;
- Needs_Box : Boolean := False;
- Errors : Boolean;
-
- procedure Process_Component (Comp : Entity_Id);
- -- Add one component with a box association to the
- -- inner aggregate, and recurse if component is
- -- itself composite.
-
- -----------------------
- -- Process_Component --
- -----------------------
-
- procedure Process_Component (Comp : Entity_Id) is
- T : constant Entity_Id := Etype (Comp);
- New_Aggr : Node_Id;
-
- begin
- if Is_Record_Type (T)
- and then Has_Discriminants (T)
- then
- New_Aggr :=
- Make_Aggregate (Loc, New_List, New_List);
- Set_Etype (New_Aggr, T);
- Add_Association
- (Comp, New_Aggr,
- Component_Associations (Aggr));
-
- -- Collect discriminant values and recurse
-
- Add_Discriminant_Values
- (New_Aggr, Assoc_List);
- Propagate_Discriminants
- (New_Aggr, Assoc_List);
-
- else
- Needs_Box := True;
- end if;
- end Process_Component;
-
- -- Start of processing for Propagate_Discriminants
-
- begin
- -- The component type may be a variant type, so
- -- collect the components that are ruled by the
- -- known values of the discriminants. Their values
- -- have already been inserted into the component
- -- list of the current aggregate.
-
- if Nkind (Def_Node) = N_Record_Definition
- and then Present (Component_List (Def_Node))
- and then
- Present
- (Variant_Part (Component_List (Def_Node)))
- then
- Gather_Components (Aggr_Type,
- Component_List (Def_Node),
- Governed_By => Component_Associations (Aggr),
- Into => Components,
- Report_Errors => Errors);
-
- Comp_Elmt := First_Elmt (Components);
- while Present (Comp_Elmt) loop
- if Ekind (Node (Comp_Elmt)) /= E_Discriminant
- then
- Process_Component (Node (Comp_Elmt));
- end if;
-
- Next_Elmt (Comp_Elmt);
- end loop;
-
- -- No variant part, iterate over all components
-
- else
- Comp := First_Component (Etype (Aggr));
- while Present (Comp) loop
- Process_Component (Comp);
- 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;
-
- -- Start of processing for Capture_Discriminants
-
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
elsif Has_Discriminants (Ctyp) then
Add_Discriminant_Values
- (Expr, Component_Associations (Expr));
+ (Expr, Component_Associations (Expr));
Propagate_Discriminants
- (Expr, Component_Associations (Expr));
+ (Expr, Component_Associations (Expr));
+
+ Build_Constrained_Itype
+ (Expr, Ctyp, Component_Associations (Expr));
else
declare
Expression => Empty,
Box_Present => True));
end if;
+
exit;
end if;
Assoc_List => New_Assoc_List);
end Capture_Discriminants;
+ -- Otherwise the component type is not a record, or it has
+ -- not discriminants, or it is private.
+
else
Add_Association
(Component => Component,
-- STEP 7: check for invalid components + check type in choice list
Step_7 : declare
+ Assoc : Node_Id;
+ New_Assoc : Node_Id;
+
Selectr : Node_Id;
-- Selector name
-- Ada 2005 (AI-287): others choice may have expression or box
- if No (Others_Etype) and then not Others_Box then
+ if No (Others_Etype) and then Others_Box = 0 then
Error_Msg_N
("OTHERS must represent at least one component", Selectr);
+
+ elsif Others_Box = 1 and then Warn_On_Redundant_Constructs then
+ Error_Msg_N ("others choice is redundant?", Box_Node);
+ Error_Msg_N
+ ("\previous choices cover all components?", Box_Node);
end if;
exit Verification;
if Nkind (N) /= N_Extension_Aggregate
or else
Scope (Original_Record_Component (C)) /=
- Etype (Ancestor_Part (N))
+ Etype (Ancestor_Part (N))
then
exit;
end if;
when E_Array_Type =>
Comp_Typ := Component_Type (Typ);
- when E_Component |
- E_Discriminant =>
+ when E_Component
+ | E_Discriminant
+ =>
Comp_Typ := Etype (Typ);
when others =>
projects / gcc.git / blobdiff