+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P A R . C H 5 --
--- --
--- B o d y --
--- --
--- $Revision: 1.2.10.1 $
--- --
--- 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. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-pragma Style_Checks (All_Checks);
--- Turn off subprogram body ordering check. Subprograms are in order
--- by RM section rather than alphabetical
-
-separate (Par)
-package body 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_IDENTIFIER ::= 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;
projects / msp430-gcc.git / blobdiff