X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fpar-ch3.adb;h=bfc4f592bf36af68761e31f59189d6ef87e85587;hb=4c97a37dc04bd1838ea3d099bebf2900e10322dd;hp=211665345e1c920b326bda2870215baa946e8224;hpb=a955b866c37d5eb0d4a767a40dcade03349ee196;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 211665345e1..bfc4f592bf3 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -6,34 +6,35 @@ -- -- -- B o d y -- -- -- --- $Revision$ --- -- --- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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. -- --- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- 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 ----------------------- @@ -58,20 +59,37 @@ 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; @@ -93,20 +111,47 @@ package body Ch3 is -- 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); + end if; + end Check_Restricted_Expression; + ------------------- -- Init_Expr_Opt -- ------------------- 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 @@ -156,7 +201,7 @@ package body Ch3 is -- 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 @@ -165,13 +210,15 @@ package body Ch3 is -- we set Force_Msg to True, since we want at least one message for each -- separate declaration (but not use) of a reserved identifier. + -- Duplication should be removed, common code should be factored??? + if Token = Tok_Identifier then - null; + Check_Future_Keyword; -- 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 @@ -184,6 +231,16 @@ package body Ch3 is 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 (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; @@ -202,11 +259,12 @@ package body Ch3 is -- | PRIVATE_EXTENSION_DECLARATION -- FULL_TYPE_DECLARATION ::= - -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION; + -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION + -- [ASPECT_SPECIFICATIONS]; -- | 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] @@ -214,37 +272,44 @@ package body Ch3 is -- 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 - -- declaration, private type declaration and type definition is - -- included in this function. The processing for concurrent type - -- declarations is NOT here, but rather in chapter 9 (i.e. this - -- function handles only declarations starting with TYPE). + -- The processing for full type declarations, incomplete type declarations, + -- private type declarations and type definitions is included in this + -- function. The processing for concurrent type declarations is NOT here, + -- but rather in chapter 9 (this 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; -- Normally holds type definition, except in the case of a private @@ -253,8 +318,22 @@ package body Ch3 is begin Type_Loc := Token_Ptr; Type_Start_Col := Start_Column; - T_Type; - Ident_Node := P_Defining_Identifier; + + -- 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 @@ -287,7 +366,8 @@ package body Ch3 is Scan; -- past = used in place of IS elsif Token = Tok_Renames then - Error_Msg_SC ("RENAMES should be IS"); + Error_Msg_SC -- CODEFIX + ("RENAMES should be IS"); Scan; -- past RENAMES used in place of IS else @@ -335,17 +415,15 @@ package body Ch3 is Abstract_Loc := Token_Ptr; Scan; -- past ABSTRACT - if Token = Tok_Limited + -- Ada 2005 (AI-419): AARM 3.4 (2/2) + + if (Ada_Version < Ada_2005 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 @@ -363,7 +441,7 @@ package body Ch3 is 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 @@ -379,24 +457,21 @@ package body Ch3 is 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_Array => Typedef_Node := P_Array_Type_Definition; - TF_Semicolon; exit; when Tok_Delta => Typedef_Node := P_Fixed_Point_Definition; - TF_Semicolon; exit; when Tok_Digits => Typedef_Node := P_Floating_Point_Definition; - TF_Semicolon; exit; when Tok_In => @@ -405,51 +480,77 @@ package body Ch3 is when Tok_Integer_Literal => T_Range; Typedef_Node := P_Signed_Integer_Type_Definition; - TF_Semicolon; exit; when Tok_Null => Typedef_Node := P_Record_Definition; - TF_Semicolon; exit; when Tok_Left_Paren => Typedef_Node := P_Enumeration_Type_Definition; - TF_Semicolon; + + End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label (Typedef_Node, End_Labl); exit; when Tok_Mod => Typedef_Node := P_Modular_Type_Definition; - TF_Semicolon; exit; when Tok_New => Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; - TF_Semicolon; + + if Nkind (Typedef_Node) = N_Derived_Type_Definition + and then Present (Record_Extension_Part (Typedef_Node)) + then + End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label + (Record_Extension_Part (Typedef_Node), End_Labl); + end if; + exit; when Tok_Range => Typedef_Node := P_Signed_Integer_Type_Definition; - TF_Semicolon; exit; when Tok_Record => Typedef_Node := P_Record_Definition; - End_Labl := - Make_Identifier (Token_Ptr, - Chars => Chars (Ident_Node)); + End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); Set_Comes_From_Source (End_Labl, False); Set_End_Label (Typedef_Node, End_Labl); - 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_2005 + 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 @@ -473,6 +574,12 @@ package body Ch3 is Typedef_Node := P_Record_Definition; Set_Tagged_Present (Typedef_Node, True); Set_Limited_Present (Typedef_Node, True); + + End_Labl := + Make_Identifier (Token_Ptr, Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label (Typedef_Node, End_Labl); end if; else @@ -489,16 +596,15 @@ package body Ch3 is else Typedef_Node := P_Record_Definition; Set_Tagged_Present (Typedef_Node, True); + + End_Labl := + Make_Identifier (Token_Ptr, Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label (Typedef_Node, End_Labl); end if; end if; - 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 => @@ -506,11 +612,13 @@ package body Ch3 is 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 @@ -521,14 +629,65 @@ package body Ch3 is -- 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 Ada 2005, "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_2005 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 (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 @@ -537,7 +696,6 @@ package body Ch3 is T_Private; -- past PRIVATE (or complain if not there!) end if; - TF_Semicolon; exit; -- Here we have an identifier after the IS, which is certainly @@ -552,7 +710,6 @@ package body Ch3 is if not Token_Is_At_Start_Of_Line then Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; - TF_Semicolon; -- If the identifier is at the start of the line, and is in the -- same column as the type declaration itself then we consider @@ -573,11 +730,101 @@ package body Ch3 is else Typedef_Node := P_Record_Definition; - TF_Semicolon; end if; exit; + -- Ada 2005 (AI-251): INTERFACE + + when Tok_Interface => + Typedef_Node := P_Interface_Type_Definition (Abstract_Present); + Abstract_Present := True; + exit; + + when Tok_Private => + Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); + Scan; -- past PRIVATE + + -- Check error cases of private [abstract] tagged + + if Token = Tok_Abstract then + Error_Msg_SC ("`ABSTRACT TAGGED` must come before PRIVATE"); + Scan; -- past ABSTRACT + + if Token = Tok_Tagged then + Scan; -- past TAGGED + end if; + + elsif Token = Tok_Tagged then + Error_Msg_SC ("TAGGED must come before PRIVATE"); + Scan; -- past TAGGED + end if; + + 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; + + exit; + -- Anything else is an error when others => @@ -637,6 +884,7 @@ package body Ch3 is 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); @@ -658,8 +906,8 @@ package body Ch3 is Set_Defining_Identifier (Decl_Node, Ident_Node); Set_Discriminant_Specifications (Decl_Node, Discr_List); + P_Aspect_Specifications (Decl_Node); return Decl_Node; - end P_Type_Declaration; ---------------------------------- @@ -679,28 +927,35 @@ package body Ch3 is -------------------------------- -- SUBTYPE_DECLARATION ::= - -- subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION; + -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION + -- {ASPECT_SPECIFICATIONS]; -- 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 - Error_Msg_SC ("NEW ignored (only allowed in type declaration)"); + Error_Msg_SC -- CODEFIX + ("NEW ignored (only allowed in type declaration)"); Scan; -- past NEW end if; - Set_Subtype_Indication (Decl_Node, P_Subtype_Indication); - TF_Semicolon; + 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)); + P_Aspect_Specifications (Decl_Node); return Decl_Node; end P_Subtype_Declaration; @@ -708,17 +963,71 @@ package body Ch3 is -- 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 + 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 + 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_2005 + 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 ("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 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, @@ -741,22 +1050,32 @@ package body Ch3 is -- Error recovery: can raise Error_Resync - function P_Subtype_Indication (Subtype_Mark : Node_Id) return Node_Id is + 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 + if No (Constr_Node) + or else + (Nkind (Constr_Node) = N_Range_Constraint + and then Nkind (Range_Expression (Constr_Node)) = N_Error) + then return Subtype_Mark; else + if Not_Null_Present then + Error_Msg_SP ("`NOT NULL` not allowed if constraint given"); + 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; ------------------------- @@ -773,7 +1092,6 @@ package body Ch3 is function P_Subtype_Mark return Node_Id is begin return P_Subtype_Mark_Resync; - exception when Error_Resync => return Error; @@ -861,7 +1179,6 @@ package body Ch3 is Make_Attribute_Reference (Prev_Token_Ptr, Prefix => Prefix, Attribute_Name => Token_Name); - Delete_Node (Token_Node); Scan; -- past type attribute identifier end if; @@ -917,7 +1234,6 @@ package body Ch3 is else return Empty; end if; - end P_Constraint_Opt; ------------------------------ @@ -939,22 +1255,31 @@ package body Ch3 is -- 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] - -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; + -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; + -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- ACCESS_DEFINITION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; + -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- ARRAY_TYPE_DEFINITION [:= EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; -- NUMBER_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION; -- OBJECT_RENAMING_DECLARATION ::= - -- DEFINING_IDENTIFIER : SUBTYPE_MARK 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; -- EXCEPTION_DECLARATION ::= - -- DEFINING_IDENTIFIER_LIST : exception; + -- DEFINING_IDENTIFIER_LIST : exception + -- [ASPECT_SPECIFICATIONS]; -- Note that the ALIASED indication in an object declaration is -- marked by a flag in the parent node. @@ -977,15 +1302,17 @@ package body Ch3 is 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 @@ -1006,16 +1333,25 @@ package body Ch3 is -- returns True, otherwise returns False. Includes checking for some -- common error cases. + ------------- + -- No_List -- + ------------- + procedure No_List is begin if Num_Idents > 1 then - Error_Msg ("identifier list not allowed for RENAMES", - Sloc (Idents (2))); + Error_Msg + ("identifier list not allowed for RENAMES", + Sloc (Idents (2))); end if; List_OK := False; end No_List; + ---------------------- + -- Token_Is_Renames -- + ---------------------- + function Token_Is_Renames return Boolean is At_Colon : Saved_Scan_State; @@ -1026,7 +1362,8 @@ package body Ch3 is Check_Misspelling_Of (Tok_Renames); if Token = Tok_Renames then - Error_Msg_SP ("extra "":"" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra "":"" ignored"); Scan; -- past RENAMES return True; else @@ -1051,7 +1388,7 @@ package body Ch3 is 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. @@ -1062,10 +1399,9 @@ package body Ch3 is -- 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; + Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); end loop; Save_Scan_State (Scan_State); -- at colon @@ -1200,6 +1536,11 @@ package body Ch3 is Init_Expr := Init_Expr_Opt; if Present (Init_Expr) then + if Not_Null_Present then + Error_Msg_SP + ("`NOT NULL` not allowed in numeric expression"); + end if; + Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc); Set_Expression (Decl_Node, Init_Expr); @@ -1215,7 +1556,8 @@ package body Ch3 is 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; @@ -1223,8 +1565,26 @@ package body Ch3 is 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); + + if Token = Tok_Access then + if Ada_Version < Ada_2005 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; if Token = Tok_Renames then @@ -1266,8 +1626,28 @@ package body Ch3 is 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); + + -- Access definition (AI-406) or subtype indication + + if Token = Tok_Access then + if Ada_Version < Ada_2005 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 @@ -1276,6 +1656,120 @@ package body Ch3 is Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); Set_Object_Definition (Decl_Node, P_Array_Type_Definition); + -- 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_2005 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_2005 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 Ada_Version < Ada_2005 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); + + -- Object declaration with access definition, or renaming + + 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; + -- Subtype indication case else @@ -1294,8 +1788,10 @@ package body Ch3 is 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 @@ -1317,13 +1813,14 @@ package body Ch3 is 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; end if; - TF_Semicolon; Set_Defining_Identifier (Decl_Node, Idents (Ident)); + P_Aspect_Specifications (Decl_Node); if List_OK then if Ident < Num_Idents then @@ -1343,7 +1840,6 @@ package body Ch3 is end loop Ident_Loop; Done := False; - end P_Identifier_Declarations; ------------------------------- @@ -1383,11 +1879,14 @@ package body Ch3 is ------------------------------------------------------------------------- -- 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 @@ -1402,33 +1901,81 @@ package body Ch3 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; + + if Ada_Version < Ada_2005 + 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 Token = Tok_Abstract then - Error_Msg_SC ("ABSTRACT must come before NEW, not after"); + Error_Msg_SC -- CODEFIX + ("ABSTRACT must come before NEW, not after"); 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)); + + -- Ada 2005 (AI-251): Deal with interfaces + + if Token = Tok_And then + Scan; -- past AND + + if Ada_Version < Ada_2005 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". - if Token = Tok_With + -- First make sure we don't have an aspect specification. If we do + -- return now, so that our caller can check it (the WITH here is not + -- part of a type extension). + + if Aspect_Specifications_Present then + return Typedef_Node; + + -- OK, not an aspect specification, so continue test for extension + + elsif Token = Tok_With or else Token = Tok_Record or else Token = Tok_Null then T_With; -- past WITH or give error message if Token = Tok_Limited then - Error_Msg_SC - ("LIMITED keyword not allowed in private extension"); + Error_Msg_SC ("LIMITED keyword not allowed in private extension"); Scan; -- ignore LIMITED end if; @@ -1446,9 +1993,9 @@ package body Ch3 is 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 @@ -1533,7 +2080,8 @@ package body Ch3 is -- | 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 @@ -1545,13 +2093,29 @@ package body Ch3 is -- 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; @@ -1566,7 +2130,7 @@ package body Ch3 is 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 @@ -1574,8 +2138,7 @@ package body Ch3 is -- 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; @@ -1583,22 +2146,38 @@ package body Ch3 is 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! + -- Simple expression case + + elsif Expr_Form = EF_Simple and then Allow_Simple_Expression then + return Expr_Node; + + -- 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; @@ -1647,7 +2226,7 @@ package body Ch3 is 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; @@ -1663,7 +2242,6 @@ package body Ch3 is function P_Defining_Character_Literal return Node_Id is Literal_Node : Node_Id; - begin Literal_Node := Token_Node; Change_Character_Literal_To_Defining_Character_Literal (Literal_Node); @@ -1701,13 +2279,30 @@ package body Ch3 is Scan; -- past RANGE end if; - Expr_Node := P_Expression; - Check_Simple_Expression (Expr_Node); - Set_Low_Bound (Typedef_Node, Expr_Node); - T_Dot_Dot; - Expr_Node := P_Expression; - Check_Simple_Expression (Expr_Node); - Set_High_Bound (Typedef_Node, Expr_Node); + Expr_Node := P_Expression_Or_Range_Attribute; + + -- Range case (not permitted by the grammar, this is surprising but + -- the grammar in the RM is as quoted above, and does not allow Range). + + if Expr_Form = EF_Range_Attr then + Error_Msg_N + ("Range attribute not allowed here, use First .. Last", Expr_Node); + Set_Low_Bound (Typedef_Node, Expr_Node); + Set_Attribute_Name (Expr_Node, Name_First); + Set_High_Bound (Typedef_Node, Copy_Separate_Tree (Expr_Node)); + Set_Attribute_Name (High_Bound (Typedef_Node), Name_Last); + + -- Normal case of explicit range + + else + Check_Simple_Expression (Expr_Node); + Set_Low_Bound (Typedef_Node, Expr_Node); + T_Dot_Dot; + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Typedef_Node, Expr_Node); + end if; + return Typedef_Node; end P_Signed_Integer_Type_Definition; @@ -1725,7 +2320,7 @@ package body Ch3 is 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; @@ -1776,7 +2371,8 @@ package body Ch3 is -- 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); @@ -1854,7 +2450,7 @@ package body Ch3 is 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; @@ -1910,7 +2506,7 @@ package body Ch3 is 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); @@ -1930,6 +2526,7 @@ package body Ch3 is -- Note: this is an obsolescent feature in Ada 95 (I.3) -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION + -- (also true in formal modes). -- The caller has checked that the initial token is DELTA @@ -1942,8 +2539,9 @@ package body Ch3 is 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); if Token = Tok_Range then @@ -1973,17 +2571,21 @@ package body Ch3 is -- 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; @@ -2041,12 +2643,51 @@ package body Ch3 is 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_2005 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; + + -- AI95-406 makes "aliased" legal (and useless) in this context so + -- followintg code which used to be needed is commented out. + + -- 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; @@ -2076,7 +2717,6 @@ package body Ch3 is 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. @@ -2139,11 +2779,17 @@ package body Ch3 is Set_High_Bound (Range_Node, Expr_Node); return Range_Node; - -- Otherwise we must have a subtype mark + -- Otherwise we must have a subtype mark, or an Ada 2012 iterator elsif Expr_Form = EF_Simple_Name then return Expr_Node; + -- The domain of iteration must be a name. Semantics will determine that + -- the expression has the proper form. + + elsif Ada_Version >= Ada_2012 then + return Expr_Node; + -- If incorrect, complain that we expect .. else @@ -2178,28 +2824,37 @@ package body Ch3 is 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; ---------------------------------- @@ -2210,7 +2865,7 @@ package body Ch3 is -- (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] @@ -2225,6 +2880,7 @@ package body Ch3 is 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; @@ -2241,16 +2897,14 @@ package body Ch3 is 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; - -- 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 @@ -2260,6 +2914,8 @@ package body Ch3 is Save_Scan_State (Scan_State); end if; + T_Colon; + -- Loop through defining identifiers in list Ident := 1; @@ -2267,19 +2923,25 @@ package body Ch3 is Specification_Node := New_Node (N_Discriminant_Specification, Ident_Sloc); Set_Defining_Identifier (Specification_Node, Idents (Ident)); + 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); + (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 @@ -2297,6 +2959,7 @@ package body Ch3 is 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; @@ -2313,7 +2976,7 @@ package body Ch3 is end P_Known_Discriminant_Part_Opt; ------------------------------------- - -- 3.7 DIscriminant Specification -- + -- 3.7 Discriminant Specification -- ------------------------------------- -- Parsed by P_Known_Discriminant_Part_Opt (3.7) @@ -2455,7 +3118,6 @@ package body Ch3 is T_Right_Paren; return Result_Node; - end P_Index_Or_Discriminant_Constraint; ------------------------------------- @@ -2482,7 +3144,7 @@ package body Ch3 is 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; @@ -2538,6 +3200,12 @@ package body Ch3 is 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: @@ -2546,7 +3214,8 @@ package body Ch3 is -- ... -- 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; @@ -2671,7 +3340,6 @@ package body Ch3 is Set_Component_Items (Component_List_Node, Decls_List); return Component_List_Node; - end P_Component_List; ------------------------- @@ -2682,9 +3350,11 @@ package body Ch3 is -- COMPONENT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION - -- [:= DEFAULT_EXPRESSION]; + -- [:= DEFAULT_EXPRESSION] + -- [ASPECT_SPECIFICATIONS]; - -- 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. @@ -2693,11 +3363,14 @@ package body Ch3 is -- 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 @@ -2712,16 +3385,14 @@ package body Ch3 is 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; - -- 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 @@ -2731,6 +3402,8 @@ package body Ch3 is Save_Scan_State (Scan_State); end if; + T_Colon; + -- Loop through defining identifiers in list Ident := 1; @@ -2748,22 +3421,57 @@ package body Ch3 is 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_2005 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; + + -- AI95-406 makes "aliased" legal (and useless) here, so the + -- following code which used to be required is commented out. + + -- 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); @@ -2785,11 +3493,10 @@ package body Ch3 is exit Ident_Loop when Ident = Num_Idents; Ident := Ident + 1; Restore_Scan_State (Scan_State); - + T_Colon; end loop Ident_Loop; - TF_Semicolon; - + P_Aspect_Specifications (Decl_Node); end P_Component_Items; -------------------------------- @@ -2816,7 +3523,6 @@ package body Ch3 is 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); @@ -2827,12 +3533,17 @@ package body Ch3 is 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_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; @@ -2865,7 +3576,6 @@ package body Ch3 is Set_Variants (Variant_Part_Node, Variants_List); return Variant_Part_Node; - end P_Variant_Part; -------------------- @@ -2919,7 +3629,6 @@ package body Ch3 is begin Choices := New_List; - loop if Token = Tok_Others then Append (New_Node (N_Others_Choice, Token_Ptr), Choices); @@ -2927,7 +3636,10 @@ package body Ch3 is 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 @@ -2935,9 +3647,13 @@ package body Ch3 is 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); @@ -2948,14 +3664,16 @@ package body Ch3 is 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); @@ -2963,8 +3681,40 @@ package body Ch3 is Append (Expr_Node, Choices); end if; + -- Expression + else - Check_Simple_Expression_In_Ada_83 (Expr_Node); + -- In Ada 2012 mode, the expression must be a simple + -- expression. The reason 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 disambiguate: + + -- one of the following: + + -- when (A in 1 .. 10 | 12) => + -- when (A in 1 .. 10) | 12 => + + -- To solve this, in Ada 2012 mode, 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 Ada_Version >= Ada_2012 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; @@ -2976,12 +3726,23 @@ package body Ch3 is end if; if Token = Tok_Comma then - Error_Msg_SC (""","" should be ""|"""); + Scan; -- past comma + + if Token = Tok_Vertical_Bar then + Error_Msg_SP -- CODEFIX + ("|extra "","" ignored"); + Scan; -- past | + + else + Error_Msg_SP -- CODEFIX + (""","" should be ""'|"""); + end if; + else exit when Token /= Tok_Vertical_Bar; + Scan; -- past | end if; - Scan; -- past | or comma end loop; return Choices; @@ -3001,6 +3762,83 @@ package body Ch3 is -- 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_2005 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 or else Aspect_Specifications_Present 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 -- ---------------------------------- @@ -3010,31 +3848,43 @@ package body Ch3 is -- | 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; + 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; @@ -3056,8 +3906,10 @@ package body Ch3 is -- 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); @@ -3068,42 +3920,72 @@ package body Ch3 is if Prot_Flag then 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; 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); 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_2005 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 := 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; @@ -3117,7 +3999,8 @@ package body Ch3 is 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; @@ -3145,20 +4028,74 @@ package body Ch3 is -- 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): Access_To_Subprogram_Definition + + if Token = Tok_Protected + or else Token = Tok_Procedure + or else Token = Tok_Function + then + if Ada_Version < Ada_2005 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 Token = Tok_All then + if Ada_Version < Ada_2005 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_2005 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; + return Def_Node; end P_Access_Definition; @@ -3231,13 +4168,15 @@ package body Ch3 is 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_Function => Check_Bad_Layout; - Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); + Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); Done := False; when Tok_For => @@ -3271,11 +4210,42 @@ package body Ch3 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_Pexp), Decls); + Done := False; + + -- Normal case, no overriding, or overriding followed by colon + + else + P_Identifier_Declarations (Decls, Done, In_Spec); + end if; + + -- Ada 2005: 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_Pexp), Decls); + Done := False; + + when Tok_Overriding => + Check_Bad_Layout; + Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); + Done := False; when Tok_Package => Check_Bad_Layout; - Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); + Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); Done := False; when Tok_Pragma => @@ -3284,7 +4254,7 @@ package body Ch3 is when Tok_Procedure => Check_Bad_Layout; - Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); + Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); Done := False; when Tok_Protected => @@ -3316,8 +4286,42 @@ package body Ch3 is when Tok_With => Check_Bad_Layout; - Error_Msg_SC ("WITH can only appear in context clause"); - raise Error_Resync; + + if Aspect_Specifications_Present then + + -- If we are after a semicolon, complain that it was ignored. + -- But we don't really ignore it, since we dump the aspects, + -- so we make the error message a normal fatal message which + -- will inhibit semantic analysis anyway). + + if Prev_Token = Tok_Semicolon then + Error_Msg_SP -- CODEFIX + ("extra "";"" ignored"); + + -- If not just past semicolon, just complain that aspects are + -- not allowed at this point. + + else + Error_Msg_SC ("aspect specifications not allowed here"); + end if; + + declare + Dummy_Node : constant Node_Id := + New_Node (N_Package_Specification, Token_Ptr); + pragma Warnings (Off, Dummy_Node); + -- Dummy node to attach aspect specifications to. We will + -- then throw them away. + + begin + P_Aspect_Specifications (Dummy_Node, Semicolon => True); + end; + + -- Here if not aspect specifications case + + else + Error_Msg_SC ("WITH can only appear in context clause"); + raise Error_Resync; + end if; -- BEGIN terminates the scan of a sequence of declarations unless -- there is a missing subprogram body, see section on handling @@ -3354,7 +4358,8 @@ package body Ch3 is -- Otherwise we saved the semicolon position, so complain else - Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc); + Error_Msg -- CODEFIX + ("|"";"" should be IS", SIS_Semicolon_Sloc); end if; -- The next job is to fix up any declarations that occurred @@ -3398,29 +4403,29 @@ package body Ch3 is Done := True; end if; - -- Normally an END terminates the scan for basic declarative - -- items. The one exception is END RECORD, which is probably - -- left over from some other junk. + -- Normally an END terminates the scan for basic declarative items. + -- The one exception is END RECORD, which is probably left over from + -- some other junk. - when Tok_End => - Save_Scan_State (Scan_State); -- at END - Scan; -- past END + when Tok_End => + Save_Scan_State (Scan_State); -- at END + Scan; -- past END - if Token = Tok_Record then - Error_Msg_SP ("no RECORD for this `end record`!"); - Scan; -- past RECORD - TF_Semicolon; + if Token = Tok_Record then + Error_Msg_SP ("no RECORD for this `end record`!"); + Scan; -- past RECORD + TF_Semicolon; - else - Restore_Scan_State (Scan_State); -- to END - Done := True; - end if; + else + Restore_Scan_State (Scan_State); -- to END + Done := True; + end if; -- The following tokens which can only be the start of a statement -- are considered to end a declarative part (i.e. we have a missing -- BEGIN situation). We are fairly conservative in making this -- judgment, because it is a real mess to go into statement mode - -- prematurely in reponse to a junk declaration. + -- prematurely in response to a junk declaration. when Tok_Abort | Tok_Accept | @@ -3526,7 +4531,6 @@ package body Ch3 is when Error_Resync => Resync_Past_Semicolon; Done := False; - end P_Declarative_Items; ---------------------------------- @@ -3549,6 +4553,11 @@ package body Ch3 is 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 @@ -3571,7 +4580,7 @@ package body Ch3 is SIS_Entry_Active := False; - -- Test for assorted illegal declarations not diagnosed elsewhere. + -- Test for assorted illegal declarations not diagnosed elsewhere Decl := First (Decls); @@ -3585,14 +4594,12 @@ package body Ch3 is Kind = N_Task_Body or else Kind = N_Protected_Body then - Error_Msg - ("proper body not allowed in package spec", Sloc (Decl)); + Error_Msg ("proper body not allowed in package spec", Sloc (Decl)); -- Test for body stub scanned, not acceptable as basic decl item elsif Kind in N_Body_Stub then - Error_Msg - ("body stub not allowed in package spec", Sloc (Decl)); + Error_Msg ("body stub not allowed in package spec", Sloc (Decl)); elsif Kind = N_Assignment_Statement then Error_Msg @@ -3641,7 +4648,7 @@ package body Ch3 is 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; @@ -3718,7 +4725,6 @@ package body Ch3 is -- hit the missing BEGIN, which will clean up the error message. Done := False; - end Statement_When_Declaration_Expected; end Ch3;