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

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             M L I B . T G T                              --
   6 --                         (Integrity VMS Version)                          --
   7 --                                                                          --
   8 --                                 B o d y                                  --
   9 --                                                                          --
  10 --              Copyright (C) 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 Integrity 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       --  Option file must end with ".opt"
 264
 265       if Opt_File_Name'Length > 4
 266         and then
 267           Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt"
 268       then
 269          For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name);
 270       else
 271          Fail ("Options File """, Opt_File_Name, """ must end with .opt");
 272       end if;
 273
 274       VMS_Options (VMS_Options'First) := For_Linker_Opt;
 275
 276       for J in Inter'Range loop
 277          To_Lower (Inter (J).all);
 278       end loop;
 279
 280       --  "gnatsym" is necessary for building the option file
 281
 282       if Gnatsym_Path = null then
 283          Gnatsym_Path := OS_Lib.Locate_Exec_On_Path (Gnatsym_Name);
 284
 285          if Gnatsym_Path = null then
 286             Fail (Gnatsym_Name, " not found in path");
 287          end if;
 288       end if;
 289
 290       --  For auto-initialization of a stand-alone library, we create
 291       --  a macro-assembly file and we invoke the macro-assembler.
 292
 293       if Auto_Init then
 294          declare
 295             Macro_File_Name : constant String := Lib_Filename & "$init.asm";
 296             Macro_File      : File_Descriptor;
 297             Init_Proc       : String := Lib_Filename & "INIT";
 298             Popen_Result    : System.Address;
 299             Pclose_Result   : Integer;
 300             Len             : Natural;
 301             OK              : Boolean := True;
 302
 303             Command  : constant String :=
 304                          Macro_Name & " " & Macro_File_Name & ASCII.NUL;
 305             --  The command to invoke the assembler on the generated auto-init
 306             --  assembly file.
 307
 308             Mode : constant String := "r" & ASCII.NUL;
 309             --  The mode for the invocation of Popen
 310
 311          begin
 312             To_Upper (Init_Proc);
 313
 314             if Verbose_Mode then
 315                Write_Str ("Creating auto-init assembly file """);
 316                Write_Str (Macro_File_Name);
 317                Write_Line ("""");
 318             end if;
 319
 320             --  Create and write the auto-init assembly file
 321
 322             declare
 323                First_Line : constant String :=
 324                  ASCII.HT &
 325                  ".type " & Init_Proc & "#, @function" &
 326                  ASCII.LF;
 327                Second_Line : constant String :=
 328                  ASCII.HT &
 329                  ".global " & Init_Proc & "#" &
 330                  ASCII.LF;
 331                Third_Line : constant String :=
 332                  ASCII.HT &
 333                  ".global LIB$INITIALIZE#" &
 334                  ASCII.LF;
 335                Fourth_Line : constant String :=
 336                  ASCII.HT &
 337                  ".section LIB$INITIALIZE#,""a"",@progbits" &
 338                  ASCII.LF;
 339                Fifth_Line : constant String :=
 340                  ASCII.HT &
 341                  "data4 @fptr(" & Init_Proc & "#)" &
 342                   ASCII.LF;
 343
 344             begin
 345                Macro_File := Create_File (Macro_File_Name, Text);
 346                OK := Macro_File /= Invalid_FD;
 347
 348                if OK then
 349                   Len := Write
 350                     (Macro_File, First_Line (First_Line'First)'Address,
 351                      First_Line'Length);
 352                   OK := Len = First_Line'Length;
 353                end if;
 354
 355                if OK then
 356                   Len := Write
 357                     (Macro_File, Second_Line (Second_Line'First)'Address,
 358                      Second_Line'Length);
 359                   OK := Len = Second_Line'Length;
 360                end if;
 361
 362                if OK then
 363                   Len := Write
 364                     (Macro_File, Third_Line (Third_Line'First)'Address,
 365                      Third_Line'Length);
 366                   OK := Len = Third_Line'Length;
 367                end if;
 368
 369                if OK then
 370                   Len := Write
 371                     (Macro_File, Fourth_Line (Fourth_Line'First)'Address,
 372                      Fourth_Line'Length);
 373                   OK := Len = Fourth_Line'Length;
 374                end if;
 375
 376                if OK then
 377                   Len := Write
 378                     (Macro_File, Fifth_Line (Fifth_Line'First)'Address,
 379                      Fifth_Line'Length);
 380                   OK := Len = Fifth_Line'Length;
 381                end if;
 382
 383                if OK then
 384                   Close (Macro_File, OK);
 385                end if;
 386
 387                if not OK then
 388                   Fail ("creation of auto-init assembly file """,
 389                         Macro_File_Name, """ failed");
 390                end if;
 391             end;
 392
 393             --  Invoke the macro-assembler
 394
 395             if Verbose_Mode then
 396                Write_Str ("Assembling auto-init assembly file """);
 397                Write_Str (Macro_File_Name);
 398                Write_Line ("""");
 399             end if;
 400
 401             Popen_Result := Popen (Command (Command'First)'Address,
 402                                    Mode (Mode'First)'Address);
 403
 404             if Popen_Result = Null_Address then
 405                Fail ("assembly of auto-init assembly file """,
 406                      Macro_File_Name, """ failed");
 407             end if;
 408
 409             --  Wait for the end of execution of the macro-assembler
 410
 411             Pclose_Result := Pclose (Popen_Result);
 412
 413             if Pclose_Result < 0 then
 414                Fail ("assembly of auto init assembly file """,
 415                      Macro_File_Name, """ failed");
 416             end if;
 417
 418             --  Add the generated object file to the list of objects to be
 419             --  included in the library.
 420
 421             Additional_Objects :=
 422               new Argument_List'
 423                 (1 => new String'(Lib_Filename & "$init.obj"));
 424          end;
 425       end if;
 426
 427       --  Allocate the argument list and put the symbol file name, the
 428       --  reference (if any) and the policy (if not autonomous).
 429
 430       Arguments := new Argument_List (1 .. Ofiles'Length + 8);
 431
 432       Last_Argument := 0;
 433
 434       --  Verbosity
 435
 436       if Verbose_Mode then
 437          Last_Argument := Last_Argument + 1;
 438          Arguments (Last_Argument) := new String'("-v");
 439       end if;
 440
 441       --  Version number (major ID)
 442
 443       if Lib_Version /= "" then
 444          Last_Argument := Last_Argument + 1;
 445          Arguments (Last_Argument) := new String'("-V");
 446          Last_Argument := Last_Argument + 1;
 447          Arguments (Last_Argument) := new String'(Version);
 448       end if;
 449
 450       --  Symbol file
 451
 452       Last_Argument := Last_Argument + 1;
 453       Arguments (Last_Argument) := new String'("-s");
 454       Last_Argument := Last_Argument + 1;
 455       Arguments (Last_Argument) := new String'(Opt_File_Name);
 456
 457       --  Reference Symbol File
 458
 459       if Symbol_Data.Reference /= No_Name then
 460          Last_Argument := Last_Argument + 1;
 461          Arguments (Last_Argument) := new String'("-r");
 462          Last_Argument := Last_Argument + 1;
 463          Arguments (Last_Argument) :=
 464            new String'(Get_Name_String (Symbol_Data.Reference));
 465       end if;
 466
 467       --  Policy
 468
 469       case Symbol_Data.Symbol_Policy is
 470          when Autonomous =>
 471             null;
 472
 473          when Compliant =>
 474             Last_Argument := Last_Argument + 1;
 475             Arguments (Last_Argument) := new String'("-c");
 476
 477          when Controlled =>
 478             Last_Argument := Last_Argument + 1;
 479             Arguments (Last_Argument) := new String'("-C");
 480
 481          when Restricted =>
 482             Last_Argument := Last_Argument + 1;
 483             Arguments (Last_Argument) := new String'("-R");
 484       end case;
 485
 486       --  Add each relevant object file
 487
 488       for Index in Ofiles'Range loop
 489          if Is_Interface (Ofiles (Index).all) then
 490             Last_Argument := Last_Argument + 1;
 491             Arguments (Last_Argument) := new String'(Ofiles (Index).all);
 492          end if;
 493       end loop;
 494
 495       --  Spawn gnatsym
 496
 497       Spawn (Program_Name => Gnatsym_Path.all,
 498              Args         => Arguments (1 .. Last_Argument),
 499              Success      => Success);
 500
 501       if not Success then
 502          Fail ("unable to create symbol file for library """,
 503                Lib_Filename, """");
 504       end if;
 505
 506       Free (Arguments);
 507
 508       --  Move all the -l switches from Opts to Opts2
 509
 510       declare
 511          Index : Natural := Opts'First;
 512          Opt   : String_Access;
 513
 514       begin
 515          while Index <= Last_Opt loop
 516             Opt := Opts (Index);
 517
 518             if Opt'Length > 2 and then
 519               Opt (Opt'First .. Opt'First + 1) = "-l"
 520             then
 521                if Index < Last_Opt then
 522                   Opts (Index .. Last_Opt - 1) :=
 523                     Opts (Index + 1 .. Last_Opt);
 524                end if;
 525
 526                Last_Opt := Last_Opt - 1;
 527
 528                Last_Opt2 := Last_Opt2 + 1;
 529                Opts2 (Last_Opt2) := Opt;
 530
 531             else
 532                Index := Index + 1;
 533             end if;
 534          end loop;
 535       end;
 536
 537       --  Invoke gcc to build the library
 538
 539       Utl.Gcc
 540         (Output_File => Lib_File,
 541          Objects     => Ofiles & Additional_Objects.all,
 542          Options     => VMS_Options,
 543          Options_2   => Link_With_Shared_Libgcc.all &
 544                         Opts (Opts'First .. Last_Opt) &
 545                         Opts2 (Opts2'First .. Last_Opt2) & Options_2,
 546          Driver_Name => Driver_Name);
 547
 548       --  The auto-init object file need to be deleted, so that it will not
 549       --  be included in the library as a regular object file, otherwise
 550       --  it will be included twice when the library will be built next
 551       --  time, which may lead to errors.
 552
 553       if Auto_Init then
 554          declare
 555             Auto_Init_Object_File_Name : constant String :=
 556                                            Lib_Filename & "$init.obj";
 557             Disregard : Boolean;
 558
 559          begin
 560             if Verbose_Mode then
 561                Write_Str ("deleting auto-init object file """);
 562                Write_Str (Auto_Init_Object_File_Name);
 563                Write_Line ("""");
 564             end if;
 565
 566             Delete_File (Auto_Init_Object_File_Name, Success => Disregard);
 567          end;
 568       end if;
 569    end Build_Dynamic_Library;
 570
 571    -------------
 572    -- DLL_Ext --
 573    -------------
 574
 575    function DLL_Ext return String is
 576    begin
 577       return "exe";
 578    end DLL_Ext;
 579
 580    --------------------
 581    -- Dynamic_Option --
 582    --------------------
 583
 584    function Dynamic_Option return String is
 585    begin
 586       return "-shared";
 587    end Dynamic_Option;
 588
 589    -------------------
 590    -- Is_Object_Ext --
 591    -------------------
 592
 593    function Is_Object_Ext (Ext : String) return Boolean is
 594    begin
 595       return Ext = ".obj";
 596    end Is_Object_Ext;
 597
 598    --------------
 599    -- Is_C_Ext --
 600    --------------
 601
 602    function Is_C_Ext (Ext : String) return Boolean is
 603    begin
 604       return Ext = ".c";
 605    end Is_C_Ext;
 606
 607    --------------------
 608    -- Is_Archive_Ext --
 609    --------------------
 610
 611    function Is_Archive_Ext (Ext : String) return Boolean is
 612    begin
 613       return Ext = ".olb" or else Ext = ".exe";
 614    end Is_Archive_Ext;
 615
 616    -------------
 617    -- Libgnat --
 618    -------------
 619
 620    function Libgnat return String is
 621       Libgnat_A : constant String := "libgnat.a";
 622       Libgnat_Olb : constant String := "libgnat.olb";
 623
 624    begin
 625       Name_Len := Libgnat_A'Length;
 626       Name_Buffer (1 .. Name_Len) := Libgnat_A;
 627
 628       if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then
 629          return Libgnat_A;
 630
 631       else
 632          return Libgnat_Olb;
 633       end if;
 634    end Libgnat;
 635
 636    ------------------------
 637    -- Library_Exists_For --
 638    ------------------------
 639
 640    function Library_Exists_For (Project : Project_Id) return Boolean is
 641    begin
 642       if not Projects.Table (Project).Library then
 643          Fail ("INTERNAL ERROR: Library_Exists_For called " &
 644                "for non library project");
 645          return False;
 646
 647       else
 648          declare
 649             Lib_Dir : constant String :=
 650               Get_Name_String (Projects.Table (Project).Library_Dir);
 651             Lib_Name : constant String :=
 652               Get_Name_String (Projects.Table (Project).Library_Name);
 653
 654          begin
 655             if Projects.Table (Project).Library_Kind = Static then
 656                return Is_Regular_File
 657                  (Lib_Dir & Directory_Separator & "lib" &
 658                   Fil.Ext_To (Lib_Name, Archive_Ext));
 659
 660             else
 661                return Is_Regular_File
 662                  (Lib_Dir & Directory_Separator & "lib" &
 663                   Fil.Ext_To (Lib_Name, DLL_Ext));
 664             end if;
 665          end;
 666       end if;
 667    end Library_Exists_For;
 668
 669    ---------------------------
 670    -- Library_File_Name_For --
 671    ---------------------------
 672
 673    function Library_File_Name_For (Project : Project_Id) return Name_Id is
 674    begin
 675       if not Projects.Table (Project).Library then
 676          Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
 677                        "for non library project");
 678          return No_Name;
 679
 680       else
 681          declare
 682             Lib_Name : constant String :=
 683               Get_Name_String (Projects.Table (Project).Library_Name);
 684
 685          begin
 686             Name_Len := 3;
 687             Name_Buffer (1 .. Name_Len) := "lib";
 688
 689             if Projects.Table (Project).Library_Kind = Static then
 690                Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
 691
 692             else
 693                Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
 694             end if;
 695
 696             return Name_Find;
 697          end;
 698       end if;
 699    end Library_File_Name_For;
 700
 701    ----------------
 702    -- Object_Ext --
 703    ----------------
 704
 705    function Object_Ext return String is
 706    begin
 707       return "obj";
 708    end Object_Ext;
 709
 710    ----------------
 711    -- PIC_Option --
 712    ----------------
 713
 714    function PIC_Option return String is
 715    begin
 716       return "";
 717    end PIC_Option;
 718
 719    -----------------------------------------------
 720    -- Standalone_Library_Auto_Init_Is_Supported --
 721    -----------------------------------------------
 722
 723    function Standalone_Library_Auto_Init_Is_Supported return Boolean is
 724    begin
 725       return True;
 726    end Standalone_Library_Auto_Init_Is_Supported;
 727
 728    ---------------------------
 729    -- Support_For_Libraries --
 730    ---------------------------
 731
 732    function Support_For_Libraries return Library_Support is
 733    begin
 734       return Full;
 735    end Support_For_Libraries;
 736
 737 end MLib.Tgt;