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