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