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