-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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 Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Expander; use Expander;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
+with Restrict; use Restrict;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Snames; use Snames;
with Stringt; use Stringt;
with Stand; use Stand;
+with Style; use Style;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-- expressions allowed for a limited component association (namely, an
-- aggregate, function call, or <> notation). Report error for violations.
+ 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.
+
------------------------------------------------------
-- Subprograms used for RECORD AGGREGATE Processing --
------------------------------------------------------
-- The algorithm of Resolve_Record_Aggregate proceeds as follows:
--
-- 1. Make sure that the record type against which the record aggregate
- -- has to be resolved is not abstract. Furthermore if the type is
- -- a null aggregate make sure the input aggregate N is also null.
+ -- has to be resolved is not abstract. Furthermore if the type is a
+ -- null aggregate make sure the input aggregate N is also null.
--
-- 2. Verify that the structure of the aggregate is that of a record
-- aggregate. Specifically, look for component associations and ensure
-- node. Also make sure that if present, the N_Others_Choice occurs
-- last and by itself.
--
- -- 3. If Typ contains discriminants, the values for each discriminant
- -- is looked for. If the record type Typ has variants, we check
- -- that the expressions corresponding to each discriminant ruling
- -- the (possibly nested) variant parts of Typ, are static. This
- -- allows us to determine the variant parts to which the rest of
- -- the aggregate must conform. The names of discriminants with their
- -- values are saved in a new association list, New_Assoc_List which
- -- is later augmented with the names and values of the remaining
- -- components in the record type.
+ -- 3. If Typ contains discriminants, the values for each discriminant is
+ -- looked for. If the record type Typ has variants, we check that the
+ -- expressions corresponding to each discriminant ruling the (possibly
+ -- nested) variant parts of Typ, are static. This allows us to determine
+ -- the variant parts to which the rest of the aggregate must conform.
+ -- The names of discriminants with their values are saved in a new
+ -- association list, New_Assoc_List which is later augmented with the
+ -- names and values of the remaining components in the record type.
--
-- During this phase we also make sure that every discriminant is
- -- assigned exactly one value. Note that when several values
- -- for a given discriminant are found, semantic processing continues
- -- looking for further errors. In this case it's the first
- -- discriminant value found which we will be recorded.
+ -- assigned exactly one value. Note that when several values for a given
+ -- discriminant are found, semantic processing continues looking for
+ -- further errors. In this case it's the first discriminant value found
+ -- which we will be recorded.
--
-- IMPORTANT NOTE: For derived tagged types this procedure expects
-- First_Discriminant and Next_Discriminant to give the correct list
-- of discriminants, in the correct order.
--
- -- 4. After all the discriminant values have been gathered, we can
- -- set the Etype of the record aggregate. If Typ contains no
- -- discriminants this is straightforward: the Etype of N is just
- -- Typ, otherwise a new implicit constrained subtype of Typ is
- -- built to be the Etype of N.
+ -- 4. After all the discriminant values have been gathered, we can set the
+ -- Etype of the record aggregate. If Typ contains no discriminants this
+ -- is straightforward: the Etype of N is just Typ, otherwise a new
+ -- implicit constrained subtype of Typ is built to be the Etype of N.
--
-- 5. Gather the remaining record components according to the discriminant
-- values. This involves recursively traversing the record type
-- derived tagged types since we need to retrieve the record structure
-- of all the ancestors of Typ.
--
- -- 6. After gathering the record components we look for their values
- -- in the record aggregate and emit appropriate error messages
- -- should we not find such values or should they be duplicated.
+ -- 6. After gathering the record components we look for their values in the
+ -- record aggregate and emit appropriate error messages should we not
+ -- find such values or should they be duplicated.
--
- -- 7. We then make sure no illegal component names appear in the
- -- record aggregate and make sure that the type of the record
- -- components appearing in a same choice list is the same.
- -- Finally we ensure that the others choice, if present, is
- -- used to provide the value of at least a record component.
+ -- 7. We then make sure no illegal component names appear in the record
+ -- aggregate and make sure that the type of the record components
+ -- appearing in a same choice list is the same. Finally we ensure that
+ -- the others choice, if present, is used to provide the value of at
+ -- least a record component.
--
- -- 8. The original aggregate node is replaced with the new named
- -- aggregate built in steps 3 through 6, as explained earlier.
+ -- 8. The original aggregate node is replaced with the new named aggregate
+ -- built in steps 3 through 6, as explained earlier.
--
- -- Given the complexity of record aggregate resolution, the primary
- -- goal of this routine is clarity and simplicity rather than execution
- -- and storage efficiency. If there are only positional components in the
- -- aggregate the running time is linear. If there are associations
- -- the running time is still linear as long as the order of the
- -- associations is not too far off the order of the components in the
- -- record type. If this is not the case the running time is at worst
- -- quadratic in the size of the association list.
+ -- Given the complexity of record aggregate resolution, the primary goal of
+ -- this routine is clarity and simplicity rather than execution and storage
+ -- efficiency. If there are only positional components in the aggregate the
+ -- running time is linear. If there are associations the running time is
+ -- still linear as long as the order of the associations is not too far off
+ -- the order of the components in the record type. If this is not the case
+ -- the running time is at worst quadratic in the size of the association
+ -- list.
procedure Check_Misspelled_Component
- (Elements : Elist_Id;
- Component : Node_Id);
- -- Give possible misspelling diagnostic if Component is likely to be
- -- a misspelling of one of the components of the Assoc_List.
- -- This is called by Resolve_Aggr_Expr after producing
- -- an invalid component error message.
+ (Elements : Elist_Id;
+ Component : Node_Id);
+ -- Give possible misspelling diagnostic if Component is likely to be a
+ -- 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.
+ -- 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 --
return;
end if;
+ -- Ada 2005 (AI-230): Generate a conversion to an anonymous access
+ -- component's type to force the appropriate accessibility checks.
+
+ -- Ada 2005 (AI-231): Generate conversion to the null-excluding
+ -- type to force the corresponding run-time check
+
+ if Is_Access_Type (Check_Typ)
+ and then ((Is_Local_Anonymous_Access (Check_Typ))
+ or else (Can_Never_Be_Null (Check_Typ)
+ and then not Can_Never_Be_Null (Exp_Typ)))
+ then
+ Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
+ Analyze_And_Resolve (Exp, Check_Typ);
+ Check_Unset_Reference (Exp);
+ end if;
+
-- This is really expansion activity, so make sure that expansion
-- is on and is allowed.
Check_Unset_Reference (Exp);
end if;
- -- Ada 2005 (AI-230): Generate a conversion to an anonymous access
- -- component's type to force the appropriate accessibility checks.
-
- -- Ada 2005 (AI-231): Generate conversion to the null-excluding
- -- type to force the corresponding run-time check
-
- elsif Is_Access_Type (Check_Typ)
- and then ((Is_Local_Anonymous_Access (Check_Typ))
- or else (Can_Never_Be_Null (Check_Typ)
- and then not Can_Never_Be_Null (Exp_Typ)))
- then
- Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
- Analyze_And_Resolve (Exp, Check_Typ);
- Check_Unset_Reference (Exp);
end if;
end Aggregate_Constraint_Checks;
------------------------
function Array_Aggr_Subtype
- (N : Node_Id;
- Typ : Entity_Id)
- return Entity_Id
+ (N : Node_Id;
+ Typ : Entity_Id) return Entity_Id
is
Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
-- Number of aggregate index dimensions
Is_Fully_Positional : Boolean := True;
procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos);
- -- N is an array (sub-)aggregate. Dim is the dimension corresponding to
- -- (sub-)aggregate N. This procedure collects the constrained N_Range
- -- nodes corresponding to each index dimension of our aggregate itype.
- -- These N_Range nodes are collected in Aggr_Range above.
+ -- N is an array (sub-)aggregate. Dim is the dimension corresponding
+ -- to (sub-)aggregate N. This procedure collects and removes the side
+ -- effects of the constrained N_Range nodes corresponding to each index
+ -- dimension of our aggregate itype. These N_Range nodes are collected
+ -- in Aggr_Range above.
--
-- Likewise collect in Aggr_Low & Aggr_High above the low and high
-- bounds of each index dimension. If, when collecting, two bounds
Expr : Node_Id;
begin
+ Remove_Side_Effects (This_Low, Variable_Ref => True);
+ Remove_Side_Effects (This_High, Variable_Ref => True);
+
-- Collect the first N_Range for a given dimension that you find.
-- For a given dimension they must be all equal anyway.
Set_Raises_Constraint_Error (N);
Error_Msg_N ("sub-aggregate low bound mismatch?", N);
Error_Msg_N
- ("\Constraint_Error will be raised at run-time?", N);
+ ("\Constraint_Error will be raised at run time?", N);
end if;
end if;
Set_Raises_Constraint_Error (N);
Error_Msg_N ("sub-aggregate high bound mismatch?", N);
Error_Msg_N
- ("\Constraint_Error will be raised at run-time?", N);
+ ("\Constraint_Error will be raised at run time?", N);
end if;
end if;
end if;
-- Array_Aggr_Subtype variables
Itype : Entity_Id;
- -- the final itype of the overall aggregate
+ -- The final itype of the overall aggregate
Index_Constraints : constant List_Id := New_List;
-- The list of index constraints of the aggregate itype
-- Start of processing for Array_Aggr_Subtype
begin
- -- Make sure that the list of index constraints is properly attached
- -- to the tree, and then collect the aggregate bounds.
+ -- Make sure that the list of index constraints is properly attached to
+ -- the tree, and then collect the aggregate bounds.
Set_Parent (Index_Constraints, N);
Collect_Aggr_Bounds (N, 1);
- -- Build the list of constrained indices of our aggregate itype
+ -- Build the list of constrained indexes of our aggregate itype
for J in 1 .. Aggr_Dimension loop
Create_Index : declare
Itype := Create_Itype (E_Array_Subtype, N);
- Set_First_Rep_Item (Itype, First_Rep_Item (Typ));
- Set_Convention (Itype, Convention (Typ));
- Set_Depends_On_Private (Itype, Has_Private_Component (Typ));
- Set_Etype (Itype, Base_Type (Typ));
- Set_Has_Alignment_Clause (Itype, Has_Alignment_Clause (Typ));
- Set_Is_Aliased (Itype, Is_Aliased (Typ));
- Set_Depends_On_Private (Itype, Depends_On_Private (Typ));
+ Set_First_Rep_Item (Itype, First_Rep_Item (Typ));
+ Set_Convention (Itype, Convention (Typ));
+ Set_Depends_On_Private (Itype, Has_Private_Component (Typ));
+ Set_Etype (Itype, Base_Type (Typ));
+ Set_Has_Alignment_Clause (Itype, Has_Alignment_Clause (Typ));
+ Set_Is_Aliased (Itype, Is_Aliased (Typ));
+ Set_Depends_On_Private (Itype, Depends_On_Private (Typ));
Copy_Suppress_Status (Index_Check, Typ, Itype);
Copy_Suppress_Status (Length_Check, Typ, Itype);
Set_Is_Internal (Itype, True);
-- 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. Subse-
- -- quent checks in exp_aggr verify that type is not packed, etc.
+ -- components should be passed to gigi unexpanded whenever possible, and
+ -- regardless of the staticness of the bounds themselves. Subsequent
+ -- checks in exp_aggr verify that type is not packed, etc.
Set_Size_Known_At_Compile_Time (Itype,
Is_Fully_Positional
and then Comes_From_Source (N)
and then Size_Known_At_Compile_Time (Component_Type (Typ)));
- -- We always need a freeze node for a packed array subtype, so that
- -- we can build the Packed_Array_Type corresponding to the subtype.
- -- If expansion is disabled, the packed array subtype is not built,
- -- and we must not generate a freeze node for the type, or else it
- -- will appear incomplete to gigi.
+ -- We always need a freeze node for a packed array subtype, so that we
+ -- can build the Packed_Array_Type corresponding to the subtype. If
+ -- expansion is disabled, the packed array subtype is not built, and we
+ -- must not generate a freeze node for the type, or else it will appear
+ -- incomplete to gigi.
- if Is_Packed (Itype) and then not In_Spec_Expression
+ if Is_Packed (Itype)
+ and then not In_Spec_Expression
and then Expander_Active
then
Freeze_Itype (Itype, N);
--------------------------------
procedure Check_Misspelled_Component
- (Elements : Elist_Id;
- Component : Node_Id)
+ (Elements : Elist_Id;
+ Component : Node_Id)
is
Max_Suggestions : constant := 2;
Component_Elmt : Elmt_Id;
begin
- -- All the components of List are matched against Component and
- -- a count 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.
+ -- All the components of List are matched against Component and a count
+ -- is maintained of possible misspellings. When at the end of the the
+ -- analysis there are one or two (not more!) possible misspellings,
+ -- these misspellings will be suggested as possible correction.
Component_Elmt := First_Elmt (Elements);
while Nr_Of_Suggestions <= Max_Suggestions
-- Report at most two suggestions
if Nr_Of_Suggestions = 1 then
- Error_Msg_NE
+ Error_Msg_NE -- CODEFIX
("\possible misspelling of&", Component, Suggestion_1);
elsif Nr_Of_Suggestions = 2 then
Error_Msg_Node_2 := Suggestion_2;
- Error_Msg_NE
+ Error_Msg_NE -- CODEFIX
("\possible misspelling of& or&", Component, Suggestion_1);
end if;
end Check_Misspelled_Component;
and then Comes_From_Source (Expr)
and then not In_Instance_Body
then
- if not OK_For_Limited_Init (Expr) then
+ if not OK_For_Limited_Init (Etype (Expr), Expr) then
Error_Msg_N ("initialization not allowed for limited types", Expr);
Explain_Limited_Type (Etype (Expr), Expr);
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_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 --
----------------------------------------
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
+ begin
+ return No (Expressions (Aggr))
+ and then
+ Nkind (First (Choices (First (Component_Associations (Aggr)))))
+ = N_Others_Choice;
+ end Is_Others_Aggregate;
+
+ ----------------------------
+ -- Is_Top_Level_Aggregate --
+ ----------------------------
+
+ 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;
+
--------------------------------
-- Make_String_Into_Aggregate --
--------------------------------
Append_To (Exprs, C_Node);
P := P + 1;
- -- something special for wide strings ???
+ -- Something special for wide strings???
end loop;
New_N := Make_Aggregate (Loc, Expressions => Exprs);
-----------------------
procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Pkind : constant Node_Kind := Nkind (Parent (N));
+ 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
-- which is the subtype of the context in which the aggregate was found.
begin
+ -- Ignore junk empty aggregate resulting from parser error
+
+ if No (Expressions (N))
+ and then No (Component_Associations (N))
+ and then not Null_Record_Present (N)
+ then
+ return;
+ end if;
+
+ -- 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
+ -- initialization calls is properly an expansion activity but it must
+ -- be done during revolution.
+
+ if Expander_Active
+ and then Present (Component_Associations (N))
+ then
+ declare
+ Comp : Node_Id;
+
+ begin
+ Comp := First (Component_Associations (N));
+ while Present (Comp) loop
+ if Box_Present (Comp) then
+ Insert_Actions (N, Freeze_Entity (Typ, N));
+ exit;
+ end if;
+
+ 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_Restriction
+ ("array aggregate should have only OTHERS", N);
+ end if;
+
+ elsif Is_Top_Level_Aggregate (N) then
+ Check_SPARK_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). We also allow aggregates of types we know to be small.
+ -- 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).
+ -- We also allow aggregates of types we know to be small.
if not Support_Aggregates_On_Target
and then Comes_From_Source (N)
-- Ada 2005 (AI-287): Limited aggregates allowed
- if Is_Limited_Type (Typ) and then Ada_Version < Ada_05 then
+ -- In an instance, ignore aggregate subcomponents tnat may be limited,
+ -- because they originate in view conflicts. If the original aggregate
+ -- is legal and the actuals are legal, the aggregate itself is legal.
+
+ if Is_Limited_Type (Typ)
+ and then Ada_Version < Ada_2005
+ and then not In_Instance
+ then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
-- 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 Number_Dimensions (Typ) = 1
and then Is_Standard_Character_Type (Component_Type (Typ))
Next (Expr);
end loop;
- Rewrite (N,
- Make_String_Literal (Sloc (N), End_String));
+ Rewrite (N, Make_String_Literal (Loc, End_String));
Analyze_And_Resolve (N, Typ);
return;
Aggr_Resolved : Boolean;
Aggr_Typ : constant Entity_Id := Etype (Typ);
- -- This is the unconstrained array type, which is the type
- -- against which the aggregate is to be resolved. Typ itself
- -- is the array type of the context which may not be the same
- -- subtype as the subtype for the final aggregate.
+ -- This is the unconstrained array type, which is the type against
+ -- which the aggregate is to be resolved. Typ itself is the array
+ -- type of the context which may not be the same subtype as the
+ -- subtype for the final aggregate.
begin
- -- In the following we determine whether an others choice is
+ -- In the following we determine whether an OTHERS choice is
-- allowed inside the array aggregate. The test checks the context
-- in which the array aggregate occurs. If the context does not
- -- permit it, or the aggregate type is unconstrained, an others
- -- choice is not allowed.
+ -- 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).
-- 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.
+ -- 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.
-- Note that there is no node for Explicit_Actual_Parameter.
-- To test for this context we therefore have to test for node
-- formal parameter. Consequently we also need to test for
-- N_Procedure_Call_Statement or N_Function_Call.
- Set_Etype (N, Aggr_Typ); -- may be overridden later on
-
- if Is_Constrained (Typ) and then
- (Pkind = N_Assignment_Statement or else
- 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_Aggregate or else
- Pkind = N_Extension_Aggregate or else
- Pkind = N_Component_Association)
+ Set_Etype (N, Aggr_Typ); -- May be overridden later on
+
+ if Pkind = N_Assignment_Statement
+ 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_Aggregate or else
+ Pkind = N_Extension_Aggregate or else
+ Pkind = N_Component_Association))
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
end if;
if not Aggr_Resolved then
+
+ -- A parenthesized expression may have been intended as an
+ -- aggregate, leading to a type error when analyzing the
+ -- component. This can also happen for a nested component
+ -- (see Analyze_Aggr_Expr).
+
+ if Paren_Count (N) > 0 then
+ Error_Msg_N
+ ("positional aggregate cannot have one component", N);
+ end if;
+
Aggr_Subtyp := Any_Composite;
+
else
Aggr_Subtyp := Array_Aggr_Subtype (N, Typ);
end if;
elsif Is_Private_Type (Typ)
and then Present (Full_View (Typ))
- and then In_Inlined_Body
+ and then (In_Inlined_Body or In_Instance_Body)
and then Is_Composite_Type (Full_View (Typ))
then
Resolve (N, Full_View (Typ));
Error_Msg_N ("illegal context for aggregate", N);
end if;
- -- If we can determine statically that the evaluation of the
- -- aggregate raises Constraint_Error, then replace the
- -- aggregate with an N_Raise_Constraint_Error node, but set the
- -- Etype to the right aggregate subtype. Gigi needs this.
+ -- If we can determine statically that the evaluation of the aggregate
+ -- raises Constraint_Error, then replace the aggregate with an
+ -- N_Raise_Constraint_Error node, but set the Etype to the right
+ -- aggregate subtype. Gigi needs this.
if Raises_Constraint_Error (N) then
Aggr_Subtyp := Etype (N);
Rewrite (N,
- Make_Raise_Constraint_Error (Sloc (N),
- Reason => CE_Range_Check_Failed));
+ Make_Raise_Constraint_Error (Loc, Reason => CE_Range_Check_Failed));
Set_Raises_Constraint_Error (N);
Set_Etype (N, Aggr_Subtyp);
Set_Analyzed (N);
Index_Typ : constant Entity_Id := Etype (Index);
Index_Typ_Low : constant Node_Id := Type_Low_Bound (Index_Typ);
Index_Typ_High : constant Node_Id := Type_High_Bound (Index_Typ);
- -- The type of the index corresponding to the array sub-aggregate
- -- along with its low and upper bounds
+ -- The type of the index corresponding to the array sub-aggregate along
+ -- with its low and upper bounds.
Index_Base : constant Entity_Id := Base_Type (Index_Typ);
Index_Base_Low : constant Node_Id := Type_Low_Bound (Index_Base);
Index_Base_High : constant Node_Id := Type_High_Bound (Index_Base);
- -- ditto for the base type
+ -- Ditto for the base type
function Add (Val : Uint; To : Node_Id) return Node_Id;
-- Creates a new expression node where Val is added to expression To.
-- analyzed expression.
procedure Check_Bound (BH : Node_Id; AH : in out Node_Id);
- -- Checks that AH (the upper bound of an array aggregate) is <= BH
- -- (the upper bound of the index base type). If the check fails a
- -- warning is emitted, the Raises_Constraint_Error Flag of N is set,
- -- and AH is replaced with a duplicate of BH.
+ -- Checks that AH (the upper bound of an array aggregate) is less than
+ -- or equal to BH (the upper bound of the index base type). If the check
+ -- fails, a warning is emitted, the Raises_Constraint_Error flag of N is
+ -- set, and AH is replaced with a duplicate of BH.
procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id);
-- Checks that range AL .. AH is compatible with range L .. H. Emits a
- -- warning if not and sets the Raises_Constraint_Error Flag in N.
+ -- warning if not and sets the Raises_Constraint_Error flag in N.
procedure Check_Length (L, H : Node_Id; Len : Uint);
-- Checks that range L .. H contains at least Len elements. Emits a
- -- warning if not and sets the Raises_Constraint_Error Flag in N.
+ -- warning if not and sets the Raises_Constraint_Error flag in N.
function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean;
-- Returns True if range L .. H is dynamic or null
Single_Elmt : Boolean) return Boolean;
-- Resolves aggregate expression Expr. Returns False if resolution
-- fails. If Single_Elmt is set to False, the expression Expr may be
- -- used to initialize several array aggregate elements (this can
- -- happen for discrete choices such as "L .. H => Expr" or the others
- -- choice). In this event we do not resolve Expr unless expansion is
- -- disabled. To know why, see the DELAYED COMPONENT RESOLUTION
- -- note above.
+ -- used to initialize several array aggregate elements (this can happen
+ -- for discrete choices such as "L .. H => Expr" or the OTHERS choice).
+ -- In this event we do not resolve Expr unless expansion is disabled.
+ -- To know why, see the DELAYED COMPONENT RESOLUTION note above.
+ --
+ -- NOTE: In the case of "... => <>", we pass the in the
+ -- N_Component_Association node as Expr, since there is no Expression in
+ -- that case, and we need a Sloc for the error message.
---------
-- Add --
if not Is_Enumeration_Type (Index_Base) then
Expr :=
Make_Op_Add (Loc,
- Left_Opnd => Duplicate_Subexpr (To),
- Right_Opnd => Make_Integer_Literal (Loc, Val));
+ Left_Opnd => Duplicate_Subexpr (To),
+ Right_Opnd => Make_Integer_Literal (Loc, Val));
-- If we are dealing with enumeration return
-- Index_Typ'Val (Index_Typ'Pos (To) + Val)
Prefix => New_Reference_To (Index_Typ, Loc),
Attribute_Name => Name_Val,
Expressions => New_List (Expr_Pos));
+
+ -- If the index type has a non standard representation, the
+ -- attributes 'Val and 'Pos expand into function calls and the
+ -- resulting expression is considered non-safe for reevaluation
+ -- by the backend. Relocate it into a constant temporary in order
+ -- to make it safe for reevaluation.
+
+ if Has_Non_Standard_Rep (Etype (N)) then
+ declare
+ Def_Id : Entity_Id;
+
+ begin
+ Def_Id := Make_Temporary (Loc, 'R', Expr);
+ Set_Etype (Def_Id, Index_Typ);
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Object_Definition => New_Reference_To (Index_Typ, Loc),
+ Constant_Present => True,
+ Expression => Relocate_Node (Expr)));
+
+ Expr := New_Reference_To (Def_Id, Loc);
+ end;
+ end if;
end if;
return Expr;
if OK_BH and then OK_AH and then Val_BH < Val_AH then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("upper bound out of range?", AH);
- Error_Msg_N ("\Constraint_Error will be raised at run-time?", AH);
+ Error_Msg_N ("\Constraint_Error will be raised at run time?", AH);
-- You need to set AH to BH or else in the case of enumerations
- -- indices we will not be able to resolve the aggregate bounds.
+ -- indexes we will not be able to resolve the aggregate bounds.
AH := Duplicate_Subexpr (BH);
end if;
if OK_L and then Val_L > Val_AL then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("lower bound of aggregate out of range?", N);
- Error_Msg_N ("\Constraint_Error will be raised at run-time?", N);
+ Error_Msg_N ("\Constraint_Error will be raised at run time?", N);
end if;
if OK_H and then Val_H < Val_AH then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("upper bound of aggregate out of range?", N);
- Error_Msg_N ("\Constraint_Error will be raised at run-time?", N);
+ Error_Msg_N ("\Constraint_Error will be raised at run time?", N);
end if;
end Check_Bounds;
if Range_Len < Len then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("too many elements?", N);
- Error_Msg_N ("\Constraint_Error will be raised at run-time?", N);
+ Error_Msg_N ("\Constraint_Error will be raised at run time?", N);
end if;
end Check_Length;
-- Set to False if resolution of the expression failed
begin
+ -- Defend against previous errors
+
+ if Nkind (Expr) = N_Error
+ or else Error_Posted (Expr)
+ then
+ return True;
+ end if;
+
-- If the array type against which we are resolving the aggregate
-- has several dimensions, the expressions nested inside the
-- aggregate must be further aggregates (or strings).
else
Error_Msg_N ("nested array aggregate expected", Expr);
+
+ -- If the expression is parenthesized, this may be
+ -- a missing component association for a 1-aggregate.
+
+ if Paren_Count (Expr) > 0 then
+ Error_Msg_N
+ ("\if single-component aggregate is intended,"
+ & " write e.g. (1 ='> ...)", Expr);
+ end if;
+
return Failure;
end if;
end if;
+ -- If it's "... => <>", nothing to resolve
+
+ if Nkind (Expr) = N_Component_Association then
+ pragma Assert (Box_Present (Expr));
+ return Success;
+ end if;
+
-- Ada 2005 (AI-231): Propagate the type to the nested aggregate.
-- Required to check the null-exclusion attribute (if present).
-- This value may be overridden later on.
Resolution_OK := Resolve_Array_Aggregate
(Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed);
- -- Do not resolve the expressions of discrete or others choices
- -- unless the expression covers a single component, or the expander
- -- is inactive.
+ else
+
+ -- If it's "... => <>", nothing to resolve
- elsif Single_Elmt
- or else not Expander_Active
- or else In_Spec_Expression
- then
- Analyze_And_Resolve (Expr, Component_Typ);
- Check_Expr_OK_In_Limited_Aggregate (Expr);
- Check_Non_Static_Context (Expr);
- Aggregate_Constraint_Checks (Expr, Component_Typ);
- Check_Unset_Reference (Expr);
+ if Nkind (Expr) = N_Component_Association then
+ pragma Assert (Box_Present (Expr));
+ return Success;
+ end if;
+
+ -- Do not resolve the expressions of discrete or others choices
+ -- unless the expression covers a single component, or the
+ -- expander is inactive.
+
+ -- In Alfa 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 Single_Elmt
+ or else not Full_Expander_Active
+ or else In_Spec_Expression
+ then
+ Analyze_And_Resolve (Expr, Component_Typ);
+ Check_Expr_OK_In_Limited_Aggregate (Expr);
+ Check_Non_Static_Context (Expr);
+ Aggregate_Constraint_Checks (Expr, Component_Typ);
+ Check_Unset_Reference (Expr);
+ end if;
+ end if;
+
+ -- 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.
+
+ if Present (Predicate_Function (Component_Typ)) then
+ Apply_Predicate_Check (Expr, Component_Typ);
end if;
if Raises_Constraint_Error (Expr)
Set_Raises_Constraint_Error (N);
end if;
+ -- If the expression has been marked as requiring a range check,
+ -- then generate it here.
+
+ if Do_Range_Check (Expr) then
+ Set_Do_Range_Check (Expr, False);
+ Generate_Range_Check (Expr, Component_Typ, CE_Range_Check_Failed);
+ end if;
+
return Resolution_OK;
end Resolve_Aggr_Expr;
-- Start of processing for Resolve_Array_Aggregate
begin
+ -- Ignore junk empty aggregate resulting from parser error
+
+ if No (Expressions (N))
+ and then No (Component_Associations (N))
+ and then not Null_Record_Present (N)
+ then
+ return False;
+ end if;
+
-- STEP 1: make sure the aggregate is correctly formatted
if Present (Component_Associations (N)) then
return Failure;
end if;
+ if Others_Present
+ and then Nkind (Parent (N)) /= N_Component_Association
+ and then No (Expressions (N))
+ and then
+ Nkind (First (Choices (First (Component_Associations (N)))))
+ = N_Others_Choice
+ and then Is_Elementary_Type (Component_Typ)
+ and then False
+ then
+ declare
+ Assoc : constant Node_Id := First (Component_Associations (N));
+ begin
+ Rewrite (Assoc,
+ Make_Component_Association (Loc,
+ Choices =>
+ New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Index_Typ, Loc),
+ Attribute_Name => Name_Range)),
+ Expression => Relocate_Node (Expression (Assoc))));
+ return Resolve_Array_Aggregate
+ (N, Index, Index_Constr, Component_Typ, Others_Allowed);
+ end;
+ end if;
+
-- Protect against cascaded errors
if Etype (Index_Typ) = Any_Type then
-- discrete association
Prev_Nb_Discrete_Choices : Nat;
- -- Used to keep track of the number of discrete choices
- -- in the current association.
+ -- Used to keep track of the number of discrete choices in the
+ -- current association.
+
+ Errors_Posted_On_Choices : Boolean := False;
+ -- Keeps track of whether any choices have semantic errors
begin
-- STEP 2 (A): Check discrete choices validity
Check_Unset_Reference (Choice);
Check_Non_Static_Context (Choice);
+ -- If semantic errors were posted on the choice, then
+ -- record that for possible early return from later
+ -- processing (see handling of enumeration choices).
+
+ if Error_Posted (Choice) then
+ Errors_Posted_On_Choices := True;
+ end if;
+
-- Do not range check a choice. This check is redundant
- -- since this test is already performed when we check
- -- that the bounds of the array aggregate are within
- -- range.
+ -- since this test is already done when we check that the
+ -- bounds of the array aggregate are within range.
Set_Do_Range_Check (Choice, False);
+
+ -- In SPARK, the choice must be static
+
+ if not (Is_Static_Expression (Choice)
+ or else (Nkind (Choice) = N_Range
+ and then Is_Static_Range (Choice)))
+ then
+ Check_SPARK_Restriction
+ ("choice should be static", Choice);
+ end if;
end if;
-- If we could not resolve the discrete choice stop here
-- Ada 2005 (AI-231)
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Known_Null (Expression (Assoc))
then
Check_Can_Never_Be_Null (Etype (N), Expression (Assoc));
end if;
-- Ada 2005 (AI-287): In case of default initialized component
- -- we delay the resolution to the expansion phase
+ -- we delay the resolution to the expansion phase.
if Box_Present (Assoc) then
- -- Ada 2005 (AI-287): In case of default initialization
- -- of a component the expander will generate calls to
- -- the corresponding initialization subprogram.
+ -- Ada 2005 (AI-287): In case of default initialization of a
+ -- component the expander will generate calls to the
+ -- corresponding initialization subprogram. We need to call
+ -- Resolve_Aggr_Expr to check the rules about
+ -- dimensionality.
- null;
+ if not Resolve_Aggr_Expr (Assoc,
+ Single_Elmt => Single_Choice)
+ then
+ return Failure;
+ end if;
elsif not Resolve_Aggr_Expr (Expression (Assoc),
Single_Elmt => Single_Choice)
then
return Failure;
+
+ -- Check incorrect use of dynamically tagged expression
+
+ -- We differentiate here two cases because the expression may
+ -- not be decorated. For example, the analysis and resolution
+ -- of the expression associated with the others choice will be
+ -- done later with the full aggregate. In such case we
+ -- duplicate the expression tree to analyze the copy and
+ -- perform the required check.
+
+ elsif not Present (Etype (Expression (Assoc))) then
+ declare
+ Save_Analysis : constant Boolean := Full_Analysis;
+ Expr : constant Node_Id :=
+ New_Copy_Tree (Expression (Assoc));
+
+ begin
+ Expander_Mode_Save_And_Set (False);
+ Full_Analysis := False;
+
+ -- Analyze the expression, making sure it is properly
+ -- attached to the tree before we do the analysis.
+
+ Set_Parent (Expr, Parent (Expression (Assoc)));
+ Analyze (Expr);
+
+ -- If the expression is a literal, propagate this info
+ -- to the expression in the association, to enable some
+ -- optimizations downstream.
+
+ if Is_Entity_Name (Expr)
+ and then Present (Entity (Expr))
+ and then Ekind (Entity (Expr)) = E_Enumeration_Literal
+ then
+ Analyze_And_Resolve
+ (Expression (Assoc), Component_Typ);
+ end if;
+
+ Full_Analysis := Save_Analysis;
+ Expander_Mode_Restore;
+
+ if Is_Tagged_Type (Etype (Expr)) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => Expr,
+ Typ => Component_Type (Etype (N)),
+ Related_Nod => N);
+ end if;
+ end;
+
+ elsif Is_Tagged_Type (Etype (Expression (Assoc))) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => Expression (Assoc),
+ Typ => Component_Type (Etype (N)),
+ Related_Nod => N);
end if;
Next (Assoc);
end loop;
-- If aggregate contains more than one choice then these must be
- -- static. Sort them and check that they are contiguous
+ -- static. Sort them and check that they are contiguous.
if Nb_Discrete_Choices > 1 then
Sort_Case_Table (Table);
and then Compile_Time_Known_Value (Choices_Low)
and then Compile_Time_Known_Value (Choices_High)
then
+ -- If any of the expressions or range bounds in choices
+ -- have semantic errors, then do not attempt further
+ -- resolution, to prevent cascaded errors.
+
+ if Errors_Posted_On_Choices then
+ return Failure;
+ end if;
+
declare
ALo : constant Node_Id := Expr_Value_E (Aggr_Low);
AHi : constant Node_Id := Expr_Value_E (Aggr_High);
Ent : Entity_Id;
begin
- -- Warning case one, missing values at start/end. Only
+ -- Warning case 1, missing values at start/end. Only
-- do the check if the number of entries is too small.
if (Enumeration_Pos (CHi) - Enumeration_Pos (CLo))
-- Ada 2005 (AI-231)
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Known_Null (Expr)
then
Check_Can_Never_Be_Null (Etype (N), Expr);
return Failure;
end if;
+ -- Check incorrect use of dynamically tagged expression
+
+ if Is_Tagged_Type (Etype (Expr)) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => Expr,
+ Typ => Component_Type (Etype (N)),
+ Related_Nod => N);
+ end if;
+
Next (Expr);
end loop;
-- Ada 2005 (AI-231)
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Known_Null (Assoc)
then
Check_Can_Never_Be_Null (Etype (N), Expression (Assoc));
end if;
- -- Ada 2005 (AI-287): In case of default initialized component
+ -- Ada 2005 (AI-287): In case of default initialized component,
-- we delay the resolution to the expansion phase.
if Box_Present (Assoc) then
- -- Ada 2005 (AI-287): In case of default initialization
- -- of a component the expander will generate calls to
- -- the corresponding initialization subprogram.
+ -- Ada 2005 (AI-287): In case of default initialization of a
+ -- component the expander will generate calls to the
+ -- corresponding initialization subprogram. We need to call
+ -- Resolve_Aggr_Expr to check the rules about
+ -- dimensionality.
- null;
+ if not Resolve_Aggr_Expr (Assoc, Single_Elmt => False) then
+ return Failure;
+ end if;
elsif not Resolve_Aggr_Expr (Expression (Assoc),
Single_Elmt => False)
then
return Failure;
+
+ -- Check incorrect use of dynamically tagged expression. The
+ -- expression of the others choice has not been resolved yet.
+ -- In order to diagnose the semantic error we create a duplicate
+ -- tree to analyze it and perform the check.
+
+ else
+ declare
+ Save_Analysis : constant Boolean := Full_Analysis;
+ Expr : constant Node_Id :=
+ New_Copy_Tree (Expression (Assoc));
+
+ begin
+ Expander_Mode_Save_And_Set (False);
+ Full_Analysis := False;
+ Analyze (Expr);
+ Full_Analysis := Save_Analysis;
+ Expander_Mode_Restore;
+
+ if Is_Tagged_Type (Etype (Expr)) then
+ Check_Dynamically_Tagged_Expression
+ (Expr => Expr,
+ Typ => Component_Type (Etype (N)),
+ Related_Nod => N);
+ end if;
+ end;
end if;
end if;
-- Do not duplicate Aggr_High if Aggr_High = Aggr_Low + Nb_Elements
-- since the addition node returned by Add is not yet analyzed. Attach
- -- to tree and analyze first. Reset analyzed flag to insure it will get
+ -- to tree and analyze first. Reset analyzed flag to ensure it will get
-- analyzed when it is a literal bound whose type must be properly set.
if Others_Present or else Nb_Discrete_Choices > 0 then
end if;
end if;
+ -- If the aggregate already has bounds attached to it, it means this is
+ -- a positional aggregate created as an optimization by
+ -- Exp_Aggr.Convert_To_Positional, so we don't want to change those
+ -- bounds.
+
+ if Present (Aggregate_Bounds (N)) and then not Others_Allowed then
+ Aggr_Low := Low_Bound (Aggregate_Bounds (N));
+ Aggr_High := High_Bound (Aggregate_Bounds (N));
+ end if;
+
Set_Aggregate_Bounds
(N, Make_Range (Loc, Low_Bound => Aggr_Low, High_Bound => Aggr_High));
-- 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
+ -- 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.
+ -- 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.
+ -- 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);
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).
+ -- 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
then
return True;
- elsif
- Nkind (Anc) = N_Qualified_Expression
- then
+ elsif Nkind (Anc) = N_Qualified_Expression then
return Valid_Limited_Ancestor (Expression (Anc));
else
begin
Imm_Type := Base_Type (Typ);
- while Is_Derived_Type (Imm_Type)
- and then Etype (Imm_Type) /= Base_Type (A_Type)
- loop
- Imm_Type := Etype (Base_Type (Imm_Type));
+ while Is_Derived_Type (Imm_Type) loop
+ if Etype (Imm_Type) = Base_Type (A_Type) then
+ return True;
+
+ -- 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.
+
+ elsif Is_Private_Type (Etype (Imm_Type))
+ and then Present (Full_View (Etype (Imm_Type)))
+ and then Base_Type (A_Type) = Full_View (Etype (Imm_Type))
+ then
+ A_Type := Etype (Imm_Type);
+ return True;
+
+ -- The parent type may be a private extension. The aggregate is
+ -- legal if the type of the aggregate is an extension of it that
+ -- is not a private extension.
+
+ elsif Is_Private_Type (A_Type)
+ and then not Is_Private_Type (Imm_Type)
+ and then Present (Full_View (A_Type))
+ and then Base_Type (Full_View (A_Type)) = Etype (Imm_Type)
+ then
+ return True;
+
+ else
+ Imm_Type := Etype (Base_Type (Imm_Type));
+ end if;
end loop;
- if not Is_Derived_Type (Base_Type (Typ))
- or else Etype (Imm_Type) /= Base_Type (A_Type)
- then
- Error_Msg_NE ("expect ancestor type of &", A, Typ);
- return False;
- else
- return True;
- end if;
+ -- If previous loop did not find a proper ancestor, report error
+
+ Error_Msg_NE ("expect ancestor type of &", A, Typ);
+ return False;
end Valid_Ancestor_Type;
-- Start of processing for Resolve_Extension_Aggregate
begin
+ -- Analyze the ancestor part and account for the case where it is a
+ -- parameterless function call.
+
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_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
+ Error_Msg_NE
+ ("aggregate not available for type& whose ancestor "
+ & "has unknown discriminants", N, Typ);
+ end if;
+ end if;
if not Is_Tagged_Type (Typ) then
Error_Msg_N ("type of extension aggregate must be tagged", N);
-- Ada 2005 (AI-287): Limited aggregates are allowed
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
return;
Get_First_Interp (A, I, It);
while Present (It.Typ) loop
+ -- Only consider limited interpretations in the Ada 2005 case
+
if Is_Tagged_Type (It.Typ)
- and then not Is_Limited_Type (It.Typ)
+ and then (Ada_Version >= Ada_2005
+ or else not Is_Limited_Type (It.Typ))
then
if A_Type /= Any_Type then
Error_Msg_N ("cannot resolve expression", A);
end loop;
if A_Type = Any_Type then
- Error_Msg_N
- ("ancestor part must be non-limited tagged type", A);
+ if Ada_Version >= Ada_2005 then
+ Error_Msg_N ("ancestor part must be of a tagged type", A);
+ else
+ Error_Msg_N
+ ("ancestor part must be of a nonlimited tagged type", A);
+ end if;
+
return;
end if;
Check_Unset_Reference (A);
Check_Non_Static_Context (A);
- if Is_Class_Wide_Type (Etype (A))
+ -- The aggregate is illegal if the ancestor expression is a call
+ -- to a function with a limited unconstrained result, unless the
+ -- type of the aggregate is a null extension. This restriction
+ -- was added in AI05-67 to simplify implementation.
+
+ if Nkind (A) = N_Function_Call
+ and then Is_Limited_Type (A_Type)
+ and then not Is_Null_Extension (Typ)
+ and then not Is_Constrained (A_Type)
+ then
+ Error_Msg_N
+ ("type of limited ancestor part must be constrained", A);
+
+ -- Reject the use of CPP constructors that leave objects partially
+ -- initialized. For example:
+
+ -- type CPP_Root is tagged limited record ...
+ -- pragma Import (CPP, CPP_Root);
+
+ -- type CPP_DT is new CPP_Root and Iface ...
+ -- pragma Import (CPP, CPP_DT);
+
+ -- type Ada_DT is new CPP_DT with ...
+
+ -- Obj : Ada_DT := Ada_DT'(New_CPP_Root with others => <>);
+
+ -- Using the constructor of CPP_Root the slots of the dispatch
+ -- table of CPP_DT cannot be set, and the secondary tag of
+ -- CPP_DT is unknown.
+
+ elsif Nkind (A) = N_Function_Call
+ and then Is_CPP_Constructor_Call (A)
+ and then Enclosing_CPP_Parent (Typ) /= A_Type
+ then
+ Error_Msg_NE
+ ("?must use 'C'P'P constructor for type &", A,
+ Enclosing_CPP_Parent (Typ));
+
+ -- The following call is not needed if the previous warning
+ -- is promoted to an error.
+
+ Resolve_Record_Aggregate (N, Typ);
+
+ elsif Is_Class_Wide_Type (Etype (A))
and then Nkind (Original_Node (A)) = N_Function_Call
then
-- If the ancestor part is a dispatching call, it appears
- -- statically to be a legal ancestor, but it yields any
- -- member of the class, and it is not possible to determine
- -- whether it is an ancestor of the extension aggregate (much
- -- less which ancestor). It is not possible to determine the
- -- required components of the extension part.
+ -- statically to be a legal ancestor, but it yields any member
+ -- of the class, and it is not possible to determine whether
+ -- it is an ancestor of the extension aggregate (much less
+ -- which ancestor). It is not possible to determine the
+ -- components of the extension part.
- -- This check implements AI-306, which in fact was motivated
- -- by an ACT query to the ARG after this test was added.
+ -- This check implements AI-306, which in fact was motivated by
+ -- an AdaCore query to the ARG after this test was added.
Error_Msg_N ("ancestor part must be statically tagged", A);
else
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.
+ -- 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.
- -- Please 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.
+ -- 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.
Others_Etype : Entity_Id := Empty;
-- This variable is used to save the Etype of the last record component
-- (b) make sure the type of all the components whose value is
-- subsumed by the others choice are the same.
--
- -- This variable is updated as a side effect of function Get_Value
+ -- This variable is updated as a side effect of function Get_Value.
Is_Box_Present : Boolean := False;
Others_Box : Boolean := False;
procedure Add_Association
(Component : Entity_Id;
Expr : Node_Id;
+ Assoc_List : List_Id;
Is_Box_Present : Boolean := False);
- -- Builds a new N_Component_Association node which associates
- -- Component to expression Expr and adds it to the new association
- -- list New_Assoc_List being built.
+ -- Builds a new N_Component_Association node which associates Component
+ -- to expression Expr and adds it to the association list being built,
+ -- either New_Assoc_List, or the association being built for an inner
+ -- aggregate.
function Discr_Present (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 the
- -- N's aggregate part. Also, in this case, the routine appends to
- -- New_Assoc_List Discr the discriminant value specified in the ancestor
- -- part.
+ -- 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.
+ --
+ -- If the aggregate is in a context with expansion delayed, it will be
+ -- reanalyzed. The inherited discriminant values must not be reinserted
+ -- in the component list to prevent spurious errors, but they must be
+ -- present on first analysis to build the proper subtype indications.
+ -- The flag Inherited_Discriminant is used to prevent the re-insertion.
function Get_Value
(Compon : Node_Id;
From : List_Id;
Consider_Others_Choice : Boolean := False)
return Node_Id;
- -- Given a record component stored in parameter Compon, the
- -- following function returns its value as it appears in the list
- -- From, which is a list of N_Component_Association nodes. If no
- -- component association has a choice for the searched component,
- -- the value provided by the others choice is returned, if there
- -- is one and Consider_Others_Choice is set to true. Otherwise
- -- Empty is returned. If there is more than one component association
- -- giving a value for the searched record component, an error message
- -- is emitted and the first found value is returned.
+ -- 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.
+ --
+ -- If no component association has a choice for the searched component,
+ -- the value provided by the others choice is returned, if there is one,
+ -- and Consider_Others_Choice is set to true. Otherwise Empty is
+ -- returned. If there is more than one component association giving a
+ -- value for the searched record component, an error message is emitted
+ -- and the first found value is returned.
--
-- If Consider_Others_Choice is set and the returned expression comes
-- from the others choice, then Others_Etype is set as a side effect.
- -- An error message is emitted if the components taking their value
- -- from the others choice do not have same type.
+ -- An error message is emitted if the components taking their value from
+ -- the others choice do not have same type.
procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id);
-- Analyzes and resolves expression Expr against the Etype of the
procedure Add_Association
(Component : Entity_Id;
Expr : Node_Id;
+ Assoc_List : List_Id;
Is_Box_Present : Boolean := False)
is
+ Loc : Source_Ptr;
Choice_List : constant List_Id := New_List;
New_Assoc : Node_Id;
begin
- Append (New_Occurrence_Of (Component, Sloc (Expr)), Choice_List);
+ -- If this is a box association the expression is missing, so
+ -- use the Sloc of the aggregate itself for the new association.
+
+ if Present (Expr) then
+ Loc := Sloc (Expr);
+ else
+ Loc := Sloc (N);
+ end if;
+
+ Append (New_Occurrence_Of (Component, Loc), Choice_List);
New_Assoc :=
- Make_Component_Association (Sloc (Expr),
+ Make_Component_Association (Loc,
Choices => Choice_List,
Expression => Expr,
Box_Present => Is_Box_Present);
- Append (New_Assoc, New_Assoc_List);
+ Append (New_Assoc, Assoc_List);
end Add_Association;
-------------------
Loc : Source_Ptr;
Ancestor : Node_Id;
+ Comp_Assoc : Node_Id;
Discr_Expr : Node_Id;
Ancestor_Typ : Entity_Id;
return True;
end if;
+ -- Check whether inherited discriminant values have already been
+ -- inserted in the aggregate. This will be the case if we are
+ -- re-analyzing an aggregate whose expansion was delayed.
+
+ if Present (Component_Associations (N)) then
+ Comp_Assoc := First (Component_Associations (N));
+ while Present (Comp_Assoc) loop
+ if Inherited_Discriminant (Comp_Assoc) then
+ return True;
+ end if;
+
+ Next (Comp_Assoc);
+ end loop;
+ end if;
+
Ancestor := Ancestor_Part (N);
Ancestor_Typ := Etype (Ancestor);
Loc := Sloc (Ancestor);
+ -- For a private type with unknown discriminants, use the underlying
+ -- record view if it is available.
+
+ if Has_Unknown_Discriminants (Ancestor_Typ)
+ and then Present (Full_View (Ancestor_Typ))
+ and then Present (Underlying_Record_View (Full_View (Ancestor_Typ)))
+ then
+ Ancestor_Typ := Underlying_Record_View (Full_View (Ancestor_Typ));
+ end if;
+
Ancestor_Is_Subtyp :=
Is_Entity_Name (Ancestor) and then Is_Type (Entity (Ancestor));
D := First_Discriminant (Ancestor_Typ);
while Present (D) loop
- -- If Ancestor has already specified Disc value than insert its
+ -- If Ancestor has already specified Disc value then insert its
-- value in the final aggregate.
if Original_Record_Component (D) = Orig_Discr then
end if;
Resolve_Aggr_Expr (Discr_Expr, Discr);
+ Set_Inherited_Discriminant (Last (New_Assoc_List));
return False;
end if;
-- Ada 2005 (AI-231)
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Known_Null (Expression (Assoc))
then
Check_Can_Never_Be_Null (Compon, Expression (Assoc));
Expr := New_Copy_Tree (Expression (Parent (Compon)));
+ -- Component may have no default, in which case the
+ -- expression is empty and the component is default-
+ -- initialized, but an association for the component
+ -- exists, and it is not covered by an others clause.
+
+ return Expr;
+
else
if Present (Next (Selector_Name)) then
Expr := New_Copy_Tree (Expression (Assoc));
end if;
end if;
- Generate_Reference (Compon, Selector_Name);
+ Generate_Reference (Compon, Selector_Name, 'm');
else
Error_Msg_NE
-- dynamic-sized aggregate in the code, something that gigi cannot
-- handle.
- 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 be relocated if its parent pointer is not set.
- -- In fact in this case Expr is the output of a New_Copy_Tree call.
- -- if Relocate is True then we have analyzed the expression node
- -- in the original aggregate and hence it needs to be relocated
- -- when moved over the new association list.
+ 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
+ -- be relocated if its parent pointer is not set. In fact in this
+ -- case Expr is the output of a New_Copy_Tree call. If Relocate is
+ -- True then we have analyzed the expression node in the original
+ -- 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);
and then Has_Expansion_Delayed (Expression (Expr)));
end Has_Expansion_Delayed;
- -- Start of processing for Resolve_Aggr_Expr
+ -- Start of processing for Resolve_Aggr_Expr
begin
-- If the type of the component is elementary or the type of the
Check_Non_Static_Context (Expr);
Check_Unset_Reference (Expr);
+ -- Check wrong use of class-wide types
+
+ if Is_Class_Wide_Type (Etype (Expr)) then
+ Error_Msg_N ("dynamically tagged expression not allowed", Expr);
+ end if;
+
if not Has_Expansion_Delayed (Expr) then
Aggregate_Constraint_Checks (Expr, Expr_Type);
end if;
+ -- 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.
+
+ if Present (Predicate_Function (Expr_Type)) then
+ Apply_Predicate_Check (Expr, Expr_Type);
+ end if;
+
if Raises_Constraint_Error (Expr) then
Set_Raises_Constraint_Error (N);
end if;
+ -- If the expression has been marked as requiring a range check, then
+ -- generate it here.
+
+ if Do_Range_Check (Expr) then
+ Set_Do_Range_Check (Expr, False);
+ Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed);
+ end if;
+
if Relocate then
- Add_Association (New_C, Relocate_Node (Expr));
+ Add_Association (New_C, Relocate_Node (Expr), New_Assoc_List);
else
- Add_Association (New_C, Expr);
+ Add_Association (New_C, Expr, New_Assoc_List);
end if;
end Resolve_Aggr_Expr;
-- Start of processing for Resolve_Record_Aggregate
begin
+ -- A record aggregate is restricted in SPARK:
+ -- Each named association can have only a single choice.
+ -- OTHERS cannot be used.
+ -- Positional and named associations cannot be mixed.
+
+ if Present (Component_Associations (N))
+ and then Present (First (Component_Associations (N)))
+ then
+
+ if Present (Expressions (N)) then
+ Check_SPARK_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_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_Restriction
+ ("record aggregate cannot contain OTHERS", Assoc);
+ end if;
+
+ Assoc := Next (Assoc);
+ end loop;
+ end;
+ end if;
+
-- We may end up calling Duplicate_Subexpr on expressions that are
-- attached to New_Assoc_List. For this reason we need to attach it
-- to the tree by setting its parent pointer to N. This parent point
Error_Msg_N ("record aggregate cannot be null", N);
return;
- elsif No (First_Entity (Typ)) then
+ -- If the type has no components, then the aggregate should either
+ -- have "null record", or in Ada 2005 it could instead have a single
+ -- component association given by "others => <>". For Ada 95 we flag an
+ -- error at this point, but for Ada 2005 we proceed with checking the
+ -- associations below, which will catch the case where it's not an
+ -- aggregate with "others => <>". Note that the legality of a <>
+ -- aggregate for a null record type was established by AI05-016.
+
+ elsif No (First_Entity (Typ))
+ and then Ada_Version < Ada_2005
+ then
Error_Msg_N ("record aggregate must be null", N);
return;
end if;
if Selector_Name /= First (Choices (Assoc))
or else Present (Next (Selector_Name))
then
- Error_Msg_N ("OTHERS must appear alone in a choice list",
- Selector_Name);
+ Error_Msg_N
+ ("OTHERS must appear alone in a choice list",
+ Selector_Name);
return;
elsif Present (Next (Assoc)) then
- Error_Msg_N ("OTHERS must appear last in an aggregate",
- Selector_Name);
+ Error_Msg_N
+ ("OTHERS must appear last in an aggregate",
+ Selector_Name);
return;
- -- (Ada2005): If this is an association with a box,
+ -- (Ada 2005): If this is an association with a box,
-- indicate that the association need not represent
-- any component.
Positional_Expr := Empty;
end if;
- if Has_Discriminants (Typ) then
+ -- AI05-0115: if the ancestor part is a subtype mark, the ancestor
+ -- must npt have unknown discriminants.
+
+ if Is_Derived_Type (Typ)
+ and then Has_Unknown_Discriminants (Root_Type (Typ))
+ and then Nkind (N) /= N_Extension_Aggregate
+ then
+ Error_Msg_NE
+ ("aggregate not available for type& whose ancestor "
+ & "has unknown discriminants ", N, Typ);
+ end if;
+
+ if Has_Unknown_Discriminants (Typ)
+ and then Present (Underlying_Record_View (Typ))
+ then
+ Discrim := First_Discriminant (Underlying_Record_View (Typ));
+ elsif Has_Discriminants (Typ) then
Discrim := First_Discriminant (Typ);
else
Discrim := Empty;
-- Ada 2005 (AI-231)
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Known_Null (Positional_Expr)
then
Check_Can_Never_Be_Null (Discrim, Positional_Expr);
Next_Discriminant (Discrim);
end loop;
- -- Find remaining discriminant values, if any, among named components
+ -- Find remaining discriminant values if any among named components
while Present (Discrim) loop
Expr := Get_Value (Discrim, Component_Associations (N), True);
-- 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) then
+ -- 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;
Next (New_Assoc);
end loop;
- Indic :=
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Occurrence_Of (Base_Type (Typ), Loc),
- Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C));
+ 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);
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;
+
begin
if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
Parent_Typ_List := New_Elmt_List;
-- If this is an extension aggregate, the component list must
- -- include all components that are not in the given ancestor
- -- type. Otherwise, the component list must include components
- -- of all ancestors, starting with the root.
+ -- include all components that are not in the given ancestor type.
+ -- Otherwise, the component list must include components of all
+ -- ancestors, starting with the root.
if Nkind (N) = N_Extension_Aggregate then
Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
+
else
+ -- AI05-0115: check legality of aggregate for type with
+ -- aa private ancestor.
+
Root_Typ := Root_Type (Typ);
+ if Has_Private_Ancestor (Typ) then
+ declare
+ Ancestor : constant Entity_Id :=
+ Find_Private_Ancestor;
+ Ancestor_Unit : constant Entity_Id :=
+ Cunit_Entity (Get_Source_Unit (Ancestor));
+ Parent_Unit : constant Entity_Id :=
+ 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
+ -- only happen if the derivation takes place in a child
+ -- unit of the unit that declares the parent, and we are
+ -- in the private part or body of that child unit, else
+ -- the aggregate is illegal.
+
+ if Is_Child_Unit (Ancestor_Unit)
+ and then Scope (Ancestor_Unit) = Parent_Unit
+ and then In_Open_Scopes (Scope (Ancestor))
+ and then
+ (In_Private_Part (Scope (Ancestor))
+ or else In_Package_Body (Scope (Ancestor)))
+ then
+ null;
- if Nkind (Parent (Base_Type (Root_Typ))) =
- N_Private_Type_Declaration
- then
- Error_Msg_NE
- ("type of aggregate has private ancestor&!",
- N, Root_Typ);
- Error_Msg_N ("must use extension aggregate!", N);
- return;
+ else
+ Error_Msg_NE
+ ("type of aggregate has private ancestor&!",
+ N, Root_Typ);
+ Error_Msg_N ("must use extension aggregate!", N);
+ return;
+ end if;
+ end;
end if;
Dnode := Declaration_Node (Base_Type (Root_Typ));
- -- If we don't get a full declaration, then we have some
- -- error which will get signalled later so skip this part.
- -- Otherwise, gather components of root that apply to the
- -- aggregate type. We use the base type in case there is an
- -- applicable stored constraint that renames the discriminants
- -- of the root.
+ -- If we don't get a full declaration, then we have some error
+ -- which will get signalled later so skip this part. Otherwise
+ -- gather components of root that apply to the aggregate type.
+ -- We use the base type in case there is an applicable stored
+ -- constraint that renames the discriminants of the root.
if Nkind (Dnode) = N_Full_Type_Declaration then
Record_Def := Type_Definition (Dnode);
end if;
end if;
- Parent_Typ := Base_Type (Typ);
+ Parent_Typ := Base_Type (Typ);
while Parent_Typ /= Root_Typ loop
Prepend_Elmt (Parent_Typ, To => Parent_Typ_List);
Parent_Typ := Etype (Parent_Typ);
Ancestor_Part (N), Parent_Typ);
return;
end if;
+
+ -- The current view of ancestor part may be a private type,
+ -- while the context type is always non-private.
+
+ elsif Is_Private_Type (Root_Typ)
+ and then Present (Full_View (Root_Typ))
+ and then Nkind (N) = N_Extension_Aggregate
+ then
+ exit when Base_Type (Full_View (Root_Typ)) = Parent_Typ;
end if;
end loop;
- -- Now collect components from all other ancestors
+ -- Now collect components from all other ancestors, beginning
+ -- with the current type. If the type has unknown discriminants
+ -- use the component list of the Underlying_Record_View, which
+ -- needs to be used for the subsequent expansion of the aggregate
+ -- into assignments.
Parent_Elmt := First_Elmt (Parent_Typ_List);
while Present (Parent_Elmt) loop
Parent_Typ := Node (Parent_Elmt);
+
+ if Has_Unknown_Discriminants (Parent_Typ)
+ and then Present (Underlying_Record_View (Typ))
+ then
+ Parent_Typ := Underlying_Record_View (Parent_Typ);
+ end if;
+
Record_Def := Type_Definition (Parent (Base_Type (Parent_Typ)));
Gather_Components (Empty,
Component_List (Record_Extension_Part (Record_Def)),
if Null_Present (Record_Def) then
null;
- else
+
+ elsif not Has_Unknown_Discriminants (Typ) then
Gather_Components (Base_Type (Typ),
Component_List (Record_Def),
Governed_By => New_Assoc_List,
Into => Components,
Report_Errors => Errors_Found);
+
+ else
+ Gather_Components
+ (Base_Type (Underlying_Record_View (Typ)),
+ Component_List (Record_Def),
+ Governed_By => New_Assoc_List,
+ Into => Components,
+ Report_Errors => Errors_Found);
end if;
end if;
-- Ada 2005 (AI-231)
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Known_Null (Positional_Expr)
then
Check_Can_Never_Be_Null (Component, Positional_Expr);
begin
-- If there is a default expression for the aggregate, copy
- -- it into a new association.
+ -- it into a new association. This copy must modify the scopes
+ -- of internal types that may be attached to the expression
+ -- (e.g. index subtypes of arrays) because in general the type
+ -- declaration and the aggregate appear in different scopes,
+ -- and the backend requires the scope of the type to match the
+ -- point at which it is elaborated.
-- If the component has an initialization procedure (IP) we
-- pass the component to the expander, which will generate
-- If the component has discriminants, their values must
-- be taken from their subtype. This is indispensable for
-- constraints that are given by the current instance of an
- -- enclosing type, to allow the expansion of the aggregate
- -- to replace the reference to the current instance by the
- -- target object of the aggregate.
+ -- enclosing type, to allow the expansion of the aggregate to
+ -- replace the reference to the current instance by the target
+ -- object of the aggregate.
if Present (Parent (Component))
and then
and then Present (Expression (Parent (Component)))
then
Expr :=
- New_Copy_Tree (Expression (Parent (Component)),
- New_Sloc => Sloc (N));
+ New_Copy_Tree
+ (Expression (Parent (Component)),
+ New_Scope => Current_Scope,
+ New_Sloc => Sloc (N));
Add_Association
- (Component => Component,
- Expr => Expr);
+ (Component => Component,
+ Expr => Expr,
+ Assoc_List => New_Assoc_List);
Set_Has_Self_Reference (N);
-- A box-defaulted access component gets the value null. Also
Expr := Make_Null (Sloc (N));
Set_Etype (Expr, Ctyp);
Add_Association
- (Component => Component,
- Expr => Expr);
+ (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
begin
Analyze_And_Resolve (Convert_Null, Ctyp);
Add_Association
- (Component => Component, Expr => Convert_Null);
+ (Component => Component,
+ Expr => Convert_Null,
+ Assoc_List => New_Assoc_List);
end;
end if;
then
if Is_Record_Type (Ctyp)
and then Has_Discriminants (Ctyp)
+ and then not Is_Private_Type (Ctyp)
then
-- We build a partially initialized aggregate with the
-- values of the discriminants and box initialization
-- 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
+ -- (transitively) by discriminants of enclosing types.
+ -- For a private type with discriminants, a call to the
+ -- initialization procedure will be generated, and no
+ -- subaggregate is needed.
+
+ Capture_Discriminants : declare
+ 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;
- declare
- Loc : constant Source_Ptr := Sloc (N);
- Assoc : Node_Id;
- Discr : Entity_Id;
- Discr_Elmt : Elmt_Id;
- Discr_Val : Node_Id;
- Expr : Node_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;
- begin
- Expr := Make_Aggregate (Loc, New_List, New_List);
+ 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.
- Discr_Elmt :=
- First_Elmt (Discriminant_Constraint (Ctyp));
- while Present (Discr_Elmt) loop
- Discr_Val := Node (Discr_Elmt);
+ 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 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
- -- The constraint may be given by a discriminant
- -- of the enclosing type, in which case we have
- -- to retrieve its value, which is part of the
- -- current aggregate.
+ 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 Is_Entity_Name (Discr_Val)
+ if Nkind (Def_Node) = N_Record_Definition
and then
- Ekind (Entity (Discr_Val)) = E_Discriminant
+ Present (Component_List (Def_Node))
+ and then
+ Present
+ (Variant_Part (Component_List (Def_Node)))
then
- Discr := Entity (Discr_Val);
-
- Assoc := First (New_Assoc_List);
- while Present (Assoc) loop
- if Present
- (Entity (First (Choices (Assoc))))
- and then
- Entity (First (Choices (Assoc))) = Discr
+ 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
- Discr_Val := Expression (Assoc);
- exit;
+ Process_Component (Node (Comp_Elmt));
end if;
- Next (Assoc);
+
+ Next_Elmt (Comp_Elmt);
end loop;
- end if;
- Append
- (New_Copy_Tree (Discr_Val), Expressions (Expr));
+ -- No variant part, iterate over all components
- -- If the discriminant constraint is a current
- -- instance, mark the current aggregate so that
- -- the self-reference can be expanded later.
+ else
+ Comp := First_Component (Etype (Aggr));
+ while Present (Comp) loop
+ Process_Component (Comp);
+ Next_Component (Comp);
+ end loop;
+ end if;
- 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 Etype (N) = Entity (Prefix (Discr_Val))
- then
- Set_Has_Self_Reference (N);
+ if Needs_Box then
+ Append
+ (Make_Component_Association (Loc,
+ Choices =>
+ New_List (Make_Others_Choice (Loc)),
+ Expression => Empty,
+ Box_Present => True),
+ Component_Associations (Aggr));
end if;
+ end Propagate_Discriminants;
- Next_Elmt (Discr_Elmt);
- end loop;
+ -- Start of processing for Capture_Discriminants
+
+ begin
+ Expr := Make_Aggregate (Loc, New_List, New_List);
+ Set_Etype (Expr, Ctyp);
- declare
- Comp : Entity_Id;
+ -- If the enclosing type has discriminants, they have
+ -- been collected in the aggregate earlier, and they
+ -- may appear as constraints of subcomponents.
- begin
- -- Look for a component that is not a discriminant
- -- before creating an others box association.
-
- Comp := First_Component (Ctyp);
- while Present (Comp) loop
- if Ekind (Comp) = E_Component then
- Append
- (Make_Component_Association (Loc,
- Choices =>
- New_List (Make_Others_Choice (Loc)),
- Expression => Empty,
- Box_Present => True),
- Component_Associations (Expr));
- exit;
- end if;
+ -- Similarly if this component has discriminants, they
+ -- might in turn be propagated to their components.
- Next_Component (Comp);
- end loop;
- end;
+ if Has_Discriminants (Typ) then
+ Add_Discriminant_Values (Expr, New_Assoc_List);
+ Propagate_Discriminants (Expr, New_Assoc_List);
+
+ elsif Has_Discriminants (Ctyp) then
+ Add_Discriminant_Values
+ (Expr, Component_Associations (Expr));
+ Propagate_Discriminants
+ (Expr, Component_Associations (Expr));
+
+ else
+ declare
+ Comp : Entity_Id;
+
+ begin
+ -- If the type has additional components, create
+ -- an OTHERS box association for them.
+
+ Comp := First_Component (Ctyp);
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Component then
+ if not Is_Record_Type (Etype (Comp)) then
+ Append
+ (Make_Component_Association (Loc,
+ Choices =>
+ New_List
+ (Make_Others_Choice (Loc)),
+ Expression => Empty,
+ Box_Present => True),
+ Component_Associations (Expr));
+ end if;
+ exit;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+ end;
+ end if;
Add_Association
- (Component => Component,
- Expr => Expr);
- end;
+ (Component => Component,
+ Expr => Expr,
+ Assoc_List => New_Assoc_List);
+ end Capture_Discriminants;
else
Add_Association
(Component => Component,
Expr => Empty,
+ Assoc_List => New_Assoc_List,
Is_Box_Present => True);
end if;
New_Assoc := First (New_Assoc_List);
while Present (New_Assoc) loop
Component := First (Choices (New_Assoc));
- exit when Chars (Selectr) = Chars (Component);
+
+ if Chars (Selectr) = Chars (Component) then
+ if Style_Check then
+ Check_Identifier (Selectr, Entity (Component));
+ end if;
+
+ exit;
+ end if;
+
Next (New_Assoc);
end loop;
elsif Chars (Selectr) /= Name_uTag
and then Chars (Selectr) /= Name_uParent
- and then Chars (Selectr) /= Name_uController
then
if not Has_Discriminants (Typ) then
Error_Msg_Node_2 := Typ;
elsif No (Typech) then
Typech := Base_Type (Etype (Component));
+ -- AI05-0199: In Ada 2012, several components of anonymous
+ -- access types can appear in a choice list, as long as the
+ -- designated types match.
+
elsif Typech /= Base_Type (Etype (Component)) then
- if not Box_Present (Parent (Selectr)) then
+ if Ada_Version >= Ada_2012
+ and then Ekind (Typech) = E_Anonymous_Access_Type
+ and then
+ Ekind (Etype (Component)) = E_Anonymous_Access_Type
+ and then Base_Type (Designated_Type (Typech)) =
+ Base_Type (Designated_Type (Etype (Component)))
+ and then
+ Subtypes_Statically_Match (Typech, (Etype (Component)))
+ then
+ null;
+
+ elsif not Box_Present (Parent (Selectr)) then
Error_Msg_N
("components in choice list must have same type",
Selectr);
begin
pragma Assert
- (Ada_Version >= Ada_05
+ (Ada_Version >= Ada_2005
and then Present (Expr)
and then Known_Null (Expr));
OSDN Git Service
