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-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. -- 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. T may contain only lower-case letters 106 -- ('a' .. 'z'). 107 108 procedure Error (Err : String); 109 pragma No_Return (Error); 110 -- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC 111 -- with a message of the form gnat.adc:line:col: xxx, where xxx is 112 -- the string Err passed as a parameter. 113 114 procedure Require_Token (T : String); 115 -- Skips white space if any, and then requires the given string 116 -- to be present. If it is, the P is stepped past it, otherwise 117 -- Error is raised, since this is a syntax error. Require_Token 118 -- is used only for sequences of special characters, so there 119 -- is no issue of terminators, or casing of letters. 120 121 procedure Scan_String (B : out Natural; E : out Natural); 122 -- Skips white space if any, then requires that a double quote 123 -- or percent be present (start of string). Raises error if 124 -- neither of these two characters is found. Otherwise scans 125 -- out the string, and returns with P pointing past the 126 -- closing quote and S (B .. E) contains the characters of the 127 -- string (including the enclosing quotes, with internal quotes 128 -- still doubled). Raises Error if the string is malformed. 129 130 procedure Skip_WS; 131 -- Skips P past any white space characters (end of line 132 -- characters, spaces, comments, horizontal tab characters). 133 134 --------------------- 135 -- Acquire_Integer -- 136 --------------------- 137 138 function Acquire_Integer return Natural is 139 N : Natural := 0; 140 141 begin 142 Skip_WS; 143 144 if S (P) not in '0' .. '9' then 145 Error ("missing index parameter"); 146 end if; 147 148 while S (P) in '0' .. '9' loop 149 N := N * 10 + Character'Pos (S (P)) - Character'Pos ('0'); 150 151 if N > 999 then 152 Error ("index value greater than 999"); 153 end if; 154 155 P := P + 1; 156 end loop; 157 158 return N; 159 end Acquire_Integer; 160 161 -------------------- 162 -- Acquire_String -- 163 -------------------- 164 165 function Acquire_String (B : Natural; E : Natural) return String is 166 Str : String (1 .. E - B - 1); 167 Q : constant Character := S (B); 168 J : Natural; 169 Ptr : Natural; 170 171 begin 172 Ptr := B + 1; 173 J := 0; 174 while Ptr < E loop 175 J := J + 1; 176 Str (J) := S (Ptr); 177 178 if S (Ptr) = Q and then S (Ptr + 1) = Q then 179 Ptr := Ptr + 2; 180 else 181 Ptr := Ptr + 1; 182 end if; 183 end loop; 184 185 return Str (1 .. J); 186 end Acquire_String; 187 188 ----------------------- 189 -- Acquire_Unit_Name -- 190 ----------------------- 191 192 function Acquire_Unit_Name return String is 193 B : Natural; 194 195 begin 196 Check_Not_At_EOF; 197 B := P; 198 199 while not At_EOF loop 200 exit when S (P) not in '0' .. '9' 201 and then S (P) /= '.' 202 and then S (P) /= '_' 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 not (S (P) = ']' and then S (P - 1) = '"') 207 and then S (P) < 'A'; 208 P := P + 1; 209 end loop; 210 211 if P = B then 212 Error ("null unit name"); 213 end if; 214 215 return S (B .. P - 1); 216 end Acquire_Unit_Name; 217 218 ------------ 219 -- At_EOF -- 220 ------------ 221 222 function At_EOF return Boolean is 223 begin 224 -- Immediate return (False) if before last character of file 225 226 if P < S'Last then 227 return False; 228 229 -- Special case: DOS EOF character as last character of file is 230 -- allowed and treated as an end of file. 231 232 elsif P = S'Last then 233 return S (P) = EOF; 234 235 -- If beyond last character of file, then definitely at EOF 236 237 else 238 return True; 239 end if; 240 end At_EOF; 241 242 --------------------- 243 -- Check_File_Type -- 244 --------------------- 245 246 function Check_File_Type return Character is 247 begin 248 if Check_Token ("spec_file_name") then 249 return 's'; 250 elsif Check_Token ("body_file_name") then 251 return 'b'; 252 elsif Check_Token ("subunit_file_name") then 253 return 'u'; 254 else 255 return ' '; 256 end if; 257 end Check_File_Type; 258 259 ---------------------- 260 -- Check_Not_At_EOF -- 261 ---------------------- 262 263 procedure Check_Not_At_EOF is 264 begin 265 Skip_WS; 266 267 if At_EOF then 268 Error ("unexpected end of file"); 269 end if; 270 271 return; 272 end Check_Not_At_EOF; 273 274 ----------------- 275 -- Check_Token -- 276 ----------------- 277 278 function Check_Token (T : String) return Boolean is 279 Save_P : Natural; 280 C : Character; 281 282 begin 283 Skip_WS; 284 Save_P := P; 285 286 for K in T'Range loop 287 if At_EOF then 288 P := Save_P; 289 return False; 290 end if; 291 292 C := S (P); 293 294 if C in 'A' .. 'Z' then 295 C := Character'Val (Character'Pos (C) + 296 (Character'Pos ('a') - Character'Pos ('A'))); 297 end if; 298 299 if C /= T (K) then 300 P := Save_P; 301 return False; 302 end if; 303 304 P := P + 1; 305 end loop; 306 307 if At_EOF then 308 return True; 309 end if; 310 311 C := S (P); 312 313 if C in '0' .. '9' 314 or else C in 'a' .. 'z' 315 or else C in 'A' .. 'Z' 316 or else C > Character'Val (127) 317 then 318 P := Save_P; 319 return False; 320 321 else 322 return True; 323 end if; 324 end Check_Token; 325 326 ----------- 327 -- Error -- 328 ----------- 329 330 procedure Error (Err : String) is 331 C : Natural := 0; 332 -- Column number 333 334 M : String (1 .. 80); 335 -- Buffer used to build resulting error msg 336 337 LM : Natural := 0; 338 -- Pointer to last set location in M 339 340 procedure Add_Nat (N : Natural); 341 -- Add chars of integer to error msg buffer 342 343 ------------- 344 -- Add_Nat -- 345 ------------- 346 347 procedure Add_Nat (N : Natural) is 348 begin 349 if N > 9 then 350 Add_Nat (N / 10); 351 end if; 352 353 LM := LM + 1; 354 M (LM) := Character'Val (N mod 10 + Character'Pos ('0')); 355 end Add_Nat; 356 357 -- Start of processing for Error 358 359 begin 360 M (1 .. 9) := "gnat.adc:"; 361 LM := 9; 362 Add_Nat (Line_Num); 363 LM := LM + 1; 364 M (LM) := ':'; 365 366 -- Determine column number 367 368 for X in Start_Of_Line .. P loop 369 C := C + 1; 370 371 if S (X) = HT then 372 C := (C + 7) / 8 * 8; 373 end if; 374 end loop; 375 376 Add_Nat (C); 377 M (LM + 1) := ':'; 378 LM := LM + 1; 379 M (LM + 1) := ' '; 380 LM := LM + 1; 381 382 M (LM + 1 .. LM + Err'Length) := Err; 383 LM := LM + Err'Length; 384 385 Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM)); 386 end Error; 387 388 ------------------- 389 -- Require_Token -- 390 ------------------- 391 392 procedure Require_Token (T : String) is 393 SaveP : Natural; 394 395 begin 396 Skip_WS; 397 SaveP := P; 398 399 for J in T'Range loop 400 401 if At_EOF or else S (P) /= T (J) then 402 declare 403 S : String (1 .. T'Length + 10); 404 405 begin 406 S (1 .. 9) := "missing """; 407 S (10 .. T'Length + 9) := T; 408 S (T'Length + 10) := '"'; 409 P := SaveP; 410 Error (S); 411 end; 412 413 else 414 P := P + 1; 415 end if; 416 end loop; 417 end Require_Token; 418 419 ---------------------- 420 -- Scan_SFN_Pragmas -- 421 ---------------------- 422 423 procedure Scan_SFN_Pragmas 424 (Source : String; 425 SFN_Ptr : Set_File_Name_Ptr; 426 SFNP_Ptr : Set_File_Name_Pattern_Ptr) 427 is 428 B, E : Natural; 429 Typ : Character; 430 Cas : Character; 431 432 begin 433 Line_Num := 1; 434 S := Source'Unrestricted_Access; 435 P := Source'First; 436 Start_Of_Line := P; 437 438 -- Loop through pragmas in file 439 440 Main_Scan_Loop : loop 441 Skip_WS; 442 exit Main_Scan_Loop when At_EOF; 443 444 -- Error if something other than pragma 445 446 if not Check_Token ("pragma") then 447 Error ("non pragma encountered"); 448 end if; 449 450 -- Source_File_Name pragma case 451 452 if Check_Token ("source_file_name") 453 or else 454 Check_Token ("source_file_name_project") 455 then 456 Require_Token ("("); 457 458 Typ := Check_File_Type; 459 460 -- First format, with unit name first 461 462 if Typ = ' ' then 463 if Check_Token ("unit_name") then 464 Require_Token ("=>"); 465 end if; 466 467 declare 468 U : constant String := Acquire_Unit_Name; 469 470 begin 471 Require_Token (","); 472 Typ := Check_File_Type; 473 474 if Typ /= 's' and then Typ /= 'b' then 475 Error ("bad pragma"); 476 end if; 477 478 Require_Token ("=>"); 479 Scan_String (B, E); 480 481 declare 482 F : constant String := Acquire_String (B, E); 483 X : Natural; 484 485 begin 486 -- Scan Index parameter if present 487 488 if Check_Token (",") then 489 if Check_Token ("index") then 490 Require_Token ("=>"); 491 end if; 492 493 X := Acquire_Integer; 494 else 495 X := 0; 496 end if; 497 498 Require_Token (")"); 499 Require_Token (";"); 500 SFN_Ptr.all (Typ, U, F, X); 501 end; 502 end; 503 504 -- Second format with pattern string 505 506 else 507 Require_Token ("=>"); 508 Scan_String (B, E); 509 510 declare 511 Pat : constant String := Acquire_String (B, E); 512 Nas : Natural := 0; 513 514 begin 515 -- Check exactly one asterisk 516 517 for J in Pat'Range loop 518 if Pat (J) = '*' then 519 Nas := Nas + 1; 520 end if; 521 end loop; 522 523 if Nas /= 1 then 524 Error ("** not allowed"); 525 end if; 526 527 B := 0; 528 E := 0; 529 Cas := ' '; 530 531 -- Loop to scan out Casing or Dot_Replacement parameters 532 533 loop 534 Check_Not_At_EOF; 535 exit when S (P) = ')'; 536 Require_Token (","); 537 538 if Check_Token ("casing") then 539 Require_Token ("=>"); 540 541 if Cas /= ' ' then 542 Error ("duplicate casing argument"); 543 elsif Check_Token ("lowercase") then 544 Cas := 'l'; 545 elsif Check_Token ("uppercase") then 546 Cas := 'u'; 547 elsif Check_Token ("mixedcase") then 548 Cas := 'm'; 549 else 550 Error ("invalid casing argument"); 551 end if; 552 553 elsif Check_Token ("dot_replacement") then 554 Require_Token ("=>"); 555 556 if E /= 0 then 557 Error ("duplicate dot_replacement"); 558 else 559 Scan_String (B, E); 560 end if; 561 562 else 563 Error ("invalid argument"); 564 end if; 565 end loop; 566 567 Require_Token (")"); 568 Require_Token (";"); 569 570 if Cas = ' ' then 571 Cas := 'l'; 572 end if; 573 574 if E = 0 then 575 SFNP_Ptr.all (Pat, Typ, ".", Cas); 576 577 else 578 declare 579 Dot : constant String := Acquire_String (B, E); 580 581 begin 582 SFNP_Ptr.all (Pat, Typ, Dot, Cas); 583 end; 584 end if; 585 end; 586 end if; 587 588 -- Some other pragma, scan to semicolon at end of pragma 589 590 else 591 Skip_Loop : loop 592 exit Main_Scan_Loop when At_EOF; 593 exit Skip_Loop when S (P) = ';'; 594 595 if S (P) = '"' or else S (P) = '%' then 596 Scan_String (B, E); 597 else 598 P := P + 1; 599 end if; 600 end loop Skip_Loop; 601 602 -- We successfully skipped to semicolon, so skip past it 603 604 P := P + 1; 605 end if; 606 end loop Main_Scan_Loop; 607 608 exception 609 when others => 610 Cursor := P - S'First + 1; 611 raise; 612 end Scan_SFN_Pragmas; 613 614 ----------------- 615 -- Scan_String -- 616 ----------------- 617 618 procedure Scan_String (B : out Natural; E : out Natural) is 619 Q : Character; 620 621 begin 622 Check_Not_At_EOF; 623 624 if S (P) = '"' then 625 Q := '"'; 626 elsif S (P) = '%' then 627 Q := '%'; 628 else 629 Error ("bad string"); 630 Q := '"'; 631 end if; 632 633 -- Scan out the string, B points to first char 634 635 B := P; 636 P := P + 1; 637 638 loop 639 if At_EOF or else S (P) = LF or else S (P) = CR then 640 Error -- CODEFIX 641 ("missing string quote"); 642 643 elsif S (P) = HT then 644 Error ("tab character in string"); 645 646 elsif S (P) /= Q then 647 P := P + 1; 648 649 -- We have a quote 650 651 else 652 P := P + 1; 653 654 -- Check for doubled quote 655 656 if not At_EOF and then S (P) = Q then 657 P := P + 1; 658 659 -- Otherwise this is the terminating quote 660 661 else 662 E := P - 1; 663 return; 664 end if; 665 end if; 666 end loop; 667 end Scan_String; 668 669 ------------- 670 -- Skip_WS -- 671 ------------- 672 673 procedure Skip_WS is 674 begin 675 WS_Scan : while not At_EOF loop 676 case S (P) is 677 678 -- End of physical line 679 680 when CR | LF => 681 Line_Num := Line_Num + 1; 682 P := P + 1; 683 684 while not At_EOF 685 and then (S (P) = CR or else S (P) = LF) 686 loop 687 Line_Num := Line_Num + 1; 688 P := P + 1; 689 end loop; 690 691 Start_Of_Line := P; 692 693 -- All other cases of white space characters 694 695 when ' ' | FF | VT | HT => 696 P := P + 1; 697 698 -- Comment 699 700 when '-' => 701 P := P + 1; 702 703 if At_EOF then 704 Error ("bad comment"); 705 706 elsif S (P) = '-' then 707 P := P + 1; 708 709 while not At_EOF loop 710 case S (P) is 711 when CR | LF | FF | VT => 712 exit; 713 when others => 714 P := P + 1; 715 end case; 716 end loop; 717 718 else 719 P := P - 1; 720 exit WS_Scan; 721 end if; 722 723 when others => 724 exit WS_Scan; 725 726 end case; 727 end loop WS_Scan; 728 end Skip_WS; 729 730end SFN_Scan; 731