1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- B U T I L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Opt; use Opt; 27with Output; use Output; 28with Unchecked_Deallocation; 29 30with GNAT; use GNAT; 31 32with System.OS_Lib; use System.OS_Lib; 33 34package body Butil is 35 36 ----------------------- 37 -- Local subprograms -- 38 ----------------------- 39 40 procedure Parse_Next_Unit_Name (Iter : in out Forced_Units_Iterator); 41 -- Parse the name of the next available unit accessible through iterator 42 -- Iter and save it in the iterator. 43 44 function Read_Forced_Elab_Order_File return String_Ptr; 45 -- Read the contents of the forced-elaboration-order file supplied to the 46 -- binder via switch -f and return them as a string. Return null if the 47 -- file is not available. 48 49 -------------- 50 -- Has_Next -- 51 -------------- 52 53 function Has_Next (Iter : Forced_Units_Iterator) return Boolean is 54 begin 55 return Present (Iter.Unit_Name); 56 end Has_Next; 57 58 ---------------------- 59 -- Is_Internal_Unit -- 60 ---------------------- 61 62 -- Note: the reason we do not use the Fname package for this function 63 -- is that it would drag too much junk into the binder. 64 65 function Is_Internal_Unit return Boolean is 66 begin 67 return Is_Predefined_Unit 68 or else (Name_Len > 4 and then (Name_Buffer (1 .. 5) = "gnat%" 69 or else 70 Name_Buffer (1 .. 5) = "gnat.")); 71 end Is_Internal_Unit; 72 73 ------------------------ 74 -- Is_Predefined_Unit -- 75 ------------------------ 76 77 -- Note: the reason we do not use the Fname package for this function 78 -- is that it would drag too much junk into the binder. 79 80 function Is_Predefined_Unit return Boolean is 81 L : Natural renames Name_Len; 82 B : String renames Name_Buffer; 83 begin 84 return (L > 3 and then B (1 .. 4) = "ada.") 85 or else (L > 6 and then B (1 .. 7) = "system.") 86 or else (L > 10 and then B (1 .. 11) = "interfaces.") 87 or else (L > 3 and then B (1 .. 4) = "ada%") 88 or else (L > 8 and then B (1 .. 9) = "calendar%") 89 or else (L > 9 and then B (1 .. 10) = "direct_io%") 90 or else (L > 10 and then B (1 .. 11) = "interfaces%") 91 or else (L > 13 and then B (1 .. 14) = "io_exceptions%") 92 or else (L > 12 and then B (1 .. 13) = "machine_code%") 93 or else (L > 13 and then B (1 .. 14) = "sequential_io%") 94 or else (L > 6 and then B (1 .. 7) = "system%") 95 or else (L > 7 and then B (1 .. 8) = "text_io%") 96 or else (L > 20 and then B (1 .. 21) = "unchecked_conversion%") 97 or else (L > 22 and then B (1 .. 23) = "unchecked_deallocation%") 98 or else (L > 4 and then B (1 .. 5) = "gnat%") 99 or else (L > 4 and then B (1 .. 5) = "gnat."); 100 end Is_Predefined_Unit; 101 102 -------------------------- 103 -- Iterate_Forced_Units -- 104 -------------------------- 105 106 function Iterate_Forced_Units return Forced_Units_Iterator is 107 Iter : Forced_Units_Iterator; 108 109 begin 110 Iter.Order := Read_Forced_Elab_Order_File; 111 Parse_Next_Unit_Name (Iter); 112 113 return Iter; 114 end Iterate_Forced_Units; 115 116 ---------- 117 -- Next -- 118 ---------- 119 120 procedure Next 121 (Iter : in out Forced_Units_Iterator; 122 Unit_Name : out Unit_Name_Type; 123 Unit_Line : out Logical_Line_Number) 124 is 125 begin 126 if not Has_Next (Iter) then 127 raise Iterator_Exhausted; 128 end if; 129 130 Unit_Line := Iter.Unit_Line; 131 Unit_Name := Iter.Unit_Name; 132 pragma Assert (Present (Unit_Name)); 133 134 Parse_Next_Unit_Name (Iter); 135 end Next; 136 137 -------------------------- 138 -- Parse_Next_Unit_Name -- 139 -------------------------- 140 141 procedure Parse_Next_Unit_Name (Iter : in out Forced_Units_Iterator) is 142 Body_Suffix : constant String := " (body)"; 143 Body_Type : constant String := "%b"; 144 Body_Length : constant Positive := Body_Suffix'Length; 145 Body_Offset : constant Natural := Body_Length - 1; 146 147 Comment_Header : constant String := "--"; 148 Comment_Offset : constant Natural := Comment_Header'Length - 1; 149 150 Spec_Suffix : constant String := " (spec)"; 151 Spec_Type : constant String := "%s"; 152 Spec_Length : constant Positive := Spec_Suffix'Length; 153 Spec_Offset : constant Natural := Spec_Length - 1; 154 155 Index : Positive renames Iter.Order_Index; 156 Line : Logical_Line_Number renames Iter.Order_Line; 157 Order : String_Ptr renames Iter.Order; 158 159 function At_Comment return Boolean; 160 pragma Inline (At_Comment); 161 -- Determine whether iterator Iter is positioned over the start of a 162 -- comment. 163 164 function At_Terminator return Boolean; 165 pragma Inline (At_Terminator); 166 -- Determine whether iterator Iter is positioned over a line terminator 167 -- character. 168 169 function At_Whitespace return Boolean; 170 pragma Inline (At_Whitespace); 171 -- Determine whether iterator Iter is positioned over a whitespace 172 -- character. 173 174 function Is_Terminator (C : Character) return Boolean; 175 pragma Inline (Is_Terminator); 176 -- Determine whether character C denotes a line terminator 177 178 function Is_Whitespace (C : Character) return Boolean; 179 pragma Inline (Is_Whitespace); 180 -- Determine whether character C denotes a whitespace 181 182 procedure Parse_Unit_Name; 183 pragma Inline (Parse_Unit_Name); 184 -- Find and parse the first available unit name 185 186 procedure Skip_Comment; 187 pragma Inline (Skip_Comment); 188 -- Skip a comment by reaching a line terminator 189 190 procedure Skip_Terminator; 191 pragma Inline (Skip_Terminator); 192 -- Skip a line terminator and deal with the logical line numbering 193 194 procedure Skip_Whitespace; 195 pragma Inline (Skip_Whitespace); 196 -- Skip whitespace 197 198 function Within_Order 199 (Low_Offset : Natural := 0; 200 High_Offset : Natural := 0) return Boolean; 201 pragma Inline (Within_Order); 202 -- Determine whether index of iterator Iter is still within the range of 203 -- the order string. Low_Offset may be used to inspect the area that is 204 -- less than the index. High_Offset may be used to inspect the area that 205 -- is greater than the index. 206 207 ---------------- 208 -- At_Comment -- 209 ---------------- 210 211 function At_Comment return Boolean is 212 begin 213 -- The interator is over a comment when the index is positioned over 214 -- the start of a comment header. 215 -- 216 -- unit (spec) -- comment 217 -- ^ 218 -- Index 219 220 return 221 Within_Order (High_Offset => Comment_Offset) 222 and then Order (Index .. Index + Comment_Offset) = Comment_Header; 223 end At_Comment; 224 225 ------------------- 226 -- At_Terminator -- 227 ------------------- 228 229 function At_Terminator return Boolean is 230 begin 231 return Within_Order and then Is_Terminator (Order (Index)); 232 end At_Terminator; 233 234 ------------------- 235 -- At_Whitespace -- 236 ------------------- 237 238 function At_Whitespace return Boolean is 239 begin 240 return Within_Order and then Is_Whitespace (Order (Index)); 241 end At_Whitespace; 242 243 ------------------- 244 -- Is_Terminator -- 245 ------------------- 246 247 function Is_Terminator (C : Character) return Boolean is 248 begin 249 -- Carriage return is treated intentionally as whitespace since it 250 -- appears only on certain targets, while line feed is consistent on 251 -- all of them. 252 253 return C = ASCII.LF; 254 end Is_Terminator; 255 256 ------------------- 257 -- Is_Whitespace -- 258 ------------------- 259 260 function Is_Whitespace (C : Character) return Boolean is 261 begin 262 return 263 C = ' ' 264 or else C = ASCII.CR -- carriage return 265 or else C = ASCII.FF -- form feed 266 or else C = ASCII.HT -- horizontal tab 267 or else C = ASCII.VT; -- vertical tab 268 end Is_Whitespace; 269 270 --------------------- 271 -- Parse_Unit_Name -- 272 --------------------- 273 274 procedure Parse_Unit_Name is 275 pragma Assert (not At_Comment); 276 pragma Assert (not At_Terminator); 277 pragma Assert (not At_Whitespace); 278 pragma Assert (Within_Order); 279 280 procedure Find_End_Index_Of_Unit_Name; 281 pragma Inline (Find_End_Index_Of_Unit_Name); 282 -- Position the index of iterator Iter at the last character of the 283 -- first available unit name. 284 285 --------------------------------- 286 -- Find_End_Index_Of_Unit_Name -- 287 --------------------------------- 288 289 procedure Find_End_Index_Of_Unit_Name is 290 begin 291 -- At this point the index points at the start of a unit name. The 292 -- unit name may be legal, in which case it appears as: 293 -- 294 -- unit (body) 295 -- 296 -- However, it may also be illegal: 297 -- 298 -- unit without suffix 299 -- unit with multiple prefixes (spec) 300 -- 301 -- In order to handle both forms, find the construct following the 302 -- unit name. This is either a comment, a terminator, or the end 303 -- of the order: 304 -- 305 -- unit (body) -- comment 306 -- unit without suffix <terminator> 307 -- unit with multiple prefixes (spec)<end of order> 308 -- 309 -- Once the construct is found, truncate the unit name by skipping 310 -- all white space between the construct and the end of the unit 311 -- name. 312 313 -- Find the construct that follows the unit name 314 315 while Within_Order loop 316 if At_Comment then 317 exit; 318 319 elsif At_Terminator then 320 exit; 321 end if; 322 323 Index := Index + 1; 324 end loop; 325 326 -- Position the index prior to the construct that follows the unit 327 -- name. 328 329 Index := Index - 1; 330 331 -- Truncate towards the end of the unit name 332 333 while Within_Order loop 334 if At_Whitespace then 335 Index := Index - 1; 336 else 337 exit; 338 end if; 339 end loop; 340 end Find_End_Index_Of_Unit_Name; 341 342 -- Local variables 343 344 Start_Index : constant Positive := Index; 345 346 End_Index : Positive; 347 Is_Body : Boolean := False; 348 Is_Spec : Boolean := False; 349 350 -- Start of processing for Parse_Unit_Name 351 352 begin 353 Find_End_Index_Of_Unit_Name; 354 End_Index := Index; 355 356 pragma Assert (Start_Index <= End_Index); 357 358 -- At this point the indices are positioned as follows: 359 -- 360 -- End_Index 361 -- Index 362 -- v 363 -- unit (spec) -- comment 364 -- ^ 365 -- Start_Index 366 367 -- Rewind the index, skipping over the legal suffixes 368 -- 369 -- Index End_Index 370 -- v v 371 -- unit (spec) -- comment 372 -- ^ 373 -- Start_Index 374 375 if Within_Order (Low_Offset => Body_Offset) 376 and then Order (Index - Body_Offset .. Index) = Body_Suffix 377 then 378 Is_Body := True; 379 Index := Index - Body_Length; 380 381 elsif Within_Order (Low_Offset => Spec_Offset) 382 and then Order (Index - Spec_Offset .. Index) = Spec_Suffix 383 then 384 Is_Spec := True; 385 Index := Index - Spec_Length; 386 end if; 387 388 -- Capture the line where the unit name is defined 389 390 Iter.Unit_Line := Line; 391 392 -- Transform the unit name to match the format recognized by the 393 -- name table. 394 395 if Is_Body then 396 Iter.Unit_Name := 397 Name_Find (Order (Start_Index .. Index) & Body_Type); 398 399 elsif Is_Spec then 400 Iter.Unit_Name := 401 Name_Find (Order (Start_Index .. Index) & Spec_Type); 402 403 -- Otherwise the unit name is illegal, so leave it as is 404 405 else 406 Iter.Unit_Name := Name_Find (Order (Start_Index .. Index)); 407 end if; 408 409 -- Advance the index past the unit name 410 -- 411 -- End_IndexIndex 412 -- vv 413 -- unit (spec) -- comment 414 -- ^ 415 -- Start_Index 416 417 Index := End_Index + 1; 418 end Parse_Unit_Name; 419 420 ------------------ 421 -- Skip_Comment -- 422 ------------------ 423 424 procedure Skip_Comment is 425 begin 426 pragma Assert (At_Comment); 427 428 while Within_Order loop 429 if At_Terminator then 430 exit; 431 end if; 432 433 Index := Index + 1; 434 end loop; 435 end Skip_Comment; 436 437 --------------------- 438 -- Skip_Terminator -- 439 --------------------- 440 441 procedure Skip_Terminator is 442 begin 443 pragma Assert (At_Terminator); 444 445 Index := Index + 1; 446 Line := Line + 1; 447 end Skip_Terminator; 448 449 --------------------- 450 -- Skip_Whitespace -- 451 --------------------- 452 453 procedure Skip_Whitespace is 454 begin 455 while Within_Order loop 456 if At_Whitespace then 457 Index := Index + 1; 458 else 459 exit; 460 end if; 461 end loop; 462 end Skip_Whitespace; 463 464 ------------------ 465 -- Within_Order -- 466 ------------------ 467 468 function Within_Order 469 (Low_Offset : Natural := 0; 470 High_Offset : Natural := 0) return Boolean 471 is 472 begin 473 return 474 Order /= null 475 and then Index - Low_Offset >= Order'First 476 and then Index + High_Offset <= Order'Last; 477 end Within_Order; 478 479 -- Start of processing for Parse_Next_Unit_Name 480 481 begin 482 -- A line in the forced-elaboration-order file has the following 483 -- grammar: 484 -- 485 -- LINE ::= 486 -- [WHITESPACE] UNIT_NAME [WHITESPACE] [COMMENT] TERMINATOR 487 -- 488 -- WHITESPACE ::= 489 -- <any whitespace character> 490 -- | <carriage return> 491 -- 492 -- UNIT_NAME ::= 493 -- UNIT_PREFIX [WHITESPACE] UNIT_SUFFIX 494 -- 495 -- UNIT_PREFIX ::= 496 -- <any string> 497 -- 498 -- UNIT_SUFFIX ::= 499 -- (body) 500 -- | (spec) 501 -- 502 -- COMMENT ::= 503 -- -- <any string> 504 -- 505 -- TERMINATOR ::= 506 -- <line feed> 507 -- <end of file> 508 -- 509 -- Items in <> brackets are semantic notions 510 511 -- Assume that the order has no remaining units 512 513 Iter.Unit_Line := No_Line_Number; 514 Iter.Unit_Name := No_Unit_Name; 515 516 -- Try to find the first available unit name from the current position 517 -- of iteration. 518 519 while Within_Order loop 520 Skip_Whitespace; 521 522 if At_Comment then 523 Skip_Comment; 524 525 elsif not Within_Order then 526 exit; 527 528 elsif At_Terminator then 529 Skip_Terminator; 530 531 else 532 Parse_Unit_Name; 533 exit; 534 end if; 535 end loop; 536 end Parse_Next_Unit_Name; 537 538 --------------------------------- 539 -- Read_Forced_Elab_Order_File -- 540 --------------------------------- 541 542 function Read_Forced_Elab_Order_File return String_Ptr is 543 procedure Free is new Unchecked_Deallocation (String, String_Ptr); 544 545 Descr : File_Descriptor; 546 Len : Natural; 547 Len_Read : Natural; 548 Result : String_Ptr; 549 Success : Boolean; 550 551 begin 552 if Force_Elab_Order_File = null then 553 return null; 554 end if; 555 556 -- Obtain and sanitize a descriptor to the elaboration-order file 557 558 Descr := Open_Read (Force_Elab_Order_File.all, Binary); 559 560 if Descr = Invalid_FD then 561 return null; 562 end if; 563 564 -- Determine the size of the file, allocate a result large enough to 565 -- house its contents, and read it. 566 567 Len := Natural (File_Length (Descr)); 568 569 if Len = 0 then 570 return null; 571 end if; 572 573 Result := new String (1 .. Len); 574 Len_Read := Read (Descr, Result (1)'Address, Len); 575 576 -- The read failed to acquire the whole content of the file 577 578 if Len_Read /= Len then 579 Free (Result); 580 return null; 581 end if; 582 583 Close (Descr, Success); 584 585 -- The file failed to close 586 587 if not Success then 588 Free (Result); 589 return null; 590 end if; 591 592 return Result; 593 end Read_Forced_Elab_Order_File; 594 595 ---------------- 596 -- Uname_Less -- 597 ---------------- 598 599 function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is 600 begin 601 Get_Name_String (U1); 602 603 declare 604 U1_Name : constant String (1 .. Name_Len) := 605 Name_Buffer (1 .. Name_Len); 606 Min_Length : Natural; 607 608 begin 609 Get_Name_String (U2); 610 611 if Name_Len < U1_Name'Last then 612 Min_Length := Name_Len; 613 else 614 Min_Length := U1_Name'Last; 615 end if; 616 617 for J in 1 .. Min_Length loop 618 if U1_Name (J) > Name_Buffer (J) then 619 return False; 620 elsif U1_Name (J) < Name_Buffer (J) then 621 return True; 622 end if; 623 end loop; 624 625 return U1_Name'Last < Name_Len; 626 end; 627 end Uname_Less; 628 629 --------------------- 630 -- Write_Unit_Name -- 631 --------------------- 632 633 procedure Write_Unit_Name (U : Unit_Name_Type) is 634 begin 635 Get_Name_String (U); 636 Write_Str (Name_Buffer (1 .. Name_Len - 2)); 637 638 if Name_Buffer (Name_Len) = 's' then 639 Write_Str (" (spec)"); 640 else 641 Write_Str (" (body)"); 642 end if; 643 644 Name_Len := Name_Len + 5; 645 end Write_Unit_Name; 646 647end Butil; 648