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