-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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 (Typ : Node_Id; Expr : Node_Id);
- -- Ada 2005 (AI-231): Check bad usage of the null-exclusion issue
+ procedure Check_Can_Never_Be_Null (Typ : Entity_Id; Expr : Node_Id);
+ -- Ada 2005 (AI-231): Check bad usage of null for a component for which
+ -- null exclusion (NOT NULL) is specified. Typ can be an E_Array_Type for
+ -- the array case (the component type of the array will be used) or an
+ -- 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
+ -- issued if the component is null excluding.
+ --
+ -- It would be better to pass the proper type for Typ ???
------------------------------------------------------
-- Subprograms used for RECORD AGGREGATE Processing --
-- N is the N_Aggregate node.
-- Typ is the record type for the aggregate resolution
--
- -- While performing the semantic checks, this procedure
- -- builds a new Component_Association_List where each record field
- -- appears alone in a Component_Choice_List along with its corresponding
- -- expression. The record fields in the Component_Association_List
- -- appear in the same order in which they appear in the record type Typ.
+ -- While performing the semantic checks, this procedure builds a new
+ -- Component_Association_List where each record field appears alone in a
+ -- Component_Choice_List along with its corresponding expression. The
+ -- record fields in the Component_Association_List appear in the same order
+ -- in which they appear in the record type Typ.
--
- -- Once this new Component_Association_List is built and all the
- -- semantic checks performed, the original aggregate subtree is replaced
- -- with the new named record aggregate just built. Note that the subtree
- -- substitution is performed with Rewrite so as to be
- -- able to retrieve the original aggregate.
+ -- Once this new Component_Association_List is built and all the semantic
+ -- checks performed, the original aggregate subtree is replaced with the
+ -- new named record aggregate just built. Note that subtree substitution is
+ -- performed with Rewrite so as to be able to retrieve the original
+ -- aggregate.
--
-- The aggregate subtree manipulation performed by Resolve_Record_Aggregate
-- yields the aggregate format expected by Gigi. Typically, this kind of
-- tree manipulations are done in the expander. However, because the
- -- semantic checks that need to be performed on record aggregates really
- -- go hand in hand with the record aggregate normalization, the aggregate
+ -- semantic checks that need to be performed on record aggregates really go
+ -- hand in hand with the record aggregate normalization, the aggregate
-- subtree transformation is performed during resolution rather than
- -- expansion. Had we decided otherwise we would have had to duplicate
- -- most of the code in the expansion procedure Expand_Record_Aggregate.
- -- Note, however, that all the expansion concerning aggegates for tagged
- -- records is done in Expand_Record_Aggregate.
+ -- expansion. Had we decided otherwise we would have had to duplicate most
+ -- of the code in the expansion procedure Expand_Record_Aggregate. Note,
+ -- however, that all the expansion concerning aggegates for tagged records
+ -- is done in Expand_Record_Aggregate.
--
-- The algorithm of Resolve_Record_Aggregate proceeds as follows:
--
elsif Expr_Value (This_Low) /= Expr_Value (Aggr_Low (Dim)) then
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);
+ Error_Msg_N
+ ("\Constraint_Error will be raised at run-time?", N);
end if;
end if;
then
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);
+ Error_Msg_N
+ ("\Constraint_Error will be raised at run-time?", N);
end if;
end if;
end if;
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.
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;
Next (Choice);
if No (Choice) then
+
-- Check if we have a single discrete choice and whether
-- this discrete choice specifies a single value.
-- Ada 2005 (AI-231)
if Ada_Version >= Ada_05
- and then Nkind (Expression (Assoc)) = N_Null
+ and then Nkind (Assoc) = N_Null
then
- Check_Can_Never_Be_Null
- (Etype (N), Expression (Assoc));
+ Check_Can_Never_Be_Null (Etype (N), Expression (Assoc));
end if;
-- Ada 2005 (AI-287): In case of default initialized component
-- 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
- -- analyzed when it is a literal bound whose type must be properly
- -- set.
+ -- analyzed when it is a literal bound whose type must be properly set.
if Others_Present or else Nb_Discrete_Choices > 0 then
Aggr_High := Duplicate_Subexpr (Aggr_High);
------------------------------
procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ Assoc : Node_Id;
+ -- N_Component_Association node belonging to the input aggregate N
+
+ Expr : Node_Id;
+ Positional_Expr : Node_Id;
+ Component : Entity_Id;
+ Component_Elmt : Elmt_Id;
+
+ Components : constant Elist_Id := New_Elmt_List;
+ -- Components is the list of the record components whose value must
+ -- be provided in the aggregate. This list does include discriminants.
+
New_Assoc_List : constant List_Id := New_List;
New_Assoc : Node_Id;
-- New_Assoc_List is the newly built list of N_Component_Association
--
-- This variable is updated as a side effect of function Get_Value
- Mbox_Present : Boolean := False;
- Others_Mbox : Boolean := False;
+ Is_Box_Present : Boolean := False;
+ Others_Box : Boolean := False;
-- Ada 2005 (AI-287): Variables used in case of default initialization
- -- to provide a functionality similar to Others_Etype. Mbox_Present
+ -- to provide a functionality similar to Others_Etype. Box_Present
-- indicates that the component takes its default initialization;
- -- Others_Mbox indicates that at least one component takes its default
+ -- Others_Box indicates that at least one component takes its default
-- initialization. Similar to Others_Etype, they are also updated as a
-- side effect of function Get_Value.
procedure Add_Association
- (Component : Entity_Id;
- Expr : Node_Id;
- Box_Present : Boolean := False);
+ (Component : Entity_Id;
+ Expr : Node_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.
---------------------
procedure Add_Association
- (Component : Entity_Id;
- Expr : Node_Id;
- Box_Present : Boolean := False)
+ (Component : Entity_Id;
+ Expr : Node_Id;
+ Is_Box_Present : Boolean := False)
is
Choice_List : constant List_Id := New_List;
New_Assoc : Node_Id;
Make_Component_Association (Sloc (Expr),
Choices => Choice_List,
Expression => Expr,
- Box_Present => Box_Present);
+ Box_Present => Is_Box_Present);
Append (New_Assoc, New_Assoc_List);
end Add_Association;
-- Start of processing for Get_Value
begin
- Mbox_Present := False;
+ Is_Box_Present := False;
if Present (From) then
Assoc := First (From);
-- expression (from the record type declaration).
if Box_Present (Assoc) then
- Others_Mbox := True;
- Mbox_Present := True;
+ Others_Box := True;
+ Is_Box_Present := True;
if Expander_Active then
return New_Copy_Tree (Expression (Parent (Compon)));
-- Ada 2005 (AI-287)
if Box_Present (Assoc) then
- Mbox_Present := True;
+ Is_Box_Present := True;
-- Duplicate the default expression of the component
-- from the record type declaration
end if;
end Resolve_Aggr_Expr;
- -- Resolve_Record_Aggregate local variables
-
- Assoc : Node_Id;
- -- N_Component_Association node belonging to the input aggregate N
-
- Expr : Node_Id;
- Positional_Expr : Node_Id;
- Component : Entity_Id;
- Component_Elmt : Elmt_Id;
-
- Components : constant Elist_Id := New_Elmt_List;
- -- Components is the list of the record components whose value must
- -- be provided in the aggregate. This list does include discriminants.
-
-- Start of processing for Resolve_Record_Aggregate
begin
Component := Node (Component_Elmt);
Expr := Get_Value (Component, Component_Associations (N), True);
- -- Ada 2005 (AI-287): Although the default initialization by means
- -- of the mbox was initially added to Ada 2005 for limited types, it
- -- is not constrained to limited types. Therefore if the component
- -- has some initialization procedure (IP) we pass the component to
- -- the expander, which will generate the call to such IP.
+ -- Note: The previous call to Get_Value sets the value of the
+ -- variable Is_Box_Present
- if Mbox_Present
- and then Has_Non_Null_Base_Init_Proc (Etype (Component))
- then
- Add_Association
- (Component => Component,
- Expr => Empty,
- Box_Present => True);
+ -- 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.
- -- Ada 2005 (AI-287): No value supplied for component
+ if Is_Box_Present then
+ declare
+ Is_Array_Subtype : constant Boolean :=
+ Ekind (Etype (Component)) =
+ E_Array_Subtype;
- elsif Mbox_Present and No (Expr) then
- null;
+ Ctyp : Entity_Id;
+
+ begin
+ if Is_Array_Subtype then
+ Ctyp := Component_Type (Base_Type (Etype (Component)));
+ else
+ Ctyp := Etype (Component);
+ end if;
+
+ -- If the component has an initialization procedure (IP) we
+ -- pass the component to the expander, which will generate
+ -- the call to such IP.
+
+ if Has_Non_Null_Base_Init_Proc (Ctyp) then
+ Add_Association
+ (Component => Component,
+ Expr => Empty,
+ Is_Box_Present => True);
+
+ -- Otherwise we only need to resolve the expression if the
+ -- component has partially initialized values (required to
+ -- 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)))
+ then
+ Resolve_Aggr_Expr (Expr, Component);
+ end if;
+ end;
elsif No (Expr) then
Error_Msg_NE ("no value supplied for component &!", N, Component);
Selectr : Node_Id;
-- Selector name
- Typech : Entity_Id;
+ Typech : Entity_Id;
-- Type of first component in choice list
begin
if Nkind (Selectr) = N_Others_Choice then
- -- Ada 2005 (AI-287): others choice may have expression or mbox
+ -- Ada 2005 (AI-287): others choice may have expression or box
if No (Others_Etype)
- and then not Others_Mbox
+ and then not Others_Box
then
Error_Msg_N
("OTHERS must represent at least one component", Selectr);
-- Check_Can_Never_Be_Null --
-----------------------------
- procedure Check_Can_Never_Be_Null (Typ : Node_Id; Expr : Node_Id) is
+ procedure Check_Can_Never_Be_Null (Typ : Entity_Id; Expr : Node_Id) is
Comp_Typ : Entity_Id;
begin
- pragma Assert (Ada_Version >= Ada_05
- and then Present (Expr)
- and then Nkind (Expr) = N_Null);
+ pragma Assert
+ (Ada_Version >= Ada_05
+ and then Present (Expr)
+ and then Nkind (Expr) = N_Null);
case Ekind (Typ) is
when E_Array_Type =>
return;
end case;
- if Present (Expr)
- and then Can_Never_Be_Null (Comp_Typ)
- then
- Error_Msg_N
- ("(Ada 2005) NULL not allowed in null-excluding components?", Expr);
- Error_Msg_NEL
- ("\& will be raised at run time!?",
- Expr, Standard_Constraint_Error, Sloc (Expr));
-
- Set_Etype (Expr, Comp_Typ);
- Set_Analyzed (Expr);
- Install_Null_Excluding_Check (Expr);
+ if Can_Never_Be_Null (Comp_Typ) then
+
+ -- Here we know we have a constraint error. Note that we do not use
+ -- Apply_Compile_Time_Constraint_Error here to the Expr, which might
+ -- seem the more natural approach. That's because in some cases the
+ -- components are rewritten, and the replacement would be missed.
+
+ Insert_Action
+ (Compile_Time_Constraint_Error
+ (Expr,
+ "(Ada 2005) NULL not allowed in null-excluding components?"),
+ Make_Raise_Constraint_Error (Sloc (Expr),
+ Reason => CE_Access_Check_Failed));
+
+ -- Set proper type for bogus component (why is this needed???)
+
+ Set_Etype (Expr, Comp_Typ);
+ Set_Analyzed (Expr);
end if;
end Check_Can_Never_Be_Null;
OSDN Git Service
