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