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