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