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