1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S F N _ S C A N -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2000-2010, 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. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Ada.Exceptions; use Ada.Exceptions; 33 34package body SFN_Scan is 35 36 use ASCII; 37 -- Allow easy access to control character definitions 38 39 EOF : constant Character := ASCII.SUB; 40 -- The character SUB (16#1A#) is used in DOS-derived systems, such as 41 -- Windows to signal the end of a text file. If this character appears as 42 -- the last character of a file scanned by a call to Scan_SFN_Pragmas, then 43 -- it is ignored, otherwise it is treated as an illegal character. 44 45 type String_Ptr is access String; 46 47 S : String_Ptr; 48 -- Points to the gnat.adc input file 49 50 P : Natural; 51 -- Subscript of next character to process in S 52 53 Line_Num : Natural; 54 -- Current line number 55 56 Start_Of_Line : Natural; 57 -- Subscript of first character at start of current line 58 59 ---------------------- 60 -- Local Procedures -- 61 ---------------------- 62 63 function Acquire_Integer return Natural; 64 -- This function skips white space, and then scans and returns 65 -- an unsigned integer. Raises Error if no integer is present 66 -- or if the integer is greater than 999. 67 68 function Acquire_String (B : Natural; E : Natural) return String; 69 -- This function takes a string scanned out by Scan_String, strips 70 -- the enclosing quote characters and any internal doubled quote 71 -- characters, and returns the result as a String. The arguments 72 -- B and E are as returned from a call to Scan_String. The lower 73 -- bound of the string returned is always 1. 74 75 function Acquire_Unit_Name return String; 76 -- Skips white space, and then scans and returns a unit name. The 77 -- unit name is cased exactly as it appears in the source file. 78 -- The terminating character must be white space, or a comma or 79 -- a right parenthesis or end of file. 80 81 function At_EOF return Boolean; 82 pragma Inline (At_EOF); 83 -- Returns True if at end of file, False if not. Note that this 84 -- function does NOT skip white space, so P is always unchanged. 85 86 procedure Check_Not_At_EOF; 87 pragma Inline (Check_Not_At_EOF); 88 -- Skips past white space if any, and then raises Error if at 89 -- end of file. Otherwise returns with P skipped past whitespace. 90 91 function Check_File_Type return Character; 92 -- Skips white space if any, and then looks for any of the tokens 93 -- Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one 94 -- of these is found then the value returned is 's', 'b' or 'u' 95 -- respectively, and P is bumped past the token. If none of 96 -- these tokens is found, then P is unchanged (except for 97 -- possible skip of white space), and a space is returned. 98 99 function Check_Token (T : String) return Boolean; 100 -- Skips white space if any, and then checks if the string at the 101 -- current location matches the given string T, and the character 102 -- immediately following is non-alphabetic, non-numeric. If so, 103 -- P is stepped past the token, and True is returned. If not, 104 -- P is unchanged (except for possibly skipping past whitespace), 105 -- and False is returned. S may contain only lower-case letters 106 -- ('a' .. 'z'). 107 108 procedure Error (Err : String); 109 -- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC 110 -- with a message of the form gnat.adc:line:col: xxx, where xxx is 111 -- the string Err passed as a parameter. 112 113 procedure Require_Token (T : String); 114 -- Skips white space if any, and then requires the given string 115 -- to be present. If it is, the P is stepped past it, otherwise 116 -- Error is raised, since this is a syntax error. Require_Token 117 -- is used only for sequences of special characters, so there 118 -- is no issue of terminators, or casing of letters. 119 120 procedure Scan_String (B : out Natural; E : out Natural); 121 -- Skips white space if any, then requires that a double quote 122 -- or percent be present (start of string). Raises error if 123 -- neither of these two characters is found. Otherwise scans 124 -- out the string, and returns with P pointing past the 125 -- closing quote and S (B .. E) contains the characters of the 126 -- string (including the enclosing quotes, with internal quotes 127 -- still doubled). Raises Error if the string is malformed. 128 129 procedure Skip_WS; 130 -- Skips P past any white space characters (end of line 131 -- characters, spaces, comments, horizontal tab characters). 132 133 --------------------- 134 -- Acquire_Integer -- 135 --------------------- 136 137 function Acquire_Integer return Natural is 138 N : Natural := 0; 139 140 begin 141 Skip_WS; 142 143 if S (P) not in '0' .. '9' then 144 Error ("missing index parameter"); 145 end if; 146 147 while S (P) in '0' .. '9' loop 148 N := N * 10 + Character'Pos (S (P)) - Character'Pos ('0'); 149 150 if N > 999 then 151 Error ("index value greater than 999"); 152 end if; 153 154 P := P + 1; 155 end loop; 156 157 return N; 158 end Acquire_Integer; 159 160 -------------------- 161 -- Acquire_String -- 162 -------------------- 163 164 function Acquire_String (B : Natural; E : Natural) return String is 165 Str : String (1 .. E - B - 1); 166 Q : constant Character := S (B); 167 J : Natural; 168 Ptr : Natural; 169 170 begin 171 Ptr := B + 1; 172 J := 0; 173 while Ptr < E loop 174 J := J + 1; 175 Str (J) := S (Ptr); 176 177 if S (Ptr) = Q and then S (Ptr + 1) = Q then 178 Ptr := Ptr + 2; 179 else 180 Ptr := Ptr + 1; 181 end if; 182 end loop; 183 184 return Str (1 .. J); 185 end Acquire_String; 186 187 ----------------------- 188 -- Acquire_Unit_Name -- 189 ----------------------- 190 191 function Acquire_Unit_Name return String is 192 B : Natural; 193 194 begin 195 Check_Not_At_EOF; 196 B := P; 197 198 while not At_EOF loop 199 exit when S (P) not in '0' .. '9' 200 and then S (P) /= '.' 201 and then S (P) /= '_' 202 and then not (S (P) = '[' and then S (P + 1) = '"') 203 and then not (S (P) = '"' and then S (P - 1) = '[') 204 and then not (S (P) = '"' and then S (P + 1) = ']') 205 and then not (S (P) = ']' and then S (P - 1) = '"') 206 and then S (P) < 'A'; 207 P := P + 1; 208 end loop; 209 210 if P = B then 211 Error ("null unit name"); 212 end if; 213 214 return S (B .. P - 1); 215 end Acquire_Unit_Name; 216 217 ------------ 218 -- At_EOF -- 219 ------------ 220 221 function At_EOF return Boolean is 222 begin 223 -- Immediate return (False) if before last character of file 224 225 if P < S'Last then 226 return False; 227 228 -- Special case: DOS EOF character as last character of file is 229 -- allowed and treated as an end of file. 230 231 elsif P = S'Last then 232 return S (P) = EOF; 233 234 -- If beyond last character of file, then definitely at EOF 235 236 else 237 return True; 238 end if; 239 end At_EOF; 240 241 --------------------- 242 -- Check_File_Type -- 243 --------------------- 244 245 function Check_File_Type return Character is 246 begin 247 if Check_Token ("spec_file_name") then 248 return 's'; 249 elsif Check_Token ("body_file_name") then 250 return 'b'; 251 elsif Check_Token ("subunit_file_name") then 252 return 'u'; 253 else 254 return ' '; 255 end if; 256 end Check_File_Type; 257 258 ---------------------- 259 -- Check_Not_At_EOF -- 260 ---------------------- 261 262 procedure Check_Not_At_EOF is 263 begin 264 Skip_WS; 265 266 if At_EOF then 267 Error ("unexpected end of file"); 268 end if; 269 270 return; 271 end Check_Not_At_EOF; 272 273 ----------------- 274 -- Check_Token -- 275 ----------------- 276 277 function Check_Token (T : String) return Boolean is 278 Save_P : Natural; 279 C : Character; 280 281 begin 282 Skip_WS; 283 Save_P := P; 284 285 for K in T'Range loop 286 if At_EOF then 287 P := Save_P; 288 return False; 289 end if; 290 291 C := S (P); 292 293 if C in 'A' .. 'Z' then 294 C := Character'Val (Character'Pos (C) + 295 (Character'Pos ('a') - Character'Pos ('A'))); 296 end if; 297 298 if C /= T (K) then 299 P := Save_P; 300 return False; 301 end if; 302 303 P := P + 1; 304 end loop; 305 306 if At_EOF then 307 return True; 308 end if; 309 310 C := S (P); 311 312 if C in '0' .. '9' 313 or else C in 'a' .. 'z' 314 or else C in 'A' .. 'Z' 315 or else C > Character'Val (127) 316 then 317 P := Save_P; 318 return False; 319 320 else 321 return True; 322 end if; 323 end Check_Token; 324 325 ----------- 326 -- Error -- 327 ----------- 328 329 procedure Error (Err : String) is 330 C : Natural := 0; 331 -- Column number 332 333 M : String (1 .. 80); 334 -- Buffer used to build resulting error msg 335 336 LM : Natural := 0; 337 -- Pointer to last set location in M 338 339 procedure Add_Nat (N : Natural); 340 -- Add chars of integer to error msg buffer 341 342 ------------- 343 -- Add_Nat -- 344 ------------- 345 346 procedure Add_Nat (N : Natural) is 347 begin 348 if N > 9 then 349 Add_Nat (N / 10); 350 end if; 351 352 LM := LM + 1; 353 M (LM) := Character'Val (N mod 10 + Character'Pos ('0')); 354 end Add_Nat; 355 356 -- Start of processing for Error 357 358 begin 359 M (1 .. 9) := "gnat.adc:"; 360 LM := 9; 361 Add_Nat (Line_Num); 362 LM := LM + 1; 363 M (LM) := ':'; 364 365 -- Determine column number 366 367 for X in Start_Of_Line .. P loop 368 C := C + 1; 369 370 if S (X) = HT then 371 C := (C + 7) / 8 * 8; 372 end if; 373 end loop; 374 375 Add_Nat (C); 376 M (LM + 1) := ':'; 377 LM := LM + 1; 378 M (LM + 1) := ' '; 379 LM := LM + 1; 380 381 M (LM + 1 .. LM + Err'Length) := Err; 382 LM := LM + Err'Length; 383 384 Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM)); 385 end Error; 386 387 ------------------- 388 -- Require_Token -- 389 ------------------- 390 391 procedure Require_Token (T : String) is 392 SaveP : Natural; 393 394 begin 395 Skip_WS; 396 SaveP := P; 397 398 for J in T'Range loop 399 400 if At_EOF or else S (P) /= T (J) then 401 declare 402 S : String (1 .. T'Length + 10); 403 404 begin 405 S (1 .. 9) := "missing """; 406 S (10 .. T'Length + 9) := T; 407 S (T'Length + 10) := '"'; 408 P := SaveP; 409 Error (S); 410 end; 411 412 else 413 P := P + 1; 414 end if; 415 end loop; 416 end Require_Token; 417 418 ---------------------- 419 -- Scan_SFN_Pragmas -- 420 ---------------------- 421 422 procedure Scan_SFN_Pragmas 423 (Source : String; 424 SFN_Ptr : Set_File_Name_Ptr; 425 SFNP_Ptr : Set_File_Name_Pattern_Ptr) 426 is 427 B, E : Natural; 428 Typ : Character; 429 Cas : Character; 430 431 begin 432 Line_Num := 1; 433 S := Source'Unrestricted_Access; 434 P := Source'First; 435 Start_Of_Line := P; 436 437 -- Loop through pragmas in file 438 439 Main_Scan_Loop : loop 440 Skip_WS; 441 exit Main_Scan_Loop when At_EOF; 442 443 -- Error if something other than pragma 444 445 if not Check_Token ("pragma") then 446 Error ("non pragma encountered"); 447 end if; 448 449 -- Source_File_Name pragma case 450 451 if Check_Token ("source_file_name") 452 or else 453 Check_Token ("source_file_name_project") 454 then 455 Require_Token ("("); 456 457 Typ := Check_File_Type; 458 459 -- First format, with unit name first 460 461 if Typ = ' ' then 462 if Check_Token ("unit_name") then 463 Require_Token ("=>"); 464 end if; 465 466 declare 467 U : constant String := Acquire_Unit_Name; 468 469 begin 470 Require_Token (","); 471 Typ := Check_File_Type; 472 473 if Typ /= 's' and then Typ /= 'b' then 474 Error ("bad pragma"); 475 end if; 476 477 Require_Token ("=>"); 478 Scan_String (B, E); 479 480 declare 481 F : constant String := Acquire_String (B, E); 482 X : Natural; 483 484 begin 485 -- Scan Index parameter if present 486 487 if Check_Token (",") then 488 if Check_Token ("index") then 489 Require_Token ("=>"); 490 end if; 491 492 X := Acquire_Integer; 493 else 494 X := 0; 495 end if; 496 497 Require_Token (")"); 498 Require_Token (";"); 499 SFN_Ptr.all (Typ, U, F, X); 500 end; 501 end; 502 503 -- Second format with pattern string 504 505 else 506 Require_Token ("=>"); 507 Scan_String (B, E); 508 509 declare 510 Pat : constant String := Acquire_String (B, E); 511 Nas : Natural := 0; 512 513 begin 514 -- Check exactly one asterisk 515 516 for J in Pat'Range loop 517 if Pat (J) = '*' then 518 Nas := Nas + 1; 519 end if; 520 end loop; 521 522 if Nas /= 1 then 523 Error ("** not allowed"); 524 end if; 525 526 B := 0; 527 E := 0; 528 Cas := ' '; 529 530 -- Loop to scan out Casing or Dot_Replacement parameters 531 532 loop 533 Check_Not_At_EOF; 534 exit when S (P) = ')'; 535 Require_Token (","); 536 537 if Check_Token ("casing") then 538 Require_Token ("=>"); 539 540 if Cas /= ' ' then 541 Error ("duplicate casing argument"); 542 elsif Check_Token ("lowercase") then 543 Cas := 'l'; 544 elsif Check_Token ("uppercase") then 545 Cas := 'u'; 546 elsif Check_Token ("mixedcase") then 547 Cas := 'm'; 548 else 549 Error ("invalid casing argument"); 550 end if; 551 552 elsif Check_Token ("dot_replacement") then 553 Require_Token ("=>"); 554 555 if E /= 0 then 556 Error ("duplicate dot_replacement"); 557 else 558 Scan_String (B, E); 559 end if; 560 561 else 562 Error ("invalid argument"); 563 end if; 564 end loop; 565 566 Require_Token (")"); 567 Require_Token (";"); 568 569 if Cas = ' ' then 570 Cas := 'l'; 571 end if; 572 573 if E = 0 then 574 SFNP_Ptr.all (Pat, Typ, ".", Cas); 575 576 else 577 declare 578 Dot : constant String := Acquire_String (B, E); 579 580 begin 581 SFNP_Ptr.all (Pat, Typ, Dot, Cas); 582 end; 583 end if; 584 end; 585 end if; 586 587 -- Some other pragma, scan to semicolon at end of pragma 588 589 else 590 Skip_Loop : loop 591 exit Main_Scan_Loop when At_EOF; 592 exit Skip_Loop when S (P) = ';'; 593 594 if S (P) = '"' or else S (P) = '%' then 595 Scan_String (B, E); 596 else 597 P := P + 1; 598 end if; 599 end loop Skip_Loop; 600 601 -- We successfully skipped to semicolon, so skip past it 602 603 P := P + 1; 604 end if; 605 end loop Main_Scan_Loop; 606 607 exception 608 when others => 609 Cursor := P - S'First + 1; 610 raise; 611 end Scan_SFN_Pragmas; 612 613 ----------------- 614 -- Scan_String -- 615 ----------------- 616 617 procedure Scan_String (B : out Natural; E : out Natural) is 618 Q : Character; 619 620 begin 621 Check_Not_At_EOF; 622 623 if S (P) = '"' then 624 Q := '"'; 625 elsif S (P) = '%' then 626 Q := '%'; 627 else 628 Error ("bad string"); 629 Q := '"'; 630 end if; 631 632 -- Scan out the string, B points to first char 633 634 B := P; 635 P := P + 1; 636 637 loop 638 if At_EOF or else S (P) = LF or else S (P) = CR then 639 Error -- CODEFIX 640 ("missing string quote"); 641 642 elsif S (P) = HT then 643 Error ("tab character in string"); 644 645 elsif S (P) /= Q then 646 P := P + 1; 647 648 -- We have a quote 649 650 else 651 P := P + 1; 652 653 -- Check for doubled quote 654 655 if not At_EOF and then S (P) = Q then 656 P := P + 1; 657 658 -- Otherwise this is the terminating quote 659 660 else 661 E := P - 1; 662 return; 663 end if; 664 end if; 665 end loop; 666 end Scan_String; 667 668 ------------- 669 -- Skip_WS -- 670 ------------- 671 672 procedure Skip_WS is 673 begin 674 WS_Scan : while not At_EOF loop 675 case S (P) is 676 677 -- End of physical line 678 679 when CR | LF => 680 Line_Num := Line_Num + 1; 681 P := P + 1; 682 683 while not At_EOF 684 and then (S (P) = CR or else S (P) = LF) 685 loop 686 Line_Num := Line_Num + 1; 687 P := P + 1; 688 end loop; 689 690 Start_Of_Line := P; 691 692 -- All other cases of white space characters 693 694 when ' ' | FF | VT | HT => 695 P := P + 1; 696 697 -- Comment 698 699 when '-' => 700 P := P + 1; 701 702 if At_EOF then 703 Error ("bad comment"); 704 705 elsif S (P) = '-' then 706 P := P + 1; 707 708 while not At_EOF loop 709 case S (P) is 710 when CR | LF | FF | VT => 711 exit; 712 when others => 713 P := P + 1; 714 end case; 715 end loop; 716 717 else 718 P := P - 1; 719 exit WS_Scan; 720 end if; 721 722 when others => 723 exit WS_Scan; 724 725 end case; 726 end loop WS_Scan; 727 end Skip_WS; 728 729end SFN_Scan; 730