| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P A R . T C H K -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| -- Token scan routines |
| |
| -- Error recovery: none of the T_xxx or TF_xxx routines raise Error_Resync |
| |
| separate (Par) |
| package body Tchk is |
| |
| type Position is (SC, BC, AP); |
| -- Specify position of error message (see Error_Msg_SC/BC/AP) |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Check_Token (T : Token_Type; P : Position); |
| pragma Inline (Check_Token); |
| -- Called by T_xx routines to check for reserved keyword token. P is the |
| -- position of the error message if the token is missing (see Wrong_Token) |
| |
| procedure Wrong_Token (T : Token_Type; P : Position); |
| -- Called when scanning a reserved keyword when the keyword is not present. |
| -- T is the token type for the keyword, and P indicates the position to be |
| -- used to place a message relative to the current token if the keyword is |
| -- not located nearby. |
| |
| ----------------- |
| -- Check_Token -- |
| ----------------- |
| |
| procedure Check_Token (T : Token_Type; P : Position) is |
| begin |
| if Token = T then |
| Scan; |
| return; |
| else |
| Wrong_Token (T, P); |
| end if; |
| end Check_Token; |
| |
| ------------- |
| -- T_Abort -- |
| ------------- |
| |
| procedure T_Abort is |
| begin |
| Check_Token (Tok_Abort, SC); |
| end T_Abort; |
| |
| ------------- |
| -- T_Arrow -- |
| ------------- |
| |
| procedure T_Arrow is |
| begin |
| if Token = Tok_Arrow then |
| Scan; |
| |
| -- A little recovery helper, accept then in place of => |
| |
| elsif Token = Tok_Then then |
| Error_Msg_BC -- CODEFIX |
| ("|THEN should be ""='>"""); |
| Scan; -- past THEN used in place of => |
| |
| elsif Token = Tok_Colon_Equal then |
| Error_Msg_SC -- CODEFIX |
| ("|"":="" should be ""='>"""); |
| Scan; -- past := used in place of => |
| |
| else |
| Error_Msg_AP -- CODEFIX |
| ("missing ""='>"""); |
| end if; |
| end T_Arrow; |
| |
| ---------- |
| -- T_At -- |
| ---------- |
| |
| procedure T_At is |
| begin |
| Check_Token (Tok_At, SC); |
| end T_At; |
| |
| ------------ |
| -- T_Body -- |
| ------------ |
| |
| procedure T_Body is |
| begin |
| Check_Token (Tok_Body, BC); |
| end T_Body; |
| |
| ----------- |
| -- T_Box -- |
| ----------- |
| |
| procedure T_Box is |
| begin |
| if Token = Tok_Box then |
| Scan; |
| else |
| Error_Msg_AP -- CODEFIX |
| ("missing ""'<'>"""); |
| end if; |
| end T_Box; |
| |
| ------------- |
| -- T_Colon -- |
| ------------- |
| |
| procedure T_Colon is |
| begin |
| if Token = Tok_Colon then |
| Scan; |
| else |
| Error_Msg_AP -- CODEFIX |
| ("missing "":"""); |
| end if; |
| end T_Colon; |
| |
| ------------------- |
| -- T_Colon_Equal -- |
| ------------------- |
| |
| procedure T_Colon_Equal is |
| begin |
| if Token = Tok_Colon_Equal then |
| Scan; |
| |
| elsif Token = Tok_Equal then |
| Error_Msg_SC -- CODEFIX |
| ("|""="" should be "":="""); |
| Scan; |
| |
| elsif Token = Tok_Colon then |
| Error_Msg_SC -- CODEFIX |
| ("|"":"" should be "":="""); |
| Scan; |
| |
| elsif Token = Tok_Is then |
| Error_Msg_SC -- CODEFIX |
| ("|IS should be "":="""); |
| Scan; |
| |
| else |
| Error_Msg_AP -- CODEFIX |
| ("missing "":="""); |
| end if; |
| end T_Colon_Equal; |
| |
| ------------- |
| -- T_Comma -- |
| ------------- |
| |
| procedure T_Comma is |
| begin |
| if Token = Tok_Comma then |
| Scan; |
| |
| else |
| if Token = Tok_Pragma then |
| P_Pragmas_Misplaced; |
| end if; |
| |
| if Token = Tok_Comma then |
| Scan; |
| else |
| Error_Msg_AP -- CODEFIX |
| ("missing "","""); |
| end if; |
| end if; |
| |
| if Token = Tok_Pragma then |
| P_Pragmas_Misplaced; |
| end if; |
| end T_Comma; |
| |
| --------------- |
| -- T_Dot_Dot -- |
| --------------- |
| |
| procedure T_Dot_Dot is |
| begin |
| if Token = Tok_Dot_Dot then |
| Scan; |
| else |
| Error_Msg_AP -- CODEFIX |
| ("missing "".."""); |
| end if; |
| end T_Dot_Dot; |
| |
| ----------- |
| -- T_For -- |
| ----------- |
| |
| procedure T_For is |
| begin |
| Check_Token (Tok_For, AP); |
| end T_For; |
| |
| ----------------------- |
| -- T_Greater_Greater -- |
| ----------------------- |
| |
| procedure T_Greater_Greater is |
| begin |
| if Token = Tok_Greater_Greater then |
| Scan; |
| else |
| Error_Msg_AP -- CODEFIX |
| ("missing ""'>'>"""); |
| end if; |
| end T_Greater_Greater; |
| |
| ------------------ |
| -- T_Identifier -- |
| ------------------ |
| |
| procedure T_Identifier is |
| begin |
| if Token = Tok_Identifier then |
| Scan; |
| elsif Token in Token_Class_Literal then |
| Error_Msg_SC ("identifier expected"); |
| Scan; |
| else |
| Error_Msg_AP ("identifier expected"); |
| end if; |
| end T_Identifier; |
| |
| ---------- |
| -- T_In -- |
| ---------- |
| |
| procedure T_In is |
| begin |
| Check_Token (Tok_In, AP); |
| end T_In; |
| |
| ---------- |
| -- T_Is -- |
| ---------- |
| |
| procedure T_Is is |
| begin |
| Ignore (Tok_Semicolon); |
| |
| -- If we have IS scan past it |
| |
| if Token = Tok_Is then |
| Scan; |
| |
| -- And ignore any following semicolons |
| |
| Ignore (Tok_Semicolon); |
| |
| -- Allow OF, => or = to substitute for IS with complaint |
| |
| elsif Token = Tok_Arrow then |
| Error_Msg_SC -- CODEFIX |
| ("|""=>"" should be IS"); |
| Scan; -- past => |
| |
| elsif Token = Tok_Of then |
| Error_Msg_SC -- CODEFIX |
| ("|OF should be IS"); |
| Scan; -- past OF |
| |
| elsif Token = Tok_Equal then |
| Error_Msg_SC -- CODEFIX |
| ("|""="" should be IS"); |
| Scan; -- past = |
| |
| else |
| Wrong_Token (Tok_Is, AP); |
| end if; |
| |
| -- Ignore extra IS keywords |
| |
| while Token = Tok_Is loop |
| Error_Msg_SC -- CODEFIX |
| ("|extra IS ignored"); |
| Scan; |
| end loop; |
| end T_Is; |
| |
| ------------------ |
| -- T_Left_Paren -- |
| ------------------ |
| |
| procedure T_Left_Paren is |
| begin |
| if Token = Tok_Left_Paren then |
| Scan; |
| else |
| Error_Msg_AP -- CODEFIX |
| ("missing ""("""); |
| end if; |
| end T_Left_Paren; |
| |
| ------------ |
| -- T_Loop -- |
| ------------ |
| |
| procedure T_Loop is |
| begin |
| if Token = Tok_Do then |
| Error_Msg_SC -- CODEFIX |
| ("LOOP expected"); |
| Scan; |
| else |
| Check_Token (Tok_Loop, AP); |
| end if; |
| end T_Loop; |
| |
| ----------- |
| -- T_Mod -- |
| ----------- |
| |
| procedure T_Mod is |
| begin |
| Check_Token (Tok_Mod, AP); |
| end T_Mod; |
| |
| ----------- |
| -- T_New -- |
| ----------- |
| |
| procedure T_New is |
| begin |
| Check_Token (Tok_New, AP); |
| end T_New; |
| |
| ---------- |
| -- T_Of -- |
| ---------- |
| |
| procedure T_Of is |
| begin |
| Check_Token (Tok_Of, AP); |
| end T_Of; |
| |
| ---------- |
| -- T_Or -- |
| ---------- |
| |
| procedure T_Or is |
| begin |
| Check_Token (Tok_Or, AP); |
| end T_Or; |
| |
| --------------- |
| -- T_Private -- |
| --------------- |
| |
| procedure T_Private is |
| begin |
| Check_Token (Tok_Private, SC); |
| end T_Private; |
| |
| ------------- |
| -- T_Range -- |
| ------------- |
| |
| procedure T_Range is |
| begin |
| Check_Token (Tok_Range, AP); |
| end T_Range; |
| |
| -------------- |
| -- T_Record -- |
| -------------- |
| |
| procedure T_Record is |
| begin |
| Check_Token (Tok_Record, AP); |
| end T_Record; |
| |
| --------------------- |
| -- T_Right_Bracket -- |
| --------------------- |
| |
| procedure T_Right_Bracket is |
| begin |
| if Token = Tok_Right_Bracket then |
| Scan; |
| else |
| Error_Msg_AP -- CODEFIX |
| ("|missing ""']'"""); |
| end if; |
| end T_Right_Bracket; |
| |
| ------------------- |
| -- T_Right_Paren -- |
| ------------------- |
| |
| procedure T_Right_Paren is |
| begin |
| if Token = Tok_Right_Paren then |
| Scan; |
| else |
| Error_Msg_AP -- CODEFIX |
| ("|missing "")"""); |
| end if; |
| end T_Right_Paren; |
| |
| ----------------- |
| -- T_Semicolon -- |
| ----------------- |
| |
| procedure T_Semicolon is |
| begin |
| if Token = Tok_Semicolon then |
| Scan; |
| |
| if Token = Tok_Semicolon then |
| Error_Msg_SC -- CODEFIX |
| ("|extra "";"" ignored"); |
| Scan; |
| end if; |
| |
| return; |
| |
| elsif Token = Tok_Colon then |
| Error_Msg_SC -- CODEFIX |
| ("|"":"" should be "";"""); |
| Scan; |
| return; |
| |
| elsif Token = Tok_Comma then |
| Error_Msg_SC -- CODEFIX |
| ("|"","" should be "";"""); |
| Scan; |
| return; |
| |
| elsif Token = Tok_Dot then |
| Error_Msg_SC -- CODEFIX |
| ("|""."" should be "";"""); |
| Scan; |
| return; |
| |
| -- An interesting little case. If the previous token is a semicolon, |
| -- then there is no way that we can legitimately need another semicolon. |
| -- This could only arise in an situation where an error has already been |
| -- signalled. By simply ignoring the request for a semicolon in this |
| -- case, we avoid some spurious missing semicolon messages. |
| |
| elsif Prev_Token = Tok_Semicolon then |
| return; |
| |
| -- If the current token is | then this is a reasonable place to suggest |
| -- the possibility of a "C" confusion. |
| |
| elsif Token = Tok_Vertical_Bar then |
| Error_Msg_SC -- CODEFIX |
| ("unexpected occurrence of ""'|"", did you mean OR'?"); |
| Resync_Past_Semicolon; |
| return; |
| |
| -- Deal with pragma. If pragma is not at start of line, it is considered |
| -- misplaced otherwise we treat it as a normal missing semicolon case. |
| |
| elsif Token = Tok_Pragma and then not Token_Is_At_Start_Of_Line then |
| P_Pragmas_Misplaced; |
| |
| if Token = Tok_Semicolon then |
| Scan; |
| return; |
| end if; |
| end if; |
| |
| -- If none of those tests return, we really have a missing semicolon |
| |
| Error_Msg_AP -- CODEFIX |
| ("|missing "";"""); |
| return; |
| end T_Semicolon; |
| |
| ------------ |
| -- T_Then -- |
| ------------ |
| |
| procedure T_Then is |
| begin |
| Check_Token (Tok_Then, AP); |
| end T_Then; |
| |
| ------------ |
| -- T_Type -- |
| ------------ |
| |
| procedure T_Type is |
| begin |
| Check_Token (Tok_Type, BC); |
| end T_Type; |
| |
| ----------- |
| -- T_Use -- |
| ----------- |
| |
| procedure T_Use is |
| begin |
| Check_Token (Tok_Use, SC); |
| end T_Use; |
| |
| ------------ |
| -- T_When -- |
| ------------ |
| |
| procedure T_When is |
| begin |
| Check_Token (Tok_When, SC); |
| end T_When; |
| |
| ------------ |
| -- T_With -- |
| ------------ |
| |
| procedure T_With is |
| begin |
| Check_Token (Tok_With, BC); |
| end T_With; |
| |
| -------------- |
| -- TF_Arrow -- |
| -------------- |
| |
| procedure TF_Arrow is |
| Scan_State : Saved_Scan_State; |
| |
| begin |
| if Token = Tok_Arrow then |
| Scan; -- skip arrow and we are done |
| |
| elsif Token = Tok_Colon_Equal then |
| T_Arrow; -- Let T_Arrow give the message |
| |
| else |
| T_Arrow; -- give missing arrow message |
| Save_Scan_State (Scan_State); -- at start of junk tokens |
| |
| loop |
| if Prev_Token_Ptr < Current_Line_Start |
| or else Token = Tok_Semicolon |
| or else Token = Tok_EOF |
| then |
| Restore_Scan_State (Scan_State); -- to where we were |
| return; |
| end if; |
| |
| Scan; -- continue search |
| |
| if Token = Tok_Arrow then |
| Scan; -- past arrow |
| return; |
| end if; |
| end loop; |
| end if; |
| end TF_Arrow; |
| |
| ----------- |
| -- TF_Is -- |
| ----------- |
| |
| procedure TF_Is is |
| Scan_State : Saved_Scan_State; |
| |
| begin |
| if Token = Tok_Is then |
| T_Is; -- past IS and we are done |
| |
| -- Allow OF or => or = in place of IS (with error message) |
| |
| elsif Token = Tok_Of |
| or else Token = Tok_Arrow |
| or else Token = Tok_Equal |
| then |
| T_Is; -- give missing IS message and skip bad token |
| |
| else |
| T_Is; -- give missing IS message |
| Save_Scan_State (Scan_State); -- at start of junk tokens |
| |
| loop |
| if Prev_Token_Ptr < Current_Line_Start |
| or else Token = Tok_Semicolon |
| or else Token = Tok_EOF |
| then |
| Restore_Scan_State (Scan_State); -- to where we were |
| return; |
| end if; |
| |
| Scan; -- continue search |
| |
| if Token = Tok_Is |
| or else Token = Tok_Of |
| or else Token = Tok_Arrow |
| then |
| Scan; -- past IS or OF or => |
| return; |
| end if; |
| end loop; |
| end if; |
| end TF_Is; |
| |
| ------------- |
| -- TF_Loop -- |
| ------------- |
| |
| procedure TF_Loop is |
| Scan_State : Saved_Scan_State; |
| |
| begin |
| if Token = Tok_Loop then |
| Scan; -- past LOOP and we are done |
| |
| -- Allow DO or THEN in place of LOOP |
| |
| elsif Token = Tok_Then or else Token = Tok_Do then |
| T_Loop; -- give missing LOOP message |
| |
| else |
| T_Loop; -- give missing LOOP message |
| Save_Scan_State (Scan_State); -- at start of junk tokens |
| |
| loop |
| if Prev_Token_Ptr < Current_Line_Start |
| or else Token = Tok_Semicolon |
| or else Token = Tok_EOF |
| then |
| Restore_Scan_State (Scan_State); -- to where we were |
| return; |
| end if; |
| |
| Scan; -- continue search |
| |
| if Token = Tok_Loop or else Token = Tok_Then then |
| Scan; -- past loop or then (message already generated) |
| return; |
| end if; |
| end loop; |
| end if; |
| end TF_Loop; |
| |
| -------------- |
| -- TF_Return-- |
| -------------- |
| |
| procedure TF_Return is |
| Scan_State : Saved_Scan_State; |
| |
| begin |
| if Token = Tok_Return then |
| Scan; -- skip RETURN and we are done |
| |
| else |
| Error_Msg_SC -- CODEFIX |
| ("missing RETURN"); |
| Save_Scan_State (Scan_State); -- at start of junk tokens |
| |
| loop |
| if Prev_Token_Ptr < Current_Line_Start |
| or else Token = Tok_Semicolon |
| or else Token = Tok_EOF |
| then |
| Restore_Scan_State (Scan_State); -- to where we were |
| return; |
| end if; |
| |
| Scan; -- continue search |
| |
| if Token = Tok_Return then |
| Scan; -- past RETURN |
| return; |
| end if; |
| end loop; |
| end if; |
| end TF_Return; |
| |
| ------------------ |
| -- TF_Semicolon -- |
| ------------------ |
| |
| procedure TF_Semicolon is |
| Scan_State : Saved_Scan_State; |
| |
| begin |
| if Token = Tok_Semicolon then |
| T_Semicolon; |
| return; |
| |
| -- An interesting little test here. If the previous token is a |
| -- semicolon, then there is no way that we can legitimately need |
| -- another semicolon. This could only arise in an error situation |
| -- where an error has already been signalled. By simply ignoring |
| -- the request for a semicolon in this case, we avoid some spurious |
| -- missing semicolon messages. |
| |
| elsif Prev_Token = Tok_Semicolon then |
| return; |
| |
| else |
| -- Deal with pragma. If pragma is not at start of line, it is |
| -- considered misplaced otherwise we treat it as a normal |
| -- missing semicolon case. |
| |
| if Token = Tok_Pragma |
| and then not Token_Is_At_Start_Of_Line |
| then |
| P_Pragmas_Misplaced; |
| |
| if Token = Tok_Semicolon then |
| T_Semicolon; |
| return; |
| end if; |
| end if; |
| |
| -- Here we definitely have a missing semicolon, so give message |
| |
| T_Semicolon; |
| |
| -- Scan out junk on rest of line. Scan stops on END keyword, since |
| -- that seems to help avoid cascaded errors. |
| |
| Save_Scan_State (Scan_State); -- at start of junk tokens |
| |
| loop |
| if Prev_Token_Ptr < Current_Line_Start |
| or else Token = Tok_EOF |
| or else Token = Tok_End |
| then |
| Restore_Scan_State (Scan_State); -- to where we were |
| return; |
| end if; |
| |
| Scan; -- continue search |
| |
| if Token = Tok_Semicolon then |
| T_Semicolon; |
| return; |
| |
| elsif Token in Token_Class_After_SM then |
| return; |
| end if; |
| end loop; |
| end if; |
| end TF_Semicolon; |
| |
| ------------- |
| -- TF_Then -- |
| ------------- |
| |
| procedure TF_Then is |
| Scan_State : Saved_Scan_State; |
| |
| begin |
| if Token = Tok_Then then |
| Scan; -- past THEN and we are done |
| |
| else |
| T_Then; -- give missing THEN message |
| Save_Scan_State (Scan_State); -- at start of junk tokens |
| |
| loop |
| if Prev_Token_Ptr < Current_Line_Start |
| or else Token = Tok_Semicolon |
| or else Token = Tok_EOF |
| then |
| Restore_Scan_State (Scan_State); -- to where we were |
| return; |
| end if; |
| |
| Scan; -- continue search |
| |
| if Token = Tok_Then then |
| Scan; -- past THEN |
| return; |
| end if; |
| end loop; |
| end if; |
| end TF_Then; |
| |
| ------------ |
| -- TF_Use -- |
| ------------ |
| |
| procedure TF_Use is |
| Scan_State : Saved_Scan_State; |
| |
| begin |
| if Token = Tok_Use then |
| Scan; -- past USE and we are done |
| |
| else |
| T_Use; -- give USE expected message |
| Save_Scan_State (Scan_State); -- at start of junk tokens |
| |
| loop |
| if Prev_Token_Ptr < Current_Line_Start |
| or else Token = Tok_Semicolon |
| or else Token = Tok_EOF |
| then |
| Restore_Scan_State (Scan_State); -- to where we were |
| return; |
| end if; |
| |
| Scan; -- continue search |
| |
| if Token = Tok_Use then |
| Scan; -- past use |
| return; |
| end if; |
| end loop; |
| end if; |
| end TF_Use; |
| |
| ------------------ |
| -- U_Left_Paren -- |
| ------------------ |
| |
| procedure U_Left_Paren is |
| begin |
| if Token = Tok_Left_Paren then |
| Scan; |
| else |
| Error_Msg_AP -- CODEFIX |
| ("missing ""(""!"); |
| end if; |
| end U_Left_Paren; |
| |
| ------------------- |
| -- U_Right_Paren -- |
| ------------------- |
| |
| procedure U_Right_Paren is |
| begin |
| if Token = Tok_Right_Paren then |
| Scan; |
| else |
| Error_Msg_AP -- CODEFIX |
| ("|missing "")""!"); |
| end if; |
| end U_Right_Paren; |
| |
| ----------------- |
| -- Wrong_Token -- |
| ----------------- |
| |
| procedure Wrong_Token (T : Token_Type; P : Position) is |
| Missing : constant String := "missing "; |
| Image : constant String := Token_Type'Image (T); |
| Tok_Name : constant String := Image (5 .. Image'Length); |
| M : constant String := Missing & Tok_Name; |
| |
| begin |
| if Token = Tok_Semicolon then |
| Scan; |
| |
| if Token = T then |
| Error_Msg_SP -- CODEFIX |
| ("|extra "";"" ignored"); |
| Scan; |
| else |
| Error_Msg_SP (M); |
| end if; |
| |
| elsif Token = Tok_Comma then |
| Scan; |
| |
| if Token = T then |
| Error_Msg_SP -- CODEFIX |
| ("|extra "","" ignored"); |
| Scan; |
| |
| else |
| Error_Msg_SP (M); |
| end if; |
| |
| else |
| case P is |
| when SC => Error_Msg_SC (M); |
| when BC => Error_Msg_BC (M); |
| when AP => Error_Msg_AP (M); |
| end case; |
| end if; |
| end Wrong_Token; |
| |
| end Tchk; |
