------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S C N -- -- -- -- B o d y -- -- -- -- -- -- Copyright (C) 1992-2002 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. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Csets; use Csets; with Errout; use Errout; with Hostparm; use Hostparm; with Namet; use Namet; with Opt; use Opt; with Scans; use Scans; with Sinput; use Sinput; with Sinfo; use Sinfo; with Snames; use Snames; with Style; with Widechar; use Widechar; with System.CRC32; with System.WCh_Con; use System.WCh_Con; package body Scn is use ASCII; -- Make control characters visible Used_As_Identifier : array (Token_Type) of Boolean; -- Flags set True if a given keyword is used as an identifier (used to -- make sure that we only post an error message for incorrect use of a -- keyword as an identifier once for a given keyword). ----------------------- -- Local Subprograms -- ----------------------- procedure Accumulate_Checksum (C : Character); pragma Inline (Accumulate_Checksum); -- This routine accumulates the checksum given character C. During the -- scanning of a source file, this routine is called with every character -- in the source, excluding blanks, and all control characters (except -- that ESC is included in the checksum). Upper case letters not in string -- literals are folded by the caller. See Sinput spec for the documentation -- of the checksum algorithm. Note: checksum values are only used if we -- generate code, so it is not necessary to worry about making the right -- sequence of calls in any error situation. procedure Accumulate_Checksum (C : Char_Code); pragma Inline (Accumulate_Checksum); -- This version is identical, except that the argument, C, is a character -- code value instead of a character. This is used when wide characters -- are scanned. We use the character code rather than the ASCII characters -- so that the checksum is independent of wide character encoding method. procedure Initialize_Checksum; pragma Inline (Initialize_Checksum); -- Initialize checksum value procedure Check_End_Of_Line; -- Called when end of line encountered. Checks that line is not -- too long, and that other style checks for the end of line are met. function Determine_License return License_Type; -- Scan header of file and check that it has an appropriate GNAT-style -- header with a proper license statement. Returns GPL, Unrestricted, -- or Modified_GPL depending on header. If none of these, returns Unknown. function Double_Char_Token (C : Character) return Boolean; -- This function is used for double character tokens like := or <>. It -- checks if the character following Source (Scan_Ptr) is C, and if so -- bumps Scan_Ptr past the pair of characters and returns True. A space -- between the two characters is also recognized with an appropriate -- error message being issued. If C is not present, False is returned. -- Note that Double_Char_Token can only be used for tokens defined in -- the Ada syntax (it's use for error cases like && is not appropriate -- since we do not want a junk message for a case like &-space-&). procedure Error_Illegal_Character; -- Give illegal character error, Scan_Ptr points to character. On return, -- Scan_Ptr is bumped past the illegal character. procedure Error_Illegal_Wide_Character; -- Give illegal wide character message. On return, Scan_Ptr is bumped -- past the illegal character, which may still leave us pointing to -- junk, not much we can do if the escape sequence is messed up! procedure Error_Long_Line; -- Signal error of excessively long line procedure Error_No_Double_Underline; -- Signal error of double underline character procedure Nlit; -- This is the procedure for scanning out numeric literals. On entry, -- Scan_Ptr points to the digit that starts the numeric literal (the -- checksum for this character has not been accumulated yet). On return -- Scan_Ptr points past the last character of the numeric literal, Token -- and Token_Node are set appropriately, and the checksum is updated. function Set_Start_Column return Column_Number; -- This routine is called with Scan_Ptr pointing to the first character -- of a line. On exit, Scan_Ptr is advanced to the first non-blank -- character of this line (or to the terminating format effector if the -- line contains no non-blank characters), and the returned result is the -- column number of this non-blank character (zero origin), which is the -- value to be stored in the Start_Column scan variable. procedure Slit; -- This is the procedure for scanning out string literals. On entry, -- Scan_Ptr points to the opening string quote (the checksum for this -- character has not been accumulated yet). On return Scan_Ptr points -- past the closing quote of the string literal, Token and Token_Node -- are set appropriately, and the checksum is upated. ------------------------- -- Accumulate_Checksum -- ------------------------- procedure Accumulate_Checksum (C : Character) is begin System.CRC32.Update (System.CRC32.CRC32 (Checksum), C); end Accumulate_Checksum; procedure Accumulate_Checksum (C : Char_Code) is begin Accumulate_Checksum (Character'Val (C / 256)); Accumulate_Checksum (Character'Val (C mod 256)); end Accumulate_Checksum; ----------------------- -- Check_End_Of_Line -- ----------------------- procedure Check_End_Of_Line is Len : constant Int := Int (Scan_Ptr) - Int (Current_Line_Start); begin if Len > Hostparm.Max_Line_Length then Error_Long_Line; elsif Style_Check then Style.Check_Line_Terminator (Len); end if; end Check_End_Of_Line; ----------------------- -- Determine_License -- ----------------------- function Determine_License return License_Type is GPL_Found : Boolean := False; function Contains (S : String) return Boolean; -- See if current comment contains successive non-blank characters -- matching the contents of S. If so leave Scan_Ptr unchanged and -- return True, otherwise leave Scan_Ptr unchanged and return False. procedure Skip_EOL; -- Skip to line terminator character -------------- -- Contains -- -------------- function Contains (S : String) return Boolean is CP : Natural; SP : Source_Ptr; SS : Source_Ptr; begin SP := Scan_Ptr; while Source (SP) /= CR and then Source (SP) /= LF loop if Source (SP) = S (S'First) then SS := SP; CP := S'First; loop SS := SS + 1; CP := CP + 1; if CP > S'Last then return True; end if; while Source (SS) = ' ' loop SS := SS + 1; end loop; exit when Source (SS) /= S (CP); end loop; end if; SP := SP + 1; end loop; return False; end Contains; -------------- -- Skip_EOL -- -------------- procedure Skip_EOL is begin while Source (Scan_Ptr) /= CR and then Source (Scan_Ptr) /= LF loop Scan_Ptr := Scan_Ptr + 1; end loop; end Skip_EOL; -- Start of processing for Determine_License begin loop if Source (Scan_Ptr) /= '-' or else Source (Scan_Ptr + 1) /= '-' then if GPL_Found then return GPL; else return Unknown; end if; elsif Contains ("Asaspecialexception") then if GPL_Found then return Modified_GPL; end if; elsif Contains ("GNUGeneralPublicLicense") then GPL_Found := True; elsif Contains ("ThisspecificationisadaptedfromtheAdaSemanticInterface") or else Contains ("ThisspecificationisderivedfromtheAdaReferenceManual") then return Unrestricted; end if; Skip_EOL; Check_End_Of_Line; declare Physical : Boolean; begin Skip_Line_Terminators (Scan_Ptr, Physical); -- If we are at start of physical line, update scan pointers -- to reflect the start of the new line. if Physical then Current_Line_Start := Scan_Ptr; Start_Column := Set_Start_Column; First_Non_Blank_Location := Scan_Ptr; end if; end; end loop; end Determine_License; ---------------------------- -- Determine_Token_Casing -- ---------------------------- function Determine_Token_Casing return Casing_Type is begin return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1)); end Determine_Token_Casing; ----------------------- -- Double_Char_Token -- ----------------------- function Double_Char_Token (C : Character) return Boolean is begin if Source (Scan_Ptr + 1) = C then Accumulate_Checksum (C); Scan_Ptr := Scan_Ptr + 2; return True; elsif Source (Scan_Ptr + 1) = ' ' and then Source (Scan_Ptr + 2) = C then Scan_Ptr := Scan_Ptr + 1; Error_Msg_S ("no space allowed here"); Scan_Ptr := Scan_Ptr + 2; return True; else return False; end if; end Double_Char_Token; ----------------------------- -- Error_Illegal_Character -- ----------------------------- procedure Error_Illegal_Character is begin Error_Msg_S ("illegal character"); Scan_Ptr := Scan_Ptr + 1; end Error_Illegal_Character; ---------------------------------- -- Error_Illegal_Wide_Character -- ---------------------------------- procedure Error_Illegal_Wide_Character is begin if OpenVMS then Error_Msg_S ("illegal wide character, check " & "'/'W'I'D'E'_'C'H'A'R'A'C'T'E'R'_'E'N'C'O'D'I'N'G qualifer"); else Error_Msg_S ("illegal wide character, check -gnatW switch"); end if; Scan_Ptr := Scan_Ptr + 1; end Error_Illegal_Wide_Character; --------------------- -- Error_Long_Line -- --------------------- procedure Error_Long_Line is begin Error_Msg ("this line is too long", Current_Line_Start + Hostparm.Max_Line_Length); end Error_Long_Line; ------------------------------- -- Error_No_Double_Underline -- ------------------------------- procedure Error_No_Double_Underline is begin Error_Msg_S ("two consecutive underlines not permitted"); end Error_No_Double_Underline; ------------------------- -- Initialize_Checksum -- ------------------------- procedure Initialize_Checksum is begin System.CRC32.Initialize (System.CRC32.CRC32 (Checksum)); end Initialize_Checksum; ------------------------ -- Initialize_Scanner -- ------------------------ procedure Initialize_Scanner (Unit : Unit_Number_Type; Index : Source_File_Index) is GNAT_Hedr : constant Text_Buffer (1 .. 78) := (others => '-'); begin -- Set up Token_Type values in Names Table entries for reserved keywords -- We use the Pos value of the Token_Type value. Note we are relying on -- the fact that Token_Type'Val (0) is not a reserved word! Set_Name_Table_Byte (Name_Abort, Token_Type'Pos (Tok_Abort)); Set_Name_Table_Byte (Name_Abs, Token_Type'Pos (Tok_Abs)); Set_Name_Table_Byte (Name_Abstract, Token_Type'Pos (Tok_Abstract)); Set_Name_Table_Byte (Name_Accept, Token_Type'Pos (Tok_Accept)); Set_Name_Table_Byte (Name_Access, Token_Type'Pos (Tok_Access)); Set_Name_Table_Byte (Name_And, Token_Type'Pos (Tok_And)); Set_Name_Table_Byte (Name_Aliased, Token_Type'Pos (Tok_Aliased)); Set_Name_Table_Byte (Name_All, Token_Type'Pos (Tok_All)); Set_Name_Table_Byte (Name_Array, Token_Type'Pos (Tok_Array)); Set_Name_Table_Byte (Name_At, Token_Type'Pos (Tok_At)); Set_Name_Table_Byte (Name_Begin, Token_Type'Pos (Tok_Begin)); Set_Name_Table_Byte (Name_Body, Token_Type'Pos (Tok_Body)); Set_Name_Table_Byte (Name_Case, Token_Type'Pos (Tok_Case)); Set_Name_Table_Byte (Name_Constant, Token_Type'Pos (Tok_Constant)); Set_Name_Table_Byte (Name_Declare, Token_Type'Pos (Tok_Declare)); Set_Name_Table_Byte (Name_Delay, Token_Type'Pos (Tok_Delay)); Set_Name_Table_Byte (Name_Delta, Token_Type'Pos (Tok_Delta)); Set_Name_Table_Byte (Name_Digits, Token_Type'Pos (Tok_Digits)); Set_Name_Table_Byte (Name_Do, Token_Type'Pos (Tok_Do)); Set_Name_Table_Byte (Name_Else, Token_Type'Pos (Tok_Else)); Set_Name_Table_Byte (Name_Elsif, Token_Type'Pos (Tok_Elsif)); Set_Name_Table_Byte (Name_End, Token_Type'Pos (Tok_End)); Set_Name_Table_Byte (Name_Entry, Token_Type'Pos (Tok_Entry)); Set_Name_Table_Byte (Name_Exception, Token_Type'Pos (Tok_Exception)); Set_Name_Table_Byte (Name_Exit, Token_Type'Pos (Tok_Exit)); Set_Name_Table_Byte (Name_For, Token_Type'Pos (Tok_For)); Set_Name_Table_Byte (Name_Function, Token_Type'Pos (Tok_Function)); Set_Name_Table_Byte (Name_Generic, Token_Type'Pos (Tok_Generic)); Set_Name_Table_Byte (Name_Goto, Token_Type'Pos (Tok_Goto)); Set_Name_Table_Byte (Name_If, Token_Type'Pos (Tok_If)); Set_Name_Table_Byte (Name_In, Token_Type'Pos (Tok_In)); Set_Name_Table_Byte (Name_Is, Token_Type'Pos (Tok_Is)); Set_Name_Table_Byte (Name_Limited, Token_Type'Pos (Tok_Limited)); Set_Name_Table_Byte (Name_Loop, Token_Type'Pos (Tok_Loop)); Set_Name_Table_Byte (Name_Mod, Token_Type'Pos (Tok_Mod)); Set_Name_Table_Byte (Name_New, Token_Type'Pos (Tok_New)); Set_Name_Table_Byte (Name_Not, Token_Type'Pos (Tok_Not)); Set_Name_Table_Byte (Name_Null, Token_Type'Pos (Tok_Null)); Set_Name_Table_Byte (Name_Of, Token_Type'Pos (Tok_Of)); Set_Name_Table_Byte (Name_Or, Token_Type'Pos (Tok_Or)); Set_Name_Table_Byte (Name_Others, Token_Type'Pos (Tok_Others)); Set_Name_Table_Byte (Name_Out, Token_Type'Pos (Tok_Out)); Set_Name_Table_Byte (Name_Package, Token_Type'Pos (Tok_Package)); Set_Name_Table_Byte (Name_Pragma, Token_Type'Pos (Tok_Pragma)); Set_Name_Table_Byte (Name_Private, Token_Type'Pos (Tok_Private)); Set_Name_Table_Byte (Name_Procedure, Token_Type'Pos (Tok_Procedure)); Set_Name_Table_Byte (Name_Protected, Token_Type'Pos (Tok_Protected)); Set_Name_Table_Byte (Name_Raise, Token_Type'Pos (Tok_Raise)); Set_Name_Table_Byte (Name_Range, Token_Type'Pos (Tok_Range)); Set_Name_Table_Byte (Name_Record, Token_Type'Pos (Tok_Record)); Set_Name_Table_Byte (Name_Rem, Token_Type'Pos (Tok_Rem)); Set_Name_Table_Byte (Name_Renames, Token_Type'Pos (Tok_Renames)); Set_Name_Table_Byte (Name_Requeue, Token_Type'Pos (Tok_Requeue)); Set_Name_Table_Byte (Name_Return, Token_Type'Pos (Tok_Return)); Set_Name_Table_Byte (Name_Reverse, Token_Type'Pos (Tok_Reverse)); Set_Name_Table_Byte (Name_Select, Token_Type'Pos (Tok_Select)); Set_Name_Table_Byte (Name_Separate, Token_Type'Pos (Tok_Separate)); Set_Name_Table_Byte (Name_Subtype, Token_Type'Pos (Tok_Subtype)); Set_Name_Table_Byte (Name_Tagged, Token_Type'Pos (Tok_Tagged)); Set_Name_Table_Byte (Name_Task, Token_Type'Pos (Tok_Task)); Set_Name_Table_Byte (Name_Terminate, Token_Type'Pos (Tok_Terminate)); Set_Name_Table_Byte (Name_Then, Token_Type'Pos (Tok_Then)); Set_Name_Table_Byte (Name_Type, Token_Type'Pos (Tok_Type)); Set_Name_Table_Byte (Name_Until, Token_Type'Pos (Tok_Until)); Set_Name_Table_Byte (Name_Use, Token_Type'Pos (Tok_Use)); Set_Name_Table_Byte (Name_When, Token_Type'Pos (Tok_When)); Set_Name_Table_Byte (Name_While, Token_Type'Pos (Tok_While)); Set_Name_Table_Byte (Name_With, Token_Type'Pos (Tok_With)); Set_Name_Table_Byte (Name_Xor, Token_Type'Pos (Tok_Xor)); -- Initialize scan control variables Current_Source_File := Index; Source := Source_Text (Current_Source_File); Current_Source_Unit := Unit; Scan_Ptr := Source_First (Current_Source_File); Token := No_Token; Token_Ptr := Scan_Ptr; Current_Line_Start := Scan_Ptr; Token_Node := Empty; Token_Name := No_Name; Start_Column := Set_Start_Column; First_Non_Blank_Location := Scan_Ptr; Initialize_Checksum; -- Set default for Comes_From_Source. All nodes built now until we -- reenter the analyzer will have Comes_From_Source set to True Set_Comes_From_Source_Default (True); -- Check license if GNAT type header possibly present if Source_Last (Index) - Scan_Ptr > 80 and then Source (Scan_Ptr .. Scan_Ptr + 77) = GNAT_Hedr then Set_License (Current_Source_File, Determine_License); end if; -- Scan initial token (note this initializes Prev_Token, Prev_Token_Ptr) Scan; -- Clear flags for reserved words used as identifiers for J in Token_Type loop Used_As_Identifier (J) := False; end loop; end Initialize_Scanner; ---------- -- Nlit -- ---------- procedure Nlit is separate; ---------- -- Scan -- ---------- procedure Scan is begin Prev_Token := Token; Prev_Token_Ptr := Token_Ptr; Token_Name := Error_Name; -- The following loop runs more than once only if a format effector -- (tab, vertical tab, form feed, line feed, carriage return) is -- encountered and skipped, or some error situation, such as an -- illegal character, is encountered. loop -- Skip past blanks, loop is opened up for speed while Source (Scan_Ptr) = ' ' loop if Source (Scan_Ptr + 1) /= ' ' then Scan_Ptr := Scan_Ptr + 1; exit; end if; if Source (Scan_Ptr + 2) /= ' ' then Scan_Ptr := Scan_Ptr + 2; exit; end if; if Source (Scan_Ptr + 3) /= ' ' then Scan_Ptr := Scan_Ptr + 3; exit; end if; if Source (Scan_Ptr + 4) /= ' ' then Scan_Ptr := Scan_Ptr + 4; exit; end if; if Source (Scan_Ptr + 5) /= ' ' then Scan_Ptr := Scan_Ptr + 5; exit; end if; if Source (Scan_Ptr + 6) /= ' ' then Scan_Ptr := Scan_Ptr + 6; exit; end if; if Source (Scan_Ptr + 7) /= ' ' then Scan_Ptr := Scan_Ptr + 7; exit; end if; Scan_Ptr := Scan_Ptr + 8; end loop; -- We are now at a non-blank character, which is the first character -- of the token we will scan, and hence the value of Token_Ptr. Token_Ptr := Scan_Ptr; -- Here begins the main case statement which transfers control on -- the basis of the non-blank character we have encountered. case Source (Scan_Ptr) is -- Line terminator characters when CR | LF | FF | VT => Line_Terminator_Case : begin -- Check line too long Check_End_Of_Line; declare Physical : Boolean; begin Skip_Line_Terminators (Scan_Ptr, Physical); -- If we are at start of physical line, update scan pointers -- to reflect the start of the new line. if Physical then Current_Line_Start := Scan_Ptr; Start_Column := Set_Start_Column; First_Non_Blank_Location := Scan_Ptr; end if; end; end Line_Terminator_Case; -- Horizontal tab, just skip past it when HT => if Style_Check then Style.Check_HT; end if; Scan_Ptr := Scan_Ptr + 1; -- End of file character, treated as an end of file only if it -- is the last character in the buffer, otherwise it is ignored. when EOF => if Scan_Ptr = Source_Last (Current_Source_File) then Check_End_Of_Line; Token := Tok_EOF; return; else Scan_Ptr := Scan_Ptr + 1; end if; -- Ampersand when '&' => Accumulate_Checksum ('&'); if Source (Scan_Ptr + 1) = '&' then Error_Msg_S ("'&'& should be `AND THEN`"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_And; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Ampersand; return; end if; -- Asterisk (can be multiplication operator or double asterisk -- which is the exponentiation compound delimtier). when '*' => Accumulate_Checksum ('*'); if Source (Scan_Ptr + 1) = '*' then Accumulate_Checksum ('*'); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Double_Asterisk; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Asterisk; return; end if; -- Colon, which can either be an isolated colon, or part of an -- assignment compound delimiter. when ':' => Accumulate_Checksum (':'); if Double_Char_Token ('=') then Token := Tok_Colon_Equal; if Style_Check then Style.Check_Colon_Equal; end if; return; elsif Source (Scan_Ptr + 1) = '-' and then Source (Scan_Ptr + 2) /= '-' then Token := Tok_Colon_Equal; Error_Msg (":- should be :=", Scan_Ptr); Scan_Ptr := Scan_Ptr + 2; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Colon; if Style_Check then Style.Check_Colon; end if; return; end if; -- Left parenthesis when '(' => Accumulate_Checksum ('('); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Left_Paren; if Style_Check then Style.Check_Left_Paren; end if; return; -- Left bracket when '[' => if Source (Scan_Ptr + 1) = '"' then Name_Len := 0; goto Scan_Identifier; else Error_Msg_S ("illegal character, replaced by ""("""); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Left_Paren; return; end if; -- Left brace when '{' => Error_Msg_S ("illegal character, replaced by ""("""); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Left_Paren; return; -- Comma when ',' => Accumulate_Checksum (','); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Comma; if Style_Check then Style.Check_Comma; end if; return; -- Dot, which is either an isolated period, or part of a double -- dot compound delimiter sequence. We also check for the case of -- a digit following the period, to give a better error message. when '.' => Accumulate_Checksum ('.'); if Double_Char_Token ('.') then Token := Tok_Dot_Dot; if Style_Check then Style.Check_Dot_Dot; end if; return; elsif Source (Scan_Ptr + 1) in '0' .. '9' then Error_Msg_S ("numeric literal cannot start with point"); Scan_Ptr := Scan_Ptr + 1; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Dot; return; end if; -- Equal, which can either be an equality operator, or part of the -- arrow (=>) compound delimiter. when '=' => Accumulate_Checksum ('='); if Double_Char_Token ('>') then Token := Tok_Arrow; if Style_Check then Style.Check_Arrow; end if; return; elsif Source (Scan_Ptr + 1) = '=' then Error_Msg_S ("== should be ="); Scan_Ptr := Scan_Ptr + 1; end if; Scan_Ptr := Scan_Ptr + 1; Token := Tok_Equal; return; -- Greater than, which can be a greater than operator, greater than -- or equal operator, or first character of a right label bracket. when '>' => Accumulate_Checksum ('>'); if Double_Char_Token ('=') then Token := Tok_Greater_Equal; return; elsif Double_Char_Token ('>') then Token := Tok_Greater_Greater; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Greater; return; end if; -- Less than, which can be a less than operator, less than or equal -- operator, or the first character of a left label bracket, or the -- first character of a box (<>) compound delimiter. when '<' => Accumulate_Checksum ('<'); if Double_Char_Token ('=') then Token := Tok_Less_Equal; return; elsif Double_Char_Token ('>') then Token := Tok_Box; if Style_Check then Style.Check_Box; end if; return; elsif Double_Char_Token ('<') then Token := Tok_Less_Less; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Less; return; end if; -- Minus, which is either a subtraction operator, or the first -- character of double minus starting a comment when '-' => Minus_Case : begin if Source (Scan_Ptr + 1) = '>' then Error_Msg_S ("invalid token"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Arrow; return; elsif Source (Scan_Ptr + 1) /= '-' then Accumulate_Checksum ('-'); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Minus; return; -- Comment else -- Source (Scan_Ptr + 1) = '-' then if Style_Check then Style.Check_Comment; end if; Scan_Ptr := Scan_Ptr + 2; -- Loop to scan comment (this loop runs more than once only if -- a horizontal tab or other non-graphic character is scanned) loop -- Scan to non graphic character (opened up for speed) loop exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; end loop; -- Keep going if horizontal tab if Source (Scan_Ptr) = HT then if Style_Check then Style.Check_HT; end if; Scan_Ptr := Scan_Ptr + 1; -- Terminate scan of comment if line terminator elsif Source (Scan_Ptr) in Line_Terminator then exit; -- Terminate scan of comment if end of file encountered -- (embedded EOF character or real last character in file) elsif Source (Scan_Ptr) = EOF then exit; -- Keep going if character in 80-FF range, or is ESC. These -- characters are allowed in comments by RM-2.1(1), 2.7(2). -- They are allowed even in Ada 83 mode according to the -- approved AI. ESC was added to the AI in June 93. elsif Source (Scan_Ptr) in Upper_Half_Character or else Source (Scan_Ptr) = ESC then Scan_Ptr := Scan_Ptr + 1; -- Otherwise we have an illegal comment character else Error_Illegal_Character; end if; end loop; -- Note that we do NOT execute a return here, instead we fall -- through to reexecute the scan loop to look for a token. end if; end Minus_Case; -- Double quote or percent starting a string literal when '"' | '%' => Slit; return; -- Apostrophe. This can either be the start of a character literal, -- or an isolated apostrophe used in a qualified expression or an -- attribute. We treat it as a character literal if it does not -- follow a right parenthesis, identifier, the keyword ALL or -- a literal. This means that we correctly treat constructs like: -- A := CHARACTER'('A'); -- Note that RM-2.2(7) does not require a separator between -- "CHARACTER" and "'" in the above. when ''' => Char_Literal_Case : declare Code : Char_Code; Err : Boolean; begin Accumulate_Checksum ('''); Scan_Ptr := Scan_Ptr + 1; -- Here is where we make the test to distinguish the cases. Treat -- as apostrophe if previous token is an identifier, right paren -- or the reserved word "all" (latter case as in A.all'Address) -- Also treat it as apostrophe after a literal (this catches -- some legitimate cases, like A."abs"'Address, and also gives -- better error behavior for impossible cases like 123'xxx). if Prev_Token = Tok_Identifier or else Prev_Token = Tok_Right_Paren or else Prev_Token = Tok_All or else Prev_Token in Token_Class_Literal then Token := Tok_Apostrophe; return; -- Otherwise the apostrophe starts a character literal else -- Case of wide character literal with ESC or [ encoding if (Source (Scan_Ptr) = ESC and then Wide_Character_Encoding_Method in WC_ESC_Encoding_Method) or else (Source (Scan_Ptr) in Upper_Half_Character and then Upper_Half_Encoding) or else (Source (Scan_Ptr) = '[' and then Source (Scan_Ptr + 1) = '"') then Scan_Wide (Source, Scan_Ptr, Code, Err); Accumulate_Checksum (Code); if Err then Error_Illegal_Wide_Character; end if; if Source (Scan_Ptr) /= ''' then Error_Msg_S ("missing apostrophe"); else Scan_Ptr := Scan_Ptr + 1; end if; -- If we do not find a closing quote in the expected place then -- assume that we have a misguided attempt at a string literal. -- However, if previous token is RANGE, then we return an -- apostrophe instead since this gives better error recovery elsif Source (Scan_Ptr + 1) /= ''' then if Prev_Token = Tok_Range then Token := Tok_Apostrophe; return; else Scan_Ptr := Scan_Ptr - 1; Error_Msg_S ("strings are delimited by double quote character"); Scn.Slit; return; end if; -- Otherwise we have a (non-wide) character literal else Accumulate_Checksum (Source (Scan_Ptr)); if Source (Scan_Ptr) not in Graphic_Character then if Source (Scan_Ptr) in Upper_Half_Character then if Ada_83 then Error_Illegal_Character; end if; else Error_Illegal_Character; end if; end if; Code := Get_Char_Code (Source (Scan_Ptr)); Scan_Ptr := Scan_Ptr + 2; end if; -- Fall through here with Scan_Ptr updated past the closing -- quote, and Code set to the Char_Code value for the literal Accumulate_Checksum ('''); Token := Tok_Char_Literal; Token_Node := New_Node (N_Character_Literal, Token_Ptr); Set_Char_Literal_Value (Token_Node, Code); Set_Character_Literal_Name (Code); Token_Name := Name_Find; Set_Chars (Token_Node, Token_Name); return; end if; end Char_Literal_Case; -- Right parenthesis when ')' => Accumulate_Checksum (')'); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Right_Paren; if Style_Check then Style.Check_Right_Paren; end if; return; -- Right bracket or right brace, treated as right paren when ']' | '}' => Error_Msg_S ("illegal character, replaced by "")"""); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Right_Paren; return; -- Slash (can be division operator or first character of not equal) when '/' => Accumulate_Checksum ('/'); if Double_Char_Token ('=') then Token := Tok_Not_Equal; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Slash; return; end if; -- Semicolon when ';' => Accumulate_Checksum (';'); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Semicolon; if Style_Check then Style.Check_Semicolon; end if; return; -- Vertical bar when '|' => Vertical_Bar_Case : begin Accumulate_Checksum ('|'); -- Special check for || to give nice message if Source (Scan_Ptr + 1) = '|' then Error_Msg_S ("""'|'|"" should be `OR ELSE`"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Or; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Vertical_Bar; if Style_Check then Style.Check_Vertical_Bar; end if; return; end if; end Vertical_Bar_Case; -- Exclamation, replacement character for vertical bar when '!' => Exclamation_Case : begin Accumulate_Checksum ('!'); if Source (Scan_Ptr + 1) = '=' then Error_Msg_S ("'!= should be /="); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Not_Equal; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Vertical_Bar; return; end if; end Exclamation_Case; -- Plus when '+' => Plus_Case : begin Accumulate_Checksum ('+'); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Plus; return; end Plus_Case; -- Digits starting a numeric literal when '0' .. '9' => Nlit; if Identifier_Char (Source (Scan_Ptr)) then Error_Msg_S ("delimiter required between literal and identifier"); end if; return; -- Lower case letters when 'a' .. 'z' => Name_Len := 1; Name_Buffer (1) := Source (Scan_Ptr); Accumulate_Checksum (Name_Buffer (1)); Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier; -- Upper case letters when 'A' .. 'Z' => Name_Len := 1; Name_Buffer (1) := Character'Val (Character'Pos (Source (Scan_Ptr)) + 32); Accumulate_Checksum (Name_Buffer (1)); Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier; -- Underline character when '_' => Error_Msg_S ("identifier cannot start with underline"); Name_Len := 1; Name_Buffer (1) := '_'; Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier; -- Space (not possible, because we scanned past blanks) when ' ' => raise Program_Error; -- Characters in top half of ASCII 8-bit chart when Upper_Half_Character => -- Wide character case. Note that Scan_Identifier will issue -- an appropriate message if wide characters are not allowed -- in identifiers. if Upper_Half_Encoding then Name_Len := 0; goto Scan_Identifier; -- Otherwise we have OK Latin-1 character else -- Upper half characters may possibly be identifier letters -- but can never be digits, so Identifier_Char can be used -- to test for a valid start of identifier character. if Identifier_Char (Source (Scan_Ptr)) then Name_Len := 0; goto Scan_Identifier; else Error_Illegal_Character; end if; end if; when ESC => -- ESC character, possible start of identifier if wide characters -- using ESC encoding are allowed in identifiers, which we can -- tell by looking at the Identifier_Char flag for ESC, which is -- only true if these conditions are met. if Identifier_Char (ESC) then Name_Len := 0; goto Scan_Identifier; else Error_Illegal_Wide_Character; end if; -- Invalid control characters when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | SO | SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM | FS | GS | RS | US | DEL => Error_Illegal_Character; -- Invalid graphic characters when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' => Error_Illegal_Character; -- End switch on non-blank character end case; -- End loop past format effectors. The exit from this loop is by -- executing a return statement following completion of token scan -- (control never falls out of this loop to the code which follows) end loop; -- Identifier scanning routine. On entry, some initial characters -- of the identifier may have already been stored in Name_Buffer. -- If so, Name_Len has the number of characters stored. otherwise -- Name_Len is set to zero on entry. <> -- This loop scans as fast as possible past lower half letters -- and digits, which we expect to be the most common characters. loop if Source (Scan_Ptr) in 'a' .. 'z' or else Source (Scan_Ptr) in '0' .. '9' then Name_Buffer (Name_Len + 1) := Source (Scan_Ptr); Accumulate_Checksum (Source (Scan_Ptr)); elsif Source (Scan_Ptr) in 'A' .. 'Z' then Name_Buffer (Name_Len + 1) := Character'Val (Character'Pos (Source (Scan_Ptr)) + 32); Accumulate_Checksum (Name_Buffer (Name_Len + 1)); else exit; end if; -- Open out the loop a couple of times for speed if Source (Scan_Ptr + 1) in 'a' .. 'z' or else Source (Scan_Ptr + 1) in '0' .. '9' then Name_Buffer (Name_Len + 2) := Source (Scan_Ptr + 1); Accumulate_Checksum (Source (Scan_Ptr + 1)); elsif Source (Scan_Ptr + 1) in 'A' .. 'Z' then Name_Buffer (Name_Len + 2) := Character'Val (Character'Pos (Source (Scan_Ptr + 1)) + 32); Accumulate_Checksum (Name_Buffer (Name_Len + 2)); else Scan_Ptr := Scan_Ptr + 1; Name_Len := Name_Len + 1; exit; end if; if Source (Scan_Ptr + 2) in 'a' .. 'z' or else Source (Scan_Ptr + 2) in '0' .. '9' then Name_Buffer (Name_Len + 3) := Source (Scan_Ptr + 2); Accumulate_Checksum (Source (Scan_Ptr + 2)); elsif Source (Scan_Ptr + 2) in 'A' .. 'Z' then Name_Buffer (Name_Len + 3) := Character'Val (Character'Pos (Source (Scan_Ptr + 2)) + 32); Accumulate_Checksum (Name_Buffer (Name_Len + 3)); else Scan_Ptr := Scan_Ptr + 2; Name_Len := Name_Len + 2; exit; end if; if Source (Scan_Ptr + 3) in 'a' .. 'z' or else Source (Scan_Ptr + 3) in '0' .. '9' then Name_Buffer (Name_Len + 4) := Source (Scan_Ptr + 3); Accumulate_Checksum (Source (Scan_Ptr + 3)); elsif Source (Scan_Ptr + 3) in 'A' .. 'Z' then Name_Buffer (Name_Len + 4) := Character'Val (Character'Pos (Source (Scan_Ptr + 3)) + 32); Accumulate_Checksum (Name_Buffer (Name_Len + 4)); else Scan_Ptr := Scan_Ptr + 3; Name_Len := Name_Len + 3; exit; end if; Scan_Ptr := Scan_Ptr + 4; Name_Len := Name_Len + 4; end loop; -- If we fall through, then we have encountered either an underline -- character, or an extended identifier character (i.e. one from the -- upper half), or a wide character, or an identifier terminator. -- The initial test speeds us up in the most common case where we -- have an identifier terminator. Note that ESC is an identifier -- character only if a wide character encoding method that uses -- ESC encoding is active, so if we find an ESC character we know -- that we have a wide character. if Identifier_Char (Source (Scan_Ptr)) then -- Case of underline, check for error cases of double underline, -- and for a trailing underline character if Source (Scan_Ptr) = '_' then Accumulate_Checksum ('_'); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := '_'; if Identifier_Char (Source (Scan_Ptr + 1)) then Scan_Ptr := Scan_Ptr + 1; if Source (Scan_Ptr) = '_' then Error_No_Double_Underline; end if; else Error_Msg_S ("identifier cannot end with underline"); Scan_Ptr := Scan_Ptr + 1; end if; goto Scan_Identifier; -- Upper half character elsif Source (Scan_Ptr) in Upper_Half_Character and then not Upper_Half_Encoding then Accumulate_Checksum (Source (Scan_Ptr)); Store_Encoded_Character (Get_Char_Code (Fold_Lower (Source (Scan_Ptr)))); Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier; -- Left bracket not followed by a quote terminates an identifier. -- This is an error, but we don't want to give a junk error msg -- about wide characters in this case! elsif Source (Scan_Ptr) = '[' and then Source (Scan_Ptr + 1) /= '"' then null; -- We know we have a wide character encoding here (the current -- character is either ESC, left bracket, or an upper half -- character depending on the encoding method). else -- Scan out the wide character and insert the appropriate -- encoding into the name table entry for the identifier. declare Sptr : constant Source_Ptr := Scan_Ptr; Code : Char_Code; Err : Boolean; Chr : Character; begin Scan_Wide (Source, Scan_Ptr, Code, Err); -- If error, signal error if Err then Error_Illegal_Wide_Character; -- If the character scanned is a normal identifier -- character, then we treat it that way. elsif In_Character_Range (Code) and then Identifier_Char (Get_Character (Code)) then Chr := Get_Character (Code); Accumulate_Checksum (Chr); Store_Encoded_Character (Get_Char_Code (Fold_Lower (Chr))); -- Character is not normal identifier character, store -- it in encoded form. else Accumulate_Checksum (Code); Store_Encoded_Character (Code); -- Make sure we are allowing wide characters in -- identifiers. Note that we allow wide character -- notation for an OK identifier character. This -- in particular allows bracket or other notation -- to be used for upper half letters. if Identifier_Character_Set /= 'w' then Error_Msg ("wide character not allowed in identifier", Sptr); end if; end if; end; goto Scan_Identifier; end if; end if; -- Scan of identifier is complete. The identifier is stored in -- Name_Buffer, and Scan_Ptr points past the last character. Token_Name := Name_Find; -- Here is where we check if it was a keyword if Get_Name_Table_Byte (Token_Name) /= 0 and then (Ada_95 or else Token_Name not in Ada_95_Reserved_Words) then Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name)); -- Deal with possible style check for non-lower case keyword, -- but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords -- for this purpose if they appear as attribute designators. -- Actually we only check the first character for speed. if Style_Check and then Source (Token_Ptr) <= 'Z' and then (Prev_Token /= Tok_Apostrophe or else (Token /= Tok_Access and then Token /= Tok_Delta and then Token /= Tok_Digits and then Token /= Tok_Range)) then Style.Non_Lower_Case_Keyword; end if; -- We must reset Token_Name since this is not an identifier -- and if we leave Token_Name set, the parser gets confused -- because it thinks it is dealing with an identifier instead -- of the corresponding keyword. Token_Name := No_Name; return; -- It is an identifier after all else Token_Node := New_Node (N_Identifier, Token_Ptr); Set_Chars (Token_Node, Token_Name); Token := Tok_Identifier; return; end if; end Scan; --------------------- -- Scan_First_Char -- --------------------- function Scan_First_Char return Source_Ptr is Ptr : Source_Ptr := Current_Line_Start; begin loop if Source (Ptr) = ' ' then Ptr := Ptr + 1; elsif Source (Ptr) = HT then if Style_Check then Style.Check_HT; end if; Ptr := Ptr + 1; else return Ptr; end if; end loop; end Scan_First_Char; ------------------------------ -- Scan_Reserved_Identifier -- ------------------------------ procedure Scan_Reserved_Identifier (Force_Msg : Boolean) is Token_Chars : constant String := Token_Type'Image (Token); begin -- We have in Token_Chars the image of the Token name, i.e. Tok_xxx. -- This code extracts the xxx and makes an identifier out of it. Name_Len := 0; for J in 5 .. Token_Chars'Length loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Fold_Lower (Token_Chars (J)); end loop; Token_Name := Name_Find; if not Used_As_Identifier (Token) or else Force_Msg then Error_Msg_Name_1 := Token_Name; Error_Msg_SC ("reserved word* cannot be used as identifier!"); Used_As_Identifier (Token) := True; end if; Token := Tok_Identifier; Token_Node := New_Node (N_Identifier, Token_Ptr); Set_Chars (Token_Node, Token_Name); end Scan_Reserved_Identifier; ---------------------- -- Set_Start_Column -- ---------------------- -- Note: it seems at first glance a little expensive to compute this value -- for every source line (since it is certainly not used for all source -- lines). On the other hand, it doesn't take much more work to skip past -- the initial white space on the line counting the columns than it would -- to scan past the white space using the standard scanning circuits. function Set_Start_Column return Column_Number is Start_Column : Column_Number := 0; begin -- Outer loop scans past horizontal tab characters Tabs_Loop : loop -- Inner loop scans past blanks as fast as possible, bumping Scan_Ptr -- past the blanks and adjusting Start_Column to account for them. Blanks_Loop : loop if Source (Scan_Ptr) = ' ' then if Source (Scan_Ptr + 1) = ' ' then if Source (Scan_Ptr + 2) = ' ' then if Source (Scan_Ptr + 3) = ' ' then if Source (Scan_Ptr + 4) = ' ' then if Source (Scan_Ptr + 5) = ' ' then if Source (Scan_Ptr + 6) = ' ' then Scan_Ptr := Scan_Ptr + 7; Start_Column := Start_Column + 7; else Scan_Ptr := Scan_Ptr + 6; Start_Column := Start_Column + 6; exit Blanks_Loop; end if; else Scan_Ptr := Scan_Ptr + 5; Start_Column := Start_Column + 5; exit Blanks_Loop; end if; else Scan_Ptr := Scan_Ptr + 4; Start_Column := Start_Column + 4; exit Blanks_Loop; end if; else Scan_Ptr := Scan_Ptr + 3; Start_Column := Start_Column + 3; exit Blanks_Loop; end if; else Scan_Ptr := Scan_Ptr + 2; Start_Column := Start_Column + 2; exit Blanks_Loop; end if; else Scan_Ptr := Scan_Ptr + 1; Start_Column := Start_Column + 1; exit Blanks_Loop; end if; else exit Blanks_Loop; end if; end loop Blanks_Loop; -- Outer loop keeps going only if a horizontal tab follows if Source (Scan_Ptr) = HT then if Style_Check then Style.Check_HT; end if; Scan_Ptr := Scan_Ptr + 1; Start_Column := (Start_Column / 8) * 8 + 8; else exit Tabs_Loop; end if; end loop Tabs_Loop; return Start_Column; end Set_Start_Column; ---------- -- Slit -- ---------- procedure Slit is separate; end Scn;