1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- L I B . W R I T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with ALI; use ALI; 27with Atree; use Atree; 28with Casing; use Casing; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Errout; use Errout; 32with Fname; use Fname; 33with Fname.UF; use Fname.UF; 34with Lib.Util; use Lib.Util; 35with Lib.Xref; use Lib.Xref; 36with Nlists; use Nlists; 37with Gnatvsn; use Gnatvsn; 38with Opt; use Opt; 39with Osint; use Osint; 40with Osint.C; use Osint.C; 41with Output; use Output; 42with Par; 43with Par_SCO; use Par_SCO; 44with Restrict; use Restrict; 45with Rident; use Rident; 46with Stand; use Stand; 47with Scn; use Scn; 48with Sem_Eval; use Sem_Eval; 49with Sinfo; use Sinfo; 50with Sinput; use Sinput; 51with Snames; use Snames; 52with Stringt; use Stringt; 53with Tbuild; use Tbuild; 54with Uname; use Uname; 55 56with System.Case_Util; use System.Case_Util; 57with System.WCh_Con; use System.WCh_Con; 58 59package body Lib.Writ is 60 61 ----------------------- 62 -- Local Subprograms -- 63 ----------------------- 64 65 procedure Write_Unit_Name (N : Node_Id); 66 -- Used to write out the unit name for R (pragma Restriction) lines 67 -- for uses of Restriction (No_Dependence => unit-name). 68 69 ---------------------------------- 70 -- Add_Preprocessing_Dependency -- 71 ---------------------------------- 72 73 procedure Add_Preprocessing_Dependency (S : Source_File_Index) is 74 begin 75 Units.Increment_Last; 76 Units.Table (Units.Last) := 77 (Unit_File_Name => File_Name (S), 78 Unit_Name => No_Unit_Name, 79 Expected_Unit => No_Unit_Name, 80 Source_Index => S, 81 Cunit => Empty, 82 Cunit_Entity => Empty, 83 Dependency_Num => 0, 84 Dynamic_Elab => False, 85 Fatal_Error => None, 86 Generate_Code => False, 87 Has_RACW => False, 88 Filler => False, 89 Ident_String => Empty, 90 Is_Predefined_Renaming => False, 91 Is_Internal_Unit => False, 92 Is_Predefined_Unit => False, 93 Filler2 => False, 94 Loading => False, 95 Main_Priority => -1, 96 Main_CPU => -1, 97 Munit_Index => 0, 98 No_Elab_Code_All => False, 99 Primary_Stack_Count => 0, 100 Sec_Stack_Count => 0, 101 Serial_Number => 0, 102 Version => 0, 103 Error_Location => No_Location, 104 OA_Setting => 'O'); 105 end Add_Preprocessing_Dependency; 106 107 ------------------------------ 108 -- Ensure_System_Dependency -- 109 ------------------------------ 110 111 procedure Ensure_System_Dependency is 112 System_Uname : Unit_Name_Type; 113 -- Unit name for system spec if needed for dummy entry 114 115 System_Fname : File_Name_Type; 116 -- File name for system spec if needed for dummy entry 117 118 begin 119 -- Nothing to do if we already compiled System 120 121 for Unum in Units.First .. Last_Unit loop 122 if Units.Table (Unum).Source_Index = System_Source_File_Index then 123 return; 124 end if; 125 end loop; 126 127 -- If no entry for system.ads in the units table, then add a entry 128 -- to the units table for system.ads, which will be referenced when 129 -- the ali file is generated. We need this because every unit depends 130 -- on system as a result of Targparm scanning the system.ads file to 131 -- determine the target dependent parameters for the compilation. 132 133 Name_Len := 6; 134 Name_Buffer (1 .. 6) := "system"; 135 System_Uname := Name_To_Unit_Name (Name_Enter); 136 System_Fname := File_Name (System_Source_File_Index); 137 138 Units.Increment_Last; 139 Units.Table (Units.Last) := 140 (Unit_File_Name => System_Fname, 141 Unit_Name => System_Uname, 142 Expected_Unit => System_Uname, 143 Source_Index => System_Source_File_Index, 144 Cunit => Empty, 145 Cunit_Entity => Empty, 146 Dependency_Num => 0, 147 Dynamic_Elab => False, 148 Fatal_Error => None, 149 Generate_Code => False, 150 Has_RACW => False, 151 Filler => False, 152 Ident_String => Empty, 153 Is_Predefined_Renaming => False, 154 Is_Internal_Unit => True, 155 Is_Predefined_Unit => True, 156 Filler2 => False, 157 Loading => False, 158 Main_Priority => -1, 159 Main_CPU => -1, 160 Munit_Index => 0, 161 No_Elab_Code_All => False, 162 Primary_Stack_Count => 0, 163 Sec_Stack_Count => 0, 164 Serial_Number => 0, 165 Version => 0, 166 Error_Location => No_Location, 167 OA_Setting => 'O'); 168 169 -- Parse system.ads so that the checksum is set right. Style checks are 170 -- not applied. The Ekind is set to ensure that this reference is always 171 -- present in the ali file. 172 173 declare 174 Save_Mindex : constant Nat := Multiple_Unit_Index; 175 Save_Style : constant Boolean := Style_Check; 176 begin 177 Multiple_Unit_Index := 0; 178 Style_Check := False; 179 Initialize_Scanner (Units.Last, System_Source_File_Index); 180 Discard_List (Par (Configuration_Pragmas => False)); 181 Set_Ekind (Cunit_Entity (Units.Last), E_Package); 182 Set_Scope (Cunit_Entity (Units.Last), Standard_Standard); 183 Style_Check := Save_Style; 184 Multiple_Unit_Index := Save_Mindex; 185 end; 186 end Ensure_System_Dependency; 187 188 --------------- 189 -- Write_ALI -- 190 --------------- 191 192 procedure Write_ALI (Object : Boolean) is 193 194 ---------------- 195 -- Local Data -- 196 ---------------- 197 198 Last_Unit : constant Unit_Number_Type := Units.Last; 199 -- Record unit number of last unit. We capture this in case we 200 -- have to add a dummy entry to the unit table for package System. 201 202 With_Flags : array (Units.First .. Last_Unit) of Boolean; 203 -- Array of flags to show which units are with'ed 204 205 Elab_Flags : array (Units.First .. Last_Unit) of Boolean; 206 -- Array of flags to show which units have pragma Elaborate set 207 208 Elab_All_Flags : array (Units.First .. Last_Unit) of Boolean; 209 -- Array of flags to show which units have pragma Elaborate All set 210 211 Elab_Des_Flags : array (Units.First .. Last_Unit) of Boolean; 212 -- Array of flags to show which units have Elaborate_Desirable set 213 214 Elab_All_Des_Flags : array (Units.First .. Last_Unit) of Boolean; 215 -- Array of flags to show which units have Elaborate_All_Desirable set 216 217 type Yes_No is (Unknown, Yes, No); 218 Has_Implicit_With : array (Units.First .. Last_Unit) of Yes_No; 219 -- Indicates if an implicit with has been given for the unit. Yes if 220 -- certainly present, No if certainly absent, Unknown if not known. 221 222 Sdep_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 2)); 223 -- Sorted table of source dependencies. One extra entry in case we 224 -- have to add a dummy entry for System. 225 226 Num_Sdep : Nat := 0; 227 -- Number of active entries in Sdep_Table 228 229 ----------------------- 230 -- Local Subprograms -- 231 ----------------------- 232 233 procedure Collect_Withs (Cunit : Node_Id); 234 -- Collect with lines for entries in the context clause of the given 235 -- compilation unit, Cunit. 236 237 procedure Update_Tables_From_ALI_File; 238 -- Given an up to date ALI file (see Up_To_Date_ALI_file_Exists 239 -- function), update tables from the ALI information, including 240 -- specifically the Compilation_Switches table. 241 242 function Up_To_Date_ALI_File_Exists return Boolean; 243 -- If there exists an ALI file that is up to date, then this function 244 -- initializes the tables in the ALI spec to contain information on 245 -- this file (using Scan_ALI) and returns True. If no file exists, 246 -- or the file is not up to date, then False is returned. 247 248 procedure Write_Unit_Information (Unit_Num : Unit_Number_Type); 249 -- Write out the library information for one unit for which code is 250 -- generated (includes unit line and with lines). 251 252 procedure Write_With_Lines; 253 -- Write out with lines collected by calls to Collect_Withs 254 255 ------------------- 256 -- Collect_Withs -- 257 ------------------- 258 259 procedure Collect_Withs (Cunit : Node_Id) is 260 function Is_Implicit_With_Clause (Clause : Node_Id) return Boolean; 261 pragma Inline (Is_Implicit_With_Clause); 262 -- Determine whether a with clause denoted by Clause is implicit 263 264 ----------------------------- 265 -- Is_Implicit_With_Clause -- 266 ----------------------------- 267 268 function Is_Implicit_With_Clause (Clause : Node_Id) return Boolean is 269 begin 270 -- With clauses created for ancestor units are marked as internal, 271 -- however, they emulate the semantics in Ada RM 10.1.2 (6/2), 272 -- where 273 -- 274 -- with A.B; 275 -- 276 -- is almost equivalent to 277 -- 278 -- with A; 279 -- with A.B; 280 -- 281 -- For ALI encoding purposes, they are considered to be explicit. 282 -- Note that the clauses cannot be marked as explicit because they 283 -- will be subjected to various checks related to with clauses and 284 -- possibly cause false positives. 285 286 if Parent_With (Clause) then 287 return False; 288 289 else 290 return Implicit_With (Clause); 291 end if; 292 end Is_Implicit_With_Clause; 293 294 -- Local variables 295 296 Item : Node_Id; 297 Unum : Unit_Number_Type; 298 299 -- Start of processing for Collect_Withs 300 301 begin 302 Item := First (Context_Items (Cunit)); 303 while Present (Item) loop 304 305 -- Process with clause 306 307 -- Ada 2005 (AI-50217): limited with_clauses do not create 308 -- dependencies, but must be recorded as components of the 309 -- partition, in case there is no regular with_clause for 310 -- the unit anywhere else. 311 312 if Nkind (Item) = N_With_Clause then 313 Unum := Get_Cunit_Unit_Number (Library_Unit (Item)); 314 With_Flags (Unum) := True; 315 316 if not Limited_Present (Item) then 317 if Elaborate_Present (Item) then 318 Elab_Flags (Unum) := True; 319 end if; 320 321 if Elaborate_All_Present (Item) then 322 Elab_All_Flags (Unum) := True; 323 end if; 324 325 if Elaborate_All_Desirable (Item) then 326 Elab_All_Des_Flags (Unum) := True; 327 end if; 328 329 if Elaborate_Desirable (Item) then 330 Elab_Des_Flags (Unum) := True; 331 end if; 332 333 else 334 Set_From_Limited_With (Cunit_Entity (Unum)); 335 end if; 336 337 if Is_Implicit_With_Clause (Item) then 338 339 -- A previous explicit with clause withs the unit. Retain 340 -- this classification, as it reflects the source relations 341 -- between units. 342 343 if Has_Implicit_With (Unum) = No then 344 null; 345 346 -- Otherwise this is either the first time any clause withs 347 -- the unit, or the unit is already implicitly withed. 348 349 else 350 Has_Implicit_With (Unum) := Yes; 351 end if; 352 353 -- Otherwise the current with clause is explicit. Such clauses 354 -- take precedence over existing implicit clauses because they 355 -- reflect the source relations between unit. 356 357 else 358 Has_Implicit_With (Unum) := No; 359 end if; 360 end if; 361 362 Next (Item); 363 end loop; 364 end Collect_Withs; 365 366 -------------------------------- 367 -- Up_To_Date_ALI_File_Exists -- 368 -------------------------------- 369 370 function Up_To_Date_ALI_File_Exists return Boolean is 371 Name : File_Name_Type; 372 Text : Text_Buffer_Ptr; 373 Id : Sdep_Id; 374 Sind : Source_File_Index; 375 376 begin 377 Opt.Check_Object_Consistency := True; 378 Read_Library_Info (Name, Text); 379 380 -- Return if we could not find an ALI file 381 382 if Text = null then 383 return False; 384 end if; 385 386 -- Return if ALI file has bad format 387 388 Initialize_ALI; 389 390 if Scan_ALI (Name, Text, False, Err => True) = No_ALI_Id then 391 return False; 392 end if; 393 394 -- If we have an OK ALI file, check if it is up to date 395 -- Note that we assume that the ALI read has all the entries 396 -- we have in our table, plus some additional ones (that can 397 -- come from expansion). 398 399 Id := First_Sdep_Entry; 400 for J in 1 .. Num_Sdep loop 401 Sind := Units.Table (Sdep_Table (J)).Source_Index; 402 403 while Sdep.Table (Id).Sfile /= File_Name (Sind) loop 404 if Id = Sdep.Last then 405 return False; 406 else 407 Id := Id + 1; 408 end if; 409 end loop; 410 411 if Sdep.Table (Id).Stamp /= Time_Stamp (Sind) then 412 return False; 413 end if; 414 end loop; 415 416 return True; 417 end Up_To_Date_ALI_File_Exists; 418 419 --------------------------------- 420 -- Update_Tables_From_ALI_File -- 421 --------------------------------- 422 423 procedure Update_Tables_From_ALI_File is 424 begin 425 -- Build Compilation_Switches table 426 427 Compilation_Switches.Init; 428 429 for J in First_Arg_Entry .. Args.Last loop 430 Compilation_Switches.Increment_Last; 431 Compilation_Switches.Table (Compilation_Switches.Last) := 432 Args.Table (J); 433 end loop; 434 end Update_Tables_From_ALI_File; 435 436 ---------------------------- 437 -- Write_Unit_Information -- 438 ---------------------------- 439 440 procedure Write_Unit_Information (Unit_Num : Unit_Number_Type) is 441 Unode : constant Node_Id := Cunit (Unit_Num); 442 Ukind : constant Node_Kind := Nkind (Unit (Unode)); 443 Uent : constant Entity_Id := Cunit_Entity (Unit_Num); 444 Pnode : Node_Id; 445 446 begin 447 Write_Info_Initiate ('U'); 448 Write_Info_Char (' '); 449 Write_Info_Name (Unit_Name (Unit_Num)); 450 Write_Info_Tab (25); 451 Write_Info_Name (Unit_File_Name (Unit_Num)); 452 453 Write_Info_Tab (49); 454 Write_Info_Str (Version_Get (Unit_Num)); 455 456 -- Add BD parameter if Elaborate_Body pragma desirable 457 458 if Ekind (Uent) = E_Package 459 and then Elaborate_Body_Desirable (Uent) 460 then 461 Write_Info_Str (" BD"); 462 end if; 463 464 -- Add BN parameter if body needed for SAL 465 466 if (Is_Subprogram (Uent) 467 or else Ekind (Uent) = E_Package 468 or else Is_Generic_Unit (Uent)) 469 and then Body_Needed_For_SAL (Uent) 470 then 471 Write_Info_Str (" BN"); 472 end if; 473 474 if Dynamic_Elab (Unit_Num) then 475 Write_Info_Str (" DE"); 476 end if; 477 478 -- Set the Elaborate_Body indication if either an explicit pragma 479 -- was present, or if this is an instantiation. 480 481 if Has_Pragma_Elaborate_Body (Uent) 482 or else (Ukind = N_Package_Declaration 483 and then Is_Generic_Instance (Uent) 484 and then Present (Corresponding_Body (Unit (Unode)))) 485 then 486 Write_Info_Str (" EB"); 487 end if; 488 489 -- Now see if we should tell the binder that an elaboration entity 490 -- is present, which must be set to true during elaboration. 491 -- We generate the indication if the following condition is met: 492 493 -- If this is a spec ... 494 495 if (Is_Subprogram (Uent) 496 or else Ekind (Uent) = E_Package 497 or else Is_Generic_Unit (Uent)) 498 499 -- and an elaboration entity was declared ... 500 501 and then Present (Elaboration_Entity (Uent)) 502 503 -- and either the elaboration flag is required ... 504 505 and then (Elaboration_Entity_Required (Uent) 506 507 -- or this unit has elaboration code ... 508 509 or else not Has_No_Elaboration_Code (Unode) 510 511 -- or this unit has a separate body and this 512 -- body has elaboration code. 513 514 or else 515 (Ekind (Uent) = E_Package 516 and then Present (Body_Entity (Uent)) 517 and then 518 not Has_No_Elaboration_Code 519 (Parent (Declaration_Node (Body_Entity (Uent)))))) 520 then 521 Write_Info_Str (" EE"); 522 end if; 523 524 if Has_No_Elaboration_Code (Unode) then 525 Write_Info_Str (" NE"); 526 end if; 527 528 Write_Info_Str (" O"); 529 Write_Info_Char (OA_Setting (Unit_Num)); 530 531 if Ekind_In (Uent, E_Package, E_Package_Body) 532 and then Present (Finalizer (Uent)) 533 then 534 Write_Info_Str (" PF"); 535 end if; 536 537 if Is_Preelaborated (Uent) then 538 Write_Info_Str (" PR"); 539 end if; 540 541 if Is_Pure (Uent) then 542 Write_Info_Str (" PU"); 543 end if; 544 545 if Has_RACW (Unit_Num) then 546 Write_Info_Str (" RA"); 547 end if; 548 549 if Is_Remote_Call_Interface (Uent) then 550 Write_Info_Str (" RC"); 551 end if; 552 553 if Is_Remote_Types (Uent) then 554 Write_Info_Str (" RT"); 555 end if; 556 557 if Serious_Errors_Detected /= 0 then 558 Write_Info_Str (" SE"); 559 end if; 560 561 if Is_Shared_Passive (Uent) then 562 Write_Info_Str (" SP"); 563 end if; 564 565 if Ukind = N_Subprogram_Declaration 566 or else Ukind = N_Subprogram_Body 567 then 568 Write_Info_Str (" SU"); 569 570 elsif Ukind = N_Package_Declaration 571 or else 572 Ukind = N_Package_Body 573 then 574 -- If this is a wrapper package for a subprogram instantiation, 575 -- the user view is the subprogram. Note that in this case the 576 -- ali file contains both the spec and body of the instance. 577 578 if Is_Wrapper_Package (Uent) then 579 Write_Info_Str (" SU"); 580 else 581 Write_Info_Str (" PK"); 582 end if; 583 584 elsif Ukind = N_Generic_Package_Declaration then 585 Write_Info_Str (" PK"); 586 587 end if; 588 589 if Ukind in N_Generic_Declaration 590 or else 591 (Present (Library_Unit (Unode)) 592 and then 593 Nkind (Unit (Library_Unit (Unode))) in N_Generic_Declaration) 594 then 595 Write_Info_Str (" GE"); 596 end if; 597 598 if not Is_Internal_Unit (Unit_Num) then 599 case Identifier_Casing (Source_Index (Unit_Num)) is 600 when All_Lower_Case => Write_Info_Str (" IL"); 601 when All_Upper_Case => Write_Info_Str (" IU"); 602 when others => null; 603 end case; 604 605 case Keyword_Casing (Source_Index (Unit_Num)) is 606 when Mixed_Case => Write_Info_Str (" KM"); 607 when All_Upper_Case => Write_Info_Str (" KU"); 608 when others => null; 609 end case; 610 end if; 611 612 if Initialize_Scalars or else Invalid_Value_Used then 613 Write_Info_Str (" IS"); 614 end if; 615 616 Write_Info_EOL; 617 618 -- Generate with lines, first those that are directly with'ed 619 620 for J in With_Flags'Range loop 621 With_Flags (J) := False; 622 Elab_Flags (J) := False; 623 Elab_All_Flags (J) := False; 624 Elab_Des_Flags (J) := False; 625 Elab_All_Des_Flags (J) := False; 626 Has_Implicit_With (J) := Unknown; 627 end loop; 628 629 Collect_Withs (Unode); 630 631 -- For a body, we must also check for any subunits which belong to 632 -- it and which have context clauses of their own, since these 633 -- with'ed units are part of its own elaboration dependencies. 634 635 if Nkind (Unit (Unode)) in N_Unit_Body then 636 for S in Units.First .. Last_Unit loop 637 638 -- We are only interested in subunits. For preproc. data and 639 -- def. files, Cunit is Empty, so we need to test that first. 640 641 if Cunit (S) /= Empty 642 and then Nkind (Unit (Cunit (S))) = N_Subunit 643 then 644 Pnode := Library_Unit (Cunit (S)); 645 646 -- In gnatc mode, the errors in the subunits will not have 647 -- been recorded, but the analysis of the subunit may have 648 -- failed. There is no information to add to ALI file in 649 -- this case. 650 651 if No (Pnode) then 652 exit; 653 end if; 654 655 -- Find ultimate parent of the subunit 656 657 while Nkind (Unit (Pnode)) = N_Subunit loop 658 Pnode := Library_Unit (Pnode); 659 end loop; 660 661 -- See if it belongs to current unit, and if so, include 662 -- its with_clauses. 663 664 if Pnode = Unode then 665 Collect_Withs (Cunit (S)); 666 end if; 667 end if; 668 end loop; 669 end if; 670 671 Write_With_Lines; 672 673 -- Generate task stack lines 674 675 if Primary_Stack_Count (Unit_Num) > 0 676 or else Sec_Stack_Count (Unit_Num) > 0 677 then 678 Write_Info_Initiate ('T'); 679 Write_Info_Char (' '); 680 Write_Info_Int (Primary_Stack_Count (Unit_Num)); 681 Write_Info_Char (' '); 682 Write_Info_Int (Sec_Stack_Count (Unit_Num)); 683 Write_Info_EOL; 684 end if; 685 686 -- Generate the linker option lines 687 688 for J in 1 .. Linker_Option_Lines.Last loop 689 690 -- Pragma Linker_Options is not allowed in predefined generic 691 -- units. This is because they won't be read, due to the fact that 692 -- with lines for generic units lack the file name and lib name 693 -- parameters (see Lib_Writ spec for an explanation). 694 695 if Is_Generic_Unit (Cunit_Entity (Main_Unit)) 696 and then Is_Predefined_Unit (Current_Sem_Unit) 697 and then Linker_Option_Lines.Table (J).Unit = Unit_Num 698 then 699 Set_Standard_Error; 700 Write_Line 701 ("linker options not allowed in predefined generic unit"); 702 raise Unrecoverable_Error; 703 end if; 704 705 -- Output one linker option line 706 707 declare 708 S : Linker_Option_Entry renames Linker_Option_Lines.Table (J); 709 begin 710 if S.Unit = Unit_Num then 711 Write_Info_Initiate ('L'); 712 Write_Info_Char (' '); 713 Write_Info_Slit (S.Option); 714 Write_Info_EOL; 715 end if; 716 end; 717 end loop; 718 719 -- Output notes 720 721 for J in 1 .. Notes.Last loop 722 declare 723 N : constant Node_Id := Notes.Table (J); 724 L : constant Source_Ptr := Sloc (N); 725 U : constant Unit_Number_Type := 726 Unit (Get_Source_File_Index (L)); 727 C : Character; 728 729 Note_Unit : Unit_Number_Type; 730 -- The unit in whose U section this note must be emitted: 731 -- notes for subunits are emitted along with the main unit; 732 -- all other notes are emitted as part of the enclosing 733 -- compilation unit. 734 735 begin 736 if U /= No_Unit and then Nkind (Unit (Cunit (U))) = N_Subunit 737 then 738 Note_Unit := Main_Unit; 739 else 740 Note_Unit := U; 741 end if; 742 743 -- No action needed for pragmas removed by the expander (for 744 -- example, pragmas of ignored ghost entities). 745 746 if Nkind (N) = N_Null_Statement then 747 pragma Assert (Nkind (Original_Node (N)) = N_Pragma); 748 null; 749 750 elsif Note_Unit = Unit_Num then 751 Write_Info_Initiate ('N'); 752 Write_Info_Char (' '); 753 754 case Pragma_Name (N) is 755 when Name_Annotate => 756 C := 'A'; 757 when Name_Comment => 758 C := 'C'; 759 when Name_Ident => 760 C := 'I'; 761 when Name_Title => 762 C := 'T'; 763 when Name_Subtitle => 764 C := 'S'; 765 when others => 766 raise Program_Error; 767 end case; 768 769 Write_Info_Char (C); 770 Write_Info_Int (Int (Get_Logical_Line_Number (L))); 771 Write_Info_Char (':'); 772 Write_Info_Int (Int (Get_Column_Number (L))); 773 774 -- Indicate source file of annotation if different from 775 -- compilation unit source file (case of annotation coming 776 -- from a separate). 777 778 if Get_Source_File_Index (L) /= Source_Index (Unit_Num) then 779 Write_Info_Char (':'); 780 Write_Info_Name (File_Name (Get_Source_File_Index (L))); 781 end if; 782 783 declare 784 A : Node_Id; 785 786 begin 787 A := First (Pragma_Argument_Associations (N)); 788 while Present (A) loop 789 Write_Info_Char (' '); 790 791 if Chars (A) /= No_Name then 792 Write_Info_Name (Chars (A)); 793 Write_Info_Char (':'); 794 end if; 795 796 declare 797 Expr : constant Node_Id := Expression (A); 798 799 begin 800 if Nkind (Expr) = N_Identifier then 801 Write_Info_Name (Chars (Expr)); 802 803 elsif Nkind (Expr) = N_Integer_Literal 804 and then Is_OK_Static_Expression (Expr) 805 then 806 Write_Info_Uint (Intval (Expr)); 807 808 elsif Nkind (Expr) = N_String_Literal 809 and then Is_OK_Static_Expression (Expr) 810 then 811 Write_Info_Slit (Strval (Expr)); 812 813 else 814 Write_Info_Str ("<expr>"); 815 end if; 816 end; 817 818 Next (A); 819 end loop; 820 end; 821 822 Write_Info_EOL; 823 end if; 824 end; 825 end loop; 826 end Write_Unit_Information; 827 828 ---------------------- 829 -- Write_With_Lines -- 830 ---------------------- 831 832 procedure Write_With_Lines is 833 Pname : constant Unit_Name_Type := 834 Get_Parent_Spec_Name (Unit_Name (Main_Unit)); 835 Body_Fname : File_Name_Type; 836 Body_Index : Nat; 837 Cunit : Node_Id; 838 Fname : File_Name_Type; 839 Num_Withs : Int := 0; 840 Unum : Unit_Number_Type; 841 Uname : Unit_Name_Type; 842 With_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 1)); 843 844 procedure Write_With_File_Names 845 (Nam : in out File_Name_Type; 846 Idx : Nat); 847 -- Write source file name Nam and ALI file name for unit index Idx. 848 -- Possibly change Nam to lowercase (generating a new file name). 849 850 --------------------------- 851 -- Write_With_File_Names -- 852 --------------------------- 853 854 procedure Write_With_File_Names 855 (Nam : in out File_Name_Type; 856 Idx : Nat) 857 is 858 begin 859 if not File_Names_Case_Sensitive then 860 Get_Name_String (Nam); 861 To_Lower (Name_Buffer (1 .. Name_Len)); 862 Nam := Name_Find; 863 end if; 864 865 Write_Info_Name (Nam); 866 Write_Info_Tab (49); 867 Write_Info_Name (Lib_File_Name (Nam, Idx)); 868 end Write_With_File_Names; 869 870 -- Start of processing for Write_With_Lines 871 872 begin 873 -- Loop to build the with table. A with on the main unit itself 874 -- is ignored (AARM 10.2(14a)). Such a with-clause can occur if 875 -- the main unit is a subprogram with no spec, and a subunit of 876 -- it unnecessarily withs the parent. 877 878 for J in Units.First + 1 .. Last_Unit loop 879 880 -- Add element to with table if it is with'ed or if it is the 881 -- parent spec of the main unit (case of main unit is a child 882 -- unit). The latter with is not needed for semantic purposes, 883 -- but is required by the binder for elaboration purposes. For 884 -- preprocessing data and definition files, there is no Unit_Name, 885 -- check for that first. 886 887 if Unit_Name (J) /= No_Unit_Name 888 and then (With_Flags (J) or else Unit_Name (J) = Pname) 889 then 890 Num_Withs := Num_Withs + 1; 891 With_Table (Num_Withs) := J; 892 end if; 893 end loop; 894 895 -- Sort and output the table 896 897 Sort (With_Table (1 .. Num_Withs)); 898 899 for J in 1 .. Num_Withs loop 900 Unum := With_Table (J); 901 902 -- Do not generate a with line for an ignored Ghost unit because 903 -- the unit does not have an ALI file. 904 905 if Is_Ignored_Ghost_Entity (Cunit_Entity (Unum)) then 906 goto Next_With_Line; 907 end if; 908 909 Cunit := Units.Table (Unum).Cunit; 910 Uname := Units.Table (Unum).Unit_Name; 911 Fname := Units.Table (Unum).Unit_File_Name; 912 913 -- Limited with clauses must be processed first because they are 914 -- the most specific among the three kinds. 915 916 if Ekind (Cunit_Entity (Unum)) = E_Package 917 and then From_Limited_With (Cunit_Entity (Unum)) 918 then 919 Write_Info_Initiate ('Y'); 920 921 elsif Has_Implicit_With (Unum) = Yes then 922 Write_Info_Initiate ('Z'); 923 924 else 925 Write_Info_Initiate ('W'); 926 end if; 927 928 Write_Info_Char (' '); 929 Write_Info_Name (Uname); 930 931 -- Now we need to figure out the names of the files that contain 932 -- the with'ed unit. These will usually be the files for the body, 933 -- except in the case of a package that has no body. Note that we 934 -- have a specific exemption here for predefined library generics 935 -- (see comments for Generic_May_Lack_ALI). We do not generate 936 -- dependency upon the ALI file for such units. Older compilers 937 -- used to not support generating code (and ALI) for generics, and 938 -- we want to avoid having different processing (namely, different 939 -- lists of files to be compiled) for different stages of the 940 -- bootstrap. 941 942 if not ((Nkind (Unit (Cunit)) in N_Generic_Declaration 943 or else 944 Nkind (Unit (Cunit)) in N_Generic_Renaming_Declaration) 945 and then Generic_May_Lack_ALI (Unum)) 946 947 -- In SPARK mode, always generate the dependencies on ALI 948 -- files, which are required to compute frame conditions 949 -- of subprograms. 950 951 or else GNATprove_Mode 952 then 953 Write_Info_Tab (25); 954 955 if Is_Spec_Name (Uname) then 956 Body_Fname := 957 Get_File_Name 958 (Uname => Get_Body_Name (Uname), 959 Subunit => False, 960 May_Fail => True); 961 962 Body_Index := Get_Unit_Index (Get_Body_Name (Uname)); 963 964 if Body_Fname = No_File then 965 Body_Fname := Get_File_Name (Uname, Subunit => False); 966 Body_Index := Get_Unit_Index (Uname); 967 end if; 968 else 969 Body_Fname := Get_File_Name (Uname, Subunit => False); 970 Body_Index := Get_Unit_Index (Uname); 971 end if; 972 973 -- A package is considered to have a body if it requires 974 -- a body or if a body is present in Ada 83 mode. 975 976 if Body_Required (Cunit) 977 or else (Ada_Version = Ada_83 978 and then Full_Source_Name (Body_Fname) /= No_File) 979 then 980 Write_With_File_Names (Body_Fname, Body_Index); 981 else 982 Write_With_File_Names (Fname, Munit_Index (Unum)); 983 end if; 984 985 if Ekind (Cunit_Entity (Unum)) = E_Package 986 and then From_Limited_With (Cunit_Entity (Unum)) 987 then 988 null; 989 else 990 if Elab_Flags (Unum) then 991 Write_Info_Str (" E"); 992 end if; 993 994 if Elab_All_Flags (Unum) then 995 Write_Info_Str (" EA"); 996 end if; 997 998 if Elab_Des_Flags (Unum) then 999 Write_Info_Str (" ED"); 1000 end if; 1001 1002 if Elab_All_Des_Flags (Unum) then 1003 Write_Info_Str (" AD"); 1004 end if; 1005 end if; 1006 end if; 1007 1008 Write_Info_EOL; 1009 1010 <<Next_With_Line>> 1011 null; 1012 end loop; 1013 1014 -- Finally generate the special lines for cases of Restriction_Set 1015 -- with No_Dependence and no restriction present. 1016 1017 declare 1018 Unam : Unit_Name_Type; 1019 1020 begin 1021 for J in Restriction_Set_Dependences.First .. 1022 Restriction_Set_Dependences.Last 1023 loop 1024 Unam := Restriction_Set_Dependences.Table (J); 1025 1026 -- Don't need an entry if already in the unit table 1027 1028 for U in 0 .. Last_Unit loop 1029 if Unit_Name (U) = Unam then 1030 goto Next_Restriction_Set; 1031 end if; 1032 end loop; 1033 1034 -- Otherwise generate the entry 1035 1036 Write_Info_Initiate ('W'); 1037 Write_Info_Char (' '); 1038 Write_Info_Name (Unam); 1039 Write_Info_EOL; 1040 1041 <<Next_Restriction_Set>> 1042 null; 1043 end loop; 1044 end; 1045 end Write_With_Lines; 1046 1047 -- Start of processing for Write_ALI 1048 1049 begin 1050 -- We never write an ALI file if the original operating mode was 1051 -- syntax-only (-gnats switch used in compiler invocation line) 1052 1053 if Original_Operating_Mode = Check_Syntax then 1054 return; 1055 end if; 1056 1057 -- Generation of ALI files may be disabled, e.g. for formal verification 1058 -- back-end. 1059 1060 if Disable_ALI_File then 1061 return; 1062 end if; 1063 1064 -- Build sorted source dependency table. We do this right away, because 1065 -- it is referenced by Up_To_Date_ALI_File_Exists. 1066 1067 for Unum in Units.First .. Last_Unit loop 1068 if Cunit_Entity (Unum) = Empty 1069 or else not From_Limited_With (Cunit_Entity (Unum)) 1070 then 1071 -- Units that are not analyzed need not appear in the dependency 1072 -- list. These units are either units appearing in limited_with 1073 -- clauses of other units, or units loaded for inlining that end 1074 -- up not inlined by a later decision of the inlining code, to 1075 -- prevent circularities. We want to exclude these files from the 1076 -- list of dependencies, so that the dependency number of other 1077 -- is correctly set, as that number is used by cross-reference 1078 -- tools to relate entity information to the unit in which they 1079 -- are declared. 1080 1081 if Present (Cunit_Entity (Unum)) 1082 and then Ekind (Cunit_Entity (Unum)) = E_Void 1083 and then Nkind (Unit (Cunit (Unum))) /= N_Subunit 1084 and then Serious_Errors_Detected = 0 1085 then 1086 null; 1087 1088 else 1089 Num_Sdep := Num_Sdep + 1; 1090 Sdep_Table (Num_Sdep) := Unum; 1091 end if; 1092 end if; 1093 end loop; 1094 1095 -- Sort the table so that the D lines are in order 1096 1097 Lib.Sort (Sdep_Table (1 .. Num_Sdep)); 1098 1099 -- If we are not generating code, and there is an up to date ALI file 1100 -- file accessible, read it, and acquire the compilation arguments from 1101 -- this file. In GNATprove mode, always generate the ALI file, which 1102 -- contains a special section for formal verification. 1103 1104 if Operating_Mode /= Generate_Code and then not GNATprove_Mode then 1105 if Up_To_Date_ALI_File_Exists then 1106 Update_Tables_From_ALI_File; 1107 return; 1108 end if; 1109 end if; 1110 1111 -- Otherwise acquire compilation arguments and prepare to write out a 1112 -- new ali file. 1113 1114 Create_Output_Library_Info; 1115 1116 -- Output version line 1117 1118 Write_Info_Initiate ('V'); 1119 Write_Info_Str (" """); 1120 Write_Info_Str (Verbose_Library_Version); 1121 Write_Info_Char ('"'); 1122 1123 Write_Info_EOL; 1124 1125 -- Output main program line if this is acceptable main program 1126 1127 Output_Main_Program_Line : declare 1128 U : Node_Id := Unit (Units.Table (Main_Unit).Cunit); 1129 S : Node_Id; 1130 1131 procedure M_Parameters; 1132 -- Output parameters for main program line 1133 1134 ------------------ 1135 -- M_Parameters -- 1136 ------------------ 1137 1138 procedure M_Parameters is 1139 begin 1140 if Main_Priority (Main_Unit) /= Default_Main_Priority then 1141 Write_Info_Char (' '); 1142 Write_Info_Nat (Main_Priority (Main_Unit)); 1143 end if; 1144 1145 if Opt.Time_Slice_Set then 1146 Write_Info_Str (" T="); 1147 Write_Info_Nat (Opt.Time_Slice_Value); 1148 end if; 1149 1150 if Main_CPU (Main_Unit) /= Default_Main_CPU then 1151 Write_Info_Str (" C="); 1152 Write_Info_Nat (Main_CPU (Main_Unit)); 1153 end if; 1154 1155 Write_Info_Str (" W="); 1156 Write_Info_Char 1157 (WC_Encoding_Letters (Wide_Character_Encoding_Method)); 1158 1159 Write_Info_EOL; 1160 end M_Parameters; 1161 1162 -- Start of processing for Output_Main_Program_Line 1163 1164 begin 1165 if Nkind (U) = N_Subprogram_Body 1166 or else 1167 (Nkind (U) = N_Package_Body 1168 and then 1169 Nkind (Original_Node (U)) in N_Subprogram_Instantiation) 1170 then 1171 -- If the unit is a subprogram instance, the entity for the 1172 -- subprogram is the alias of the visible entity, which is the 1173 -- related instance of the wrapper package. We retrieve the 1174 -- subprogram declaration of the desired entity. 1175 1176 if Nkind (U) = N_Package_Body then 1177 U := Parent (Parent ( 1178 Alias (Related_Instance (Defining_Unit_Name 1179 (Specification (Unit (Library_Unit (Parent (U))))))))); 1180 end if; 1181 1182 S := Specification (U); 1183 1184 -- A generic subprogram is never a main program 1185 1186 if Nkind (U) = N_Subprogram_Body 1187 and then Present (Corresponding_Spec (U)) 1188 and then 1189 Ekind_In (Corresponding_Spec (U), E_Generic_Procedure, 1190 E_Generic_Function) 1191 then 1192 null; 1193 1194 elsif No (Parameter_Specifications (S)) then 1195 if Nkind (S) = N_Procedure_Specification then 1196 Write_Info_Initiate ('M'); 1197 Write_Info_Str (" P"); 1198 M_Parameters; 1199 1200 else 1201 declare 1202 Nam : Node_Id := Defining_Unit_Name (S); 1203 1204 begin 1205 -- If it is a child unit, get its simple name 1206 1207 if Nkind (Nam) = N_Defining_Program_Unit_Name then 1208 Nam := Defining_Identifier (Nam); 1209 end if; 1210 1211 if Is_Integer_Type (Etype (Nam)) then 1212 Write_Info_Initiate ('M'); 1213 Write_Info_Str (" F"); 1214 M_Parameters; 1215 end if; 1216 end; 1217 end if; 1218 end if; 1219 end if; 1220 end Output_Main_Program_Line; 1221 1222 -- Write command argument ('A') lines 1223 1224 for A in 1 .. Compilation_Switches.Last loop 1225 Write_Info_Initiate ('A'); 1226 Write_Info_Char (' '); 1227 Write_Info_Str (Compilation_Switches.Table (A).all); 1228 Write_Info_Terminate; 1229 end loop; 1230 1231 -- Output parameters ('P') line 1232 1233 Write_Info_Initiate ('P'); 1234 1235 if Compilation_Errors then 1236 Write_Info_Str (" CE"); 1237 end if; 1238 1239 if Opt.Detect_Blocking then 1240 Write_Info_Str (" DB"); 1241 end if; 1242 1243 if Tasking_Used and then not Is_Predefined_Unit (Main_Unit) then 1244 if Locking_Policy /= ' ' then 1245 Write_Info_Str (" L"); 1246 Write_Info_Char (Locking_Policy); 1247 end if; 1248 1249 if Queuing_Policy /= ' ' then 1250 Write_Info_Str (" Q"); 1251 Write_Info_Char (Queuing_Policy); 1252 end if; 1253 1254 if Task_Dispatching_Policy /= ' ' then 1255 Write_Info_Str (" T"); 1256 Write_Info_Char (Task_Dispatching_Policy); 1257 Write_Info_Char (' '); 1258 end if; 1259 end if; 1260 1261 if GNATprove_Mode then 1262 Write_Info_Str (" GP"); 1263 end if; 1264 1265 if Partition_Elaboration_Policy /= ' ' then 1266 Write_Info_Str (" E"); 1267 Write_Info_Char (Partition_Elaboration_Policy); 1268 end if; 1269 1270 if No_Component_Reordering_Config then 1271 Write_Info_Str (" NC"); 1272 end if; 1273 1274 if not Object then 1275 Write_Info_Str (" NO"); 1276 end if; 1277 1278 if No_Run_Time_Mode then 1279 Write_Info_Str (" NR"); 1280 end if; 1281 1282 if Normalize_Scalars then 1283 Write_Info_Str (" NS"); 1284 end if; 1285 1286 if Default_SSO_Config /= ' ' then 1287 Write_Info_Str (" O"); 1288 Write_Info_Char (Default_SSO_Config); 1289 end if; 1290 1291 if Sec_Stack_Used then 1292 Write_Info_Str (" SS"); 1293 end if; 1294 1295 if Unreserve_All_Interrupts then 1296 Write_Info_Str (" UA"); 1297 end if; 1298 1299 if Front_End_Exceptions then 1300 Write_Info_Str (" FX"); 1301 end if; 1302 1303 if ZCX_Exceptions then 1304 Write_Info_Str (" ZX"); 1305 end if; 1306 1307 Write_Info_EOL; 1308 1309 -- Before outputting the restrictions line, update the setting of 1310 -- the No_Elaboration_Code flag. Violations of this restriction 1311 -- cannot be detected until after the backend has been called since 1312 -- it is the backend that sets this flag. We have to check all units 1313 -- for which we have generated code 1314 1315 for Unit in Units.First .. Last_Unit loop 1316 if Units.Table (Unit).Generate_Code or else Unit = Main_Unit then 1317 if not Has_No_Elaboration_Code (Cunit (Unit)) then 1318 Main_Restrictions.Violated (No_Elaboration_Code) := True; 1319 end if; 1320 end if; 1321 end loop; 1322 1323 -- Positional case (only if debug flag -gnatd.R is set) 1324 1325 if Debug_Flag_Dot_RR then 1326 1327 -- Output first restrictions line 1328 1329 Write_Info_Initiate ('R'); 1330 Write_Info_Char (' '); 1331 1332 -- First the information for the boolean restrictions 1333 1334 for R in All_Boolean_Restrictions loop 1335 if Main_Restrictions.Set (R) 1336 and then not Restriction_Warnings (R) 1337 then 1338 Write_Info_Char ('r'); 1339 elsif Main_Restrictions.Violated (R) then 1340 Write_Info_Char ('v'); 1341 else 1342 Write_Info_Char ('n'); 1343 end if; 1344 end loop; 1345 1346 -- And now the information for the parameter restrictions 1347 1348 for RP in All_Parameter_Restrictions loop 1349 if Main_Restrictions.Set (RP) 1350 and then not Restriction_Warnings (RP) 1351 then 1352 Write_Info_Char ('r'); 1353 Write_Info_Nat (Nat (Main_Restrictions.Value (RP))); 1354 else 1355 Write_Info_Char ('n'); 1356 end if; 1357 1358 if not Main_Restrictions.Violated (RP) 1359 or else RP not in Checked_Parameter_Restrictions 1360 then 1361 Write_Info_Char ('n'); 1362 else 1363 Write_Info_Char ('v'); 1364 Write_Info_Nat (Nat (Main_Restrictions.Count (RP))); 1365 1366 if Main_Restrictions.Unknown (RP) then 1367 Write_Info_Char ('+'); 1368 end if; 1369 end if; 1370 end loop; 1371 1372 Write_Info_EOL; 1373 1374 -- Named case (if debug flag -gnatd.R is not set) 1375 1376 else 1377 declare 1378 C : Character; 1379 1380 begin 1381 -- Write RN header line with preceding blank line 1382 1383 Write_Info_EOL; 1384 Write_Info_Initiate ('R'); 1385 Write_Info_Char ('N'); 1386 Write_Info_EOL; 1387 1388 -- First the lines for the boolean restrictions 1389 1390 for R in All_Boolean_Restrictions loop 1391 if Main_Restrictions.Set (R) 1392 and then not Restriction_Warnings (R) 1393 then 1394 C := 'R'; 1395 elsif Main_Restrictions.Violated (R) then 1396 C := 'V'; 1397 else 1398 goto Continue; 1399 end if; 1400 1401 Write_Info_Initiate ('R'); 1402 Write_Info_Char (C); 1403 Write_Info_Char (' '); 1404 Write_Info_Str (All_Boolean_Restrictions'Image (R)); 1405 Write_Info_EOL; 1406 1407 <<Continue>> 1408 null; 1409 end loop; 1410 end; 1411 1412 -- And now the lines for the parameter restrictions 1413 1414 for RP in All_Parameter_Restrictions loop 1415 if Main_Restrictions.Set (RP) 1416 and then not Restriction_Warnings (RP) 1417 then 1418 Write_Info_Initiate ('R'); 1419 Write_Info_Str ("R "); 1420 Write_Info_Str (All_Parameter_Restrictions'Image (RP)); 1421 Write_Info_Char ('='); 1422 Write_Info_Nat (Nat (Main_Restrictions.Value (RP))); 1423 Write_Info_EOL; 1424 end if; 1425 1426 if not Main_Restrictions.Violated (RP) 1427 or else RP not in Checked_Parameter_Restrictions 1428 then 1429 null; 1430 else 1431 Write_Info_Initiate ('R'); 1432 Write_Info_Str ("V "); 1433 Write_Info_Str (All_Parameter_Restrictions'Image (RP)); 1434 Write_Info_Char ('='); 1435 Write_Info_Nat (Nat (Main_Restrictions.Count (RP))); 1436 1437 if Main_Restrictions.Unknown (RP) then 1438 Write_Info_Char ('+'); 1439 end if; 1440 1441 Write_Info_EOL; 1442 end if; 1443 end loop; 1444 end if; 1445 1446 -- Output R lines for No_Dependence entries 1447 1448 for J in No_Dependences.First .. No_Dependences.Last loop 1449 if In_Extended_Main_Source_Unit (No_Dependences.Table (J).Unit) 1450 and then not No_Dependences.Table (J).Warn 1451 then 1452 Write_Info_Initiate ('R'); 1453 Write_Info_Char (' '); 1454 Write_Unit_Name (No_Dependences.Table (J).Unit); 1455 Write_Info_EOL; 1456 end if; 1457 end loop; 1458 1459 -- Output interrupt state lines 1460 1461 for J in Interrupt_States.First .. Interrupt_States.Last loop 1462 Write_Info_Initiate ('I'); 1463 Write_Info_Char (' '); 1464 Write_Info_Nat (Interrupt_States.Table (J).Interrupt_Number); 1465 Write_Info_Char (' '); 1466 Write_Info_Char (Interrupt_States.Table (J).Interrupt_State); 1467 Write_Info_Char (' '); 1468 Write_Info_Nat 1469 (Nat (Get_Logical_Line_Number 1470 (Interrupt_States.Table (J).Pragma_Loc))); 1471 Write_Info_EOL; 1472 end loop; 1473 1474 -- Output priority specific dispatching lines 1475 1476 for J in Specific_Dispatching.First .. Specific_Dispatching.Last loop 1477 Write_Info_Initiate ('S'); 1478 Write_Info_Char (' '); 1479 Write_Info_Char (Specific_Dispatching.Table (J).Dispatching_Policy); 1480 Write_Info_Char (' '); 1481 Write_Info_Nat (Specific_Dispatching.Table (J).First_Priority); 1482 Write_Info_Char (' '); 1483 Write_Info_Nat (Specific_Dispatching.Table (J).Last_Priority); 1484 Write_Info_Char (' '); 1485 Write_Info_Nat 1486 (Nat (Get_Logical_Line_Number 1487 (Specific_Dispatching.Table (J).Pragma_Loc))); 1488 Write_Info_EOL; 1489 end loop; 1490 1491 -- Loop through file table to output information for all units for which 1492 -- we have generated code, as marked by the Generate_Code flag. 1493 1494 for Unit in Units.First .. Last_Unit loop 1495 if Units.Table (Unit).Generate_Code 1496 or else Unit = Main_Unit 1497 then 1498 Write_Info_EOL; -- blank line 1499 Write_Unit_Information (Unit); 1500 end if; 1501 end loop; 1502 1503 Write_Info_EOL; -- blank line 1504 1505 -- Output external version reference lines 1506 1507 for J in 1 .. Version_Ref.Last loop 1508 Write_Info_Initiate ('E'); 1509 Write_Info_Char (' '); 1510 1511 for K in 1 .. String_Length (Version_Ref.Table (J)) loop 1512 Write_Info_Char_Code (Get_String_Char (Version_Ref.Table (J), K)); 1513 end loop; 1514 1515 Write_Info_EOL; 1516 end loop; 1517 1518 -- Prepare to output the source dependency lines 1519 1520 declare 1521 Unum : Unit_Number_Type; 1522 -- Number of unit being output 1523 1524 Sind : Source_File_Index; 1525 -- Index of corresponding source file 1526 1527 Fname : File_Name_Type; 1528 1529 begin 1530 for J in 1 .. Num_Sdep loop 1531 Unum := Sdep_Table (J); 1532 Units.Table (Unum).Dependency_Num := J; 1533 Sind := Units.Table (Unum).Source_Index; 1534 1535 Write_Info_Initiate ('D'); 1536 Write_Info_Char (' '); 1537 1538 -- Normal case of a unit entry with a source index 1539 1540 if Sind > No_Source_File then 1541 -- We never want directory information in ALI files 1542 -- ???But back out this change temporarily until 1543 -- gprbuild is fixed. 1544 1545 if False then 1546 Fname := Strip_Directory (File_Name (Sind)); 1547 else 1548 Fname := File_Name (Sind); 1549 end if; 1550 1551 -- Ensure that on platforms where the file names are not 1552 -- case sensitive, the recorded file name is in lower case. 1553 1554 if not File_Names_Case_Sensitive then 1555 Get_Name_String (Fname); 1556 To_Lower (Name_Buffer (1 .. Name_Len)); 1557 Fname := Name_Find; 1558 end if; 1559 1560 Write_Info_Name_May_Be_Quoted (Fname); 1561 Write_Info_Tab (25); 1562 Write_Info_Str (String (Time_Stamp (Sind))); 1563 Write_Info_Char (' '); 1564 Write_Info_Str (Get_Hex_String (Source_Checksum (Sind))); 1565 1566 -- If the dependency comes from a limited_with clause, record 1567 -- limited_checksum. This is disabled until full checksum 1568 -- changes are checked. 1569 1570 -- if Present (Cunit_Entity (Unum)) 1571 -- and then From_Limited_With (Cunit_Entity (Unum)) 1572 -- then 1573 -- Write_Info_Char (' '); 1574 -- Write_Info_Char ('Y'); 1575 -- Write_Info_Str (Get_Hex_String (Limited_Chk_Sum (Sind))); 1576 -- end if; 1577 1578 -- If subunit, add unit name, omitting the %b at the end 1579 1580 if Present (Cunit (Unum)) then 1581 Get_Decoded_Name_String (Unit_Name (Unum)); 1582 Write_Info_Char (' '); 1583 1584 if Nkind (Unit (Cunit (Unum))) = N_Subunit then 1585 Write_Info_Str (Name_Buffer (1 .. Name_Len - 2)); 1586 else 1587 Write_Info_Str (Name_Buffer (1 .. Name_Len)); 1588 end if; 1589 end if; 1590 1591 -- If Source_Reference pragma used, output information 1592 1593 if Num_SRef_Pragmas (Sind) > 0 then 1594 Write_Info_Char (' '); 1595 1596 if Num_SRef_Pragmas (Sind) = 1 then 1597 Write_Info_Nat (Int (First_Mapped_Line (Sind))); 1598 else 1599 Write_Info_Nat (0); 1600 end if; 1601 1602 Write_Info_Char (':'); 1603 Write_Info_Name (Reference_Name (Sind)); 1604 end if; 1605 1606 -- Case where there is no source index (happens for missing 1607 -- files). In this case we write a dummy time stamp. 1608 1609 else 1610 Write_Info_Name (Unit_File_Name (Unum)); 1611 Write_Info_Tab (25); 1612 Write_Info_Str (String (Dummy_Time_Stamp)); 1613 Write_Info_Char (' '); 1614 Write_Info_Str (Get_Hex_String (0)); 1615 end if; 1616 1617 Write_Info_EOL; 1618 end loop; 1619 end; 1620 1621 -- Output cross-references 1622 1623 if Opt.Xref_Active then 1624 Output_References; 1625 end if; 1626 1627 -- Output SCO information if present 1628 1629 if Generate_SCO then 1630 SCO_Record_Filtered; 1631 SCO_Output; 1632 end if; 1633 1634 -- Output final blank line and we are done. This final blank line is 1635 -- probably junk, but we don't feel like making an incompatible change. 1636 1637 Write_Info_Terminate; 1638 Close_Output_Library_Info; 1639 end Write_ALI; 1640 1641 --------------------- 1642 -- Write_Unit_Name -- 1643 --------------------- 1644 1645 procedure Write_Unit_Name (N : Node_Id) is 1646 begin 1647 if Nkind (N) = N_Identifier then 1648 Write_Info_Name (Chars (N)); 1649 1650 else 1651 pragma Assert (Nkind (N) = N_Selected_Component); 1652 Write_Unit_Name (Prefix (N)); 1653 Write_Info_Char ('.'); 1654 Write_Unit_Name (Selector_Name (N)); 1655 end if; 1656 end Write_Unit_Name; 1657 1658end Lib.Writ; 1659