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