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