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