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