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