gcc/ada/scn.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                  S C N                                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --          Copyright (C) 1992-2002 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Atree;    use Atree;
  29 with Csets;    use Csets;
  30 with Errout;   use Errout;
  31 with Hostparm; use Hostparm;
  32 with Namet;    use Namet;
  33 with Opt;      use Opt;
  34 with Scans;    use Scans;
  35 with Sinput;   use Sinput;
  36 with Sinfo;    use Sinfo;
  37 with Snames;   use Snames;
  38 with Style;
  39 with Widechar; use Widechar;
  40
  41 with System.CRC32;
  42 with System.WCh_Con; use System.WCh_Con;
  43
  44 package body Scn is
  45
  46    use ASCII;
  47    --  Make control characters visible
  48
  49    Used_As_Identifier : array (Token_Type) of Boolean;
  50    --  Flags set True if a given keyword is used as an identifier (used to
  51    --  make sure that we only post an error message for incorrect use of a
  52    --  keyword as an identifier once for a given keyword).
  53
  54    -----------------------
  55    -- Local Subprograms --
  56    -----------------------
  57
  58    procedure Accumulate_Checksum (C : Character);
  59    pragma Inline (Accumulate_Checksum);
  60    --  This routine accumulates the checksum given character C. During the
  61    --  scanning of a source file, this routine is called with every character
  62    --  in the source, excluding blanks, and all control characters (except
  63    --  that ESC is included in the checksum). Upper case letters not in string
  64    --  literals are folded by the caller. See Sinput spec for the documentation
  65    --  of the checksum algorithm. Note: checksum values are only used if we
  66    --  generate code, so it is not necessary to worry about making the right
  67    --  sequence of calls in any error situation.
  68
  69    procedure Accumulate_Checksum (C : Char_Code);
  70    pragma Inline (Accumulate_Checksum);
  71    --  This version is identical, except that the argument, C, is a character
  72    --  code value instead of a character. This is used when wide characters
  73    --  are scanned. We use the character code rather than the ASCII characters
  74    --  so that the checksum is independent of wide character encoding method.
  75
  76    procedure Initialize_Checksum;
  77    pragma Inline (Initialize_Checksum);
  78    --  Initialize checksum value
  79
  80    procedure Check_End_Of_Line;
  81    --  Called when end of line encountered. Checks that line is not
  82    --  too long, and that other style checks for the end of line are met.
  83
  84    function Determine_License return License_Type;
  85    --  Scan header of file and check that it has an appropriate GNAT-style
  86    --  header with a proper license statement. Returns GPL, Unrestricted,
  87    --  or Modified_GPL depending on header. If none of these, returns Unknown.
  88
  89    function Double_Char_Token (C : Character) return Boolean;
  90    --  This function is used for double character tokens like := or <>. It
  91    --  checks if the character following Source (Scan_Ptr) is C, and if so
  92    --  bumps Scan_Ptr past the pair of characters and returns True. A space
  93    --  between the two characters is also recognized with an appropriate
  94    --  error message being issued. If C is not present, False is returned.
  95    --  Note that Double_Char_Token can only be used for tokens defined in
  96    --  the Ada syntax (it's use for error cases like && is not appropriate
  97    --  since we do not want a junk message for a case like &-space-&).
  98
  99    procedure Error_Illegal_Character;
 100    --  Give illegal character error, Scan_Ptr points to character. On return,
 101    --  Scan_Ptr is bumped past the illegal character.
 102
 103    procedure Error_Illegal_Wide_Character;
 104    --  Give illegal wide character message. On return, Scan_Ptr is bumped
 105    --  past the illegal character, which may still leave us pointing to
 106    --  junk, not much we can do if the escape sequence is messed up!
 107
 108    procedure Error_Long_Line;
 109    --  Signal error of excessively long line
 110
 111    procedure Error_No_Double_Underline;
 112    --  Signal error of double underline character
 113
 114    procedure Nlit;
 115    --  This is the procedure for scanning out numeric literals. On entry,
 116    --  Scan_Ptr points to the digit that starts the numeric literal (the
 117    --  checksum for this character has not been accumulated yet). On return
 118    --  Scan_Ptr points past the last character of the numeric literal, Token
 119    --  and Token_Node are set appropriately, and the checksum is updated.
 120
 121    function Set_Start_Column return Column_Number;
 122    --  This routine is called with Scan_Ptr pointing to the first character
 123    --  of a line. On exit, Scan_Ptr is advanced to the first non-blank
 124    --  character of this line (or to the terminating format effector if the
 125    --  line contains no non-blank characters), and the returned result is the
 126    --  column number of this non-blank character (zero origin), which is the
 127    --  value to be stored in the Start_Column scan variable.
 128
 129    procedure Slit;
 130    --  This is the procedure for scanning out string literals. On entry,
 131    --  Scan_Ptr points to the opening string quote (the checksum for this
 132    --  character has not been accumulated yet). On return Scan_Ptr points
 133    --  past the closing quote of the string literal, Token and Token_Node
 134    --  are set appropriately, and the checksum is upated.
 135
 136    -------------------------
 137    -- Accumulate_Checksum --
 138    -------------------------
 139
 140    procedure Accumulate_Checksum (C : Character) is
 141    begin
 142       System.CRC32.Update (System.CRC32.CRC32 (Checksum), C);
 143    end Accumulate_Checksum;
 144
 145    procedure Accumulate_Checksum (C : Char_Code) is
 146    begin
 147       Accumulate_Checksum (Character'Val (C / 256));
 148       Accumulate_Checksum (Character'Val (C mod 256));
 149    end Accumulate_Checksum;
 150
 151    -----------------------
 152    -- Check_End_Of_Line --
 153    -----------------------
 154
 155    procedure Check_End_Of_Line is
 156       Len : constant Int := Int (Scan_Ptr) - Int (Current_Line_Start);
 157
 158    begin
 159       if Len > Hostparm.Max_Line_Length then
 160          Error_Long_Line;
 161
 162       elsif Style_Check then
 163          Style.Check_Line_Terminator (Len);
 164       end if;
 165    end Check_End_Of_Line;
 166
 167    -----------------------
 168    -- Determine_License --
 169    -----------------------
 170
 171    function Determine_License return License_Type is
 172       GPL_Found : Boolean := False;
 173
 174       function Contains (S : String) return Boolean;
 175       --  See if current comment contains successive non-blank characters
 176       --  matching the contents of S. If so leave Scan_Ptr unchanged and
 177       --  return True, otherwise leave Scan_Ptr unchanged and return False.
 178
 179       procedure Skip_EOL;
 180       --  Skip to line terminator character
 181
 182       --------------
 183       -- Contains --
 184       --------------
 185
 186       function Contains (S : String) return Boolean is
 187          CP : Natural;
 188          SP : Source_Ptr;
 189          SS : Source_Ptr;
 190
 191       begin
 192          SP := Scan_Ptr;
 193          while Source (SP) /= CR and then Source (SP) /= LF loop
 194             if Source (SP) = S (S'First) then
 195                SS := SP;
 196                CP := S'First;
 197
 198                loop
 199                   SS := SS + 1;
 200                   CP := CP + 1;
 201
 202                   if CP > S'Last then
 203                      return True;
 204                   end if;
 205
 206                   while Source (SS) = ' ' loop
 207                      SS := SS + 1;
 208                   end loop;
 209
 210                   exit when Source (SS) /= S (CP);
 211                end loop;
 212             end if;
 213
 214             SP := SP + 1;
 215          end loop;
 216
 217          return False;
 218       end Contains;
 219
 220       --------------
 221       -- Skip_EOL --
 222       --------------
 223
 224       procedure Skip_EOL is
 225       begin
 226          while Source (Scan_Ptr) /= CR
 227            and then Source (Scan_Ptr) /= LF
 228          loop
 229             Scan_Ptr := Scan_Ptr + 1;
 230          end loop;
 231       end Skip_EOL;
 232
 233    --  Start of processing for Determine_License
 234
 235    begin
 236       loop
 237          if Source (Scan_Ptr) /= '-'
 238            or else Source (Scan_Ptr + 1) /= '-'
 239          then
 240             if GPL_Found then
 241                return GPL;
 242             else
 243                return Unknown;
 244             end if;
 245
 246          elsif Contains ("Asaspecialexception") then
 247             if GPL_Found then
 248                return Modified_GPL;
 249             end if;
 250
 251          elsif Contains ("GNUGeneralPublicLicense") then
 252             GPL_Found := True;
 253
 254          elsif
 255              Contains
 256                ("ThisspecificationisadaptedfromtheAdaSemanticInterface")
 257            or else
 258              Contains
 259               ("ThisspecificationisderivedfromtheAdaReferenceManual")
 260          then
 261             return Unrestricted;
 262          end if;
 263
 264          Skip_EOL;
 265
 266          Check_End_Of_Line;
 267
 268          declare
 269             Physical : Boolean;
 270
 271          begin
 272             Skip_Line_Terminators (Scan_Ptr, Physical);
 273
 274             --  If we are at start of physical line, update scan pointers
 275             --  to reflect the start of the new line.
 276
 277             if Physical then
 278                Current_Line_Start       := Scan_Ptr;
 279                Start_Column             := Set_Start_Column;
 280                First_Non_Blank_Location := Scan_Ptr;
 281             end if;
 282          end;
 283       end loop;
 284    end Determine_License;
 285
 286    ----------------------------
 287    -- Determine_Token_Casing --
 288    ----------------------------
 289
 290    function Determine_Token_Casing return Casing_Type is
 291    begin
 292       return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1));
 293    end Determine_Token_Casing;
 294
 295    -----------------------
 296    -- Double_Char_Token --
 297    -----------------------
 298
 299    function Double_Char_Token (C : Character) return Boolean is
 300    begin
 301       if Source (Scan_Ptr + 1) = C then
 302          Accumulate_Checksum (C);
 303          Scan_Ptr := Scan_Ptr + 2;
 304          return True;
 305
 306       elsif Source (Scan_Ptr + 1) = ' '
 307         and then Source (Scan_Ptr + 2) = C
 308       then
 309          Scan_Ptr := Scan_Ptr + 1;
 310          Error_Msg_S ("no space allowed here");
 311          Scan_Ptr := Scan_Ptr + 2;
 312          return True;
 313
 314       else
 315          return False;
 316       end if;
 317    end Double_Char_Token;
 318
 319    -----------------------------
 320    -- Error_Illegal_Character --
 321    -----------------------------
 322
 323    procedure Error_Illegal_Character is
 324    begin
 325       Error_Msg_S ("illegal character");
 326       Scan_Ptr := Scan_Ptr + 1;
 327    end Error_Illegal_Character;
 328
 329    ----------------------------------
 330    -- Error_Illegal_Wide_Character --
 331    ----------------------------------
 332
 333    procedure Error_Illegal_Wide_Character is
 334    begin
 335       if OpenVMS then
 336          Error_Msg_S
 337            ("illegal wide character, check " &
 338             "'/'W'I'D'E'_'C'H'A'R'A'C'T'E'R'_'E'N'C'O'D'I'N'G qualifer");
 339       else
 340          Error_Msg_S
 341            ("illegal wide character, check -gnatW switch");
 342       end if;
 343
 344       Scan_Ptr := Scan_Ptr + 1;
 345    end Error_Illegal_Wide_Character;
 346
 347    ---------------------
 348    -- Error_Long_Line --
 349    ---------------------
 350
 351    procedure Error_Long_Line is
 352    begin
 353       Error_Msg
 354         ("this line is too long",
 355          Current_Line_Start + Hostparm.Max_Line_Length);
 356    end Error_Long_Line;
 357
 358    -------------------------------
 359    -- Error_No_Double_Underline --
 360    -------------------------------
 361
 362    procedure Error_No_Double_Underline is
 363    begin
 364       Error_Msg_S ("two consecutive underlines not permitted");
 365    end Error_No_Double_Underline;
 366
 367    -------------------------
 368    -- Initialize_Checksum --
 369    -------------------------
 370
 371    procedure Initialize_Checksum is
 372    begin
 373       System.CRC32.Initialize (System.CRC32.CRC32 (Checksum));
 374    end Initialize_Checksum;
 375
 376    ------------------------
 377    -- Initialize_Scanner --
 378    ------------------------
 379
 380    procedure Initialize_Scanner
 381      (Unit  : Unit_Number_Type;
 382       Index : Source_File_Index)
 383    is
 384       GNAT_Hedr : constant Text_Buffer (1 .. 78) := (others => '-');
 385
 386    begin
 387       --  Set up Token_Type values in Names Table entries for reserved keywords
 388       --  We use the Pos value of the Token_Type value. Note we are relying on
 389       --  the fact that Token_Type'Val (0) is not a reserved word!
 390
 391       Set_Name_Table_Byte (Name_Abort,      Token_Type'Pos (Tok_Abort));
 392       Set_Name_Table_Byte (Name_Abs,        Token_Type'Pos (Tok_Abs));
 393       Set_Name_Table_Byte (Name_Abstract,   Token_Type'Pos (Tok_Abstract));
 394       Set_Name_Table_Byte (Name_Accept,     Token_Type'Pos (Tok_Accept));
 395       Set_Name_Table_Byte (Name_Access,     Token_Type'Pos (Tok_Access));
 396       Set_Name_Table_Byte (Name_And,        Token_Type'Pos (Tok_And));
 397       Set_Name_Table_Byte (Name_Aliased,    Token_Type'Pos (Tok_Aliased));
 398       Set_Name_Table_Byte (Name_All,        Token_Type'Pos (Tok_All));
 399       Set_Name_Table_Byte (Name_Array,      Token_Type'Pos (Tok_Array));
 400       Set_Name_Table_Byte (Name_At,         Token_Type'Pos (Tok_At));
 401       Set_Name_Table_Byte (Name_Begin,      Token_Type'Pos (Tok_Begin));
 402       Set_Name_Table_Byte (Name_Body,       Token_Type'Pos (Tok_Body));
 403       Set_Name_Table_Byte (Name_Case,       Token_Type'Pos (Tok_Case));
 404       Set_Name_Table_Byte (Name_Constant,   Token_Type'Pos (Tok_Constant));
 405       Set_Name_Table_Byte (Name_Declare,    Token_Type'Pos (Tok_Declare));
 406       Set_Name_Table_Byte (Name_Delay,      Token_Type'Pos (Tok_Delay));
 407       Set_Name_Table_Byte (Name_Delta,      Token_Type'Pos (Tok_Delta));
 408       Set_Name_Table_Byte (Name_Digits,     Token_Type'Pos (Tok_Digits));
 409       Set_Name_Table_Byte (Name_Do,         Token_Type'Pos (Tok_Do));
 410       Set_Name_Table_Byte (Name_Else,       Token_Type'Pos (Tok_Else));
 411       Set_Name_Table_Byte (Name_Elsif,      Token_Type'Pos (Tok_Elsif));
 412       Set_Name_Table_Byte (Name_End,        Token_Type'Pos (Tok_End));
 413       Set_Name_Table_Byte (Name_Entry,      Token_Type'Pos (Tok_Entry));
 414       Set_Name_Table_Byte (Name_Exception,  Token_Type'Pos (Tok_Exception));
 415       Set_Name_Table_Byte (Name_Exit,       Token_Type'Pos (Tok_Exit));
 416       Set_Name_Table_Byte (Name_For,        Token_Type'Pos (Tok_For));
 417       Set_Name_Table_Byte (Name_Function,   Token_Type'Pos (Tok_Function));
 418       Set_Name_Table_Byte (Name_Generic,    Token_Type'Pos (Tok_Generic));
 419       Set_Name_Table_Byte (Name_Goto,       Token_Type'Pos (Tok_Goto));
 420       Set_Name_Table_Byte (Name_If,         Token_Type'Pos (Tok_If));
 421       Set_Name_Table_Byte (Name_In,         Token_Type'Pos (Tok_In));
 422       Set_Name_Table_Byte (Name_Is,         Token_Type'Pos (Tok_Is));
 423       Set_Name_Table_Byte (Name_Limited,    Token_Type'Pos (Tok_Limited));
 424       Set_Name_Table_Byte (Name_Loop,       Token_Type'Pos (Tok_Loop));
 425       Set_Name_Table_Byte (Name_Mod,        Token_Type'Pos (Tok_Mod));
 426       Set_Name_Table_Byte (Name_New,        Token_Type'Pos (Tok_New));
 427       Set_Name_Table_Byte (Name_Not,        Token_Type'Pos (Tok_Not));
 428       Set_Name_Table_Byte (Name_Null,       Token_Type'Pos (Tok_Null));
 429       Set_Name_Table_Byte (Name_Of,         Token_Type'Pos (Tok_Of));
 430       Set_Name_Table_Byte (Name_Or,         Token_Type'Pos (Tok_Or));
 431       Set_Name_Table_Byte (Name_Others,     Token_Type'Pos (Tok_Others));
 432       Set_Name_Table_Byte (Name_Out,        Token_Type'Pos (Tok_Out));
 433       Set_Name_Table_Byte (Name_Package,    Token_Type'Pos (Tok_Package));
 434       Set_Name_Table_Byte (Name_Pragma,     Token_Type'Pos (Tok_Pragma));
 435       Set_Name_Table_Byte (Name_Private,    Token_Type'Pos (Tok_Private));
 436       Set_Name_Table_Byte (Name_Procedure,  Token_Type'Pos (Tok_Procedure));
 437       Set_Name_Table_Byte (Name_Protected,  Token_Type'Pos (Tok_Protected));
 438       Set_Name_Table_Byte (Name_Raise,      Token_Type'Pos (Tok_Raise));
 439       Set_Name_Table_Byte (Name_Range,      Token_Type'Pos (Tok_Range));
 440       Set_Name_Table_Byte (Name_Record,     Token_Type'Pos (Tok_Record));
 441       Set_Name_Table_Byte (Name_Rem,        Token_Type'Pos (Tok_Rem));
 442       Set_Name_Table_Byte (Name_Renames,    Token_Type'Pos (Tok_Renames));
 443       Set_Name_Table_Byte (Name_Requeue,    Token_Type'Pos (Tok_Requeue));
 444       Set_Name_Table_Byte (Name_Return,     Token_Type'Pos (Tok_Return));
 445       Set_Name_Table_Byte (Name_Reverse,    Token_Type'Pos (Tok_Reverse));
 446       Set_Name_Table_Byte (Name_Select,     Token_Type'Pos (Tok_Select));
 447       Set_Name_Table_Byte (Name_Separate,   Token_Type'Pos (Tok_Separate));
 448       Set_Name_Table_Byte (Name_Subtype,    Token_Type'Pos (Tok_Subtype));
 449       Set_Name_Table_Byte (Name_Tagged,     Token_Type'Pos (Tok_Tagged));
 450       Set_Name_Table_Byte (Name_Task,       Token_Type'Pos (Tok_Task));
 451       Set_Name_Table_Byte (Name_Terminate,  Token_Type'Pos (Tok_Terminate));
 452       Set_Name_Table_Byte (Name_Then,       Token_Type'Pos (Tok_Then));
 453       Set_Name_Table_Byte (Name_Type,       Token_Type'Pos (Tok_Type));
 454       Set_Name_Table_Byte (Name_Until,      Token_Type'Pos (Tok_Until));
 455       Set_Name_Table_Byte (Name_Use,        Token_Type'Pos (Tok_Use));
 456       Set_Name_Table_Byte (Name_When,       Token_Type'Pos (Tok_When));
 457       Set_Name_Table_Byte (Name_While,      Token_Type'Pos (Tok_While));
 458       Set_Name_Table_Byte (Name_With,       Token_Type'Pos (Tok_With));
 459       Set_Name_Table_Byte (Name_Xor,        Token_Type'Pos (Tok_Xor));
 460
 461       --  Initialize scan control variables
 462
 463       Current_Source_File       := Index;
 464       Source                    := Source_Text (Current_Source_File);
 465       Current_Source_Unit       := Unit;
 466       Scan_Ptr                  := Source_First (Current_Source_File);
 467       Token                     := No_Token;
 468       Token_Ptr                 := Scan_Ptr;
 469       Current_Line_Start        := Scan_Ptr;
 470       Token_Node                := Empty;
 471       Token_Name                := No_Name;
 472       Start_Column              := Set_Start_Column;
 473       First_Non_Blank_Location  := Scan_Ptr;
 474
 475       Initialize_Checksum;
 476
 477       --  Set default for Comes_From_Source. All nodes built now until we
 478       --  reenter the analyzer will have Comes_From_Source set to True
 479
 480       Set_Comes_From_Source_Default (True);
 481
 482       --  Check license if GNAT type header possibly present
 483
 484       if Source_Last (Index) - Scan_Ptr > 80
 485         and then Source (Scan_Ptr .. Scan_Ptr + 77) = GNAT_Hedr
 486       then
 487          Set_License (Current_Source_File, Determine_License);
 488       end if;
 489
 490       --  Scan initial token (note this initializes Prev_Token, Prev_Token_Ptr)
 491
 492       Scan;
 493
 494       --  Clear flags for reserved words used as identifiers
 495
 496       for J in Token_Type loop
 497          Used_As_Identifier (J) := False;
 498       end loop;
 499
 500    end Initialize_Scanner;
 501
 502    ----------
 503    -- Nlit --
 504    ----------
 505
 506    procedure Nlit is separate;
 507
 508    ----------
 509    -- Scan --
 510    ----------
 511
 512    procedure Scan is
 513    begin
 514       Prev_Token := Token;
 515       Prev_Token_Ptr := Token_Ptr;
 516       Token_Name := Error_Name;
 517
 518       --  The following loop runs more than once only if a format effector
 519       --  (tab, vertical tab, form  feed, line feed, carriage return) is
 520       --  encountered and skipped, or some error situation, such as an
 521       --  illegal character, is encountered.
 522
 523       loop
 524          --  Skip past blanks, loop is opened up for speed
 525
 526          while Source (Scan_Ptr) = ' ' loop
 527
 528             if Source (Scan_Ptr + 1) /= ' ' then
 529                Scan_Ptr := Scan_Ptr + 1;
 530                exit;
 531             end if;
 532
 533             if Source (Scan_Ptr + 2) /= ' ' then
 534                Scan_Ptr := Scan_Ptr + 2;
 535                exit;
 536             end if;
 537
 538             if Source (Scan_Ptr + 3) /= ' ' then
 539                Scan_Ptr := Scan_Ptr + 3;
 540                exit;
 541             end if;
 542
 543             if Source (Scan_Ptr + 4) /= ' ' then
 544                Scan_Ptr := Scan_Ptr + 4;
 545                exit;
 546             end if;
 547
 548             if Source (Scan_Ptr + 5) /= ' ' then
 549                Scan_Ptr := Scan_Ptr + 5;
 550                exit;
 551             end if;
 552
 553             if Source (Scan_Ptr + 6) /= ' ' then
 554                Scan_Ptr := Scan_Ptr + 6;
 555                exit;
 556             end if;
 557
 558             if Source (Scan_Ptr + 7) /= ' ' then
 559                Scan_Ptr := Scan_Ptr + 7;
 560                exit;
 561             end if;
 562
 563             Scan_Ptr := Scan_Ptr + 8;
 564          end loop;
 565
 566          --  We are now at a non-blank character, which is the first character
 567          --  of the token we will scan, and hence the value of Token_Ptr.
 568
 569          Token_Ptr := Scan_Ptr;
 570
 571          --  Here begins the main case statement which transfers control on
 572          --  the basis of the non-blank character we have encountered.
 573
 574          case Source (Scan_Ptr) is
 575
 576          --  Line terminator characters
 577
 578          when CR | LF | FF | VT => Line_Terminator_Case : begin
 579
 580             --  Check line too long
 581
 582             Check_End_Of_Line;
 583
 584             declare
 585                Physical : Boolean;
 586
 587             begin
 588                Skip_Line_Terminators (Scan_Ptr, Physical);
 589
 590                --  If we are at start of physical line, update scan pointers
 591                --  to reflect the start of the new line.
 592
 593                if Physical then
 594                   Current_Line_Start       := Scan_Ptr;
 595                   Start_Column             := Set_Start_Column;
 596                   First_Non_Blank_Location := Scan_Ptr;
 597                end if;
 598             end;
 599          end Line_Terminator_Case;
 600
 601          --  Horizontal tab, just skip past it
 602
 603          when HT =>
 604             if Style_Check then Style.Check_HT; end if;
 605             Scan_Ptr := Scan_Ptr + 1;
 606
 607          --  End of file character, treated as an end of file only if it
 608          --  is the last character in the buffer, otherwise it is ignored.
 609
 610          when EOF =>
 611             if Scan_Ptr = Source_Last (Current_Source_File) then
 612                Check_End_Of_Line;
 613                Token := Tok_EOF;
 614                return;
 615
 616             else
 617                Scan_Ptr := Scan_Ptr + 1;
 618             end if;
 619
 620          --  Ampersand
 621
 622          when '&' =>
 623             Accumulate_Checksum ('&');
 624
 625             if Source (Scan_Ptr + 1) = '&' then
 626                Error_Msg_S ("'&'& should be `AND THEN`");
 627                Scan_Ptr := Scan_Ptr + 2;
 628                Token := Tok_And;
 629                return;
 630
 631             else
 632                Scan_Ptr := Scan_Ptr + 1;
 633                Token := Tok_Ampersand;
 634                return;
 635             end if;
 636
 637          --  Asterisk (can be multiplication operator or double asterisk
 638          --  which is the exponentiation compound delimtier).
 639
 640          when '*' =>
 641             Accumulate_Checksum ('*');
 642
 643             if Source (Scan_Ptr + 1) = '*' then
 644                Accumulate_Checksum ('*');
 645                Scan_Ptr := Scan_Ptr + 2;
 646                Token := Tok_Double_Asterisk;
 647                return;
 648
 649             else
 650                Scan_Ptr := Scan_Ptr + 1;
 651                Token := Tok_Asterisk;
 652                return;
 653             end if;
 654
 655          --  Colon, which can either be an isolated colon, or part of an
 656          --  assignment compound delimiter.
 657
 658          when ':' =>
 659             Accumulate_Checksum (':');
 660
 661             if Double_Char_Token ('=') then
 662                Token := Tok_Colon_Equal;
 663                if Style_Check then Style.Check_Colon_Equal; end if;
 664                return;
 665
 666             elsif Source (Scan_Ptr + 1) = '-'
 667               and then Source (Scan_Ptr + 2) /= '-'
 668             then
 669                Token := Tok_Colon_Equal;
 670                Error_Msg (":- should be :=", Scan_Ptr);
 671                Scan_Ptr := Scan_Ptr + 2;
 672                return;
 673
 674             else
 675                Scan_Ptr := Scan_Ptr + 1;
 676                Token := Tok_Colon;
 677                if Style_Check then Style.Check_Colon; end if;
 678                return;
 679             end if;
 680
 681          --  Left parenthesis
 682
 683          when '(' =>
 684             Accumulate_Checksum ('(');
 685             Scan_Ptr := Scan_Ptr + 1;
 686             Token := Tok_Left_Paren;
 687             if Style_Check then Style.Check_Left_Paren; end if;
 688             return;
 689
 690          --  Left bracket
 691
 692          when '[' =>
 693             if Source (Scan_Ptr + 1) = '"' then
 694                Name_Len := 0;
 695                goto Scan_Identifier;
 696
 697             else
 698                Error_Msg_S ("illegal character, replaced by ""(""");
 699                Scan_Ptr := Scan_Ptr + 1;
 700                Token := Tok_Left_Paren;
 701                return;
 702             end if;
 703
 704          --  Left brace
 705
 706          when '{' =>
 707             Error_Msg_S ("illegal character, replaced by ""(""");
 708             Scan_Ptr := Scan_Ptr + 1;
 709             Token := Tok_Left_Paren;
 710             return;
 711
 712          --  Comma
 713
 714          when ',' =>
 715             Accumulate_Checksum (',');
 716             Scan_Ptr := Scan_Ptr + 1;
 717             Token := Tok_Comma;
 718             if Style_Check then Style.Check_Comma; end if;
 719             return;
 720
 721          --  Dot, which is either an isolated period, or part of a double
 722          --  dot compound delimiter sequence. We also check for the case of
 723          --  a digit following the period, to give a better error message.
 724
 725          when '.' =>
 726             Accumulate_Checksum ('.');
 727
 728             if Double_Char_Token ('.') then
 729                Token := Tok_Dot_Dot;
 730                if Style_Check then Style.Check_Dot_Dot; end if;
 731                return;
 732
 733             elsif Source (Scan_Ptr + 1) in '0' .. '9' then
 734                Error_Msg_S ("numeric literal cannot start with point");
 735                Scan_Ptr := Scan_Ptr + 1;
 736
 737             else
 738                Scan_Ptr := Scan_Ptr + 1;
 739                Token := Tok_Dot;
 740                return;
 741             end if;
 742
 743          --  Equal, which can either be an equality operator, or part of the
 744          --  arrow (=>) compound delimiter.
 745
 746          when '=' =>
 747             Accumulate_Checksum ('=');
 748
 749             if Double_Char_Token ('>') then
 750                Token := Tok_Arrow;
 751                if Style_Check then Style.Check_Arrow; end if;
 752                return;
 753
 754             elsif Source (Scan_Ptr + 1) = '=' then
 755                Error_Msg_S ("== should be =");
 756                Scan_Ptr := Scan_Ptr + 1;
 757             end if;
 758
 759             Scan_Ptr := Scan_Ptr + 1;
 760             Token := Tok_Equal;
 761             return;
 762
 763          --  Greater than, which can be a greater than operator, greater than
 764          --  or equal operator, or first character of a right label bracket.
 765
 766          when '>' =>
 767             Accumulate_Checksum ('>');
 768
 769             if Double_Char_Token ('=') then
 770                Token := Tok_Greater_Equal;
 771                return;
 772
 773             elsif Double_Char_Token ('>') then
 774                Token := Tok_Greater_Greater;
 775                return;
 776
 777             else
 778                Scan_Ptr := Scan_Ptr + 1;
 779                Token := Tok_Greater;
 780                return;
 781             end if;
 782
 783          --  Less than, which can be a less than operator, less than or equal
 784          --  operator, or the first character of a left label bracket, or the
 785          --  first character of a box (<>) compound delimiter.
 786
 787          when '<' =>
 788             Accumulate_Checksum ('<');
 789
 790             if Double_Char_Token ('=') then
 791                Token := Tok_Less_Equal;
 792                return;
 793
 794             elsif Double_Char_Token ('>') then
 795                Token := Tok_Box;
 796                if Style_Check then Style.Check_Box; end if;
 797                return;
 798
 799             elsif Double_Char_Token ('<') then
 800                Token := Tok_Less_Less;
 801                return;
 802
 803             else
 804                Scan_Ptr := Scan_Ptr + 1;
 805                Token := Tok_Less;
 806                return;
 807             end if;
 808
 809          --  Minus, which is either a subtraction operator, or the first
 810          --  character of double minus starting a comment
 811
 812          when '-' => Minus_Case : begin
 813             if Source (Scan_Ptr + 1) = '>' then
 814                Error_Msg_S ("invalid token");
 815                Scan_Ptr := Scan_Ptr + 2;
 816                Token := Tok_Arrow;
 817                return;
 818
 819             elsif Source (Scan_Ptr + 1) /= '-' then
 820                Accumulate_Checksum ('-');
 821                Scan_Ptr := Scan_Ptr + 1;
 822                Token := Tok_Minus;
 823                return;
 824
 825             --  Comment
 826
 827             else -- Source (Scan_Ptr + 1) = '-' then
 828                if Style_Check then Style.Check_Comment; end if;
 829                Scan_Ptr := Scan_Ptr + 2;
 830
 831                --  Loop to scan comment (this loop runs more than once only if
 832                --  a horizontal tab or other non-graphic character is scanned)
 833
 834                loop
 835                   --  Scan to non graphic character (opened up for speed)
 836
 837                   loop
 838                      exit when Source (Scan_Ptr) not in Graphic_Character;
 839                      Scan_Ptr := Scan_Ptr + 1;
 840                      exit when Source (Scan_Ptr) not in Graphic_Character;
 841                      Scan_Ptr := Scan_Ptr + 1;
 842                      exit when Source (Scan_Ptr) not in Graphic_Character;
 843                      Scan_Ptr := Scan_Ptr + 1;
 844                      exit when Source (Scan_Ptr) not in Graphic_Character;
 845                      Scan_Ptr := Scan_Ptr + 1;
 846                      exit when Source (Scan_Ptr) not in Graphic_Character;
 847                      Scan_Ptr := Scan_Ptr + 1;
 848                   end loop;
 849
 850                   --  Keep going if horizontal tab
 851
 852                   if Source (Scan_Ptr) = HT then
 853                      if Style_Check then Style.Check_HT; end if;
 854                      Scan_Ptr := Scan_Ptr + 1;
 855
 856                   --  Terminate scan of comment if line terminator
 857
 858                   elsif Source (Scan_Ptr) in Line_Terminator then
 859                      exit;
 860
 861                   --  Terminate scan of comment if end of file encountered
 862                   --  (embedded EOF character or real last character in file)
 863
 864                   elsif Source (Scan_Ptr) = EOF then
 865                      exit;
 866
 867                   --  Keep going if character in 80-FF range, or is ESC. These
 868                   --  characters are allowed in comments by RM-2.1(1), 2.7(2).
 869                   --  They are allowed even in Ada 83 mode according to the
 870                   --  approved AI. ESC was added to the AI in June 93.
 871
 872                   elsif Source (Scan_Ptr) in Upper_Half_Character
 873                     or else Source (Scan_Ptr) = ESC
 874                   then
 875                      Scan_Ptr := Scan_Ptr + 1;
 876
 877                   --  Otherwise we have an illegal comment character
 878
 879                   else
 880                      Error_Illegal_Character;
 881                   end if;
 882
 883                end loop;
 884
 885                --  Note that we do NOT execute a return here, instead we fall
 886                --  through to reexecute the scan loop to look for a token.
 887
 888             end if;
 889          end Minus_Case;
 890
 891          --  Double quote or percent starting a string literal
 892
 893          when '"' | '%' =>
 894             Slit;
 895             return;
 896
 897          --  Apostrophe. This can either be the start of a character literal,
 898          --  or an isolated apostrophe used in a qualified expression or an
 899          --  attribute. We treat it as a character literal if it does not
 900          --  follow a right parenthesis, identifier, the keyword ALL or
 901          --  a literal. This means that we correctly treat constructs like:
 902
 903          --    A := CHARACTER'('A');
 904
 905          --  Note that RM-2.2(7) does not require a separator between
 906          --  "CHARACTER" and "'" in the above.
 907
 908          when ''' => Char_Literal_Case : declare
 909             Code : Char_Code;
 910             Err  : Boolean;
 911
 912          begin
 913             Accumulate_Checksum (''');
 914             Scan_Ptr := Scan_Ptr + 1;
 915
 916             --  Here is where we make the test to distinguish the cases. Treat
 917             --  as apostrophe if previous token is an identifier, right paren
 918             --  or the reserved word "all" (latter case as in A.all'Address)
 919             --  Also treat it as apostrophe after a literal (this catches
 920             --  some legitimate cases, like A."abs"'Address, and also gives
 921             --  better error behavior for impossible cases like 123'xxx).
 922
 923             if Prev_Token = Tok_Identifier
 924                or else Prev_Token = Tok_Right_Paren
 925                or else Prev_Token = Tok_All
 926                or else Prev_Token in Token_Class_Literal
 927             then
 928                Token := Tok_Apostrophe;
 929                return;
 930
 931             --  Otherwise the apostrophe starts a character literal
 932
 933             else
 934                --  Case of wide character literal with ESC or [ encoding
 935
 936                if (Source (Scan_Ptr) = ESC
 937                      and then
 938                     Wide_Character_Encoding_Method in WC_ESC_Encoding_Method)
 939                  or else
 940                    (Source (Scan_Ptr) in Upper_Half_Character
 941                      and then
 942                     Upper_Half_Encoding)
 943                  or else
 944                    (Source (Scan_Ptr) = '['
 945                      and then
 946                     Source (Scan_Ptr + 1) = '"')
 947                then
 948                   Scan_Wide (Source, Scan_Ptr, Code, Err);
 949                   Accumulate_Checksum (Code);
 950
 951                   if Err then
 952                      Error_Illegal_Wide_Character;
 953                   end if;
 954
 955                   if Source (Scan_Ptr) /= ''' then
 956                      Error_Msg_S ("missing apostrophe");
 957                   else
 958                      Scan_Ptr := Scan_Ptr + 1;
 959                   end if;
 960
 961                --  If we do not find a closing quote in the expected place then
 962                --  assume that we have a misguided attempt at a string literal.
 963
 964                --  However, if previous token is RANGE, then we return an
 965                --  apostrophe instead since this gives better error recovery
 966
 967                elsif Source (Scan_Ptr + 1) /= ''' then
 968
 969                   if Prev_Token = Tok_Range then
 970                      Token := Tok_Apostrophe;
 971                      return;
 972
 973                   else
 974                      Scan_Ptr := Scan_Ptr - 1;
 975                      Error_Msg_S
 976                        ("strings are delimited by double quote character");
 977                      Scn.Slit;
 978                      return;
 979                   end if;
 980
 981                --  Otherwise we have a (non-wide) character literal
 982
 983                else
 984                   Accumulate_Checksum (Source (Scan_Ptr));
 985
 986                   if Source (Scan_Ptr) not in Graphic_Character then
 987                      if Source (Scan_Ptr) in Upper_Half_Character then
 988                         if Ada_83 then
 989                            Error_Illegal_Character;
 990                         end if;
 991
 992                      else
 993                         Error_Illegal_Character;
 994                      end if;
 995                   end if;
 996
 997                   Code := Get_Char_Code (Source (Scan_Ptr));
 998                   Scan_Ptr := Scan_Ptr + 2;
 999                end if;
1000
1001                --  Fall through here with Scan_Ptr updated past the closing
1002                --  quote, and Code set to the Char_Code value for the literal
1003
1004                Accumulate_Checksum (''');
1005                Token := Tok_Char_Literal;
1006                Token_Node := New_Node (N_Character_Literal, Token_Ptr);
1007                Set_Char_Literal_Value (Token_Node, Code);
1008                Set_Character_Literal_Name (Code);
1009                Token_Name := Name_Find;
1010                Set_Chars (Token_Node, Token_Name);
1011                return;
1012             end if;
1013          end Char_Literal_Case;
1014
1015          --  Right parenthesis
1016
1017          when ')' =>
1018             Accumulate_Checksum (')');
1019             Scan_Ptr := Scan_Ptr + 1;
1020             Token := Tok_Right_Paren;
1021             if Style_Check then Style.Check_Right_Paren; end if;
1022             return;
1023
1024          --  Right bracket or right brace, treated as right paren
1025
1026          when ']' | '}' =>
1027             Error_Msg_S ("illegal character, replaced by "")""");
1028             Scan_Ptr := Scan_Ptr + 1;
1029             Token := Tok_Right_Paren;
1030             return;
1031
1032          --  Slash (can be division operator or first character of not equal)
1033
1034          when '/' =>
1035             Accumulate_Checksum ('/');
1036
1037             if Double_Char_Token ('=') then
1038                Token := Tok_Not_Equal;
1039                return;
1040             else
1041                Scan_Ptr := Scan_Ptr + 1;
1042                Token := Tok_Slash;
1043                return;
1044             end if;
1045
1046          --  Semicolon
1047
1048          when ';' =>
1049             Accumulate_Checksum (';');
1050             Scan_Ptr := Scan_Ptr + 1;
1051             Token := Tok_Semicolon;
1052             if Style_Check then Style.Check_Semicolon; end if;
1053             return;
1054
1055          --  Vertical bar
1056
1057          when '|' => Vertical_Bar_Case : begin
1058             Accumulate_Checksum ('|');
1059
1060             --  Special check for || to give nice message
1061
1062             if Source (Scan_Ptr + 1) = '|' then
1063                Error_Msg_S ("""'|'|"" should be `OR ELSE`");
1064                Scan_Ptr := Scan_Ptr + 2;
1065                Token := Tok_Or;
1066                return;
1067
1068             else
1069                Scan_Ptr := Scan_Ptr + 1;
1070                Token := Tok_Vertical_Bar;
1071                if Style_Check then Style.Check_Vertical_Bar; end if;
1072                return;
1073             end if;
1074          end Vertical_Bar_Case;
1075
1076          --  Exclamation, replacement character for vertical bar
1077
1078          when '!' => Exclamation_Case : begin
1079             Accumulate_Checksum ('!');
1080
1081             if Source (Scan_Ptr + 1) = '=' then
1082                Error_Msg_S ("'!= should be /=");
1083                Scan_Ptr := Scan_Ptr + 2;
1084                Token := Tok_Not_Equal;
1085                return;
1086
1087             else
1088                Scan_Ptr := Scan_Ptr + 1;
1089                Token := Tok_Vertical_Bar;
1090                return;
1091             end if;
1092
1093          end Exclamation_Case;
1094
1095          --  Plus
1096
1097          when '+' => Plus_Case : begin
1098             Accumulate_Checksum ('+');
1099             Scan_Ptr := Scan_Ptr + 1;
1100             Token := Tok_Plus;
1101             return;
1102          end Plus_Case;
1103
1104          --  Digits starting a numeric literal
1105
1106          when '0' .. '9' =>
1107             Nlit;
1108
1109             if Identifier_Char (Source (Scan_Ptr)) then
1110                Error_Msg_S
1111                  ("delimiter required between literal and identifier");
1112             end if;
1113
1114             return;
1115
1116          --  Lower case letters
1117
1118          when 'a' .. 'z' =>
1119             Name_Len := 1;
1120             Name_Buffer (1) := Source (Scan_Ptr);
1121             Accumulate_Checksum (Name_Buffer (1));
1122             Scan_Ptr := Scan_Ptr + 1;
1123             goto Scan_Identifier;
1124
1125          --  Upper case letters
1126
1127          when 'A' .. 'Z' =>
1128             Name_Len := 1;
1129             Name_Buffer (1) :=
1130               Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
1131             Accumulate_Checksum (Name_Buffer (1));
1132             Scan_Ptr := Scan_Ptr + 1;
1133             goto Scan_Identifier;
1134
1135          --  Underline character
1136
1137          when '_' =>
1138             Error_Msg_S ("identifier cannot start with underline");
1139             Name_Len := 1;
1140             Name_Buffer (1) := '_';
1141             Scan_Ptr := Scan_Ptr + 1;
1142             goto Scan_Identifier;
1143
1144          --  Space (not possible, because we scanned past blanks)
1145
1146          when ' ' =>
1147             raise Program_Error;
1148
1149          --  Characters in top half of ASCII 8-bit chart
1150
1151          when Upper_Half_Character =>
1152
1153             --  Wide character case. Note that Scan_Identifier will issue
1154             --  an appropriate message if wide characters are not allowed
1155             --  in identifiers.
1156
1157             if Upper_Half_Encoding then
1158                Name_Len := 0;
1159                goto Scan_Identifier;
1160
1161             --  Otherwise we have OK Latin-1 character
1162
1163             else
1164                --  Upper half characters may possibly be identifier letters
1165                --  but can never be digits, so Identifier_Char can be used
1166                --  to test for a valid start of identifier character.
1167
1168                if Identifier_Char (Source (Scan_Ptr)) then
1169                   Name_Len := 0;
1170                   goto Scan_Identifier;
1171                else
1172                   Error_Illegal_Character;
1173                end if;
1174             end if;
1175
1176          when ESC =>
1177
1178             --  ESC character, possible start of identifier if wide characters
1179             --  using ESC encoding are allowed in identifiers, which we can
1180             --  tell by looking at the Identifier_Char flag for ESC, which is
1181             --  only true if these conditions are met.
1182
1183             if Identifier_Char (ESC) then
1184                Name_Len := 0;
1185                goto Scan_Identifier;
1186             else
1187                Error_Illegal_Wide_Character;
1188             end if;
1189
1190          --  Invalid control characters
1191
1192          when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS  | SO  |
1193               SI  | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
1194               EM  | FS  | GS  | RS  | US  | DEL
1195          =>
1196             Error_Illegal_Character;
1197
1198          --  Invalid graphic characters
1199
1200          when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' =>
1201             Error_Illegal_Character;
1202
1203          --  End switch on non-blank character
1204
1205          end case;
1206
1207       --  End loop past format effectors. The exit from this loop is by
1208       --  executing a return statement following completion of token scan
1209       --  (control never falls out of this loop to the code which follows)
1210
1211       end loop;
1212
1213       --  Identifier scanning routine. On entry, some initial characters
1214       --  of the identifier may have already been stored in Name_Buffer.
1215       --  If so, Name_Len has the number of characters stored. otherwise
1216       --  Name_Len is set to zero on entry.
1217
1218       <<Scan_Identifier>>
1219
1220          --  This loop scans as fast as possible past lower half letters
1221          --  and digits, which we expect to be the most common characters.
1222
1223          loop
1224             if Source (Scan_Ptr) in 'a' .. 'z'
1225               or else Source (Scan_Ptr) in '0' .. '9'
1226             then
1227                Name_Buffer (Name_Len + 1) := Source (Scan_Ptr);
1228                Accumulate_Checksum (Source (Scan_Ptr));
1229
1230             elsif Source (Scan_Ptr) in 'A' .. 'Z' then
1231                Name_Buffer (Name_Len + 1) :=
1232                  Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
1233                Accumulate_Checksum (Name_Buffer (Name_Len + 1));
1234             else
1235                exit;
1236             end if;
1237
1238             --  Open out the loop a couple of times for speed
1239
1240             if Source (Scan_Ptr + 1) in 'a' .. 'z'
1241               or else Source (Scan_Ptr + 1) in '0' .. '9'
1242             then
1243                Name_Buffer (Name_Len + 2) := Source (Scan_Ptr + 1);
1244                Accumulate_Checksum (Source (Scan_Ptr + 1));
1245
1246             elsif Source (Scan_Ptr + 1) in 'A' .. 'Z' then
1247                Name_Buffer (Name_Len + 2) :=
1248                  Character'Val (Character'Pos (Source (Scan_Ptr + 1)) + 32);
1249                Accumulate_Checksum (Name_Buffer (Name_Len + 2));
1250
1251             else
1252                Scan_Ptr := Scan_Ptr + 1;
1253                Name_Len := Name_Len + 1;
1254                exit;
1255             end if;
1256
1257             if Source (Scan_Ptr + 2) in 'a' .. 'z'
1258               or else Source (Scan_Ptr + 2) in '0' .. '9'
1259             then
1260                Name_Buffer (Name_Len + 3) := Source (Scan_Ptr + 2);
1261                Accumulate_Checksum (Source (Scan_Ptr + 2));
1262
1263             elsif Source (Scan_Ptr + 2) in 'A' .. 'Z' then
1264                Name_Buffer (Name_Len + 3) :=
1265                  Character'Val (Character'Pos (Source (Scan_Ptr + 2)) + 32);
1266                Accumulate_Checksum (Name_Buffer (Name_Len + 3));
1267             else
1268                Scan_Ptr := Scan_Ptr + 2;
1269                Name_Len := Name_Len + 2;
1270                exit;
1271             end if;
1272
1273             if Source (Scan_Ptr + 3) in 'a' .. 'z'
1274               or else Source (Scan_Ptr + 3) in '0' .. '9'
1275             then
1276                Name_Buffer (Name_Len + 4) := Source (Scan_Ptr + 3);
1277                Accumulate_Checksum (Source (Scan_Ptr + 3));
1278
1279             elsif Source (Scan_Ptr + 3) in 'A' .. 'Z' then
1280                Name_Buffer (Name_Len + 4) :=
1281                  Character'Val (Character'Pos (Source (Scan_Ptr + 3)) + 32);
1282                Accumulate_Checksum (Name_Buffer (Name_Len + 4));
1283
1284             else
1285                Scan_Ptr := Scan_Ptr + 3;
1286                Name_Len := Name_Len + 3;
1287                exit;
1288             end if;
1289
1290             Scan_Ptr := Scan_Ptr + 4;
1291             Name_Len := Name_Len + 4;
1292          end loop;
1293
1294          --  If we fall through, then we have encountered either an underline
1295          --  character, or an extended identifier character (i.e. one from the
1296          --  upper half), or a wide character, or an identifier terminator.
1297          --  The initial test speeds us up in the most common case where we
1298          --  have an identifier terminator. Note that ESC is an identifier
1299          --  character only if a wide character encoding method that uses
1300          --  ESC encoding is active, so if we find an ESC character we know
1301          --  that we have a wide character.
1302
1303          if Identifier_Char (Source (Scan_Ptr)) then
1304
1305             --  Case of underline, check for error cases of double underline,
1306             --  and for a trailing underline character
1307
1308             if Source (Scan_Ptr) = '_' then
1309                Accumulate_Checksum ('_');
1310                Name_Len := Name_Len + 1;
1311                Name_Buffer (Name_Len) := '_';
1312
1313                if Identifier_Char (Source (Scan_Ptr + 1)) then
1314                   Scan_Ptr := Scan_Ptr + 1;
1315
1316                   if Source (Scan_Ptr) = '_' then
1317                      Error_No_Double_Underline;
1318                   end if;
1319
1320                else
1321                   Error_Msg_S ("identifier cannot end with underline");
1322                   Scan_Ptr := Scan_Ptr + 1;
1323                end if;
1324
1325                goto Scan_Identifier;
1326
1327             --  Upper half character
1328
1329             elsif Source (Scan_Ptr) in Upper_Half_Character
1330               and then not Upper_Half_Encoding
1331             then
1332                Accumulate_Checksum (Source (Scan_Ptr));
1333                Store_Encoded_Character
1334                  (Get_Char_Code (Fold_Lower (Source (Scan_Ptr))));
1335                Scan_Ptr := Scan_Ptr + 1;
1336                goto Scan_Identifier;
1337
1338             --  Left bracket not followed by a quote terminates an identifier.
1339             --  This is an error, but we don't want to give a junk error msg
1340             --  about wide characters in this case!
1341
1342             elsif Source (Scan_Ptr) = '['
1343               and then Source (Scan_Ptr + 1) /= '"'
1344             then
1345                null;
1346
1347             --  We know we have a wide character encoding here (the current
1348             --  character is either ESC, left bracket, or an upper half
1349             --  character depending on the encoding method).
1350
1351             else
1352                --  Scan out the wide character and insert the appropriate
1353                --  encoding into the name table entry for the identifier.
1354
1355                declare
1356                   Sptr : constant Source_Ptr := Scan_Ptr;
1357                   Code : Char_Code;
1358                   Err  : Boolean;
1359                   Chr  : Character;
1360
1361                begin
1362                   Scan_Wide (Source, Scan_Ptr, Code, Err);
1363
1364                   --  If error, signal error
1365
1366                   if Err then
1367                      Error_Illegal_Wide_Character;
1368
1369                   --  If the character scanned is a normal identifier
1370                   --  character, then we treat it that way.
1371
1372                   elsif In_Character_Range (Code)
1373                     and then Identifier_Char (Get_Character (Code))
1374                   then
1375                      Chr := Get_Character (Code);
1376                      Accumulate_Checksum (Chr);
1377                      Store_Encoded_Character
1378                        (Get_Char_Code (Fold_Lower (Chr)));
1379
1380                   --  Character is not normal identifier character, store
1381                   --  it in encoded form.
1382
1383                   else
1384                      Accumulate_Checksum (Code);
1385                      Store_Encoded_Character (Code);
1386
1387                      --  Make sure we are allowing wide characters in
1388                      --  identifiers. Note that we allow wide character
1389                      --  notation for an OK identifier character. This
1390                      --  in particular allows bracket or other notation
1391                      --  to be used for upper half letters.
1392
1393                      if Identifier_Character_Set /= 'w' then
1394                         Error_Msg
1395                           ("wide character not allowed in identifier", Sptr);
1396                      end if;
1397                   end if;
1398                end;
1399
1400                goto Scan_Identifier;
1401             end if;
1402          end if;
1403
1404          --  Scan of identifier is complete. The identifier is stored in
1405          --  Name_Buffer, and Scan_Ptr points past the last character.
1406
1407          Token_Name := Name_Find;
1408
1409          --  Here is where we check if it was a keyword
1410
1411          if Get_Name_Table_Byte (Token_Name) /= 0
1412            and then (Ada_95 or else Token_Name not in Ada_95_Reserved_Words)
1413          then
1414             Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
1415
1416             --  Deal with possible style check for non-lower case keyword,
1417             --  but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords
1418             --  for this purpose if they appear as attribute designators.
1419             --  Actually we only check the first character for speed.
1420
1421             if Style_Check
1422               and then Source (Token_Ptr) <= 'Z'
1423               and then (Prev_Token /= Tok_Apostrophe
1424                           or else
1425                             (Token /= Tok_Access
1426                                and then Token /= Tok_Delta
1427                                and then Token /= Tok_Digits
1428                                and then Token /= Tok_Range))
1429             then
1430                Style.Non_Lower_Case_Keyword;
1431             end if;
1432
1433             --  We must reset Token_Name since this is not an identifier
1434             --  and if we leave Token_Name set, the parser gets confused
1435             --  because it thinks it is dealing with an identifier instead
1436             --  of the corresponding keyword.
1437
1438             Token_Name := No_Name;
1439             return;
1440
1441          --  It is an identifier after all
1442
1443          else
1444             Token_Node := New_Node (N_Identifier, Token_Ptr);
1445             Set_Chars (Token_Node, Token_Name);
1446             Token := Tok_Identifier;
1447             return;
1448          end if;
1449    end Scan;
1450
1451    ---------------------
1452    -- Scan_First_Char --
1453    ---------------------
1454
1455    function Scan_First_Char return Source_Ptr is
1456       Ptr : Source_Ptr := Current_Line_Start;
1457
1458    begin
1459       loop
1460          if Source (Ptr) = ' ' then
1461             Ptr := Ptr + 1;
1462
1463          elsif Source (Ptr) = HT then
1464             if Style_Check then Style.Check_HT; end if;
1465             Ptr := Ptr + 1;
1466
1467          else
1468             return Ptr;
1469          end if;
1470       end loop;
1471    end Scan_First_Char;
1472
1473    ------------------------------
1474    -- Scan_Reserved_Identifier --
1475    ------------------------------
1476
1477    procedure Scan_Reserved_Identifier (Force_Msg : Boolean) is
1478       Token_Chars : constant String := Token_Type'Image (Token);
1479
1480    begin
1481       --  We have in Token_Chars the image of the Token name, i.e. Tok_xxx.
1482       --  This code extracts the xxx and makes an identifier out of it.
1483
1484       Name_Len := 0;
1485
1486       for J in 5 .. Token_Chars'Length loop
1487          Name_Len := Name_Len + 1;
1488          Name_Buffer (Name_Len) := Fold_Lower (Token_Chars (J));
1489       end loop;
1490
1491       Token_Name := Name_Find;
1492
1493       if not Used_As_Identifier (Token) or else Force_Msg then
1494          Error_Msg_Name_1 := Token_Name;
1495          Error_Msg_SC ("reserved word* cannot be used as identifier!");
1496          Used_As_Identifier (Token) := True;
1497       end if;
1498
1499       Token := Tok_Identifier;
1500       Token_Node := New_Node (N_Identifier, Token_Ptr);
1501       Set_Chars (Token_Node, Token_Name);
1502    end Scan_Reserved_Identifier;
1503
1504    ----------------------
1505    -- Set_Start_Column --
1506    ----------------------
1507
1508    --  Note: it seems at first glance a little expensive to compute this value
1509    --  for every source line (since it is certainly not used for all source
1510    --  lines). On the other hand, it doesn't take much more work to skip past
1511    --  the initial white space on the line counting the columns than it would
1512    --  to scan past the white space using the standard scanning circuits.
1513
1514    function Set_Start_Column return Column_Number is
1515       Start_Column : Column_Number := 0;
1516
1517    begin
1518       --  Outer loop scans past horizontal tab characters
1519
1520       Tabs_Loop : loop
1521
1522          --  Inner loop scans past blanks as fast as possible, bumping Scan_Ptr
1523          --  past the blanks and adjusting Start_Column to account for them.
1524
1525          Blanks_Loop : loop
1526             if Source (Scan_Ptr) = ' ' then
1527                if Source (Scan_Ptr + 1) = ' ' then
1528                   if Source (Scan_Ptr + 2) = ' ' then
1529                      if Source (Scan_Ptr + 3) = ' ' then
1530                         if Source (Scan_Ptr + 4) = ' ' then
1531                            if Source (Scan_Ptr + 5) = ' ' then
1532                               if Source (Scan_Ptr + 6) = ' ' then
1533                                  Scan_Ptr := Scan_Ptr + 7;
1534                                  Start_Column := Start_Column + 7;
1535                               else
1536                                  Scan_Ptr := Scan_Ptr + 6;
1537                                  Start_Column := Start_Column + 6;
1538                                  exit Blanks_Loop;
1539                               end if;
1540                            else
1541                               Scan_Ptr := Scan_Ptr + 5;
1542                               Start_Column := Start_Column + 5;
1543                               exit Blanks_Loop;
1544                            end if;
1545                         else
1546                            Scan_Ptr := Scan_Ptr + 4;
1547                            Start_Column := Start_Column + 4;
1548                            exit Blanks_Loop;
1549                         end if;
1550                      else
1551                         Scan_Ptr := Scan_Ptr + 3;
1552                         Start_Column := Start_Column + 3;
1553                         exit Blanks_Loop;
1554                      end if;
1555                   else
1556                      Scan_Ptr := Scan_Ptr + 2;
1557                      Start_Column := Start_Column + 2;
1558                      exit Blanks_Loop;
1559                   end if;
1560                else
1561                   Scan_Ptr := Scan_Ptr + 1;
1562                   Start_Column := Start_Column + 1;
1563                   exit Blanks_Loop;
1564                end if;
1565             else
1566                exit Blanks_Loop;
1567             end if;
1568          end loop Blanks_Loop;
1569
1570          --  Outer loop keeps going only if a horizontal tab follows
1571
1572          if Source (Scan_Ptr) = HT then
1573             if Style_Check then Style.Check_HT; end if;
1574             Scan_Ptr := Scan_Ptr + 1;
1575             Start_Column := (Start_Column / 8) * 8 + 8;
1576          else
1577             exit Tabs_Loop;
1578          end if;
1579
1580       end loop Tabs_Loop;
1581
1582       return Start_Column;
1583    end Set_Start_Column;
1584
1585    ----------
1586    -- Slit --
1587    ----------
1588
1589    procedure Slit is separate;
1590
1591 end Scn;