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