gcc/ada/mlib-tgt-vms-alpha.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             M L I B . T G T                              --
   6 --                           (Alpha VMS Version)                            --
   7 --                                                                          --
   8 --                                 B o d y                                  --
   9 --                                                                          --
  10 --          Copyright (C) 2003-2004, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 --  This is the Alpha VMS version of the body
  29
  30 with Ada.Characters.Handling; use Ada.Characters.Handling;
  31
  32 with GNAT.Directory_Operations;  use GNAT.Directory_Operations;
  33 with GNAT.OS_Lib;                use GNAT.OS_Lib;
  34
  35 with MLib.Fil;
  36 with MLib.Utl;
  37 with Namet;             use Namet;
  38 with Opt;               use Opt;
  39 with Output;            use Output;
  40 with Prj.Com;
  41 with System;            use System;
  42 with System.Case_Util;  use System.Case_Util;
  43
  44 package body MLib.Tgt is
  45
  46    use GNAT;
  47
  48    Empty_Argument_List : aliased Argument_List := (1 .. 0 => null);
  49    Additional_Objects  : Argument_List_Access := Empty_Argument_List'Access;
  50    --  Used to add the generated auto-init object files for auto-initializing
  51    --  stand-alone libraries.
  52
  53    Macro_Name   : constant String := "mcr gnu:[bin]gcc -c -x assembler";
  54    --  The name of the command to invoke the macro-assembler
  55
  56    VMS_Options : Argument_List := (1 .. 1 => null);
  57
  58    Gnatsym_Name : constant String := "gnatsym";
  59
  60    Gnatsym_Path : String_Access;
  61
  62    Arguments : Argument_List_Access := null;
  63    Last_Argument : Natural := 0;
  64
  65    Success : Boolean := False;
  66
  67    Shared_Libgcc : aliased String := "-shared-libgcc";
  68
  69    No_Shared_Libgcc_Switch : aliased Argument_List := (1 .. 0 => null);
  70    Shared_Libgcc_Switch    : aliased Argument_List :=
  71                                (1 => Shared_Libgcc'Access);
  72    Link_With_Shared_Libgcc : Argument_List_Access :=
  73                                No_Shared_Libgcc_Switch'Access;
  74
  75    ------------------------------
  76    -- Target dependent section --
  77    ------------------------------
  78
  79    function Popen (Command, Mode : System.Address) return System.Address;
  80    pragma Import (C, Popen);
  81
  82    function Pclose (File : System.Address) return Integer;
  83    pragma Import (C, Pclose);
  84
  85    ---------------------
  86    -- Archive_Builder --
  87    ---------------------
  88
  89    function Archive_Builder return String is
  90    begin
  91       return "ar";
  92    end Archive_Builder;
  93
  94    -----------------------------
  95    -- Archive_Builder_Options --
  96    -----------------------------
  97
  98    function Archive_Builder_Options return String_List_Access is
  99    begin
 100       return new String_List'(1 => new String'("cr"));
 101    end Archive_Builder_Options;
 102
 103    -----------------
 104    -- Archive_Ext --
 105    -----------------
 106
 107    function Archive_Ext return String is
 108    begin
 109       return "olb";
 110    end Archive_Ext;
 111
 112    ---------------------
 113    -- Archive_Indexer --
 114    ---------------------
 115
 116    function Archive_Indexer return String is
 117    begin
 118       return "ranlib";
 119    end Archive_Indexer;
 120
 121    -----------------------------
 122    -- Archive_Indexer_Options --
 123    -----------------------------
 124
 125    function Archive_Indexer_Options return String_List_Access is
 126    begin
 127       return new String_List (1 .. 0);
 128    end Archive_Indexer_Options;
 129
 130    ---------------------------
 131    -- Build_Dynamic_Library --
 132    ---------------------------
 133
 134    procedure Build_Dynamic_Library
 135      (Ofiles       : Argument_List;
 136       Foreign      : Argument_List;
 137       Afiles       : Argument_List;
 138       Options      : Argument_List;
 139       Options_2    : Argument_List;
 140       Interfaces   : Argument_List;
 141       Lib_Filename : String;
 142       Lib_Dir      : String;
 143       Symbol_Data  : Symbol_Record;
 144       Driver_Name  : Name_Id := No_Name;
 145       Lib_Version  : String  := "";
 146       Auto_Init    : Boolean := False)
 147    is
 148       pragma Unreferenced (Foreign);
 149       pragma Unreferenced (Afiles);
 150
 151       Lib_File : constant String :=
 152                    Lib_Dir & Directory_Separator & "lib" &
 153                    Fil.Ext_To (Lib_Filename, DLL_Ext);
 154
 155       Opts      : Argument_List := Options;
 156       Last_Opt  : Natural       := Opts'Last;
 157       Opts2     : Argument_List (Options'Range);
 158       Last_Opt2 : Natural       := Opts2'First - 1;
 159
 160       Inter : constant Argument_List := Interfaces;
 161
 162       function Is_Interface (Obj_File : String) return Boolean;
 163       --  For a Stand-Alone Library, returns True if Obj_File is the object
 164       --  file name of an interface of the SAL. For other libraries, always
 165       --  return True.
 166
 167       function Option_File_Name return String;
 168       --  Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"
 169
 170       function Version_String return String;
 171       --  Returns Lib_Version if not empty, otherwise returns "1".
 172       --  Fails gnatmake if Lib_Version is not the image of a positive number.
 173
 174       ------------------
 175       -- Is_Interface --
 176       ------------------
 177
 178       function Is_Interface (Obj_File : String) return Boolean is
 179          ALI : constant String :=
 180                  Fil.Ext_To
 181                   (Filename => To_Lower (Base_Name (Obj_File)),
 182                    New_Ext  => "ali");
 183
 184       begin
 185          if Inter'Length = 0 then
 186             return True;
 187
 188          elsif ALI'Length > 2 and then
 189                ALI (ALI'First .. ALI'First + 1) = "b$"
 190          then
 191             return True;
 192
 193          else
 194             for J in Inter'Range loop
 195                if Inter (J).all = ALI then
 196                   return True;
 197                end if;
 198             end loop;
 199
 200             return False;
 201          end if;
 202       end Is_Interface;
 203
 204       ----------------------
 205       -- Option_File_Name --
 206       ----------------------
 207
 208       function Option_File_Name return String is
 209       begin
 210          if Symbol_Data.Symbol_File = No_Name then
 211             return "symvec.opt";
 212          else
 213             Get_Name_String (Symbol_Data.Symbol_File);
 214             To_Lower (Name_Buffer (1 .. Name_Len));
 215             return Name_Buffer (1 .. Name_Len);
 216          end if;
 217       end Option_File_Name;
 218
 219       --------------------
 220       -- Version_String --
 221       --------------------
 222
 223       function Version_String return String is
 224          Version : Integer := 0;
 225       begin
 226          if Lib_Version = "" then
 227             return "1";
 228
 229          else
 230             begin
 231                Version := Integer'Value (Lib_Version);
 232
 233                if Version <= 0 then
 234                   raise Constraint_Error;
 235                end if;
 236
 237                return Lib_Version;
 238
 239             exception
 240                when Constraint_Error =>
 241                   Fail ("illegal version """, Lib_Version,
 242                         """ (on VMS version must be a positive number)");
 243                   return "";
 244             end;
 245          end if;
 246       end Version_String;
 247
 248       Opt_File_Name  : constant String := Option_File_Name;
 249       Version        : constant String := Version_String;
 250       For_Linker_Opt : String_Access;
 251
 252    --  Start of processing for Build_Dynamic_Library
 253
 254    begin
 255       --  Invoke gcc with -shared-libgcc, but only for GCC 3 or higher
 256
 257       if GCC_Version >= 3 then
 258          Link_With_Shared_Libgcc := Shared_Libgcc_Switch'Access;
 259       else
 260          Link_With_Shared_Libgcc := No_Shared_Libgcc_Switch'Access;
 261       end if;
 262
 263       --  If option file name does not ends with ".opt", append "/OPTIONS"
 264       --  to its specification for the VMS linker.
 265
 266       if Opt_File_Name'Length > 4
 267         and then
 268           Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt"
 269       then
 270          For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name);
 271       else
 272          For_Linker_Opt :=
 273            new String'("--for-linker=" & Opt_File_Name & "/OPTIONS");
 274       end if;
 275
 276       VMS_Options (VMS_Options'First) := For_Linker_Opt;
 277
 278       for J in Inter'Range loop
 279          To_Lower (Inter (J).all);
 280       end loop;
 281
 282       --  "gnatsym" is necessary for building the option file
 283
 284       if Gnatsym_Path = null then
 285          Gnatsym_Path := OS_Lib.Locate_Exec_On_Path (Gnatsym_Name);
 286
 287          if Gnatsym_Path = null then
 288             Fail (Gnatsym_Name, " not found in path");
 289          end if;
 290       end if;
 291
 292       --  For auto-initialization of a stand-alone library, we create
 293       --  a macro-assembly file and we invoke the macro-assembler.
 294
 295       if Auto_Init then
 296          declare
 297             Macro_File_Name : constant String := Lib_Filename & "$init.asm";
 298             Macro_File      : File_Descriptor;
 299             Init_Proc       : String := Lib_Filename & "INIT";
 300             Popen_Result    : System.Address;
 301             Pclose_Result   : Integer;
 302             Len             : Natural;
 303             OK              : Boolean := True;
 304
 305             Command  : constant String :=
 306                          Macro_Name & " " & Macro_File_Name & ASCII.NUL;
 307             --  The command to invoke the assembler on the generated auto-init
 308             --  assembly file.
 309
 310             Mode : constant String := "r" & ASCII.NUL;
 311             --  The mode for the invocation of Popen
 312
 313          begin
 314             To_Upper (Init_Proc);
 315
 316             if Verbose_Mode then
 317                Write_Str ("Creating auto-init assembly file """);
 318                Write_Str (Macro_File_Name);
 319                Write_Line ("""");
 320             end if;
 321
 322             --  Create and write the auto-init assembly file
 323
 324             declare
 325                First_Line : constant String :=
 326                               ASCII.HT & ".section LIB$INITIALIZE,GBL,NOWRT" &
 327                ASCII.LF;
 328                Second_Line : constant String :=
 329                                ASCII.HT & ".long " & Init_Proc & ASCII.LF;
 330                --  First and second lines of the auto-init assembly file
 331
 332             begin
 333                Macro_File := Create_File (Macro_File_Name, Text);
 334                OK := Macro_File /= Invalid_FD;
 335
 336                if OK then
 337                   Len := Write
 338                     (Macro_File, First_Line (First_Line'First)'Address,
 339                      First_Line'Length);
 340                   OK := Len = First_Line'Length;
 341                end if;
 342
 343                if OK then
 344                   Len := Write
 345                     (Macro_File, Second_Line (Second_Line'First)'Address,
 346                      Second_Line'Length);
 347                   OK := Len = Second_Line'Length;
 348                end if;
 349
 350                if OK then
 351                   Close (Macro_File, OK);
 352                end if;
 353
 354                if not OK then
 355                   Fail ("creation of auto-init assembly file """,
 356                         Macro_File_Name, """ failed");
 357                end if;
 358             end;
 359
 360             --  Invoke the macro-assembler
 361
 362             if Verbose_Mode then
 363                Write_Str ("Assembling auto-init assembly file """);
 364                Write_Str (Macro_File_Name);
 365                Write_Line ("""");
 366             end if;
 367
 368             Popen_Result := Popen (Command (Command'First)'Address,
 369                                    Mode (Mode'First)'Address);
 370
 371             if Popen_Result = Null_Address then
 372                Fail ("assembly of auto-init assembly file """,
 373                      Macro_File_Name, """ failed");
 374             end if;
 375
 376             --  Wait for the end of execution of the macro-assembler
 377
 378             Pclose_Result := Pclose (Popen_Result);
 379
 380             if Pclose_Result < 0 then
 381                Fail ("assembly of auto init assembly file """,
 382                      Macro_File_Name, """ failed");
 383             end if;
 384
 385             --  Add the generated object file to the list of objects to be
 386             --  included in the library.
 387
 388             Additional_Objects :=
 389               new Argument_List'
 390                 (1 => new String'(Lib_Filename & "$init.obj"));
 391          end;
 392       end if;
 393
 394       --  Allocate the argument list and put the symbol file name, the
 395       --  reference (if any) and the policy (if not autonomous).
 396
 397       Arguments := new Argument_List (1 .. Ofiles'Length + 8);
 398
 399       Last_Argument := 0;
 400
 401       --  Verbosity
 402
 403       if Verbose_Mode then
 404          Last_Argument := Last_Argument + 1;
 405          Arguments (Last_Argument) := new String'("-v");
 406       end if;
 407
 408       --  Version number (major ID)
 409
 410       if Lib_Version /= "" then
 411          Last_Argument := Last_Argument + 1;
 412          Arguments (Last_Argument) := new String'("-V");
 413          Last_Argument := Last_Argument + 1;
 414          Arguments (Last_Argument) := new String'(Version);
 415       end if;
 416
 417       --  Symbol file
 418
 419       Last_Argument := Last_Argument + 1;
 420       Arguments (Last_Argument) := new String'("-s");
 421       Last_Argument := Last_Argument + 1;
 422       Arguments (Last_Argument) := new String'(Opt_File_Name);
 423
 424       --  Reference Symbol File
 425
 426       if Symbol_Data.Reference /= No_Name then
 427          Last_Argument := Last_Argument + 1;
 428          Arguments (Last_Argument) := new String'("-r");
 429          Last_Argument := Last_Argument + 1;
 430          Arguments (Last_Argument) :=
 431            new String'(Get_Name_String (Symbol_Data.Reference));
 432       end if;
 433
 434       --  Policy
 435
 436       case Symbol_Data.Symbol_Policy is
 437          when Autonomous =>
 438             null;
 439
 440          when Compliant =>
 441             Last_Argument := Last_Argument + 1;
 442             Arguments (Last_Argument) := new String'("-c");
 443
 444          when Controlled =>
 445             Last_Argument := Last_Argument + 1;
 446             Arguments (Last_Argument) := new String'("-C");
 447
 448          when Restricted =>
 449             Last_Argument := Last_Argument + 1;
 450             Arguments (Last_Argument) := new String'("-R");
 451       end case;
 452
 453       --  Add each relevant object file
 454
 455       for Index in Ofiles'Range loop
 456          if Is_Interface (Ofiles (Index).all) then
 457             Last_Argument := Last_Argument + 1;
 458             Arguments (Last_Argument) := new String'(Ofiles (Index).all);
 459          end if;
 460       end loop;
 461
 462       --  Spawn gnatsym
 463
 464       Spawn (Program_Name => Gnatsym_Path.all,
 465              Args         => Arguments (1 .. Last_Argument),
 466              Success      => Success);
 467
 468       if not Success then
 469          Fail ("unable to create symbol file for library """,
 470                Lib_Filename, """");
 471       end if;
 472
 473       Free (Arguments);
 474
 475       --  Move all the -l switches from Opts to Opts2
 476
 477       declare
 478          Index : Natural := Opts'First;
 479          Opt   : String_Access;
 480
 481       begin
 482          while Index <= Last_Opt loop
 483             Opt := Opts (Index);
 484
 485             if Opt'Length > 2 and then
 486               Opt (Opt'First .. Opt'First + 1) = "-l"
 487             then
 488                if Index < Last_Opt then
 489                   Opts (Index .. Last_Opt - 1) :=
 490                     Opts (Index + 1 .. Last_Opt);
 491                end if;
 492
 493                Last_Opt := Last_Opt - 1;
 494
 495                Last_Opt2 := Last_Opt2 + 1;
 496                Opts2 (Last_Opt2) := Opt;
 497
 498             else
 499                Index := Index + 1;
 500             end if;
 501          end loop;
 502       end;
 503
 504       --  Invoke gcc to build the library
 505
 506       Utl.Gcc
 507         (Output_File => Lib_File,
 508          Objects     => Ofiles & Additional_Objects.all,
 509          Options     => VMS_Options,
 510          Options_2   => Link_With_Shared_Libgcc.all &
 511                         Opts (Opts'First .. Last_Opt) &
 512                         Opts2 (Opts2'First .. Last_Opt2) & Options_2,
 513          Driver_Name => Driver_Name);
 514
 515       --  The auto-init object file need to be deleted, so that it will not
 516       --  be included in the library as a regular object file, otherwise
 517       --  it will be included twice when the library will be built next
 518       --  time, which may lead to errors.
 519
 520       if Auto_Init then
 521          declare
 522             Auto_Init_Object_File_Name : constant String :=
 523                                            Lib_Filename & "$init.obj";
 524             Disregard : Boolean;
 525
 526          begin
 527             if Verbose_Mode then
 528                Write_Str ("deleting auto-init object file """);
 529                Write_Str (Auto_Init_Object_File_Name);
 530                Write_Line ("""");
 531             end if;
 532
 533             Delete_File (Auto_Init_Object_File_Name, Success => Disregard);
 534          end;
 535       end if;
 536    end Build_Dynamic_Library;
 537
 538    -------------
 539    -- DLL_Ext --
 540    -------------
 541
 542    function DLL_Ext return String is
 543    begin
 544       return "exe";
 545    end DLL_Ext;
 546
 547    --------------------
 548    -- Dynamic_Option --
 549    --------------------
 550
 551    function Dynamic_Option return String is
 552    begin
 553       return "-shared";
 554    end Dynamic_Option;
 555
 556    -------------------
 557    -- Is_Object_Ext --
 558    -------------------
 559
 560    function Is_Object_Ext (Ext : String) return Boolean is
 561    begin
 562       return Ext = ".obj";
 563    end Is_Object_Ext;
 564
 565    --------------
 566    -- Is_C_Ext --
 567    --------------
 568
 569    function Is_C_Ext (Ext : String) return Boolean is
 570    begin
 571       return Ext = ".c";
 572    end Is_C_Ext;
 573
 574    --------------------
 575    -- Is_Archive_Ext --
 576    --------------------
 577
 578    function Is_Archive_Ext (Ext : String) return Boolean is
 579    begin
 580       return Ext = ".olb" or else Ext = ".exe";
 581    end Is_Archive_Ext;
 582
 583    -------------
 584    -- Libgnat --
 585    -------------
 586
 587    function Libgnat return String is
 588       Libgnat_A : constant String := "libgnat.a";
 589       Libgnat_Olb : constant String := "libgnat.olb";
 590
 591    begin
 592       Name_Len := Libgnat_A'Length;
 593       Name_Buffer (1 .. Name_Len) := Libgnat_A;
 594
 595       if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then
 596          return Libgnat_A;
 597
 598       else
 599          return Libgnat_Olb;
 600       end if;
 601    end Libgnat;
 602
 603    ------------------------
 604    -- Library_Exists_For --
 605    ------------------------
 606
 607    function Library_Exists_For (Project : Project_Id) return Boolean is
 608    begin
 609       if not Projects.Table (Project).Library then
 610          Fail ("INTERNAL ERROR: Library_Exists_For called " &
 611                "for non library project");
 612          return False;
 613
 614       else
 615          declare
 616             Lib_Dir : constant String :=
 617               Get_Name_String (Projects.Table (Project).Library_Dir);
 618             Lib_Name : constant String :=
 619               Get_Name_String (Projects.Table (Project).Library_Name);
 620
 621          begin
 622             if Projects.Table (Project).Library_Kind = Static then
 623                return Is_Regular_File
 624                  (Lib_Dir & Directory_Separator & "lib" &
 625                   Fil.Ext_To (Lib_Name, Archive_Ext));
 626
 627             else
 628                return Is_Regular_File
 629                  (Lib_Dir & Directory_Separator & "lib" &
 630                   Fil.Ext_To (Lib_Name, DLL_Ext));
 631             end if;
 632          end;
 633       end if;
 634    end Library_Exists_For;
 635
 636    ---------------------------
 637    -- Library_File_Name_For --
 638    ---------------------------
 639
 640    function Library_File_Name_For (Project : Project_Id) return Name_Id is
 641    begin
 642       if not Projects.Table (Project).Library then
 643          Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
 644                        "for non library project");
 645          return No_Name;
 646
 647       else
 648          declare
 649             Lib_Name : constant String :=
 650               Get_Name_String (Projects.Table (Project).Library_Name);
 651
 652          begin
 653             Name_Len := 3;
 654             Name_Buffer (1 .. Name_Len) := "lib";
 655
 656             if Projects.Table (Project).Library_Kind = Static then
 657                Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
 658
 659             else
 660                Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
 661             end if;
 662
 663             return Name_Find;
 664          end;
 665       end if;
 666    end Library_File_Name_For;
 667
 668    ----------------
 669    -- Object_Ext --
 670    ----------------
 671
 672    function Object_Ext return String is
 673    begin
 674       return "obj";
 675    end Object_Ext;
 676
 677    ----------------
 678    -- PIC_Option --
 679    ----------------
 680
 681    function PIC_Option return String is
 682    begin
 683       return "";
 684    end PIC_Option;
 685
 686    -----------------------------------------------
 687    -- Standalone_Library_Auto_Init_Is_Supported --
 688    -----------------------------------------------
 689
 690    function Standalone_Library_Auto_Init_Is_Supported return Boolean is
 691    begin
 692       return True;
 693    end Standalone_Library_Auto_Init_Is_Supported;
 694
 695    ---------------------------
 696    -- Support_For_Libraries --
 697    ---------------------------
 698
 699    function Support_For_Libraries return Library_Support is
 700    begin
 701       return Full;
 702    end Support_For_Libraries;
 703
 704 end MLib.Tgt;