-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
-- statement of variant part will usually be small and probably in near
-- sorted order.
+ procedure Check_Can_Never_Be_Null (N : Node_Id; Expr : Node_Id);
+ -- Ada 2005 (AI-231): Check bad usage of the null-exclusion issue
+
------------------------------------------------------
-- Subprograms used for RECORD AGGREGATE Processing --
------------------------------------------------------
-- 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-aggreate nested at the i-th level
+ -- 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).
-- Note that for aggregates analysis and resolution go hand in hand.
-- Aggregate analysis has been delayed up to here and it is done while
--
-- Typ is the context type in which N occurs.
--
- -- This routine creates an implicit array subtype whose bouds are
+ -- This routine creates an implicit array subtype whose bounds are
-- those defined by the aggregate. When this routine is invoked
-- Resolve_Array_Aggregate has already processed aggregate N. Thus the
-- Aggregate_Bounds of each sub-aggregate, is an N_Range node giving the
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
+
+ -- 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 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;
Error_Msg_N ("aggregate type cannot have limited component", N);
Explain_Limited_Type (Typ, N);
+ -- Ada 2005 (AI-287): Limited aggregates allowed
+
elsif Is_Limited_Type (Typ)
- and not Extensions_Allowed
+ and Ada_Version < Ada_05
then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
Aggr_Typ : constant Entity_Id := Etype (Typ);
-- This is the unconstrained array type, which is the type
- -- against which the aggregate is to be resoved. Typ itself
+ -- 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.
-- 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
+
+ -- Ada 2005 (AI-231): Propagate the null_exclusion attribute to
+ -- the components of the array aggregate
+
+ if Ada_Version >= Ada_05 then
+ Set_Can_Never_Be_Null (Aggr_Typ, Can_Never_Be_Null (Typ));
+ end if;
+
if Is_Constrained (Typ) and then
(Pkind = N_Assignment_Statement or else
Pkind = N_Parameter_Association or else
end if;
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.
+
+ Set_Etype (Expr, Etype (N));
+
Resolution_OK := Resolve_Array_Aggregate
(Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed);
return Failure;
end if;
- if Ada_83
+ if Ada_Version = Ada_83
and then Assoc /= First (Component_Associations (N))
and then (Nkind (Parent (N)) = N_Assignment_Statement
or else
end if;
end loop;
- if not
- Resolve_Aggr_Expr
- (Expression (Assoc), Single_Elmt => Single_Choice)
+ -- Ada 2005 (AI-231)
+
+ Check_Can_Never_Be_Null (N, Expression (Assoc));
+
+ -- 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.
+
+ null;
+
+ elsif not Resolve_Aggr_Expr (Expression (Assoc),
+ Single_Elmt => Single_Choice)
then
return Failure;
end if;
while Present (Expr) loop
Nb_Elements := Nb_Elements + 1;
+ Check_Can_Never_Be_Null (N, Expr); -- Ada 2005 (AI-231)
+
if not Resolve_Aggr_Expr (Expr, Single_Elmt => True) then
return Failure;
end if;
if Others_Present then
Assoc := Last (Component_Associations (N));
- if not Resolve_Aggr_Expr (Expression (Assoc),
- Single_Elmt => False)
+
+ Check_Can_Never_Be_Null
+ (N, Expression (Assoc)); -- Ada 2005 (AI-231)
+
+ -- 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.
+
+ null;
+
+ elsif not Resolve_Aggr_Expr (Expression (Assoc),
+ Single_Elmt => False)
then
return Failure;
end if;
Error_Msg_N ("type of extension aggregate must be tagged", N);
return;
- elsif Is_Limited_Type (Typ)
- and not Extensions_Allowed
- then
- Error_Msg_N ("aggregate type cannot be limited", N);
- Explain_Limited_Type (Typ, N);
- return;
+ elsif Is_Limited_Type (Typ) then
+
+ -- Ada 2005 (AI-287): Limited aggregates are allowed
+
+ if Ada_Version < Ada_05 then
+ Error_Msg_N ("aggregate type cannot be limited", N);
+ Explain_Limited_Type (Typ, N);
+ return;
+ end if;
elsif Is_Class_Wide_Type (Typ) then
Error_Msg_N ("aggregate cannot be of a class-wide type", N);
Mbox_Present : Boolean := False;
Others_Mbox : Boolean := False;
- -- Variables used in case of default initialization to provide a
- -- functionality similar to Others_Etype. Mbox_Present indicates
- -- that the component takes its default initialization; Others_Mbox
- -- indicates that at least one component takes its default initiali-
- -- zation. Similar to Others_Etype, they are also updated as a side
- -- effect of function Get_Value.
+ -- Ada 2005 (AI-287): Variables used in case of default initialization
+ -- to provide a functionality similar to Others_Etype. Mbox_Present
+ -- indicates that the component takes its default initialization;
+ -- Others_Mbox indicates that at least one component takes its default
+ -- initialization. Similar to Others_Etype, they are also updated as a
+ -- side effect of function Get_Value.
procedure Add_Association
(Component : Entity_Id;
-- C : Lim := (..., others => <>);
-- end record;
+ ----------------------------
+ -- Check_Non_Limited_Type --
+ ----------------------------
+
procedure Check_Non_Limited_Type is
begin
if Is_Limited_Type (Etype (Compon))
and then Comes_From_Source (Compon)
and then not In_Instance_Body
then
+ -- Ada 2005 (AI-287): Limited aggregates are allowed
- if Extensions_Allowed
+ if Ada_Version >= Ada_05
and then Present (Expression (Assoc))
and then Nkind (Expression (Assoc)) = N_Aggregate
then
end if;
end Check_Non_Limited_Type;
+ -- Start of processing for Get_Value
+
begin
Mbox_Present := False;
-- indispensable otherwise, because each one must be
-- expanded individually to preserve side-effects.
+ -- Ada 2005 (AI-287): In case of default initialization
+ -- of components, we duplicate the corresponding default
+ -- expression (from the record type declaration).
+
if Box_Present (Assoc) then
Others_Mbox := True;
Mbox_Present := True;
else
return Expression (Parent (Compon));
end if;
- else
+ else
Check_Non_Limited_Type;
if Present (Others_Etype) and then
elsif Chars (Compon) = Chars (Selector_Name) then
if No (Expr) then
+ -- Ada 2005 (AI-231)
+
+ if Ada_Version >= Ada_05
+ and then Present (Expression (Assoc))
+ and then Nkind (Expression (Assoc)) = N_Null
+ and then Can_Never_Be_Null (Compon)
+ then
+ Error_Msg_N
+ ("(Ada 2005) NULL not allowed in null-excluding " &
+ "components", Expression (Assoc));
+ end if;
+
-- We need to duplicate the expression when several
-- components are grouped together with a "|" choice.
-- For instance "filed1 | filed2 => Expr"
+ -- Ada 2005 (AI-287)
+
if Box_Present (Assoc) then
Mbox_Present := True;
-- from the record type declaration
if Present (Next (Selector_Name)) then
- Expr := New_Copy_Tree
- (Expression (Parent (Compon)));
+ Expr :=
+ New_Copy_Tree (Expression (Parent (Compon)));
else
Expr := Expression (Parent (Compon));
end if;
- else
+ else
Check_Non_Limited_Type;
if Present (Next (Selector_Name)) then
while Present (Discrim) and then Present (Positional_Expr) loop
if Discr_Present (Discrim) then
Resolve_Aggr_Expr (Positional_Expr, Discrim);
+
+ -- Ada 2005 (AI-231)
+
+ if Ada_Version >= Ada_05
+ and then Nkind (Positional_Expr) = N_Null
+ and then Can_Never_Be_Null (Discrim)
+ then
+ Error_Msg_N
+ ("(Ada 2005) NULL not allowed in null-excluding " &
+ "components", Positional_Expr);
+ end if;
+
Next (Positional_Expr);
end if;
Component := Node (Component_Elmt);
Resolve_Aggr_Expr (Positional_Expr, Component);
+ -- Ada 2005 (AI-231)
+
+ if Ada_Version >= Ada_05
+ and then Nkind (Positional_Expr) = N_Null
+ and then Can_Never_Be_Null (Component)
+ then
+ Error_Msg_N
+ ("(Ada 2005) NULL not allowed in null-excluding components",
+ Positional_Expr);
+ end if;
+
if Present (Get_Value (Component, Component_Associations (N))) then
Error_Msg_NE
("more than one value supplied for Component &", N, Component);
Component := Node (Component_Elmt);
Expr := Get_Value (Component, Component_Associations (N), True);
- if Mbox_Present and then Is_Limited_Type (Etype (Component)) then
-
- -- In case of default initialization of a limited component we
- -- pass the limited component to the expander. The expander will
- -- generate calls to the corresponding initialization subprograms.
+ -- Ada 2005 (AI-287): Default initialized limited component are
+ -- passed to the expander, that will generate calls to the
+ -- corresponding IP.
+ if Mbox_Present and then Is_Limited_Type (Etype (Component)) then
Add_Association
(Component => Component,
Expr => Empty,
Box_Present => True);
+ -- Ada 2005 (AI-287): No value supplied for component
+
+ elsif Mbox_Present and No (Expr) then
+ null;
+
elsif No (Expr) then
Error_Msg_NE ("no value supplied for component &!", N, Component);
+
else
Resolve_Aggr_Expr (Expr, Component);
end if;
Typech := Empty;
if Nkind (Selectr) = N_Others_Choice then
+
+ -- Ada 2005 (AI-287): others choice may have expression or mbox
+
if No (Others_Etype)
and then not Others_Mbox
then
Typech := Base_Type (Etype (Component));
elsif Typech /= Base_Type (Etype (Component)) then
-
if not Box_Present (Parent (Selectr)) then
Error_Msg_N
("components in choice list must have same type",
Selectr);
end if;
-
end if;
Next (Selectr);
end Step_8;
end Resolve_Record_Aggregate;
+ -----------------------------
+ -- Check_Can_Never_Be_Null --
+ -----------------------------
+
+ procedure Check_Can_Never_Be_Null (N : Node_Id; Expr : Node_Id) is
+ begin
+ if Ada_Version >= Ada_05
+ and then Nkind (Expr) = N_Null
+ and then Can_Never_Be_Null (Etype (N))
+ then
+ Error_Msg_N
+ ("(Ada 2005) NULL not allowed in null-excluding components", Expr);
+ end if;
+ end Check_Can_Never_Be_Null;
+
---------------------
-- Sort_Case_Table --
---------------------
OSDN Git Service
