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