Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/par-ch9.adb @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/ada/par-ch9.adb Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,1977 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, 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 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 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. + +separate (Par) +package body Ch9 is + + -- Local subprograms, used only in this chapter + + function P_Accept_Alternative return Node_Id; + function P_Delay_Alternative return Node_Id; + function P_Delay_Relative_Statement return Node_Id; + function P_Delay_Until_Statement return Node_Id; + function P_Entry_Barrier return Node_Id; + function P_Entry_Body_Formal_Part return Node_Id; + function P_Entry_Declaration return Node_Id; + function P_Entry_Index_Specification return Node_Id; + function P_Protected_Definition return Node_Id; + function P_Protected_Operation_Declaration_Opt return Node_Id; + function P_Protected_Operation_Items return List_Id; + function P_Task_Items return List_Id; + function P_Task_Definition return Node_Id; + + ----------------------------- + -- 9.1 Task (also 10.1.3) -- + ----------------------------- + + -- TASK_TYPE_DECLARATION ::= + -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] + -- [ASPECT_SPECIFICATIONS] + -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; + + -- SINGLE_TASK_DECLARATION ::= + -- task DEFINING_IDENTIFIER + -- [ASPECT_SPECIFICATIONS] + -- [is [new INTERFACE_LIST with] TASK_DEFINITION]; + + -- TASK_BODY ::= + -- task body DEFINING_IDENTIFIER [ASPECT_SPECIFICATIONS] is + -- DECLARATIVE_PART + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [task_IDENTIFIER] + + -- TASK_BODY_STUB ::= + -- task body DEFINING_IDENTIFIER is separate + -- [ASPECT_SPECIFICATIONS]; + + -- This routine scans out a task declaration, task body, or task stub + + -- The caller has checked that the initial token is TASK and scanned + -- past it, so that Token is set to the token after TASK + + -- Error recovery: cannot raise Error_Resync + + function P_Task return Node_Id is + Aspect_Sloc : Source_Ptr := No_Location; + Name_Node : Node_Id; + Task_Node : Node_Id; + Task_Sloc : Source_Ptr; + + Dummy_Node : constant Node_Id := New_Node (N_Task_Body, Token_Ptr); + -- Placeholder node used to hold legal or prematurely declared aspect + -- specifications. Depending on the context, the aspect specifications + -- may be moved to a new node. + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Lreq := False; + Task_Sloc := Prev_Token_Ptr; + + if Token = Tok_Body then + Scan; -- past BODY + Name_Node := P_Defining_Identifier (C_Is); + Scope.Table (Scope.Last).Labl := Name_Node; + + if Token = Tok_Left_Paren then + Error_Msg_SC ("discriminant part not allowed in task body"); + Discard_Junk_List (P_Known_Discriminant_Part_Opt); + end if; + + if Aspect_Specifications_Present then + Aspect_Sloc := Token_Ptr; + P_Aspect_Specifications (Dummy_Node, Semicolon => False); + end if; + + TF_Is; + + -- Task stub + + if Token = Tok_Separate then + Scan; -- past SEPARATE + Task_Node := New_Node (N_Task_Body_Stub, Task_Sloc); + Set_Defining_Identifier (Task_Node, Name_Node); + + if Has_Aspects (Dummy_Node) then + Error_Msg + ("aspect specifications must come after SEPARATE", + Aspect_Sloc); + end if; + + P_Aspect_Specifications (Task_Node, Semicolon => False); + TF_Semicolon; + Pop_Scope_Stack; -- remove unused entry + + -- Task body + + else + Task_Node := New_Node (N_Task_Body, Task_Sloc); + Set_Defining_Identifier (Task_Node, Name_Node); + + -- Move the aspect specifications to the body node + + if Has_Aspects (Dummy_Node) then + Move_Aspects (From => Dummy_Node, To => Task_Node); + end if; + + Parse_Decls_Begin_End (Task_Node); + + -- The statement list of a task body needs to include at least a + -- null statement, so if a parsing error produces an empty list, + -- patch it now. + + if No (First (Statements + (Handled_Statement_Sequence (Task_Node)))) + then + Set_Statements (Handled_Statement_Sequence (Task_Node), + New_List (Make_Null_Statement (Token_Ptr))); + end if; + end if; + + return Task_Node; + + -- Otherwise we must have a task declaration + + else + if Token = Tok_Type then + Scan; -- past TYPE + Task_Node := New_Node (N_Task_Type_Declaration, Task_Sloc); + Name_Node := P_Defining_Identifier; + Set_Defining_Identifier (Task_Node, Name_Node); + Scope.Table (Scope.Last).Labl := Name_Node; + Set_Discriminant_Specifications + (Task_Node, P_Known_Discriminant_Part_Opt); + + else + Task_Node := New_Node (N_Single_Task_Declaration, Task_Sloc); + Name_Node := P_Defining_Identifier (C_Is); + Set_Defining_Identifier (Task_Node, Name_Node); + Scope.Table (Scope.Last).Labl := Name_Node; + + if Token = Tok_Left_Paren then + Error_Msg_SC ("discriminant part not allowed for single task"); + Discard_Junk_List (P_Known_Discriminant_Part_Opt); + end if; + end if; + + -- Scan aspect specifications, don't eat the semicolon, since it + -- might not be there if we have an IS. + + P_Aspect_Specifications (Task_Node, Semicolon => False); + + -- Parse optional task definition. Note that P_Task_Definition scans + -- out the semicolon and possible aspect specifications as well as + -- the task definition itself. + + if Token = Tok_Semicolon then + + -- A little check, if the next token after semicolon is Entry, + -- then surely the semicolon should really be IS + + Scan; -- past semicolon + + if Token = Tok_Entry then + Error_Msg_SP -- CODEFIX + ("|"";"" should be IS"); + Set_Task_Definition (Task_Node, P_Task_Definition); + else + Pop_Scope_Stack; -- Remove unused entry + end if; + + -- Here we have a task definition + + else + TF_Is; -- must have IS if no semicolon + + -- Ada 2005 (AI-345) + + if Token = Tok_New then + Scan; -- past NEW + + if Ada_Version < Ada_2005 then + Error_Msg_SP ("task interface is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + Set_Interface_List (Task_Node, New_List); + + loop + Append (P_Qualified_Simple_Name, Interface_List (Task_Node)); + exit when Token /= Tok_And; + Scan; -- past AND + end loop; + + if Token /= Tok_With then + Error_Msg_SC -- CODEFIX + ("WITH expected"); + end if; + + Scan; -- past WITH + + if Token = Tok_Private then + Error_Msg_SP -- CODEFIX + ("PRIVATE not allowed in task type declaration"); + end if; + end if; + + Set_Task_Definition (Task_Node, P_Task_Definition); + end if; + + return Task_Node; + end if; + end P_Task; + + -------------------------------- + -- 9.1 Task Type Declaration -- + -------------------------------- + + -- Parsed by P_Task (9.1) + + ---------------------------------- + -- 9.1 Single Task Declaration -- + ---------------------------------- + + -- Parsed by P_Task (9.1) + + -------------------------- + -- 9.1 Task Definition -- + -------------------------- + + -- TASK_DEFINITION ::= + -- {TASK_ITEM} + -- [private + -- {TASK_ITEM}] + -- end [task_IDENTIFIER]; + + -- The caller has already made the scope stack entry + + -- Note: there is a small deviation from official syntax here in that we + -- regard the semicolon after end as part of the Task_Definition, and in + -- the official syntax, it's part of the enclosing declaration. The reason + -- for this deviation is that otherwise the end processing would have to + -- be special cased, which would be a nuisance. + + -- Error recovery: cannot raise Error_Resync + + function P_Task_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := New_Node (N_Task_Definition, Token_Ptr); + Set_Visible_Declarations (Def_Node, P_Task_Items); + + if Token = Tok_Private then + Scan; -- past PRIVATE + Set_Private_Declarations (Def_Node, P_Task_Items); + + -- Deal gracefully with multiple PRIVATE parts + + while Token = Tok_Private loop + Error_Msg_SC ("only one private part allowed per task"); + Scan; -- past PRIVATE + Append_List (P_Task_Items, Private_Declarations (Def_Node)); + end loop; + end if; + + End_Statements (Def_Node); + return Def_Node; + end P_Task_Definition; + + -------------------- + -- 9.1 Task Item -- + -------------------- + + -- TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE + + -- This subprogram scans a (possibly empty) list of task items and pragmas + + -- Error recovery: cannot raise Error_Resync + + -- Note: a pragma can also be returned in this position + + function P_Task_Items return List_Id is + Items : List_Id; + Item_Node : Node_Id; + Decl_Sloc : Source_Ptr; + + begin + -- 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 + + SIS_Entry_Active := False; + + -- Loop to scan out task items + + Items := New_List; + + Decl_Loop : loop + Decl_Sloc := Token_Ptr; + + if Token = Tok_Pragma then + P_Pragmas_Opt (Items); + + -- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING may begin an + -- entry declaration. + + elsif Token = Tok_Entry + or else Token = Tok_Not + or else Token = Tok_Overriding + then + Append (P_Entry_Declaration, Items); + + elsif Token = Tok_For then + + -- Representation clause in task declaration. The only rep clause + -- which is legal in a protected declaration is an address clause, + -- so that is what we try to scan out. + + Item_Node := P_Representation_Clause; + + if Nkind (Item_Node) = N_At_Clause then + Append (Item_Node, Items); + + elsif Nkind (Item_Node) = N_Attribute_Definition_Clause + and then Chars (Item_Node) = Name_Address + then + Append (Item_Node, Items); + + else + Error_Msg + ("the only representation clause " & + "allowed here is an address clause!", Decl_Sloc); + end if; + + elsif Token = Tok_Identifier + or else Token in Token_Class_Declk + then + Error_Msg_SC ("illegal declaration in task definition"); + Resync_Past_Semicolon; + + else + exit Decl_Loop; + end if; + end loop Decl_Loop; + + return Items; + end P_Task_Items; + + -------------------- + -- 9.1 Task Body -- + -------------------- + + -- Parsed by P_Task (9.1) + + ---------------------------------- + -- 9.4 Protected (also 10.1.3) -- + ---------------------------------- + + -- PROTECTED_TYPE_DECLARATION ::= + -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] + -- [ASPECT_SPECIFICATIONS] + -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; + + -- SINGLE_PROTECTED_DECLARATION ::= + -- protected DEFINING_IDENTIFIER + -- [ASPECT_SPECIFICATIONS] + -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION; + + -- PROTECTED_BODY ::= + -- protected body DEFINING_IDENTIFIER + -- [ASPECT_SPECIFICATIONS] + -- is + -- {PROTECTED_OPERATION_ITEM} + -- end [protected_IDENTIFIER]; + + -- PROTECTED_BODY_STUB ::= + -- protected body DEFINING_IDENTIFIER is separate + -- [ASPECT_SPECIFICATIONS]; + + -- This routine scans out a protected declaration, protected body + -- or a protected stub. + + -- The caller has checked that the initial token is PROTECTED and + -- scanned past it, so Token is set to the following token. + + -- Error recovery: cannot raise Error_Resync + + function P_Protected return Node_Id is + Aspect_Sloc : Source_Ptr := No_Location; + Name_Node : Node_Id; + Protected_Node : Node_Id; + Protected_Sloc : Source_Ptr; + Scan_State : Saved_Scan_State; + + Dummy_Node : constant Node_Id := New_Node (N_Protected_Body, Token_Ptr); + -- Placeholder node used to hold legal or prematurely declared aspect + -- specifications. Depending on the context, the aspect specifications + -- may be moved to a new node. + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Lreq := False; + Protected_Sloc := Prev_Token_Ptr; + + if Token = Tok_Body then + Scan; -- past BODY + Name_Node := P_Defining_Identifier (C_Is); + Scope.Table (Scope.Last).Labl := Name_Node; + + if Token = Tok_Left_Paren then + Error_Msg_SC ("discriminant part not allowed in protected body"); + Discard_Junk_List (P_Known_Discriminant_Part_Opt); + end if; + + if Aspect_Specifications_Present then + Aspect_Sloc := Token_Ptr; + P_Aspect_Specifications (Dummy_Node, Semicolon => False); + end if; + + TF_Is; + + -- Protected stub + + if Token = Tok_Separate then + Scan; -- past SEPARATE + + Protected_Node := New_Node (N_Protected_Body_Stub, Protected_Sloc); + Set_Defining_Identifier (Protected_Node, Name_Node); + + if Has_Aspects (Dummy_Node) then + Error_Msg + ("aspect specifications must come after SEPARATE", + Aspect_Sloc); + end if; + + P_Aspect_Specifications (Protected_Node, Semicolon => False); + TF_Semicolon; + Pop_Scope_Stack; -- remove unused entry + + -- Protected body + + else + Protected_Node := New_Node (N_Protected_Body, Protected_Sloc); + Set_Defining_Identifier (Protected_Node, Name_Node); + + Move_Aspects (From => Dummy_Node, To => Protected_Node); + Set_Declarations (Protected_Node, P_Protected_Operation_Items); + End_Statements (Protected_Node); + end if; + + return Protected_Node; + + -- Otherwise we must have a protected declaration + + else + if Token = Tok_Type then + Scan; -- past TYPE + Protected_Node := + New_Node (N_Protected_Type_Declaration, Protected_Sloc); + Name_Node := P_Defining_Identifier (C_Is); + Set_Defining_Identifier (Protected_Node, Name_Node); + Scope.Table (Scope.Last).Labl := Name_Node; + Set_Discriminant_Specifications + (Protected_Node, P_Known_Discriminant_Part_Opt); + + else + Protected_Node := + New_Node (N_Single_Protected_Declaration, Protected_Sloc); + Name_Node := P_Defining_Identifier (C_Is); + Set_Defining_Identifier (Protected_Node, Name_Node); + + if Token = Tok_Left_Paren then + Error_Msg_SC + ("discriminant part not allowed for single protected"); + Discard_Junk_List (P_Known_Discriminant_Part_Opt); + end if; + + Scope.Table (Scope.Last).Labl := Name_Node; + end if; + + P_Aspect_Specifications (Protected_Node, Semicolon => False); + + -- Check for semicolon not followed by IS, this is something like + + -- protected type r; + + -- where we want + + -- protected type r IS END; + + if Token = Tok_Semicolon then + Save_Scan_State (Scan_State); -- at semicolon + Scan; -- past semicolon + + if Token /= Tok_Is then + Restore_Scan_State (Scan_State); + Error_Msg_SC -- CODEFIX + ("missing IS"); + Set_Protected_Definition (Protected_Node, + Make_Protected_Definition (Token_Ptr, + Visible_Declarations => Empty_List, + End_Label => Empty)); + + SIS_Entry_Active := False; + End_Statements + (Protected_Definition (Protected_Node), Protected_Node); + return Protected_Node; + end if; + + Error_Msg_SP -- CODEFIX + ("|extra ""("" ignored"); + end if; + + T_Is; + + -- Ada 2005 (AI-345) + + if Token = Tok_New then + Scan; -- past NEW + + if Ada_Version < Ada_2005 then + Error_Msg_SP ("protected interface is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + end if; + + Set_Interface_List (Protected_Node, New_List); + + loop + Append (P_Qualified_Simple_Name, + Interface_List (Protected_Node)); + + exit when Token /= Tok_And; + Scan; -- past AND + end loop; + + if Token /= Tok_With then + Error_Msg_SC -- CODEFIX + ("WITH expected"); + end if; + + Scan; -- past WITH + end if; + + Set_Protected_Definition (Protected_Node, P_Protected_Definition); + return Protected_Node; + end if; + end P_Protected; + + ------------------------------------- + -- 9.4 Protected Type Declaration -- + ------------------------------------- + + -- Parsed by P_Protected (9.4) + + --------------------------------------- + -- 9.4 Single Protected Declaration -- + --------------------------------------- + + -- Parsed by P_Protected (9.4) + + ------------------------------- + -- 9.4 Protected Definition -- + ------------------------------- + + -- PROTECTED_DEFINITION ::= + -- {PROTECTED_OPERATION_DECLARATION} + -- [private + -- {PROTECTED_ELEMENT_DECLARATION}] + -- end [protected_IDENTIFIER] + + -- PROTECTED_ELEMENT_DECLARATION ::= + -- PROTECTED_OPERATION_DECLARATION + -- | COMPONENT_DECLARATION + + -- The caller has already established the scope stack entry + + -- Error recovery: cannot raise Error_Resync + + function P_Protected_Definition return Node_Id is + Def_Node : Node_Id; + Item_Node : Node_Id; + Priv_Decls : List_Id; + Vis_Decls : List_Id; + + begin + Def_Node := New_Node (N_Protected_Definition, Token_Ptr); + + -- 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 + + SIS_Entry_Active := False; + + -- Loop to scan visible declarations (protected operation declarations) + + Vis_Decls := New_List; + Set_Visible_Declarations (Def_Node, Vis_Decls); + + -- Flag and discard all pragmas which cannot appear in the protected + -- definition. Note that certain pragmas are still allowed as long as + -- they apply to entries, entry families, or protected subprograms. + + P_Pragmas_Opt (Vis_Decls); + + loop + Item_Node := P_Protected_Operation_Declaration_Opt; + + if Present (Item_Node) then + Append (Item_Node, Vis_Decls); + end if; + + P_Pragmas_Opt (Vis_Decls); + + exit when No (Item_Node); + end loop; + + -- Deal with PRIVATE part (including graceful handling of multiple + -- PRIVATE parts). + + Private_Loop : while Token = Tok_Private loop + Priv_Decls := Private_Declarations (Def_Node); + + if Present (Priv_Decls) then + Error_Msg_SC ("duplicate private part"); + else + Priv_Decls := New_List; + Set_Private_Declarations (Def_Node, Priv_Decls); + end if; + + Scan; -- past PRIVATE + + -- Flag and discard all pragmas which cannot appear in the protected + -- definition. Note that certain pragmas are still allowed as long as + -- they apply to entries, entry families, or protected subprograms. + + P_Pragmas_Opt (Priv_Decls); + + Declaration_Loop : loop + if Token = Tok_Identifier then + P_Component_Items (Priv_Decls); + P_Pragmas_Opt (Priv_Decls); + + else + Item_Node := P_Protected_Operation_Declaration_Opt; + + if Present (Item_Node) then + Append (Item_Node, Priv_Decls); + end if; + + P_Pragmas_Opt (Priv_Decls); + + exit Declaration_Loop when No (Item_Node); + end if; + end loop Declaration_Loop; + end loop Private_Loop; + + End_Statements (Def_Node); + return Def_Node; + end P_Protected_Definition; + + ------------------------------------------ + -- 9.4 Protected Operation Declaration -- + ------------------------------------------ + + -- PROTECTED_OPERATION_DECLARATION ::= + -- SUBPROGRAM_DECLARATION + -- | ENTRY_DECLARATION + -- | REPRESENTATION_CLAUSE + + -- Error recovery: cannot raise Error_Resync + + -- Note: a pragma can also be returned in this position + + -- We are not currently permitting representation clauses to appear as + -- protected operation declarations, do we have to rethink this??? + + function P_Protected_Operation_Declaration_Opt return Node_Id is + L : List_Id; + P : Source_Ptr; + + function P_Entry_Or_Subprogram_With_Indicator return Node_Id; + -- Ada 2005 (AI-397): Parse an entry or a subprogram with an overriding + -- indicator. The caller has checked that the initial token is NOT or + -- OVERRIDING. + + ------------------------------------------ + -- P_Entry_Or_Subprogram_With_Indicator -- + ------------------------------------------ + + function P_Entry_Or_Subprogram_With_Indicator return Node_Id is + Decl : Node_Id := Error; + Is_Overriding : Boolean := False; + Not_Overriding : Boolean := False; + + begin + if Token = Tok_Not then + Scan; -- past NOT + + if Token = Tok_Overriding then + Scan; -- past OVERRIDING + Not_Overriding := True; + else + Error_Msg_SC -- CODEFIX + ("OVERRIDING expected!"); + end if; + + else + Scan; -- past OVERRIDING + Is_Overriding := True; + end if; + + if Is_Overriding or else Not_Overriding then + if Ada_Version < Ada_2005 then + Error_Msg_SP ("overriding indicator is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + + elsif Token = Tok_Entry then + Decl := P_Entry_Declaration; + + Set_Must_Override (Decl, Is_Overriding); + Set_Must_Not_Override (Decl, Not_Overriding); + + elsif Token = Tok_Function or else Token = Tok_Procedure then + Decl := P_Subprogram (Pf_Decl_Pexp); + + Set_Must_Override (Specification (Decl), Is_Overriding); + Set_Must_Not_Override (Specification (Decl), Not_Overriding); + + else + Error_Msg_SC -- CODEFIX + ("ENTRY, FUNCTION or PROCEDURE expected!"); + end if; + end if; + + return Decl; + end P_Entry_Or_Subprogram_With_Indicator; + + -- Start of processing for P_Protected_Operation_Declaration_Opt + + begin + -- This loop runs more than once only when a junk declaration + -- is skipped. + + loop + if Token = Tok_Pragma then + return P_Pragma; + + elsif Token = Tok_Not or else Token = Tok_Overriding then + return P_Entry_Or_Subprogram_With_Indicator; + + elsif Token = Tok_Entry then + return P_Entry_Declaration; + + elsif Token = Tok_Function or else Token = Tok_Procedure then + return P_Subprogram (Pf_Decl_Pexp); + + elsif Token = Tok_Identifier then + L := New_List; + P := Token_Ptr; + Skip_Declaration (L); + + if Nkind (First (L)) = N_Object_Declaration then + Error_Msg + ("component must be declared in private part of " & + "protected type", P); + else + Error_Msg + ("illegal declaration in protected definition", P); + end if; + + elsif Token in Token_Class_Declk then + Error_Msg_SC ("illegal declaration in protected definition"); + Resync_Past_Semicolon; + + -- Return now to avoid cascaded messages if next declaration + -- is a valid component declaration. + + return Error; + + elsif Token = Tok_For then + Error_Msg_SC + ("representation clause not allowed in protected definition"); + Resync_Past_Semicolon; + + else + return Empty; + end if; + end loop; + end P_Protected_Operation_Declaration_Opt; + + ----------------------------------- + -- 9.4 Protected Operation Item -- + ----------------------------------- + + -- PROTECTED_OPERATION_ITEM ::= + -- SUBPROGRAM_DECLARATION + -- | SUBPROGRAM_BODY + -- | ENTRY_BODY + -- | REPRESENTATION_CLAUSE + + -- This procedure parses and returns a list of protected operation items + + -- We are not currently permitting representation clauses to appear + -- as protected operation items, do we have to rethink this??? + + function P_Protected_Operation_Items return List_Id is + Item_List : List_Id; + + begin + Item_List := New_List; + + loop + if Token = Tok_Entry or else Bad_Spelling_Of (Tok_Entry) then + Append (P_Entry_Body, Item_List); + + -- If the operation starts with procedure, function, or an overriding + -- indicator ("overriding" or "not overriding"), parse a subprogram. + + elsif Token = Tok_Function or else Bad_Spelling_Of (Tok_Function) + or else + Token = Tok_Procedure or else Bad_Spelling_Of (Tok_Procedure) + or else + Token = Tok_Overriding or else Bad_Spelling_Of (Tok_Overriding) + or else + Token = Tok_Not or else Bad_Spelling_Of (Tok_Not) + then + Append (P_Subprogram (Pf_Decl_Pbod_Pexp), Item_List); + + elsif Token = Tok_Pragma or else Bad_Spelling_Of (Tok_Pragma) then + P_Pragmas_Opt (Item_List); + + elsif Token = Tok_Private or else Bad_Spelling_Of (Tok_Private) then + Error_Msg_SC ("PRIVATE not allowed in protected body"); + Scan; -- past PRIVATE + + elsif Token = Tok_Identifier then + Error_Msg_SC ("all components must be declared in spec!"); + Resync_Past_Semicolon; + + elsif Token in Token_Class_Declk then + Error_Msg_SC ("this declaration not allowed in protected body"); + Resync_Past_Semicolon; + + else + exit; + end if; + end loop; + + return Item_List; + end P_Protected_Operation_Items; + + ------------------------------ + -- 9.5.2 Entry Declaration -- + ------------------------------ + + -- ENTRY_DECLARATION ::= + -- [OVERRIDING_INDICATOR] + -- entry DEFINING_IDENTIFIER + -- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE + -- [ASPECT_SPECIFICATIONS]; + + -- The caller has checked that the initial token is ENTRY, NOT or + -- OVERRIDING. + + -- Error recovery: cannot raise Error_Resync + + function P_Entry_Declaration return Node_Id is + Decl_Node : Node_Id; + Scan_State : Saved_Scan_State; + + -- Flags for optional overriding indication. Two flags are needed, + -- to distinguish positive and negative overriding indicators from + -- the absence of any indicator. + + Is_Overriding : Boolean := False; + Not_Overriding : Boolean := False; + + begin + -- Ada 2005 (AI-397): Scan leading overriding indicator + + if Token = Tok_Not then + Scan; -- past NOT + + if Token = Tok_Overriding then + Scan; -- part OVERRIDING + Not_Overriding := True; + else + Error_Msg_SC -- CODEFIX + ("OVERRIDING expected!"); + end if; + + elsif Token = Tok_Overriding then + Scan; -- part OVERRIDING + Is_Overriding := True; + end if; + + if Is_Overriding or else Not_Overriding then + if Ada_Version < Ada_2005 then + Error_Msg_SP ("overriding indicator is an Ada 2005 extension"); + Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); + + elsif Token /= Tok_Entry then + Error_Msg_SC -- CODEFIX + ("ENTRY expected!"); + end if; + end if; + + Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr); + Scan; -- past ENTRY + + Set_Defining_Identifier + (Decl_Node, P_Defining_Identifier (C_Left_Paren_Semicolon)); + + -- If left paren, could be (Discrete_Subtype_Definition) or Formal_Part + + if Token = Tok_Left_Paren then + Scan; -- past ( + + -- If identifier after left paren, could still be either + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Scan; -- past Id + + -- If comma or colon after Id, must be Formal_Part + + if Token = Tok_Comma or else Token = Tok_Colon then + Restore_Scan_State (Scan_State); -- to Id + Set_Parameter_Specifications (Decl_Node, P_Formal_Part); + + -- Else if Id without comma or colon, must be discrete subtype + -- defn + + else + Restore_Scan_State (Scan_State); -- to Id + Set_Discrete_Subtype_Definition + (Decl_Node, P_Discrete_Subtype_Definition); + T_Right_Paren; + Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile); + end if; + + -- If no Id, must be discrete subtype definition + + else + Set_Discrete_Subtype_Definition + (Decl_Node, P_Discrete_Subtype_Definition); + T_Right_Paren; + Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile); + end if; + end if; + + if Is_Overriding then + Set_Must_Override (Decl_Node); + elsif Not_Overriding then + Set_Must_Not_Override (Decl_Node); + end if; + + -- Error recovery check for illegal return + + if Token = Tok_Return then + Error_Msg_SC ("entry cannot have return value!"); + Scan; + Discard_Junk_Node (P_Subtype_Indication); + end if; + + -- Error recovery check for improper use of entry barrier in spec + + if Token = Tok_When then + Error_Msg_SC ("barrier not allowed here (belongs in body)"); + Scan; -- past WHEN; + Discard_Junk_Node (P_Expression_No_Right_Paren); + end if; + + P_Aspect_Specifications (Decl_Node); + return Decl_Node; + + exception + when Error_Resync => + Resync_Past_Semicolon; + return Error; + end P_Entry_Declaration; + + ----------------------------- + -- 9.5.2 Accept Statement -- + ----------------------------- + + -- ACCEPT_STATEMENT ::= + -- accept entry_DIRECT_NAME + -- [(ENTRY_INDEX)] PARAMETER_PROFILE [do + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [entry_IDENTIFIER]]; + + -- The caller has checked that the initial token is ACCEPT + + -- Error recovery: cannot raise Error_Resync. If an error occurs, the + -- scan is resynchronized past the next semicolon and control returns. + + function P_Accept_Statement return Node_Id is + Scan_State : Saved_Scan_State; + Accept_Node : Node_Id; + Hand_Seq : Node_Id; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Ecol := Start_Column; + + Accept_Node := New_Node (N_Accept_Statement, Token_Ptr); + Scan; -- past ACCEPT + Scope.Table (Scope.Last).Labl := Token_Node; + + Set_Entry_Direct_Name (Accept_Node, P_Identifier (C_Do)); + + -- Left paren could be (Entry_Index) or Formal_Part, determine which + + if Token = Tok_Left_Paren then + Save_Scan_State (Scan_State); -- at left paren + Scan; -- past left paren + + -- If first token after left paren not identifier, then Entry_Index + + if Token /= Tok_Identifier then + Set_Entry_Index (Accept_Node, P_Expression); + T_Right_Paren; + Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile); + + -- First token after left paren is identifier, could be either case + + else -- Token = Tok_Identifier + Scan; -- past identifier + + -- If identifier followed by comma or colon, must be Formal_Part + + if Token = Tok_Comma or else Token = Tok_Colon then + Restore_Scan_State (Scan_State); -- to left paren + Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile); + + -- If identifier not followed by comma/colon, must be entry index + + else + Restore_Scan_State (Scan_State); -- to left paren + Scan; -- past left paren (again) + Set_Entry_Index (Accept_Node, P_Expression); + T_Right_Paren; + Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile); + end if; + end if; + end if; + + -- Scan out DO if present + + if Token = Tok_Do then + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Lreq := False; + Scan; -- past DO + Hand_Seq := P_Handled_Sequence_Of_Statements; + Set_Handled_Statement_Sequence (Accept_Node, Hand_Seq); + End_Statements (Handled_Statement_Sequence (Accept_Node)); + + -- Exception handlers not allowed in Ada 95 node + + if Present (Exception_Handlers (Hand_Seq)) then + if Ada_Version = Ada_83 then + Error_Msg_N + ("(Ada 83) exception handlers in accept not allowed", + First_Non_Pragma (Exception_Handlers (Hand_Seq))); + end if; + end if; + + else + Pop_Scope_Stack; -- discard unused entry + TF_Semicolon; + end if; + + return Accept_Node; + + -- If error, resynchronize past semicolon + + exception + when Error_Resync => + Resync_Past_Semicolon; + Pop_Scope_Stack; -- discard unused entry + return Error; + end P_Accept_Statement; + + ------------------------ + -- 9.5.2 Entry Index -- + ------------------------ + + -- Parsed by P_Expression (4.4) + + -------------------------- + -- 9.5.2 Entry Barrier -- + -------------------------- + + -- ENTRY_BARRIER ::= when CONDITION + + -- Error_Recovery: cannot raise Error_Resync + + function P_Entry_Barrier return Node_Id is + Bnode : Node_Id; + + begin + if Token = Tok_When then + Scan; -- past WHEN; + Bnode := P_Expression_No_Right_Paren; + + if Token = Tok_Colon_Equal then + Error_Msg_SC -- CODEFIX + ("|"":="" should be ""="""); + Scan; + Bnode := P_Expression_No_Right_Paren; + end if; + + else + T_When; -- to give error message + Bnode := Error; + end if; + + return Bnode; + end P_Entry_Barrier; + + ----------------------- + -- 9.5.2 Entry Body -- + ----------------------- + + -- ENTRY_BODY ::= + -- entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART + -- [ASPECT_SPECIFICATIONS] ENTRY_BARRIER + -- is + -- DECLARATIVE_PART + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [entry_IDENTIFIER]; + + -- The caller has checked that the initial token is ENTRY + + -- Error_Recovery: cannot raise Error_Resync + + function P_Entry_Body return Node_Id is + Dummy_Node : Node_Id; + Entry_Node : Node_Id; + Formal_Part_Node : Node_Id; + Name_Node : Node_Id; + + begin + Push_Scope_Stack; + Entry_Node := New_Node (N_Entry_Body, Token_Ptr); + Scan; -- past ENTRY + + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Lreq := False; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + + Name_Node := P_Defining_Identifier; + Set_Defining_Identifier (Entry_Node, Name_Node); + Scope.Table (Scope.Last).Labl := Name_Node; + + Formal_Part_Node := P_Entry_Body_Formal_Part; + Set_Entry_Body_Formal_Part (Entry_Node, Formal_Part_Node); + + -- Ada 2012 (AI12-0169): Aspect specifications may appear on an entry + -- body immediately after the formal part. Do not parse the aspect + -- specifications directly because the "when" of the entry barrier may + -- be interpreted as a misused "with". + + if Token = Tok_With then + P_Aspect_Specifications (Entry_Node, Semicolon => False); + end if; + + Set_Condition (Formal_Part_Node, P_Entry_Barrier); + + -- Detect an illegal placement of aspect specifications following the + -- entry barrier. + + -- entry E ... when Barrier with Aspect is + + if Token = Tok_With then + Error_Msg_SC ("aspect specifications must come before entry barrier"); + + -- Consume the illegal aspects to allow for parsing to continue + + Dummy_Node := New_Node (N_Entry_Body, Sloc (Entry_Node)); + P_Aspect_Specifications (Dummy_Node, Semicolon => False); + end if; + + TF_Is; + Parse_Decls_Begin_End (Entry_Node); + + return Entry_Node; + end P_Entry_Body; + + ----------------------------------- + -- 9.5.2 Entry Body Formal Part -- + ----------------------------------- + + -- ENTRY_BODY_FORMAL_PART ::= + -- [(ENTRY_INDEX_SPECIFICATION)] [PARAMETER_PART] + + -- Error_Recovery: cannot raise Error_Resync + + function P_Entry_Body_Formal_Part return Node_Id is + Fpart_Node : Node_Id; + Scan_State : Saved_Scan_State; + + begin + Fpart_Node := New_Node (N_Entry_Body_Formal_Part, Token_Ptr); + + -- See if entry index specification present, and if so parse it + + if Token = Tok_Left_Paren then + Save_Scan_State (Scan_State); -- at left paren + Scan; -- past left paren + + if Token = Tok_For then + Set_Entry_Index_Specification + (Fpart_Node, P_Entry_Index_Specification); + T_Right_Paren; + else + Restore_Scan_State (Scan_State); -- to left paren + end if; + + -- Check for (common?) case of left paren omitted before FOR. This + -- is a tricky case, because the corresponding missing left paren + -- can cause real havoc if a formal part is present which gets + -- treated as part of the discrete subtype definition of the + -- entry index specification, so just give error and resynchronize + + elsif Token = Tok_For then + T_Left_Paren; -- to give error message + Resync_To_When; + end if; + + Set_Parameter_Specifications (Fpart_Node, P_Parameter_Profile); + return Fpart_Node; + end P_Entry_Body_Formal_Part; + + -------------------------------------- + -- 9.5.2 Entry Index Specification -- + -------------------------------------- + + -- ENTRY_INDEX_SPECIFICATION ::= + -- for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION + + -- Error recovery: can raise Error_Resync + + function P_Entry_Index_Specification return Node_Id is + Iterator_Node : Node_Id; + + begin + Iterator_Node := New_Node (N_Entry_Index_Specification, Token_Ptr); + T_For; -- past FOR + Set_Defining_Identifier (Iterator_Node, P_Defining_Identifier (C_In)); + T_In; + Set_Discrete_Subtype_Definition + (Iterator_Node, P_Discrete_Subtype_Definition); + return Iterator_Node; + end P_Entry_Index_Specification; + + --------------------------------- + -- 9.5.3 Entry Call Statement -- + --------------------------------- + + -- Parsed by P_Name (4.1). Within a select, an entry call is parsed + -- by P_Select_Statement (9.7) + + ------------------------------ + -- 9.5.4 Requeue Statement -- + ------------------------------ + + -- REQUEUE_STATEMENT ::= requeue entry_NAME [with abort]; + + -- The caller has checked that the initial token is requeue + + -- Error recovery: can raise Error_Resync + + function P_Requeue_Statement return Node_Id is + Requeue_Node : Node_Id; + + begin + Requeue_Node := New_Node (N_Requeue_Statement, Token_Ptr); + Scan; -- past REQUEUE + Set_Name (Requeue_Node, P_Name); + + if Token = Tok_With then + Scan; -- past WITH + T_Abort; + Set_Abort_Present (Requeue_Node, True); + end if; + + TF_Semicolon; + return Requeue_Node; + end P_Requeue_Statement; + + -------------------------- + -- 9.6 Delay Statement -- + -------------------------- + + -- DELAY_STATEMENT ::= + -- DELAY_UNTIL_STATEMENT + -- | DELAY_RELATIVE_STATEMENT + + -- The caller has checked that the initial token is DELAY + + -- Error recovery: cannot raise Error_Resync + + function P_Delay_Statement return Node_Id is + begin + Scan; -- past DELAY + + -- The following check for delay until misused in Ada 83 doesn't catch + -- all cases, but it's good enough to catch most of them. + + if Token_Name = Name_Until then + Check_95_Keyword (Tok_Until, Tok_Left_Paren); + Check_95_Keyword (Tok_Until, Tok_Identifier); + end if; + + if Token = Tok_Until then + return P_Delay_Until_Statement; + else + return P_Delay_Relative_Statement; + end if; + end P_Delay_Statement; + + -------------------------------- + -- 9.6 Delay Until Statement -- + -------------------------------- + + -- DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION; + + -- The caller has checked that the initial token is DELAY, scanned it + -- out and checked that the current token is UNTIL + + -- Error recovery: cannot raise Error_Resync + + function P_Delay_Until_Statement return Node_Id is + Delay_Node : Node_Id; + + begin + Delay_Node := New_Node (N_Delay_Until_Statement, Prev_Token_Ptr); + Scan; -- past UNTIL + Set_Expression (Delay_Node, P_Expression_No_Right_Paren); + TF_Semicolon; + return Delay_Node; + end P_Delay_Until_Statement; + + ----------------------------------- + -- 9.6 Delay Relative Statement -- + ----------------------------------- + + -- DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION; + + -- The caller has checked that the initial token is DELAY, scanned it + -- out and determined that the current token is not UNTIL + + -- Error recovery: cannot raise Error_Resync + + function P_Delay_Relative_Statement return Node_Id is + Delay_Node : Node_Id; + + begin + Delay_Node := New_Node (N_Delay_Relative_Statement, Prev_Token_Ptr); + Set_Expression (Delay_Node, P_Expression_No_Right_Paren); + Check_Simple_Expression_In_Ada_83 (Expression (Delay_Node)); + TF_Semicolon; + return Delay_Node; + end P_Delay_Relative_Statement; + + --------------------------- + -- 9.7 Select Statement -- + --------------------------- + + -- SELECT_STATEMENT ::= + -- SELECTIVE_ACCEPT + -- | TIMED_ENTRY_CALL + -- | CONDITIONAL_ENTRY_CALL + -- | ASYNCHRONOUS_SELECT + + -- SELECTIVE_ACCEPT ::= + -- select + -- [GUARD] + -- SELECT_ALTERNATIVE + -- {or + -- [GUARD] + -- SELECT_ALTERNATIVE + -- [else + -- SEQUENCE_OF_STATEMENTS] + -- end select; + + -- GUARD ::= when CONDITION => + + -- Note: the guard preceding a select alternative is included as part + -- of the node generated for a selective accept alternative. + + -- SELECT_ALTERNATIVE ::= + -- ACCEPT_ALTERNATIVE + -- | DELAY_ALTERNATIVE + -- | TERMINATE_ALTERNATIVE + + -- TIMED_ENTRY_CALL ::= + -- select + -- ENTRY_CALL_ALTERNATIVE + -- or + -- DELAY_ALTERNATIVE + -- end select; + + -- CONDITIONAL_ENTRY_CALL ::= + -- select + -- ENTRY_CALL_ALTERNATIVE + -- else + -- SEQUENCE_OF_STATEMENTS + -- end select; + + -- ENTRY_CALL_ALTERNATIVE ::= + -- ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- ASYNCHRONOUS_SELECT ::= + -- select + -- TRIGGERING_ALTERNATIVE + -- then abort + -- ABORTABLE_PART + -- end select; + + -- TRIGGERING_ALTERNATIVE ::= + -- TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT + + -- The caller has checked that the initial token is SELECT + + -- Error recovery: can raise Error_Resync + + function P_Select_Statement return Node_Id is + Select_Node : Node_Id; + Select_Sloc : Source_Ptr; + Stmnt_Sloc : Source_Ptr; + Ecall_Node : Node_Id; + Alternative : Node_Id; + Select_Pragmas : List_Id; + Alt_Pragmas : List_Id; + Statement_List : List_Id; + Alt_List : List_Id; + Cond_Expr : Node_Id; + Delay_Stmnt : Node_Id; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Select; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Labl := Error; + + Select_Sloc := Token_Ptr; + Scan; -- past SELECT + Stmnt_Sloc := Token_Ptr; + Select_Pragmas := P_Pragmas_Opt; + + -- If first token after select is designator, then we have an entry + -- call, which must be the start of a conditional entry call, timed + -- entry call or asynchronous select + + if Token in Token_Class_Desig then + + -- Scan entry call statement + + begin + Ecall_Node := P_Name; + + -- ?? The following two clauses exactly parallel code in ch5 + -- and should be combined sometime + + if Nkind (Ecall_Node) = N_Indexed_Component then + declare + Prefix_Node : constant Node_Id := Prefix (Ecall_Node); + Exprs_Node : constant List_Id := Expressions (Ecall_Node); + + begin + Change_Node (Ecall_Node, N_Procedure_Call_Statement); + Set_Name (Ecall_Node, Prefix_Node); + Set_Parameter_Associations (Ecall_Node, Exprs_Node); + end; + + elsif Nkind (Ecall_Node) = N_Function_Call then + declare + Fname_Node : constant Node_Id := Name (Ecall_Node); + Params_List : constant List_Id := + Parameter_Associations (Ecall_Node); + + begin + Change_Node (Ecall_Node, N_Procedure_Call_Statement); + Set_Name (Ecall_Node, Fname_Node); + Set_Parameter_Associations (Ecall_Node, Params_List); + end; + + elsif Nkind (Ecall_Node) = N_Identifier + or else Nkind (Ecall_Node) = N_Selected_Component + then + -- Case of a call to a parameterless entry + + declare + C_Node : constant Node_Id := + New_Node (N_Procedure_Call_Statement, Stmnt_Sloc); + begin + Set_Name (C_Node, Ecall_Node); + Set_Parameter_Associations (C_Node, No_List); + Ecall_Node := C_Node; + end; + end if; + + TF_Semicolon; + + exception + when Error_Resync => + Resync_Past_Semicolon; + return Error; + end; + + Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm); + + -- OR follows, we have a timed entry call + + if Token = Tok_Or then + Scan; -- past OR + Alt_Pragmas := P_Pragmas_Opt; + + Select_Node := New_Node (N_Timed_Entry_Call, Select_Sloc); + Set_Entry_Call_Alternative (Select_Node, + Make_Entry_Call_Alternative (Stmnt_Sloc, + Entry_Call_Statement => Ecall_Node, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List)); + + -- Only possibility is delay alternative. If we have anything + -- else, give message, and treat as conditional entry call. + + if Token /= Tok_Delay then + Error_Msg_SC + ("only allowed alternative in timed entry call is delay!"); + Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); + Set_Delay_Alternative (Select_Node, Error); + + else + Set_Delay_Alternative (Select_Node, P_Delay_Alternative); + Set_Pragmas_Before + (Delay_Alternative (Select_Node), Alt_Pragmas); + end if; + + -- ELSE follows, we have a conditional entry call + + elsif Token = Tok_Else then + Scan; -- past ELSE + Select_Node := New_Node (N_Conditional_Entry_Call, Select_Sloc); + + Set_Entry_Call_Alternative (Select_Node, + Make_Entry_Call_Alternative (Stmnt_Sloc, + Entry_Call_Statement => Ecall_Node, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List)); + + Set_Else_Statements + (Select_Node, P_Sequence_Of_Statements (SS_Sreq)); + + -- Only remaining case is THEN ABORT (asynchronous select) + + elsif Token = Tok_Abort then + Select_Node := + Make_Asynchronous_Select (Select_Sloc, + Triggering_Alternative => + Make_Triggering_Alternative (Stmnt_Sloc, + Triggering_Statement => Ecall_Node, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List), + Abortable_Part => P_Abortable_Part); + + -- Else error + + else + if Ada_Version = Ada_83 then + Error_Msg_BC ("OR or ELSE expected"); + else + Error_Msg_BC ("OR or ELSE or THEN ABORT expected"); + end if; + + Select_Node := Error; + end if; + + End_Statements; + + -- Here we have a selective accept or an asynchronous select (first + -- token after SELECT is other than a designator token). + + else + -- If we have delay with no guard, could be asynchronous select + + if Token = Tok_Delay then + Delay_Stmnt := P_Delay_Statement; + Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm); + + -- Asynchronous select + + if Token = Tok_Abort then + Select_Node := + Make_Asynchronous_Select (Select_Sloc, + Triggering_Alternative => + Make_Triggering_Alternative (Stmnt_Sloc, + Triggering_Statement => Delay_Stmnt, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List), + Abortable_Part => P_Abortable_Part); + + End_Statements; + return Select_Node; + + -- Delay which was not an asynchronous select. Must be a selective + -- accept, and since at least one accept statement is required, + -- we must have at least one OR phrase present. + + else + Alt_List := New_List ( + Make_Delay_Alternative (Stmnt_Sloc, + Delay_Statement => Delay_Stmnt, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List)); + T_Or; + Alt_Pragmas := P_Pragmas_Opt; + end if; + + -- If not a delay statement, then must be another possibility for + -- a selective accept alternative, or perhaps a guard is present + + else + Alt_List := New_List; + Alt_Pragmas := Select_Pragmas; + end if; + + Select_Node := New_Node (N_Selective_Accept, Select_Sloc); + Set_Select_Alternatives (Select_Node, Alt_List); + + -- Scan out selective accept alternatives. On entry to this loop, + -- we are just past a SELECT or OR token, and any pragmas that + -- immediately follow the SELECT or OR are in Alt_Pragmas. + + loop + if Token = Tok_When then + + if Present (Alt_Pragmas) then + Error_Msg_SC ("pragmas may not precede guard"); + end if; + + Scan; -- past WHEN + Cond_Expr := P_Expression_No_Right_Paren; + T_Arrow; + Alt_Pragmas := P_Pragmas_Opt; + + else + Cond_Expr := Empty; + end if; + + if Token = Tok_Accept then + Alternative := P_Accept_Alternative; + + -- Check for junk attempt at asynchronous select using + -- an Accept alternative as the triggering statement + + if Token = Tok_Abort + and then Is_Empty_List (Alt_List) + and then No (Cond_Expr) + then + Error_Msg + ("triggering statement must be entry call or delay", + Sloc (Alternative)); + Scan; -- past junk ABORT + Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); + End_Statements; + return Error; + end if; + + elsif Token = Tok_Delay then + Alternative := P_Delay_Alternative; + + elsif Token = Tok_Terminate then + Alternative := P_Terminate_Alternative; + + else + Error_Msg_SC + ("select alternative (ACCEPT, ABORT, DELAY) expected"); + Alternative := Error; + + if Token = Tok_Semicolon then + Scan; -- past junk semicolon + end if; + end if; + + -- THEN ABORT at this stage is just junk + + if Token = Tok_Abort then + Error_Msg_SP ("misplaced `THEN ABORT`"); + Scan; -- past junk ABORT + Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); + End_Statements; + return Error; + + else + if Alternative /= Error then + Set_Condition (Alternative, Cond_Expr); + Set_Pragmas_Before (Alternative, Alt_Pragmas); + Append (Alternative, Alt_List); + end if; + + exit when Token /= Tok_Or; + end if; + + T_Or; + Alt_Pragmas := P_Pragmas_Opt; + end loop; + + if Token = Tok_Else then + Scan; -- past ELSE + Set_Else_Statements + (Select_Node, P_Sequence_Of_Statements (SS_Ortm_Sreq)); + + if Token = Tok_Or then + Error_Msg_SC ("select alternative cannot follow else part!"); + end if; + end if; + + End_Statements; + end if; + + return Select_Node; + end P_Select_Statement; + + ----------------------------- + -- 9.7.1 Selective Accept -- + ----------------------------- + + -- Parsed by P_Select_Statement (9.7) + + ------------------ + -- 9.7.1 Guard -- + ------------------ + + -- Parsed by P_Select_Statement (9.7) + + ------------------------------- + -- 9.7.1 Select Alternative -- + ------------------------------- + + -- SELECT_ALTERNATIVE ::= + -- ACCEPT_ALTERNATIVE + -- | DELAY_ALTERNATIVE + -- | TERMINATE_ALTERNATIVE + + -- Note: the guard preceding a select alternative is included as part + -- of the node generated for a selective accept alternative. + + -- Error recovery: cannot raise Error_Resync + + ------------------------------- + -- 9.7.1 Accept Alternative -- + ------------------------------- + + -- ACCEPT_ALTERNATIVE ::= + -- ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- Error_Recovery: Cannot raise Error_Resync + + -- Note: the caller is responsible for setting the Pragmas_Before + -- field of the returned N_Terminate_Alternative node. + + function P_Accept_Alternative return Node_Id is + Accept_Alt_Node : Node_Id; + + begin + Accept_Alt_Node := New_Node (N_Accept_Alternative, Token_Ptr); + Set_Accept_Statement (Accept_Alt_Node, P_Accept_Statement); + + -- Note: the reason that we accept THEN ABORT as a terminator for + -- the sequence of statements is for error recovery which allows + -- for misuse of an accept statement as a triggering statement. + + Set_Statements + (Accept_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm)); + return Accept_Alt_Node; + end P_Accept_Alternative; + + ------------------------------ + -- 9.7.1 Delay Alternative -- + ------------------------------ + + -- DELAY_ALTERNATIVE ::= + -- DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- Error_Recovery: Cannot raise Error_Resync + + -- Note: the caller is responsible for setting the Pragmas_Before + -- field of the returned N_Terminate_Alternative node. + + function P_Delay_Alternative return Node_Id is + Delay_Alt_Node : Node_Id; + + begin + Delay_Alt_Node := New_Node (N_Delay_Alternative, Token_Ptr); + Set_Delay_Statement (Delay_Alt_Node, P_Delay_Statement); + + -- Note: the reason that we accept THEN ABORT as a terminator for + -- the sequence of statements is for error recovery which allows + -- for misuse of an accept statement as a triggering statement. + + Set_Statements + (Delay_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm)); + return Delay_Alt_Node; + end P_Delay_Alternative; + + ---------------------------------- + -- 9.7.1 Terminate Alternative -- + ---------------------------------- + + -- TERMINATE_ALTERNATIVE ::= terminate; + + -- Error_Recovery: Cannot raise Error_Resync + + -- Note: the caller is responsible for setting the Pragmas_Before + -- field of the returned N_Terminate_Alternative node. + + function P_Terminate_Alternative return Node_Id is + Terminate_Alt_Node : Node_Id; + + begin + Terminate_Alt_Node := New_Node (N_Terminate_Alternative, Token_Ptr); + Scan; -- past TERMINATE + TF_Semicolon; + + -- For all other select alternatives, the sequence of statements + -- after the alternative statement will swallow up any pragmas + -- coming in this position. But the terminate alternative has no + -- sequence of statements, so the pragmas here must be treated + -- specially. + + Set_Pragmas_After (Terminate_Alt_Node, P_Pragmas_Opt); + return Terminate_Alt_Node; + end P_Terminate_Alternative; + + ----------------------------- + -- 9.7.2 Timed Entry Call -- + ----------------------------- + + -- Parsed by P_Select_Statement (9.7) + + ----------------------------------- + -- 9.7.2 Entry Call Alternative -- + ----------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + ----------------------------------- + -- 9.7.3 Conditional Entry Call -- + ----------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + -------------------------------- + -- 9.7.4 Asynchronous Select -- + -------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + ----------------------------------- + -- 9.7.4 Triggering Alternative -- + ----------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + --------------------------------- + -- 9.7.4 Triggering Statement -- + --------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + --------------------------- + -- 9.7.4 Abortable Part -- + --------------------------- + + -- ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS + + -- The caller has verified that THEN ABORT is present, and Token is + -- pointing to the ABORT on entry (or if not, then we have an error) + + -- Error recovery: cannot raise Error_Resync + + function P_Abortable_Part return Node_Id is + Abortable_Part_Node : Node_Id; + + begin + Abortable_Part_Node := New_Node (N_Abortable_Part, Token_Ptr); + T_Abort; -- scan past ABORT + + if Ada_Version = Ada_83 then + Error_Msg_SP ("(Ada 83) asynchronous select not allowed!"); + end if; + + Set_Statements (Abortable_Part_Node, P_Sequence_Of_Statements (SS_Sreq)); + return Abortable_Part_Node; + end P_Abortable_Part; + + -------------------------- + -- 9.8 Abort Statement -- + -------------------------- + + -- ABORT_STATEMENT ::= abort task_NAME {, task_NAME}; + + -- The caller has checked that the initial token is ABORT + + -- Error recovery: cannot raise Error_Resync + + function P_Abort_Statement return Node_Id is + Abort_Node : Node_Id; + + begin + Abort_Node := New_Node (N_Abort_Statement, Token_Ptr); + Scan; -- past ABORT + Set_Names (Abort_Node, New_List); + + loop + Append (P_Name, Names (Abort_Node)); + exit when Token /= Tok_Comma; + Scan; -- past comma + end loop; + + TF_Semicolon; + return Abort_Node; + end P_Abort_Statement; + +end Ch9;