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