-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, 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. --
pragma Style_Checks (All_Checks);
-- Turn off subprogram body ordering check. Subprograms are in order
--- by RM section rather than alphabetical
+-- by RM section rather than alphabetical.
with Sinfo.CN; use Sinfo.CN;
separate (Par)
+---------
+-- Ch3 --
+---------
+
package body Ch3 is
-----------------------
function P_Variant return Node_Id;
function P_Variant_Part return Node_Id;
+ procedure Check_Restricted_Expression (N : Node_Id);
+ -- Check that the expression N meets the Restricted_Expression syntax.
+ -- The syntax is as follows:
+ --
+ -- RESTRICTED_EXPRESSION ::=
+ -- RESTRICTED_RELATION {and RESTRICTED_RELATION}
+ -- | RESTRICTED_RELATION {and then RESTRICTED_RELATION}
+ -- | RESTRICTED_RELATION {or RESTRICTED_RELATION}
+ -- | RESTRICTED_RELATION {or else RESTRICTED_RELATION}
+ -- | RESTRICTED_RELATION {xor RESTRICTED_RELATION}
+ --
+ -- RESTRICTED_RELATION ::=
+ -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
+ --
+ -- This syntax is used for choices when extensions (and set notations)
+ -- are enabled, to remove the ambiguity of "when X in A | B". We consider
+ -- it very unlikely that this will ever arise in practice.
+
procedure P_Declarative_Items
(Decls : List_Id;
Done : out Boolean;
In_Spec : Boolean);
-- Scans out a single declarative item, or, in the case of a declaration
- -- with a list of identifiers, a list of declarations, one for each of
- -- the identifiers in the list. The declaration or declarations scanned
- -- are appended to the given list. Done indicates whether or not there
- -- may be additional declarative items to scan. If Done is True, then
- -- a decision has been made that there are no more items to scan. If
- -- Done is False, then there may be additional declarations to scan.
- -- In_Spec is true if we are scanning a package declaration, and is used
- -- to generate an appropriate message if a statement is encountered in
- -- such a context.
+ -- with a list of identifiers, a list of declarations, one for each of the
+ -- identifiers in the list. The declaration or declarations scanned are
+ -- appended to the given list. Done indicates whether or not there may be
+ -- additional declarative items to scan. If Done is True, then a decision
+ -- has been made that there are no more items to scan. If Done is False,
+ -- then there may be additional declarations to scan. In_Spec is true if
+ -- we are scanning a package declaration, and is used to generate an
+ -- appropriate message if a statement is encountered in such a context.
procedure P_Identifier_Declarations
(Decls : List_Id;
-- current token, and if this is the first such message issued, saves
-- the message id in Missing_Begin_Msg, for possible later replacement.
+
+ ---------------------------------
+ -- Check_Restricted_Expression --
+ ---------------------------------
+
+ procedure Check_Restricted_Expression (N : Node_Id) is
+ begin
+ if Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor, N_And_Then, N_Or_Else) then
+ Check_Restricted_Expression (Left_Opnd (N));
+ Check_Restricted_Expression (Right_Opnd (N));
+
+ elsif Nkind_In (N, N_In, N_Not_In)
+ and then Paren_Count (N) = 0
+ then
+ Error_Msg_N
+ ("|this expression must be parenthesized!", N);
+ Error_Msg_N
+ ("\|since extensions (and set notation) are allowed", N);
+ end if;
+ end Check_Restricted_Expression;
+
-------------------
-- Init_Expr_Opt --
-------------------
-- separate declaration (but not use) of a reserved identifier.
if Token = Tok_Identifier then
- null;
+
+ -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
+ -- OVERRIDING, and SYNCHRONIZED are new reserved words. Note that
+ -- in the case where these keywords are misused in Ada 95 mode,
+ -- this routine will generally not be called at all.
+
+ if Ada_Version = Ada_95
+ and then Warn_On_Ada_2005_Compatibility
+ then
+ if Token_Name = Name_Overriding
+ or else Token_Name = Name_Synchronized
+ or else (Token_Name = Name_Interface
+ and then Prev_Token /= Tok_Pragma)
+ then
+ Error_Msg_N ("& is a reserved word in Ada 2005?", Token_Node);
+ end if;
+ end if;
-- If we have a reserved identifier, manufacture an identifier with
-- a corresponding name after posting an appropriate error message
Ident_Node := Token_Node;
Scan; -- past the reserved identifier
+ -- If we already have a defining identifier, clean it out and make
+ -- a new clean identifier. This situation arises in some error cases
+ -- and we need to fix it.
+
+ if Nkind (Ident_Node) = N_Defining_Identifier then
+ Ident_Node :=
+ Make_Identifier (Sloc (Ident_Node),
+ Chars => Chars (Ident_Node));
+ end if;
+
+ -- Change identifier to defining identifier if not in error
+
if Ident_Node /= Error then
Change_Identifier_To_Defining_Identifier (Ident_Node);
end if;
-- | CONCURRENT_TYPE_DECLARATION
-- INCOMPLETE_TYPE_DECLARATION ::=
- -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART];
+ -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged];
-- PRIVATE_TYPE_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
-- PRIVATE_EXTENSION_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
- -- [abstract] new ancestor_SUBTYPE_INDICATION with private;
+ -- [abstract] [limited | synchronized]
+ -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
+ -- with private;
-- TYPE_DEFINITION ::=
-- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
-- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
-- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
- -- | DERIVED_TYPE_DEFINITION
+ -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
-- INTEGER_TYPE_DEFINITION ::=
-- SIGNED_INTEGER_TYPE_DEFINITION
-- MODULAR_TYPE_DEFINITION
+ -- INTERFACE_TYPE_DEFINITION ::=
+ -- [limited | task | protected | synchronized ] interface
+ -- [and INTERFACE_LIST]
+
-- Error recovery: can raise Error_Resync
-- Note: The processing for full type declaration, incomplete type
-- function handles only declarations starting with TYPE).
function P_Type_Declaration return Node_Id is
- Type_Loc : Source_Ptr;
- Type_Start_Col : Column_Number;
- Ident_Node : Node_Id;
+ Abstract_Present : Boolean := False;
+ Abstract_Loc : Source_Ptr := No_Location;
Decl_Node : Node_Id;
Discr_List : List_Id;
- Unknown_Dis : Boolean;
Discr_Sloc : Source_Ptr;
- Abstract_Present : Boolean;
- Abstract_Loc : Source_Ptr;
End_Labl : Node_Id;
+ Ident_Node : Node_Id;
+ Is_Derived_Iface : Boolean := False;
+ Type_Loc : Source_Ptr;
+ Type_Start_Col : Column_Number;
+ Unknown_Dis : Boolean;
- Typedef_Node : Node_Id;
+ Typedef_Node : Node_Id;
-- Normally holds type definition, except in the case of a private
-- extension declaration, in which case it holds the declaration itself
begin
Type_Loc := Token_Ptr;
Type_Start_Col := Start_Column;
- T_Type;
- Ident_Node := P_Defining_Identifier (C_Is);
+
+ -- If we have TYPE, then proceed ahead and scan identifier
+
+ if Token = Tok_Type then
+ Type_Token_Location := Type_Loc;
+ Scan; -- past TYPE
+ Ident_Node := P_Defining_Identifier (C_Is);
+
+ -- Otherwise this is an error case
+
+ else
+ T_Type;
+ Type_Token_Location := Type_Loc;
+ Ident_Node := P_Defining_Identifier (C_Is);
+ end if;
+
Discr_Sloc := Token_Ptr;
if P_Unknown_Discriminant_Part_Opt then
Abstract_Loc := Token_Ptr;
Scan; -- past ABSTRACT
- if Token = Tok_Limited
+ -- Ada 2005 (AI-419): AARM 3.4 (2/2)
+
+ if (Ada_Version < Ada_05 and then Token = Tok_Limited)
or else Token = Tok_Private
or else Token = Tok_Record
or else Token = Tok_Null
then
Error_Msg_AP ("TAGGED expected");
end if;
-
- else
- Abstract_Present := False;
- Abstract_Loc := No_Location;
end if;
-- Check for misuse of Ada 95 keyword Tagged
Scan; -- past ALIASED
end if;
- -- The following procesing deals with either a private type declaration
+ -- The following processing deals with either a private type declaration
-- or a full type declaration. In the private type case, we build the
-- N_Private_Type_Declaration node, setting its Tagged_Present and
-- Limited_Present flags, on encountering the Private keyword, and
case Token is
when Tok_Access |
- Tok_Not => -- Ada 0Y (AI-231)
+ Tok_Not => -- Ada 2005 (AI-231)
Typedef_Node := P_Access_Type_Definition;
TF_Semicolon;
exit;
when Tok_Tagged =>
Scan; -- past TAGGED
+ -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
+ -- is a tagged incomplete type.
+
+ if Ada_Version >= Ada_05
+ and then Token = Tok_Semicolon
+ then
+ Scan; -- past ;
+
+ Decl_Node :=
+ New_Node (N_Incomplete_Type_Declaration, Type_Loc);
+ Set_Defining_Identifier (Decl_Node, Ident_Node);
+ Set_Tagged_Present (Decl_Node);
+ Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
+ Set_Discriminant_Specifications (Decl_Node, Discr_List);
+
+ return Decl_Node;
+ end if;
+
if Token = Tok_Abstract then
- Error_Msg_SC ("ABSTRACT must come before TAGGED");
+ Error_Msg_SC -- CODEFIX
+ ("ABSTRACT must come before TAGGED");
Abstract_Present := True;
Abstract_Loc := Token_Ptr;
Scan; -- past ABSTRACT
TF_Semicolon;
exit;
- when Tok_Private =>
- Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
- Scan; -- past PRIVATE
- TF_Semicolon;
- exit;
-
when Tok_Limited =>
Scan; -- past LIMITED
loop
if Token = Tok_Tagged then
- Error_Msg_SC ("TAGGED must come before LIMITED");
+ Error_Msg_SC -- CODEFIX
+ ("TAGGED must come before LIMITED");
Scan; -- past TAGGED
elsif Token = Tok_Abstract then
- Error_Msg_SC ("ABSTRACT must come before LIMITED");
+ Error_Msg_SC -- CODEFIX
+ ("ABSTRACT must come before LIMITED");
Scan; -- past ABSTRACT
else
-- 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!");
+
+ -- In Ada2005, "abstract limited" can appear before "new",
+ -- but it cannot be part of an untagged record declaration.
+
+ elsif Abstract_Present
+ and then Prev_Token /= Tok_Tagged
+ then
+ Error_Msg_SP ("TAGGED expected");
end if;
Typedef_Node := P_Record_Definition;
Set_Limited_Present (Typedef_Node, True);
+ -- Ada 2005 (AI-251): LIMITED INTERFACE
+
+ -- If we are compiling in Ada 83 or Ada 95 mode, "interface"
+ -- is not a reserved word but we force its analysis to
+ -- generate the corresponding usage error.
+
+ elsif Token = Tok_Interface
+ or else (Token = Tok_Identifier
+ and then Chars (Token_Node) = Name_Interface)
+ then
+ Typedef_Node :=
+ P_Interface_Type_Definition (Abstract_Present);
+ Abstract_Present := True;
+ Set_Limited_Present (Typedef_Node);
+
+ if Nkind (Typedef_Node) = N_Derived_Type_Definition then
+ Is_Derived_Iface := True;
+ end if;
+
+ -- Ada 2005 (AI-419): LIMITED NEW
+
+ elsif Token = Tok_New then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("LIMITED in derived type is an Ada 2005 extension");
+ Error_Msg_SP
+ ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
+ Set_Limited_Present (Typedef_Node);
+
+ 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;
+
-- LIMITED PRIVATE is the only remaining possibility here
else
exit;
+ -- Ada 2005 (AI-251): INTERFACE
+
+ when Tok_Interface =>
+ Typedef_Node := P_Interface_Type_Definition (Abstract_Present);
+ Abstract_Present := True;
+ TF_Semicolon;
+ exit;
+
+ when Tok_Private =>
+ Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
+ Scan; -- past PRIVATE
+ TF_Semicolon;
+ exit;
+
+ -- Ada 2005 (AI-345): Protected, synchronized or task interface
+ -- or Ada 2005 (AI-443): Synchronized private extension.
+
+ when Tok_Protected |
+ Tok_Synchronized |
+ Tok_Task =>
+
+ declare
+ Saved_Token : constant Token_Type := Token;
+
+ begin
+ Scan; -- past TASK, PROTECTED or SYNCHRONIZED
+
+ -- Synchronized private extension
+
+ if Token = Tok_New then
+ Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
+
+ if Saved_Token = Tok_Synchronized then
+ if Nkind (Typedef_Node) =
+ N_Derived_Type_Definition
+ then
+ Error_Msg_N
+ ("SYNCHRONIZED not allowed for record extension",
+ Typedef_Node);
+ else
+ Set_Synchronized_Present (Typedef_Node);
+ end if;
+
+ else
+ Error_Msg_SC ("invalid kind of private extension");
+ end if;
+
+ -- Interface
+
+ else
+ if Token /= Tok_Interface then
+ Error_Msg_SC ("NEW or INTERFACE expected");
+ end if;
+
+ Typedef_Node :=
+ P_Interface_Type_Definition (Abstract_Present);
+ Abstract_Present := True;
+
+ case Saved_Token is
+ when Tok_Task =>
+ Set_Task_Present (Typedef_Node);
+
+ when Tok_Protected =>
+ Set_Protected_Present (Typedef_Node);
+
+ when Tok_Synchronized =>
+ Set_Synchronized_Present (Typedef_Node);
+
+ when others =>
+ pragma Assert (False);
+ null;
+ end case;
+ end if;
+ end;
+
+ TF_Semicolon;
+ exit;
+
-- Anything else is an error
when others =>
if Nkind (Typedef_Node) = N_Record_Definition
or else (Nkind (Typedef_Node) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Typedef_Node)))
+ or else Is_Derived_Iface
then
Set_Abstract_Present (Typedef_Node, Abstract_Present);
--------------------------------
-- 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
function P_Subtype_Declaration return Node_Id is
Decl_Node : Node_Id;
Not_Null_Present : Boolean := False;
+
begin
Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
Scan; -- past SUBTYPE
Scan; -- past NEW
end if;
- if Extensions_Allowed then -- Ada 0Y (AI-231)
- Not_Null_Present := P_Null_Exclusion;
- Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
- end if;
+ 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));
-------------------------------
-- SUBTYPE_INDICATION ::=
- -- [NOT NULL] SUBTYPE_MARK [CONSTRAINT]
+ -- [not null] SUBTYPE_MARK [CONSTRAINT]
-- Error recovery: can raise Error_Resync
- function P_Null_Exclusion return Boolean is
+ function P_Null_Exclusion
+ (Allow_Anonymous_In_95 : Boolean := False) return Boolean
+ is
+ Not_Loc : constant Source_Ptr := Token_Ptr;
+ -- Source position of "not", if present
+
begin
if Token /= Tok_Not then
return False;
else
- if not Extensions_Allowed then
- Error_Msg_SP
- ("null-excluding access is an Ada 0Y extension");
- Error_Msg_SP ("\unit must be compiled with -gnatX switch");
- end if;
-
Scan; -- past NOT
if Token = Tok_Null then
Scan; -- past NULL
+
+ -- Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95,
+ -- except in the case of anonymous access types.
+
+ -- Allow_Anonymous_In_95 will be True if we're parsing a formal
+ -- parameter or discriminant, which are the only places where
+ -- anonymous access types occur in Ada 95. "Formal : not null
+ -- access ..." is legal in Ada 95, whereas "Formal : not null
+ -- Named_Access_Type" is not.
+
+ if Ada_Version >= Ada_05
+ or else (Ada_Version >= Ada_95
+ and then Allow_Anonymous_In_95
+ and then Token = Tok_Access)
+ then
+ null; -- OK
+
+ else
+ Error_Msg
+ ("`NOT NULL` access type is an Ada 2005 extension", Not_Loc);
+ Error_Msg
+ ("\unit should be compiled with -gnat05 switch", Not_Loc);
+ end if;
+
else
- Error_Msg_SP ("(Ada 0Y) missing NULL");
+ Error_Msg_SP ("NULL expected");
+ end if;
+
+ if Token = Tok_New then
+ Error_Msg ("`NOT NULL` comes after NEW, not before", Not_Loc);
end if;
return True;
end P_Null_Exclusion;
function P_Subtype_Indication
- (Not_Null_Present : Boolean := False) return Node_Id is
- Type_Node : Node_Id;
+ (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
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;
+ Not_Null_Present : Boolean := False) return Node_Id
+ is
+ Indic_Node : Node_Id;
+ Constr_Node : Node_Id;
begin
Constr_Node := P_Constraint_Opt;
return Subtype_Mark;
else
if Not_Null_Present then
- Error_Msg_SP ("(Ada 0Y) constrained null-exclusion not allowed");
+ Error_Msg_SP ("`NOT NULL` not allowed if constraint given");
end if;
Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
function P_Subtype_Mark return Node_Id is
begin
return P_Subtype_Mark_Resync;
-
exception
when Error_Resync =>
return Error;
Make_Attribute_Reference (Prev_Token_Ptr,
Prefix => Prefix,
Attribute_Name => Token_Name);
- Delete_Node (Token_Node);
Scan; -- past type attribute identifier
end if;
-- 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]
+ -- ACCESS_DEFINITION [:= EXPRESSION];
+ -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
-- NUMBER_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
-- OBJECT_RENAMING_DECLARATION ::=
- -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
- -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
+ -- DEFINING_IDENTIFIER :
+ -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
+ -- | DEFINING_IDENTIFIER :
+ -- ACCESS_DEFINITION renames object_NAME;
-- EXCEPTION_RENAMING_DECLARATION ::=
-- DEFINING_IDENTIFIER : exception renames exception_NAME;
-- returns True, otherwise returns False. Includes checking for some
-- common error cases.
+ -------------
+ -- No_List --
+ -------------
+
procedure No_List is
begin
if Num_Idents > 1 then
List_OK := False;
end No_List;
+ ----------------------
+ -- Token_Is_Renames --
+ ----------------------
+
function Token_Is_Renames return Boolean is
At_Colon : Saved_Scan_State;
Check_Misspelling_Of (Tok_Renames);
if Token = Tok_Renames then
- Error_Msg_SP ("extra "":"" ignored");
+ Error_Msg_SP ("|extra "":"" ignored");
Scan; -- past RENAMES
return True;
else
-- If we have a comma, then scan out the list of identifiers
elsif Token = Tok_Comma then
-
while Comma_Present loop
Num_Idents := Num_Idents + 1;
Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
if Present (Init_Expr) then
if Not_Null_Present then
- Error_Msg_SP ("(Ada 0Y) null-exclusion not allowed in "
- & "numeric expression");
+ Error_Msg_SP
+ ("`NOT NULL` not allowed in numeric expression");
end if;
Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc);
else
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
- Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
Set_Constant_Present (Decl_Node, True);
if Token_Name = Name_Aliased then
end if;
if Token = Tok_Aliased then
- Error_Msg_SC ("ALIASED should be before CONSTANT");
+ Error_Msg_SC -- CODEFIX
+ ("ALIASED should be before CONSTANT");
Scan; -- past ALIASED
Set_Aliased_Present (Decl_Node, True);
end if;
(Decl_Node, P_Array_Type_Definition);
else
- if Extensions_Allowed then -- Ada 0Y (AI-231)
- Not_Null_Present := P_Null_Exclusion;
- Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
- end if;
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
+ Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
+
+ 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;
- Set_Object_Definition (Decl_Node,
- P_Subtype_Indication (Not_Null_Present));
+ Set_Object_Definition
+ (Decl_Node, P_Access_Definition (Not_Null_Present));
+ else
+ Set_Object_Definition
+ (Decl_Node, P_Subtype_Indication (Not_Null_Present));
+ end if;
end if;
if Token = Tok_Renames then
Scan; -- past ALIASED
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Aliased_Present (Decl_Node, True);
- Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
if Token = Tok_Constant then
Scan; -- past CONSTANT
(Decl_Node, P_Array_Type_Definition);
else
- if Extensions_Allowed then -- Ada 0Y (AI-231)
- Not_Null_Present := P_Null_Exclusion;
- Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
- end if;
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
+ Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
+
+ -- Access definition (AI-406) or subtype indication
- Set_Object_Definition (Decl_Node,
- P_Subtype_Indication (Not_Null_Present));
+ 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;
+
+ Set_Object_Definition
+ (Decl_Node, P_Access_Definition (Not_Null_Present));
+ else
+ Set_Object_Definition
+ (Decl_Node, P_Subtype_Indication (Not_Null_Present));
+ end if;
end if;
-- Array case
Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
- -- Ada 0Y (AI-230): Access Definition case
+ -- Ada 2005 (AI-254, AI-406)
+
+ elsif Token = Tok_Not then
+
+ -- OBJECT_DECLARATION ::=
+ -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
+ -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
+ -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
+ -- ACCESS_DEFINITION [:= EXPRESSION];
+
+ -- OBJECT_RENAMING_DECLARATION ::=
+ -- DEFINING_IDENTIFIER :
+ -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
+ -- | DEFINING_IDENTIFIER :
+ -- ACCESS_DEFINITION renames object_NAME;
+
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423)
+
+ 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
+ Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
+ Set_Object_Definition (Decl_Node, Acc_Node);
+
+ else
+ 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);
+ end if;
+
+ else
+ Type_Node := P_Subtype_Mark;
+
+ -- Object renaming declaration
+
+ if Token_Is_Renames then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("`NOT NULL` not allowed in object renaming");
+ raise Error_Resync;
+
+ -- Ada 2005 (AI-423): Object renaming declaration with
+ -- a null exclusion.
+
+ else
+ No_List;
+ Decl_Node :=
+ New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
+ Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
+ Set_Subtype_Mark (Decl_Node, Type_Node);
+ Set_Name (Decl_Node, P_Name);
+ end if;
+
+ -- 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 not Extensions_Allowed then
+ if Ada_Version < Ada_05 then
Error_Msg_SP
("generalized use of anonymous access types " &
- "is an Ada 0Y extension");
- Error_Msg_SP ("\unit must be compiled with -gnatX switch");
+ "is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
- Acc_Node := P_Access_Definition;
+ Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
+
+ -- Object declaration with access definition, or renaming
if Token /= Tok_Renames then
- Error_Msg_SC ("'RENAMES' expected");
- raise Error_Resync;
- end if;
+ Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
+ Set_Object_Definition (Decl_Node, Acc_Node);
- 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
+ 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);
+ end if;
-- Subtype indication case
else
- if Extensions_Allowed then -- Ada 0Y (AI-231)
- Not_Null_Present := P_Null_Exclusion;
- end if;
-
Type_Node := P_Subtype_Mark;
-- Object renaming declaration
if Token_Is_Renames then
- if Not_Null_Present then
- Error_Msg_SP
- ("(Ada 0Y) null-exclusion not allowed in renamings");
- end if;
-
No_List;
Decl_Node :=
New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
if Present (Init_Expr) then
if Nkind (Decl_Node) = N_Object_Declaration then
Set_Expression (Decl_Node, Init_Expr);
+ Set_Has_Init_Expression (Decl_Node);
else
Error_Msg ("initialization not allowed here", Init_Loc);
end if;
-------------------------------------------------------------------------
-- DERIVED_TYPE_DEFINITION ::=
- -- [abstract] new parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART]
+ -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
+ -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
-- PRIVATE_EXTENSION_DECLARATION ::=
-- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
- -- [abstract] new ancestor_SUBTYPE_INDICATION with PRIVATE;
+ -- [abstract] [limited | synchronized]
+ -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
+ -- with private;
-- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
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;
- if Token = Tok_Abstract then
- Error_Msg_SC ("ABSTRACT must come before NEW, not after");
- Scan;
+ if Ada_Version < Ada_05
+ and then Token = Tok_Identifier
+ and then Token_Name = Name_Interface
+ then
+ Error_Msg_SP
+ ("abstract interface is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ else
+ T_New;
end if;
- if Extensions_Allowed then -- Ada 0Y (AI-231)
- Not_Null_Present := P_Null_Exclusion;
- Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
+ if Token = Tok_Abstract then
+ Error_Msg_SC -- CODEFIX
+ ("ABSTRACT must come before NEW, not after");
+ Scan;
end if;
+ 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));
+ -- Ada 2005 (AI-251): Deal with interfaces
+
+ if Token = Tok_And then
+ Scan; -- past AND
+
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("abstract interface is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Set_Interface_List (Typedef_Node, New_List);
+
+ loop
+ Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node));
+ exit when Token /= Tok_And;
+ Scan; -- past AND
+ end loop;
+
+ if Token /= Tok_With then
+ Error_Msg_SC ("WITH expected");
+ raise Error_Resync;
+ end if;
+ end if;
+
-- 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
-- case of "type X is new Y null record".
Make_Private_Extension_Declaration (No_Location,
Defining_Identifier => Empty,
Subtype_Indication => Subtype_Indication (Typedef_Node),
- Abstract_Present => Abstract_Present (Typedef_Node));
+ Abstract_Present => Abstract_Present (Typedef_Node),
+ Interface_List => Interface_List (Typedef_Node));
- Delete_Node (Typedef_Node);
return Typedecl_Node;
-- Derived type definition with record extension part
-- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
-- This routine scans out the range or subtype mark that forms the right
- -- operand of a membership test.
+ -- operand of a membership test (it is not used in any other contexts, and
+ -- error messages are specialized with this knowledge in mind).
-- Note: as documented in the Sinfo interface, although the syntax only
-- allows a subtype mark, we in fact allow any simple expression to be
-- Error recovery: cannot raise Error_Resync
- function P_Range_Or_Subtype_Mark return Node_Id is
+ function P_Range_Or_Subtype_Mark
+ (Allow_Simple_Expression : Boolean := False) return Node_Id
+ is
Expr_Node : Node_Id;
Range_Node : Node_Id;
+ Save_Loc : Source_Ptr;
+
+
+ -- Start of processing for P_Range_Or_Subtype_Mark
begin
+ -- Save location of possible junk parentheses
+
+ Save_Loc := Token_Ptr;
+
+ -- Scan out either a simple expression or a range (this accepts more
+ -- than is legal here, but as explained above, we like to allow more
+ -- with a proper diagnostic, and in the case of a membership operation
+ -- where sets are allowed, a simple expression is permissible anyway.
+
Expr_Node := P_Simple_Expression_Or_Range_Attribute;
+ -- Range attribute
+
if Expr_Form = EF_Range_Attr then
return Expr_Node;
return Range_Node;
-- Case of subtype mark (optionally qualified simple name or an
- -- attribute whose prefix is an optionally qualifed simple name)
+ -- attribute whose prefix is an optionally qualified simple name)
elsif Expr_Form = EF_Simple_Name
or else Nkind (Expr_Node) = N_Attribute_Reference
-- Check for error of range constraint after a subtype mark
if Token = Tok_Range then
- Error_Msg_SC
- ("range constraint not allowed in membership test");
+ Error_Msg_SC ("range constraint not allowed in membership test");
Scan; -- past RANGE
raise Error_Resync;
elsif Token = Tok_Digits or else Token = Tok_Delta then
Error_Msg_SC
- ("accuracy definition not allowed in membership test");
+ ("accuracy definition not allowed in membership test");
Scan; -- past DIGITS or DELTA
raise Error_Resync;
+ -- Attribute reference, may or may not be OK, but in any case we
+ -- will scan it out
+
elsif Token = Tok_Apostrophe then
return P_Subtype_Mark_Attribute (Expr_Node);
+ -- OK case of simple name, just return it
+
else
return Expr_Node;
end if;
- -- At this stage, we have some junk following the expression. We
- -- really can't tell what is wrong, might be a missing semicolon,
- -- or a missing THEN, or whatever. Our caller will figure it out!
+ -- Here we have some kind of error situation. Check for junk parens
+ -- then return what we have, caller will deal with other errors.
else
+ if Nkind (Expr_Node) in N_Subexpr
+ and then Paren_Count (Expr_Node) /= 0
+ then
+ Error_Msg ("|parentheses not allowed for subtype mark", Save_Loc);
+ Set_Paren_Count (Expr_Node, 0);
+ end if;
+
return Expr_Node;
end if;
end P_Range_Or_Subtype_Mark;
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;
-- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
if Token = Tok_Delta then
- Error_Msg_SC ("DELTA must come before DIGITS");
+ Error_Msg_SC -- CODEFIX
+ ("|DELTA must come before DIGITS");
Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc);
Scan; -- past DELTA
Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren);
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;
begin
Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr);
Scan; -- past DIGITS
- Expr_Node := P_Expression_No_Right_Paren;
+ Expr_Node := P_Expression;
Check_Simple_Expression_In_Ada_83 (Expr_Node);
Set_Digits_Expression (Constraint_Node, Expr_Node);
begin
Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr);
Scan; -- past DELTA
- Expr_Node := P_Expression_No_Right_Paren;
+ Expr_Node := P_Expression;
Check_Simple_Expression_In_Ada_83 (Expr_Node);
Set_Delta_Expression (Constraint_Node, Expr_Node);
-- DISCRETE_SUBTYPE_INDICATION | RANGE
-- COMPONENT_DEFINITION ::=
- -- [aliased] SUBTYPE_INDICATION | ACCESS_DEFINITION
+ -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
-- The caller has checked that the initial token is ARRAY
Not_Null_Present : Boolean := False;
Subs_List : List_Id;
Scan_State : Saved_Scan_State;
+ Aliased_Present : Boolean := False;
begin
Array_Loc := Token_Ptr;
CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
- -- Ada 0Y (AI-230): Access Definition case
+ 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
+ end if;
+
+ 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 not Extensions_Allowed then
+ if Ada_Version < Ada_05 then
Error_Msg_SP
("generalized use of anonymous access types " &
- "is an Ada 0Y extension");
- Error_Msg_SP ("\unit must be compiled with -gnatX switch");
+ "is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
- Set_Subtype_Indication (CompDef_Node, Empty);
- Set_Aliased_Present (CompDef_Node, False);
- Set_Access_Definition (CompDef_Node, P_Access_Definition);
- else
- Set_Access_Definition (CompDef_Node, Empty);
-
- if Token_Name = Name_Aliased then
- Check_95_Keyword (Tok_Aliased, Tok_Identifier);
- end if;
-
- if Token = Tok_Aliased then
- Set_Aliased_Present (CompDef_Node, True);
- Scan; -- past ALIASED
+ if Aliased_Present then
+ Error_Msg_SP ("ALIASED not allowed here");
end if;
- if Extensions_Allowed then -- Ada 0Y (AI-231)
- Not_Null_Present := P_Null_Exclusion;
- Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
- 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_Subtype_Indication (CompDef_Node,
- P_Subtype_Indication (Not_Null_Present));
+ 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);
Scan_State : Saved_Scan_State;
begin
- if Token /= Tok_Left_Paren then
+ -- If <> right now, then this is missing left paren
+
+ if Token = Tok_Box then
+ U_Left_Paren;
+
+ -- If not <> or left paren, then definitely no box
+
+ elsif Token /= Tok_Left_Paren then
return False;
+ -- Left paren, so might be a box after it
+
else
Save_Scan_State (Scan_State);
Scan; -- past the left paren
- if Token = Tok_Box then
- if Ada_83 then
- Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
- end if;
-
- Scan; -- past the box
- T_Right_Paren; -- must be followed by right paren
- return True;
-
- else
+ if Token /= Tok_Box then
Restore_Scan_State (Scan_State);
return False;
end if;
end if;
+
+ -- We are now pointing to the box
+
+ if Ada_Version = Ada_83 then
+ Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
+ end if;
+
+ Scan; -- past the box
+ U_Right_Paren; -- must be followed by right paren
+ return True;
end P_Unknown_Discriminant_Part_Opt;
----------------------------------
-- (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]
Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop;
- T_Colon;
-
-- If there are multiple identifiers, we repeatedly scan the
-- type and initialization expression information by resetting
-- the scan pointer (so that we get completely separate trees
Save_Scan_State (Scan_State);
end if;
+ T_Colon;
+
-- Loop through defining identifiers in list
Ident := 1;
Specification_Node :=
New_Node (N_Discriminant_Specification, Ident_Sloc);
Set_Defining_Identifier (Specification_Node, Idents (Ident));
-
- Not_Null_Present := P_Null_Exclusion; -- Ada 0Y (AI-231)
+ Not_Null_Present := -- Ada 2005 (AI-231, AI-447)
+ P_Null_Exclusion (Allow_Anonymous_In_95 => True);
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);
- Set_Null_Exclusion_Present -- Ada 0Y (AI-231)
- (Discriminant_Type (Specification_Node),
- Not_Null_Present);
+ (Specification_Node,
+ P_Access_Definition (Not_Null_Present));
else
+
Set_Discriminant_Type
(Specification_Node, P_Subtype_Mark);
No_Constraint;
- Set_Null_Exclusion_Present -- Ada 0Y (AI-231)
+ Set_Null_Exclusion_Present -- Ada 2005 (AI-231)
(Specification_Node, Not_Null_Present);
end if;
exit Ident_Loop when Ident = Num_Idents;
Ident := Ident + 1;
Restore_Scan_State (Scan_State);
+ T_Colon;
end loop Ident_Loop;
exit Specification_Loop when Token /= Tok_Semicolon;
end P_Known_Discriminant_Part_Opt;
-------------------------------------
- -- 3.7 DIscriminant Specification --
+ -- 3.7 Discriminant Specification --
-------------------------------------
-- Parsed by P_Known_Discriminant_Part_Opt (3.7)
T_Record;
Set_Null_Present (Rec_Node, True);
+ -- Catch incomplete declaration to prevent cascaded errors, see
+ -- ACATS B393002 for an example.
+
+ elsif Token = Tok_Semicolon then
+ Error_Msg_AP ("missing record definition");
+
-- Case starting with RECORD keyword. Build scope stack entry. For the
-- column, we use the first non-blank character on the line, to deal
-- with situations such as:
-- ...
-- end record;
- -- which is not official RM indentation, but is not uncommon usage
+ -- which is not official RM indentation, but is not uncommon usage, and
+ -- in particular is standard GNAT coding style, so handle it nicely.
else
Push_Scope_Stack;
-- [:= DEFAULT_EXPRESSION];
-- COMPONENT_DEFINITION ::=
- -- [aliased] SUBTYPE_INDICATION | ACCESS_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
+ Aliased_Present : Boolean := False;
CompDef_Node : Node_Id;
Decl_Node : Node_Id;
Scan_State : Saved_Scan_State;
Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop;
- T_Colon;
-
-- If there are multiple identifiers, we repeatedly scan the
-- type and initialization expression information by resetting
-- the scan pointer (so that we get completely separate trees
Save_Scan_State (Scan_State);
end if;
+ T_Colon;
+
-- Loop through defining identifiers in list
Ident := 1;
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
+ end if;
+
+ 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 not Extensions_Allowed then
+ if Ada_Version < Ada_05 then
Error_Msg_SP
- ("Generalized use of anonymous access types " &
- "is an Ada 0Y extension");
- Error_Msg_SP ("\unit must be compiled with -gnatX switch");
+ ("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);
+ Set_Access_Definition (CompDef_Node,
+ P_Access_Definition (Not_Null_Present));
else
- Set_Access_Definition (CompDef_Node, Empty);
-
- if Token_Name = Name_Aliased then
- Check_95_Keyword (Tok_Aliased, Tok_Identifier);
- end if;
-
- if Token = Tok_Aliased then
- Scan; -- past ALIASED
- Set_Aliased_Present (CompDef_Node, True);
- end if;
+ 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
raise Error_Resync;
end if;
- if Extensions_Allowed then -- Ada 0Y (AI-231)
- Not_Null_Present := P_Null_Exclusion;
- Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
- end if;
-
Set_Subtype_Indication (CompDef_Node,
- P_Subtype_Indication (Not_Null_Present));
+ P_Subtype_Indication (Not_Null_Present));
end if;
Set_Component_Definition (Decl_Node, CompDef_Node);
exit Ident_Loop when Ident = Num_Idents;
Ident := Ident + 1;
Restore_Scan_State (Scan_State);
+ T_Colon;
end loop Ident_Loop;
if Nkind (Case_Node) /= N_Identifier then
Set_Name (Variant_Part_Node, Error);
Error_Msg ("discriminant name expected", Sloc (Case_Node));
+
+ elsif Paren_Count (Case_Node) /= 0 then
+ Error_Msg ("|discriminant name may not be parenthesized",
+ Sloc (Case_Node));
+ Set_Paren_Count (Case_Node, 0);
end if;
TF_Is;
begin
Choices := New_List;
-
loop
if Token = Tok_Others then
Append (New_Node (N_Others_Choice, Token_Ptr), Choices);
else
begin
- Expr_Node := No_Right_Paren (P_Expression_Or_Range_Attribute);
+ -- Scan out expression or range attribute
+
+ Expr_Node := P_Expression_Or_Range_Attribute;
+ Ignore (Tok_Right_Paren);
if Token = Tok_Colon
and then Nkind (Expr_Node) = N_Identifier
Error_Msg_SP ("label not permitted in this context");
Scan; -- past colon
+ -- Range attribute
+
elsif Expr_Form = EF_Range_Attr then
Append (Expr_Node, Choices);
+ -- Explicit range
+
elsif Token = Tok_Dot_Dot then
Check_Simple_Expression (Expr_Node);
Choice_Node := New_Node (N_Range, Token_Ptr);
Set_High_Bound (Choice_Node, Expr_Node);
Append (Choice_Node, Choices);
+ -- Simple name, must be subtype, so range allowed
+
elsif Expr_Form = EF_Simple_Name then
if Token = Tok_Range then
Append (P_Subtype_Indication (Expr_Node), Choices);
elsif Token in Token_Class_Consk then
Error_Msg_SC
- ("the only constraint allowed here " &
- "is a range constraint");
+ ("the only constraint allowed here " &
+ "is a range constraint");
Discard_Junk_Node (P_Constraint_Opt);
Append (Expr_Node, Choices);
Append (Expr_Node, Choices);
end if;
+ -- Expression
+
else
- Check_Simple_Expression_In_Ada_83 (Expr_Node);
+ -- If extensions are permitted then the expression must be a
+ -- simple expression. The resaon for this restriction (i.e.
+ -- going back to the Ada 83 rule) is to avoid ambiguities
+ -- when set membership operations are allowed, consider the
+ -- following:
+
+ -- when A in 1 .. 10 | 12 =>
+
+ -- This is ambiguous without parentheses, so we require one
+ -- of the following two parenthesized forms to disambuguate:
+
+ -- one of the following:
+
+ -- when (A in 1 .. 10 | 12) =>
+ -- when (A in 1 .. 10) | 12 =>
+
+ -- To solve this, if extensins are enabled, we disallow
+ -- the use of membership operations in expressions in
+ -- choices. Technically in the grammar, the expression
+ -- must match the grammar for restricted expression.
+
+ if Extensions_Allowed then
+ Check_Restricted_Expression (Expr_Node);
+
+ -- In Ada 83 mode, the syntax required a simple expression
+
+ else
+ Check_Simple_Expression_In_Ada_83 (Expr_Node);
+ end if;
+
Append (Expr_Node, Choices);
end if;
-- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
+ --------------------------------------
+ -- 3.9.4 Interface Type Definition --
+ --------------------------------------
+
+ -- INTERFACE_TYPE_DEFINITION ::=
+ -- [limited | task | protected | synchronized] interface
+ -- [and INTERFACE_LIST]
+
+ -- Error recovery: cannot raise Error_Resync
+
+ function P_Interface_Type_Definition
+ (Abstract_Present : Boolean) return Node_Id
+ is
+ Typedef_Node : Node_Id;
+
+ begin
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP ("abstract interface is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ if Abstract_Present then
+ Error_Msg_SP ("ABSTRACT not allowed in interface type definition " &
+ "(RM 3.9.4(2/2))");
+ end if;
+
+ Scan; -- past INTERFACE
+
+ -- Ada 2005 (AI-345): In case of interfaces with a null list of
+ -- interfaces we build a record_definition node.
+
+ if Token = Tok_Semicolon then
+ Typedef_Node := New_Node (N_Record_Definition, Token_Ptr);
+
+ Set_Abstract_Present (Typedef_Node);
+ Set_Tagged_Present (Typedef_Node);
+ Set_Null_Present (Typedef_Node);
+ Set_Interface_Present (Typedef_Node);
+
+ -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
+ -- a list of interfaces we build a derived_type_definition node. This
+ -- simplifies the semantic analysis (and hence further maintenance)
+
+ else
+ if Token /= Tok_And then
+ Error_Msg_AP ("AND expected");
+ else
+ Scan; -- past AND
+ end if;
+
+ Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
+
+ Set_Abstract_Present (Typedef_Node);
+ Set_Interface_Present (Typedef_Node);
+ Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name);
+
+ Set_Record_Extension_Part (Typedef_Node,
+ New_Node (N_Record_Definition, Token_Ptr));
+ Set_Null_Present (Record_Extension_Part (Typedef_Node));
+
+ if Token = Tok_And then
+ Set_Interface_List (Typedef_Node, New_List);
+ Scan; -- past AND
+
+ loop
+ Append (P_Qualified_Simple_Name,
+ Interface_List (Typedef_Node));
+ exit when Token /= Tok_And;
+ Scan; -- past AND
+ end loop;
+ end if;
+ end if;
+
+ return Typedef_Node;
+ end P_Interface_Type_Definition;
+
----------------------------------
-- 3.10 Access Type Definition --
----------------------------------
-- | 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
+ function P_Access_Type_Definition
+ (Header_Already_Parsed : Boolean := False) return Node_Id
+ is
+ Access_Loc : constant Source_Ptr := Token_Ptr;
Prot_Flag : Boolean;
- Access_Loc : Source_Ptr;
Not_Null_Present : Boolean := False;
Type_Def_Node : Node_Id;
+ Result_Not_Null : Boolean;
+ Result_Node : Node_Id;
procedure Check_Junk_Subprogram_Name;
-- Used in access to subprogram definition cases to check for an
-- identifier or operator symbol that does not belong.
+ --------------------------------
+ -- Check_Junk_Subprogram_Name --
+ --------------------------------
+
procedure Check_Junk_Subprogram_Name is
Saved_State : Saved_Scan_State;
-- Start of processing for P_Access_Type_Definition
begin
- if Extensions_Allowed then -- Ada 0Y (AI-231)
- Not_Null_Present := P_Null_Exclusion;
+ if not Header_Already_Parsed then
+ Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
+ Scan; -- past ACCESS
end if;
- Access_Loc := Token_Ptr;
- Scan; -- past ACCESS
-
if Token_Name = Name_Protected then
Check_95_Keyword (Tok_Protected, Tok_Procedure);
Check_95_Keyword (Tok_Protected, Tok_Function);
Scan; -- past PROTECTED
if Token /= Tok_Procedure and then Token /= Tok_Function then
- Error_Msg_SC ("FUNCTION or PROCEDURE expected");
+ Error_Msg_SC -- CODEFIX
+ ("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;
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;
Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
Set_Protected_Present (Type_Def_Node, Prot_Flag);
TF_Return;
- Set_Subtype_Mark (Type_Def_Node, P_Subtype_Mark);
- No_Constraint;
+
+ Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231)
+
+ -- Ada 2005 (AI-318-02)
+
+ if Token = Tok_Access then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SC
+ ("anonymous access result type is an Ada 2005 extension");
+ Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Result_Node := P_Access_Definition (Result_Not_Null);
+
+ else
+ Result_Node := P_Subtype_Mark;
+ No_Constraint;
+
+ -- A null exclusion on the result type must be recorded in a flag
+ -- distinct from the one used for the access-to-subprogram type's
+ -- null exclusion.
+
+ Set_Null_Exclusion_In_Return_Present
+ (Type_Def_Node, Result_Not_Null);
+ end if;
+
+ Set_Result_Definition (Type_Def_Node, Result_Node);
else
Type_Def_Node :=
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;
-- 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
- -- Ada 0Y (AI-231): ACCESS [general_access_modifier] subtype_mark
+ -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
+
+ if Token = Tok_Protected
+ or else Token = Tok_Procedure
+ or else Token = Tok_Function
+ then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP ("access-to-subprogram is an Ada 2005 extension");
+ Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
+ end if;
+
+ 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 Extensions_Allowed then
if Token = Tok_All then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("ALL is not permitted for anonymous access types");
+ end if;
+
Scan; -- past ALL
Set_All_Present (Def_Node);
elsif Token = Tok_Constant then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP ("access-to-constant is an Ada 2005 extension");
+ Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
+ end if;
+
Scan; -- past CONSTANT
Set_Constant_Present (Def_Node);
end if;
+
+ Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
+ No_Constraint;
end if;
- Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
- No_Constraint;
return Def_Node;
end P_Access_Definition;
Scan_State : Saved_Scan_State;
begin
- if Style_Check then Style.Check_Indentation; end if;
+ if Style_Check then
+ Style.Check_Indentation;
+ end if;
case Token is
when Tok_Identifier =>
Check_Bad_Layout;
- P_Identifier_Declarations (Decls, Done, In_Spec);
+
+ -- Special check for misuse of overriding not in Ada 2005 mode
+
+ if Token_Name = Name_Overriding
+ and then not Next_Token_Is (Tok_Colon)
+ then
+ Error_Msg_SC ("overriding indicator is an Ada 2005 extension");
+ Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
+
+ Token := Tok_Overriding;
+ Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+ Done := False;
+
+ -- Normal case, no overriding, or overriding followed by colon
+
+ else
+ P_Identifier_Declarations (Decls, Done, In_Spec);
+ end if;
+
+ -- Ada2005: A subprogram declaration can start with "not" or
+ -- "overriding". In older versions, "overriding" is handled
+ -- like an identifier, with the appropriate messages.
+
+ when Tok_Not =>
+ Check_Bad_Layout;
+ Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+ Done := False;
+
+ when Tok_Overriding =>
+ Check_Bad_Layout;
+ Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+ Done := False;
when Tok_Package =>
Check_Bad_Layout;
-- Otherwise we saved the semicolon position, so complain
else
- Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
+ Error_Msg ("|"";"" should be IS", SIS_Semicolon_Sloc);
end if;
-- The next job is to fix up any declarations that occurred
SIS_Entry_Active := False;
- -- Test for assorted illegal declarations not diagnosed elsewhere.
+ -- Test for assorted illegal declarations not diagnosed elsewhere
Decl := First (Decls);
procedure Skip_Declaration (S : List_Id) is
Dummy_Done : Boolean;
-
+ pragma Warnings (Off, Dummy_Done);
begin
P_Declarative_Items (S, Dummy_Done, False);
end Skip_Declaration;
OSDN Git Service
