-- --
-- B o d y --
-- --
--- $Revision: 1.2 $
--- --
--- Copyright (C) 1992-2001, 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- --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
function Init_Expr_Opt (P : Boolean := False) return Node_Id is
begin
- if Token = Tok_Colon_Equal
+ -- For colon, assume it means := unless it is at the end of
+ -- a line, in which case guess that it means a semicolon.
+
+ if Token = Tok_Colon then
+ if Token_Is_At_End_Of_Line then
+ T_Semicolon;
+ return Empty;
+ end if;
+
+ -- Here if := or something that we will take as equivalent
+
+ elsif Token = Tok_Colon_Equal
or else Token = Tok_Equal
- or else Token = Tok_Colon
or else Token = Tok_Is
then
null;
- -- One other possibility. If we have a literal followed by a semicolon,
+ -- Another possibility. If we have a literal followed by a semicolon,
-- we assume that we have a missing colon-equal.
elsif Token in Token_Class_Literal then
-- Error recovery: can raise Error_Resync
- function P_Defining_Identifier return Node_Id is
+ function P_Defining_Identifier (C : Id_Check := None) return Node_Id is
Ident_Node : Node_Id;
begin
-- If we have a reserved identifier, manufacture an identifier with
-- a corresponding name after posting an appropriate error message
- elsif Is_Reserved_Identifier then
+ elsif Is_Reserved_Identifier (C) then
Scan_Reserved_Identifier (Force_Msg => True);
-- Otherwise we have junk that cannot be interpreted as an identifier
Type_Loc := Token_Ptr;
Type_Start_Col := Start_Column;
T_Type;
- Ident_Node := P_Defining_Identifier;
+ Ident_Node := P_Defining_Identifier (C_Is);
Discr_Sloc := Token_Ptr;
if P_Unknown_Discriminant_Part_Opt then
loop
case Token is
- when Tok_Access =>
+ when Tok_Access |
+ Tok_Not => -- Ada 2005 (AI-231)
Typedef_Node := P_Access_Type_Definition;
TF_Semicolon;
exit;
when Tok_Left_Paren =>
Typedef_Node := P_Enumeration_Type_Definition;
+
+ End_Labl :=
+ Make_Identifier (Token_Ptr,
+ Chars => Chars (Ident_Node));
+ Set_Comes_From_Source (End_Labl, False);
+
+ Set_End_Label (Typedef_Node, End_Labl);
TF_Semicolon;
exit;
when Tok_New =>
Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
+
+ if Nkind (Typedef_Node) = N_Derived_Type_Definition
+ and then Present (Record_Extension_Part (Typedef_Node))
+ then
+ End_Labl :=
+ Make_Identifier (Token_Ptr,
+ Chars => Chars (Ident_Node));
+ Set_Comes_From_Source (End_Labl, False);
+
+ Set_End_Label
+ (Record_Extension_Part (Typedef_Node), End_Labl);
+ end if;
+
TF_Semicolon;
exit;
Typedef_Node := P_Record_Definition;
Set_Tagged_Present (Typedef_Node, True);
Set_Limited_Present (Typedef_Node, True);
+
+ End_Labl :=
+ Make_Identifier (Token_Ptr,
+ Chars => Chars (Ident_Node));
+ Set_Comes_From_Source (End_Labl, False);
+
+ Set_End_Label (Typedef_Node, End_Labl);
end if;
else
else
Typedef_Node := P_Record_Definition;
Set_Tagged_Present (Typedef_Node, True);
+
+ End_Labl :=
+ Make_Identifier (Token_Ptr,
+ Chars => Chars (Ident_Node));
+ Set_Comes_From_Source (End_Labl, False);
+
+ Set_End_Label (Typedef_Node, End_Labl);
end if;
end if;
-- LIMITED RECORD or LIMITED NULL RECORD
if Token = Tok_Record or else Token = Tok_Null then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SP
("(Ada 83) limited record declaration not allowed!");
end if;
Set_Defining_Identifier (Decl_Node, Ident_Node);
Set_Discriminant_Specifications (Decl_Node, Discr_List);
return Decl_Node;
-
end P_Type_Declaration;
----------------------------------
--------------------------------
-- SUBTYPE_DECLARATION ::=
- -- subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION;
+ -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
-- The caller has checked that the initial token is SUBTYPE
-- Error recovery: can raise Error_Resync
function P_Subtype_Declaration return Node_Id is
- Decl_Node : Node_Id;
-
+ Decl_Node : Node_Id;
+ Not_Null_Present : Boolean := False;
begin
Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
Scan; -- past SUBTYPE
- Set_Defining_Identifier (Decl_Node, P_Defining_Identifier);
+ Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is));
TF_Is;
if Token = Tok_New then
Scan; -- past NEW
end if;
- Set_Subtype_Indication (Decl_Node, P_Subtype_Indication);
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
+ Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
+
+ Set_Subtype_Indication
+ (Decl_Node, P_Subtype_Indication (Not_Null_Present));
TF_Semicolon;
return Decl_Node;
end P_Subtype_Declaration;
-- 3.2.2 Subtype Indication --
-------------------------------
- -- SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT]
+ -- SUBTYPE_INDICATION ::=
+ -- [NOT NULL] SUBTYPE_MARK [CONSTRAINT]
-- Error recovery: can raise Error_Resync
- function P_Subtype_Indication return Node_Id is
- Type_Node : Node_Id;
+ function P_Null_Exclusion return Boolean is
+ begin
+ if Token /= Tok_Not then
+ return False;
+
+ else
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("null-excluding access is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Scan; -- past NOT
+
+ if Token = Tok_Null then
+ Scan; -- past NULL
+ else
+ Error_Msg_SP ("NULL expected");
+ end if;
+
+ return True;
+ end if;
+ end P_Null_Exclusion;
+
+ function P_Subtype_Indication
+ (Not_Null_Present : Boolean := False) return Node_Id is
+ Type_Node : Node_Id;
begin
if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
Type_Node := P_Subtype_Mark;
- return P_Subtype_Indication (Type_Node);
+ return P_Subtype_Indication (Type_Node, Not_Null_Present);
else
-- Check for error of using record definition and treat it nicely,
-- Error recovery: can raise Error_Resync
- function P_Subtype_Indication (Subtype_Mark : Node_Id) return Node_Id is
- Indic_Node : Node_Id;
- Constr_Node : Node_Id;
+ function P_Subtype_Indication
+ (Subtype_Mark : Node_Id;
+ Not_Null_Present : Boolean := False) return Node_Id is
+ Indic_Node : Node_Id;
+ Constr_Node : Node_Id;
begin
Constr_Node := P_Constraint_Opt;
if No (Constr_Node) then
return Subtype_Mark;
else
+ if Not_Null_Present then
+ Error_Msg_SP ("constrained null-exclusion not allowed");
+ end if;
+
Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark));
Set_Constraint (Indic_Node, Constr_Node);
return Indic_Node;
end if;
-
end P_Subtype_Indication;
-------------------------
else
return Empty;
end if;
-
end P_Constraint_Opt;
------------------------------
-- This routine scans out a declaration starting with an identifier:
-- OBJECT_DECLARATION ::=
- -- DEFINING_IDENTIFIER_LIST : [constant] [aliased]
- -- SUBTYPE_INDICATION [:= EXPRESSION];
- -- | DEFINING_IDENTIFIER_LIST : [constant] [aliased]
+ -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
+ -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
+ -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
-- NUMBER_DECLARATION ::=
-- OBJECT_RENAMING_DECLARATION ::=
-- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
+ -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
-- EXCEPTION_RENAMING_DECLARATION ::=
-- DEFINING_IDENTIFIER : exception renames exception_NAME;
Done : out Boolean;
In_Spec : Boolean)
is
- Decl_Node : Node_Id;
- Type_Node : Node_Id;
- Ident_Sloc : Source_Ptr;
- Scan_State : Saved_Scan_State;
- List_OK : Boolean := True;
- Ident : Nat;
- Init_Expr : Node_Id;
- Init_Loc : Source_Ptr;
- Con_Loc : Source_Ptr;
+ Acc_Node : Node_Id;
+ Decl_Node : Node_Id;
+ Type_Node : Node_Id;
+ Ident_Sloc : Source_Ptr;
+ Scan_State : Saved_Scan_State;
+ List_OK : Boolean := True;
+ Ident : Nat;
+ Init_Expr : Node_Id;
+ Init_Loc : Source_Ptr;
+ Con_Loc : Source_Ptr;
+ Not_Null_Present : Boolean := False;
Idents : array (Int range 1 .. 4096) of Entity_Id;
-- Used to save identifiers in the identifier list. The upper bound
begin
Ident_Sloc := Token_Ptr;
Save_Scan_State (Scan_State); -- at first identifier
- Idents (1) := P_Defining_Identifier;
+ Idents (1) := P_Defining_Identifier (C_Comma_Colon);
-- If we have a colon after the identifier, then we can assume that
-- this is in fact a valid identifier declaration and can steam ahead.
while Comma_Present loop
Num_Idents := Num_Idents + 1;
- Idents (Num_Idents) := P_Defining_Identifier;
+ Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop;
Save_Scan_State (Scan_State); -- at colon
Init_Expr := Init_Expr_Opt;
if Present (Init_Expr) then
+ if Not_Null_Present then
+ Error_Msg_SP ("null-exclusion not allowed in "
+ & "numeric expression");
+ end if;
+
Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc);
Set_Expression (Decl_Node, Init_Expr);
if Token = Tok_Array then
Set_Object_Definition
(Decl_Node, P_Array_Type_Definition);
+
else
- Set_Object_Definition (Decl_Node, P_Subtype_Indication);
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
+ Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
+
+ Set_Object_Definition (Decl_Node,
+ P_Subtype_Indication (Not_Null_Present));
end if;
if Token = Tok_Renames then
if Token = Tok_Array then
Set_Object_Definition
(Decl_Node, P_Array_Type_Definition);
+
else
- Set_Object_Definition (Decl_Node, P_Subtype_Indication);
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
+ Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
+ Set_Object_Definition (Decl_Node,
+ P_Subtype_Indication (Not_Null_Present));
end if;
-- Array case
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
+ -- Ada 2005 (AI-254)
+
+ elsif Token = Tok_Not then
+
+ -- OBJECT_DECLARATION ::=
+ -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
+ -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
+
+ -- OBJECT_RENAMING_DECLARATION ::=
+ -- ...
+ -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
+
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
+
+ if Token = Tok_Access then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("generalized use of anonymous access types " &
+ "is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Acc_Node := P_Access_Definition (Not_Null_Present);
+
+ if Token /= Tok_Renames then
+ Error_Msg_SC ("'RENAMES' expected");
+ raise Error_Resync;
+ end if;
+
+ Scan; -- past renames
+ No_List;
+ Decl_Node :=
+ New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
+ Set_Access_Definition (Decl_Node, Acc_Node);
+ Set_Name (Decl_Node, P_Name);
+
+ else
+ Type_Node := P_Subtype_Mark;
+
+ -- Object renaming declaration
+
+ if Token_Is_Renames then
+ Error_Msg_SP
+ ("null-exclusion not allowed in object renamings");
+ raise Error_Resync;
+
+ -- Object declaration
+
+ else
+ Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
+ Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
+ Set_Object_Definition
+ (Decl_Node,
+ P_Subtype_Indication (Type_Node, Not_Null_Present));
+
+ -- RENAMES at this point means that we had the combination
+ -- of a constraint on the Type_Node and renames, which is
+ -- illegal
+
+ if Token_Is_Renames then
+ Error_Msg_N ("constraint not allowed in object renaming "
+ & "declaration",
+ Constraint (Object_Definition (Decl_Node)));
+ raise Error_Resync;
+ end if;
+ end if;
+ end if;
+
+ -- Ada 2005 (AI-230): Access Definition case
+
+ elsif Token = Tok_Access then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("generalized use of anonymous access types " &
+ "is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
+
+ if Token /= Tok_Renames then
+ Error_Msg_SC ("'RENAMES' expected");
+ raise Error_Resync;
+ end if;
+
+ Scan; -- past renames
+ No_List;
+ Decl_Node :=
+ New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
+ Set_Access_Definition (Decl_Node, Acc_Node);
+ Set_Name (Decl_Node, P_Name);
+
-- Subtype indication case
else
else
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
+ Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Object_Definition
- (Decl_Node, P_Subtype_Indication (Type_Node));
+ (Decl_Node,
+ P_Subtype_Indication (Type_Node, Not_Null_Present));
-- RENAMES at this point means that we had the combination of
-- a constraint on the Type_Node and renames, which is illegal
end loop Ident_Loop;
Done := False;
-
end P_Identifier_Declarations;
-------------------------------
-------------------------------------------------------------------------
-- DERIVED_TYPE_DEFINITION ::=
- -- [abstract] new parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART]
+ -- [abstract] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
+ -- [RECORD_EXTENSION_PART]
-- PRIVATE_EXTENSION_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
-- Error recovery: can raise Error_Resync;
function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is
- Typedef_Node : Node_Id;
- Typedecl_Node : Node_Id;
-
+ Typedef_Node : Node_Id;
+ Typedecl_Node : Node_Id;
+ Not_Null_Present : Boolean := False;
begin
Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
T_New;
Scan;
end if;
- Set_Subtype_Indication (Typedef_Node, P_Subtype_Indication);
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
+ Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
+ Set_Subtype_Indication (Typedef_Node,
+ P_Subtype_Indication (Not_Null_Present));
-- Deal with record extension, note that we assume that a WITH is
-- missing in the case of "type X is new Y record ..." or in the
if Token = Tok_Char_Literal then
return P_Defining_Character_Literal;
else
- return P_Defining_Identifier;
+ return P_Defining_Identifier (C_Comma_Right_Paren);
end if;
end P_Enumeration_Literal_Specification;
Typedef_Node : Node_Id;
begin
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83): modular types not allowed");
end if;
Check_Simple_Expression_In_Ada_83 (Delta_Node);
if Token = Tok_Digits then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!");
end if;
-- DISCRETE_SUBTYPE_DEFINITION ::=
-- DISCRETE_SUBTYPE_INDICATION | RANGE
- -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION
+ -- COMPONENT_DEFINITION ::=
+ -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
-- The caller has checked that the initial token is ARRAY
-- Error recovery: can raise Error_Resync
function P_Array_Type_Definition return Node_Id is
- Array_Loc : Source_Ptr;
- Def_Node : Node_Id;
- Subs_List : List_Id;
- Scan_State : Saved_Scan_State;
+ Array_Loc : Source_Ptr;
+ CompDef_Node : Node_Id;
+ Def_Node : Node_Id;
+ Not_Null_Present : Boolean := False;
+ Subs_List : List_Id;
+ Scan_State : Saved_Scan_State;
+ Aliased_Present : Boolean := False;
begin
Array_Loc := Token_Ptr;
T_Right_Paren;
T_Of;
+ CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
+
+ if Token_Name = Name_Aliased then
+ Check_95_Keyword (Tok_Aliased, Tok_Identifier);
+ end if;
+
if Token = Tok_Aliased then
- Set_Aliased_Present (Def_Node, True);
+ Aliased_Present := True;
Scan; -- past ALIASED
end if;
- Set_Subtype_Indication (Def_Node, P_Subtype_Indication);
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
+
+ -- Ada 2005 (AI-230): Access Definition case
+
+ if Token = Tok_Access then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("generalized use of anonymous access types " &
+ "is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ if Aliased_Present then
+ Error_Msg_SP ("ALIASED not allowed here");
+ end if;
+
+ Set_Subtype_Indication (CompDef_Node, Empty);
+ Set_Aliased_Present (CompDef_Node, False);
+ Set_Access_Definition (CompDef_Node,
+ P_Access_Definition (Not_Null_Present));
+ else
+
+ Set_Access_Definition (CompDef_Node, Empty);
+ Set_Aliased_Present (CompDef_Node, Aliased_Present);
+ Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
+ Set_Subtype_Indication (CompDef_Node,
+ P_Subtype_Indication (Not_Null_Present));
+ end if;
+
+ Set_Component_Definition (Def_Node, CompDef_Node);
+
return Def_Node;
end P_Array_Type_Definition;
function P_Discrete_Subtype_Definition return Node_Id is
begin
-
-- The syntax of a discrete subtype definition is identical to that
-- of a discrete range, so we simply share the same parsing code.
Scan; -- past the left paren
if Token = Tok_Box then
-
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
end if;
-- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
-- DISCRIMINANT_SPECIFICATION ::=
- -- DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK
+ -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
-- [:= DEFAULT_EXPRESSION]
-- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
-- [:= DEFAULT_EXPRESSION]
Ident_Sloc : Source_Ptr;
Scan_State : Saved_Scan_State;
Num_Idents : Nat;
+ Not_Null_Present : Boolean;
Ident : Nat;
Idents : array (Int range 1 .. 4096) of Entity_Id;
Specification_Loop : loop
Ident_Sloc := Token_Ptr;
- Idents (1) := P_Defining_Identifier;
+ Idents (1) := P_Defining_Identifier (C_Comma_Colon);
Num_Idents := 1;
while Comma_Present loop
Num_Idents := Num_Idents + 1;
- Idents (Num_Idents) := P_Defining_Identifier;
+ Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop;
T_Colon;
Specification_Node :=
New_Node (N_Discriminant_Specification, Ident_Sloc);
Set_Defining_Identifier (Specification_Node, Idents (Ident));
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
if Token = Tok_Access then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC
("(Ada 83) access discriminant not allowed!");
end if;
Set_Discriminant_Type
- (Specification_Node, P_Access_Definition);
+ (Specification_Node,
+ P_Access_Definition (Not_Null_Present));
else
+
Set_Discriminant_Type
(Specification_Node, P_Subtype_Mark);
No_Constraint;
+ Set_Null_Exclusion_Present -- Ada 2005 (AI-231)
+ (Specification_Node, Not_Null_Present);
end if;
Set_Expression
T_Right_Paren;
return Result_Node;
-
end P_Index_Or_Discriminant_Constraint;
-------------------------------------
Names_List := New_List;
loop
- Append (P_Identifier, Names_List);
+ Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List);
exit when Token /= Tok_Vertical_Bar;
Scan; -- past |
end loop;
Set_Component_Items (Component_List_Node, Decls_List);
return Component_List_Node;
-
end P_Component_List;
-------------------------
-- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
-- [:= DEFAULT_EXPRESSION];
- -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION
+ -- COMPONENT_DEFINITION ::=
+ -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
-- Error recovery: cannot raise Error_Resync, if an error occurs,
-- the scan is positioned past the following semicolon.
-- items, do we need to add this capability sometime in the future ???
procedure P_Component_Items (Decls : List_Id) is
- Decl_Node : Node_Id;
- Scan_State : Saved_Scan_State;
- Num_Idents : Nat;
- Ident : Nat;
- Ident_Sloc : Source_Ptr;
+ Aliased_Present : Boolean := False;
+ CompDef_Node : Node_Id;
+ Decl_Node : Node_Id;
+ Scan_State : Saved_Scan_State;
+ Not_Null_Present : Boolean := False;
+ Num_Idents : Nat;
+ Ident : Nat;
+ Ident_Sloc : Source_Ptr;
Idents : array (Int range 1 .. 4096) of Entity_Id;
-- This array holds the list of defining identifiers. The upper bound
end if;
Ident_Sloc := Token_Ptr;
- Idents (1) := P_Defining_Identifier;
+ Idents (1) := P_Defining_Identifier (C_Comma_Colon);
Num_Idents := 1;
while Comma_Present loop
Num_Idents := Num_Idents + 1;
- Idents (Num_Idents) := P_Defining_Identifier;
+ Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop;
T_Colon;
Scan;
end if;
+ CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
+
if Token_Name = Name_Aliased then
Check_95_Keyword (Tok_Aliased, Tok_Identifier);
end if;
if Token = Tok_Aliased then
+ Aliased_Present := True;
Scan; -- past ALIASED
- Set_Aliased_Present (Decl_Node, True);
end if;
- if Token = Tok_Array then
- Error_Msg_SC ("anonymous arrays not allowed as components");
- raise Error_Resync;
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
+
+ -- Ada 2005 (AI-230): Access Definition case
+
+ if Token = Tok_Access then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("generalized use of anonymous access types " &
+ "is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ if Aliased_Present then
+ Error_Msg_SP ("ALIASED not allowed here");
+ end if;
+
+ Set_Subtype_Indication (CompDef_Node, Empty);
+ Set_Aliased_Present (CompDef_Node, False);
+ Set_Access_Definition (CompDef_Node,
+ P_Access_Definition (Not_Null_Present));
+ else
+
+ Set_Access_Definition (CompDef_Node, Empty);
+ Set_Aliased_Present (CompDef_Node, Aliased_Present);
+ Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
+
+ if Token = Tok_Array then
+ Error_Msg_SC
+ ("anonymous arrays not allowed as components");
+ raise Error_Resync;
+ end if;
+
+ Set_Subtype_Indication (CompDef_Node,
+ P_Subtype_Indication (Not_Null_Present));
end if;
- Set_Subtype_Indication (Decl_Node, P_Subtype_Indication);
- Set_Expression (Decl_Node, Init_Expr_Opt);
+ Set_Component_Definition (Decl_Node, CompDef_Node);
+ Set_Expression (Decl_Node, Init_Expr_Opt);
if Ident > 1 then
Set_Prev_Ids (Decl_Node, True);
end loop Ident_Loop;
TF_Semicolon;
-
end P_Component_Items;
--------------------------------
Variant_Part_Node : Node_Id;
Variants_List : List_Id;
Case_Node : Node_Id;
- Case_Sloc : Source_Ptr;
begin
Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr);
Scan; -- past CASE
Case_Node := P_Expression;
- Case_Sloc := Token_Ptr;
Set_Name (Variant_Part_Node, Case_Node);
if Nkind (Case_Node) /= N_Identifier then
Set_Variants (Variant_Part_Node, Variants_List);
return Variant_Part_Node;
-
end P_Variant_Part;
--------------------
end if;
if Token = Tok_Comma then
- Error_Msg_SC (""","" should be ""|""");
+ Error_Msg_SC (""","" should be ""'|""");
else
exit when Token /= Tok_Vertical_Bar;
end if;
-- | ACCESS_TO_SUBPROGRAM_DEFINITION
-- ACCESS_TO_OBJECT_DEFINITION ::=
- -- access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
+ -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
-- GENERAL_ACCESS_MODIFIER ::= all | constant
-- ACCESS_TO_SUBPROGRAM_DEFINITION
- -- access [protected] procedure PARAMETER_PROFILE
- -- | access [protected] function PARAMETER_AND_RESULT_PROFILE
+ -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
+ -- | [NULL_EXCLUSION] access [protected] function
+ -- PARAMETER_AND_RESULT_PROFILE
-- PARAMETER_PROFILE ::= [FORMAL_PART]
-- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
- -- The caller has checked that the initial token is ACCESS
+ -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
+ -- parsed the null_exclusion part and has also removed the ACCESS token;
+ -- otherwise the caller has just checked that the initial token is ACCESS
-- Error recovery: can raise Error_Resync
- function P_Access_Type_Definition return Node_Id is
- Prot_Flag : Boolean;
- Access_Loc : Source_Ptr;
- Type_Def_Node : Node_Id;
+ function P_Access_Type_Definition
+ (Header_Already_Parsed : Boolean := False) return Node_Id is
+ Access_Loc : constant Source_Ptr := Token_Ptr;
+ Prot_Flag : Boolean;
+ Not_Null_Present : Boolean := False;
+ Type_Def_Node : Node_Id;
procedure Check_Junk_Subprogram_Name;
-- Used in access to subprogram definition cases to check for an
-- Start of processing for P_Access_Type_Definition
begin
- Access_Loc := Token_Ptr;
- Scan; -- past ACCESS
+ if not Header_Already_Parsed then
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
+ Scan; -- past ACCESS
+ end if;
if Token_Name = Name_Protected then
Check_95_Keyword (Tok_Protected, Tok_Procedure);
if Prot_Flag then
Scan; -- past PROTECTED
+
if Token /= Tok_Procedure and then Token /= Tok_Function then
Error_Msg_SC ("FUNCTION or PROCEDURE expected");
end if;
end if;
if Token = Tok_Procedure then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) access to procedure not allowed!");
end if;
Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc);
+ Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
Scan; -- past PROCEDURE
Check_Junk_Subprogram_Name;
Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
Set_Protected_Present (Type_Def_Node, Prot_Flag);
elsif Token = Tok_Function then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) access to function not allowed!");
end if;
Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc);
+ Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
Scan; -- past FUNCTION
Check_Junk_Subprogram_Name;
Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
else
Type_Def_Node :=
New_Node (N_Access_To_Object_Definition, Access_Loc);
+ Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
if Token = Tok_All or else Token = Tok_Constant then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) access modifier not allowed!");
end if;
Scan; -- past ALL or CONSTANT
end if;
- Set_Subtype_Indication (Type_Def_Node, P_Subtype_Indication);
+ Set_Subtype_Indication (Type_Def_Node,
+ P_Subtype_Indication (Not_Null_Present));
end if;
return Type_Def_Node;
-- 3.10 Access Definition --
-----------------------------
- -- ACCESS_DEFINITION ::= access SUBTYPE_MARK
+ -- ACCESS_DEFINITION ::=
+ -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
+ -- | ACCESS_TO_SUBPROGRAM_DEFINITION
+ --
+ -- ACCESS_TO_SUBPROGRAM_DEFINITION
+ -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
+ -- | [NULL_EXCLUSION] access [protected] function
+ -- PARAMETER_AND_RESULT_PROFILE
- -- The caller has checked that the initial token is ACCESS
+ -- The caller has parsed the null-exclusion part and it has also checked
+ -- that the next token is ACCESS
-- Error recovery: cannot raise Error_Resync
- function P_Access_Definition return Node_Id is
- Def_Node : Node_Id;
+ function P_Access_Definition
+ (Null_Exclusion_Present : Boolean) return Node_Id is
+ Def_Node : Node_Id;
+ Subp_Node : Node_Id;
begin
Def_Node := New_Node (N_Access_Definition, Token_Ptr);
Scan; -- past ACCESS
- Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
- No_Constraint;
+
+ -- Ada 2005 (AI-254/AI-231)
+
+ if Ada_Version >= Ada_05 then
+
+ -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
+
+ if Token = Tok_Protected
+ or else Token = Tok_Procedure
+ or else Token = Tok_Function
+ then
+ Subp_Node :=
+ P_Access_Type_Definition (Header_Already_Parsed => True);
+ Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present);
+ Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node);
+
+ -- Ada 2005 (AI-231)
+ -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
+
+ else
+ Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present);
+
+ if Token = Tok_All then
+ Scan; -- past ALL
+ Set_All_Present (Def_Node);
+
+ elsif Token = Tok_Constant then
+ Scan; -- past CONSTANT
+ Set_Constant_Present (Def_Node);
+ end if;
+
+ Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
+ No_Constraint;
+ end if;
+
+ -- Ada 95
+
+ else
+ -- Ada 2005 (AI-254): The null-exclusion present is never present
+ -- in Ada 83 and Ada 95
+
+ pragma Assert (Null_Exclusion_Present = False);
+
+ Set_Null_Exclusion_Present (Def_Node, False);
+ Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
+ No_Constraint;
+ end if;
+
return Def_Node;
end P_Access_Definition;
when Error_Resync =>
Resync_Past_Semicolon;
Done := False;
-
end P_Declarative_Items;
----------------------------------
Done : Boolean;
begin
+ -- Indicate no bad declarations detected yet in the current context:
+ -- visible or private declarations of a package spec.
+
+ Missing_Begin_Msg := No_Error_Msg;
+
-- Get rid of active SIS entry from outer scope. This means we will
-- miss some nested cases, but it doesn't seem worth the effort. See
-- discussion in Par for further details
-- hit the missing BEGIN, which will clean up the error message.
Done := False;
-
end Statement_When_Declaration_Expected;
end Ch3;
OSDN Git Service
