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