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