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