gcc/ada/lib-writ.adb

   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-2001 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with ALI;      use ALI;
  28 with Atree;    use Atree;
  29 with Casing;   use Casing;
  30 with Einfo;    use Einfo;
  31 with Errout;   use Errout;
  32 with Fname;    use Fname;
  33 with Fname.UF; use Fname.UF;
  34 with Lib.Util; use Lib.Util;
  35 with Lib.Xref; use Lib.Xref;
  36 with Namet;    use Namet;
  37 with Nlists;   use Nlists;
  38 with Gnatvsn;  use Gnatvsn;
  39 with Opt;      use Opt;
  40 with Osint;    use Osint;
  41 with Osint.C;  use Osint.C;
  42 with Par;
  43 with Restrict; use Restrict;
  44 with Scn;      use Scn;
  45 with Sinfo;    use Sinfo;
  46 with Sinput;   use Sinput;
  47 with Stringt;  use Stringt;
  48 with Uname;    use Uname;
  49
  50 with System.WCh_Con; use System.WCh_Con;
  51
  52 package body Lib.Writ is
  53
  54    ------------------------------
  55    -- Ensure_System_Dependency --
  56    ------------------------------
  57
  58    procedure Ensure_System_Dependency is
  59       Discard : List_Id;
  60
  61       System_Uname : Unit_Name_Type;
  62       --  Unit name for system spec if needed for dummy entry
  63
  64       System_Fname : File_Name_Type;
  65       --  File name for system spec if needed for dummy entry
  66
  67    begin
  68       --  Nothing to do if we already compiled System
  69
  70       for Unum in Units.First .. Last_Unit loop
  71          if Units.Table (Unum).Source_Index = System_Source_File_Index then
  72             return;
  73          end if;
  74       end loop;
  75
  76       --  If no entry for system.ads in the units table, then add a entry
  77       --  to the units table for system.ads, which will be referenced when
  78       --  the ali file is generated. We need this because every unit depends
  79       --  on system as a result of Targparm scanning the system.ads file to
  80       --  determine the target dependent parameters for the compilation.
  81
  82       Name_Len := 6;
  83       Name_Buffer (1 .. 6) := "system";
  84       System_Uname := Name_To_Unit_Name (Name_Enter);
  85       System_Fname := File_Name (System_Source_File_Index);
  86
  87       Units.Increment_Last;
  88       Units.Table (Units.Last) := (
  89         Unit_File_Name  => System_Fname,
  90         Unit_Name       => System_Uname,
  91         Expected_Unit   => System_Uname,
  92         Source_Index    => System_Source_File_Index,
  93         Cunit           => Empty,
  94         Cunit_Entity    => Empty,
  95         Dependency_Num  => 0,
  96         Dependent_Unit  => True,
  97         Dynamic_Elab    => False,
  98         Fatal_Error     => False,
  99         Generate_Code   => False,
 100         Has_RACW        => False,
 101         Ident_String    => Empty,
 102         Loading         => False,
 103         Main_Priority   => -1,
 104         Serial_Number   => 0,
 105         Version         => 0,
 106         Error_Location  => No_Location);
 107
 108       --  Parse system.ads so that the checksum is set right
 109
 110       Initialize_Scanner (Units.Last, System_Source_File_Index);
 111       Discard := Par (Configuration_Pragmas => False);
 112    end Ensure_System_Dependency;
 113
 114    ---------------
 115    -- Write_ALI --
 116    ---------------
 117
 118    procedure Write_ALI (Object : Boolean) is
 119
 120       ----------------
 121       -- Local Data --
 122       ----------------
 123
 124       Last_Unit : constant Unit_Number_Type := Units.Last;
 125       --  Record unit number of last unit. We capture this in case we
 126       --  have to add a dummy entry to the unit table for package System.
 127
 128       With_Flags : array (Units.First .. Last_Unit) of Boolean;
 129       --  Array of flags to show which units are with'ed
 130
 131       Elab_Flags : array (Units.First .. Last_Unit) of Boolean;
 132       --  Array of flags to show which units have pragma Elaborate set
 133
 134       Elab_All_Flags : array (Units.First .. Last_Unit) of Boolean;
 135       --  Array of flags to show which units have pragma Elaborate All set
 136
 137       Elab_Des_Flags : array (Units.First .. Last_Unit) of Boolean;
 138       --  Array of flags to show which units have Elaborate_All_Desirable set
 139
 140       Sdep_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 2));
 141       --  Sorted table of source dependencies. One extra entry in case we
 142       --  have to add a dummy entry for System.
 143
 144       Num_Sdep : Nat := 0;
 145       --  Number of active entries in Sdep_Table
 146
 147       -----------------------
 148       -- Local Subprograms --
 149       -----------------------
 150
 151       procedure Collect_Withs (Cunit : Node_Id);
 152       --  Collect with lines for entries in the context clause of the
 153       --  given compilation unit, Cunit.
 154
 155       procedure Update_Tables_From_ALI_File;
 156       --  Given an up to date ALI file (see Up_To_Date_ALI_file_Exists
 157       --  function), update tables from the ALI information, including
 158       --  specifically the Compilation_Switches table.
 159
 160       function Up_To_Date_ALI_File_Exists return Boolean;
 161       --  If there exists an ALI file that is up to date, then this function
 162       --  initializes the tables in the ALI spec to contain information on
 163       --  this file (using Scan_ALI) and returns True. If no file exists,
 164       --  or the file is not up to date, then False is returned.
 165
 166       procedure Write_Unit_Information (Unit_Num : Unit_Number_Type);
 167       --  Write out the library information for one unit for which code is
 168       --  generated (includes unit line and with lines).
 169
 170       procedure Write_With_Lines;
 171       --  Write out with lines collected by calls to Collect_Withs
 172
 173       -------------------
 174       -- Collect_Withs --
 175       -------------------
 176
 177       procedure Collect_Withs (Cunit : Node_Id) is
 178          Item : Node_Id;
 179          Unum : Unit_Number_Type;
 180
 181       begin
 182          Item := First (Context_Items (Cunit));
 183          while Present (Item) loop
 184
 185             if Nkind (Item) = N_With_Clause then
 186                Unum := Get_Cunit_Unit_Number (Library_Unit (Item));
 187                With_Flags (Unum) := True;
 188
 189                if Elaborate_Present (Item) then
 190                   Elab_Flags (Unum) := True;
 191                end if;
 192
 193                if Elaborate_All_Present (Item) then
 194                   Elab_All_Flags (Unum) := True;
 195                end if;
 196
 197                if Elaborate_All_Desirable (Cunit_Entity (Unum)) then
 198                   Elab_Des_Flags (Unum) := True;
 199                end if;
 200             end if;
 201
 202             Next (Item);
 203          end loop;
 204       end Collect_Withs;
 205
 206       --------------------------------
 207       -- Up_To_Date_ALI_File_Exists --
 208       --------------------------------
 209
 210       function Up_To_Date_ALI_File_Exists return Boolean is
 211          Name : File_Name_Type;
 212          Text : Text_Buffer_Ptr;
 213          Id   : Sdep_Id;
 214          Sind : Source_File_Index;
 215
 216       begin
 217          Opt.Check_Object_Consistency := True;
 218          Read_Library_Info (Name, Text);
 219
 220          --  Return if we could not find an ALI file
 221
 222          if Text = null then
 223             return False;
 224          end if;
 225
 226          --  Return if ALI file has bad format
 227
 228          Initialize_ALI;
 229
 230          if Scan_ALI (Name, Text, False, Err => True) = No_ALI_Id then
 231             return False;
 232          end if;
 233
 234          --  If we have an OK ALI file, check if it is up to date
 235          --  Note that we assume that the ALI read has all the entries
 236          --  we have in our table, plus some additional ones (that can
 237          --  come from expansion).
 238
 239          Id := First_Sdep_Entry;
 240          for J in 1 .. Num_Sdep loop
 241             Sind := Units.Table (Sdep_Table (J)).Source_Index;
 242
 243             while Sdep.Table (Id).Sfile /= File_Name (Sind) loop
 244                if Id = Sdep.Last then
 245                   return False;
 246                else
 247                   Id := Id + 1;
 248                end if;
 249             end loop;
 250
 251             if Sdep.Table (Id).Stamp /= Time_Stamp (Sind) then
 252                return False;
 253             end if;
 254          end loop;
 255
 256          return True;
 257       end Up_To_Date_ALI_File_Exists;
 258
 259       ---------------------------------
 260       -- Update_Tables_From_ALI_File --
 261       ---------------------------------
 262
 263       procedure Update_Tables_From_ALI_File is
 264       begin
 265          --  Build Compilation_Switches table
 266
 267          Compilation_Switches.Init;
 268
 269          for J in First_Arg_Entry .. Args.Last loop
 270             Compilation_Switches.Increment_Last;
 271             Compilation_Switches.Table (Compilation_Switches.Last) :=
 272               Args.Table (J);
 273          end loop;
 274       end Update_Tables_From_ALI_File;
 275
 276       ----------------------------
 277       -- Write_Unit_Information --
 278       ----------------------------
 279
 280       procedure Write_Unit_Information (Unit_Num : Unit_Number_Type) is
 281          Unode : constant Node_Id   := Cunit (Unit_Num);
 282          Ukind : constant Node_Kind := Nkind (Unit (Unode));
 283          Uent  : constant Entity_Id := Cunit_Entity (Unit_Num);
 284          Pnode : Node_Id;
 285
 286       begin
 287          Write_Info_Initiate ('U');
 288          Write_Info_Char (' ');
 289          Write_Info_Name (Unit_Name (Unit_Num));
 290          Write_Info_Tab (25);
 291          Write_Info_Name (Unit_File_Name (Unit_Num));
 292
 293          Write_Info_Tab (49);
 294          Write_Info_Str (Version_Get (Unit_Num));
 295
 296          if Dynamic_Elab (Unit_Num) then
 297             Write_Info_Str (" DE");
 298          end if;
 299
 300          --  We set the Elaborate_Body indication if either an explicit pragma
 301          --  was present, or if this is an instantiation. RM 12.3(20) requires
 302          --  that the body be immediately elaborated after the spec. We would
 303          --  normally do that anyway, but the EB we generate here ensures that
 304          --  this gets done even when we use the -p gnatbind switch.
 305
 306          if Has_Pragma_Elaborate_Body (Uent)
 307            or else (Ukind = N_Package_Declaration
 308                      and then Is_Generic_Instance (Uent)
 309                      and then Present (Corresponding_Body (Unit (Unode))))
 310          then
 311             Write_Info_Str (" EB");
 312          end if;
 313
 314          --  Now see if we should tell the binder that an elaboration entity
 315          --  is present, which must be reset to true during elaboration. We
 316          --  generate the indication if the following condition is met:
 317
 318          --  If this is a spec ...
 319
 320          if (Is_Subprogram (Uent)
 321                or else
 322              Ekind (Uent) = E_Package
 323                or else
 324              Is_Generic_Unit (Uent))
 325
 326             --  and an elaboration entity was declared ...
 327
 328             and then Present (Elaboration_Entity (Uent))
 329
 330             --  and either the elaboration flag is required ...
 331
 332             and then
 333               (Elaboration_Entity_Required (Uent)
 334
 335                --  or this unit has elaboration code ...
 336
 337                or else not Has_No_Elaboration_Code (Unode)
 338
 339                --  or this unit has a separate body and this
 340                --  body has elaboration code.
 341
 342                or else
 343                  (Ekind (Uent) = E_Package
 344                    and then Present (Body_Entity (Uent))
 345                    and then
 346                      not Has_No_Elaboration_Code
 347                            (Parent
 348                              (Declaration_Node
 349                                (Body_Entity (Uent))))))
 350          then
 351             Write_Info_Str (" EE");
 352          end if;
 353
 354          if Has_No_Elaboration_Code (Unode) then
 355             Write_Info_Str (" NE");
 356          end if;
 357
 358          if Is_Preelaborated (Uent) then
 359             Write_Info_Str (" PR");
 360          end if;
 361
 362          if Is_Pure (Uent) then
 363             Write_Info_Str (" PU");
 364          end if;
 365
 366          if Has_RACW (Unit_Num) then
 367             Write_Info_Str (" RA");
 368          end if;
 369
 370          if Is_Remote_Call_Interface (Uent) then
 371             Write_Info_Str (" RC");
 372          end if;
 373
 374          if Is_Remote_Types (Uent) then
 375             Write_Info_Str (" RT");
 376          end if;
 377
 378          if Is_Shared_Passive (Uent) then
 379             Write_Info_Str (" SP");
 380          end if;
 381
 382          if Ukind = N_Subprogram_Declaration
 383            or else Ukind = N_Subprogram_Body
 384          then
 385             Write_Info_Str (" SU");
 386
 387          elsif Ukind = N_Package_Declaration
 388                  or else
 389                Ukind = N_Package_Body
 390          then
 391             --  If this is a wrapper package for a subprogram instantiation,
 392             --  the user view is the subprogram. Note that in this case the
 393             --  ali file contains both the spec and body of the instance.
 394
 395             if Is_Wrapper_Package (Uent) then
 396                Write_Info_Str (" SU");
 397             else
 398                Write_Info_Str (" PK");
 399             end if;
 400
 401          elsif Ukind = N_Generic_Package_Declaration then
 402             Write_Info_Str (" PK");
 403
 404          end if;
 405
 406          if Ukind in N_Generic_Declaration
 407            or else
 408              (Present (Library_Unit (Unode))
 409                 and then
 410               Nkind (Unit (Library_Unit (Unode))) in N_Generic_Declaration)
 411          then
 412             Write_Info_Str (" GE");
 413          end if;
 414
 415          if not Is_Internal_File_Name (Unit_File_Name (Unit_Num), True) then
 416             case Identifier_Casing (Source_Index (Unit_Num)) is
 417                when All_Lower_Case => Write_Info_Str (" IL");
 418                when All_Upper_Case => Write_Info_Str (" IU");
 419                when others         => null;
 420             end case;
 421
 422             case Keyword_Casing (Source_Index (Unit_Num)) is
 423                when Mixed_Case     => Write_Info_Str (" KM");
 424                when All_Upper_Case => Write_Info_Str (" KU");
 425                when others         => null;
 426             end case;
 427          end if;
 428
 429          if Initialize_Scalars then
 430             Write_Info_Str (" IS");
 431          end if;
 432
 433          Write_Info_EOL;
 434
 435          --  Generate with lines, first those that are directly with'ed
 436
 437          for J in With_Flags'Range loop
 438             With_Flags (J) := False;
 439             Elab_Flags (J) := False;
 440             Elab_All_Flags (J) := False;
 441             Elab_Des_Flags (J) := False;
 442          end loop;
 443
 444          Collect_Withs (Unode);
 445
 446          --  For a body, we must also check for any subunits which belong to
 447          --  it and which have context clauses of their own, since these
 448          --  with'ed units are part of its own elaboration dependencies.
 449
 450          if Nkind (Unit (Unode)) in N_Unit_Body then
 451             for S in Units.First .. Last_Unit loop
 452
 453                --  We are only interested in subunits
 454
 455                if Nkind (Unit (Cunit (S))) = N_Subunit then
 456                   Pnode := Library_Unit (Cunit (S));
 457
 458                   --  In gnatc mode, the errors in the subunits will not
 459                   --  have been recorded, but the analysis of the subunit
 460                   --  may have failed. There is no information to add to
 461                   --  ALI file in this case.
 462
 463                   if No (Pnode) then
 464                      exit;
 465                   end if;
 466
 467                   --  Find ultimate parent of the subunit
 468
 469                   while Nkind (Unit (Pnode)) = N_Subunit loop
 470                      Pnode := Library_Unit (Pnode);
 471                   end loop;
 472
 473                   --  See if it belongs to current unit, and if so, include
 474                   --  its with_clauses.
 475
 476                   if Pnode = Unode then
 477                      Collect_Withs (Cunit (S));
 478                   end if;
 479                end if;
 480             end loop;
 481          end if;
 482
 483          Write_With_Lines;
 484
 485          --  Output linker option lines
 486
 487          for J in 1 .. Linker_Option_Lines.Last loop
 488             declare
 489                S : constant Linker_Option_Entry :=
 490                      Linker_Option_Lines.Table (J);
 491                C : Character;
 492
 493             begin
 494                if S.Unit = Unit_Num then
 495                   Write_Info_Initiate ('L');
 496                   Write_Info_Str (" """);
 497
 498                   for J in 1 .. String_Length (S.Option) loop
 499                      C := Get_Character (Get_String_Char (S.Option, J));
 500
 501                      if C in Character'Val (16#20#) .. Character'Val (16#7E#)
 502                        and then C /= '{'
 503                      then
 504                         Write_Info_Char (C);
 505
 506                         if C = '"' then
 507                            Write_Info_Char (C);
 508                         end if;
 509
 510                      else
 511                         declare
 512                            Hex : array (0 .. 15) of Character :=
 513                                    "0123456789ABCDEF";
 514
 515                         begin
 516                            Write_Info_Char ('{');
 517                            Write_Info_Char (Hex (Character'Pos (C) / 16));
 518                            Write_Info_Char (Hex (Character'Pos (C) mod 16));
 519                            Write_Info_Char ('}');
 520                         end;
 521                      end if;
 522                   end loop;
 523
 524                   Write_Info_Char ('"');
 525                   Write_Info_EOL;
 526                end if;
 527             end;
 528          end loop;
 529       end Write_Unit_Information;
 530
 531       ----------------------
 532       -- Write_With_Lines --
 533       ----------------------
 534
 535       procedure Write_With_Lines is
 536          With_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 1));
 537          Num_Withs  : Int := 0;
 538          Unum       : Unit_Number_Type;
 539          Cunit      : Node_Id;
 540          Cunite     : Entity_Id;
 541          Uname      : Unit_Name_Type;
 542          Fname      : File_Name_Type;
 543          Pname      : constant Unit_Name_Type :=
 544                         Get_Parent_Spec_Name (Unit_Name (Main_Unit));
 545          Body_Fname : File_Name_Type;
 546
 547       begin
 548          --  Loop to build the with table. A with on the main unit itself
 549          --  is ignored (AARM 10.2(14a)). Such a with-clause can occur if
 550          --  the main unit is a subprogram with no spec, and a subunit of
 551          --  it unecessarily withs the parent.
 552
 553          for J in Units.First + 1 .. Last_Unit loop
 554
 555             --  Add element to with table if it is with'ed or if it is the
 556             --  parent spec of the main unit (case of main unit is a child
 557             --  unit). The latter with is not needed for semantic purposes,
 558             --  but is required by the binder for elaboration purposes.
 559
 560             if (With_Flags (J) or else Unit_Name (J) = Pname)
 561               and then Units.Table (J).Dependent_Unit
 562             then
 563                Num_Withs := Num_Withs + 1;
 564                With_Table (Num_Withs) := J;
 565             end if;
 566          end loop;
 567
 568          --  Sort and output the table
 569
 570          Sort (With_Table (1 .. Num_Withs));
 571
 572          for J in 1 .. Num_Withs loop
 573             Unum   := With_Table (J);
 574             Cunit  := Units.Table (Unum).Cunit;
 575             Cunite := Units.Table (Unum).Cunit_Entity;
 576             Uname  := Units.Table (Unum).Unit_Name;
 577             Fname  := Units.Table (Unum).Unit_File_Name;
 578
 579             Write_Info_Initiate ('W');
 580             Write_Info_Char (' ');
 581             Write_Info_Name (Uname);
 582
 583             --  Now we need to figure out the names of the files that contain
 584             --  the with'ed unit. These will usually be the files for the body,
 585             --  except in the case of a package that has no body.
 586
 587             if (Nkind (Unit (Cunit)) not in N_Generic_Declaration
 588                   and then
 589                 Nkind (Unit (Cunit)) not in N_Generic_Renaming_Declaration)
 590               or else Generic_Separately_Compiled (Cunite)
 591             then
 592                Write_Info_Tab (25);
 593
 594                if Is_Spec_Name (Uname) then
 595                   Body_Fname :=
 596                     Get_File_Name (Get_Body_Name (Uname), Subunit => False);
 597                else
 598                   Body_Fname := Get_File_Name (Uname, Subunit => False);
 599                end if;
 600
 601                --  A package is considered to have a body if it requires
 602                --  a body or if a body is present in Ada 83 mode.
 603
 604                if Body_Required (Cunit)
 605                  or else (Ada_83
 606                            and then Full_Source_Name (Body_Fname) /= No_File)
 607                then
 608                   Write_Info_Name (Body_Fname);
 609                   Write_Info_Tab (49);
 610                   Write_Info_Name (Lib_File_Name (Body_Fname));
 611                else
 612                   Write_Info_Name (Fname);
 613                   Write_Info_Tab (49);
 614                   Write_Info_Name (Lib_File_Name (Fname));
 615                end if;
 616
 617                if Elab_Flags (Unum) then
 618                   Write_Info_Str ("  E");
 619                end if;
 620
 621                if Elab_All_Flags (Unum) then
 622                   Write_Info_Str ("  EA");
 623                end if;
 624
 625                if Elab_Des_Flags (Unum) then
 626                   Write_Info_Str ("  ED");
 627                end if;
 628             end if;
 629
 630             Write_Info_EOL;
 631          end loop;
 632       end Write_With_Lines;
 633
 634    --  Start of processing for Writ_ALI
 635
 636    begin
 637       --  Build sorted source dependency table. We do this right away,
 638       --  because it is referenced by Up_To_Date_ALI_File_Exists.
 639
 640       for Unum in Units.First .. Last_Unit loop
 641          Num_Sdep := Num_Sdep + 1;
 642          Sdep_Table (Num_Sdep) := Unum;
 643       end loop;
 644
 645       --  Sort the table so that the D lines are in order
 646
 647       Lib.Sort (Sdep_Table (1 .. Num_Sdep));
 648
 649       --  If we are not generating code, and there is an up to date
 650       --  ali file accessible, read it, and acquire the compilation
 651       --  arguments from this file.
 652
 653       if Operating_Mode /= Generate_Code then
 654          if Up_To_Date_ALI_File_Exists then
 655             Update_Tables_From_ALI_File;
 656             return;
 657          end if;
 658       end if;
 659
 660       --  Otherwise acquire compilation arguments and prepare to write
 661       --  out a new ali file.
 662
 663       Create_Output_Library_Info;
 664
 665       --  Output version line
 666
 667       Write_Info_Initiate ('V');
 668       Write_Info_Str (" """);
 669       Write_Info_Str (Library_Version);
 670       Write_Info_Char ('"');
 671
 672       Write_Info_EOL;
 673
 674       --  Output main program line if this is acceptable main program
 675
 676       declare
 677          U : Node_Id := Unit (Units.Table (Main_Unit).Cunit);
 678          S : Node_Id;
 679
 680          procedure M_Parameters;
 681          --  Output parameters for main program line
 682
 683          procedure M_Parameters is
 684          begin
 685             if Main_Priority (Main_Unit) /= Default_Main_Priority then
 686                Write_Info_Char (' ');
 687                Write_Info_Nat (Main_Priority (Main_Unit));
 688             end if;
 689
 690             if Opt.Time_Slice_Set then
 691                Write_Info_Str (" T=");
 692                Write_Info_Nat (Opt.Time_Slice_Value);
 693             end if;
 694
 695             Write_Info_Str (" W=");
 696             Write_Info_Char
 697               (WC_Encoding_Letters (Wide_Character_Encoding_Method));
 698
 699             Write_Info_EOL;
 700          end M_Parameters;
 701
 702       begin
 703          if Nkind (U) = N_Subprogram_Body
 704            or else (Nkind (U) = N_Package_Body
 705                       and then
 706                         (Nkind (Original_Node (U)) = N_Function_Instantiation
 707                            or else
 708                          Nkind (Original_Node (U)) =
 709                                                   N_Procedure_Instantiation))
 710          then
 711             --  If the unit is a subprogram instance, the entity for the
 712             --  subprogram is the alias of the visible entity, which is the
 713             --  related instance of the wrapper package. We retrieve the
 714             --  subprogram declaration of the desired entity.
 715
 716             if Nkind (U) = N_Package_Body then
 717                U := Parent (Parent (
 718                    Alias (Related_Instance (Defining_Unit_Name
 719                      (Specification (Unit (Library_Unit (Parent (U)))))))));
 720             end if;
 721
 722             S := Specification (U);
 723
 724             if not Present (Parameter_Specifications (S)) then
 725                if Nkind (S) = N_Procedure_Specification then
 726                   Write_Info_Initiate ('M');
 727                   Write_Info_Str (" P");
 728                   M_Parameters;
 729
 730                else
 731                   declare
 732                      Nam : Node_Id := Defining_Unit_Name (S);
 733
 734                   begin
 735                      --  If it is a child unit, get its simple name.
 736
 737                      if Nkind (Nam) = N_Defining_Program_Unit_Name then
 738                         Nam := Defining_Identifier (Nam);
 739                      end if;
 740
 741                      if Is_Integer_Type (Etype (Nam)) then
 742                         Write_Info_Initiate ('M');
 743                         Write_Info_Str (" F");
 744                         M_Parameters;
 745                      end if;
 746                   end;
 747                end if;
 748             end if;
 749          end if;
 750       end;
 751
 752       --  Write command argmument ('A') lines
 753
 754       for A in 1 .. Compilation_Switches.Last loop
 755          Write_Info_Initiate ('A');
 756          Write_Info_Char (' ');
 757          Write_Info_Str (Compilation_Switches.Table (A).all);
 758          Write_Info_Terminate;
 759       end loop;
 760
 761       --  Output parameters ('P') line
 762
 763       Write_Info_Initiate ('P');
 764
 765       if Compilation_Errors then
 766          Write_Info_Str (" CE");
 767       end if;
 768
 769       if Opt.Float_Format /= ' ' then
 770          Write_Info_Str (" F");
 771
 772          if Opt.Float_Format = 'I' then
 773             Write_Info_Char ('I');
 774
 775          elsif Opt.Float_Format_Long = 'D' then
 776             Write_Info_Char ('D');
 777
 778          else
 779             Write_Info_Char ('G');
 780          end if;
 781       end if;
 782
 783       if Tasking_Used
 784         and then not Is_Predefined_File_Name (Unit_File_Name (Main_Unit))
 785       then
 786          if Locking_Policy /= ' ' then
 787             Write_Info_Str  (" L");
 788             Write_Info_Char (Locking_Policy);
 789          end if;
 790
 791          if Queuing_Policy /= ' ' then
 792             Write_Info_Str  (" Q");
 793             Write_Info_Char (Queuing_Policy);
 794          end if;
 795
 796          if Task_Dispatching_Policy /= ' ' then
 797             Write_Info_Str  (" T");
 798             Write_Info_Char (Task_Dispatching_Policy);
 799             Write_Info_Char (' ');
 800          end if;
 801       end if;
 802
 803       if not Object then
 804          Write_Info_Str (" NO");
 805       end if;
 806
 807       if No_Run_Time then
 808          Write_Info_Str (" NR");
 809       end if;
 810
 811       if Normalize_Scalars then
 812          Write_Info_Str (" NS");
 813       end if;
 814
 815       if Unreserve_All_Interrupts then
 816          Write_Info_Str (" UA");
 817       end if;
 818
 819       if Exception_Mechanism /= Setjmp_Longjmp then
 820          if Unit_Exception_Table_Present then
 821             Write_Info_Str (" UX");
 822          end if;
 823
 824          Write_Info_Str (" ZX");
 825       end if;
 826
 827       Write_Info_EOL;
 828
 829       --  Output restrictions line
 830
 831       Write_Info_Initiate ('R');
 832       Write_Info_Char (' ');
 833
 834       for J in All_Restrictions loop
 835          if Main_Restrictions (J) then
 836             Write_Info_Char ('r');
 837          elsif Violations (J) then
 838             Write_Info_Char ('v');
 839          else
 840             Write_Info_Char ('n');
 841          end if;
 842       end loop;
 843
 844       Write_Info_EOL;
 845
 846       --  Loop through file table to output information for all units for which
 847       --  we have generated code, as marked by the Generate_Code flag.
 848
 849       for Unit in Units.First .. Last_Unit loop
 850          if Units.Table (Unit).Generate_Code
 851            or else Unit = Main_Unit
 852          then
 853             Write_Info_EOL; -- blank line
 854             Write_Unit_Information (Unit);
 855          end if;
 856       end loop;
 857
 858       Write_Info_EOL; -- blank line
 859
 860       --  Output external version reference lines
 861
 862       for J in 1 .. Version_Ref.Last loop
 863          Write_Info_Initiate ('E');
 864          Write_Info_Char (' ');
 865
 866          for K in 1 .. String_Length (Version_Ref.Table (J)) loop
 867             Write_Info_Char_Code (Get_String_Char (Version_Ref.Table (J), K));
 868          end loop;
 869
 870          Write_Info_EOL;
 871       end loop;
 872
 873       --  Prepare to output the source dependency lines
 874
 875       declare
 876          Unum : Unit_Number_Type;
 877          --  Number of unit being output
 878
 879          Sind : Source_File_Index;
 880          --  Index of corresponding source file
 881
 882       begin
 883          for J in 1 .. Num_Sdep loop
 884             Unum := Sdep_Table (J);
 885             Units.Table (Unum).Dependency_Num := J;
 886             Sind := Units.Table (Unum).Source_Index;
 887
 888             Write_Info_Initiate ('D');
 889             Write_Info_Char (' ');
 890
 891             --  Normal case of a dependent unit entry with a source index
 892
 893             if Sind /= No_Source_File
 894               and then Units.Table (Unum).Dependent_Unit
 895             then
 896                Write_Info_Name (File_Name (Sind));
 897                Write_Info_Tab (25);
 898                Write_Info_Str (String (Time_Stamp (Sind)));
 899                Write_Info_Char (' ');
 900                Write_Info_Str (Get_Hex_String (Source_Checksum (Sind)));
 901
 902                --  If subunit, add unit name, omitting the %b at the end
 903
 904                if Present (Cunit (Unum))
 905                  and then Nkind (Unit (Cunit (Unum))) = N_Subunit
 906                then
 907                   Get_Decoded_Name_String (Unit_Name (Unum));
 908                   Write_Info_Char (' ');
 909                   Write_Info_Str (Name_Buffer (1 .. Name_Len - 2));
 910                end if;
 911
 912                --  If Source_Reference pragma used output information
 913
 914                if Num_SRef_Pragmas (Sind) > 0 then
 915                   Write_Info_Char (' ');
 916
 917                   if Num_SRef_Pragmas (Sind) = 1 then
 918                      Write_Info_Nat (Int (First_Mapped_Line (Sind)));
 919                   else
 920                      Write_Info_Nat (0);
 921                   end if;
 922
 923                   Write_Info_Char (':');
 924                   Write_Info_Name (Reference_Name (Sind));
 925                end if;
 926
 927             --  Case where there is no source index (happens for missing files)
 928             --  Also come here for non-dependent units.
 929
 930             else
 931                Write_Info_Name (Unit_File_Name (Unum));
 932                Write_Info_Tab (25);
 933                Write_Info_Str (String (Dummy_Time_Stamp));
 934                Write_Info_Char (' ');
 935                Write_Info_Str (Get_Hex_String (0));
 936             end if;
 937
 938             Write_Info_EOL;
 939          end loop;
 940       end;
 941
 942       Output_References;
 943       Write_Info_Terminate;
 944       Close_Output_Library_Info;
 945
 946    end Write_ALI;
 947
 948 end Lib.Writ;