gcc/ada/scng.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                 S C N G                                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2004 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Csets;    use Csets;
  28 with Err_Vars; use Err_Vars;
  29 with Namet;    use Namet;
  30 with Opt;      use Opt;
  31 with Scans;    use Scans;
  32 with Sinput;   use Sinput;
  33 with Snames;   use Snames;
  34 with Stringt;  use Stringt;
  35 with Stylesw;  use Stylesw;
  36 with Uintp;    use Uintp;
  37 with Urealp;   use Urealp;
  38 with Widechar; use Widechar;
  39
  40 with System.CRC32;
  41 with System.WCh_Con; use System.WCh_Con;
  42
  43 package body Scng is
  44
  45    use ASCII;
  46    --  Make control characters visible
  47
  48    Special_Characters : array (Character) of Boolean := (others => False);
  49    --  For characters that are Special token, the value is True
  50
  51    Comment_Is_Token : Boolean := False;
  52    --  True if comments are tokens
  53
  54    End_Of_Line_Is_Token : Boolean := False;
  55    --  True if End_Of_Line is a token
  56
  57    -----------------------
  58    -- Local Subprograms --
  59    -----------------------
  60
  61    procedure Accumulate_Token_Checksum;
  62    pragma Inline (Accumulate_Token_Checksum);
  63
  64    procedure Accumulate_Checksum (C : Character);
  65    pragma Inline (Accumulate_Checksum);
  66    --  This routine accumulates the checksum given character C. During the
  67    --  scanning of a source file, this routine is called with every character
  68    --  in the source, excluding blanks, and all control characters (except
  69    --  that ESC is included in the checksum). Upper case letters not in string
  70    --  literals are folded by the caller. See Sinput spec for the documentation
  71    --  of the checksum algorithm. Note: checksum values are only used if we
  72    --  generate code, so it is not necessary to worry about making the right
  73    --  sequence of calls in any error situation.
  74
  75    procedure Accumulate_Checksum (C : Char_Code);
  76    pragma Inline (Accumulate_Checksum);
  77    --  This version is identical, except that the argument, C, is a character
  78    --  code value instead of a character. This is used when wide characters
  79    --  are scanned. We use the character code rather than the ASCII characters
  80    --  so that the checksum is independent of wide character encoding method.
  81
  82    procedure Initialize_Checksum;
  83    pragma Inline (Initialize_Checksum);
  84    --  Initialize checksum value
  85
  86    -------------------------
  87    -- Accumulate_Checksum --
  88    -------------------------
  89
  90    procedure Accumulate_Checksum (C : Character) is
  91    begin
  92       System.CRC32.Update (System.CRC32.CRC32 (Checksum), C);
  93    end Accumulate_Checksum;
  94
  95    procedure Accumulate_Checksum (C : Char_Code) is
  96    begin
  97       Accumulate_Checksum (Character'Val (C / 256));
  98       Accumulate_Checksum (Character'Val (C mod 256));
  99    end Accumulate_Checksum;
 100
 101    -------------------------------
 102    -- Accumulate_Token_Checksum --
 103    -------------------------------
 104
 105    procedure Accumulate_Token_Checksum is
 106    begin
 107       System.CRC32.Update
 108         (System.CRC32.CRC32 (Checksum),
 109          Character'Val (Token_Type'Pos (Token)));
 110    end Accumulate_Token_Checksum;
 111
 112    ----------------------------
 113    -- Determine_Token_Casing --
 114    ----------------------------
 115
 116    function Determine_Token_Casing return Casing_Type is
 117    begin
 118       return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1));
 119    end Determine_Token_Casing;
 120
 121    -------------------------
 122    -- Initialize_Checksum --
 123    -------------------------
 124
 125    procedure Initialize_Checksum is
 126    begin
 127       System.CRC32.Initialize (System.CRC32.CRC32 (Checksum));
 128    end Initialize_Checksum;
 129
 130    ------------------------
 131    -- Initialize_Scanner --
 132    ------------------------
 133
 134    procedure Initialize_Scanner
 135      (Unit  : Unit_Number_Type;
 136       Index : Source_File_Index)
 137    is
 138    begin
 139       --  Set up Token_Type values in Names Table entries for reserved keywords
 140       --  We use the Pos value of the Token_Type value. Note we are relying on
 141       --  the fact that Token_Type'Val (0) is not a reserved word!
 142
 143       Set_Name_Table_Byte (Name_Abort,      Token_Type'Pos (Tok_Abort));
 144       Set_Name_Table_Byte (Name_Abs,        Token_Type'Pos (Tok_Abs));
 145       Set_Name_Table_Byte (Name_Abstract,   Token_Type'Pos (Tok_Abstract));
 146       Set_Name_Table_Byte (Name_Accept,     Token_Type'Pos (Tok_Accept));
 147       Set_Name_Table_Byte (Name_Access,     Token_Type'Pos (Tok_Access));
 148       Set_Name_Table_Byte (Name_And,        Token_Type'Pos (Tok_And));
 149       Set_Name_Table_Byte (Name_Aliased,    Token_Type'Pos (Tok_Aliased));
 150       Set_Name_Table_Byte (Name_All,        Token_Type'Pos (Tok_All));
 151       Set_Name_Table_Byte (Name_Array,      Token_Type'Pos (Tok_Array));
 152       Set_Name_Table_Byte (Name_At,         Token_Type'Pos (Tok_At));
 153       Set_Name_Table_Byte (Name_Begin,      Token_Type'Pos (Tok_Begin));
 154       Set_Name_Table_Byte (Name_Body,       Token_Type'Pos (Tok_Body));
 155       Set_Name_Table_Byte (Name_Case,       Token_Type'Pos (Tok_Case));
 156       Set_Name_Table_Byte (Name_Constant,   Token_Type'Pos (Tok_Constant));
 157       Set_Name_Table_Byte (Name_Declare,    Token_Type'Pos (Tok_Declare));
 158       Set_Name_Table_Byte (Name_Delay,      Token_Type'Pos (Tok_Delay));
 159       Set_Name_Table_Byte (Name_Delta,      Token_Type'Pos (Tok_Delta));
 160       Set_Name_Table_Byte (Name_Digits,     Token_Type'Pos (Tok_Digits));
 161       Set_Name_Table_Byte (Name_Do,         Token_Type'Pos (Tok_Do));
 162       Set_Name_Table_Byte (Name_Else,       Token_Type'Pos (Tok_Else));
 163       Set_Name_Table_Byte (Name_Elsif,      Token_Type'Pos (Tok_Elsif));
 164       Set_Name_Table_Byte (Name_End,        Token_Type'Pos (Tok_End));
 165       Set_Name_Table_Byte (Name_Entry,      Token_Type'Pos (Tok_Entry));
 166       Set_Name_Table_Byte (Name_Exception,  Token_Type'Pos (Tok_Exception));
 167       Set_Name_Table_Byte (Name_Exit,       Token_Type'Pos (Tok_Exit));
 168       Set_Name_Table_Byte (Name_For,        Token_Type'Pos (Tok_For));
 169       Set_Name_Table_Byte (Name_Function,   Token_Type'Pos (Tok_Function));
 170       Set_Name_Table_Byte (Name_Generic,    Token_Type'Pos (Tok_Generic));
 171       Set_Name_Table_Byte (Name_Goto,       Token_Type'Pos (Tok_Goto));
 172       Set_Name_Table_Byte (Name_If,         Token_Type'Pos (Tok_If));
 173       Set_Name_Table_Byte (Name_In,         Token_Type'Pos (Tok_In));
 174       Set_Name_Table_Byte (Name_Is,         Token_Type'Pos (Tok_Is));
 175       Set_Name_Table_Byte (Name_Limited,    Token_Type'Pos (Tok_Limited));
 176       Set_Name_Table_Byte (Name_Loop,       Token_Type'Pos (Tok_Loop));
 177       Set_Name_Table_Byte (Name_Mod,        Token_Type'Pos (Tok_Mod));
 178       Set_Name_Table_Byte (Name_New,        Token_Type'Pos (Tok_New));
 179       Set_Name_Table_Byte (Name_Not,        Token_Type'Pos (Tok_Not));
 180       Set_Name_Table_Byte (Name_Null,       Token_Type'Pos (Tok_Null));
 181       Set_Name_Table_Byte (Name_Of,         Token_Type'Pos (Tok_Of));
 182       Set_Name_Table_Byte (Name_Or,         Token_Type'Pos (Tok_Or));
 183       Set_Name_Table_Byte (Name_Others,     Token_Type'Pos (Tok_Others));
 184       Set_Name_Table_Byte (Name_Out,        Token_Type'Pos (Tok_Out));
 185       Set_Name_Table_Byte (Name_Package,    Token_Type'Pos (Tok_Package));
 186       Set_Name_Table_Byte (Name_Pragma,     Token_Type'Pos (Tok_Pragma));
 187       Set_Name_Table_Byte (Name_Private,    Token_Type'Pos (Tok_Private));
 188       Set_Name_Table_Byte (Name_Procedure,  Token_Type'Pos (Tok_Procedure));
 189       Set_Name_Table_Byte (Name_Protected,  Token_Type'Pos (Tok_Protected));
 190       Set_Name_Table_Byte (Name_Raise,      Token_Type'Pos (Tok_Raise));
 191       Set_Name_Table_Byte (Name_Range,      Token_Type'Pos (Tok_Range));
 192       Set_Name_Table_Byte (Name_Record,     Token_Type'Pos (Tok_Record));
 193       Set_Name_Table_Byte (Name_Rem,        Token_Type'Pos (Tok_Rem));
 194       Set_Name_Table_Byte (Name_Renames,    Token_Type'Pos (Tok_Renames));
 195       Set_Name_Table_Byte (Name_Requeue,    Token_Type'Pos (Tok_Requeue));
 196       Set_Name_Table_Byte (Name_Return,     Token_Type'Pos (Tok_Return));
 197       Set_Name_Table_Byte (Name_Reverse,    Token_Type'Pos (Tok_Reverse));
 198       Set_Name_Table_Byte (Name_Select,     Token_Type'Pos (Tok_Select));
 199       Set_Name_Table_Byte (Name_Separate,   Token_Type'Pos (Tok_Separate));
 200       Set_Name_Table_Byte (Name_Subtype,    Token_Type'Pos (Tok_Subtype));
 201       Set_Name_Table_Byte (Name_Tagged,     Token_Type'Pos (Tok_Tagged));
 202       Set_Name_Table_Byte (Name_Task,       Token_Type'Pos (Tok_Task));
 203       Set_Name_Table_Byte (Name_Terminate,  Token_Type'Pos (Tok_Terminate));
 204       Set_Name_Table_Byte (Name_Then,       Token_Type'Pos (Tok_Then));
 205       Set_Name_Table_Byte (Name_Type,       Token_Type'Pos (Tok_Type));
 206       Set_Name_Table_Byte (Name_Until,      Token_Type'Pos (Tok_Until));
 207       Set_Name_Table_Byte (Name_Use,        Token_Type'Pos (Tok_Use));
 208       Set_Name_Table_Byte (Name_When,       Token_Type'Pos (Tok_When));
 209       Set_Name_Table_Byte (Name_While,      Token_Type'Pos (Tok_While));
 210       Set_Name_Table_Byte (Name_With,       Token_Type'Pos (Tok_With));
 211       Set_Name_Table_Byte (Name_Xor,        Token_Type'Pos (Tok_Xor));
 212
 213       --  Initialize scan control variables
 214
 215       Current_Source_File       := Index;
 216       Source                    := Source_Text (Current_Source_File);
 217       Current_Source_Unit       := Unit;
 218       Scan_Ptr                  := Source_First (Current_Source_File);
 219       Token                     := No_Token;
 220       Token_Ptr                 := Scan_Ptr;
 221       Current_Line_Start        := Scan_Ptr;
 222       Token_Node                := Empty;
 223       Token_Name                := No_Name;
 224       Start_Column              := Set_Start_Column;
 225       First_Non_Blank_Location  := Scan_Ptr;
 226
 227       Initialize_Checksum;
 228
 229       --  Do not call Scan, otherwise the License stuff does not work in Scn.
 230
 231    end Initialize_Scanner;
 232
 233    ------------------------------
 234    -- Reset_Special_Characters --
 235    ------------------------------
 236
 237    procedure Reset_Special_Characters is
 238    begin
 239       Special_Characters := (others => False);
 240    end Reset_Special_Characters;
 241
 242    ----------
 243    -- Scan --
 244    ----------
 245
 246    procedure Scan is
 247
 248       Start_Of_Comment : Source_Ptr;
 249
 250       procedure Check_End_Of_Line;
 251       --  Called when end of line encountered. Checks that line is not
 252       --  too long, and that other style checks for the end of line are met.
 253
 254       function Double_Char_Token (C : Character) return Boolean;
 255       --  This function is used for double character tokens like := or <>. It
 256       --  checks if the character following Source (Scan_Ptr) is C, and if so
 257       --  bumps Scan_Ptr past the pair of characters and returns True. A space
 258       --  between the two characters is also recognized with an appropriate
 259       --  error message being issued. If C is not present, False is returned.
 260       --  Note that Double_Char_Token can only be used for tokens defined in
 261       --  the Ada syntax (it's use for error cases like && is not appropriate
 262       --  since we do not want a junk message for a case like &-space-&).
 263
 264       procedure Error_Illegal_Character;
 265       --  Give illegal character error, Scan_Ptr points to character.
 266       --  On return, Scan_Ptr is bumped past the illegal character.
 267
 268       procedure Error_Illegal_Wide_Character;
 269       --  Give illegal wide character message. On return, Scan_Ptr is bumped
 270       --  past the illegal character, which may still leave us pointing to
 271       --  junk, not much we can do if the escape sequence is messed up!
 272
 273       procedure Error_Long_Line;
 274       --  Signal error of excessively long line
 275
 276       procedure Error_No_Double_Underline;
 277       --  Signal error of double underline character
 278
 279       procedure Nlit;
 280       --  This is the procedure for scanning out numeric literals. On entry,
 281       --  Scan_Ptr points to the digit that starts the numeric literal (the
 282       --  checksum for this character has not been accumulated yet). On return
 283       --  Scan_Ptr points past the last character of the numeric literal, Token
 284       --  and Token_Node are set appropriately, and the checksum is updated.
 285
 286       procedure Slit;
 287       --  This is the procedure for scanning out string literals. On entry,
 288       --  Scan_Ptr points to the opening string quote (the checksum for this
 289       --  character has not been accumulated yet). On return Scan_Ptr points
 290       --  past the closing quote of the string literal, Token and Token_Node
 291       --  are set appropriately, and the checksum is upated.
 292
 293       -----------------------
 294       -- Check_End_Of_Line --
 295       -----------------------
 296
 297       procedure Check_End_Of_Line is
 298          Len : constant Int := Int (Scan_Ptr) - Int (Current_Line_Start);
 299
 300       begin
 301          if Style_Check and Style_Check_Max_Line_Length then
 302             Style.Check_Line_Terminator (Len);
 303
 304          --  If style checking is inactive, check maximum line length against
 305          --  standard value. Note that we take this from Opt.Max_Line_Length
 306          --  rather than Hostparm.Max_Line_Length because we do not want to
 307          --  impose any limit during scanning of configuration pragma files,
 308          --  and Opt.Max_Line_Length (normally set to Hostparm.Max_Line_Length)
 309          --  is reset to Column_Number'Max during scanning of such files.
 310
 311          elsif Len > Opt.Max_Line_Length then
 312             Error_Long_Line;
 313          end if;
 314       end Check_End_Of_Line;
 315
 316       -----------------------
 317       -- Double_Char_Token --
 318       -----------------------
 319
 320       function Double_Char_Token (C : Character) return Boolean is
 321       begin
 322          if Source (Scan_Ptr + 1) = C then
 323             Accumulate_Checksum (C);
 324             Scan_Ptr := Scan_Ptr + 2;
 325             return True;
 326
 327          elsif Source (Scan_Ptr + 1) = ' '
 328            and then Source (Scan_Ptr + 2) = C
 329          then
 330             Scan_Ptr := Scan_Ptr + 1;
 331             Error_Msg_S ("no space allowed here");
 332             Scan_Ptr := Scan_Ptr + 2;
 333             return True;
 334
 335          else
 336             return False;
 337          end if;
 338       end Double_Char_Token;
 339
 340       -----------------------------
 341       -- Error_Illegal_Character --
 342       -----------------------------
 343
 344       procedure Error_Illegal_Character is
 345       begin
 346          Error_Msg_S ("illegal character");
 347          Scan_Ptr := Scan_Ptr + 1;
 348       end Error_Illegal_Character;
 349
 350       ----------------------------------
 351       -- Error_Illegal_Wide_Character --
 352       ----------------------------------
 353
 354       procedure Error_Illegal_Wide_Character is
 355       begin
 356          Error_Msg_S ("illegal wide character, check -gnatW switch");
 357          Scan_Ptr := Scan_Ptr + 1;
 358       end Error_Illegal_Wide_Character;
 359
 360       ---------------------
 361       -- Error_Long_Line --
 362       ---------------------
 363
 364       procedure Error_Long_Line is
 365       begin
 366          Error_Msg
 367            ("this line is too long",
 368             Current_Line_Start + Source_Ptr (Opt.Max_Line_Length));
 369       end Error_Long_Line;
 370
 371       -------------------------------
 372       -- Error_No_Double_Underline --
 373       -------------------------------
 374
 375       procedure Error_No_Double_Underline is
 376       begin
 377          Error_Msg_S ("two consecutive underlines not permitted");
 378       end Error_No_Double_Underline;
 379
 380       ----------
 381       -- Nlit --
 382       ----------
 383
 384       procedure Nlit is
 385
 386          C : Character;
 387          --  Current source program character
 388
 389          Base_Char : Character;
 390          --  Either # or : (character at start of based number)
 391
 392          Base : Int;
 393          --  Value of base
 394
 395          UI_Base : Uint;
 396          --  Value of base in Uint format
 397
 398          UI_Int_Value : Uint;
 399          --  Value of integer scanned by Scan_Integer in Uint format
 400
 401          UI_Num_Value : Uint;
 402          --  Value of integer in numeric value being scanned
 403
 404          Scale : Int;
 405          --  Scale value for real literal
 406
 407          UI_Scale : Uint;
 408          --  Scale in Uint format
 409
 410          Exponent_Is_Negative : Boolean;
 411          --  Set true for negative exponent
 412
 413          Extended_Digit_Value : Int;
 414          --  Extended digit value
 415
 416          Point_Scanned : Boolean;
 417          --  Flag for decimal point scanned in numeric literal
 418
 419          -----------------------
 420          -- Local Subprograms --
 421          -----------------------
 422
 423          procedure Error_Digit_Expected;
 424          --  Signal error of bad digit, Scan_Ptr points to the location at
 425          --  which the digit was expected on input, and is unchanged on return.
 426
 427          procedure Scan_Integer;
 428          --  Procedure to scan integer literal. On entry, Scan_Ptr points to
 429          --  a digit, on exit Scan_Ptr points past the last character of
 430          --  the integer.
 431          --
 432          --  For each digit encountered, UI_Int_Value is multiplied by 10,
 433          --  and the value of the digit added to the result. In addition,
 434          --  the value in Scale is decremented by one for each actual digit
 435          --  scanned.
 436
 437          --------------------------
 438          -- Error_Digit_Expected --
 439          --------------------------
 440
 441          procedure Error_Digit_Expected is
 442          begin
 443             Error_Msg_S ("digit expected");
 444          end Error_Digit_Expected;
 445
 446          -------------------
 447          --  Scan_Integer --
 448          -------------------
 449
 450          procedure Scan_Integer is
 451             C : Character;
 452             --  Next character scanned
 453
 454          begin
 455             C := Source (Scan_Ptr);
 456
 457             --  Loop through digits (allowing underlines)
 458
 459             loop
 460                Accumulate_Checksum (C);
 461                UI_Int_Value :=
 462                  UI_Int_Value * 10 + (Character'Pos (C) - Character'Pos ('0'));
 463                Scan_Ptr := Scan_Ptr + 1;
 464                Scale := Scale - 1;
 465                C := Source (Scan_Ptr);
 466
 467                if C = '_' then
 468
 469                   --  We do not accumulate the '_' in the checksum, so that
 470                   --  1_234 is equivalent to 1234, and does not trigger
 471                   --  compilation for "minimal recompilation" (gnatmake -m).
 472
 473                   loop
 474                      Scan_Ptr := Scan_Ptr + 1;
 475                      C := Source (Scan_Ptr);
 476                      exit when C /= '_';
 477                      Error_No_Double_Underline;
 478                   end loop;
 479
 480                   if C not in '0' .. '9' then
 481                      Error_Digit_Expected;
 482                      exit;
 483                   end if;
 484
 485                else
 486                   exit when C not in '0' .. '9';
 487                end if;
 488             end loop;
 489
 490          end Scan_Integer;
 491
 492          ----------------------------------
 493          -- Start of Processing for Nlit --
 494          ----------------------------------
 495
 496       begin
 497          Base := 10;
 498          UI_Base := Uint_10;
 499          UI_Int_Value := Uint_0;
 500          Scale := 0;
 501          Scan_Integer;
 502          Scale := 0;
 503          Point_Scanned := False;
 504          UI_Num_Value := UI_Int_Value;
 505
 506          --  Various possibilities now for continuing the literal are
 507          --  period, E/e (for exponent), or :/# (for based literal).
 508
 509          Scale := 0;
 510          C := Source (Scan_Ptr);
 511
 512          if C = '.' then
 513
 514             --  Scan out point, but do not scan past .. which is a range
 515             --  sequence, and must not be eaten up scanning a numeric literal.
 516
 517             while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop
 518                Accumulate_Checksum ('.');
 519
 520                if Point_Scanned then
 521                   Error_Msg_S ("duplicate point ignored");
 522                end if;
 523
 524                Point_Scanned := True;
 525                Scan_Ptr := Scan_Ptr + 1;
 526                C := Source (Scan_Ptr);
 527
 528                if C not in '0' .. '9' then
 529                   Error_Msg
 530                     ("real literal cannot end with point", Scan_Ptr - 1);
 531                else
 532                   Scan_Integer;
 533                   UI_Num_Value := UI_Int_Value;
 534                end if;
 535             end loop;
 536
 537             --  Based literal case. The base is the value we already scanned.
 538             --  In the case of colon, we insist that the following character
 539             --  is indeed an extended digit or a period. This catches a number
 540             --  of common errors, as well as catching the well known tricky
 541             --  bug otherwise arising from "x : integer range 1 .. 10:= 6;"
 542
 543          elsif C = '#'
 544            or else (C = ':' and then
 545                       (Source (Scan_Ptr + 1) = '.'
 546                          or else
 547                        Source (Scan_Ptr + 1) in '0' .. '9'
 548                          or else
 549                        Source (Scan_Ptr + 1) in 'A' .. 'Z'
 550                          or else
 551                        Source (Scan_Ptr + 1) in 'a' .. 'z'))
 552          then
 553             if C = ':' and then Warn_On_Obsolescent_Feature then
 554                Error_Msg_S
 555                  ("use of "":"" is an obsolescent feature ('R'M 'J.2(3))?");
 556                Error_Msg_S
 557                  ("\use ""'#"" instead?");
 558             end if;
 559
 560             Accumulate_Checksum (C);
 561             Base_Char := C;
 562             UI_Base := UI_Int_Value;
 563
 564             if UI_Base < 2 or else UI_Base > 16 then
 565                Error_Msg_SC ("base not 2-16");
 566                UI_Base := Uint_16;
 567             end if;
 568
 569             Base := UI_To_Int (UI_Base);
 570             Scan_Ptr := Scan_Ptr + 1;
 571
 572             --  Scan out extended integer [. integer]
 573
 574             C := Source (Scan_Ptr);
 575             UI_Int_Value := Uint_0;
 576             Scale := 0;
 577
 578             loop
 579                if C in '0' .. '9' then
 580                   Accumulate_Checksum (C);
 581                   Extended_Digit_Value :=
 582                     Int'(Character'Pos (C)) - Int'(Character'Pos ('0'));
 583
 584                elsif C in 'A' .. 'F' then
 585                   Accumulate_Checksum (Character'Val (Character'Pos (C) + 32));
 586                   Extended_Digit_Value :=
 587                     Int'(Character'Pos (C)) - Int'(Character'Pos ('A')) + 10;
 588
 589                elsif C in 'a' .. 'f' then
 590                   Accumulate_Checksum (C);
 591                   Extended_Digit_Value :=
 592                     Int'(Character'Pos (C)) - Int'(Character'Pos ('a')) + 10;
 593
 594                else
 595                   Error_Msg_S ("extended digit expected");
 596                   exit;
 597                end if;
 598
 599                if Extended_Digit_Value >= Base then
 600                   Error_Msg_S ("digit '>= base");
 601                end if;
 602
 603                UI_Int_Value := UI_Int_Value * UI_Base + Extended_Digit_Value;
 604                Scale := Scale - 1;
 605                Scan_Ptr := Scan_Ptr + 1;
 606                C := Source (Scan_Ptr);
 607
 608                if C = '_' then
 609                   loop
 610                      Accumulate_Checksum ('_');
 611                      Scan_Ptr := Scan_Ptr + 1;
 612                      C := Source (Scan_Ptr);
 613                      exit when C /= '_';
 614                      Error_No_Double_Underline;
 615                   end loop;
 616
 617                elsif C = '.' then
 618                   Accumulate_Checksum ('.');
 619
 620                   if Point_Scanned then
 621                      Error_Msg_S ("duplicate point ignored");
 622                   end if;
 623
 624                   Scan_Ptr := Scan_Ptr + 1;
 625                   C := Source (Scan_Ptr);
 626                   Point_Scanned := True;
 627                   Scale := 0;
 628
 629                elsif C = Base_Char then
 630                   Accumulate_Checksum (C);
 631                   Scan_Ptr := Scan_Ptr + 1;
 632                   exit;
 633
 634                elsif C = '#' or else C = ':' then
 635                   Error_Msg_S ("based number delimiters must match");
 636                   Scan_Ptr := Scan_Ptr + 1;
 637                   exit;
 638
 639                elsif not Identifier_Char (C) then
 640                   if Base_Char = '#' then
 641                      Error_Msg_S ("missing '#");
 642                   else
 643                      Error_Msg_S ("missing ':");
 644                   end if;
 645
 646                   exit;
 647                end if;
 648
 649             end loop;
 650
 651             UI_Num_Value := UI_Int_Value;
 652          end if;
 653
 654          --  Scan out exponent
 655
 656          if not Point_Scanned then
 657             Scale := 0;
 658             UI_Scale := Uint_0;
 659          else
 660             UI_Scale := UI_From_Int (Scale);
 661          end if;
 662
 663          if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then
 664             Accumulate_Checksum ('e');
 665             Scan_Ptr := Scan_Ptr + 1;
 666             Exponent_Is_Negative := False;
 667
 668             if Source (Scan_Ptr) = '+' then
 669                Accumulate_Checksum ('+');
 670                Scan_Ptr := Scan_Ptr + 1;
 671
 672             elsif Source (Scan_Ptr) = '-' then
 673                Accumulate_Checksum ('-');
 674
 675                if not Point_Scanned then
 676                   Error_Msg_S
 677                     ("negative exponent not allowed for integer literal");
 678                else
 679                   Exponent_Is_Negative := True;
 680                end if;
 681
 682                Scan_Ptr := Scan_Ptr + 1;
 683             end if;
 684
 685             UI_Int_Value := Uint_0;
 686
 687             if Source (Scan_Ptr) in '0' .. '9' then
 688                Scan_Integer;
 689             else
 690                Error_Digit_Expected;
 691             end if;
 692
 693             if Exponent_Is_Negative then
 694                UI_Scale := UI_Scale - UI_Int_Value;
 695             else
 696                UI_Scale := UI_Scale + UI_Int_Value;
 697             end if;
 698          end if;
 699
 700          --  Case of real literal to be returned
 701
 702          if Point_Scanned then
 703             Token := Tok_Real_Literal;
 704             Real_Literal_Value :=
 705               UR_From_Components (
 706                                   Num   => UI_Num_Value,
 707                                   Den   => -UI_Scale,
 708                                   Rbase => Base);
 709
 710             --  Case of integer literal to be returned
 711
 712          else
 713             Token := Tok_Integer_Literal;
 714
 715             if UI_Scale = 0 then
 716                Int_Literal_Value := UI_Num_Value;
 717
 718                --  Avoid doing possibly expensive calculations in cases like
 719                --  parsing 163E800_000# when semantics will not be done anyway.
 720                --  This is especially useful when parsing garbled input.
 721
 722             elsif Operating_Mode /= Check_Syntax
 723               and then (Serious_Errors_Detected = 0 or else Try_Semantics)
 724             then
 725                Int_Literal_Value := UI_Num_Value * UI_Base ** UI_Scale;
 726
 727             else
 728                Int_Literal_Value := No_Uint;
 729
 730             end if;
 731
 732          end if;
 733
 734          Accumulate_Token_Checksum;
 735
 736          return;
 737
 738       end Nlit;
 739
 740       ----------
 741       -- Slit --
 742       ----------
 743
 744       procedure Slit is
 745
 746          Delimiter : Character;
 747          --  Delimiter (first character of string)
 748
 749          C : Character;
 750          --  Current source program character
 751
 752          Code : Char_Code;
 753          --  Current character code value
 754
 755          Err : Boolean;
 756          --  Error flag for Scan_Wide call
 757
 758          procedure Error_Bad_String_Char;
 759          --  Signal bad character in string/character literal. On entry
 760          --  Scan_Ptr points to the improper character encountered during
 761          --  the scan. Scan_Ptr is not modified, so it still points to the bad
 762          --  character on return.
 763
 764          procedure Error_Unterminated_String;
 765          --  Procedure called if a line terminator character is encountered
 766          --  during scanning a string, meaning that the string is not properly
 767          --  terminated.
 768
 769          procedure Set_String;
 770          --  Procedure used to distinguish between string and operator symbol.
 771          --  On entry the string has been scanned out, and its characters start
 772          --  at Token_Ptr and end one character before Scan_Ptr. On exit Token
 773          --  is set to Tok_String_Literal or Tok_Operator_Symbol as
 774          --  appropriate, and Token_Node is appropriately initialized.
 775          --  In addition, in the operator symbol case, Token_Name is
 776          --  appropriately set.
 777
 778          ---------------------------
 779          -- Error_Bad_String_Char --
 780          ---------------------------
 781
 782          procedure Error_Bad_String_Char is
 783             C : constant Character := Source (Scan_Ptr);
 784
 785          begin
 786             if C = HT then
 787                Error_Msg_S ("horizontal tab not allowed in string");
 788
 789             elsif C = VT or else C = FF then
 790                Error_Msg_S ("format effector not allowed in string");
 791
 792             elsif C in Upper_Half_Character then
 793                Error_Msg_S ("(Ada 83) upper half character not allowed");
 794
 795             else
 796                Error_Msg_S ("control character not allowed in string");
 797             end if;
 798          end Error_Bad_String_Char;
 799
 800          -------------------------------
 801          -- Error_Unterminated_String --
 802          -------------------------------
 803
 804          procedure Error_Unterminated_String is
 805          begin
 806             --  An interesting little refinement. Consider the following
 807             --  examples:
 808
 809             --     A := "this is an unterminated string;
 810             --     A := "this is an unterminated string &
 811             --     P(A, "this is a parameter that didn't get terminated);
 812
 813             --  We fiddle a little to do slightly better placement in these
 814             --  cases also if there is white space at the end of the line we
 815             --  place the flag at the start of this white space, not at the
 816             --  end. Note that we only have to test for blanks, since tabs
 817             --  aren't allowed in strings in the first place and would have
 818             --  caused an error message.
 819
 820             --  Two more cases that we treat specially are:
 821
 822             --     A := "this string uses the wrong terminator'
 823             --     A := "this string uses the wrong terminator' &
 824
 825             --  In these cases we give a different error message as well
 826
 827             --  We actually reposition the scan pointer to the point where we
 828             --  place the flag in these cases, since it seems a better bet on
 829             --  the original intention.
 830
 831             while Source (Scan_Ptr - 1) = ' '
 832               or else Source (Scan_Ptr - 1) = '&'
 833             loop
 834                Scan_Ptr := Scan_Ptr - 1;
 835                Unstore_String_Char;
 836             end loop;
 837
 838             --  Check for case of incorrect string terminator, but single quote
 839             --  is not considered incorrect if the opening terminator misused
 840             --  a single quote (error message already given).
 841
 842             if Delimiter /= '''
 843               and then Source (Scan_Ptr - 1) = '''
 844             then
 845                Unstore_String_Char;
 846                Error_Msg
 847                  ("incorrect string terminator character", Scan_Ptr - 1);
 848                return;
 849             end if;
 850
 851             if Source (Scan_Ptr - 1) = ';' then
 852                Scan_Ptr := Scan_Ptr - 1;
 853                Unstore_String_Char;
 854
 855                if Source (Scan_Ptr - 1) = ')' then
 856                   Scan_Ptr := Scan_Ptr - 1;
 857                   Unstore_String_Char;
 858                end if;
 859             end if;
 860
 861             Error_Msg_S ("missing string quote");
 862          end Error_Unterminated_String;
 863
 864          ----------------
 865          -- Set_String --
 866          ----------------
 867
 868          procedure Set_String is
 869             Slen : constant Int := Int (Scan_Ptr - Token_Ptr - 2);
 870             C1   : Character;
 871             C2   : Character;
 872             C3   : Character;
 873
 874          begin
 875             --  Token_Name is currently set to Error_Name. The following
 876             --  section of code resets Token_Name to the proper Name_Op_xx
 877             --  value if the string is a valid operator symbol, otherwise it is
 878             --  left set to Error_Name.
 879
 880             if Slen = 1 then
 881                C1 := Source (Token_Ptr + 1);
 882
 883                case C1 is
 884                   when '=' =>
 885                      Token_Name := Name_Op_Eq;
 886
 887                   when '>' =>
 888                      Token_Name := Name_Op_Gt;
 889
 890                   when '<' =>
 891                      Token_Name := Name_Op_Lt;
 892
 893                   when '+' =>
 894                      Token_Name := Name_Op_Add;
 895
 896                   when '-' =>
 897                      Token_Name := Name_Op_Subtract;
 898
 899                   when '&' =>
 900                      Token_Name := Name_Op_Concat;
 901
 902                   when '*' =>
 903                      Token_Name := Name_Op_Multiply;
 904
 905                   when '/' =>
 906                      Token_Name := Name_Op_Divide;
 907
 908                   when others =>
 909                      null;
 910                end case;
 911
 912             elsif Slen = 2 then
 913                C1 := Source (Token_Ptr + 1);
 914                C2 := Source (Token_Ptr + 2);
 915
 916                if C1 = '*' and then C2 = '*' then
 917                   Token_Name := Name_Op_Expon;
 918
 919                elsif C2 = '=' then
 920
 921                   if C1 = '/' then
 922                      Token_Name := Name_Op_Ne;
 923                   elsif C1 = '<' then
 924                      Token_Name := Name_Op_Le;
 925                   elsif C1 = '>' then
 926                      Token_Name := Name_Op_Ge;
 927                   end if;
 928
 929                elsif (C1 = 'O' or else C1 = 'o') and then    -- OR
 930                  (C2 = 'R' or else C2 = 'r')
 931                then
 932                   Token_Name := Name_Op_Or;
 933                end if;
 934
 935             elsif Slen = 3 then
 936                C1 := Source (Token_Ptr + 1);
 937                C2 := Source (Token_Ptr + 2);
 938                C3 := Source (Token_Ptr + 3);
 939
 940                if (C1 = 'A' or else C1 = 'a') and then       -- AND
 941                  (C2 = 'N' or else C2 = 'n') and then
 942                  (C3 = 'D' or else C3 = 'd')
 943                then
 944                   Token_Name := Name_Op_And;
 945
 946                elsif (C1 = 'A' or else C1 = 'a') and then    -- ABS
 947                  (C2 = 'B' or else C2 = 'b') and then
 948                  (C3 = 'S' or else C3 = 's')
 949                then
 950                   Token_Name := Name_Op_Abs;
 951
 952                elsif (C1 = 'M' or else C1 = 'm') and then    -- MOD
 953                  (C2 = 'O' or else C2 = 'o') and then
 954                  (C3 = 'D' or else C3 = 'd')
 955                then
 956                   Token_Name := Name_Op_Mod;
 957
 958                elsif (C1 = 'N' or else C1 = 'n') and then    -- NOT
 959                  (C2 = 'O' or else C2 = 'o') and then
 960                  (C3 = 'T' or else C3 = 't')
 961                then
 962                   Token_Name := Name_Op_Not;
 963
 964                elsif (C1 = 'R' or else C1 = 'r') and then    -- REM
 965                  (C2 = 'E' or else C2 = 'e') and then
 966                  (C3 = 'M' or else C3 = 'm')
 967                then
 968                   Token_Name := Name_Op_Rem;
 969
 970                elsif (C1 = 'X' or else C1 = 'x') and then    -- XOR
 971                  (C2 = 'O' or else C2 = 'o') and then
 972                  (C3 = 'R' or else C3 = 'r')
 973                then
 974                   Token_Name := Name_Op_Xor;
 975                end if;
 976
 977             end if;
 978
 979             --  If it is an operator symbol, then Token_Name is set.
 980             --  If it is some other string value, then Token_Name still
 981             --  contains Error_Name.
 982
 983             if Token_Name = Error_Name then
 984                Token := Tok_String_Literal;
 985
 986             else
 987                Token := Tok_Operator_Symbol;
 988             end if;
 989
 990          end Set_String;
 991
 992          ----------
 993          -- Slit --
 994          ----------
 995
 996       begin
 997          --  On entry, Scan_Ptr points to the opening character of the string
 998          --  which is either a percent, double quote, or apostrophe
 999          --  (single quote). The latter case is an error detected by
1000          --  the character literal circuit.
1001
1002          Delimiter := Source (Scan_Ptr);
1003          Accumulate_Checksum (Delimiter);
1004          Start_String;
1005          Scan_Ptr := Scan_Ptr + 1;
1006
1007          --  Loop to scan out characters of string literal
1008
1009          loop
1010             C := Source (Scan_Ptr);
1011
1012             if C = Delimiter then
1013                Accumulate_Checksum (C);
1014                Scan_Ptr := Scan_Ptr + 1;
1015                exit when Source (Scan_Ptr) /= Delimiter;
1016                Code := Get_Char_Code (C);
1017                Accumulate_Checksum (C);
1018                Scan_Ptr := Scan_Ptr + 1;
1019
1020             else
1021                if C = '"' and then Delimiter = '%' then
1022                   Error_Msg_S
1023                     ("quote not allowed in percent delimited string");
1024                   Code := Get_Char_Code (C);
1025                   Scan_Ptr := Scan_Ptr + 1;
1026
1027                elsif (C = ESC
1028                         and then
1029                         Wide_Character_Encoding_Method
1030                                              in WC_ESC_Encoding_Method)
1031                  or else
1032                  (C in Upper_Half_Character
1033                     and then
1034                     Upper_Half_Encoding)
1035                  or else
1036                  (C = '['
1037                     and then
1038                     Source (Scan_Ptr + 1) = '"'
1039                     and then
1040                     Identifier_Char (Source (Scan_Ptr + 2)))
1041                then
1042                   Scan_Wide (Source, Scan_Ptr, Code, Err);
1043                   Accumulate_Checksum (Code);
1044
1045                   if Err then
1046                      Error_Illegal_Wide_Character;
1047                      Code := Get_Char_Code (' ');
1048                   end if;
1049
1050                else
1051                   Accumulate_Checksum (C);
1052
1053                   if C not in Graphic_Character then
1054                      if C in Line_Terminator then
1055                         Error_Unterminated_String;
1056                         exit;
1057
1058                      elsif C in Upper_Half_Character then
1059                         if Ada_Version = Ada_83 then
1060                            Error_Bad_String_Char;
1061                         end if;
1062
1063                      else
1064                         Error_Bad_String_Char;
1065                      end if;
1066                   end if;
1067
1068                   Code := Get_Char_Code (C);
1069                   Scan_Ptr := Scan_Ptr + 1;
1070                end if;
1071             end if;
1072
1073             Store_String_Char (Code);
1074
1075             if not In_Character_Range (Code) then
1076                Wide_Character_Found := True;
1077             end if;
1078          end loop;
1079
1080          String_Literal_Id := End_String;
1081          Set_String;
1082          return;
1083
1084       end Slit;
1085
1086    --  Start of body of Scan
1087
1088    begin
1089       Prev_Token := Token;
1090       Prev_Token_Ptr := Token_Ptr;
1091       Token_Name := Error_Name;
1092
1093       --  The following loop runs more than once only if a format effector
1094       --  (tab, vertical tab, form  feed, line feed, carriage return) is
1095       --  encountered and skipped, or some error situation, such as an
1096       --  illegal character, is encountered.
1097
1098       loop
1099          --  Skip past blanks, loop is opened up for speed
1100
1101          while Source (Scan_Ptr) = ' ' loop
1102
1103             if Source (Scan_Ptr + 1) /= ' ' then
1104                Scan_Ptr := Scan_Ptr + 1;
1105                exit;
1106             end if;
1107
1108             if Source (Scan_Ptr + 2) /= ' ' then
1109                Scan_Ptr := Scan_Ptr + 2;
1110                exit;
1111             end if;
1112
1113             if Source (Scan_Ptr + 3) /= ' ' then
1114                Scan_Ptr := Scan_Ptr + 3;
1115                exit;
1116             end if;
1117
1118             if Source (Scan_Ptr + 4) /= ' ' then
1119                Scan_Ptr := Scan_Ptr + 4;
1120                exit;
1121             end if;
1122
1123             if Source (Scan_Ptr + 5) /= ' ' then
1124                Scan_Ptr := Scan_Ptr + 5;
1125                exit;
1126             end if;
1127
1128             if Source (Scan_Ptr + 6) /= ' ' then
1129                Scan_Ptr := Scan_Ptr + 6;
1130                exit;
1131             end if;
1132
1133             if Source (Scan_Ptr + 7) /= ' ' then
1134                Scan_Ptr := Scan_Ptr + 7;
1135                exit;
1136             end if;
1137
1138             Scan_Ptr := Scan_Ptr + 8;
1139          end loop;
1140
1141          --  We are now at a non-blank character, which is the first character
1142          --  of the token we will scan, and hence the value of Token_Ptr.
1143
1144          Token_Ptr := Scan_Ptr;
1145
1146          --  Here begins the main case statement which transfers control on
1147          --  the basis of the non-blank character we have encountered.
1148
1149          case Source (Scan_Ptr) is
1150
1151          --  Line terminator characters
1152
1153          when CR | LF | FF | VT => Line_Terminator_Case : begin
1154
1155             --  Check line too long
1156
1157             Check_End_Of_Line;
1158
1159             --  Set Token_Ptr, if End_Of_Line is a token, for the case when
1160             --  it is a physical line.
1161
1162             if End_Of_Line_Is_Token then
1163                Token_Ptr := Scan_Ptr;
1164             end if;
1165
1166             declare
1167                Physical : Boolean;
1168
1169             begin
1170                Skip_Line_Terminators (Scan_Ptr, Physical);
1171
1172                --  If we are at start of physical line, update scan pointers
1173                --  to reflect the start of the new line.
1174
1175                if Physical then
1176                   Current_Line_Start       := Scan_Ptr;
1177                   Start_Column             := Set_Start_Column;
1178                   First_Non_Blank_Location := Scan_Ptr;
1179
1180                   --  If End_Of_Line is a token, we return it as it is
1181                   --  a physical line.
1182
1183                   if End_Of_Line_Is_Token then
1184                      Token := Tok_End_Of_Line;
1185                      return;
1186                   end if;
1187                end if;
1188             end;
1189          end Line_Terminator_Case;
1190
1191          --  Horizontal tab, just skip past it
1192
1193          when HT =>
1194             if Style_Check then Style.Check_HT; end if;
1195             Scan_Ptr := Scan_Ptr + 1;
1196
1197          --  End of file character, treated as an end of file only if it
1198          --  is the last character in the buffer, otherwise it is ignored.
1199
1200          when EOF =>
1201             if Scan_Ptr = Source_Last (Current_Source_File) then
1202                Check_End_Of_Line;
1203                Token := Tok_EOF;
1204                return;
1205
1206             else
1207                Scan_Ptr := Scan_Ptr + 1;
1208             end if;
1209
1210          --  Ampersand
1211
1212          when '&' =>
1213             Accumulate_Checksum ('&');
1214
1215             if Source (Scan_Ptr + 1) = '&' then
1216                Error_Msg_S ("'&'& should be `AND THEN`");
1217                Scan_Ptr := Scan_Ptr + 2;
1218                Token := Tok_And;
1219                return;
1220
1221             else
1222                Scan_Ptr := Scan_Ptr + 1;
1223                Token := Tok_Ampersand;
1224                return;
1225             end if;
1226
1227          --  Asterisk (can be multiplication operator or double asterisk
1228          --  which is the exponentiation compound delimiter).
1229
1230          when '*' =>
1231             Accumulate_Checksum ('*');
1232
1233             if Source (Scan_Ptr + 1) = '*' then
1234                Accumulate_Checksum ('*');
1235                Scan_Ptr := Scan_Ptr + 2;
1236                Token := Tok_Double_Asterisk;
1237                return;
1238
1239             else
1240                Scan_Ptr := Scan_Ptr + 1;
1241                Token := Tok_Asterisk;
1242                return;
1243             end if;
1244
1245          --  Colon, which can either be an isolated colon, or part of an
1246          --  assignment compound delimiter.
1247
1248          when ':' =>
1249             Accumulate_Checksum (':');
1250
1251             if Double_Char_Token ('=') then
1252                Token := Tok_Colon_Equal;
1253                if Style_Check then Style.Check_Colon_Equal; end if;
1254                return;
1255
1256             elsif Source (Scan_Ptr + 1) = '-'
1257               and then Source (Scan_Ptr + 2) /= '-'
1258             then
1259                Token := Tok_Colon_Equal;
1260                Error_Msg (":- should be :=", Scan_Ptr);
1261                Scan_Ptr := Scan_Ptr + 2;
1262                return;
1263
1264             else
1265                Scan_Ptr := Scan_Ptr + 1;
1266                Token := Tok_Colon;
1267                if Style_Check then Style.Check_Colon; end if;
1268                return;
1269             end if;
1270
1271          --  Left parenthesis
1272
1273          when '(' =>
1274             Accumulate_Checksum ('(');
1275             Scan_Ptr := Scan_Ptr + 1;
1276             Token := Tok_Left_Paren;
1277             if Style_Check then Style.Check_Left_Paren; end if;
1278             return;
1279
1280          --  Left bracket
1281
1282          when '[' =>
1283             if Source (Scan_Ptr + 1) = '"' then
1284                Name_Len := 0;
1285                goto Scan_Identifier;
1286
1287             else
1288                Error_Msg_S ("illegal character, replaced by ""(""");
1289                Scan_Ptr := Scan_Ptr + 1;
1290                Token := Tok_Left_Paren;
1291                return;
1292             end if;
1293
1294          --  Left brace
1295
1296          when '{' =>
1297             Error_Msg_S ("illegal character, replaced by ""(""");
1298             Scan_Ptr := Scan_Ptr + 1;
1299             Token := Tok_Left_Paren;
1300             return;
1301
1302          --  Comma
1303
1304          when ',' =>
1305             Accumulate_Checksum (',');
1306             Scan_Ptr := Scan_Ptr + 1;
1307             Token := Tok_Comma;
1308             if Style_Check then Style.Check_Comma; end if;
1309             return;
1310
1311          --  Dot, which is either an isolated period, or part of a double
1312          --  dot compound delimiter sequence. We also check for the case of
1313          --  a digit following the period, to give a better error message.
1314
1315          when '.' =>
1316             Accumulate_Checksum ('.');
1317
1318             if Double_Char_Token ('.') then
1319                Token := Tok_Dot_Dot;
1320                if Style_Check then Style.Check_Dot_Dot; end if;
1321                return;
1322
1323             elsif Source (Scan_Ptr + 1) in '0' .. '9' then
1324                Error_Msg_S ("numeric literal cannot start with point");
1325                Scan_Ptr := Scan_Ptr + 1;
1326
1327             else
1328                Scan_Ptr := Scan_Ptr + 1;
1329                Token := Tok_Dot;
1330                return;
1331             end if;
1332
1333          --  Equal, which can either be an equality operator, or part of the
1334          --  arrow (=>) compound delimiter.
1335
1336          when '=' =>
1337             Accumulate_Checksum ('=');
1338
1339             if Double_Char_Token ('>') then
1340                Token := Tok_Arrow;
1341                if Style_Check then Style.Check_Arrow; end if;
1342                return;
1343
1344             elsif Source (Scan_Ptr + 1) = '=' then
1345                Error_Msg_S ("== should be =");
1346                Scan_Ptr := Scan_Ptr + 1;
1347             end if;
1348
1349             Scan_Ptr := Scan_Ptr + 1;
1350             Token := Tok_Equal;
1351             return;
1352
1353          --  Greater than, which can be a greater than operator, greater than
1354          --  or equal operator, or first character of a right label bracket.
1355
1356          when '>' =>
1357             Accumulate_Checksum ('>');
1358
1359             if Double_Char_Token ('=') then
1360                Token := Tok_Greater_Equal;
1361                return;
1362
1363             elsif Double_Char_Token ('>') then
1364                Token := Tok_Greater_Greater;
1365                return;
1366
1367             else
1368                Scan_Ptr := Scan_Ptr + 1;
1369                Token := Tok_Greater;
1370                return;
1371             end if;
1372
1373          --  Less than, which can be a less than operator, less than or equal
1374          --  operator, or the first character of a left label bracket, or the
1375          --  first character of a box (<>) compound delimiter.
1376
1377          when '<' =>
1378             Accumulate_Checksum ('<');
1379
1380             if Double_Char_Token ('=') then
1381                Token := Tok_Less_Equal;
1382                return;
1383
1384             elsif Double_Char_Token ('>') then
1385                Token := Tok_Box;
1386                if Style_Check then Style.Check_Box; end if;
1387                return;
1388
1389             elsif Double_Char_Token ('<') then
1390                Token := Tok_Less_Less;
1391                return;
1392
1393             else
1394                Scan_Ptr := Scan_Ptr + 1;
1395                Token := Tok_Less;
1396                return;
1397             end if;
1398
1399          --  Minus, which is either a subtraction operator, or the first
1400          --  character of double minus starting a comment
1401
1402          when '-' => Minus_Case : begin
1403             if Source (Scan_Ptr + 1) = '>' then
1404                Error_Msg_S ("invalid token");
1405                Scan_Ptr := Scan_Ptr + 2;
1406                Token := Tok_Arrow;
1407                return;
1408
1409             elsif Source (Scan_Ptr + 1) /= '-' then
1410                Accumulate_Checksum ('-');
1411                Scan_Ptr := Scan_Ptr + 1;
1412                Token := Tok_Minus;
1413                return;
1414
1415             --  Comment
1416
1417             else -- Source (Scan_Ptr + 1) = '-' then
1418                if Style_Check then Style.Check_Comment; end if;
1419                Scan_Ptr := Scan_Ptr + 2;
1420                Start_Of_Comment := Scan_Ptr;
1421
1422                --  Loop to scan comment (this loop runs more than once only if
1423                --  a horizontal tab or other non-graphic character is scanned)
1424
1425                loop
1426                   --  Scan to non graphic character (opened up for speed)
1427
1428                   loop
1429                      exit when Source (Scan_Ptr) not in Graphic_Character;
1430                      Scan_Ptr := Scan_Ptr + 1;
1431                      exit when Source (Scan_Ptr) not in Graphic_Character;
1432                      Scan_Ptr := Scan_Ptr + 1;
1433                      exit when Source (Scan_Ptr) not in Graphic_Character;
1434                      Scan_Ptr := Scan_Ptr + 1;
1435                      exit when Source (Scan_Ptr) not in Graphic_Character;
1436                      Scan_Ptr := Scan_Ptr + 1;
1437                      exit when Source (Scan_Ptr) not in Graphic_Character;
1438                      Scan_Ptr := Scan_Ptr + 1;
1439                   end loop;
1440
1441                   --  Keep going if horizontal tab
1442
1443                   if Source (Scan_Ptr) = HT then
1444                      if Style_Check then Style.Check_HT; end if;
1445                      Scan_Ptr := Scan_Ptr + 1;
1446
1447                   --  Terminate scan of comment if line terminator
1448
1449                   elsif Source (Scan_Ptr) in Line_Terminator then
1450                      exit;
1451
1452                   --  Terminate scan of comment if end of file encountered
1453                   --  (embedded EOF character or real last character in file)
1454
1455                   elsif Source (Scan_Ptr) = EOF then
1456                      exit;
1457
1458                   --  Keep going if character in 80-FF range, or is ESC. These
1459                   --  characters are allowed in comments by RM-2.1(1), 2.7(2).
1460                   --  They are allowed even in Ada 83 mode according to the
1461                   --  approved AI. ESC was added to the AI in June 93.
1462
1463                   elsif Source (Scan_Ptr) in Upper_Half_Character
1464                     or else Source (Scan_Ptr) = ESC
1465                   then
1466                      Scan_Ptr := Scan_Ptr + 1;
1467
1468                   --  Otherwise we have an illegal comment character
1469
1470                   else
1471                      Error_Illegal_Character;
1472                   end if;
1473
1474                end loop;
1475
1476                --  Note that, except when comments are tokens, we do NOT
1477                --  execute a return here, instead we fall through to reexecute
1478                --  the scan loop to look for a token.
1479
1480                if Comment_Is_Token then
1481                   Name_Len := Integer (Scan_Ptr - Start_Of_Comment);
1482                   Name_Buffer (1 .. Name_Len) :=
1483                     String (Source (Start_Of_Comment .. Scan_Ptr - 1));
1484                   Comment_Id := Name_Find;
1485                   Token := Tok_Comment;
1486                   return;
1487                end if;
1488             end if;
1489          end Minus_Case;
1490
1491          --  Double quote starting a string literal
1492
1493          when '"' =>
1494             Slit;
1495             Post_Scan;
1496             return;
1497
1498          --  Percent starting a string literal
1499
1500          when '%' =>
1501             if Warn_On_Obsolescent_Feature then
1502                Error_Msg_S
1503                  ("use of ""'%"" is an obsolescent feature ('R'M 'J.2(4))?");
1504                Error_Msg_S
1505                  ("\use """""" instead?");
1506             end if;
1507
1508             Slit;
1509             Post_Scan;
1510             return;
1511
1512          --  Apostrophe. This can either be the start of a character literal,
1513          --  or an isolated apostrophe used in a qualified expression or an
1514          --  attribute. We treat it as a character literal if it does not
1515          --  follow a right parenthesis, identifier, the keyword ALL or
1516          --  a literal. This means that we correctly treat constructs like:
1517
1518          --    A := CHARACTER'('A');
1519
1520          --  Note that RM-2.2(7) does not require a separator between
1521          --  "CHARACTER" and "'" in the above.
1522
1523          when ''' => Char_Literal_Case : declare
1524             Code : Char_Code;
1525             Err  : Boolean;
1526
1527          begin
1528             Accumulate_Checksum (''');
1529             Scan_Ptr := Scan_Ptr + 1;
1530
1531             --  Here is where we make the test to distinguish the cases. Treat
1532             --  as apostrophe if previous token is an identifier, right paren
1533             --  or the reserved word "all" (latter case as in A.all'Address)
1534             --  (or the reserved word "project" in project files).
1535             --  Also treat it as apostrophe after a literal (this catches
1536             --  some legitimate cases, like A."abs"'Address, and also gives
1537             --  better error behavior for impossible cases like 123'xxx).
1538
1539             if Prev_Token = Tok_Identifier
1540                or else Prev_Token = Tok_Right_Paren
1541                or else Prev_Token = Tok_All
1542                or else Prev_Token = Tok_Project
1543                or else Prev_Token in Token_Class_Literal
1544             then
1545                Token := Tok_Apostrophe;
1546                if Style_Check then Style.Check_Apostrophe; end if;
1547                return;
1548
1549             --  Otherwise the apostrophe starts a character literal
1550
1551             else
1552                --  Case of wide character literal with ESC or [ encoding
1553
1554                if (Source (Scan_Ptr) = ESC
1555                      and then
1556                     Wide_Character_Encoding_Method in WC_ESC_Encoding_Method)
1557                  or else
1558                    (Source (Scan_Ptr) in Upper_Half_Character
1559                      and then
1560                     Upper_Half_Encoding)
1561                  or else
1562                    (Source (Scan_Ptr) = '['
1563                      and then
1564                     Source (Scan_Ptr + 1) = '"')
1565                then
1566                   Scan_Wide (Source, Scan_Ptr, Code, Err);
1567                   Accumulate_Checksum (Code);
1568
1569                   if Err then
1570                      Error_Illegal_Wide_Character;
1571                   end if;
1572
1573                   if Source (Scan_Ptr) /= ''' then
1574                      Error_Msg_S ("missing apostrophe");
1575                   else
1576                      Scan_Ptr := Scan_Ptr + 1;
1577                   end if;
1578
1579                --  If we do not find a closing quote in the expected place then
1580                --  assume that we have a misguided attempt at a string literal.
1581
1582                --  However, if previous token is RANGE, then we return an
1583                --  apostrophe instead since this gives better error recovery
1584
1585                elsif Source (Scan_Ptr + 1) /= ''' then
1586
1587                   if Prev_Token = Tok_Range then
1588                      Token := Tok_Apostrophe;
1589                      return;
1590
1591                   else
1592                      Scan_Ptr := Scan_Ptr - 1;
1593                      Error_Msg_S
1594                        ("strings are delimited by double quote character");
1595                      Slit;
1596                      Post_Scan;
1597                      return;
1598                   end if;
1599
1600                --  Otherwise we have a (non-wide) character literal
1601
1602                else
1603                   Accumulate_Checksum (Source (Scan_Ptr));
1604
1605                   if Source (Scan_Ptr) not in Graphic_Character then
1606                      if Source (Scan_Ptr) in Upper_Half_Character then
1607                         if Ada_Version = Ada_83 then
1608                            Error_Illegal_Character;
1609                         end if;
1610
1611                      else
1612                         Error_Illegal_Character;
1613                      end if;
1614                   end if;
1615
1616                   Code := Get_Char_Code (Source (Scan_Ptr));
1617                   Scan_Ptr := Scan_Ptr + 2;
1618                end if;
1619
1620                --  Fall through here with Scan_Ptr updated past the closing
1621                --  quote, and Code set to the Char_Code value for the literal
1622
1623                Accumulate_Checksum (''');
1624                Token := Tok_Char_Literal;
1625                Set_Character_Literal_Name (Code);
1626                Token_Name := Name_Find;
1627                Character_Code := Code;
1628                Post_Scan;
1629                return;
1630             end if;
1631          end Char_Literal_Case;
1632
1633          --  Right parenthesis
1634
1635          when ')' =>
1636             Accumulate_Checksum (')');
1637             Scan_Ptr := Scan_Ptr + 1;
1638             Token := Tok_Right_Paren;
1639             if Style_Check then Style.Check_Right_Paren; end if;
1640             return;
1641
1642          --  Right bracket or right brace, treated as right paren
1643
1644          when ']' | '}' =>
1645             Error_Msg_S ("illegal character, replaced by "")""");
1646             Scan_Ptr := Scan_Ptr + 1;
1647             Token := Tok_Right_Paren;
1648             return;
1649
1650          --  Slash (can be division operator or first character of not equal)
1651
1652          when '/' =>
1653             Accumulate_Checksum ('/');
1654
1655             if Double_Char_Token ('=') then
1656                Token := Tok_Not_Equal;
1657                return;
1658             else
1659                Scan_Ptr := Scan_Ptr + 1;
1660                Token := Tok_Slash;
1661                return;
1662             end if;
1663
1664          --  Semicolon
1665
1666          when ';' =>
1667             Accumulate_Checksum (';');
1668             Scan_Ptr := Scan_Ptr + 1;
1669             Token := Tok_Semicolon;
1670             if Style_Check then Style.Check_Semicolon; end if;
1671             return;
1672
1673          --  Vertical bar
1674
1675          when '|' => Vertical_Bar_Case : begin
1676             Accumulate_Checksum ('|');
1677
1678             --  Special check for || to give nice message
1679
1680             if Source (Scan_Ptr + 1) = '|' then
1681                Error_Msg_S ("""'|'|"" should be `OR ELSE`");
1682                Scan_Ptr := Scan_Ptr + 2;
1683                Token := Tok_Or;
1684                return;
1685
1686             else
1687                Scan_Ptr := Scan_Ptr + 1;
1688                Token := Tok_Vertical_Bar;
1689                if Style_Check then Style.Check_Vertical_Bar; end if;
1690                return;
1691             end if;
1692          end Vertical_Bar_Case;
1693
1694          --  Exclamation, replacement character for vertical bar
1695
1696          when '!' => Exclamation_Case : begin
1697             Accumulate_Checksum ('!');
1698
1699             if Warn_On_Obsolescent_Feature then
1700                Error_Msg_S
1701                  ("use of ""'!"" is an obsolescent feature ('R'M 'J.2(2))?");
1702                Error_Msg_S
1703                  ("\use ""'|"" instead?");
1704             end if;
1705
1706             if Source (Scan_Ptr + 1) = '=' then
1707                Error_Msg_S ("'!= should be /=");
1708                Scan_Ptr := Scan_Ptr + 2;
1709                Token := Tok_Not_Equal;
1710                return;
1711
1712             else
1713                Scan_Ptr := Scan_Ptr + 1;
1714                Token := Tok_Vertical_Bar;
1715                return;
1716             end if;
1717
1718          end Exclamation_Case;
1719
1720          --  Plus
1721
1722          when '+' => Plus_Case : begin
1723             Accumulate_Checksum ('+');
1724             Scan_Ptr := Scan_Ptr + 1;
1725             Token := Tok_Plus;
1726             return;
1727          end Plus_Case;
1728
1729          --  Digits starting a numeric literal
1730
1731          when '0' .. '9' =>
1732             Nlit;
1733
1734             if Identifier_Char (Source (Scan_Ptr)) then
1735                Error_Msg_S
1736                  ("delimiter required between literal and identifier");
1737             end if;
1738             Post_Scan;
1739             return;
1740
1741          --  Lower case letters
1742
1743          when 'a' .. 'z' =>
1744             Name_Len := 1;
1745             Name_Buffer (1) := Source (Scan_Ptr);
1746             Accumulate_Checksum (Name_Buffer (1));
1747             Scan_Ptr := Scan_Ptr + 1;
1748             goto Scan_Identifier;
1749
1750          --  Upper case letters
1751
1752          when 'A' .. 'Z' =>
1753             Name_Len := 1;
1754             Name_Buffer (1) :=
1755               Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
1756             Accumulate_Checksum (Name_Buffer (1));
1757             Scan_Ptr := Scan_Ptr + 1;
1758             goto Scan_Identifier;
1759
1760          --  Underline character
1761
1762          when '_' =>
1763             if Special_Characters ('_') then
1764                Token_Ptr := Scan_Ptr;
1765                Scan_Ptr := Scan_Ptr + 1;
1766                Token := Tok_Special;
1767                Special_Character := '_';
1768                return;
1769             end if;
1770
1771             Error_Msg_S ("identifier cannot start with underline");
1772             Name_Len := 1;
1773             Name_Buffer (1) := '_';
1774             Scan_Ptr := Scan_Ptr + 1;
1775             goto Scan_Identifier;
1776
1777          --  Space (not possible, because we scanned past blanks)
1778
1779          when ' ' =>
1780             raise Program_Error;
1781
1782          --  Characters in top half of ASCII 8-bit chart
1783
1784          when Upper_Half_Character =>
1785
1786             --  Wide character case. Note that Scan_Identifier will issue
1787             --  an appropriate message if wide characters are not allowed
1788             --  in identifiers.
1789
1790             if Upper_Half_Encoding then
1791                Name_Len := 0;
1792                goto Scan_Identifier;
1793
1794             --  Otherwise we have OK Latin-1 character
1795
1796             else
1797                --  Upper half characters may possibly be identifier letters
1798                --  but can never be digits, so Identifier_Char can be used
1799                --  to test for a valid start of identifier character.
1800
1801                if Identifier_Char (Source (Scan_Ptr)) then
1802                   Name_Len := 0;
1803                   goto Scan_Identifier;
1804                else
1805                   Error_Illegal_Character;
1806                end if;
1807             end if;
1808
1809          when ESC =>
1810
1811             --  ESC character, possible start of identifier if wide characters
1812             --  using ESC encoding are allowed in identifiers, which we can
1813             --  tell by looking at the Identifier_Char flag for ESC, which is
1814             --  only true if these conditions are met.
1815
1816             if Identifier_Char (ESC) then
1817                Name_Len := 0;
1818                goto Scan_Identifier;
1819             else
1820                Error_Illegal_Wide_Character;
1821             end if;
1822
1823          --  Invalid control characters
1824
1825          when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS  | SO  |
1826               SI  | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
1827               EM  | FS  | GS  | RS  | US  | DEL
1828          =>
1829             Error_Illegal_Character;
1830
1831          --  Invalid graphic characters
1832
1833          when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' =>
1834             --  If Set_Special_Character has been called for this character,
1835             --  set Scans.Special_Character and return a Special token.
1836
1837             if Special_Characters (Source (Scan_Ptr)) then
1838                Token_Ptr := Scan_Ptr;
1839                Token := Tok_Special;
1840                Special_Character := Source (Scan_Ptr);
1841                Scan_Ptr := Scan_Ptr + 1;
1842                return;
1843
1844             --  otherwise, this is an illegal character
1845
1846             else
1847                Error_Illegal_Character;
1848             end if;
1849
1850          --  End switch on non-blank character
1851
1852          end case;
1853
1854       --  End loop past format effectors. The exit from this loop is by
1855       --  executing a return statement following completion of token scan
1856       --  (control never falls out of this loop to the code which follows)
1857
1858       end loop;
1859
1860       --  Identifier scanning routine. On entry, some initial characters
1861       --  of the identifier may have already been stored in Name_Buffer.
1862       --  If so, Name_Len has the number of characters stored. otherwise
1863       --  Name_Len is set to zero on entry.
1864
1865       <<Scan_Identifier>>
1866
1867          --  This loop scans as fast as possible past lower half letters
1868          --  and digits, which we expect to be the most common characters.
1869
1870          loop
1871             if Source (Scan_Ptr) in 'a' .. 'z'
1872               or else Source (Scan_Ptr) in '0' .. '9'
1873             then
1874                Name_Buffer (Name_Len + 1) := Source (Scan_Ptr);
1875                Accumulate_Checksum (Source (Scan_Ptr));
1876
1877             elsif Source (Scan_Ptr) in 'A' .. 'Z' then
1878                Name_Buffer (Name_Len + 1) :=
1879                  Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
1880                Accumulate_Checksum (Name_Buffer (Name_Len + 1));
1881             else
1882                exit;
1883             end if;
1884
1885             --  Open out the loop a couple of times for speed
1886
1887             if Source (Scan_Ptr + 1) in 'a' .. 'z'
1888               or else Source (Scan_Ptr + 1) in '0' .. '9'
1889             then
1890                Name_Buffer (Name_Len + 2) := Source (Scan_Ptr + 1);
1891                Accumulate_Checksum (Source (Scan_Ptr + 1));
1892
1893             elsif Source (Scan_Ptr + 1) in 'A' .. 'Z' then
1894                Name_Buffer (Name_Len + 2) :=
1895                  Character'Val (Character'Pos (Source (Scan_Ptr + 1)) + 32);
1896                Accumulate_Checksum (Name_Buffer (Name_Len + 2));
1897
1898             else
1899                Scan_Ptr := Scan_Ptr + 1;
1900                Name_Len := Name_Len + 1;
1901                exit;
1902             end if;
1903
1904             if Source (Scan_Ptr + 2) in 'a' .. 'z'
1905               or else Source (Scan_Ptr + 2) in '0' .. '9'
1906             then
1907                Name_Buffer (Name_Len + 3) := Source (Scan_Ptr + 2);
1908                Accumulate_Checksum (Source (Scan_Ptr + 2));
1909
1910             elsif Source (Scan_Ptr + 2) in 'A' .. 'Z' then
1911                Name_Buffer (Name_Len + 3) :=
1912                  Character'Val (Character'Pos (Source (Scan_Ptr + 2)) + 32);
1913                Accumulate_Checksum (Name_Buffer (Name_Len + 3));
1914             else
1915                Scan_Ptr := Scan_Ptr + 2;
1916                Name_Len := Name_Len + 2;
1917                exit;
1918             end if;
1919
1920             if Source (Scan_Ptr + 3) in 'a' .. 'z'
1921               or else Source (Scan_Ptr + 3) in '0' .. '9'
1922             then
1923                Name_Buffer (Name_Len + 4) := Source (Scan_Ptr + 3);
1924                Accumulate_Checksum (Source (Scan_Ptr + 3));
1925
1926             elsif Source (Scan_Ptr + 3) in 'A' .. 'Z' then
1927                Name_Buffer (Name_Len + 4) :=
1928                  Character'Val (Character'Pos (Source (Scan_Ptr + 3)) + 32);
1929                Accumulate_Checksum (Name_Buffer (Name_Len + 4));
1930
1931             else
1932                Scan_Ptr := Scan_Ptr + 3;
1933                Name_Len := Name_Len + 3;
1934                exit;
1935             end if;
1936
1937             Scan_Ptr := Scan_Ptr + 4;
1938             Name_Len := Name_Len + 4;
1939          end loop;
1940
1941          --  If we fall through, then we have encountered either an underline
1942          --  character, or an extended identifier character (i.e. one from the
1943          --  upper half), or a wide character, or an identifier terminator.
1944          --  The initial test speeds us up in the most common case where we
1945          --  have an identifier terminator. Note that ESC is an identifier
1946          --  character only if a wide character encoding method that uses
1947          --  ESC encoding is active, so if we find an ESC character we know
1948          --  that we have a wide character.
1949
1950          if Identifier_Char (Source (Scan_Ptr)) then
1951
1952             --  Case of underline
1953
1954             if Source (Scan_Ptr) = '_' then
1955                Accumulate_Checksum ('_');
1956
1957                --  Check error case of identifier ending with underscore
1958                --  In this case we ignore the underscore and do not store it.
1959
1960                if not Identifier_Char (Source (Scan_Ptr + 1)) then
1961                   Error_Msg_S ("identifier cannot end with underline");
1962                   Scan_Ptr := Scan_Ptr + 1;
1963
1964                --  Check error case of two underscores. In this case we do
1965                --  not store the first underscore (we will store the second)
1966
1967                elsif Source (Scan_Ptr + 1) = '_' then
1968                      Error_No_Double_Underline;
1969
1970                --  Normal case of legal underscore
1971
1972                else
1973                   Name_Len := Name_Len + 1;
1974                   Name_Buffer (Name_Len) := '_';
1975                end if;
1976
1977                Scan_Ptr := Scan_Ptr + 1;
1978                goto Scan_Identifier;
1979
1980             --  Upper half character
1981
1982             elsif Source (Scan_Ptr) in Upper_Half_Character
1983               and then not Upper_Half_Encoding
1984             then
1985                Accumulate_Checksum (Source (Scan_Ptr));
1986                Store_Encoded_Character
1987                  (Get_Char_Code (Fold_Lower (Source (Scan_Ptr))));
1988                Scan_Ptr := Scan_Ptr + 1;
1989                goto Scan_Identifier;
1990
1991             --  Left bracket not followed by a quote terminates an identifier.
1992             --  This is an error, but we don't want to give a junk error msg
1993             --  about wide characters in this case!
1994
1995             elsif Source (Scan_Ptr) = '['
1996               and then Source (Scan_Ptr + 1) /= '"'
1997             then
1998                null;
1999
2000             --  We know we have a wide character encoding here (the current
2001             --  character is either ESC, left bracket, or an upper half
2002             --  character depending on the encoding method).
2003
2004             else
2005                --  Scan out the wide character and insert the appropriate
2006                --  encoding into the name table entry for the identifier.
2007
2008                declare
2009                   Sptr : constant Source_Ptr := Scan_Ptr;
2010                   Code : Char_Code;
2011                   Err  : Boolean;
2012                   Chr  : Character;
2013
2014                begin
2015                   Scan_Wide (Source, Scan_Ptr, Code, Err);
2016
2017                   --  If error, signal error
2018
2019                   if Err then
2020                      Error_Illegal_Wide_Character;
2021
2022                   --  If the character scanned is a normal identifier
2023                   --  character, then we treat it that way.
2024
2025                   elsif In_Character_Range (Code)
2026                     and then Identifier_Char (Get_Character (Code))
2027                   then
2028                      Chr := Get_Character (Code);
2029                      Accumulate_Checksum (Chr);
2030                      Store_Encoded_Character
2031                        (Get_Char_Code (Fold_Lower (Chr)));
2032
2033                   --  Character is not normal identifier character, store
2034                   --  it in encoded form.
2035
2036                   else
2037                      Accumulate_Checksum (Code);
2038                      Store_Encoded_Character (Code);
2039
2040                      --  Make sure we are allowing wide characters in
2041                      --  identifiers. Note that we allow wide character
2042                      --  notation for an OK identifier character. This
2043                      --  in particular allows bracket or other notation
2044                      --  to be used for upper half letters.
2045
2046                      if Identifier_Character_Set /= 'w' then
2047                         Error_Msg
2048                           ("wide character not allowed in identifier", Sptr);
2049                      end if;
2050                   end if;
2051                end;
2052
2053                goto Scan_Identifier;
2054             end if;
2055          end if;
2056
2057          --  Scan of identifier is complete. The identifier is stored in
2058          --  Name_Buffer, and Scan_Ptr points past the last character.
2059
2060          Token_Name := Name_Find;
2061
2062          --  Here is where we check if it was a keyword
2063
2064          if Get_Name_Table_Byte (Token_Name) /= 0
2065            and then (Ada_Version >= Ada_95
2066                        or else Token_Name not in Ada_95_Reserved_Words)
2067          then
2068             Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
2069
2070             --  Deal with possible style check for non-lower case keyword,
2071             --  but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords
2072             --  for this purpose if they appear as attribute designators.
2073             --  Actually we only check the first character for speed.
2074
2075             if Style_Check
2076               and then Source (Token_Ptr) <= 'Z'
2077               and then (Prev_Token /= Tok_Apostrophe
2078                           or else
2079                             (Token /= Tok_Access
2080                                and then Token /= Tok_Delta
2081                                and then Token /= Tok_Digits
2082                                and then Token /= Tok_Range))
2083             then
2084                Style.Non_Lower_Case_Keyword;
2085             end if;
2086
2087             --  We must reset Token_Name since this is not an identifier
2088             --  and if we leave Token_Name set, the parser gets confused
2089             --  because it thinks it is dealing with an identifier instead
2090             --  of the corresponding keyword.
2091
2092             Token_Name := No_Name;
2093             Accumulate_Token_Checksum;
2094             return;
2095
2096          --  It is an identifier after all
2097
2098          else
2099             Token := Tok_Identifier;
2100             Accumulate_Token_Checksum;
2101             Post_Scan;
2102             return;
2103          end if;
2104    end Scan;
2105
2106    --------------------------
2107    -- Set_Comment_As_Token --
2108    --------------------------
2109
2110    procedure Set_Comment_As_Token (Value : Boolean) is
2111    begin
2112       Comment_Is_Token := Value;
2113    end Set_Comment_As_Token;
2114
2115    ------------------------------
2116    -- Set_End_Of_Line_As_Token --
2117    ------------------------------
2118
2119    procedure Set_End_Of_Line_As_Token (Value : Boolean) is
2120    begin
2121       End_Of_Line_Is_Token := Value;
2122    end Set_End_Of_Line_As_Token;
2123
2124    ---------------------------
2125    -- Set_Special_Character --
2126    ---------------------------
2127
2128    procedure Set_Special_Character (C : Character) is
2129    begin
2130       case C is
2131          when '#' | '$' | '_' | '?' | '@' | '`' | '\' | '^' | '~' =>
2132             Special_Characters (C) := True;
2133
2134          when others =>
2135             null;
2136       end case;
2137    end Set_Special_Character;
2138
2139    ----------------------
2140    -- Set_Start_Column --
2141    ----------------------
2142
2143    --  Note: it seems at first glance a little expensive to compute this value
2144    --  for every source line (since it is certainly not used for all source
2145    --  lines). On the other hand, it doesn't take much more work to skip past
2146    --  the initial white space on the line counting the columns than it would
2147    --  to scan past the white space using the standard scanning circuits.
2148
2149    function Set_Start_Column return Column_Number is
2150       Start_Column : Column_Number := 0;
2151
2152    begin
2153       --  Outer loop scans past horizontal tab characters
2154
2155       Tabs_Loop : loop
2156
2157          --  Inner loop scans past blanks as fast as possible, bumping Scan_Ptr
2158          --  past the blanks and adjusting Start_Column to account for them.
2159
2160          Blanks_Loop : loop
2161             if Source (Scan_Ptr) = ' ' then
2162                if Source (Scan_Ptr + 1) = ' ' then
2163                   if Source (Scan_Ptr + 2) = ' ' then
2164                      if Source (Scan_Ptr + 3) = ' ' then
2165                         if Source (Scan_Ptr + 4) = ' ' then
2166                            if Source (Scan_Ptr + 5) = ' ' then
2167                               if Source (Scan_Ptr + 6) = ' ' then
2168                                  Scan_Ptr := Scan_Ptr + 7;
2169                                  Start_Column := Start_Column + 7;
2170                               else
2171                                  Scan_Ptr := Scan_Ptr + 6;
2172                                  Start_Column := Start_Column + 6;
2173                                  exit Blanks_Loop;
2174                               end if;
2175                            else
2176                               Scan_Ptr := Scan_Ptr + 5;
2177                               Start_Column := Start_Column + 5;
2178                               exit Blanks_Loop;
2179                            end if;
2180                         else
2181                            Scan_Ptr := Scan_Ptr + 4;
2182                            Start_Column := Start_Column + 4;
2183                            exit Blanks_Loop;
2184                         end if;
2185                      else
2186                         Scan_Ptr := Scan_Ptr + 3;
2187                         Start_Column := Start_Column + 3;
2188                         exit Blanks_Loop;
2189                      end if;
2190                   else
2191                      Scan_Ptr := Scan_Ptr + 2;
2192                      Start_Column := Start_Column + 2;
2193                      exit Blanks_Loop;
2194                   end if;
2195                else
2196                   Scan_Ptr := Scan_Ptr + 1;
2197                   Start_Column := Start_Column + 1;
2198                   exit Blanks_Loop;
2199                end if;
2200             else
2201                exit Blanks_Loop;
2202             end if;
2203          end loop Blanks_Loop;
2204
2205          --  Outer loop keeps going only if a horizontal tab follows
2206
2207          if Source (Scan_Ptr) = HT then
2208             if Style_Check then Style.Check_HT; end if;
2209             Scan_Ptr := Scan_Ptr + 1;
2210             Start_Column := (Start_Column / 8) * 8 + 8;
2211          else
2212             exit Tabs_Loop;
2213          end if;
2214
2215       end loop Tabs_Loop;
2216
2217       return Start_Column;
2218    end Set_Start_Column;
2219
2220 end Scng;