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