-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
+with Namet.Sp; use Namet.Sp;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
-with Rtsfind; use Rtsfind;
with Sem; use Sem;
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 Tbuild; use Tbuild;
with Uintp; use Uintp;
-with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
-
package body Sem_Aggr is
type Case_Bounds is record
-- E_Component/E_Discriminant entity in the record case, in which case the
-- type of the component will be used for the test. If Typ is any other
-- kind of entity, the call is ignored. Expr is the component node in the
- -- aggregate which is an explicit occurrence of NULL. An error will be
+ -- aggregate which is known to have a null value. A warning message will be
-- issued if the component is null excluding.
--
-- It would be better to pass the proper type for Typ ???
+ procedure Check_Expr_OK_In_Limited_Aggregate (Expr : Node_Id);
+ -- Check that Expr is either not limited or else is one of the cases of
+ -- expressions allowed for a limited component association (namely, an
+ -- aggregate, function call, or <> notation). Report error for violations.
+
------------------------------------------------------
-- Subprograms used for RECORD AGGREGATE Processing --
------------------------------------------------------
-- quadratic in the size of the association list.
procedure Check_Misspelled_Component
- (Elements : Elist_Id;
- Component : Node_Id);
+ (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 Resolv_Aggr_Expr after producing
+ -- 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);
Index : Node_Id;
Index_Constr : Node_Id;
Component_Typ : Entity_Id;
- Others_Allowed : Boolean)
- return Boolean;
+ Others_Allowed : Boolean) return Boolean;
-- This procedure performs the semantic checks for an array aggregate.
-- True is returned if the aggregate resolution succeeds.
+ --
-- The procedure works by recursively checking each nested aggregate.
-- Specifically, after checking a sub-aggregate nested at the i-th level
-- we recursively check all the subaggregates at the i+1-st level (if any).
-- appears last in the sub-aggregate. Check that we do not have
-- positional and named components in the array sub-aggregate (unless
-- the named association is an others choice). Finally if an others
- -- choice is present, make sure it is allowed in the aggregate contex.
+ -- choice is present, make sure it is allowed in the aggregate context.
--
-- 2. If the array sub-aggregate contains discrete_choices:
--
-- This is really expansion activity, so make sure that expansion
-- is on and is allowed.
- if not Expander_Active or else In_Default_Expression then
+ if not Expander_Active or else In_Spec_Expression then
return;
end if;
Index_Typ : Entity_Id;
begin
- -- Construct the Index subtype
+ -- Construct the Index subtype, and associate it with the range
+ -- construct that generates it.
- Index_Typ := Create_Itype (Subtype_Kind (Ekind (Index_Base)), N);
+ Index_Typ :=
+ Create_Itype (Subtype_Kind (Ekind (Index_Base)), Aggr_Range (J));
Set_Etype (Index_Typ, Index_Base);
Set_First_Index (Itype, First (Index_Constraints));
Set_Is_Constrained (Itype, True);
Set_Is_Internal (Itype, True);
- Init_Size_Align (Itype);
-
- -- Handle aggregate initializing statically allocated dispatch table
-
- if Static_Dispatch_Tables
- and then VM_Target = No_VM
- and then RTU_Loaded (Ada_Tags)
-
- -- Avoid circularity when rebuilding the compiler
-
- and then Cunit_Entity (Get_Source_Unit (N)) /= RTU_Entity (Ada_Tags)
- and then (Etype (N) = RTE (RE_Address_Array)
- or else
- Base_Type (Etype (N)) = RTE (RE_Tag_Table))
- then
- Set_Size_Known_At_Compile_Time (Itype);
-- 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.
- else
- 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)));
- end if;
+ 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.
-- 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_Default_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;
-- misspellings, these misspellings will be suggested as
-- possible correction.
- Get_Name_String (Chars (Component));
+ Component_Elmt := First_Elmt (Elements);
+ while Nr_Of_Suggestions <= Max_Suggestions
+ and then Present (Component_Elmt)
+ loop
+ if Is_Bad_Spelling_Of
+ (Chars (Node (Component_Elmt)),
+ Chars (Component))
+ then
+ Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
- declare
- S : constant String (1 .. Name_Len) :=
- Name_Buffer (1 .. Name_Len);
+ case Nr_Of_Suggestions is
+ when 1 => Suggestion_1 := Node (Component_Elmt);
+ when 2 => Suggestion_2 := Node (Component_Elmt);
+ when others => exit;
+ end case;
+ end if;
- begin
- Component_Elmt := First_Elmt (Elements);
- while Nr_Of_Suggestions <= Max_Suggestions
- and then Present (Component_Elmt)
- loop
- Get_Name_String (Chars (Node (Component_Elmt)));
+ Next_Elmt (Component_Elmt);
+ end loop;
- if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
- Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
+ -- Report at most two suggestions
- case Nr_Of_Suggestions is
- when 1 => Suggestion_1 := Node (Component_Elmt);
- when 2 => Suggestion_2 := Node (Component_Elmt);
- when others => exit;
- end case;
- end if;
+ if Nr_Of_Suggestions = 1 then
+ Error_Msg_NE
+ ("\possible misspelling of&", Component, Suggestion_1);
- Next_Elmt (Component_Elmt);
- end loop;
-
- -- Report at most two suggestions
+ elsif Nr_Of_Suggestions = 2 then
+ Error_Msg_Node_2 := Suggestion_2;
+ Error_Msg_NE
+ ("\possible misspelling of& or&", Component, Suggestion_1);
+ end if;
+ end Check_Misspelled_Component;
- if Nr_Of_Suggestions = 1 then
- Error_Msg_NE ("\possible misspelling of&",
- Component, Suggestion_1);
+ ----------------------------------------
+ -- Check_Expr_OK_In_Limited_Aggregate --
+ ----------------------------------------
- elsif Nr_Of_Suggestions = 2 then
- Error_Msg_Node_2 := Suggestion_2;
- Error_Msg_NE ("\possible misspelling of& or&",
- Component, Suggestion_1);
+ procedure Check_Expr_OK_In_Limited_Aggregate (Expr : Node_Id) is
+ begin
+ if Is_Limited_Type (Etype (Expr))
+ and then Comes_From_Source (Expr)
+ and then not In_Instance_Body
+ then
+ if not OK_For_Limited_Init (Expr) then
+ Error_Msg_N ("initialization not allowed for limited types", Expr);
+ Explain_Limited_Type (Etype (Expr), Expr);
end if;
- end;
- end Check_Misspelled_Component;
+ end if;
+ end Check_Expr_OK_In_Limited_Aggregate;
----------------------------------------
-- Check_Static_Discriminated_Subtype --
-- 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.
if Number_Dimensions (Typ) = 1
- and then
- (Root_Type (Component_Type (Typ)) = Standard_Character
- or else
- Root_Type (Component_Type (Typ)) = Standard_Wide_Character
- or else
- Root_Type (Component_Type (Typ)) = Standard_Wide_Wide_Character)
+ and then Is_Standard_Character_Type (Component_Type (Typ))
and then No (Component_Associations (N))
and then not Is_Limited_Composite (Typ)
and then not Is_Private_Composite (Typ)
Pkind = N_Procedure_Call_Statement or else
Pkind = N_Generic_Association or else
Pkind = N_Formal_Object_Declaration or else
- Pkind = N_Return_Statement 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
Index : Node_Id;
Index_Constr : Node_Id;
Component_Typ : Entity_Id;
- Others_Allowed : Boolean)
- return Boolean
+ Others_Allowed : Boolean) return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
function Resolve_Aggr_Expr
(Expr : Node_Id;
- Single_Elmt : Boolean)
- return Boolean;
- -- Resolves aggregate expression Expr. Returs False if resolution
+ 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
Val_AL : Uint;
Val_AH : Uint;
- OK_L : Boolean;
- OK_H : Boolean;
+ OK_L : Boolean;
+ OK_H : Boolean;
+
OK_AL : Boolean;
- OK_AH : Boolean;
+ OK_AH : Boolean;
+ pragma Warnings (Off, OK_AL);
+ pragma Warnings (Off, OK_AH);
begin
if Raises_Constraint_Error (N)
function Resolve_Aggr_Expr
(Expr : Node_Id;
- Single_Elmt : Boolean)
- return Boolean
+ Single_Elmt : Boolean) return Boolean
is
Nxt_Ind : constant Node_Id := Next_Index (Index);
Nxt_Ind_Constr : constant Node_Id := Next_Index (Index_Constr);
- -- Index is the current index corresponding to the expresion
+ -- Index is the current index corresponding to the expression
Resolution_OK : Boolean := True;
-- Set to False if resolution of the expression failed
if Is_Character_Type (Component_Typ)
and then No (Next_Index (Nxt_Ind))
- and then (Nkind (Expr) = N_String_Literal
- or else Nkind (Expr) = N_Operator_Symbol)
+ and then Nkind_In (Expr, N_String_Literal, N_Operator_Symbol)
then
-- A string literal used in a multidimensional array
-- aggregate in place of the final one-dimensional
elsif Single_Elmt
or else not Expander_Active
- or else In_Default_Expression
+ 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);
Choice : Node_Id;
Expr : Node_Id;
- Who_Cares : Node_Id;
+ Discard : Node_Id;
+ pragma Warnings (Off, Discard);
Aggr_Low : Node_Id := Empty;
Aggr_High : Node_Id := Empty;
if Ada_Version = Ada_83
and then Assoc /= First (Component_Associations (N))
- and then (Nkind (Parent (N)) = N_Assignment_Statement
- or else
- Nkind (Parent (N)) = N_Object_Declaration)
+ and then Nkind_In (Parent (N), N_Assignment_Statement,
+ N_Object_Declaration)
then
Error_Msg_N
("(Ada 83) illegal context for OTHERS choice", N);
-- STEP 2: Process named components
if No (Expressions (N)) then
-
if Others_Present then
Case_Table_Size := Nb_Choices - 1;
else
return Failure;
end if;
+ -- Case of subtype indication
+
elsif Nkind (Choice) = N_Subtype_Indication then
Resolve_Discrete_Subtype_Indication (Choice, Index_Base);
Get_Index_Bounds (Choice, Low, High);
Check_Bounds (S_Low, S_High, Low, High);
- else -- Choice is a range or an expression
+ -- Case of range or expression
+
+ else
Resolve (Choice, Index_Base);
Check_Unset_Reference (Choice);
Check_Non_Static_Context (Choice);
-- Ada 2005 (AI-231)
if Ada_Version >= Ada_05
- and then Nkind (Expression (Assoc)) = N_Null
+ and then Known_Null (Expression (Assoc))
then
Check_Can_Never_Be_Null (Etype (N), Expression (Assoc));
end if;
return Failure;
elsif not Others_Present then
-
Hi_Val := Expr_Value (Table (J).Choice_Hi);
Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
Choices_High := Table (Nb_Discrete_Choices).Choice_Hi;
end if;
+ -- If Others is present, then bounds of aggregate come from the
+ -- index constraint (not the choices in the aggregate itself).
+
if Others_Present then
Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
+ -- No others clause present
+
else
+ -- Special processing if others allowed and not present. This
+ -- means that the bounds of the aggregate come from the index
+ -- constraint (and the length must match).
+
+ if Others_Allowed then
+ Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
+
+ -- 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
+ -- an additional warning is useful:
+
+ -- If we have no positional components, and the length is
+ -- wrong (which we can tell by others being allowed with
+ -- missing components), and the index type is an enumeration
+ -- type, then issue appropriate warnings about these missing
+ -- components. They are only warnings, since the aggregate
+ -- is fine, it's just the wrong length. We skip this check
+ -- for standard character types (since there are no literals
+ -- and it is too much trouble to concoct them), and also if
+ -- any of the bounds have not-known-at-compile-time values.
+
+ -- Another case warranting a warning is when the length is
+ -- right, but as above we have an index type that is an
+ -- enumeration, and the bounds do not match. This is a
+ -- case where dubious sliding is allowed and we generate
+ -- a warning that the bounds do not match.
+
+ if No (Expressions (N))
+ and then Nkind (Index) = N_Range
+ and then Is_Enumeration_Type (Etype (Index))
+ and then not Is_Standard_Character_Type (Etype (Index))
+ and then Compile_Time_Known_Value (Aggr_Low)
+ and then Compile_Time_Known_Value (Aggr_High)
+ and then Compile_Time_Known_Value (Choices_Low)
+ and then Compile_Time_Known_Value (Choices_High)
+ then
+ declare
+ ALo : constant Node_Id := Expr_Value_E (Aggr_Low);
+ AHi : constant Node_Id := Expr_Value_E (Aggr_High);
+ CLo : constant Node_Id := Expr_Value_E (Choices_Low);
+ CHi : constant Node_Id := Expr_Value_E (Choices_High);
+
+ Ent : Entity_Id;
+
+ begin
+ -- Warning case one, missing values at start/end. Only
+ -- do the check if the number of entries is too small.
+
+ if (Enumeration_Pos (CHi) - Enumeration_Pos (CLo))
+ <
+ (Enumeration_Pos (AHi) - Enumeration_Pos (ALo))
+ then
+ Error_Msg_N
+ ("missing index value(s) in array aggregate?", N);
+
+ -- Output missing value(s) at start
+
+ if Chars (ALo) /= Chars (CLo) then
+ Ent := Prev (CLo);
+
+ if Chars (ALo) = Chars (Ent) then
+ Error_Msg_Name_1 := Chars (ALo);
+ Error_Msg_N ("\ %?", N);
+ else
+ Error_Msg_Name_1 := Chars (ALo);
+ Error_Msg_Name_2 := Chars (Ent);
+ Error_Msg_N ("\ % .. %?", N);
+ end if;
+ end if;
+
+ -- Output missing value(s) at end
+
+ if Chars (AHi) /= Chars (CHi) then
+ Ent := Next (CHi);
+
+ if Chars (AHi) = Chars (Ent) then
+ Error_Msg_Name_1 := Chars (Ent);
+ Error_Msg_N ("\ %?", N);
+ else
+ Error_Msg_Name_1 := Chars (Ent);
+ Error_Msg_Name_2 := Chars (AHi);
+ Error_Msg_N ("\ % .. %?", N);
+ end if;
+ end if;
+
+ -- Warning case 2, dubious sliding. The First_Subtype
+ -- test distinguishes between a constrained type where
+ -- sliding is not allowed (so we will get a warning
+ -- later that Constraint_Error will be raised), and
+ -- the unconstrained case where sliding is permitted.
+
+ elsif (Enumeration_Pos (CHi) - Enumeration_Pos (CLo))
+ =
+ (Enumeration_Pos (AHi) - Enumeration_Pos (ALo))
+ and then Chars (ALo) /= Chars (CLo)
+ and then
+ not Is_Constrained (First_Subtype (Etype (N)))
+ then
+ Error_Msg_N
+ ("bounds of aggregate do not match target?", N);
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- If no others, aggregate bounds come from aggregate
+
Aggr_Low := Choices_Low;
Aggr_High := Choices_High;
end if;
-- Ada 2005 (AI-231)
if Ada_Version >= Ada_05
- and then Nkind (Expr) = N_Null
+ and then Known_Null (Expr)
then
Check_Can_Never_Be_Null (Etype (N), Expr);
end if;
-- Ada 2005 (AI-231)
if Ada_Version >= Ada_05
- and then Nkind (Assoc) = N_Null
+ and then Known_Null (Assoc)
then
Check_Can_Never_Be_Null (Etype (N), Expression (Assoc));
end if;
else
if Others_Allowed then
- Get_Index_Bounds (Index_Constr, Aggr_Low, Who_Cares);
+ Get_Index_Bounds (Index_Constr, Aggr_Low, Discard);
else
Aggr_Low := Index_Typ_Low;
end if;
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.
+ -- of the expected type, which must be a type extension.
+
+ ----------------------------
+ -- 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;
+
+ elsif Nkind_In (Anc, N_Aggregate, 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));
+
+ else
+ return False;
+ end if;
+ end Valid_Limited_Ancestor;
-------------------------
-- Valid_Ancestor_Type --
Imm_Type := Etype (Base_Type (Imm_Type));
end loop;
- if Etype (Imm_Type) /= Base_Type (A_Type) then
+ 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
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
return;
+
+ elsif Valid_Limited_Ancestor (A) then
+ null;
+
+ else
+ Error_Msg_N
+ ("limited ancestor part must be aggregate or function call", A);
end if;
elsif Is_Class_Wide_Type (Typ) then
-- Ada 2005 (AI-231)
if Ada_Version >= Ada_05
- and then Nkind (Expression (Assoc)) = N_Null
+ and then Known_Null (Expression (Assoc))
then
Check_Can_Never_Be_Null (Compon, Expression (Assoc));
end if;
return Expr;
end Get_Value;
- procedure Check_Non_Limited_Type (Expr : Node_Id);
- -- Relax check to allow the default initialization of limited types.
- -- For example:
- -- record
- -- C : Lim := (..., others => <>);
- -- end record;
-
- ----------------------------
- -- Check_Non_Limited_Type --
- ----------------------------
-
- procedure Check_Non_Limited_Type (Expr : Node_Id) is
- begin
- if Is_Limited_Type (Etype (Expr))
- and then Comes_From_Source (Expr)
- and then not In_Instance_Body
- then
- if not OK_For_Limited_Init (Expr) then
- Error_Msg_N
- ("initialization not allowed for limited types", N);
- Explain_Limited_Type (Etype (Expr), Expr);
- end if;
- end if;
- end Check_Non_Limited_Type;
-
-----------------------
-- Resolve_Aggr_Expr --
-----------------------
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
Kind : constant Node_Kind := Nkind (Expr);
-
begin
- return ((Kind = N_Aggregate
- or else Kind = N_Extension_Aggregate)
+ 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;
Expr_Type := Etype (Component);
-- Otherwise we have to pick up the new type of the component from
- -- the new costrained subtype of the aggregate. In fact components
+ -- the new constrained subtype of the aggregate. In fact components
-- which are of a composite type might be constrained by a
-- discriminant, and we want to resolve Expr against the subtype were
-- all discriminant occurrences are replaced with their actual value.
end if;
Analyze_And_Resolve (Expr, Expr_Type);
- Check_Non_Limited_Type (Expr);
+ Check_Expr_OK_In_Limited_Aggregate (Expr);
Check_Non_Static_Context (Expr);
Check_Unset_Reference (Expr);
Error_Msg_N ("OTHERS must appear last in an aggregate",
Selector_Name);
return;
+
+ -- (Ada2005): If this is an association with a box,
+ -- indicate that the association need not represent
+ -- any component.
+
+ elsif Box_Present (Assoc) then
+ Others_Box := True;
end if;
else
-- Ada 2005 (AI-231)
if Ada_Version >= Ada_05
- and then Nkind (Positional_Expr) = N_Null
+ and then Known_Null (Positional_Expr)
then
Check_Can_Never_Be_Null (Discrim, Positional_Expr);
end if;
-- in sem_ch3 and here rather than have a copy of the code which is a
-- maintenance nightmare.
- -- ??? Performace WARNING. The current implementation creates a new
+ -- ??? 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 cmponent type has discriminants. For large aggregates
+ -- 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.
else
Root_Typ := Root_Type (Typ);
- if Nkind (Parent (Base_Type (Root_Typ)))
- = N_Private_Type_Declaration
+ if Nkind (Parent (Base_Type (Root_Typ))) =
+ N_Private_Type_Declaration
then
Error_Msg_NE
("type of aggregate has private ancestor&!",
-- Ada 2005 (AI-231)
if Ada_Version >= Ada_05
- and then Nkind (Positional_Expr) = N_Null
+ and then Known_Null (Positional_Expr)
then
Check_Can_Never_Be_Null (Component, Positional_Expr);
end if;
Expr := Get_Value (Component, Component_Associations (N), True);
-- Note: The previous call to Get_Value sets the value of the
- -- variable Is_Box_Present
+ -- variable Is_Box_Present.
-- Ada 2005 (AI-287): Handle components with default initialization.
-- Note: This feature was originally added to Ada 2005 for limited
-- but it was finally allowed with any type.
if Is_Box_Present then
- declare
- Is_Array_Subtype : constant Boolean :=
- Ekind (Etype (Component)) =
- E_Array_Subtype;
-
- Ctyp : Entity_Id;
+ Check_Box_Component : declare
+ Ctyp : constant Entity_Id := Etype (Component);
begin
- if Is_Array_Subtype then
- Ctyp := Component_Type (Base_Type (Etype (Component)));
- else
- Ctyp := Etype (Component);
- end if;
-
-- If there is a default expression for the aggregate, copy
-- it into a new association.
Expr => Expr);
Set_Has_Self_Reference (N);
+ -- A box-defaulted access component gets the value null. Also
+ -- included are components of private types whose underlying
+ -- type is an access type. In either case set the type of the
+ -- literal, for subsequent use in semantic checks.
+
+ 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);
+
+ -- 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
+ 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)));
+
+ Convert_Null : constant Node_Id :=
+ Unchecked_Convert_To
+ (Ctyp, Qual_Null);
+
+ begin
+ Analyze_And_Resolve (Convert_Null, Ctyp);
+ Add_Association
+ (Component => Component, Expr => Convert_Null);
+ end;
+ end if;
+
elsif Has_Non_Null_Base_Init_Proc (Ctyp)
or else not Expander_Active
then
then
-- We build a partially initialized aggregate with the
-- values of the discriminants and box initialization
- -- for the rest.
+ -- for the rest, if other components are present.
declare
Loc : constant Source_Ptr := Sloc (N);
+ Assoc : Node_Id;
+ Discr : Entity_Id;
Discr_Elmt : Elmt_Id;
Discr_Val : Node_Id;
Expr : Node_Id;
First_Elmt (Discriminant_Constraint (Ctyp));
while Present (Discr_Elmt) loop
Discr_Val := Node (Discr_Elmt);
+
+ -- 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.
+
+ if Is_Entity_Name (Discr_Val)
+ and then
+ Ekind (Entity (Discr_Val)) = E_Discriminant
+ 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
+ then
+ Discr_Val := Expression (Assoc);
+ exit;
+ end if;
+ Next (Assoc);
+ end loop;
+ end if;
+
Append
(New_Copy_Tree (Discr_Val), Expressions (Expr));
Next_Elmt (Discr_Elmt);
end loop;
- Append
- (Make_Component_Association (Loc,
- Choices =>
- New_List (Make_Others_Choice (Loc)),
- Expression => Empty,
- Box_Present => True),
- Component_Associations (Expr));
+ declare
+ Comp : Entity_Id;
+
+ 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;
+
+ Next_Component (Comp);
+ end loop;
+ end;
Add_Association
(Component => Component,
-- expand the corresponding assignments and run-time checks).
elsif Present (Expr)
- and then
- ((not Is_Array_Subtype
- and then Is_Partially_Initialized_Type (Component))
- or else
- (Is_Array_Subtype
- and then Is_Partially_Initialized_Type (Ctyp)))
+ and then Is_Partially_Initialized_Type (Ctyp)
then
Resolve_Aggr_Expr (Expr, Component);
end if;
- end;
+ end Check_Box_Component;
elsif No (Expr) then
-- Ignore hidden components associated with the position of the
-- interface tags: these are initialized dynamically.
- if Present (Related_Interface (Component)) then
- null;
- else
+ if not Present (Related_Type (Component)) then
Error_Msg_NE
("no value supplied for component &!", N, Component);
end if;
C := First_Component (Typ);
while Present (C) loop
if Chars (C) = Chars (Selectr) then
- exit;
+
+ -- If the context is an extension aggregate,
+ -- the component must not be inherited from
+ -- the ancestor part of the aggregate.
+
+ if Nkind (N) /= N_Extension_Aggregate
+ or else
+ Scope (Original_Record_Component (C)) /=
+ Etype (Ancestor_Part (N))
+ then
+ exit;
+ end if;
end if;
Next_Component (C);
pragma Assert
(Ada_Version >= Ada_05
and then Present (Expr)
- and then Nkind (Expr) = N_Null);
+ and then Known_Null (Expr));
case Ekind (Typ) is
when E_Array_Type =>
Insert_Action
(Compile_Time_Constraint_Error
(Expr,
- "(Ada 2005) NULL not allowed in null-excluding components?"),
+ "(Ada 2005) null not allowed in null-excluding component?"),
Make_Raise_Constraint_Error (Sloc (Expr),
Reason => CE_Access_Check_Failed));