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