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