URL https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [scng.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                 S C N G                                  --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2011, 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.      --
--                                                                          --
------------------------------------------------------------------------------
 
with Csets;    use Csets;
with Err_Vars; use Err_Vars;
with Hostparm; use Hostparm;
with Namet;    use Namet;
with Opt;      use Opt;
with Restrict; use Restrict;
with Rident;   use Rident;
with Scans;    use Scans;
with Sinput;   use Sinput;
with Snames;   use Snames;
with Stringt;  use Stringt;
with Stylesw;  use Stylesw;
with Uintp;    use Uintp;
with Urealp;   use Urealp;
with Widechar; use Widechar;
 
pragma Warnings (Off);
--  This package is used also by gnatcoll
with System.CRC32;
with System.UTF_32;  use System.UTF_32;
with System.WCh_Con; use System.WCh_Con;
pragma Warnings (On);
 
package body Scng is
 
   use ASCII;
   --  Make control characters visible
 
   Special_Characters : array (Character) of Boolean := (others => False);
   --  For characters that are Special token, the value is True
 
   Comment_Is_Token : Boolean := False;
   --  True if comments are tokens
 
   End_Of_Line_Is_Token : Boolean := False;
   --  True if End_Of_Line is a token
 
   -----------------------
   -- Local Subprograms --
   -----------------------
 
   procedure Accumulate_Token_Checksum;
   pragma Inline (Accumulate_Token_Checksum);
   --  Called after each numeric literal and identifier/keyword. For keywords,
   --  the token used is Tok_Identifier. This allows to detect additional
   --  spaces added in sources when using the builder switch -m.
 
   procedure Accumulate_Token_Checksum_GNAT_6_3;
   --  Used in place of Accumulate_Token_Checksum for GNAT versions 5.04 to
   --  6.3, when Tok_Some was not included in Token_Type and the actual
   --  Token_Type was used for keywords. This procedure is never used in the
   --  compiler or gnatmake, only in gprbuild.
 
   procedure Accumulate_Token_Checksum_GNAT_5_03;
   --  Used in place of Accumulate_Token_Checksum for GNAT version 5.03, when
   --  Tok_Interface, Tok_Some, Tok_Synchronized and Tok_Overriding were not
   --  included in Token_Type and the actual Token_Type was used for keywords.
   --  This procedure is never used in the compiler or gnatmake, only in
   --  gprbuild.
 
   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
 
   -------------------------
   -- 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
      if C > 16#FFFF# then
         Accumulate_Checksum (Character'Val (C / 2 ** 24));
         Accumulate_Checksum (Character'Val ((C / 2 ** 16) mod 256));
         Accumulate_Checksum (Character'Val ((C / 256) mod 256));
      else
         Accumulate_Checksum (Character'Val (C / 256));
      end if;
 
      Accumulate_Checksum (Character'Val (C mod 256));
   end Accumulate_Checksum;
 
   -------------------------------
   -- Accumulate_Token_Checksum --
   -------------------------------
 
   procedure Accumulate_Token_Checksum is
   begin
      System.CRC32.Update
        (System.CRC32.CRC32 (Checksum),
         Character'Val (Token_Type'Pos (Token)));
   end Accumulate_Token_Checksum;
 
   ----------------------------------------
   -- Accumulate_Token_Checksum_GNAT_6_3 --
   ----------------------------------------
 
   procedure Accumulate_Token_Checksum_GNAT_6_3 is
   begin
      --  Individual values of Token_Type are used, instead of subranges, so
      --  that additions or suppressions of enumerated values in type
      --  Token_Type are detected by the compiler.
 
      case Token is
         when Tok_Integer_Literal | Tok_Real_Literal | Tok_String_Literal |
              Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier |
              Tok_Double_Asterisk | Tok_Ampersand | Tok_Minus | Tok_Plus |
              Tok_Asterisk | Tok_Mod | Tok_Rem | Tok_Slash | Tok_New |
              Tok_Abs | Tok_Others | Tok_Null | Tok_Dot | Tok_Apostrophe |
              Tok_Left_Paren | Tok_Delta | Tok_Digits | Tok_Range |
              Tok_Right_Paren | Tok_Comma | Tok_And | Tok_Or | Tok_Xor |
              Tok_Less | Tok_Equal | Tok_Greater | Tok_Not_Equal |
              Tok_Greater_Equal | Tok_Less_Equal | Tok_In | Tok_Not |
              Tok_Box | Tok_Colon_Equal | Tok_Colon | Tok_Greater_Greater |
              Tok_Abstract | Tok_Access | Tok_Aliased | Tok_All | Tok_Array |
              Tok_At | Tok_Body | Tok_Constant | Tok_Do | Tok_Is |
              Tok_Interface | Tok_Limited | Tok_Of | Tok_Out | Tok_Record |
              Tok_Renames | Tok_Reverse =>
 
            System.CRC32.Update
              (System.CRC32.CRC32 (Checksum),
               Character'Val (Token_Type'Pos (Token)));
 
         when Tok_Some =>
 
            System.CRC32.Update
              (System.CRC32.CRC32 (Checksum),
               Character'Val (Token_Type'Pos (Tok_Identifier)));
 
         when Tok_Tagged | Tok_Then | Tok_Less_Less | Tok_Abort | Tok_Accept |
              Tok_Case | Tok_Delay | Tok_Else | Tok_Elsif | Tok_End |
              Tok_Exception | Tok_Exit | Tok_Goto | Tok_If | Tok_Pragma |
              Tok_Raise | Tok_Requeue | Tok_Return | Tok_Select |
              Tok_Terminate | Tok_Until | Tok_When | Tok_Begin | Tok_Declare |
              Tok_For | Tok_Loop | Tok_While | Tok_Entry | Tok_Protected |
              Tok_Task | Tok_Type | Tok_Subtype | Tok_Overriding |
              Tok_Synchronized | Tok_Use | Tok_Function | Tok_Generic |
              Tok_Package | Tok_Procedure | Tok_Private | Tok_With |
              Tok_Separate | Tok_EOF | Tok_Semicolon | Tok_Arrow |
              Tok_Vertical_Bar | Tok_Dot_Dot | Tok_Project | Tok_Extends |
              Tok_External | Tok_External_As_List | Tok_Comment |
              Tok_End_Of_Line | Tok_Special | Tok_SPARK_Hide | No_Token =>
 
            System.CRC32.Update
              (System.CRC32.CRC32 (Checksum),
               Character'Val (Token_Type'Pos (Token_Type'Pred (Token))));
      end case;
   end Accumulate_Token_Checksum_GNAT_6_3;
 
   -----------------------------------------
   -- Accumulate_Token_Checksum_GNAT_5_03 --
   -----------------------------------------
 
   procedure Accumulate_Token_Checksum_GNAT_5_03 is
   begin
      --  Individual values of Token_Type are used, instead of subranges, so
      --  that additions or suppressions of enumerated values in type
      --  Token_Type are detected by the compiler.
 
      case Token is
         when Tok_Integer_Literal | Tok_Real_Literal | Tok_String_Literal |
              Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier |
              Tok_Double_Asterisk | Tok_Ampersand | Tok_Minus | Tok_Plus |
              Tok_Asterisk | Tok_Mod | Tok_Rem | Tok_Slash | Tok_New |
              Tok_Abs | Tok_Others | Tok_Null | Tok_Dot | Tok_Apostrophe |
              Tok_Left_Paren | Tok_Delta | Tok_Digits | Tok_Range |
              Tok_Right_Paren | Tok_Comma | Tok_And | Tok_Or | Tok_Xor |
              Tok_Less | Tok_Equal | Tok_Greater | Tok_Not_Equal |
              Tok_Greater_Equal | Tok_Less_Equal | Tok_In | Tok_Not |
              Tok_Box | Tok_Colon_Equal | Tok_Colon | Tok_Greater_Greater |
              Tok_Abstract | Tok_Access | Tok_Aliased | Tok_All | Tok_Array |
              Tok_At | Tok_Body | Tok_Constant | Tok_Do | Tok_Is =>
 
            System.CRC32.Update
              (System.CRC32.CRC32 (Checksum),
               Character'Val (Token_Type'Pos (Token)));
 
         when Tok_Interface | Tok_Some | Tok_Overriding | Tok_Synchronized =>
            System.CRC32.Update
              (System.CRC32.CRC32 (Checksum),
               Character'Val (Token_Type'Pos (Tok_Identifier)));
 
         when Tok_Limited | Tok_Of | Tok_Out | Tok_Record |
              Tok_Renames | Tok_Reverse =>
 
            System.CRC32.Update
              (System.CRC32.CRC32 (Checksum),
               Character'Val (Token_Type'Pos (Token) - 1));
 
         when Tok_Tagged | Tok_Then | Tok_Less_Less | Tok_Abort | Tok_Accept |
              Tok_Case | Tok_Delay | Tok_Else | Tok_Elsif | Tok_End |
              Tok_Exception | Tok_Exit | Tok_Goto | Tok_If | Tok_Pragma |
              Tok_Raise | Tok_Requeue | Tok_Return | Tok_Select |
              Tok_Terminate | Tok_Until | Tok_When | Tok_Begin | Tok_Declare |
              Tok_For | Tok_Loop | Tok_While | Tok_Entry | Tok_Protected |
              Tok_Task | Tok_Type | Tok_Subtype =>
 
            System.CRC32.Update
              (System.CRC32.CRC32 (Checksum),
               Character'Val (Token_Type'Pos (Token) - 2));
 
         when Tok_Use | Tok_Function | Tok_Generic |
              Tok_Package | Tok_Procedure | Tok_Private | Tok_With |
              Tok_Separate | Tok_EOF | Tok_Semicolon | Tok_Arrow |
              Tok_Vertical_Bar | Tok_Dot_Dot | Tok_Project | Tok_Extends |
              Tok_External | Tok_External_As_List | Tok_Comment |
              Tok_End_Of_Line | Tok_Special | Tok_SPARK_Hide | No_Token =>
 
            System.CRC32.Update
              (System.CRC32.CRC32 (Checksum),
               Character'Val (Token_Type'Pos (Token) - 4));
      end case;
   end Accumulate_Token_Checksum_GNAT_5_03;
 
   ----------------------------
   -- 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;
 
   -------------------------
   -- Initialize_Checksum --
   -------------------------
 
   procedure Initialize_Checksum is
   begin
      System.CRC32.Initialize (System.CRC32.CRC32 (Checksum));
   end Initialize_Checksum;
 
   ------------------------
   -- Initialize_Scanner --
   ------------------------
 
   procedure Initialize_Scanner (Index : Source_File_Index) is
   begin
      --  Establish reserved words
 
      Scans.Initialize_Ada_Keywords;
 
      --  Initialize scan control variables
 
      Current_Source_File       := Index;
      Source                    := Source_Text (Current_Source_File);
      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;
      Wide_Char_Byte_Count := 0;
 
      --  Do not call Scan, otherwise the License stuff does not work in Scn
 
   end Initialize_Scanner;
 
   ------------------------------
   -- Reset_Special_Characters --
   ------------------------------
 
   procedure Reset_Special_Characters is
   begin
      Special_Characters := (others => False);
   end Reset_Special_Characters;
 
   ----------
   -- Scan --
   ----------
 
   procedure Scan is
 
      Start_Of_Comment : Source_Ptr;
      --  Record start of comment position
 
      Underline_Found : Boolean;
      --  During scanning of an identifier, set to True if last character
      --  scanned was an underline or other punctuation character. This
      --  is used to flag the error of two underlines/punctuations in a
      --  row or ending an identifier with a underline/punctuation. Here
      --  punctuation means any UTF_32 character in the Unicode category
      --  Punctuation,Connector.
 
      Wptr : Source_Ptr;
      --  Used to remember start of last wide character scanned
 
      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 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 two underline or punctuation characters in a row.
      --  Called with Scan_Ptr pointing to second underline/punctuation char.
 
      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.
 
      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 updated.
 
      procedure Skip_Other_Format_Characters;
      --  Skips past any "other format" category characters at the current
      --  cursor location (does not skip past spaces or any other characters).
 
      function Start_Of_Wide_Character return Boolean;
      --  Returns True if the scan pointer is pointing to the start of a wide
      --  character sequence, does not modify the scan pointer in any case.
 
      -----------------------
      -- Check_End_Of_Line --
      -----------------------
 
      procedure Check_End_Of_Line is
         Len : constant Int :=
                 Int (Scan_Ptr) -
                 Int (Current_Line_Start) -
                 Wide_Char_Byte_Count;
 
      begin
         if Style_Check then
            Style.Check_Line_Terminator (Len);
         end if;
 
         --  Deal with checking maximum line length
 
         if Style_Check and Style_Check_Max_Line_Length then
            Style.Check_Line_Max_Length (Len);
 
         --  If style checking is inactive, check maximum line length against
         --  standard value.
 
         elsif Len > Max_Line_Length then
            Error_Long_Line;
         end if;
 
         --  Now one more checking circuit. Normally we are only enforcing a
         --  limit of physical characters, with tabs counting as one character.
         --  But if after tab expansion we would have a total line length that
         --  exceeded 32766, that would really cause trouble, because column
         --  positions would exceed the maximum we allow for a column count.
         --  Note: the limit is 32766 rather than 32767, since we use a value
         --  of 32767 for special purposes (see Sinput). Now we really do not
         --  want to go messing with tabs in the normal case, so what we do is
         --  to check for a line that has more than 4096 physical characters.
         --  Any shorter line could not be a problem, even if it was all tabs.
 
         if Len >= 4096 then
            declare
               Col : Natural;
               Ptr : Source_Ptr;
 
            begin
               Col := 1;
               Ptr := Current_Line_Start;
               loop
                  exit when Ptr = Scan_Ptr;
 
                  if Source (Ptr) = ASCII.HT then
                     Col := (Col - 1 + 8) / 8 * 8 + 1;
                  else
                     Col := Col + 1;
                  end if;
 
                  if Col > 32766 then
                     Error_Msg
                       ("this line is longer than 32766 characters",
                        Current_Line_Start);
                     raise Unrecoverable_Error;
                  end if;
 
                  Ptr := Ptr + 1;
               end loop;
            end;
         end if;
 
         --  Reset wide character byte count for next line
 
         Wide_Char_Byte_Count := 0;
      end Check_End_Of_Line;
 
      -----------------------
      -- 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 -- CODEFIX
              ("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
         Scan_Ptr := Scan_Ptr + 1;
         Error_Msg ("illegal wide character", Wptr);
      end Error_Illegal_Wide_Character;
 
      ---------------------
      -- Error_Long_Line --
      ---------------------
 
      procedure Error_Long_Line is
      begin
         Error_Msg
           ("this line is too long",
            Current_Line_Start + Source_Ptr (Max_Line_Length));
      end Error_Long_Line;
 
      -------------------------------
      -- Error_No_Double_Underline --
      -------------------------------
 
      procedure Error_No_Double_Underline is
      begin
         Underline_Found := False;
 
         --  There are four cases, and we special case the messages
 
         if Source (Scan_Ptr) = '_' then
            if Source (Scan_Ptr - 1) = '_' then
               Error_Msg_S -- CODEFIX
                 ("two consecutive underlines not permitted");
            else
               Error_Msg_S ("underline cannot follow punctuation character");
            end if;
 
         else
            if Source (Scan_Ptr - 1) = '_' then
               Error_Msg_S ("punctuation character cannot follow underline");
            else
               Error_Msg_S
                 ("two consecutive punctuation characters not permitted");
            end if;
         end if;
      end Error_No_Double_Underline;
 
      ----------
      -- Nlit --
      ----------
 
      procedure Nlit is
 
         C : Character;
         --  Current source program character
 
         Base_Char : Character;
         --  Either # or : (character at start of based number)
 
         Base : Int;
         --  Value of base
 
         UI_Base : Uint;
         --  Value of base in Uint format
 
         UI_Int_Value : Uint;
         --  Value of integer scanned by Scan_Integer in Uint format
 
         UI_Num_Value : Uint;
         --  Value of integer in numeric value being scanned
 
         Scale : Int;
         --  Scale value for real literal
 
         UI_Scale : Uint;
         --  Scale in Uint format
 
         Exponent_Is_Negative : Boolean;
         --  Set true for negative exponent
 
         Extended_Digit_Value : Int;
         --  Extended digit value
 
         Point_Scanned : Boolean;
         --  Flag for decimal point scanned in numeric literal
 
         -----------------------
         -- Local Subprograms --
         -----------------------
 
         procedure Error_Digit_Expected;
         --  Signal error of bad digit, Scan_Ptr points to the location at
         --  which the digit was expected on input, and is unchanged on return.
 
         procedure Scan_Integer;
         --  Procedure to scan integer literal. On entry, Scan_Ptr points to a
         --  digit, on exit Scan_Ptr points past the last character of the
         --  integer.
         --
         --  For each digit encountered, UI_Int_Value is multiplied by 10, and
         --  the value of the digit added to the result. In addition, the
         --  value in Scale is decremented by one for each actual digit
         --  scanned.
 
         --------------------------
         -- Error_Digit_Expected --
         --------------------------
 
         procedure Error_Digit_Expected is
         begin
            Error_Msg_S ("digit expected");
         end Error_Digit_Expected;
 
         ------------------
         -- Scan_Integer --
         ------------------
 
         procedure Scan_Integer is
            C : Character;
            --  Next character scanned
 
         begin
            C := Source (Scan_Ptr);
 
            --  Loop through digits (allowing underlines)
 
            loop
               Accumulate_Checksum (C);
               UI_Int_Value :=
                 UI_Int_Value * 10 + (Character'Pos (C) - Character'Pos ('0'));
               Scan_Ptr := Scan_Ptr + 1;
               Scale := Scale - 1;
               C := Source (Scan_Ptr);
 
               --  Case of underline encountered
 
               if C = '_' then
 
                  --  We do not accumulate the '_' in the checksum, so that
                  --  1_234 is equivalent to 1234, and does not trigger
                  --  compilation for "minimal recompilation" (gnatmake -m).
 
                  loop
                     Scan_Ptr := Scan_Ptr + 1;
                     C := Source (Scan_Ptr);
                     exit when C /= '_';
                     Error_No_Double_Underline;
                  end loop;
 
                  if C not in '0' .. '9' then
                     Error_Digit_Expected;
                     exit;
                  end if;
 
               else
                  exit when C not in '0' .. '9';
               end if;
            end loop;
         end Scan_Integer;
 
      --  Start of Processing for Nlit
 
      begin
         Base := 10;
         UI_Base := Uint_10;
         UI_Int_Value := Uint_0;
         Based_Literal_Uses_Colon := False;
         Scale := 0;
         Scan_Integer;
         Point_Scanned := False;
         UI_Num_Value := UI_Int_Value;
 
         --  Various possibilities now for continuing the literal are period,
         --  E/e (for exponent), or :/# (for based literal).
 
         Scale := 0;
         C := Source (Scan_Ptr);
 
         if C = '.' then
 
            --  Scan out point, but do not scan past .. which is a range
            --  sequence, and must not be eaten up scanning a numeric literal.
 
            while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop
               Accumulate_Checksum ('.');
 
               if Point_Scanned then
                  Error_Msg_S ("duplicate point ignored");
               end if;
 
               Point_Scanned := True;
               Scan_Ptr := Scan_Ptr + 1;
               C := Source (Scan_Ptr);
 
               if C not in '0' .. '9' then
                  Error_Msg
                    ("real literal cannot end with point", Scan_Ptr - 1);
               else
                  Scan_Integer;
                  UI_Num_Value := UI_Int_Value;
               end if;
            end loop;
 
         --  Based literal case. The base is the value we already scanned.
         --  In the case of colon, we insist that the following character
         --  is indeed an extended digit or a period. This catches a number
         --  of common errors, as well as catching the well known tricky
         --  bug otherwise arising from "x : integer range 1 .. 10:= 6;"
 
         elsif C = '#'
           or else (C = ':' and then
                      (Source (Scan_Ptr + 1) = '.'
                         or else
                       Source (Scan_Ptr + 1) in '0' .. '9'
                         or else
                       Source (Scan_Ptr + 1) in 'A' .. 'Z'
                         or else
                       Source (Scan_Ptr + 1) in 'a' .. 'z'))
         then
            Accumulate_Checksum (C);
            Base_Char := C;
            UI_Base := UI_Int_Value;
 
            if Base_Char = ':' then
               Based_Literal_Uses_Colon := True;
            end if;
 
            if UI_Base < 2 or else UI_Base > 16 then
               Error_Msg_SC ("base not 2-16");
               UI_Base := Uint_16;
            end if;
 
            Base := UI_To_Int (UI_Base);
            Scan_Ptr := Scan_Ptr + 1;
 
            --  Scan out extended integer [. integer]
 
            C := Source (Scan_Ptr);
            UI_Int_Value := Uint_0;
            Scale := 0;
 
            loop
               if C in '0' .. '9' then
                  Accumulate_Checksum (C);
                  Extended_Digit_Value :=
                    Int'(Character'Pos (C)) - Int'(Character'Pos ('0'));
 
               elsif C in 'A' .. 'F' then
                  Accumulate_Checksum (Character'Val (Character'Pos (C) + 32));
                  Extended_Digit_Value :=
                    Int'(Character'Pos (C)) - Int'(Character'Pos ('A')) + 10;
 
               elsif C in 'a' .. 'f' then
                  Accumulate_Checksum (C);
                  Extended_Digit_Value :=
                    Int'(Character'Pos (C)) - Int'(Character'Pos ('a')) + 10;
 
               else
                  Error_Msg_S ("extended digit expected");
                  exit;
               end if;
 
               if Extended_Digit_Value >= Base then
                  Error_Msg_S ("digit '>= base");
               end if;
 
               UI_Int_Value := UI_Int_Value * UI_Base + Extended_Digit_Value;
               Scale := Scale - 1;
               Scan_Ptr := Scan_Ptr + 1;
               C := Source (Scan_Ptr);
 
               if C = '_' then
                  loop
                     Accumulate_Checksum ('_');
                     Scan_Ptr := Scan_Ptr + 1;
                     C := Source (Scan_Ptr);
                     exit when C /= '_';
                     Error_No_Double_Underline;
                  end loop;
 
               elsif C = '.' then
                  Accumulate_Checksum ('.');
 
                  if Point_Scanned then
                     Error_Msg_S ("duplicate point ignored");
                  end if;
 
                  Scan_Ptr := Scan_Ptr + 1;
                  C := Source (Scan_Ptr);
                  Point_Scanned := True;
                  Scale := 0;
 
               elsif C = Base_Char then
                  Accumulate_Checksum (C);
                  Scan_Ptr := Scan_Ptr + 1;
                  exit;
 
               elsif C = '#' or else C = ':' then
                  Error_Msg_S ("based number delimiters must match");
                  Scan_Ptr := Scan_Ptr + 1;
                  exit;
 
               elsif not Identifier_Char (C) then
                  if Base_Char = '#' then
                     Error_Msg_S -- CODEFIX
                       ("missing '#");
                  else
                     Error_Msg_S -- CODEFIX
                       ("missing ':");
                  end if;
 
                  exit;
               end if;
 
            end loop;
 
            UI_Num_Value := UI_Int_Value;
         end if;
 
         --  Scan out exponent
 
         if not Point_Scanned then
            Scale := 0;
            UI_Scale := Uint_0;
         else
            UI_Scale := UI_From_Int (Scale);
         end if;
 
         if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then
            Accumulate_Checksum ('e');
            Scan_Ptr := Scan_Ptr + 1;
            Exponent_Is_Negative := False;
 
            if Source (Scan_Ptr) = '+' then
               Accumulate_Checksum ('+');
               Scan_Ptr := Scan_Ptr + 1;
 
            elsif Source (Scan_Ptr) = '-' then
               Accumulate_Checksum ('-');
 
               if not Point_Scanned then
                  Error_Msg_S
                    ("negative exponent not allowed for integer literal");
               else
                  Exponent_Is_Negative := True;
               end if;
 
               Scan_Ptr := Scan_Ptr + 1;
            end if;
 
            UI_Int_Value := Uint_0;
 
            if Source (Scan_Ptr) in '0' .. '9' then
               Scan_Integer;
            else
               Error_Digit_Expected;
            end if;
 
            if Exponent_Is_Negative then
               UI_Scale := UI_Scale - UI_Int_Value;
            else
               UI_Scale := UI_Scale + UI_Int_Value;
            end if;
         end if;
 
         --  Case of real literal to be returned
 
         if Point_Scanned then
            Token := Tok_Real_Literal;
            Real_Literal_Value :=
              UR_From_Components (
                                  Num   => UI_Num_Value,
                                  Den   => -UI_Scale,
                                  Rbase => Base);
 
         --  Case of integer literal to be returned
 
         else
            Token := Tok_Integer_Literal;
 
            if UI_Scale = 0 then
               Int_Literal_Value := UI_Num_Value;
 
            --  Avoid doing possibly expensive calculations in cases like
            --  parsing 163E800_000# when semantics will not be done anyway.
            --  This is especially useful when parsing garbled input.
 
            elsif Operating_Mode /= Check_Syntax
              and then (Serious_Errors_Detected = 0 or else Try_Semantics)
            then
               Int_Literal_Value := UI_Num_Value * UI_Base ** UI_Scale;
 
            else
               Int_Literal_Value := No_Uint;
            end if;
         end if;
 
         if Checksum_Accumulate_Token_Checksum then
            Accumulate_Token_Checksum;
         end if;
 
         return;
      end Nlit;
 
      ----------
      -- Slit --
      ----------
 
      procedure Slit is
 
         Delimiter : Character;
         --  Delimiter (first character of string)
 
         C : Character;
         --  Current source program character
 
         Code : Char_Code;
         --  Current character code value
 
         Err : Boolean;
         --  Error flag for Scan_Wide call
 
         String_Start : Source_Ptr;
         --  Point to first character of string
 
         procedure Error_Bad_String_Char;
         --  Signal bad character in string/character literal. On entry
         --  Scan_Ptr points to the improper character encountered during the
         --  scan. Scan_Ptr is not modified, so it still points to the bad
         --  character on return.
 
         procedure Error_Unterminated_String;
         --  Procedure called if a line terminator character is encountered
         --  during scanning a string, meaning that the string is not properly
         --  terminated.
 
         procedure Set_String;
         --  Procedure used to distinguish between string and operator symbol.
         --  On entry the string has been scanned out, and its characters start
         --  at Token_Ptr and end one character before Scan_Ptr. On exit Token
         --  is set to Tok_String_Literal/Tok_Operator_Symbol as appropriate,
         --  and Token_Node is appropriately initialized. In addition, in the
         --  operator symbol case, Token_Name is appropriately set, and the
         --  flags [Wide_]Wide_Character_Found are set appropriately.
 
         ---------------------------
         -- Error_Bad_String_Char --
         ---------------------------
 
         procedure Error_Bad_String_Char is
            C : constant Character := Source (Scan_Ptr);
 
         begin
            if C = HT then
               Error_Msg_S ("horizontal tab not allowed in string");
 
            elsif C = VT or else C = FF then
               Error_Msg_S ("format effector not allowed in string");
 
            elsif C in Upper_Half_Character then
               Error_Msg_S ("(Ada 83) upper half character not allowed");
 
            else
               Error_Msg_S ("control character not allowed in string");
            end if;
         end Error_Bad_String_Char;
 
         -------------------------------
         -- Error_Unterminated_String --
         -------------------------------
 
         procedure Error_Unterminated_String is
            S : Source_Ptr;
 
         begin
            --  An interesting little refinement. Consider the following
            --  examples:
 
            --     A := "this is an unterminated string;
            --     A := "this is an unterminated string &
            --     P(A, "this is a parameter that didn't get terminated);
            --     P("this is a parameter that didn't get terminated, A);
 
            --  We fiddle a little to do slightly better placement in these
            --  cases also if there is white space at the end of the line we
            --  place the flag at the start of this white space, not at the
            --  end. Note that we only have to test for blanks, since tabs
            --  aren't allowed in strings in the first place and would have
            --  caused an error message.
 
            --  Two more cases that we treat specially are:
 
            --     A := "this string uses the wrong terminator'
            --     A := "this string uses the wrong terminator' &
 
            --  In these cases we give a different error message as well
 
            --  We actually reposition the scan pointer to the point where we
            --  place the flag in these cases, since it seems a better bet on
            --  the original intention.
 
            while Source (Scan_Ptr - 1) = ' '
              or else Source (Scan_Ptr - 1) = '&'
            loop
               Scan_Ptr := Scan_Ptr - 1;
               Unstore_String_Char;
            end loop;
 
            --  Check for case of incorrect string terminator, but single quote
            --  is not considered incorrect if the opening terminator misused
            --  a single quote (error message already given).
 
            if Delimiter /= '''
              and then Source (Scan_Ptr - 1) = '''
            then
               Unstore_String_Char;
               Error_Msg
                 ("incorrect string terminator character", Scan_Ptr - 1);
               return;
            end if;
 
            --  Backup over semicolon or right-paren/semicolon sequence
 
            if Source (Scan_Ptr - 1) = ';' then
               Scan_Ptr := Scan_Ptr - 1;
               Unstore_String_Char;
 
               if Source (Scan_Ptr - 1) = ')' then
                  Scan_Ptr := Scan_Ptr - 1;
                  Unstore_String_Char;
               end if;
            end if;
 
            --  See if there is a comma in the string, if so, guess that
            --  the first comma terminates the string.
 
            S := String_Start;
            while S < Scan_Ptr loop
               if Source (S) = ',' then
                  while Scan_Ptr > S loop
                     Scan_Ptr := Scan_Ptr - 1;
                     Unstore_String_Char;
                  end loop;
 
                  exit;
               end if;
 
               S := S + 1;
            end loop;
 
            --  Now we have adjusted the scan pointer, give message
 
            Error_Msg_S -- CODEFIX
              ("missing string quote");
         end Error_Unterminated_String;
 
         ----------------
         -- Set_String --
         ----------------
 
         procedure Set_String is
            Slen : constant Int := Int (Scan_Ptr - Token_Ptr - 2);
            C1   : Character;
            C2   : Character;
            C3   : Character;
 
         begin
            --  Token_Name is currently set to Error_Name. The following
            --  section of code resets Token_Name to the proper Name_Op_xx
            --  value if the string is a valid operator symbol, otherwise it is
            --  left set to Error_Name.
 
            if Slen = 1 then
               C1 := Source (Token_Ptr + 1);
 
               case C1 is
                  when '=' =>
                     Token_Name := Name_Op_Eq;
 
                  when '>' =>
                     Token_Name := Name_Op_Gt;
 
                  when '<' =>
                     Token_Name := Name_Op_Lt;
 
                  when '+' =>
                     Token_Name := Name_Op_Add;
 
                  when '-' =>
                     Token_Name := Name_Op_Subtract;
 
                  when '&' =>
                     Token_Name := Name_Op_Concat;
 
                  when '*' =>
                     Token_Name := Name_Op_Multiply;
 
                  when '/' =>
                     Token_Name := Name_Op_Divide;
 
                  when others =>
                     null;
               end case;
 
            elsif Slen = 2 then
               C1 := Source (Token_Ptr + 1);
               C2 := Source (Token_Ptr + 2);
 
               if C1 = '*' and then C2 = '*' then
                  Token_Name := Name_Op_Expon;
 
               elsif C2 = '=' then
 
                  if C1 = '/' then
                     Token_Name := Name_Op_Ne;
                  elsif C1 = '<' then
                     Token_Name := Name_Op_Le;
                  elsif C1 = '>' then
                     Token_Name := Name_Op_Ge;
                  end if;
 
               elsif (C1 = 'O' or else C1 = 'o') and then    -- OR
                 (C2 = 'R' or else C2 = 'r')
               then
                  Token_Name := Name_Op_Or;
               end if;
 
            elsif Slen = 3 then
               C1 := Source (Token_Ptr + 1);
               C2 := Source (Token_Ptr + 2);
               C3 := Source (Token_Ptr + 3);
 
               if (C1 = 'A' or else C1 = 'a') and then       -- AND
                 (C2 = 'N' or else C2 = 'n') and then
                 (C3 = 'D' or else C3 = 'd')
               then
                  Token_Name := Name_Op_And;
 
               elsif (C1 = 'A' or else C1 = 'a') and then    -- ABS
                 (C2 = 'B' or else C2 = 'b') and then
                 (C3 = 'S' or else C3 = 's')
               then
                  Token_Name := Name_Op_Abs;
 
               elsif (C1 = 'M' or else C1 = 'm') and then    -- MOD
                 (C2 = 'O' or else C2 = 'o') and then
                 (C3 = 'D' or else C3 = 'd')
               then
                  Token_Name := Name_Op_Mod;
 
               elsif (C1 = 'N' or else C1 = 'n') and then    -- NOT
                 (C2 = 'O' or else C2 = 'o') and then
                 (C3 = 'T' or else C3 = 't')
               then
                  Token_Name := Name_Op_Not;
 
               elsif (C1 = 'R' or else C1 = 'r') and then    -- REM
                 (C2 = 'E' or else C2 = 'e') and then
                 (C3 = 'M' or else C3 = 'm')
               then
                  Token_Name := Name_Op_Rem;
 
               elsif (C1 = 'X' or else C1 = 'x') and then    -- XOR
                 (C2 = 'O' or else C2 = 'o') and then
                 (C3 = 'R' or else C3 = 'r')
               then
                  Token_Name := Name_Op_Xor;
               end if;
 
            end if;
 
            --  If it is an operator symbol, then Token_Name is set. If it is
            --  some other string value, then Token_Name still contains
            --  Error_Name.
 
            if Token_Name = Error_Name then
               Token := Tok_String_Literal;
 
            else
               Token := Tok_Operator_Symbol;
            end if;
         end Set_String;
 
      --  Start of processing for Slit
 
      begin
         --  On entry, Scan_Ptr points to the opening character of the string
         --  which is either a percent, double quote, or apostrophe (single
         --  quote). The latter case is an error detected by the character
         --  literal circuit.
 
         String_Start := Scan_Ptr;
 
         Delimiter := Source (Scan_Ptr);
         Accumulate_Checksum (Delimiter);
 
         Start_String;
         Wide_Character_Found      := False;
         Wide_Wide_Character_Found := False;
         Scan_Ptr := Scan_Ptr + 1;
 
         --  Loop to scan out characters of string literal
 
         loop
            C := Source (Scan_Ptr);
 
            if C = Delimiter then
               Accumulate_Checksum (C);
               Scan_Ptr := Scan_Ptr + 1;
               exit when Source (Scan_Ptr) /= Delimiter;
               Code := Get_Char_Code (C);
               Accumulate_Checksum (C);
               Scan_Ptr := Scan_Ptr + 1;
 
            else
               if C = '"' and then Delimiter = '%' then
                  Error_Msg_S
                    ("quote not allowed in percent delimited string");
                  Code := Get_Char_Code (C);
                  Scan_Ptr := Scan_Ptr + 1;
 
               elsif Start_Of_Wide_Character then
                  Wptr := Scan_Ptr;
                  Scan_Wide (Source, Scan_Ptr, Code, Err);
 
                  if Err then
                     Error_Illegal_Wide_Character;
                     Code := Get_Char_Code (' ');
                  end if;
 
                  Accumulate_Checksum (Code);
 
                  --  In Ada 95 mode we allow any wide characters in a string
                  --  but in Ada 2005, the set of characters allowed has been
                  --  restricted to graphic characters.
 
                  if Ada_Version >= Ada_2005
                    and then Is_UTF_32_Non_Graphic (UTF_32 (Code))
                  then
                     Error_Msg
                       ("(Ada 2005) non-graphic character not permitted " &
                        "in string literal", Wptr);
                  end if;
 
               else
                  Accumulate_Checksum (C);
 
                  if C not in Graphic_Character then
                     if C in Line_Terminator then
                        Error_Unterminated_String;
                        exit;
 
                     elsif C in Upper_Half_Character then
                        if Ada_Version = Ada_83 then
                           Error_Bad_String_Char;
                        end if;
 
                     else
                        Error_Bad_String_Char;
                     end if;
                  end if;
 
                  Code := Get_Char_Code (C);
                  Scan_Ptr := Scan_Ptr + 1;
               end if;
            end if;
 
            Store_String_Char (Code);
 
            if not In_Character_Range (Code) then
               if In_Wide_Character_Range (Code) then
                  Wide_Character_Found := True;
               else
                  Wide_Wide_Character_Found := True;
               end if;
            end if;
         end loop;
 
         String_Literal_Id := End_String;
         Set_String;
         return;
      end Slit;
 
      ----------------------------------
      -- Skip_Other_Format_Characters --
      ----------------------------------
 
      procedure Skip_Other_Format_Characters is
         P    : Source_Ptr;
         Code : Char_Code;
         Err  : Boolean;
 
      begin
         while Start_Of_Wide_Character loop
            P := Scan_Ptr;
            Scan_Wide (Source, Scan_Ptr, Code, Err);
 
            if not Is_UTF_32_Other (UTF_32 (Code)) then
               Scan_Ptr := P;
               return;
            end if;
         end loop;
      end Skip_Other_Format_Characters;
 
      -----------------------------
      -- Start_Of_Wide_Character --
      -----------------------------
 
      function Start_Of_Wide_Character return Boolean is
         C : constant Character := Source (Scan_Ptr);
 
      begin
         --  ESC encoding method with ESC present
 
         if C = ESC
           and then Wide_Character_Encoding_Method in WC_ESC_Encoding_Method
         then
            return True;
 
         --  Upper half character with upper half encoding
 
         elsif C in Upper_Half_Character and then Upper_Half_Encoding then
            return True;
 
         --  Brackets encoding
 
         elsif C = '['
           and then Source (Scan_Ptr + 1) = '"'
           and then Identifier_Char (Source (Scan_Ptr + 2))
         then
            return True;
 
         --  Not the start of a wide character
 
         else
            return False;
         end if;
      end Start_Of_Wide_Character;
 
   --  Start of processing for Scan
 
   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.
 
      <<Scan_Next_Character>>
 
      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 =>
            goto Scan_Line_Terminator;
 
         --  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;
 
               if Style_Check then
                  Style.Check_EOF;
               end if;
 
               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 -- CODEFIX
                 ("'&'& 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 delimiter).
 
         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 -- CODEFIX
                 (":- 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
               goto Scan_Wide_Character;
 
            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 -- CODEFIX
                 ("== 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;
 
               --  If we are in preprocessor mode with Replace_In_Comments set,
               --  then we return the "--" as a token on its own.
 
               if Replace_In_Comments then
                  Token := Tok_Comment;
                  return;
               end if;
 
               --  Otherwise scan out the comment
 
               Start_Of_Comment := Scan_Ptr;
 
               --  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)
 
                  --  Note that we just eat left brackets, which means that
                  --  bracket notation cannot be used for end of line
                  --  characters in comments. This seems a reasonable choice,
                  --  since no one would ever use brackets notation in a real
                  --  program in this situation, and if we allow brackets
                  --  notation, we forbid some valid comments which contain a
                  --  brackets sequence that happens to match an end of line
                  --  character.
 
                  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;
 
                  --  If we have a wide character, we have to scan it out,
                  --  because it might be a legitimate line terminator
 
                  elsif Start_Of_Wide_Character then
                     declare
                        Wptr : constant Source_Ptr := Scan_Ptr;
                        Code : Char_Code;
                        Err  : Boolean;
 
                     begin
                        Scan_Wide (Source, Scan_Ptr, Code, Err);
 
                        --  If not well formed wide character, then just skip
                        --  past it and ignore it.
 
                        if Err then
                           Scan_Ptr := Wptr + 1;
 
                        --  If UTF_32 terminator, terminate comment scan
 
                        elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then
                           Scan_Ptr := Wptr;
                           exit;
                        end if;
                     end;
 
                  --  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, except when comments are tokens, we do NOT
               --  execute a return here, instead we fall through to reexecute
               --  the scan loop to look for a token.
 
               if Comment_Is_Token then
                  Name_Len := Integer (Scan_Ptr - Start_Of_Comment);
                  Name_Buffer (1 .. Name_Len) :=
                    String (Source (Start_Of_Comment .. Scan_Ptr - 1));
                  Comment_Id := Name_Find;
                  Token := Tok_Comment;
                  return;
               end if;
 
               --  If the SPARK restriction is set for this unit, then generate
               --  a token Tok_SPARK_Hide for a SPARK HIDE directive.
 
               if Restriction_Check_Required (SPARK)
                 and then Source (Start_Of_Comment) = '#'
               then
                  declare
                     Scan_SPARK_Ptr : Source_Ptr;
 
                  begin
                     Scan_SPARK_Ptr := Start_Of_Comment + 1;
 
                     --  Scan out blanks
 
                     while Source (Scan_SPARK_Ptr) = ' '
                       or else Source (Scan_SPARK_Ptr) = HT
                     loop
                        Scan_SPARK_Ptr := Scan_SPARK_Ptr + 1;
                     end loop;
 
                     --  Recognize HIDE directive. SPARK input cannot be
                     --  encoded as wide characters, so only deal with
                     --  lower/upper case.
 
                     if (Source (Scan_SPARK_Ptr) = 'h'
                          or else Source (Scan_SPARK_Ptr) = 'H')
                       and then (Source (Scan_SPARK_Ptr + 1) = 'i'
                                  or else Source (Scan_SPARK_Ptr + 1) = 'I')
                       and then (Source (Scan_SPARK_Ptr + 2) = 'd'
                                  or else Source (Scan_SPARK_Ptr + 2) = 'D')
                       and then (Source (Scan_SPARK_Ptr + 3) = 'e'
                                  or else Source (Scan_SPARK_Ptr + 3) = 'E')
                       and then (Source (Scan_SPARK_Ptr + 4) = ' '
                                  or else Source (Scan_SPARK_Ptr + 4) = HT)
                     then
                        Token := Tok_SPARK_Hide;
                        return;
                     end if;
                  end;
               end if;
            end if;
         end Minus_Case;
 
         --  Double quote or percent starting a string literal
 
         when '"' | '%' =>
            Slit;
            Post_Scan;
            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)
            --  (or the reserved word "project" in project files). 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 = Tok_Project
               or else Prev_Token in Token_Class_Literal
            then
               Token := Tok_Apostrophe;
 
               if Style_Check then
                  Style.Check_Apostrophe;
               end if;
 
               return;
 
            --  Otherwise the apostrophe starts a character literal
 
            else
               --  Case of wide character literal
 
               if Start_Of_Wide_Character then
                  Wptr := Scan_Ptr;
                  Scan_Wide (Source, Scan_Ptr, Code, Err);
                  Accumulate_Checksum (Code);
 
                  if Err then
                     Error_Illegal_Wide_Character;
                     Code := Character'Pos (' ');
 
                  --  In Ada 95 mode we allow any wide character in a character
                  --  literal, but in Ada 2005, the set of characters allowed
                  --  is restricted to graphic characters.
 
                  elsif Ada_Version >= Ada_2005
                    and then Is_UTF_32_Non_Graphic (UTF_32 (Code))
                  then
                     Error_Msg -- CODEFIX????
                       ("(Ada 2005) non-graphic character not permitted " &
                        "in character literal", Wptr);
                  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");
                     Slit;
                     Post_Scan;
                     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_Version = 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;
               Set_Character_Literal_Name (Code);
               Token_Name := Name_Find;
               Character_Code := Code;
               Post_Scan;
               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 -- CODEFIX
                 ("""'|'|"" 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;
 
               Post_Scan;
               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 -- CODEFIX
                 ("'!= should be /=");
               Scan_Ptr := Scan_Ptr + 2;
               Token := Tok_Not_Equal;
               return;
 
            else
               Scan_Ptr := Scan_Ptr + 1;
               Token := Tok_Vertical_Bar;
               Post_Scan;
               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' =>
 
            --  First a bit of a scan ahead to see if we have a case of an
            --  identifier starting with a digit (remembering exponent case).
 
            declare
               C : constant Character := Source (Scan_Ptr + 1);
 
            begin
               --  OK literal if digit followed by digit or underscore
 
               if C in '0' .. '9' or else C = '_' then
                  null;
 
               --  OK literal if digit not followed by identifier char
 
               elsif not Identifier_Char (C) then
                  null;
 
               --  OK literal if digit followed by e/E followed by digit/sign.
               --  We also allow underscore after the E, which is an error, but
               --  better handled by Nlit than deciding this is an identifier.
 
               elsif (C = 'e' or else C = 'E')
                 and then (Source (Scan_Ptr + 2) in '0' .. '9'
                             or else Source (Scan_Ptr + 2) = '+'
                             or else Source (Scan_Ptr + 2) = '-'
                             or else Source (Scan_Ptr + 2) = '_')
               then
                  null;
 
               --  Here we have what really looks like an identifier that
               --  starts with a digit, so give error msg.
 
               else
                  Error_Msg_S ("identifier may not start with digit");
                  Name_Len := 1;
                  Underline_Found := False;
                  Name_Buffer (1) := Source (Scan_Ptr);
                  Accumulate_Checksum (Name_Buffer (1));
                  Scan_Ptr := Scan_Ptr + 1;
                  goto Scan_Identifier;
               end if;
            end;
 
            --  Here we have an OK integer literal
 
            Nlit;
 
            --  Check for proper delimiter, ignoring other format characters
 
            Skip_Other_Format_Characters;
 
            if Identifier_Char (Source (Scan_Ptr)) then
               Error_Msg_S
                 ("delimiter required between literal and identifier");
            end if;
 
            Post_Scan;
            return;
 
         --  Lower case letters
 
         when 'a' .. 'z' =>
            Name_Len := 1;
            Underline_Found := False;
            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;
            Underline_Found := False;
            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 '_' =>
            if Special_Characters ('_') then
               Token_Ptr := Scan_Ptr;
               Scan_Ptr := Scan_Ptr + 1;
               Token := Tok_Special;
               Special_Character := '_';
               return;
            end if;
 
            Error_Msg_S ("identifier cannot start with underline");
            Name_Len := 1;
            Name_Buffer (1) := '_';
            Scan_Ptr := Scan_Ptr + 1;
            Underline_Found := False;
            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
 
            if Upper_Half_Encoding then
               goto Scan_Wide_Character;
 
            --  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;
                  Underline_Found := False;
                  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. In Ada 2005 mode, may
            --  also be valid UTF_32 space or line terminator character.
 
            if Identifier_Char (ESC) then
               Name_Len := 0;
               goto Scan_Wide_Character;
            else
               Error_Illegal_Character;
            end if;
 
         --  Invalid control characters
 
         when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS  | ASCII.SO |
              SI  | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
              EM  | FS  | GS  | RS  | US  | DEL
         =>
            Error_Illegal_Character;
 
         --  Invalid graphic characters
 
         when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' =>
 
            --  If Set_Special_Character has been called for this character,
            --  set Scans.Special_Character and return a Special token.
 
            if Special_Characters (Source (Scan_Ptr)) then
               Token_Ptr := Scan_Ptr;
               Token := Tok_Special;
               Special_Character := Source (Scan_Ptr);
               Scan_Ptr := Scan_Ptr + 1;
               return;
 
            --  Otherwise, this is an illegal character
 
            else
               Error_Illegal_Character;
            end if;
 
         --  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;
 
      --  Wide_Character scanning routine. On entry we have encountered the
      --  initial character of a wide character sequence.
 
      <<Scan_Wide_Character>>
 
         declare
            Code : Char_Code;
            Cat  : Category;
            Err  : Boolean;
 
         begin
            Wptr := Scan_Ptr;
            Scan_Wide (Source, Scan_Ptr, Code, Err);
 
            --  If bad wide character, signal error and continue scan
 
            if Err then
               Error_Illegal_Wide_Character;
               goto Scan_Next_Character;
            end if;
 
            Cat := Get_Category (UTF_32 (Code));
 
            --  If OK letter, reset scan ptr and go scan identifier
 
            if Is_UTF_32_Letter (Cat) then
               Scan_Ptr := Wptr;
               Name_Len := 0;
               Underline_Found := False;
               goto Scan_Identifier;
 
            --  If OK wide space, ignore and keep scanning (we do not include
            --  any ignored spaces in checksum)
 
            elsif Is_UTF_32_Space (Cat) then
               goto Scan_Next_Character;
 
            --  If other format character, ignore and keep scanning (again we
            --  do not include in the checksum) (this is for AI-0079).
 
            elsif Is_UTF_32_Other (Cat) then
               goto Scan_Next_Character;
 
            --  If OK wide line terminator, terminate current line
 
            elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then
               Scan_Ptr := Wptr;
               goto Scan_Line_Terminator;
 
            --  Punctuation is an error (at start of identifier)
 
            elsif Is_UTF_32_Punctuation (Cat) then
               Error_Msg ("identifier cannot start with punctuation", Wptr);
               Scan_Ptr := Wptr;
               Name_Len := 0;
               Underline_Found := False;
               goto Scan_Identifier;
 
            --  Mark character is an error (at start of identifier)
 
            elsif Is_UTF_32_Mark (Cat) then
               Error_Msg ("identifier cannot start with mark character", Wptr);
               Scan_Ptr := Wptr;
               Name_Len := 0;
               Underline_Found := False;
               goto Scan_Identifier;
 
            --  Extended digit character is an error. Could be bad start of
            --  identifier or bad literal. Not worth doing too much to try to
            --  distinguish these cases, but we will do a little bit.
 
            elsif Is_UTF_32_Digit (Cat) then
               Error_Msg
                 ("identifier cannot start with digit character", Wptr);
               Scan_Ptr := Wptr;
               Name_Len := 0;
               Underline_Found := False;
               goto Scan_Identifier;
 
            --  All other wide characters are illegal here
 
            else
               Error_Illegal_Wide_Character;
               goto Scan_Next_Character;
            end if;
         end;
 
      --  Routine to scan line terminator. On entry Scan_Ptr points to a
      --  character which is one of FF,LR,CR,VT, or one of the wide characters
      --  that is treated as a line terminator.
 
      <<Scan_Line_Terminator>>
 
         --  Check line too long
 
         Check_End_Of_Line;
 
         --  Set Token_Ptr, if End_Of_Line is a token, for the case when it is
         --  a physical line.
 
         if End_Of_Line_Is_Token then
            Token_Ptr := Scan_Ptr;
         end if;
 
         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;
 
               --  If End_Of_Line is a token, we return it as it is a
               --  physical line.
 
               if End_Of_Line_Is_Token then
                  Token := Tok_End_Of_Line;
                  return;
               end if;
            end if;
         end;
 
         goto Scan_Next_Character;
 
      --  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. Underline_Found is also set False on entry.
 
      <<Scan_Identifier>>
 
         --  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;
 
            Underline_Found := False;
            Scan_Ptr := Scan_Ptr + 1;
            Name_Len := Name_Len + 1;
         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))
           or else (Source (Scan_Ptr) in Upper_Half_Character
                     and then Upper_Half_Encoding)
         then
            --  Case of underline
 
            if Source (Scan_Ptr) = '_' then
               Accumulate_Checksum ('_');
 
               if Underline_Found then
                  Error_No_Double_Underline;
               else
                  Underline_Found := True;
                  Name_Len := Name_Len + 1;
                  Name_Buffer (Name_Len) := '_';
               end if;
 
               Scan_Ptr := Scan_Ptr + 1;
               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;
               Underline_Found := False;
               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
                  Code : Char_Code;
                  Err  : Boolean;
                  Chr  : Character;
                  Cat  : Category;
 
               begin
                  Wptr := Scan_Ptr;
                  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)));
                     Underline_Found := False;
 
                  --  Here if not a normal identifier character
 
                  else
                     Cat := Get_Category (UTF_32 (Code));
 
                     --  Wide character in Unicode category "Other, Format"
                     --  is not accepted in an identifier. This is because it
                     --  it is considered a security risk (AI-0091).
 
                     --  However, it is OK for such a character to appear at
                     --  the end of an identifier.
 
                     if Is_UTF_32_Other (Cat) then
                        if not Identifier_Char (Source (Scan_Ptr)) then
                           goto Scan_Identifier_Complete;
                        else
                           Error_Msg
                             ("identifier cannot contain other_format "
                              & "character", Wptr);
                           goto Scan_Identifier;
                        end if;
 
                     --  Wide character in category Separator,Space terminates
 
                     elsif Is_UTF_32_Space (Cat) then
                        goto Scan_Identifier_Complete;
                     end if;
 
                     --  Here if wide character is part of the identifier
 
                     --  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.
 
                     --  Wide characters are always allowed in Ada 2005
 
                     if Identifier_Character_Set /= 'w'
                       and then Ada_Version < Ada_2005
                     then
                        Error_Msg
                          ("wide character not allowed in identifier", Wptr);
                     end if;
 
                     --  If OK letter, store it folding to upper case. Note
                     --  that we include the folded letter in the checksum.
 
                     if Is_UTF_32_Letter (Cat) then
                        Code :=
                          Char_Code (UTF_32_To_Upper_Case (UTF_32 (Code)));
                        Accumulate_Checksum (Code);
                        Store_Encoded_Character (Code);
                        Underline_Found := False;
 
                     --  If OK extended digit or mark, then store it
 
                     elsif Is_UTF_32_Digit (Cat)
                       or else Is_UTF_32_Mark (Cat)
                     then
                        Accumulate_Checksum (Code);
                        Store_Encoded_Character (Code);
                        Underline_Found := False;
 
                     --  Wide punctuation is also stored, but counts as an
                     --  underline character for error checking purposes.
 
                     elsif Is_UTF_32_Punctuation (Cat) then
                        Accumulate_Checksum (Code);
 
                        if Underline_Found then
                           declare
                              Cend : constant Source_Ptr := Scan_Ptr;
                           begin
                              Scan_Ptr := Wptr;
                              Error_No_Double_Underline;
                              Scan_Ptr := Cend;
                           end;
 
                        else
                           Store_Encoded_Character (Code);
                           Underline_Found := True;
                        end if;
 
                     --  Any other wide character is not acceptable
 
                     else
                        Error_Msg
                          ("invalid wide character in identifier", Wptr);
                     end if;
                  end if;
 
                  goto Scan_Identifier;
               end;
            end if;
         end if;
 
      --  Scan of identifier is complete. The identifier is stored in
      --  Name_Buffer, and Scan_Ptr points past the last character.
 
      <<Scan_Identifier_Complete>>
         Token_Name := Name_Find;
 
         --  Check for identifier ending with underline or punctuation char
 
         if Underline_Found then
            Underline_Found := False;
 
            if Source (Scan_Ptr - 1) = '_' then
               Error_Msg
                 ("identifier cannot end with underline", Scan_Ptr - 1);
            else
               Error_Msg
                 ("identifier cannot end with punctuation character", Wptr);
            end if;
         end if;
 
         --  We will assume it is an identifier, not a keyword, so that the
         --  checksum is independent of the Ada version.
 
         Token := Tok_Identifier;
 
         --  Here is where we check if it was a keyword
 
         if Is_Keyword_Name (Token_Name) then
            if Opt.Checksum_GNAT_6_3 then
               Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
 
               if Checksum_Accumulate_Token_Checksum then
                  if Checksum_GNAT_5_03 then
                     Accumulate_Token_Checksum_GNAT_5_03;
                  else
                     Accumulate_Token_Checksum_GNAT_6_3;
                  end if;
               end if;
 
            else
               Accumulate_Token_Checksum;
               Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
            end if;
 
            --  Keyword style checks
 
            if Style_Check then
 
               --  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.
 
               --  Ada 2005 (AI-284): Do not apply the style check in case of
               --  "pragma Interface"
 
               --  Ada 2005 (AI-340): Do not apply the style check in case of
               --  MOD attribute.
 
               if 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_Mod    and then
                              Token /= Tok_Range))
                       and then (Token /= Tok_Interface
                                  or else
                                    (Token = Tok_Interface
                                      and then Prev_Token /= Tok_Pragma))
               then
                  Style.Non_Lower_Case_Keyword;
               end if;
 
               --  Check THEN/ELSE style rules. These do not apply to AND THEN
               --  or OR ELSE, and do not apply in conditional expressions.
 
               if (Token = Tok_Then and then Prev_Token /= Tok_And)
                    or else
                  (Token = Tok_Else and then Prev_Token /= Tok_Or)
               then
                  if Inside_Conditional_Expression = 0 then
                     Style.Check_Separate_Stmt_Lines;
                  end if;
               end if;
            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
            if Checksum_Accumulate_Token_Checksum then
               Accumulate_Token_Checksum;
            end if;
 
            Post_Scan;
            return;
         end if;
   end Scan;
 
   --------------------------
   -- Set_Comment_As_Token --
   --------------------------
 
   procedure Set_Comment_As_Token (Value : Boolean) is
   begin
      Comment_Is_Token := Value;
   end Set_Comment_As_Token;
 
   ------------------------------
   -- Set_End_Of_Line_As_Token --
   ------------------------------
 
   procedure Set_End_Of_Line_As_Token (Value : Boolean) is
   begin
      End_Of_Line_Is_Token := Value;
   end Set_End_Of_Line_As_Token;
 
   ---------------------------
   -- Set_Special_Character --
   ---------------------------
 
   procedure Set_Special_Character (C : Character) is
   begin
      case C is
         when '#' | '$' | '_' | '?' | '@' | '`' | '\' | '^' | '~' =>
            Special_Characters (C) := True;
 
         when others =>
            null;
      end case;
   end Set_Special_Character;
 
   ----------------------
   -- 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;
 
   --  A constraint error can happen only if we have a compiler with checks on
   --  and a line with a ludicrous number of tabs or spaces at the start. In
   --  such a case, we really don't care if Start_Column is right or not.
 
   exception
      when Constraint_Error =>
         return Start_Column;
   end Set_Start_Column;
 
end Scng;
Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [scng.adb] - Blame information for rev 706

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- S C N G --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --`
17			`-- for more details. You should have received a copy of the GNU General --`
18			`-- Public License distributed with GNAT; see file COPYING3. If not, go to --`
19			`-- http://www.gnu.org/licenses for a complete copy of the license. --`
20			`-- --`
21			`-- GNAT was originally developed by the GNAT team at New York University. --`
22			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
23			`-- --`
24			`------------------------------------------------------------------------------`
25
26			`with Csets; use Csets;`
27			`with Err_Vars; use Err_Vars;`
28			`with Hostparm; use Hostparm;`
29			`with Namet; use Namet;`
30			`with Opt; use Opt;`
31			`with Restrict; use Restrict;`
32			`with Rident; use Rident;`
33			`with Scans; use Scans;`
34			`with Sinput; use Sinput;`
35			`with Snames; use Snames;`
36			`with Stringt; use Stringt;`
37			`with Stylesw; use Stylesw;`
38			`with Uintp; use Uintp;`
39			`with Urealp; use Urealp;`
40			`with Widechar; use Widechar;`