| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P A R . C H 9 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, 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; |
| Scopes (Scope.Last).Etyp := E_Name; |
| Scopes (Scope.Last).Ecol := Start_Column; |
| Scopes (Scope.Last).Sloc := Token_Ptr; |
| Scopes (Scope.Last).Lreq := False; |
| Task_Sloc := Prev_Token_Ptr; |
| |
| if Token = Tok_Body then |
| Scan; -- past BODY |
| Name_Node := P_Defining_Identifier (C_Is); |
| Scopes (Scope.Last).Labl := Name_Node; |
| Current_Node := 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); |
| Scopes (Scope.Last).Labl := Name_Node; |
| Current_Node := 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); |
| Scopes (Scope.Last).Labl := Name_Node; |
| Current_Node := 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 |
| |
| Error_Msg_Ada_2005_Extension ("task interface"); |
| |
| 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 in Tok_Entry | Tok_Not | 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; |
| Scopes (Scope.Last).Etyp := E_Name; |
| Scopes (Scope.Last).Ecol := Start_Column; |
| Scopes (Scope.Last).Lreq := False; |
| Protected_Sloc := Prev_Token_Ptr; |
| |
| if Token = Tok_Body then |
| Scan; -- past BODY |
| Name_Node := P_Defining_Identifier (C_Is); |
| Scopes (Scope.Last).Labl := Name_Node; |
| Current_Node := 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); |
| Scopes (Scope.Last).Labl := Name_Node; |
| Current_Node := 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; |
| |
| Scopes (Scope.Last).Labl := Name_Node; |
| Current_Node := 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 |
| |
| Error_Msg_Ada_2005_Extension ("protected interface"); |
| |
| 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_Ada_2005_Extension ("overriding indicator"); |
| |
| elsif Token = Tok_Entry then |
| Decl := P_Entry_Declaration; |
| |
| Set_Must_Override (Decl, Is_Overriding); |
| Set_Must_Not_Override (Decl, Not_Overriding); |
| |
| elsif Token in Tok_Function | 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; |
| |
| Result : Node_Id := Empty; |
| |
| -- Start of processing for P_Protected_Operation_Declaration_Opt |
| |
| begin |
| -- This loop runs more than once only when a junk declaration is skipped |
| |
| loop |
| case Token is |
| when Tok_Pragma => |
| Result := P_Pragma; |
| exit; |
| |
| when Tok_Not |
| | Tok_Overriding |
| => |
| Result := P_Entry_Or_Subprogram_With_Indicator; |
| exit; |
| |
| when Tok_Entry => |
| Result := P_Entry_Declaration; |
| exit; |
| |
| when Tok_Function |
| | Tok_Procedure |
| => |
| Result := P_Subprogram (Pf_Decl_Pexp); |
| exit; |
| |
| when Tok_Identifier => |
| 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; |
| -- Continue looping |
| |
| when Tok_For => |
| Error_Msg_SC |
| ("representation clause not allowed in protected definition"); |
| Resync_Past_Semicolon; |
| -- Continue looping |
| |
| when others => |
| if 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. |
| |
| Result := Error; |
| end if; |
| |
| exit; |
| end case; |
| end loop; |
| |
| if Nkind (Result) = N_Subprogram_Declaration |
| and then Nkind (Specification (Result)) = |
| N_Procedure_Specification |
| and then Null_Present (Specification (Result)) |
| then |
| Error_Msg_N |
| ("protected operation cannot be a null procedure", |
| Null_Statement (Specification (Result))); |
| end if; |
| |
| return Result; |
| 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 ("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_Ada_2005_Extension ("overriding indicator"); |
| 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 in Tok_Comma | 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; |
| Scopes (Scope.Last).Sloc := Token_Ptr; |
| Scopes (Scope.Last).Ecol := Start_Column; |
| |
| Accept_Node := New_Node (N_Accept_Statement, Token_Ptr); |
| Scan; -- past ACCEPT |
| Scopes (Scope.Last).Labl := Token_Node; |
| Current_Node := 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 in Tok_Comma | 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 |
| Scopes (Scope.Last).Etyp := E_Name; |
| Scopes (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 |
| |
| Scopes (Scope.Last).Ecol := Start_Column; |
| Scopes (Scope.Last).Lreq := False; |
| Scopes (Scope.Last).Etyp := E_Name; |
| Scopes (Scope.Last).Sloc := Token_Ptr; |
| |
| Name_Node := P_Defining_Identifier; |
| Set_Defining_Identifier (Entry_Node, Name_Node); |
| Scopes (Scope.Last).Labl := Name_Node; |
| Current_Node := 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 |
| -- [ASPECT_SPECIFICATION] |
| |
| -- 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); |
| |
| if Token = Tok_With then |
| P_Aspect_Specifications (Iterator_Node, False); |
| end if; |
| |
| 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; |
| Scopes (Scope.Last).Etyp := E_Select; |
| Scopes (Scope.Last).Ecol := Start_Column; |
| Scopes (Scope.Last).Sloc := Token_Ptr; |
| Scopes (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; |
