gcc/ada/mlib-prj.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                            M L I B . P R J                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --              Copyright (C) 2001-2005, Ada Core Technologies, Inc.        --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with ALI;      use ALI;
  28 with Gnatvsn;  use Gnatvsn;
  29 with Hostparm;
  30 with MLib.Fil; use MLib.Fil;
  31 with MLib.Tgt; use MLib.Tgt;
  32 with MLib.Utl; use MLib.Utl;
  33 with Namet;    use Namet;
  34 with Opt;
  35 with Osint;    use Osint;
  36 with Output;   use Output;
  37 with Prj.Com;  use Prj.Com;
  38 with Prj.Env;  use Prj.Env;
  39 with Prj.Util; use Prj.Util;
  40 with Sinput.P;
  41 with Snames;   use Snames;
  42 with Switch;   use Switch;
  43 with Table;
  44 with Types;    use Types;
  45
  46 with Ada.Characters.Handling;
  47
  48 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  49 with GNAT.HTable;
  50 with GNAT.OS_Lib;               use GNAT.OS_Lib;
  51 with Interfaces.C_Streams;      use Interfaces.C_Streams;
  52 with System;                    use System;
  53 with System.Case_Util;          use System.Case_Util;
  54
  55 package body MLib.Prj is
  56
  57    Prj_Add_Obj_Files : Types.Int;
  58    pragma Import (C, Prj_Add_Obj_Files, "__gnat_prj_add_obj_files");
  59    Add_Object_Files : constant Boolean := Prj_Add_Obj_Files /= 0;
  60    --  Indicates if object files in pragmas Linker_Options (found in the
  61    --  binder generated file) should be taken when linking aq stand-alone
  62    --  library.
  63    --  False for Windows, True for other platforms.
  64
  65    ALI_Suffix : constant String := ".ali";
  66    B_Start    : String := "b~";
  67
  68    S_Osinte_Ads : Name_Id := No_Name;
  69    --  Name_Id for "s-osinte.ads"
  70
  71    S_Dec_Ads : Name_Id := No_Name;
  72    --  Name_Id for "dec.ads"
  73
  74    G_Trasym_Ads : Name_Id := No_Name;
  75    --  Name_Id for "g-trasym.ads"
  76
  77    No_Argument_List : aliased String_List := (1 .. 0 => null);
  78    No_Argument      : constant String_List_Access := No_Argument_List'Access;
  79
  80    Arguments : String_List_Access := No_Argument;
  81    --  Used to accumulate arguments for the invocation of gnatbind and of
  82    --  the compiler. Also used to collect the interface ALI when copying
  83    --  the ALI files to the library directory.
  84
  85    Argument_Number : Natural := 0;
  86    --  Index of the last argument in Arguments
  87
  88    Initial_Argument_Max : constant := 10;
  89
  90    No_Main_String : aliased String := "-n";
  91    No_Main : constant String_Access := No_Main_String'Access;
  92
  93    Output_Switch_String : aliased String := "-o";
  94    Output_Switch : constant String_Access := Output_Switch_String'Access;
  95
  96    Compile_Switch_String : aliased String := "-c";
  97    Compile_Switch : constant String_Access := Compile_Switch_String'Access;
  98
  99    --  List of objects to put inside the library
 100
 101    Object_Files : Argument_List_Access;
 102
 103    package Objects is new Table.Table
 104      (Table_Name           => "Mlib.Prj.Objects",
 105       Table_Component_Type => String_Access,
 106       Table_Index_Type     => Natural,
 107       Table_Low_Bound      => 1,
 108       Table_Initial        => 50,
 109       Table_Increment      => 100);
 110
 111    package Objects_Htable is new GNAT.HTable.Simple_HTable
 112      (Header_Num => Header_Num,
 113       Element    => Boolean,
 114       No_Element => False,
 115       Key        => Name_Id,
 116       Hash       => Hash,
 117       Equal      => "=");
 118
 119    --  List of non-Ada object files
 120
 121    Foreign_Objects : Argument_List_Access;
 122
 123    package Foreigns is new Table.Table
 124      (Table_Name           => "Mlib.Prj.Foreigns",
 125       Table_Component_Type => String_Access,
 126       Table_Index_Type     => Natural,
 127       Table_Low_Bound      => 1,
 128       Table_Initial        => 20,
 129       Table_Increment      => 100);
 130
 131    --  List of ALI files
 132
 133    Ali_Files : Argument_List_Access;
 134
 135    package ALIs is new Table.Table
 136      (Table_Name           => "Mlib.Prj.Alis",
 137       Table_Component_Type => String_Access,
 138       Table_Index_Type     => Natural,
 139       Table_Low_Bound      => 1,
 140       Table_Initial        => 50,
 141       Table_Increment      => 100);
 142
 143    --  List of options set in the command line.
 144
 145    Options : Argument_List_Access;
 146
 147    package Opts is new Table.Table
 148      (Table_Name           => "Mlib.Prj.Opts",
 149       Table_Component_Type => String_Access,
 150       Table_Index_Type     => Natural,
 151       Table_Low_Bound      => 1,
 152       Table_Initial        => 5,
 153       Table_Increment      => 100);
 154
 155    --  All the ALI file in the library
 156
 157    package Library_ALIs is new GNAT.HTable.Simple_HTable
 158      (Header_Num => Header_Num,
 159       Element    => Boolean,
 160       No_Element => False,
 161       Key        => Name_Id,
 162       Hash       => Hash,
 163       Equal      => "=");
 164
 165    --  The ALI files in the interface sets
 166
 167    package Interface_ALIs is new GNAT.HTable.Simple_HTable
 168      (Header_Num => Header_Num,
 169       Element    => Boolean,
 170       No_Element => False,
 171       Key        => Name_Id,
 172       Hash       => Hash,
 173       Equal      => "=");
 174
 175    --  The ALI files that have been processed to check if the corresponding
 176    --  library unit is in the interface set.
 177
 178    package Processed_ALIs is new GNAT.HTable.Simple_HTable
 179      (Header_Num => Header_Num,
 180       Element    => Boolean,
 181       No_Element => False,
 182       Key        => Name_Id,
 183       Hash       => Hash,
 184       Equal      => "=");
 185
 186    --  The projects imported directly or indirectly.
 187
 188    package Processed_Projects is new GNAT.HTable.Simple_HTable
 189      (Header_Num => Header_Num,
 190       Element    => Boolean,
 191       No_Element => False,
 192       Key        => Name_Id,
 193       Hash       => Hash,
 194       Equal      => "=");
 195
 196    --  The library projects imported directly or indirectly.
 197
 198    package Library_Projs is new Table.Table (
 199      Table_Component_Type => Project_Id,
 200      Table_Index_Type     => Integer,
 201      Table_Low_Bound      => 1,
 202      Table_Initial        => 10,
 203      Table_Increment      => 10,
 204      Table_Name           => "Make.Library_Projs");
 205
 206    type Build_Mode_State is (None, Static, Dynamic, Relocatable);
 207
 208    procedure Add_Argument (S : String);
 209    --  Add one argument to the array Arguments.
 210    --  If Arguments is full, double its size.
 211
 212    function ALI_File_Name (Source : String) return String;
 213    --  Return the ALI file name corresponding to a source.
 214
 215    procedure Check (Filename : String);
 216    --  Check if filename is a regular file. Fail if it is not.
 217
 218    procedure Check_Context;
 219    --  Check each object files in table Object_Files
 220    --  Fail if any of them is not a regular file
 221
 222    procedure Clean (Directory : Name_Id);
 223    --  Attempt to delete all files in Directory, but not subdirectories
 224
 225    procedure Copy_Interface_Sources
 226      (For_Project : Project_Id;
 227       In_Tree     : Project_Tree_Ref;
 228       Interfaces  : Argument_List;
 229       To_Dir      : Name_Id);
 230    --  Copy the interface sources of a SAL to directory To_Dir
 231
 232    procedure Display (Executable : String);
 233    --  Display invocation of gnatbind and of the compiler with the arguments
 234    --  in Arguments, except when Quiet_Output is True.
 235
 236    procedure Process_Binder_File (Name : String);
 237    --  For Stand-Alone libraries, get the Linker Options in the binder
 238    --  generated file.
 239
 240    procedure Reset_Tables;
 241    --  Make sure that all the above tables are empty
 242    --  (Objects, Foreign_Objects, Ali_Files, Options).
 243
 244    ------------------
 245    -- Add_Argument --
 246    ------------------
 247
 248    procedure Add_Argument (S : String) is
 249    begin
 250       if Argument_Number = Arguments'Last then
 251          declare
 252             New_Args : constant String_List_Access :=
 253               new String_List (1 .. 2 * Arguments'Last);
 254
 255          begin
 256             --  Copy the String_Accesses and set them to null in Arguments
 257             --  so that they will not be deallocated by the call to
 258             --  Free (Arguments).
 259
 260             New_Args (Arguments'Range) := Arguments.all;
 261             Arguments.all := (others => null);
 262             Free (Arguments);
 263             Arguments := New_Args;
 264          end;
 265       end if;
 266
 267       Argument_Number := Argument_Number + 1;
 268       Arguments (Argument_Number) := new String'(S);
 269    end Add_Argument;
 270
 271    -------------------
 272    -- ALI_File_Name --
 273    -------------------
 274
 275    function ALI_File_Name (Source : String) return String is
 276    begin
 277       --  If the source name has an extension, then replace it with
 278       --  the ALI suffix.
 279
 280       for Index in reverse Source'First + 1 .. Source'Last loop
 281          if Source (Index) = '.' then
 282             return Source (Source'First .. Index - 1) & ALI_Suffix;
 283          end if;
 284       end loop;
 285
 286       --  If there is no dot, or if it is the first character, just add the
 287       --  ALI suffix.
 288
 289       return Source & ALI_Suffix;
 290    end ALI_File_Name;
 291
 292    -------------------
 293    -- Build_Library --
 294    -------------------
 295
 296    procedure Build_Library
 297      (For_Project   : Project_Id;
 298       In_Tree       : Project_Tree_Ref;
 299       Gnatbind      : String;
 300       Gnatbind_Path : String_Access;
 301       Gcc           : String;
 302       Gcc_Path      : String_Access;
 303       Bind          : Boolean := True;
 304       Link          : Boolean := True)
 305    is
 306       Warning_For_Library : Boolean := False;
 307       --  Set to True for the first warning about a unit missing from the
 308       --  interface set.
 309
 310       Libgnarl_Needed   : Boolean := False;
 311       --  Set to True if library needs to be linked with libgnarl
 312
 313       Libdecgnat_Needed : Boolean := False;
 314       --  On OpenVMS, set to True if library needs to be linked with libdecgnat
 315
 316       Gtrasymobj_Needed : Boolean := False;
 317       --  On OpenVMS, set to True if library needs to be linked with
 318       --  g-trasym.obj.
 319
 320       Data : Project_Data := In_Tree.Projects.Table (For_Project);
 321
 322       Object_Directory_Path : constant String :=
 323                           Get_Name_String (Data.Object_Directory);
 324
 325       Standalone   : constant Boolean := Data.Standalone_Library;
 326
 327       Project_Name : constant String := Get_Name_String (Data.Name);
 328
 329       Current_Dir  : constant String := Get_Current_Dir;
 330
 331       Lib_Filename : String_Access;
 332       Lib_Dirpath  : String_Access;
 333       Lib_Version  : String_Access := new String'("");
 334
 335       The_Build_Mode : Build_Mode_State := None;
 336
 337       Success : Boolean := False;
 338
 339       Library_Options : Variable_Value := Nil_Variable_Value;
 340
 341       Library_GCC     : Variable_Value := Nil_Variable_Value;
 342
 343       Driver_Name : Name_Id := No_Name;
 344
 345       In_Main_Object_Directory : Boolean := True;
 346
 347       Rpath : String_Access := null;
 348       --  Allocated only if Path Option is supported
 349
 350       Rpath_Last : Natural := 0;
 351       --  Index of last valid character of Rpath
 352
 353       Initial_Rpath_Length : constant := 200;
 354       --  Initial size of Rpath, when first allocated
 355
 356       Path_Option : String_Access := Linker_Library_Path_Option;
 357       --  If null, Path Option is not supported.
 358       --  Not a constant so that it can be deallocated.
 359
 360       Copy_Dir : Name_Id;
 361       --  Directory where to copy ALI files and possibly interface sources
 362
 363       First_ALI : Name_Id := No_Name;
 364       --  Store the ALI file name of a source of the library (the first found)
 365
 366       procedure Add_ALI_For (Source : Name_Id);
 367       --  Add the name of the ALI file corresponding to Source to the
 368       --  Arguments.
 369
 370       procedure Add_Rpath (Path : String);
 371       --  Add a path name to Rpath
 372
 373       function Check_Project (P : Project_Id) return Boolean;
 374       --  Returns True if P is For_Project or a project extended by For_Project
 375
 376       procedure Check_Libs (ALI_File : String);
 377       --  Set Libgnarl_Needed if the ALI_File indicates that there is a need
 378       --  to link with -lgnarl (this is the case when there is a dependency
 379       --  on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file
 380       --  indicates that there is a need to link with -ldecgnat (this is the
 381       --  case when there is a dependency on dec.ads), and set
 382       --  Gtrasymobj_Needed if there is a dependency on g-trasym.ads.
 383
 384       procedure Process (The_ALI : File_Name_Type);
 385       --  Check if the closure of a library unit which is or should be in the
 386       --  interface set is also in the interface set. Issue a warning for each
 387       --  missing library unit.
 388
 389       procedure Process_Imported_Libraries;
 390       --  Add the -L and -l switches for the imported Library Project Files,
 391       --  and, if Path Option is supported, the library directory path names
 392       --  to Rpath.
 393
 394       -----------------
 395       -- Add_ALI_For --
 396       -----------------
 397
 398       procedure Add_ALI_For (Source : Name_Id) is
 399          ALI    : constant String := ALI_File_Name (Get_Name_String (Source));
 400          ALI_Id : Name_Id;
 401
 402       begin
 403          if Bind then
 404             Add_Argument (ALI);
 405          end if;
 406
 407          Name_Len := 0;
 408          Add_Str_To_Name_Buffer (S => ALI);
 409          ALI_Id := Name_Find;
 410
 411          --  Add the ALI file name to the library ALIs
 412
 413          if Bind then
 414             Library_ALIs.Set (ALI_Id, True);
 415          end if;
 416
 417          --  Set First_ALI, if not already done
 418
 419          if First_ALI = No_Name then
 420             First_ALI := ALI_Id;
 421          end if;
 422       end Add_ALI_For;
 423
 424       ---------------
 425       -- Add_Rpath --
 426       ---------------
 427
 428       procedure Add_Rpath (Path : String) is
 429
 430          procedure Double;
 431          --  Double Rpath size
 432
 433          ------------
 434          -- Double --
 435          ------------
 436
 437          procedure Double is
 438             New_Rpath : constant String_Access :=
 439                           new String (1 .. 2 * Rpath'Length);
 440          begin
 441             New_Rpath (1 .. Rpath_Last) := Rpath (1 .. Rpath_Last);
 442             Free (Rpath);
 443             Rpath := New_Rpath;
 444          end Double;
 445
 446       --  Start of processing for Add_Rpath
 447
 448       begin
 449          --  If firt path, allocate initial Rpath
 450
 451          if Rpath = null then
 452             Rpath := new String (1 .. Initial_Rpath_Length);
 453             Rpath_Last := 0;
 454
 455          else
 456             --  Otherwise, add a path separator between two path names
 457
 458             if Rpath_Last = Rpath'Last then
 459                Double;
 460             end if;
 461
 462             Rpath_Last := Rpath_Last + 1;
 463             Rpath (Rpath_Last) := Path_Separator;
 464          end if;
 465
 466          --  Increase Rpath size until it is large enough
 467
 468          while Rpath_Last + Path'Length > Rpath'Last loop
 469             Double;
 470          end loop;
 471
 472          --  Add the path name
 473
 474          Rpath (Rpath_Last + 1 .. Rpath_Last + Path'Length) := Path;
 475          Rpath_Last := Rpath_Last + Path'Length;
 476       end Add_Rpath;
 477
 478       -------------------
 479       -- Check_Project --
 480       -------------------
 481
 482       function Check_Project (P : Project_Id) return Boolean is
 483       begin
 484          if P = For_Project then
 485             return True;
 486
 487          elsif P /= No_Project then
 488             declare
 489                Data : Project_Data :=
 490                         In_Tree.Projects.Table (For_Project);
 491             begin
 492                while Data.Extends /= No_Project loop
 493                   if P = Data.Extends then
 494                      return True;
 495                   end if;
 496
 497                   Data := In_Tree.Projects.Table (Data.Extends);
 498                end loop;
 499             end;
 500          end if;
 501
 502          return False;
 503       end Check_Project;
 504
 505       ----------------
 506       -- Check_Libs --
 507       ----------------
 508
 509       procedure Check_Libs (ALI_File : String) is
 510          Lib_File : Name_Id;
 511          Text     : Text_Buffer_Ptr;
 512          Id       : ALI.ALI_Id;
 513
 514       begin
 515          if not Libgnarl_Needed or
 516            (Hostparm.OpenVMS and then
 517               ((not Libdecgnat_Needed) or
 518                (not Gtrasymobj_Needed)))
 519          then
 520             --  Scan the ALI file
 521
 522             Name_Len := ALI_File'Length;
 523             Name_Buffer (1 .. Name_Len) := ALI_File;
 524             Lib_File := Name_Find;
 525             Text := Read_Library_Info (Lib_File, True);
 526
 527             Id  := ALI.Scan_ALI
 528                          (F          => Lib_File,
 529                           T          => Text,
 530                           Ignore_ED  => False,
 531                           Err        => True,
 532                           Read_Lines => "D");
 533             Free (Text);
 534
 535             --  Look for s-osinte.ads in the dependencies
 536
 537             for Index in ALI.ALIs.Table (Id).First_Sdep ..
 538                          ALI.ALIs.Table (Id).Last_Sdep
 539             loop
 540                if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then
 541                   Libgnarl_Needed := True;
 542
 543                elsif Hostparm.OpenVMS then
 544                   if ALI.Sdep.Table (Index).Sfile = S_Dec_Ads then
 545                      Libdecgnat_Needed := True;
 546
 547                   elsif ALI.Sdep.Table (Index).Sfile = G_Trasym_Ads then
 548                      Gtrasymobj_Needed := True;
 549                   end if;
 550                end if;
 551             end loop;
 552          end if;
 553       end Check_Libs;
 554
 555       -------------
 556       -- Process --
 557       -------------
 558
 559       procedure Process (The_ALI : File_Name_Type) is
 560          Text       : Text_Buffer_Ptr;
 561          Idread     : ALI_Id;
 562          First_Unit : ALI.Unit_Id;
 563          Last_Unit  : ALI.Unit_Id;
 564          Unit_Data  : Unit_Record;
 565          Afile      : File_Name_Type;
 566
 567       begin
 568          --  Nothing to do if the ALI file has already been processed.
 569          --  This happens if an interface imports another interface.
 570
 571          if not Processed_ALIs.Get (The_ALI) then
 572             Processed_ALIs.Set (The_ALI, True);
 573             Text := Read_Library_Info (The_ALI);
 574
 575             if Text /= null then
 576                Idread :=
 577                  Scan_ALI
 578                    (F         => The_ALI,
 579                     T         => Text,
 580                     Ignore_ED => False,
 581                     Err       => True);
 582                Free (Text);
 583
 584                if Idread /= No_ALI_Id then
 585                   First_Unit := ALI.ALIs.Table (Idread).First_Unit;
 586                   Last_Unit  := ALI.ALIs.Table (Idread).Last_Unit;
 587
 588                   --  Process both unit (spec and body) if the body is needed
 589                   --  by the spec (inline or generic). Otherwise, just process
 590                   --  the spec.
 591
 592                   if First_Unit /= Last_Unit and then
 593                     not ALI.Units.Table (Last_Unit).Body_Needed_For_SAL
 594                   then
 595                      First_Unit := Last_Unit;
 596                   end if;
 597
 598                   for Unit in First_Unit .. Last_Unit loop
 599                      Unit_Data := ALI.Units.Table (Unit);
 600
 601                      --  Check if each withed unit which is in the library is
 602                      --  also in the interface set, if it has not yet been
 603                      --  processed.
 604
 605                      for W in Unit_Data.First_With .. Unit_Data.Last_With loop
 606                         Afile := Withs.Table (W).Afile;
 607
 608                         if Afile /= No_Name and then Library_ALIs.Get (Afile)
 609                           and then not Processed_ALIs.Get (Afile)
 610                         then
 611                            if not Interface_ALIs.Get (Afile) then
 612                               if not Warning_For_Library then
 613                                  Write_Str ("Warning: In library project """);
 614                                  Get_Name_String (Data.Name);
 615                                  To_Mixed (Name_Buffer (1 .. Name_Len));
 616                                  Write_Str (Name_Buffer (1 .. Name_Len));
 617                                  Write_Line ("""");
 618                                  Warning_For_Library := True;
 619                               end if;
 620
 621                               Write_Str ("         Unit """);
 622                               Get_Name_String (Withs.Table (W).Uname);
 623                               To_Mixed (Name_Buffer (1 .. Name_Len - 2));
 624                               Write_Str (Name_Buffer (1 .. Name_Len - 2));
 625                               Write_Line (""" is not in the interface set");
 626                               Write_Str ("         but it is needed by ");
 627
 628                               case Unit_Data.Utype is
 629                                  when Is_Spec =>
 630                                     Write_Str ("the spec of ");
 631
 632                                  when Is_Body =>
 633                                     Write_Str ("the body of ");
 634
 635                                  when others =>
 636                                     null;
 637                               end case;
 638
 639                               Write_Str ("""");
 640                               Get_Name_String (Unit_Data.Uname);
 641                               To_Mixed (Name_Buffer (1 .. Name_Len - 2));
 642                               Write_Str (Name_Buffer (1 .. Name_Len - 2));
 643                               Write_Line ("""");
 644                            end if;
 645
 646                            --  Now, process this unit
 647
 648                            Process (Afile);
 649                         end if;
 650                      end loop;
 651                   end loop;
 652                end if;
 653             end if;
 654          end if;
 655       end Process;
 656
 657       --------------------------------
 658       -- Process_Imported_Libraries --
 659       --------------------------------
 660
 661       procedure Process_Imported_Libraries is
 662          Current : Project_Id;
 663
 664          procedure Process_Project (Project : Project_Id);
 665          --  Process Project and its imported projects recursively.
 666          --  Add any library projects to table Library_Projs.
 667
 668          ---------------------
 669          -- Process_Project --
 670          ---------------------
 671
 672          procedure Process_Project (Project : Project_Id) is
 673             Data     : constant Project_Data :=
 674                          In_Tree.Projects.Table (Project);
 675             Imported : Project_List := Data.Imported_Projects;
 676             Element  : Project_Element;
 677
 678          begin
 679             --  Nothing to do if process has already been processed
 680
 681             if not Processed_Projects.Get (Data.Name) then
 682                Processed_Projects.Set (Data.Name, True);
 683
 684                --  Call Process_Project recursively for any imported project.
 685                --  We first process the imported projects to guarantee that
 686                --  we have a proper reverse order for the libraries.
 687
 688                while Imported /= Empty_Project_List loop
 689                   Element :=
 690                     In_Tree.Project_Lists.Table (Imported);
 691
 692                   if Element.Project /= No_Project then
 693                      Process_Project (Element.Project);
 694                   end if;
 695
 696                   Imported := Element.Next;
 697                end loop;
 698
 699                --  If it is a library project, add it to Library_Projs
 700
 701                if Project /= For_Project and then Data.Library then
 702                   Library_Projs.Increment_Last;
 703                   Library_Projs.Table (Library_Projs.Last) := Project;
 704                end if;
 705
 706             end if;
 707          end Process_Project;
 708
 709       --  Start of processing for Process_Imported_Libraries
 710
 711       begin
 712          --  Build list of library projects imported directly or indirectly,
 713          --  in the reverse order.
 714
 715          Process_Project (For_Project);
 716
 717          --  Add the -L and -l switches and, if the Rpath option is supported,
 718          --  add the directory to the Rpath.
 719          --  As the library projects are in the wrong order, process from the
 720          --  last to the first.
 721
 722          for Index in reverse 1 .. Library_Projs.Last loop
 723             Current := Library_Projs.Table (Index);
 724
 725             Get_Name_String
 726               (In_Tree.Projects.Table (Current).Library_Dir);
 727             Opts.Increment_Last;
 728             Opts.Table (Opts.Last) :=
 729               new String'("-L" & Name_Buffer (1 .. Name_Len));
 730
 731             if Path_Option /= null then
 732                Add_Rpath (Name_Buffer (1 .. Name_Len));
 733             end if;
 734
 735             Opts.Increment_Last;
 736             Opts.Table (Opts.Last) :=
 737               new String'
 738                 ("-l" &
 739                  Get_Name_String
 740                    (In_Tree.Projects.Table
 741                       (Current).Library_Name));
 742          end loop;
 743       end Process_Imported_Libraries;
 744
 745    --  Start of processing for Build_Library
 746
 747    begin
 748       Reset_Tables;
 749
 750       --  Fail if project is not a library project
 751
 752       if not Data.Library then
 753          Com.Fail ("project """, Project_Name, """ has no library");
 754       end if;
 755
 756       --  If this is the first time Build_Library is called, get the Name_Id
 757       --  of "s-osinte.ads".
 758
 759       if S_Osinte_Ads = No_Name then
 760          Name_Len := 0;
 761          Add_Str_To_Name_Buffer ("s-osinte.ads");
 762          S_Osinte_Ads := Name_Find;
 763       end if;
 764
 765       if S_Dec_Ads = No_Name then
 766          Name_Len := 0;
 767          Add_Str_To_Name_Buffer ("dec.ads");
 768          S_Dec_Ads := Name_Find;
 769       end if;
 770
 771       if G_Trasym_Ads = No_Name then
 772          Name_Len := 0;
 773          Add_Str_To_Name_Buffer ("g-trasym.ads");
 774          G_Trasym_Ads := Name_Find;
 775       end if;
 776
 777       --  We work in the object directory
 778
 779       Change_Dir (Object_Directory_Path);
 780
 781       if Standalone then
 782          --  Call gnatbind only if Bind is True
 783
 784          if Bind then
 785             if Gnatbind_Path = null then
 786                Com.Fail ("unable to locate ", Gnatbind);
 787             end if;
 788
 789             if Gcc_Path = null then
 790                Com.Fail ("unable to locate ", Gcc);
 791             end if;
 792
 793             --  Allocate Arguments, if it is the first time we see a standalone
 794             --  library.
 795
 796             if Arguments = No_Argument then
 797                Arguments := new String_List (1 .. Initial_Argument_Max);
 798             end if;
 799
 800             --  Add "-n -o b~<lib>.adb (b$<lib>.adb on VMS) -L<lib>"
 801
 802             Argument_Number := 2;
 803             Arguments (1) := No_Main;
 804             Arguments (2) := Output_Switch;
 805
 806             if Hostparm.OpenVMS then
 807                B_Start (B_Start'Last) := '$';
 808             end if;
 809
 810             Add_Argument
 811               (B_Start & Get_Name_String (Data.Library_Name) & ".adb");
 812             Add_Argument ("-L" & Get_Name_String (Data.Library_Name));
 813
 814             --  Check if Binder'Default_Switches ("Ada) is defined. If it is,
 815             --  add these switches to call gnatbind.
 816
 817             declare
 818                Binder_Package : constant Package_Id :=
 819                                   Value_Of
 820                                     (Name        => Name_Binder,
 821                                      In_Packages => Data.Decl.Packages,
 822                                      In_Tree     => In_Tree);
 823
 824             begin
 825                if Binder_Package /= No_Package then
 826                   declare
 827                      Defaults : constant Array_Element_Id :=
 828                                   Value_Of
 829                                     (Name      => Name_Default_Switches,
 830                                      In_Arrays =>
 831                                        In_Tree.Packages.Table
 832                                          (Binder_Package).Decl.Arrays,
 833                                      In_Tree   => In_Tree);
 834                      Switches : Variable_Value := Nil_Variable_Value;
 835
 836                      Switch : String_List_Id := Nil_String;
 837
 838                   begin
 839                      if Defaults /= No_Array_Element then
 840                         Switches :=
 841                           Value_Of
 842                             (Index     => Name_Ada,
 843                              Src_Index => 0,
 844                              In_Array  => Defaults,
 845                              In_Tree   => In_Tree);
 846
 847                         if not Switches.Default then
 848                            Switch := Switches.Values;
 849
 850                            while Switch /= Nil_String loop
 851                               Add_Argument
 852                                 (Get_Name_String
 853                                    (In_Tree.String_Elements.Table
 854                                       (Switch).Value));
 855                               Switch := In_Tree.String_Elements.
 856                                           Table (Switch).Next;
 857                            end loop;
 858                         end if;
 859                      end if;
 860                   end;
 861                end if;
 862             end;
 863          end if;
 864
 865          --  Get all the ALI files of the project file. We do that even if
 866          --  Bind is False, so that First_ALI is set.
 867
 868          declare
 869             Unit : Unit_Data;
 870
 871          begin
 872             Library_ALIs.Reset;
 873             Interface_ALIs.Reset;
 874             Processed_ALIs.Reset;
 875
 876             for Source in Unit_Table.First ..
 877                           Unit_Table.Last (In_Tree.Units)
 878             loop
 879                Unit := In_Tree.Units.Table (Source);
 880
 881                if Unit.File_Names (Body_Part).Name /= No_Name
 882                  and then Unit.File_Names (Body_Part).Path /= Slash
 883                then
 884                   if
 885                     Check_Project (Unit.File_Names (Body_Part).Project)
 886                   then
 887                      if Unit.File_Names (Specification).Name = No_Name then
 888                         declare
 889                            Src_Ind : Source_File_Index;
 890
 891                         begin
 892                            Src_Ind := Sinput.P.Load_Project_File
 893                              (Get_Name_String
 894                                 (Unit.File_Names
 895                                    (Body_Part).Path));
 896
 897                            --  Add the ALI file only if it is not a subunit
 898
 899                            if
 900                            not Sinput.P.Source_File_Is_Subunit (Src_Ind)
 901                            then
 902                               Add_ALI_For
 903                                 (Unit.File_Names (Body_Part).Name);
 904                               exit when not Bind;
 905                            end if;
 906                         end;
 907
 908                      else
 909                         Add_ALI_For (Unit.File_Names (Body_Part).Name);
 910                         exit when not Bind;
 911                      end if;
 912                   end if;
 913
 914                elsif Unit.File_Names (Specification).Name /= No_Name
 915                  and then Unit.File_Names (Specification).Path /= Slash
 916                  and then Check_Project
 917                    (Unit.File_Names (Specification).Project)
 918                then
 919                   Add_ALI_For (Unit.File_Names (Specification).Name);
 920                   exit when not Bind;
 921                end if;
 922             end loop;
 923          end;
 924
 925          --  Continue setup and call gnatbind if Bind is True
 926
 927          if Bind then
 928
 929             --  Get an eventual --RTS from the ALI file
 930
 931             if First_ALI /= No_Name then
 932                declare
 933                   use Types;
 934                   T : Text_Buffer_Ptr;
 935                   A : ALI_Id;
 936
 937                begin
 938                   --  Load the ALI file
 939
 940                   T := Read_Library_Info (First_ALI, True);
 941
 942                   --  Read it
 943
 944                   A := Scan_ALI
 945                          (First_ALI, T, Ignore_ED => False, Err => False);
 946
 947                   if A /= No_ALI_Id then
 948                      for Index in
 949                        ALI.Units.Table
 950                          (ALI.ALIs.Table (A).First_Unit).First_Arg ..
 951                        ALI.Units.Table
 952                          (ALI.ALIs.Table (A).First_Unit).Last_Arg
 953                      loop
 954                         --  Look for --RTS. If found, add the switch to call
 955                         --  gnatbind.
 956
 957                         declare
 958                            Arg : String_Ptr renames Args.Table (Index);
 959                         begin
 960                            if Arg'Length >= 6 and then
 961                               Arg (Arg'First + 2 .. Arg'First + 5) = "RTS="
 962                            then
 963                               Add_Argument (Arg.all);
 964                               exit;
 965                            end if;
 966                         end;
 967                      end loop;
 968                   end if;
 969                end;
 970             end if;
 971
 972             --  Set the paths
 973
 974             Set_Ada_Paths
 975               (Project             => For_Project,
 976                In_Tree             => In_Tree,
 977                Including_Libraries => True);
 978
 979             --  Display the gnatbind command, if not in quiet output
 980
 981             Display (Gnatbind);
 982
 983             --  Invoke gnatbind
 984
 985             GNAT.OS_Lib.Spawn
 986               (Gnatbind_Path.all, Arguments (1 .. Argument_Number), Success);
 987
 988             if not Success then
 989                Com.Fail ("could not bind standalone library ",
 990                          Get_Name_String (Data.Library_Name));
 991             end if;
 992          end if;
 993
 994          --  Compile the binder generated file only if Link is true
 995
 996          if Link then
 997             --  Set the paths
 998
 999             Set_Ada_Paths
1000               (Project             => For_Project,
1001                In_Tree             => In_Tree,
1002                Including_Libraries => True);
1003
1004             --  Invoke <gcc> -c b$$<lib>.adb
1005
1006             --  Allocate Arguments, if it is the first time we see a standalone
1007             --  library.
1008
1009             if Arguments = No_Argument then
1010                Arguments := new String_List (1 .. Initial_Argument_Max);
1011             end if;
1012
1013             Argument_Number := 1;
1014             Arguments (1) := Compile_Switch;
1015
1016             if Hostparm.OpenVMS then
1017                B_Start (B_Start'Last) := '$';
1018             end if;
1019
1020             Add_Argument
1021               (B_Start & Get_Name_String (Data.Library_Name) & ".adb");
1022
1023             --  If necessary, add the PIC option
1024
1025             if PIC_Option /= "" then
1026                Add_Argument (PIC_Option);
1027             end if;
1028
1029             --  Get the back-end switches and --RTS from the ALI file
1030
1031             if First_ALI /= No_Name then
1032                declare
1033                   use Types;
1034                   T : Text_Buffer_Ptr;
1035                   A : ALI_Id;
1036
1037                begin
1038                   --  Load the ALI file
1039
1040                   T := Read_Library_Info (First_ALI, True);
1041
1042                   --  Read it
1043
1044                   A := Scan_ALI
1045                          (First_ALI, T, Ignore_ED => False, Err => False);
1046
1047                   if A /= No_ALI_Id then
1048                      for Index in
1049                        ALI.Units.Table
1050                          (ALI.ALIs.Table (A).First_Unit).First_Arg ..
1051                        ALI.Units.Table
1052                          (ALI.ALIs.Table (A).First_Unit).Last_Arg
1053                      loop
1054                         --  Do not compile with the front end switches except
1055                         --  for --RTS.
1056
1057                         declare
1058                            Arg : String_Ptr renames Args.Table (Index);
1059                         begin
1060                            if not Is_Front_End_Switch (Arg.all)
1061                              or else
1062                                Arg (Arg'First + 2 .. Arg'First + 5) = "RTS="
1063                            then
1064                               Add_Argument (Arg.all);
1065                            end if;
1066                         end;
1067                      end loop;
1068                   end if;
1069                end;
1070             end if;
1071
1072             --  Now that all the arguments are set, compile the binder
1073             --  generated file.
1074
1075             Display (Gcc);
1076             GNAT.OS_Lib.Spawn
1077               (Gcc_Path.all, Arguments (1 .. Argument_Number), Success);
1078
1079             if not Success then
1080                Com.Fail
1081                  ("could not compile binder generated file for library ",
1082                   Get_Name_String (Data.Library_Name));
1083             end if;
1084
1085             --  Process binder generated file for pragmas Linker_Options
1086
1087             Process_Binder_File (Arguments (2).all & ASCII.NUL);
1088          end if;
1089       end if;
1090
1091       --  Build the library only if Link is True
1092
1093       if Link then
1094          --  If attribute Library_GCC was specified, get the driver name
1095
1096          Library_GCC :=
1097            Value_Of (Name_Library_GCC, Data.Decl.Attributes, In_Tree);
1098
1099          if not Library_GCC.Default then
1100             Driver_Name := Library_GCC.Value;
1101          end if;
1102
1103          --  If attribute Library_Options was specified, add these additional
1104          --  options.
1105
1106          Library_Options :=
1107            Value_Of (Name_Library_Options, Data.Decl.Attributes, In_Tree);
1108
1109          if not Library_Options.Default then
1110             declare
1111                Current : String_List_Id := Library_Options.Values;
1112                Element : String_Element;
1113
1114             begin
1115                while Current /= Nil_String loop
1116                   Element :=
1117                     In_Tree.String_Elements.Table (Current);
1118                   Get_Name_String (Element.Value);
1119
1120                   if Name_Len /= 0 then
1121                      Opts.Increment_Last;
1122                      Opts.Table (Opts.Last) :=
1123                        new String'(Name_Buffer (1 .. Name_Len));
1124                   end if;
1125
1126                   Current := Element.Next;
1127                end loop;
1128             end;
1129          end if;
1130
1131          Lib_Dirpath  := new String'(Get_Name_String (Data.Library_Dir));
1132          Lib_Filename := new String'(Get_Name_String (Data.Library_Name));
1133
1134          case Data.Library_Kind is
1135             when Static =>
1136                The_Build_Mode := Static;
1137
1138             when Dynamic =>
1139                The_Build_Mode := Dynamic;
1140
1141             when Relocatable =>
1142                The_Build_Mode := Relocatable;
1143
1144                if PIC_Option /= "" then
1145                   Opts.Increment_Last;
1146                   Opts.Table (Opts.Last) := new String'(PIC_Option);
1147                end if;
1148          end case;
1149
1150          --  Get the library version, if any
1151
1152          if Data.Lib_Internal_Name /= No_Name then
1153             Lib_Version :=
1154               new String'(Get_Name_String (Data.Lib_Internal_Name));
1155          end if;
1156
1157          --  Add the objects found in the object directory and the object
1158          --  directories of the extended files, if any, except for generated
1159          --  object files (b~.. or B$..) from extended projects.
1160          --  When there are one or more extended files, only add an object file
1161          --  if no object file with the same name have already been added.
1162
1163          In_Main_Object_Directory := True;
1164
1165          loop
1166             declare
1167                Object_Dir_Path : constant String :=
1168                                    Get_Name_String (Data.Object_Directory);
1169                Object_Dir      : Dir_Type;
1170                Filename        : String (1 .. 255);
1171                Last            : Natural;
1172                Id              : Name_Id;
1173
1174             begin
1175                Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path);
1176
1177                --  For all entries in the object directory
1178
1179                loop
1180                   Read (Object_Dir, Filename, Last);
1181
1182                   exit when Last = 0;
1183
1184                   --  Check if it is an object file
1185
1186                   if Is_Obj (Filename (1 .. Last)) then
1187                      declare
1188                         Object_Path : String :=
1189                           Normalize_Pathname
1190                             (Object_Dir_Path & Directory_Separator &
1191                              Filename (1 .. Last));
1192
1193                      begin
1194                         Canonical_Case_File_Name (Object_Path);
1195                         Canonical_Case_File_Name (Filename (1 .. Last));
1196
1197                         --  If in the object directory of an extended project,
1198                         --  do not consider generated object files.
1199
1200                         if In_Main_Object_Directory
1201                           or else Last < 5
1202                           or else Filename (1 .. B_Start'Length) /= B_Start
1203                         then
1204                            Name_Len := Last;
1205                            Name_Buffer (1 .. Name_Len) := Filename (1 .. Last);
1206                            Id := Name_Find;
1207
1208                            if not Objects_Htable.Get (Id) then
1209
1210                               --  Record this object file
1211
1212                               Objects_Htable.Set (Id, True);
1213                               Objects.Increment_Last;
1214                               Objects.Table (Objects.Last) :=
1215                                 new String'(Object_Path);
1216
1217                               declare
1218                                  ALI_File : constant String :=
1219                                               Ext_To (Object_Path, "ali");
1220
1221                               begin
1222                                  if Is_Regular_File (ALI_File) then
1223
1224                                     --  Record the ALI file
1225
1226                                     ALIs.Increment_Last;
1227                                     ALIs.Table (ALIs.Last) :=
1228                                       new String'(ALI_File);
1229
1230                                     --  Find out if for this ALI file,
1231                                     --  libgnarl or libdecgnat or g-trasym.obj
1232                                     --  (on OpenVMS) is necessary.
1233
1234                                     Check_Libs (ALI_File);
1235
1236                                  else
1237                                     --  Object file is a foreign object file
1238
1239                                     Foreigns.Increment_Last;
1240                                     Foreigns.Table (Foreigns.Last) :=
1241                                       new String'(Object_Path);
1242                                  end if;
1243                               end;
1244                            end if;
1245                         end if;
1246                      end;
1247                   end if;
1248                end loop;
1249
1250                Close (Dir => Object_Dir);
1251
1252             exception
1253                when Directory_Error =>
1254                   Com.Fail ("cannot find object directory """,
1255                             Get_Name_String (Data.Object_Directory),
1256                             """");
1257             end;
1258
1259             exit when Data.Extends = No_Project;
1260
1261             In_Main_Object_Directory  := False;
1262             Data := In_Tree.Projects.Table (Data.Extends);
1263          end loop;
1264
1265          --  Add the -L and -l switches for the imported Library Project Files,
1266          --  and, if Path Option is supported, the library directory path names
1267          --  to Rpath.
1268
1269          Process_Imported_Libraries;
1270
1271          --  Link with libgnat and possibly libgnarl
1272
1273          Opts.Increment_Last;
1274          Opts.Table (Opts.Last) := new String'("-L" & Lib_Directory);
1275
1276          --  If Path Option is supported, add libgnat directory path name to
1277          --  Rpath.
1278
1279          if Path_Option /= null then
1280             Add_Rpath (Lib_Directory);
1281          end if;
1282
1283          if Libgnarl_Needed then
1284             Opts.Increment_Last;
1285
1286             if The_Build_Mode = Static then
1287                Opts.Table (Opts.Last) := new String'("-lgnarl");
1288             else
1289                Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnarl"));
1290             end if;
1291          end if;
1292
1293          if Gtrasymobj_Needed then
1294             Opts.Increment_Last;
1295             Opts.Table (Opts.Last) :=
1296               new String'(Lib_Directory & "/g-trasym.obj");
1297          end if;
1298
1299          if Libdecgnat_Needed then
1300             Opts.Increment_Last;
1301             Opts.Table (Opts.Last) :=
1302               new String'("-L" & Lib_Directory & "/../declib");
1303             Opts.Increment_Last;
1304             Opts.Table (Opts.Last) := new String'("-ldecgnat");
1305          end if;
1306
1307          Opts.Increment_Last;
1308
1309          if The_Build_Mode = Static then
1310             Opts.Table (Opts.Last) := new String'("-lgnat");
1311          else
1312             Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnat"));
1313          end if;
1314
1315          --  If Path Option is supported, add the necessary switch with the
1316          --  content of Rpath. As Rpath contains at least libgnat directory
1317          --  path name, it is guaranteed that it is not null.
1318
1319          if Path_Option /= null then
1320             Opts.Increment_Last;
1321             Opts.Table (Opts.Last) :=
1322               new String'(Path_Option.all & Rpath (1 .. Rpath_Last));
1323             Free (Path_Option);
1324             Free (Rpath);
1325          end if;
1326
1327          Object_Files :=
1328            new Argument_List'
1329              (Argument_List (Objects.Table (1 .. Objects.Last)));
1330
1331          Foreign_Objects :=
1332            new Argument_List'(Argument_List
1333                                 (Foreigns.Table (1 .. Foreigns.Last)));
1334
1335          Ali_Files :=
1336            new Argument_List'(Argument_List (ALIs.Table (1 .. ALIs.Last)));
1337
1338          Options :=
1339            new Argument_List'(Argument_List (Opts.Table (1 .. Opts.Last)));
1340
1341          --  We fail if there are no object to put in the library
1342          --  (Ada or foreign objects).
1343
1344          if Object_Files'Length = 0 then
1345             Com.Fail ("no object files for library """ &
1346                       Lib_Filename.all & '"');
1347          end if;
1348
1349          if not Opt.Quiet_Output then
1350             Write_Eol;
1351             Write_Str  ("building ");
1352             Write_Str (Ada.Characters.Handling.To_Lower
1353                          (Build_Mode_State'Image (The_Build_Mode)));
1354             Write_Str  (" library for project ");
1355             Write_Line (Project_Name);
1356
1357             Write_Eol;
1358
1359             Write_Line ("object files:");
1360
1361             for Index in Object_Files'Range loop
1362                Write_Str  ("   ");
1363                Write_Line (Object_Files (Index).all);
1364             end loop;
1365
1366             Write_Eol;
1367
1368             if Ali_Files'Length = 0 then
1369                Write_Line ("NO ALI files");
1370
1371             else
1372                Write_Line ("ALI files:");
1373
1374                for Index in Ali_Files'Range loop
1375                   Write_Str  ("   ");
1376                   Write_Line (Ali_Files (Index).all);
1377                end loop;
1378             end if;
1379
1380             Write_Eol;
1381          end if;
1382
1383          --  We check that all object files are regular files
1384
1385          Check_Context;
1386
1387          --  Delete the existing library file, if it exists.
1388          --  Fail if the library file is not writable, or if it is not possible
1389          --  to delete the file.
1390
1391          declare
1392             DLL_Name : aliased String :=
1393                          Lib_Dirpath.all & "/lib" &
1394                            Lib_Filename.all & "." & DLL_Ext;
1395
1396             Archive_Name : aliased String :=
1397                              Lib_Dirpath.all & "/lib" &
1398                                Lib_Filename.all & "." & Archive_Ext;
1399
1400             type Str_Ptr is access all String;
1401             --  This type is necessary to meet the accessibility rules of Ada.
1402             --  It is not possible to use String_Access here.
1403
1404             Full_Lib_Name : Str_Ptr;
1405             --  Designates the full library path name. Either DLL_Name or
1406             --  Archive_Name, depending on the library kind.
1407
1408             Success : Boolean := False;
1409             --  Used to call Delete_File
1410
1411          begin
1412             if The_Build_Mode = Static then
1413                Full_Lib_Name := Archive_Name'Access;
1414             else
1415                Full_Lib_Name := DLL_Name'Access;
1416             end if;
1417
1418             if Is_Regular_File (Full_Lib_Name.all) then
1419                if Is_Writable_File (Full_Lib_Name.all) then
1420                   Delete_File (Full_Lib_Name.all, Success);
1421                end if;
1422
1423                if Is_Regular_File (Full_Lib_Name.all) then
1424                   Com.Fail ("could not delete """ & Full_Lib_Name.all & """");
1425                end if;
1426             end if;
1427          end;
1428
1429          Argument_Number := 0;
1430
1431          --  If we have a standalone library, gather all the interface ALI.
1432          --  They are passed to Build_Dynamic_Library, where they are used by
1433          --  some platforms (VMS, for example) to decide what symbols should be
1434          --  exported. They are also flagged as Interface when we copy them to
1435          --  the library directory (by Copy_ALI_Files, below).
1436
1437          if Standalone then
1438             Data := In_Tree.Projects.Table (For_Project);
1439
1440             declare
1441                Iface : String_List_Id := Data.Lib_Interface_ALIs;
1442                ALI   : File_Name_Type;
1443
1444             begin
1445                while Iface /= Nil_String loop
1446                   ALI :=
1447                     In_Tree.String_Elements.Table (Iface).Value;
1448                   Interface_ALIs.Set (ALI, True);
1449                   Get_Name_String
1450                     (In_Tree.String_Elements.Table (Iface).Value);
1451                   Add_Argument (Name_Buffer (1 .. Name_Len));
1452                   Iface :=
1453                     In_Tree.String_Elements.Table (Iface).Next;
1454                end loop;
1455
1456                Iface := Data.Lib_Interface_ALIs;
1457
1458                if not Opt.Quiet_Output then
1459
1460                   --  Check that the interface set is complete: any unit in the
1461                   --  library that is needed by an interface should also be an
1462                   --  interface. If it is not the case, output a warning.
1463
1464                   while Iface /= Nil_String loop
1465                      ALI := In_Tree.String_Elements.Table
1466                               (Iface).Value;
1467                      Process (ALI);
1468                      Iface :=
1469                        In_Tree.String_Elements.Table (Iface).Next;
1470                   end loop;
1471                end if;
1472             end;
1473          end if;
1474
1475          --  Clean the library directory, if it is also the directory where
1476          --  the ALI files are copied, either because there is no interface
1477          --  copy directory or because the interface copy directory is the
1478          --  same as the library directory.
1479
1480          Copy_Dir :=
1481            In_Tree.Projects.Table (For_Project).Library_Dir;
1482          Clean (Copy_Dir);
1483
1484          --  Call procedure to build the library, depending on the build mode
1485
1486          case The_Build_Mode is
1487             when Dynamic | Relocatable =>
1488                Build_Dynamic_Library
1489                  (Ofiles        => Object_Files.all,
1490                   Foreign       => Foreign_Objects.all,
1491                   Afiles        => Ali_Files.all,
1492                   Options       => Options.all,
1493                   Options_2     => No_Argument_List,
1494                   Interfaces    => Arguments (1 .. Argument_Number),
1495                   Lib_Filename  => Lib_Filename.all,
1496                   Lib_Dir       => Lib_Dirpath.all,
1497                   Symbol_Data   => Data.Symbol_Data,
1498                   Driver_Name   => Driver_Name,
1499                   Lib_Version   => Lib_Version.all,
1500                   Auto_Init     => Data.Lib_Auto_Init);
1501
1502             when Static =>
1503                MLib.Build_Library
1504                  (Object_Files.all,
1505                   Ali_Files.all,
1506                   Lib_Filename.all,
1507                   Lib_Dirpath.all);
1508
1509             when None =>
1510                null;
1511          end case;
1512
1513          --  We need to copy the ALI files from the object directory to
1514          --  the library directory, so that the linker find them there,
1515          --  and does not need to look in the object directory where it
1516          --  would also find the object files; and we don't want that:
1517          --  we want the linker to use the library.
1518
1519          --  Copy the ALI files and make the copies read-only. For interfaces,
1520          --  mark the copies as interfaces.
1521
1522          Copy_ALI_Files
1523            (Files      => Ali_Files.all,
1524             To         => Copy_Dir,
1525             Interfaces => Arguments (1 .. Argument_Number));
1526
1527          --  Copy interface sources if Library_Src_Dir specified
1528
1529          if Standalone
1530            and then In_Tree.Projects.Table
1531                       (For_Project).Library_Src_Dir /= No_Name
1532          then
1533             --  Clean the interface copy directory, if it is not also the
1534             --  library directory. If it is also the library directory, it
1535             --  has already been cleaned before generation of the library.
1536
1537             if In_Tree.Projects.Table
1538               (For_Project).Library_Src_Dir /= Copy_Dir
1539             then
1540                Copy_Dir := In_Tree.Projects.Table
1541                              (For_Project).Library_Src_Dir;
1542                Clean (Copy_Dir);
1543             end if;
1544
1545             Copy_Interface_Sources
1546               (For_Project => For_Project,
1547                In_Tree     => In_Tree,
1548                Interfaces  => Arguments (1 .. Argument_Number),
1549                To_Dir      => Copy_Dir);
1550          end if;
1551       end if;
1552
1553       --  Reset the current working directory to its previous value
1554
1555       Change_Dir (Current_Dir);
1556    end Build_Library;
1557
1558    -----------
1559    -- Check --
1560    -----------
1561
1562    procedure Check (Filename : String) is
1563    begin
1564       if not Is_Regular_File (Filename) then
1565          Com.Fail (Filename, " not found.");
1566       end if;
1567    end Check;
1568
1569    -------------------
1570    -- Check_Context --
1571    -------------------
1572
1573    procedure Check_Context is
1574    begin
1575       --  Check that each object file exists
1576
1577       for F in Object_Files'Range loop
1578          Check (Object_Files (F).all);
1579       end loop;
1580    end Check_Context;
1581
1582    -------------------
1583    -- Check_Library --
1584    -------------------
1585
1586    procedure Check_Library
1587      (For_Project : Project_Id; In_Tree : Project_Tree_Ref)
1588    is
1589       Data : constant Project_Data :=
1590                In_Tree.Projects.Table (For_Project);
1591
1592    begin
1593       --  No need to build the library if there is no object directory,
1594       --  hence no object files to build the library.
1595
1596       if Data.Library
1597         and then not Data.Need_To_Build_Lib
1598         and then Data.Object_Directory /= No_Name
1599       then
1600          declare
1601             Current  : constant Dir_Name_Str := Get_Current_Dir;
1602             Lib_Name : constant Name_Id :=
1603                          Library_File_Name_For (For_Project, In_Tree);
1604             Lib_TS   : Time_Stamp_Type;
1605             Obj_TS   : Time_Stamp_Type;
1606
1607             Object_Dir : Dir_Type;
1608
1609          begin
1610             if Hostparm.OpenVMS then
1611                B_Start (B_Start'Last) := '$';
1612             end if;
1613
1614             Change_Dir (Get_Name_String (Data.Library_Dir));
1615
1616             Lib_TS := File_Stamp (Lib_Name);
1617
1618             --  If the library file does not exist, then the time stamp will
1619             --  be Empty_Time_Stamp, earlier than any other time stamp.
1620
1621             Change_Dir (Get_Name_String (Data.Object_Directory));
1622             Open (Dir => Object_Dir, Dir_Name => ".");
1623
1624             --  For all entries in the object directory
1625
1626             loop
1627                Read (Object_Dir, Name_Buffer, Name_Len);
1628                exit when Name_Len = 0;
1629
1630                --  Check if it is an object file, but ignore any binder
1631                --  generated file.
1632
1633                if Is_Obj (Name_Buffer (1 .. Name_Len))
1634                   and then Name_Buffer (1 .. B_Start'Length) /= B_Start
1635                then
1636                   --  Get the object file time stamp
1637
1638                   Obj_TS := File_Stamp (Name_Find);
1639
1640                   --  If library file time stamp is earlier, set
1641                   --  Need_To_Build_Lib and return. String comparaison is used,
1642                   --  otherwise time stamps may be too close and the
1643                   --  comparaison would return True, which would trigger
1644                   --  an unnecessary rebuild of the library.
1645
1646                   if String (Lib_TS) < String (Obj_TS) then
1647
1648                      --  Library must be rebuilt
1649
1650                      In_Tree.Projects.Table
1651                        (For_Project).Need_To_Build_Lib := True;
1652                      exit;
1653                   end if;
1654                end if;
1655             end loop;
1656
1657             Change_Dir (Current);
1658          end;
1659       end if;
1660    end Check_Library;
1661
1662    -----------
1663    -- Clean --
1664    -----------
1665
1666    procedure Clean (Directory : Name_Id) is
1667       Current  : constant Dir_Name_Str := Get_Current_Dir;
1668
1669       Dir : Dir_Type;
1670
1671       Name : String (1 .. 200);
1672       Last : Natural;
1673
1674       Disregard : Boolean;
1675
1676    begin
1677       Get_Name_String (Directory);
1678
1679       --  Change the working directory to the directory to clean
1680
1681       begin
1682          Change_Dir (Name_Buffer (1 .. Name_Len));
1683
1684       exception
1685          when others =>
1686             Com.Fail
1687               ("unable to access directory """,
1688                Name_Buffer (1 .. Name_Len),
1689                """");
1690       end;
1691
1692       Open (Dir, ".");
1693
1694       --  For each regular file in the directory, make it writable and
1695       --  delete the file.
1696
1697       loop
1698          Read (Dir, Name, Last);
1699          exit when Last = 0;
1700
1701          if Is_Regular_File (Name (1 .. Last)) then
1702             Set_Writable (Name (1 .. Last));
1703             Delete_File (Name (1 .. Last), Disregard);
1704          end if;
1705       end loop;
1706
1707       Close (Dir);
1708
1709       --  Restore the initial working directory
1710
1711       Change_Dir (Current);
1712    end Clean;
1713
1714    ----------------------------
1715    -- Copy_Interface_Sources --
1716    ----------------------------
1717
1718    procedure Copy_Interface_Sources
1719      (For_Project : Project_Id;
1720       In_Tree     : Project_Tree_Ref;
1721       Interfaces  : Argument_List;
1722       To_Dir      : Name_Id)
1723    is
1724       Current  : constant Dir_Name_Str := Get_Current_Dir;
1725       Target   : constant Dir_Name_Str := Get_Name_String (To_Dir);
1726
1727       Text     : Text_Buffer_Ptr;
1728       The_ALI  : ALI.ALI_Id;
1729       Lib_File : Name_Id;
1730
1731       First_Unit  : ALI.Unit_Id;
1732       Second_Unit : ALI.Unit_Id;
1733
1734       Data : Unit_Data;
1735
1736       Copy_Subunits : Boolean := False;
1737
1738       procedure Copy (File_Name : Name_Id);
1739       --  Copy one source of the project to the target directory
1740
1741       ----------
1742       -- Copy --
1743       ----------
1744
1745       procedure Copy (File_Name : Name_Id) is
1746          Success : Boolean := False;
1747
1748       begin
1749          Unit_Loop :
1750          for Index in Unit_Table.First ..
1751                       Unit_Table.Last (In_Tree.Units)
1752          loop
1753             Data := In_Tree.Units.Table (Index);
1754
1755             for J in Data.File_Names'Range loop
1756                if Data.File_Names (J).Project = For_Project
1757                  and then Data.File_Names (J).Name = File_Name
1758                then
1759                   Copy_File
1760                     (Get_Name_String (Data.File_Names (J).Path),
1761                      Target,
1762                      Success,
1763                      Mode => Overwrite,
1764                      Preserve => Preserve);
1765                   exit Unit_Loop;
1766                end if;
1767             end loop;
1768          end loop Unit_Loop;
1769       end Copy;
1770
1771       use ALI;
1772
1773    --  Start of processing for Copy_Interface_Sources
1774
1775    begin
1776       --  Change the working directory to the object directory
1777
1778       Change_Dir
1779         (Get_Name_String
1780            (In_Tree.Projects.Table
1781               (For_Project).Object_Directory));
1782
1783       for Index in Interfaces'Range loop
1784
1785          --  First, load the ALI file
1786
1787          Name_Len := 0;
1788          Add_Str_To_Name_Buffer (Interfaces (Index).all);
1789          Lib_File := Name_Find;
1790          Text := Read_Library_Info (Lib_File);
1791          The_ALI := Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
1792          Free (Text);
1793
1794          Second_Unit := No_Unit_Id;
1795          First_Unit := ALI.ALIs.Table (The_ALI).First_Unit;
1796          Copy_Subunits := True;
1797
1798          --  If there is both a spec and a body, check if they are both needed
1799
1800          if ALI.Units.Table (First_Unit).Utype = Is_Body then
1801             Second_Unit := ALI.ALIs.Table (The_ALI).Last_Unit;
1802
1803             --  If the body is not needed, then reset First_Unit
1804
1805             if not ALI.Units.Table (Second_Unit).Body_Needed_For_SAL then
1806                First_Unit := No_Unit_Id;
1807                Copy_Subunits := False;
1808             end if;
1809
1810          elsif ALI.Units.Table (First_Unit).Utype = Is_Spec_Only then
1811             Copy_Subunits := False;
1812          end if;
1813
1814          --  Copy the file(s) that need to be copied
1815
1816          if First_Unit /= No_Unit_Id then
1817             Copy (File_Name => ALI.Units.Table (First_Unit).Sfile);
1818          end if;
1819
1820          if Second_Unit /= No_Unit_Id then
1821             Copy (File_Name => ALI.Units.Table (Second_Unit).Sfile);
1822          end if;
1823
1824          --  Copy all the separates, if any
1825
1826          if Copy_Subunits then
1827             for Dep in ALI.ALIs.Table (The_ALI).First_Sdep ..
1828               ALI.ALIs.Table (The_ALI).Last_Sdep
1829             loop
1830                if Sdep.Table (Dep).Subunit_Name /= No_Name then
1831                   Copy (File_Name => Sdep.Table (Dep).Sfile);
1832                end if;
1833             end loop;
1834          end if;
1835       end loop;
1836
1837       --  Restore the initial working directory
1838
1839       Change_Dir (Current);
1840    end Copy_Interface_Sources;
1841
1842    -------------
1843    -- Display --
1844    -------------
1845
1846    procedure Display (Executable : String) is
1847    begin
1848       if not Opt.Quiet_Output then
1849          Write_Str (Executable);
1850
1851          for Index in 1 .. Argument_Number loop
1852             Write_Char (' ');
1853             Write_Str (Arguments (Index).all);
1854          end loop;
1855
1856          Write_Eol;
1857       end if;
1858    end Display;
1859
1860    -------------------------
1861    -- Process_Binder_File --
1862    -------------------------
1863
1864    procedure Process_Binder_File (Name : String) is
1865       Fd : FILEs;
1866       --  Binder file's descriptor
1867
1868       Read_Mode  : constant String := "r" & ASCII.Nul;
1869       --  For fopen
1870
1871       Status : Interfaces.C_Streams.int;
1872       pragma Unreferenced (Status);
1873       --  For fclose
1874
1875       Begin_Info : constant String := "--  BEGIN Object file/option list";
1876       End_Info   : constant String := "--  END Object file/option list   ";
1877
1878       Next_Line : String (1 .. 1000);
1879       --  Current line value
1880       --  Where does this odd constant 1000 come from, looks suspicious ???
1881
1882       Nlast : Integer;
1883       --  End of line slice (the slice does not contain the line terminator)
1884
1885       procedure Get_Next_Line;
1886       --  Read the next line from the binder file without the line terminator
1887
1888       -------------------
1889       -- Get_Next_Line --
1890       -------------------
1891
1892       procedure Get_Next_Line is
1893          Fchars : chars;
1894
1895       begin
1896          Fchars := fgets (Next_Line'Address, Next_Line'Length, Fd);
1897
1898          if Fchars = System.Null_Address then
1899             Fail ("Error reading binder output");
1900          end if;
1901
1902          Nlast := 1;
1903          while Nlast <= Next_Line'Last
1904            and then Next_Line (Nlast) /= ASCII.LF
1905            and then Next_Line (Nlast) /= ASCII.CR
1906          loop
1907             Nlast := Nlast + 1;
1908          end loop;
1909
1910          Nlast := Nlast - 1;
1911       end Get_Next_Line;
1912
1913    --  Start of processing for Process_Binder_File
1914
1915    begin
1916       Fd := fopen (Name'Address, Read_Mode'Address);
1917
1918       if Fd = NULL_Stream then
1919          Fail ("Failed to open binder output");
1920       end if;
1921
1922       --  Skip up to the Begin Info line
1923
1924       loop
1925          Get_Next_Line;
1926          exit when Next_Line (1 .. Nlast) = Begin_Info;
1927       end loop;
1928
1929       --  Find the first switch
1930
1931       loop
1932          Get_Next_Line;
1933
1934          exit when Next_Line (1 .. Nlast) = End_Info;
1935
1936          --  As the binder generated file is in Ada, remove the first eight
1937          --  characters "   --   ".
1938
1939          Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast);
1940          Nlast := Nlast - 8;
1941
1942          --  Stop when the first switch is found
1943
1944          exit when Next_Line (1) = '-';
1945       end loop;
1946
1947       if Next_Line (1 .. Nlast) /= End_Info then
1948          loop
1949             --  Ignore -static and -shared, since -shared will be used
1950             --  in any case.
1951
1952             --  Ignore -lgnat, -lgnarl and -ldecgnat as they will be added
1953             --  later, because they are also needed for non Stand-Alone shared
1954             --  libraries.
1955
1956             --  Also ignore the shared libraries which are :
1957
1958             --  UNIX / Windows    VMS
1959             --  -lgnat-<version>  -lgnat_<version>  (7 + version'length chars)
1960             --  -lgnarl-<version> -lgnarl_<version> (8 + version'length chars)
1961
1962             if Next_Line (1 .. Nlast) /= "-static" and then
1963                Next_Line (1 .. Nlast) /= "-shared" and then
1964                Next_Line (1 .. Nlast) /= "-ldecgnat" and then
1965                Next_Line (1 .. Nlast) /= "-lgnarl" and then
1966                Next_Line (1 .. Nlast) /= "-lgnat" and then
1967                Next_Line
1968                  (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) /=
1969                    Shared_Lib ("gnarl") and then
1970                Next_Line
1971                  (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) /=
1972                    Shared_Lib ("gnat")
1973             then
1974                if Next_Line (1) /= '-' then
1975
1976                   --  This is not an option, should we add it?
1977
1978                   if Add_Object_Files then
1979                      Opts.Increment_Last;
1980                      Opts.Table (Opts.Last) :=
1981                        new String'(Next_Line (1 .. Nlast));
1982                   end if;
1983
1984                else
1985                   --  Add all other options
1986
1987                   Opts.Increment_Last;
1988                   Opts.Table (Opts.Last) :=
1989                     new String'(Next_Line (1 .. Nlast));
1990                end if;
1991             end if;
1992
1993             --  Next option, if any
1994
1995             Get_Next_Line;
1996             exit when Next_Line (1 .. Nlast) = End_Info;
1997
1998             --  Remove first eight characters "   --   "
1999
2000             Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast);
2001             Nlast := Nlast - 8;
2002          end loop;
2003       end if;
2004
2005       Status := fclose (Fd);
2006       --  Is it really right to ignore any close error ???
2007    end Process_Binder_File;
2008
2009    ------------------
2010    -- Reset_Tables --
2011    ------------------
2012
2013    procedure Reset_Tables is
2014    begin
2015       Objects.Init;
2016       Objects_Htable.Reset;
2017       Foreigns.Init;
2018       ALIs.Init;
2019       Opts.Init;
2020       Processed_Projects.Reset;
2021       Library_Projs.Init;
2022    end Reset_Tables;
2023
2024 end MLib.Prj;