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