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