diff options
Diffstat (limited to 'gcc/ada/par-ch5.adb')
| -rw-r--r-- | gcc/ada/par-ch5.adb | 2184 |
1 files changed, 2184 insertions, 0 deletions
diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb new file mode 100644 index 00000000000..2ec56726e6b --- /dev/null +++ b/gcc/ada/par-ch5.adb @@ -0,0 +1,2184 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 5 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.95 $ +-- -- +-- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +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 Ch5 is + + -- Local functions, used only in this chapter + + function P_Case_Statement return Node_Id; + function P_Case_Statement_Alternative return Node_Id; + function P_Condition return Node_Id; + function P_Exit_Statement return Node_Id; + function P_Goto_Statement return Node_Id; + function P_If_Statement return Node_Id; + function P_Label return Node_Id; + function P_Loop_Parameter_Specification return Node_Id; + function P_Null_Statement return Node_Id; + + function P_Assignment_Statement (LHS : Node_Id) return Node_Id; + -- Parse assignment statement. On entry, the caller has scanned the left + -- hand side (passed in as Lhs), and the colon-equal (or some symbol + -- taken to be an error equivalent such as equal). + + function P_Begin_Statement (Block_Name : Node_Id := Empty) return Node_Id; + -- Parse begin-end statement. If Block_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the block. If Block_Name is + -- Empty on entry (the default), then the block statement is unlabeled. + + function P_Declare_Statement (Block_Name : Node_Id := Empty) return Node_Id; + -- Parse declare block. If Block_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the block. If Block_Name is + -- Empty on entry (the default), then the block statement is unlabeled. + + function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id; + -- Parse for statement. If Loop_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the loop. If Loop_Name is + -- Empty on entry (the default), then the for statement is unlabeled. + + function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id; + -- Parse loop statement. If Loop_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the loop. If Loop_Name is + -- Empty on entry (the default), then the loop statement is unlabeled. + + function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id; + -- Parse while statement. If Loop_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the loop. If Loop_Name is + -- Empty on entry (the default), then the while statement is unlabeled. + + function Set_Loop_Block_Name (L : Character) return Name_Id; + -- Given a letter 'L' for a loop or 'B' for a block, returns a name + -- of the form L_nn or B_nn where nn is a serial number obtained by + -- incrementing the variable Loop_Block_Count. + + procedure Then_Scan; + -- Scan past THEN token, testing for illegal junk after it + + --------------------------------- + -- 5.1 Sequence of Statements -- + --------------------------------- + + -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} + + -- STATEMENT ::= + -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT + + -- SIMPLE_STATEMENT ::= NULL_STATEMENT + -- | ASSIGNMENT_STATEMENT | EXIT_STATEMENT + -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT + -- | RETURN_STATEMENT | ENTRY_CALL_STATEMENT + -- | REQUEUE_STATEMENT | DELAY_STATEMENT + -- | ABORT_STATEMENT | RAISE_STATEMENT + -- | CODE_STATEMENT + + -- COMPOUND_STATEMENT ::= + -- IF_STATEMENT | CASE_STATEMENT + -- | LOOP_STATEMENT | BLOCK_STATEMENT + -- | ACCEPT_STATEMENT | SELECT_STATEMENT + + -- This procedure scans a sequence of statements. The caller sets SS_Flags + -- to indicate acceptable termination conditions for the sequence: + + -- SS_Flags.Eftm Terminate on ELSIF + -- SS_Flags.Eltm Terminate on ELSE + -- SS_Flags.Extm Terminate on EXCEPTION + -- SS_Flags.Ortm Terminate on OR + -- SS_Flags.Tatm Terminate on THEN ABORT (Token = ABORT on return) + -- SS_Flags.Whtm Terminate on WHEN + -- SS_Flags.Unco Unconditional terminate after scanning one statement + + -- In addition, the scan is always terminated by encountering END or the + -- end of file (EOF) condition. If one of the six above terminators is + -- encountered with the corresponding SS_Flags flag not set, then the + -- action taken is as follows: + + -- If the keyword occurs to the left of the expected column of the end + -- for the current sequence (as recorded in the current end context), + -- then it is assumed to belong to an outer context, and is considered + -- to terminate the sequence of statements. + + -- If the keyword occurs to the right of, or in the expected column of + -- the end for the current sequence, then an error message is output, + -- the keyword together with its associated context is skipped, and + -- the statement scan continues until another terminator is found. + + -- Note that the first action means that control can return to the caller + -- with Token set to a terminator other than one of those specified by the + -- SS parameter. The caller should treat such a case as equivalent to END. + + -- In addition, the flag SS_Flags.Sreq is set to True to indicate that at + -- least one real statement (other than a pragma) is required in the + -- statement sequence. During the processing of the sequence, this + -- flag is manipulated to indicate the current status of the requirement + -- for a statement. For example, it is turned off by the occurrence of a + -- statement, and back on by a label (which requires a following statement) + + -- Error recovery: cannot raise Error_Resync. If an error occurs during + -- parsing a statement, then the scan pointer is advanced past the next + -- semicolon and the parse continues. + + function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id is + + Statement_Required : Boolean; + -- This flag indicates if a subsequent statement (other than a pragma) + -- is required. It is initialized from the Sreq flag, and modified as + -- statements are scanned (a statement turns it off, and a label turns + -- it back on again since a statement must follow a label). + + Declaration_Found : Boolean := False; + -- This flag is set True if a declaration is encountered, so that the + -- error message about declarations in the statement part is only + -- given once for a given sequence of statements. + + Scan_State_Label : Saved_Scan_State; + Scan_State : Saved_Scan_State; + + Statement_List : List_Id; + Block_Label : Name_Id; + Id_Node : Node_Id; + Name_Node : Node_Id; + + procedure Junk_Declaration; + -- Procedure called to handle error of declaration encountered in + -- statement sequence. + + procedure Test_Statement_Required; + -- Flag error if Statement_Required flag set + + procedure Junk_Declaration is + begin + if (not Declaration_Found) or All_Errors_Mode then + Error_Msg_SC ("declarations must come before BEGIN"); + Declaration_Found := True; + end if; + + Skip_Declaration (Statement_List); + end Junk_Declaration; + + procedure Test_Statement_Required is + begin + if Statement_Required then + Error_Msg_BC ("statement expected"); + end if; + end Test_Statement_Required; + + -- Start of processing for P_Sequence_Of_Statements + + begin + Statement_List := New_List; + Statement_Required := SS_Flags.Sreq; + + loop + while Token = Tok_Semicolon loop + Error_Msg_SC ("unexpected semicolon ignored"); + Scan; -- past junk semicolon + end loop; + + begin + if Style_Check then Style.Check_Indentation; end if; + + -- Deal with reserved identifier (in assignment or call) + + if Is_Reserved_Identifier then + Save_Scan_State (Scan_State); -- at possible bad identifier + Scan; -- and scan past it + + -- We have an reserved word which is spelled in identifier + -- style, so the question is whether it really is intended + -- to be an identifier. + + if + -- If followed by a semicolon, then it is an identifier, + -- with the exception of the cases tested for below. + + (Token = Tok_Semicolon + and then Prev_Token /= Tok_Return + and then Prev_Token /= Tok_Null + and then Prev_Token /= Tok_Raise + and then Prev_Token /= Tok_End + and then Prev_Token /= Tok_Exit) + + -- If followed by colon, colon-equal, or dot, then we + -- definitely have an identifier (could not be reserved) + + or else Token = Tok_Colon + or else Token = Tok_Colon_Equal + or else Token = Tok_Dot + + -- Left paren means we have an identifier except for those + -- reserved words that can legitimately be followed by a + -- left paren. + + or else + (Token = Tok_Left_Paren + and then Prev_Token /= Tok_Case + and then Prev_Token /= Tok_Delay + and then Prev_Token /= Tok_If + and then Prev_Token /= Tok_Elsif + and then Prev_Token /= Tok_Return + and then Prev_Token /= Tok_When + and then Prev_Token /= Tok_While + and then Prev_Token /= Tok_Separate) + then + -- Here we have an apparent reserved identifier and the + -- token past it is appropriate to this usage (and would + -- be a definite error if this is not an identifier). What + -- we do is to use P_Identifier to fix up the identifier, + -- and then fall into the normal processing. + + Restore_Scan_State (Scan_State); -- back to the ID + Scan_Reserved_Identifier (Force_Msg => False); + + -- Not a reserved identifier after all (or at least we can't + -- be sure that it is), so reset the scan and continue. + + else + Restore_Scan_State (Scan_State); -- back to the reserved word + end if; + end if; + + -- Now look to see what kind of statement we have + + case Token is + + -- Case of end or EOF + + when Tok_End | Tok_EOF => + + -- These tokens always terminate the statement sequence + + Test_Statement_Required; + exit; + + -- Case of ELSIF + + when Tok_Elsif => + + -- Terminate if Eftm set or if the ELSIF is to the left + -- of the expected column of the end for this sequence + + if SS_Flags.Eftm + or else Start_Column < Scope.Table (Scope.Last).Ecol + then + Test_Statement_Required; + exit; + + -- Otherwise complain and skip past ELSIF Condition then + + else + Error_Msg_SC ("ELSIF not allowed here"); + Scan; -- past ELSIF + Discard_Junk_Node (P_Expression_No_Right_Paren); + Then_Scan; + Statement_Required := False; + end if; + + -- Case of ELSE + + when Tok_Else => + + -- Terminate if Eltm set or if the else is to the left + -- of the expected column of the end for this sequence + + if SS_Flags.Eltm + or else Start_Column < Scope.Table (Scope.Last).Ecol + then + Test_Statement_Required; + exit; + + -- Otherwise complain and skip past else + + else + Error_Msg_SC ("ELSE not allowed here"); + Scan; -- past ELSE + Statement_Required := False; + end if; + + -- Case of exception + + when Tok_Exception => + Test_Statement_Required; + + -- If Extm not set and the exception is not to the left + -- of the expected column of the end for this sequence, then + -- we assume it belongs to the current sequence, even though + -- it is not permitted. + + if not SS_Flags.Extm and then + Start_Column >= Scope.Table (Scope.Last).Ecol + + then + Error_Msg_SC ("exception handler not permitted here"); + Scan; -- past EXCEPTION + Discard_Junk_List (Parse_Exception_Handlers); + end if; + + -- Always return, in the case where we scanned out handlers + -- that we did not expect, Parse_Exception_Handlers returned + -- with Token being either end or EOF, so we are OK + + exit; + + -- Case of OR + + when Tok_Or => + + -- Terminate if Ortm set or if the or is to the left + -- of the expected column of the end for this sequence + + if SS_Flags.Ortm + or else Start_Column < Scope.Table (Scope.Last).Ecol + then + Test_Statement_Required; + exit; + + -- Otherwise complain and skip past or + + else + Error_Msg_SC ("OR not allowed here"); + Scan; -- past or + Statement_Required := False; + end if; + + -- Case of THEN (deal also with THEN ABORT) + + when Tok_Then => + Save_Scan_State (Scan_State); -- at THEN + Scan; -- past THEN + + -- Terminate if THEN ABORT allowed (ATC case) + + exit when SS_Flags.Tatm and then Token = Tok_Abort; + + -- Otherwise we treat THEN as some kind of mess where we + -- did not see the associated IF, but we pick up assuming + -- it had been there! + + Restore_Scan_State (Scan_State); -- to THEN + Append_To (Statement_List, P_If_Statement); + Statement_Required := False; + + -- Case of WHEN (error because we are not in a case) + + when Tok_When | Tok_Others => + + -- Terminate if Whtm set or if the WHEN is to the left + -- of the expected column of the end for this sequence + + if SS_Flags.Whtm + or else Start_Column < Scope.Table (Scope.Last).Ecol + then + Test_Statement_Required; + exit; + + -- Otherwise complain and skip when Choice {| Choice} => + + else + Error_Msg_SC ("WHEN not allowed here"); + Scan; -- past when + Discard_Junk_List (P_Discrete_Choice_List); + TF_Arrow; + Statement_Required := False; + end if; + + -- Cases of statements starting with an identifier + + when Tok_Identifier => + Check_Bad_Layout; + + -- Save scan pointers and line number in case block label + + Id_Node := Token_Node; + Block_Label := Token_Name; + Save_Scan_State (Scan_State_Label); -- at possible label + Scan; -- past Id + + -- Check for common case of assignment, since it occurs + -- frequently, and we want to process it efficiently. + + if Token = Tok_Colon_Equal then + Scan; -- past the colon-equal + Append_To (Statement_List, + P_Assignment_Statement (Id_Node)); + Statement_Required := False; + + -- Check common case of procedure call, another case that + -- we want to speed up as much as possible. + + elsif Token = Tok_Semicolon then + Append_To (Statement_List, + P_Statement_Name (Id_Node)); + Scan; -- past semicolon + Statement_Required := False; + + -- Check for case of "go to" in place of "goto" + + elsif Token = Tok_Identifier + and then Block_Label = Name_Go + and then Token_Name = Name_To + then + Error_Msg_SP ("goto is one word"); + Append_To (Statement_List, P_Goto_Statement); + Statement_Required := False; + + -- Check common case of = used instead of :=, just so we + -- give a better error message for this special misuse. + + elsif Token = Tok_Equal then + T_Colon_Equal; -- give := expected message + Append_To (Statement_List, + P_Assignment_Statement (Id_Node)); + Statement_Required := False; + + -- Check case of loop label or block label + + elsif Token = Tok_Colon + or else (Token in Token_Class_Labeled_Stmt + and then not Token_Is_At_Start_Of_Line) + then + T_Colon; -- past colon (if there, or msg for missing one) + + -- Test for more than one label + + loop + exit when Token /= Tok_Identifier; + Save_Scan_State (Scan_State); -- at second Id + Scan; -- past Id + + if Token = Tok_Colon then + Error_Msg_SP + ("only one label allowed on block or loop"); + Scan; -- past colon on extra label + + -- Use the second label as the "real" label + + Scan_State_Label := Scan_State; + + -- We will set Error_name as the Block_Label since + -- we really don't know which of the labels might + -- be used at the end of the loop or block! + + Block_Label := Error_Name; + + -- If Id with no colon, then backup to point to the + -- Id and we will issue the message below when we try + -- to scan out the statement as some other form. + + else + Restore_Scan_State (Scan_State); -- to second Id + exit; + end if; + end loop; + + -- Loop_Statement (labeled Loop_Statement) + + if Token = Tok_Loop then + Append_To (Statement_List, + P_Loop_Statement (Id_Node)); + + -- While statement (labeled loop statement with WHILE) + + elsif Token = Tok_While then + Append_To (Statement_List, + P_While_Statement (Id_Node)); + + -- Declare statement (labeled block statement with + -- DECLARE part) + + elsif Token = Tok_Declare then + Append_To (Statement_List, + P_Declare_Statement (Id_Node)); + + -- Begin statement (labeled block statement with no + -- DECLARE part) + + elsif Token = Tok_Begin then + Append_To (Statement_List, + P_Begin_Statement (Id_Node)); + + -- For statement (labeled loop statement with FOR) + + elsif Token = Tok_For then + Append_To (Statement_List, + P_For_Statement (Id_Node)); + + -- Improper statement follows label. If we have an + -- expression token, then assume the colon was part + -- of a misplaced declaration. + + elsif Token not in Token_Class_Eterm then + Restore_Scan_State (Scan_State_Label); + Junk_Declaration; + + -- Otherwise complain we have inappropriate statement + + else + Error_Msg_AP + ("loop or block statement must follow label"); + end if; + + Statement_Required := False; + + -- Here we have an identifier followed by something + -- other than a colon, semicolon or assignment symbol. + -- The only valid possibility is a name extension symbol + + elsif Token in Token_Class_Namext then + Restore_Scan_State (Scan_State_Label); -- to Id + Name_Node := P_Name; + + -- Skip junk right parens in this context + + while Token = Tok_Right_Paren loop + Error_Msg_SC ("extra right paren"); + Scan; -- past ) + end loop; + + -- Check context following call + + if Token = Tok_Colon_Equal then + Scan; -- past colon equal + Append_To (Statement_List, + P_Assignment_Statement (Name_Node)); + Statement_Required := False; + + -- Check common case of = used instead of := + + elsif Token = Tok_Equal then + T_Colon_Equal; -- give := expected message + Append_To (Statement_List, + P_Assignment_Statement (Name_Node)); + Statement_Required := False; + + -- Check apostrophe cases + + elsif Token = Tok_Apostrophe then + Append_To (Statement_List, + P_Code_Statement (Name_Node)); + Statement_Required := False; + + -- The only other valid item after a name is ; which + -- means that the item we just scanned was a call. + + elsif Token = Tok_Semicolon then + Append_To (Statement_List, + P_Statement_Name (Name_Node)); + Scan; -- past semicolon + Statement_Required := False; + + -- Else we have a missing semicolon + + else + TF_Semicolon; + Statement_Required := False; + end if; + + -- If junk after identifier, check if identifier is an + -- instance of an incorrectly spelled keyword. If so, we + -- do nothing. The Bad_Spelling_Of will have reset Token + -- to the appropriate keyword, so the next time round the + -- loop we will process the modified token. Note that we + -- check for ELSIF before ELSE here. That's not accidental. + -- We don't want to identify a misspelling of ELSE as + -- ELSIF, and in particular we do not want to treat ELSEIF + -- as ELSE IF. + + else + Restore_Scan_State (Scan_State_Label); -- to identifier + + if Bad_Spelling_Of (Tok_Abort) + or else Bad_Spelling_Of (Tok_Accept) + or else Bad_Spelling_Of (Tok_Case) + or else Bad_Spelling_Of (Tok_Declare) + or else Bad_Spelling_Of (Tok_Delay) + or else Bad_Spelling_Of (Tok_Elsif) + or else Bad_Spelling_Of (Tok_Else) + or else Bad_Spelling_Of (Tok_End) + or else Bad_Spelling_Of (Tok_Exception) + or else Bad_Spelling_Of (Tok_Exit) + or else Bad_Spelling_Of (Tok_For) + or else Bad_Spelling_Of (Tok_Goto) + or else Bad_Spelling_Of (Tok_If) + or else Bad_Spelling_Of (Tok_Loop) + or else Bad_Spelling_Of (Tok_Or) + or else Bad_Spelling_Of (Tok_Pragma) + or else Bad_Spelling_Of (Tok_Raise) + or else Bad_Spelling_Of (Tok_Requeue) + or else Bad_Spelling_Of (Tok_Return) + or else Bad_Spelling_Of (Tok_Select) + or else Bad_Spelling_Of (Tok_When) + or else Bad_Spelling_Of (Tok_While) + then + null; + + -- If not a bad spelling, then we really have junk + + else + Scan; -- past identifier again + + -- If next token is first token on line, then we + -- consider that we were missing a semicolon after + -- the identifier, and process it as a procedure + -- call with no parameters. + + if Token_Is_At_Start_Of_Line then + Append_To (Statement_List, + P_Statement_Name (Id_Node)); + T_Semicolon; -- to give error message + Statement_Required := False; + + -- Otherwise we give a missing := message and + -- simply abandon the junk that is there now. + + else + T_Colon_Equal; -- give := expected message + raise Error_Resync; + end if; + + end if; + end if; + + -- Statement starting with operator symbol. This could be + -- a call, a name starting an assignment, or a qualified + -- expression. + + when Tok_Operator_Symbol => + Check_Bad_Layout; + Name_Node := P_Name; + + -- An attempt at a range attribute or a qualified expression + -- must be illegal here (a code statement cannot possibly + -- allow qualification by a function name). + + if Token = Tok_Apostrophe then + Error_Msg_SC ("apostrophe illegal here"); + raise Error_Resync; + end if; + + -- Scan possible assignment if we have a name + + if Expr_Form = EF_Name + and then Token = Tok_Colon_Equal + then + Scan; -- past colon equal + Append_To (Statement_List, + P_Assignment_Statement (Name_Node)); + else + Append_To (Statement_List, + P_Statement_Name (Name_Node)); + end if; + + TF_Semicolon; + Statement_Required := False; + + -- Label starting with << which must precede real statement + + when Tok_Less_Less => + Append_To (Statement_List, P_Label); + Statement_Required := True; + + -- Pragma appearing as a statement in a statement sequence + + when Tok_Pragma => + Check_Bad_Layout; + Append_To (Statement_List, P_Pragma); + + -- Abort_Statement + + when Tok_Abort => + Check_Bad_Layout; + Append_To (Statement_List, P_Abort_Statement); + Statement_Required := False; + + -- Accept_Statement + + when Tok_Accept => + Check_Bad_Layout; + Append_To (Statement_List, P_Accept_Statement); + Statement_Required := False; + + -- Begin_Statement (Block_Statement with no declare, no label) + + when Tok_Begin => + Check_Bad_Layout; + Append_To (Statement_List, P_Begin_Statement); + Statement_Required := False; + + -- Case_Statement + + when Tok_Case => + Check_Bad_Layout; + Append_To (Statement_List, P_Case_Statement); + Statement_Required := False; + + -- Block_Statement with DECLARE and no label + + when Tok_Declare => + Check_Bad_Layout; + Append_To (Statement_List, P_Declare_Statement); + Statement_Required := False; + + -- Delay_Statement + + when Tok_Delay => + Check_Bad_Layout; + Append_To (Statement_List, P_Delay_Statement); + Statement_Required := False; + + -- Exit_Statement + + when Tok_Exit => + Check_Bad_Layout; + Append_To (Statement_List, P_Exit_Statement); + Statement_Required := False; + + -- Loop_Statement with FOR and no label + + when Tok_For => + Check_Bad_Layout; + Append_To (Statement_List, P_For_Statement); + Statement_Required := False; + + -- Goto_Statement + + when Tok_Goto => + Check_Bad_Layout; + Append_To (Statement_List, P_Goto_Statement); + Statement_Required := False; + + -- If_Statement + + when Tok_If => + Check_Bad_Layout; + Append_To (Statement_List, P_If_Statement); + Statement_Required := False; + + -- Loop_Statement + + when Tok_Loop => + Check_Bad_Layout; + Append_To (Statement_List, P_Loop_Statement); + Statement_Required := False; + + -- Null_Statement + + when Tok_Null => + Check_Bad_Layout; + Append_To (Statement_List, P_Null_Statement); + Statement_Required := False; + + -- Raise_Statement + + when Tok_Raise => + Check_Bad_Layout; + Append_To (Statement_List, P_Raise_Statement); + Statement_Required := False; + + -- Requeue_Statement + + when Tok_Requeue => + Check_Bad_Layout; + Append_To (Statement_List, P_Requeue_Statement); + Statement_Required := False; + + -- Return_Statement + + when Tok_Return => + Check_Bad_Layout; + Append_To (Statement_List, P_Return_Statement); + Statement_Required := False; + + -- Select_Statement + + when Tok_Select => + Check_Bad_Layout; + Append_To (Statement_List, P_Select_Statement); + Statement_Required := False; + + -- While_Statement (Block_Statement with while and no loop) + + when Tok_While => + Check_Bad_Layout; + Append_To (Statement_List, P_While_Statement); + Statement_Required := False; + + -- Anything else is some kind of junk, signal an error message + -- and then raise Error_Resync, to merge with the normal + -- handling of a bad statement. + + when others => + + if Token in Token_Class_Declk then + Junk_Declaration; + + else + Error_Msg_BC ("statement expected"); + raise Error_Resync; + end if; + end case; + + -- On error resynchronization, skip past next semicolon, and, since + -- we are still in the statement loop, look for next statement. We + -- set Statement_Required False to avoid an unnecessary error message + -- complaining that no statement was found (i.e. we consider the + -- junk to satisfy the requirement for a statement being present). + + exception + when Error_Resync => + Resync_Past_Semicolon_Or_To_Loop_Or_Then; + Statement_Required := False; + end; + + exit when SS_Flags.Unco; + + end loop; + + return Statement_List; + + end P_Sequence_Of_Statements; + + -------------------- + -- 5.1 Statement -- + -------------------- + + -- Parsed by P_Sequence_Of_Statements (5.1), except for the case + -- of a statement of the form of a name, which is handled here. The + -- argument passed in is the tree for the name which has been scanned + -- The returned value is the corresponding statement form. + + -- This routine is also used by Par.Prag for processing the procedure + -- call that appears as the second argument of a pragma Assert. + + -- Error recovery: cannot raise Error_Resync + + function P_Statement_Name (Name_Node : Node_Id) return Node_Id is + Stmt_Node : Node_Id; + + begin + -- Case of Indexed component, which is a procedure call with arguments + + if Nkind (Name_Node) = N_Indexed_Component then + declare + Prefix_Node : Node_Id := Prefix (Name_Node); + Exprs_Node : List_Id := Expressions (Name_Node); + begin + Change_Node (Name_Node, N_Procedure_Call_Statement); + Set_Name (Name_Node, Prefix_Node); + Set_Parameter_Associations (Name_Node, Exprs_Node); + return Name_Node; + end; + + -- Case of function call node, which is a really a procedure call + + elsif Nkind (Name_Node) = N_Function_Call then + declare + Fname_Node : Node_Id := Name (Name_Node); + Params_List : List_Id := Parameter_Associations (Name_Node); + + begin + Change_Node (Name_Node, N_Procedure_Call_Statement); + Set_Name (Name_Node, Fname_Node); + Set_Parameter_Associations (Name_Node, Params_List); + return Name_Node; + end; + + -- Case of call to attribute that denotes a procedure. Here we + -- just leave the attribute reference unchanged. + + elsif Nkind (Name_Node) = N_Attribute_Reference + and then Is_Procedure_Attribute_Name (Attribute_Name (Name_Node)) + then + return Name_Node; + + -- All other cases of names are parameterless procedure calls + + else + Stmt_Node := + New_Node (N_Procedure_Call_Statement, Sloc (Name_Node)); + Set_Name (Stmt_Node, Name_Node); + return Stmt_Node; + end if; + + end P_Statement_Name; + + --------------------------- + -- 5.1 Simple Statement -- + --------------------------- + + -- Parsed by P_Sequence_Of_Statements (5.1) + + ----------------------------- + -- 5.1 Compound Statement -- + ----------------------------- + + -- Parsed by P_Sequence_Of_Statements (5.1) + + ------------------------- + -- 5.1 Null Statement -- + ------------------------- + + -- NULL_STATEMENT ::= null; + + -- The caller has already checked that the current token is null + + -- Error recovery: cannot raise Error_Resync + + function P_Null_Statement return Node_Id is + Null_Stmt_Node : Node_Id; + + begin + Null_Stmt_Node := New_Node (N_Null_Statement, Token_Ptr); + Scan; -- past NULL + TF_Semicolon; + return Null_Stmt_Node; + end P_Null_Statement; + + ---------------- + -- 5.1 Label -- + ---------------- + + -- LABEL ::= <<label_STATEMENT_IDENTIFIER>> + + -- STATEMENT_INDENTIFIER ::= DIRECT_NAME + + -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier + -- (not an OPERATOR_SYMBOL) + + -- The caller has already checked that the current token is << + + -- Error recovery: can raise Error_Resync + + function P_Label return Node_Id is + Label_Node : Node_Id; + + begin + Label_Node := New_Node (N_Label, Token_Ptr); + Scan; -- past << + Set_Identifier (Label_Node, P_Identifier); + T_Greater_Greater; + Append_Elmt (Label_Node, Label_List); + return Label_Node; + end P_Label; + + ------------------------------- + -- 5.1 Statement Identifier -- + ------------------------------- + + -- Statement label is parsed by P_Label (5.1) + + -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5) + -- or P_While_Statement (5.5) + + -- Block label is parsed by P_Begin_Statement (5.6) or + -- P_Declare_Statement (5.6) + + ------------------------------- + -- 5.2 Assignment Statement -- + ------------------------------- + + -- ASSIGNMENT_STATEMENT ::= + -- variable_NAME := EXPRESSION; + + -- Error recovery: can raise Error_Resync + + function P_Assignment_Statement (LHS : Node_Id) return Node_Id is + Assign_Node : Node_Id; + + begin + Assign_Node := New_Node (N_Assignment_Statement, Prev_Token_Ptr); + Set_Name (Assign_Node, LHS); + Set_Expression (Assign_Node, P_Expression_No_Right_Paren); + TF_Semicolon; + return Assign_Node; + end P_Assignment_Statement; + + ----------------------- + -- 5.3 If Statement -- + ----------------------- + + -- IF_STATEMENT ::= + -- if CONDITION then + -- SEQUENCE_OF_STATEMENTS + -- {elsif CONDITION then + -- SEQUENCE_OF_STATEMENTS} + -- [else + -- SEQUENCE_OF_STATEMENTS] + -- end if; + + -- The caller has checked that the initial token is IF (or in the error + -- case of a mysterious THEN, the initial token may simply be THEN, in + -- which case, no condition (or IF) was scanned). + + -- Error recovery: can raise Error_Resync + + function P_If_Statement return Node_Id is + If_Node : Node_Id; + Elsif_Node : Node_Id; + Loc : Source_Ptr; + + procedure Add_Elsif_Part; + -- An internal procedure used to scan out a single ELSIF part. On entry + -- the ELSIF (or an ELSE which has been determined should be ELSIF) is + -- scanned out and is in Prev_Token. + + procedure Check_If_Column; + -- An internal procedure used to check that THEN, ELSE ELSE, or ELSIF + -- appear in the right place if column checking is enabled (i.e. if + -- they are the first token on the line, then they must appear in + -- the same column as the opening IF). + + procedure Check_Then_Column; + -- This procedure carries out the style checks for a THEN token + -- Note that the caller has set Loc to the Source_Ptr value for + -- the previous IF or ELSIF token. These checks apply only to a + -- THEN at the start of a line. + + function Else_Should_Be_Elsif return Boolean; + -- An internal routine used to do a special error recovery check when + -- an ELSE is encountered. It determines if the ELSE should be treated + -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE + -- is followed by a sequence of tokens, starting on the same line as + -- the ELSE, which are not expression terminators, followed by a THEN. + -- On entry, the ELSE has been scanned out. + + procedure Add_Elsif_Part is + begin + if No (Elsif_Parts (If_Node)) then + Set_Elsif_Parts (If_Node, New_List); + end if; + + Elsif_Node := New_Node (N_Elsif_Part, Prev_Token_Ptr); + Loc := Prev_Token_Ptr; + Set_Condition (Elsif_Node, P_Condition); + Check_Then_Column; + Then_Scan; + Set_Then_Statements + (Elsif_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); + Append (Elsif_Node, Elsif_Parts (If_Node)); + end Add_Elsif_Part; + + procedure Check_If_Column is + begin + if Style.RM_Column_Check and then Token_Is_At_Start_Of_Line + and then Start_Column /= Scope.Table (Scope.Last).Ecol + then + Error_Msg_Col := Scope.Table (Scope.Last).Ecol; + Error_Msg_SC ("(style) this token should be@"); + end if; + end Check_If_Column; + + procedure Check_Then_Column is + begin + if Token_Is_At_Start_Of_Line and then Token = Tok_Then then + Check_If_Column; + if Style_Check then Style.Check_Then (Loc); end if; + end if; + end Check_Then_Column; + + function Else_Should_Be_Elsif return Boolean is + Scan_State : Saved_Scan_State; + + begin + if Token_Is_At_Start_Of_Line then + return False; + + else + Save_Scan_State (Scan_State); + + loop + if Token in Token_Class_Eterm then + Restore_Scan_State (Scan_State); + return False; + else + Scan; -- past non-expression terminating token + + if Token = Tok_Then then + Restore_Scan_State (Scan_State); + return True; + end if; + end if; + end loop; + end if; + end Else_Should_Be_Elsif; + + -- Start of processing for P_If_Statement + + begin + If_Node := New_Node (N_If_Statement, Token_Ptr); + + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_If; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Labl := Error; + Scope.Table (Scope.Last).Node := If_Node; + + if Token = Tok_If then + Loc := Token_Ptr; + Scan; -- past IF + Set_Condition (If_Node, P_Condition); + + -- Deal with misuse of IF expression => used instead + -- of WHEN expression => + + if Token = Tok_Arrow then + Error_Msg_SC ("THEN expected"); + Scan; -- past the arrow + Pop_Scope_Stack; -- remove unneeded entry + raise Error_Resync; + end if; + + Check_Then_Column; + + else + Error_Msg_SC ("no IF for this THEN"); + Set_Condition (If_Node, Error); + end if; + + Then_Scan; + + Set_Then_Statements + (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); + + -- This loop scans out else and elsif parts + + loop + if Token = Tok_Elsif then + Check_If_Column; + + if Present (Else_Statements (If_Node)) then + Error_Msg_SP ("ELSIF cannot appear after ELSE"); + end if; + + Scan; -- past ELSIF + Add_Elsif_Part; + + elsif Token = Tok_Else then + Check_If_Column; + Scan; -- past ELSE + + if Else_Should_Be_Elsif then + Error_Msg_SP ("ELSE should be ELSIF"); + Add_Elsif_Part; + + else + -- Here we have an else that really is an else + + if Present (Else_Statements (If_Node)) then + Error_Msg_SP ("Only one ELSE part allowed"); + Append_List + (P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq), + Else_Statements (If_Node)); + else + Set_Else_Statements + (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); + end if; + end if; + + -- If anything other than ELSE or ELSIF, exit the loop. The token + -- had better be END (and in fact it had better be END IF), but + -- we will let End_Statements take care of checking that. + + else + exit; + end if; + end loop; + + End_Statements; + return If_Node; + + end P_If_Statement; + + -------------------- + -- 5.3 Condition -- + -------------------- + + -- CONDITION ::= boolean_EXPRESSION + + function P_Condition return Node_Id is + Cond : Node_Id; + + begin + Cond := P_Expression_No_Right_Paren; + + -- It is never possible for := to follow a condition, so if we get + -- a := we assume it is a mistyped equality. Note that we do not try + -- to reconstruct the tree correctly in this case, but we do at least + -- give an accurate error message. + + while Token = Tok_Colon_Equal loop + Error_Msg_SC (""":="" should be ""="""); + Scan; -- past junk := + Discard_Junk_Node (P_Expression_No_Right_Paren); + end loop; + + return Cond; + end P_Condition; + + ------------------------- + -- 5.4 Case Statement -- + ------------------------- + + -- CASE_STATEMENT ::= + -- case EXPRESSION is + -- CASE_STATEMENT_ALTERNATIVE + -- {CASE_STATEMENT_ALTERNATIVE} + -- end case; + + -- The caller has checked that the first token is CASE + + -- Can raise Error_Resync + + function P_Case_Statement return Node_Id is + Case_Node : Node_Id; + Alternatives_List : List_Id; + First_When_Loc : Source_Ptr; + + begin + Case_Node := New_Node (N_Case_Statement, Token_Ptr); + + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Case; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Labl := Error; + Scope.Table (Scope.Last).Node := Case_Node; + + Scan; -- past CASE + Set_Expression (Case_Node, P_Expression_No_Right_Paren); + TF_Is; + + -- Prepare to parse case statement alternatives + + Alternatives_List := New_List; + P_Pragmas_Opt (Alternatives_List); + First_When_Loc := Token_Ptr; + + -- Loop through case statement alternatives + + loop + -- If we have a WHEN or OTHERS, then that's fine keep going. Note + -- that it is a semantic check to ensure the proper use of OTHERS + + if Token = Tok_When or else Token = Tok_Others then + Append (P_Case_Statement_Alternative, Alternatives_List); + + -- If we have an END, then probably we are at the end of the case + -- but we only exit if Check_End thinks the END was reasonable. + + elsif Token = Tok_End then + exit when Check_End; + + -- Here if token is other than WHEN, OTHERS or END. We definitely + -- have an error, but the question is whether or not to get out of + -- the case statement. We don't want to get out early, or we will + -- get a slew of junk error messages for subsequent when tokens. + + -- If the token is not at the start of the line, or if it is indented + -- with respect to the current case statement, then the best guess is + -- that we are still supposed to be inside the case statement. We + -- complain about the missing WHEN, and discard the junk statements. + + elsif not Token_Is_At_Start_Of_Line + or else Start_Column > Scope.Table (Scope.Last).Ecol + then + Error_Msg_BC ("WHEN (case statement alternative) expected"); + + -- Here is a possibility for infinite looping if we don't make + -- progress. So try to process statements, otherwise exit + + declare + Error_Ptr : constant Source_Ptr := Scan_Ptr; + begin + Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm)); + exit when Scan_Ptr = Error_Ptr and then Check_End; + end; + + -- Here we have a junk token at the start of the line and it is + -- not indented. If Check_End thinks there is a missing END, then + -- we will get out of the case, otherwise we keep going. + + else + exit when Check_End; + end if; + end loop; + + -- Make sure we have at least one alternative + + if No (First_Non_Pragma (Alternatives_List)) then + Error_Msg + ("WHEN expected, must have at least one alternative in case", + First_When_Loc); + return Error; + + else + Set_Alternatives (Case_Node, Alternatives_List); + return Case_Node; + end if; + end P_Case_Statement; + + ------------------------------------- + -- 5.4 Case Statement Alternative -- + ------------------------------------- + + -- CASE_STATEMENT_ALTERNATIVE ::= + -- when DISCRETE_CHOICE_LIST => + -- SEQUENCE_OF_STATEMENTS + + -- The caller has checked that the initial token is WHEN or OTHERS + -- Error recovery: can raise Error_Resync + + function P_Case_Statement_Alternative return Node_Id is + Case_Alt_Node : Node_Id; + + begin + if Style_Check then Style.Check_Indentation; end if; + Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr); + T_When; -- past WHEN (or give error in OTHERS case) + Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List); + TF_Arrow; + Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm)); + return Case_Alt_Node; + end P_Case_Statement_Alternative; + + ------------------------- + -- 5.5 Loop Statement -- + ------------------------- + + -- LOOP_STATEMENT ::= + -- [LOOP_STATEMENT_IDENTIFIER:] + -- [ITERATION_SCHEME] loop + -- SEQUENCE_OF_STATEMENTS + -- end loop [loop_IDENTIFIER]; + + -- ITERATION_SCHEME ::= + -- while CONDITION + -- | for LOOP_PARAMETER_SPECIFICATION + + -- The parsing of loop statements is handled by one of three functions + -- P_Loop_Statement, P_For_Statement or P_While_Statement depending + -- on the initial keyword in the construct (excluding the identifier) + + -- P_Loop_Statement + + -- This function parses the case where no iteration scheme is present + + -- The caller has checked that the initial token is LOOP. The parameter + -- is the node identifiers for the loop label if any (or is set to Empty + -- if there is no loop label). + + -- Error recovery : cannot raise Error_Resync + + function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is + Loop_Node : Node_Id; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Labl := Loop_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Etyp := E_Loop; + + Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); + TF_Loop; + + if No (Loop_Name) then + Set_Has_Created_Identifier (Loop_Node, True); + Set_Identifier (Loop_Node, + Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'))); + else + Set_Identifier (Loop_Node, Loop_Name); + end if; + + Append_Elmt (Loop_Node, Label_List); + + Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); + End_Statements (Loop_Node); + return Loop_Node; + end P_Loop_Statement; + + -- P_For_Statement + + -- This function parses a loop statement with a FOR iteration scheme + + -- The caller has checked that the initial token is FOR. The parameter + -- is the node identifier for the block label if any (or is set to Empty + -- if there is no block label). + + -- Note: the caller fills in the Identifier field if a label was present + + -- Error recovery: can raise Error_Resync + + function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id is + Loop_Node : Node_Id; + Iter_Scheme_Node : Node_Id; + Loop_For_Flag : Boolean; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Labl := Loop_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Etyp := E_Loop; + + Loop_For_Flag := (Prev_Token = Tok_Loop); + Scan; -- past FOR + Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr); + Set_Loop_Parameter_Specification + (Iter_Scheme_Node, P_Loop_Parameter_Specification); + + -- The following is a special test so that a miswritten for loop such + -- as "loop for I in 1..10;" is handled nicely, without making an extra + -- entry in the scope stack. We don't bother to actually fix up the + -- tree in this case since it's not worth the effort. Instead we just + -- eat up the loop junk, leaving the entry for what now looks like an + -- unmodified loop intact. + + if Loop_For_Flag and then Token = Tok_Semicolon then + Error_Msg_SC ("LOOP belongs here, not before FOR"); + Pop_Scope_Stack; + return Error; + + -- Normal case + + else + Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); + TF_Loop; + Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); + End_Statements (Loop_Node); + Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node); + + if No (Loop_Name) then + Set_Has_Created_Identifier (Loop_Node, True); + Set_Identifier (Loop_Node, + Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'))); + else + Set_Identifier (Loop_Node, Loop_Name); + end if; + + Append_Elmt (Loop_Node, Label_List); + + return Loop_Node; + end if; + + end P_For_Statement; + + -- P_While_Statement + + -- This procedure scans a loop statement with a WHILE iteration scheme + + -- The caller has checked that the initial token is WHILE. The parameter + -- is the node identifier for the block label if any (or is set to Empty + -- if there is no block label). + + -- Error recovery: cannot raise Error_Resync + + function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id is + Loop_Node : Node_Id; + Iter_Scheme_Node : Node_Id; + Loop_While_Flag : Boolean; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Labl := Loop_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Etyp := E_Loop; + + Loop_While_Flag := (Prev_Token = Tok_Loop); + Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr); + Scan; -- past WHILE + Set_Condition (Iter_Scheme_Node, P_Condition); + + -- The following is a special test so that a miswritten for loop such + -- as "loop while I > 10;" is handled nicely, without making an extra + -- entry in the scope stack. We don't bother to actually fix up the + -- tree in this case since it's not worth the effort. Instead we just + -- eat up the loop junk, leaving the entry for what now looks like an + -- unmodified loop intact. + + if Loop_While_Flag and then Token = Tok_Semicolon then + Error_Msg_SC ("LOOP belongs here, not before WHILE"); + Pop_Scope_Stack; + return Error; + + -- Normal case + + else + Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); + TF_Loop; + Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); + End_Statements (Loop_Node); + Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node); + + if No (Loop_Name) then + Set_Has_Created_Identifier (Loop_Node, True); + Set_Identifier (Loop_Node, + Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'))); + else + Set_Identifier (Loop_Node, Loop_Name); + end if; + + Append_Elmt (Loop_Node, Label_List); + + return Loop_Node; + end if; + + end P_While_Statement; + + --------------------------------------- + -- 5.5 Loop Parameter Specification -- + --------------------------------------- + + -- LOOP_PARAMETER_SPECIFICATION ::= + -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION + + -- Error recovery: cannot raise Error_Resync + + function P_Loop_Parameter_Specification return Node_Id is + Loop_Param_Specification_Node : Node_Id; + + ID_Node : Node_Id; + Scan_State : Saved_Scan_State; + + begin + Loop_Param_Specification_Node := + New_Node (N_Loop_Parameter_Specification, Token_Ptr); + + Save_Scan_State (Scan_State); + ID_Node := P_Defining_Identifier; + Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node); + + if Token = Tok_Left_Paren then + Error_Msg_SC ("subscripted loop parameter not allowed"); + Restore_Scan_State (Scan_State); + Discard_Junk_Node (P_Name); + + elsif Token = Tok_Dot then + Error_Msg_SC ("selected loop parameter not allowed"); + Restore_Scan_State (Scan_State); + Discard_Junk_Node (P_Name); + end if; + + T_In; + + if Token = Tok_Reverse then + Scan; -- past REVERSE + Set_Reverse_Present (Loop_Param_Specification_Node, True); + end if; + + Set_Discrete_Subtype_Definition + (Loop_Param_Specification_Node, P_Discrete_Subtype_Definition); + return Loop_Param_Specification_Node; + + exception + when Error_Resync => + return Error; + end P_Loop_Parameter_Specification; + + -------------------------- + -- 5.6 Block Statement -- + -------------------------- + + -- BLOCK_STATEMENT ::= + -- [block_STATEMENT_IDENTIFIER:] + -- [declare + -- DECLARATIVE_PART] + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [block_IDENTIFIER]; + + -- The parsing of block statements is handled by one of the two functions + -- P_Declare_Statement or P_Begin_Statement depending on whether or not + -- a declare section is present + + -- P_Declare_Statement + + -- This function parses a block statement with DECLARE present + + -- The caller has checked that the initial token is DECLARE. + + -- Error recovery: cannot raise Error_Resync + + function P_Declare_Statement + (Block_Name : Node_Id := Empty) + return Node_Id + is + Block_Node : Node_Id; + + begin + Block_Node := New_Node (N_Block_Statement, Token_Ptr); + + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Lreq := Present (Block_Name); + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Labl := Block_Name; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + + Scan; -- past DECLARE + + if No (Block_Name) then + Set_Has_Created_Identifier (Block_Node, True); + Set_Identifier (Block_Node, + Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B'))); + else + Set_Identifier (Block_Node, Block_Name); + end if; + + Append_Elmt (Block_Node, Label_List); + Parse_Decls_Begin_End (Block_Node); + return Block_Node; + end P_Declare_Statement; + + -- P_Begin_Statement + + -- This function parses a block statement with no DECLARE present + + -- The caller has checked that the initial token is BEGIN + + -- Error recovery: cannot raise Error_Resync + + function P_Begin_Statement + (Block_Name : Node_Id := Empty) + return Node_Id + is + Block_Node : Node_Id; + + begin + Block_Node := New_Node (N_Block_Statement, Token_Ptr); + + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Lreq := Present (Block_Name); + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Labl := Block_Name; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + + if No (Block_Name) then + Set_Has_Created_Identifier (Block_Node, True); + Set_Identifier (Block_Node, + Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B'))); + else + Set_Identifier (Block_Node, Block_Name); + end if; + + Append_Elmt (Block_Node, Label_List); + + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scan; -- past BEGIN + Set_Handled_Statement_Sequence + (Block_Node, P_Handled_Sequence_Of_Statements); + End_Statements (Handled_Statement_Sequence (Block_Node)); + return Block_Node; + end P_Begin_Statement; + + ------------------------- + -- 5.7 Exit Statement -- + ------------------------- + + -- EXIT_STATEMENT ::= + -- exit [loop_NAME] [when CONDITION]; + + -- The caller has checked that the initial token is EXIT + + -- Error recovery: can raise Error_Resync + + function P_Exit_Statement return Node_Id is + Exit_Node : Node_Id; + + function Missing_Semicolon_On_Exit return Boolean; + -- This function deals with the following specialized situation + -- + -- when 'x' => + -- exit [identifier] + -- when 'y' => + -- + -- This looks like a messed up EXIT WHEN, when in fact the problem + -- is a missing semicolon. It is called with Token pointing to the + -- WHEN token, and returns True if a semicolon is missing before + -- the WHEN as in the above example. + + function Missing_Semicolon_On_Exit return Boolean is + State : Saved_Scan_State; + + begin + if not Token_Is_At_Start_Of_Line then + return False; + + elsif Scope.Table (Scope.Last).Etyp /= E_Case then + return False; + + else + Save_Scan_State (State); + Scan; -- past WHEN + Scan; -- past token after WHEN + + if Token = Tok_Arrow then + Restore_Scan_State (State); + return True; + else + Restore_Scan_State (State); + return False; + end if; + end if; + end Missing_Semicolon_On_Exit; + + -- Start of processing for P_Exit_Statement + + begin + Exit_Node := New_Node (N_Exit_Statement, Token_Ptr); + Scan; -- past EXIT + + if Token = Tok_Identifier then + Set_Name (Exit_Node, P_Qualified_Simple_Name); + + elsif Style_Check then + -- This EXIT has no name, so check that + -- the innermost loop is unnamed too. + + Check_No_Exit_Name : + for J in reverse 1 .. Scope.Last loop + if Scope.Table (J).Etyp = E_Loop then + if Present (Scope.Table (J).Labl) then + + -- Innermost loop in fact had a name, style check fails + + Style.No_Exit_Name (Scope.Table (J).Labl); + end if; + + exit Check_No_Exit_Name; + end if; + end loop Check_No_Exit_Name; + end if; + + if Token = Tok_When and then not Missing_Semicolon_On_Exit then + Scan; -- past WHEN + Set_Condition (Exit_Node, P_Condition); + + -- Allow IF instead of WHEN, giving error message + + elsif Token = Tok_If then + T_When; + Scan; -- past IF used in place of WHEN + Set_Condition (Exit_Node, P_Expression_No_Right_Paren); + end if; + + TF_Semicolon; + return Exit_Node; + end P_Exit_Statement; + + ------------------------- + -- 5.8 Goto Statement -- + ------------------------- + + -- GOTO_STATEMENT ::= goto label_NAME; + + -- The caller has checked that the initial token is GOTO (or TO in the + -- error case where GO and TO were incorrectly separated). + + -- Error recovery: can raise Error_Resync + + function P_Goto_Statement return Node_Id is + Goto_Node : Node_Id; + + begin + Goto_Node := New_Node (N_Goto_Statement, Token_Ptr); + Scan; -- past GOTO (or TO) + Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync); + No_Constraint; + TF_Semicolon; + return Goto_Node; + end P_Goto_Statement; + + --------------------------- + -- Parse_Decls_Begin_End -- + --------------------------- + + -- This function parses the construct: + + -- DECLARATIVE_PART + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [NAME]; + + -- The caller has built the scope stack entry, and created the node to + -- whose Declarations and Handled_Statement_Sequence fields are to be + -- set. On return these fields are filled in (except in the case of a + -- task body, where the handled statement sequence is optional, and may + -- thus be Empty), and the scan is positioned past the End sequence. + + -- If the BEGIN is missing, then the parent node is used to help construct + -- an appropriate missing BEGIN message. Possibilities for the parent are: + + -- N_Block_Statement declare block + -- N_Entry_Body entry body + -- N_Package_Body package body (begin part optional) + -- N_Subprogram_Body procedure or function body + -- N_Task_Body task body + + -- Note: in the case of a block statement, there is definitely a DECLARE + -- present (because a Begin statement without a DECLARE is handled by the + -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End. + + -- Error recovery: cannot raise Error_Resync + + procedure Parse_Decls_Begin_End (Parent : Node_Id) is + Body_Decl : Node_Id; + Body_Sloc : Source_Ptr; + Decls : List_Id; + Decl : Node_Id; + Parent_Nkind : Node_Kind; + Spec_Node : Node_Id; + HSS : Node_Id; + + procedure Missing_Begin (Msg : String); + -- Called to post a missing begin message. In the normal case this is + -- posted at the start of the current token. A special case arises when + -- P_Declarative_Items has previously found a missing begin, in which + -- case we replace the original error message. + + procedure Set_Null_HSS (Parent : Node_Id); + -- Construct an empty handled statement sequence and install in Parent + -- Leaves HSS set to reference the newly constructed statement sequence. + + ------------------- + -- Missing_Begin -- + ------------------- + + procedure Missing_Begin (Msg : String) is + begin + if Missing_Begin_Msg = No_Error_Msg then + Error_Msg_BC (Msg); + else + Change_Error_Text (Missing_Begin_Msg, Msg); + + -- Purge any messages issued after than, since a missing begin + -- can cause a lot of havoc, and it is better not to dump these + -- cascaded messages on the user. + + Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr); + end if; + end Missing_Begin; + + ------------------ + -- Set_Null_HSS -- + ------------------ + + procedure Set_Null_HSS (Parent : Node_Id) is + Null_Stm : Node_Id; + + begin + Null_Stm := + Make_Null_Statement (Token_Ptr); + Set_Comes_From_Source (Null_Stm, False); + + HSS := + Make_Handled_Sequence_Of_Statements (Token_Ptr, + Statements => New_List (Null_Stm)); + Set_Comes_From_Source (HSS, False); + + Set_Handled_Statement_Sequence (Parent, HSS); + end Set_Null_HSS; + + -- Start of processing for Parse_Decls_Begin_End + + begin + Decls := P_Declarative_Part; + + -- Check for misplacement of later vs basic declarations in Ada 83 + + if Ada_83 then + Decl := First (Decls); + + -- Loop through sequence of basic declarative items + + Outer : while Present (Decl) loop + if Nkind (Decl) /= N_Subprogram_Body + and then Nkind (Decl) /= N_Package_Body + and then Nkind (Decl) /= N_Task_Body + and then Nkind (Decl) not in N_Body_Stub + then + Next (Decl); + + -- Once a body is encountered, we only allow later declarative + -- items. The inner loop checks the rest of the list. + + else + Body_Sloc := Sloc (Decl); + + Inner : while Present (Decl) loop + if Nkind (Decl) not in N_Later_Decl_Item + and then Nkind (Decl) /= N_Pragma + then + if Ada_83 then + Error_Msg_Sloc := Body_Sloc; + Error_Msg_N + ("(Ada 83) decl cannot appear after body#", Decl); + end if; + end if; + + Next (Decl); + end loop Inner; + end if; + end loop Outer; + end if; + + -- Here is where we deal with the case of IS used instead of semicolon. + -- Specifically, if the last declaration in the declarative part is a + -- subprogram body still marked as having a bad IS, then this is where + -- we decide that the IS should really have been a semicolon and that + -- the body should have been a declaration. Note that if the bad IS + -- had turned out to be OK (i.e. a decent begin/end was found for it), + -- then the Bad_Is_Detected flag would have been reset by now. + + Body_Decl := Last (Decls); + + if Present (Body_Decl) + and then Nkind (Body_Decl) = N_Subprogram_Body + and then Bad_Is_Detected (Body_Decl) + then + -- OK, we have the case of a bad IS, so we need to fix up the tree. + -- What we have now is a subprogram body with attached declarations + -- and a possible statement sequence. + + -- First step is to take the declarations that were part of the bogus + -- subprogram body and append them to the outer declaration chain. + -- In other words we append them past the body (which we will later + -- convert into a declaration). + + Append_List (Declarations (Body_Decl), Decls); + + -- Now take the handled statement sequence of the bogus body and + -- set it as the statement sequence for the outer construct. Note + -- that it may be empty (we specially allowed a missing BEGIN for + -- a subprogram body marked as having a bad IS -- see below). + + Set_Handled_Statement_Sequence (Parent, + Handled_Statement_Sequence (Body_Decl)); + + -- Next step is to convert the old body node to a declaration node + + Spec_Node := Specification (Body_Decl); + Change_Node (Body_Decl, N_Subprogram_Declaration); + Set_Specification (Body_Decl, Spec_Node); + + -- Final step is to put the declarations for the parent where + -- they belong, and then fall through the IF to scan out the + -- END statements. + + Set_Declarations (Parent, Decls); + + -- This is the normal case (i.e. any case except the bad IS case) + -- If we have a BEGIN, then scan out the sequence of statements, and + -- also reset the expected column for the END to match the BEGIN. + + else + Set_Declarations (Parent, Decls); + + if Token = Tok_Begin then + if Style_Check then Style.Check_Indentation; end if; + + Error_Msg_Col := Scope.Table (Scope.Last).Ecol; + + if Style.RM_Column_Check + and then Token_Is_At_Start_Of_Line + and then Start_Column /= Error_Msg_Col + then + Error_Msg_SC ("(style) BEGIN in wrong column, should be@"); + + else + Scope.Table (Scope.Last).Ecol := Start_Column; + end if; + + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scan; -- past BEGIN + Set_Handled_Statement_Sequence (Parent, + P_Handled_Sequence_Of_Statements); + + -- No BEGIN present + + else + Parent_Nkind := Nkind (Parent); + + -- A special check for the missing IS case. If we have a + -- subprogram body that was marked as having a suspicious + -- IS, and the current token is END, then we simply confirm + -- the suspicion, and do not require a BEGIN to be present + + if Parent_Nkind = N_Subprogram_Body + and then Token = Tok_End + and then Scope.Table (Scope.Last).Etyp = E_Suspicious_Is + then + Scope.Table (Scope.Last).Etyp := E_Bad_Is; + + -- Otherwise BEGIN is not required for a package body, so we + -- don't mind if it is missing, but we do construct a dummy + -- one (so that we have somewhere to set End_Label). + + -- However if we have something other than a BEGIN which + -- looks like it might be statements, then we signal a missing + -- BEGIN for these cases as well. We define "something which + -- looks like it might be statements" as a token other than + -- END, EOF, or a token which starts declarations. + + elsif Parent_Nkind = N_Package_Body + and then (Token = Tok_End + or else Token = Tok_EOF + or else Token in Token_Class_Declk) + then + Set_Null_HSS (Parent); + + -- These are cases in which a BEGIN is required and not present + + else + Set_Null_HSS (Parent); + + -- Prepare to issue error message + + Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc; + Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; + + -- Now issue appropriate message + + if Parent_Nkind = N_Block_Statement then + Missing_Begin ("missing BEGIN for DECLARE#!"); + + elsif Parent_Nkind = N_Entry_Body then + Missing_Begin ("missing BEGIN for ENTRY#!"); + + elsif Parent_Nkind = N_Subprogram_Body then + if Nkind (Specification (Parent)) + = N_Function_Specification + then + Missing_Begin ("missing BEGIN for function&#!"); + else + Missing_Begin ("missing BEGIN for procedure&#!"); + end if; + + -- The case for package body arises only when + -- we have possible statement junk present. + + elsif Parent_Nkind = N_Package_Body then + Missing_Begin ("missing BEGIN for package body&#!"); + + else + pragma Assert (Parent_Nkind = N_Task_Body); + Missing_Begin ("missing BEGIN for task body&#!"); + end if; + + -- Here we pick up the statements after the BEGIN that + -- should have been present but was not. We don't insist + -- on statements being present if P_Declarative_Part had + -- already found a missing BEGIN, since it might have + -- swallowed a lone statement into the declarative part. + + if Missing_Begin_Msg /= No_Error_Msg + and then Token = Tok_End + then + null; + else + Set_Handled_Statement_Sequence (Parent, + P_Handled_Sequence_Of_Statements); + end if; + end if; + end if; + end if; + + -- Here with declarations and handled statement sequence scanned + + if Present (Handled_Statement_Sequence (Parent)) then + End_Statements (Handled_Statement_Sequence (Parent)); + else + End_Statements; + end if; + + -- We know that End_Statements removed an entry from the scope stack + -- (because it is required to do so under all circumstances). We can + -- therefore reference the entry it removed one past the stack top. + -- What we are interested in is whether it was a case of a bad IS. + + if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then + Error_Msg ("IS should be "";""", Scope.Table (Scope.Last + 1).S_Is); + Set_Bad_Is_Detected (Parent, True); + end if; + + end Parse_Decls_Begin_End; + + ------------------------- + -- Set_Loop_Block_Name -- + ------------------------- + + function Set_Loop_Block_Name (L : Character) return Name_Id is + begin + Name_Buffer (1) := L; + Name_Buffer (2) := '_'; + Name_Len := 2; + Loop_Block_Count := Loop_Block_Count + 1; + Add_Nat_To_Name_Buffer (Loop_Block_Count); + return Name_Find; + end Set_Loop_Block_Name; + + --------------- + -- Then_Scan -- + --------------- + + procedure Then_Scan is + begin + TF_Then; + + while Token = Tok_Then loop + Error_Msg_SC ("redundant THEN"); + TF_Then; + end loop; + + if Token = Tok_And or else Token = Tok_Or then + Error_Msg_SC ("unexpected logical operator"); + Scan; + + if (Prev_Token = Tok_And and then Token = Tok_Then) + or else + (Prev_Token = Tok_Or and then Token = Tok_Else) + then + Scan; + end if; + + Discard_Junk_Node (P_Expression); + end if; + + if Token = Tok_Then then + Scan; + end if; + end Then_Scan; + +end Ch5; |