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