gcc/ada/lib-writ.adb

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