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