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