Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / par-ch5.adb < prev next >

Wrap

Text File | 1996-09-28 | 71KB | 1,933 lines

------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 5 -- -- -- -- B o d y -- -- -- -- $Revision: 1.62 $ -- -- -- -- Copyright (c) 1992,1993,1994 NYU, All Rights Reserved -- -- -- -- 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, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ 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_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. --------------------------------- -- 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 sequenece: -- 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). Scan_State : Saved_Scan_State; Statement_List : List_Id; Statement_Node : Node_Id; Block_Label : Name_Id; Id_Node : Node_Id; Name_Node : Node_Id; procedure Test_Statement_Required; -- Flag error if Statement_Required flag set 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; -- If we are checking columns, then if the next statement is at -- the start of the line, it must start to the right of the opener -- of the enclosing construct. If not, then we terminate the scan -- for statements, and the caller will give an error message if -- we are not at an appropriate terminating token. if RM_Column_Check and then Token_Is_At_Start_Of_Line and then Start_Column <= Scope.Table (Scope.Last).Ecol then if Statement_Required then Error_Msg_BC ("incorrect layout for column check mode"); end if; exit; 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); TF_Then; 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 => -- Save scan pointers and line number in case block label Id_Node := Token_Node; Block_Label := Token_Name; Save_Scan_State (Scan_State); -- at Id 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 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 -- 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 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 a -- malformed attempt at an assignment symbol. elsif Token not in Token_Class_Eterm then Error_Msg_SP ("assignment symbol is "":="""); Append_To (Statement_List, P_Assignment_Statement (Id_Node)); -- 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); -- 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); -- 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 => 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 => Append_To (Statement_List, P_Pragma); -- Abort_Statement when Tok_Abort => Append_To (Statement_List, P_Abort_Statement); Statement_Required := False; -- Accept_Statement when Tok_Accept => Append_To (Statement_List, P_Accept_Statement); Statement_Required := False; -- Begin_Statement (Block_Statement with no declare, no label) when Tok_Begin => Append_To (Statement_List, P_Begin_Statement); Statement_Required := False; -- Case_Statement when Tok_Case => Append_To (Statement_List, P_Case_Statement); Statement_Required := False; -- Block_Statement with DECLARE and no label when Tok_Declare => Append_To (Statement_List, P_Declare_Statement); Statement_Required := False; -- Delay_Statement when Tok_Delay => Append_To (Statement_List, P_Delay_Statement); Statement_Required := False; -- Exit_Statement when Tok_Exit => Append_To (Statement_List, P_Exit_Statement); Statement_Required := False; -- Loop_Statement with FOR and no label when Tok_For => Append_To (Statement_List, P_For_Statement); Statement_Required := False; -- Goto_Statement when Tok_Goto => Append_To (Statement_List, P_Goto_Statement); Statement_Required := False; -- If_Statement when Tok_If => Append_To (Statement_List, P_If_Statement); Statement_Required := False; -- Loop_Statement when Tok_Loop => Append_To (Statement_List, P_Loop_Statement); Statement_Required := False; -- Null_Statement when Tok_Null => Append_To (Statement_List, P_Null_Statement); Statement_Required := False; -- Raise_Statement when Tok_Raise => Append_To (Statement_List, P_Raise_Statement); Statement_Required := False; -- Requeue_Statement when Tok_Requeue => Append_To (Statement_List, P_Requeue_Statement); Statement_Required := False; -- Return_Statement when Tok_Return => Append_To (Statement_List, P_Return_Statement); Statement_Required := False; -- Select_Statement when Tok_Select => Append_To (Statement_List, P_Select_Statement); Statement_Required := False; -- While_Statement (Block_Statement with while and no loop) when Tok_While => 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 => Error_Msg_BC ("statement expected"); raise Error_Resync; 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; -- 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; -- CONDITION ::= boolean_EXPRESSION -- 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_Expression_No_Right_Paren); Check_Then_Column; TF_Then; 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 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 ("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 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; If_Node := New_Node (N_If_Statement, Token_Ptr); if Token = Tok_If then Loc := Token_Ptr; Scan; -- past IF Set_Condition (If_Node, P_Expression_No_Right_Paren); -- 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; TF_Then; while Token = Tok_Then loop Error_Msg_SC ("redundant THEN"); Scan; -- past junk THEN end loop; 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 is always parsed (as an expression) by its parent construct ------------------------- -- 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 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; Case_Node := New_Node (N_Case_Statement, Token_Ptr); 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_Misplaced; 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"); Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm)); -- 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 Is_Empty_List (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 : can not 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), New_Internal_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; 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; 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), New_Internal_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_Expression_No_Right_Paren); -- 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; 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), New_Internal_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; begin Loop_Param_Specification_Node := New_Node (N_Loop_Parameter_Specification, Token_Ptr); ID_Node := P_Defining_Identifier; Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node); 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), New_Internal_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), New_Internal_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; 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; begin Exit_Node := New_Node (N_Exit_Statement, Token_Ptr); Scan; -- past EXIT if Token = Tok_Identifier then Set_Name (Exit_Node, Token_Node); Scan; -- past Identifier end if; if Token = Tok_When then Scan; -- past WHEN Set_Condition (Exit_Node, P_Expression_No_Right_Paren); -- 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; 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 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); end if; end Missing_Begin; -- Start of processing for Parse_Decls_Begin_End begin Decls := P_Declarative_Part; -- Check for misplacement of later vs basic declarations in Ada 83 -- Also carry out this check if we are checking for Ada 95 features if Ada_83 or Features_On 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 Decl := 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 Note_Feature (Later_Declaration_Ordering, Sloc (Decl)); if Ada_83 then Error_Msg_Sloc := Body_Sloc; Error_Msg_N ("(Ada 83) decl cannot appear after body#", Decl); end if; end if; Decl := 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; Scope.Table (Scope.Last).Ecol := Start_Column; 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. -- 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 null; -- BEGIN not required for these cases -- These are cases in which a BEGIN is required and not present else -- Issue error message Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc; Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; 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 End_Statements; -- 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; end Ch5;