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