-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Gnatlink usage: please consult the gnat documentation
-with Ada.Exceptions; use Ada.Exceptions;
with ALI; use ALI;
with Gnatvsn; use Gnatvsn;
with Hostparm;
+with Indepsw; use Indepsw;
with Namet; use Namet;
with Opt;
with Osint; use Osint;
with Types;
with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Exceptions; use Ada.Exceptions;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Interfaces.C_Streams; use Interfaces.C_Streams;
+with Interfaces.C.Strings; use Interfaces.C.Strings;
+with System.CRTL;
procedure Gnatlink is
pragma Ident (Gnatvsn.Gnat_Static_Version_String);
-- This table collects the arguments to be passed to compile the binder
-- generated file.
- subtype chars_ptr is System.Address;
-
Gcc : String_Access := Program_Name ("gcc");
Read_Mode : constant String := "r" & ASCII.Nul;
Compile_Bind_File : Boolean := True;
-- Set to False if bind file is not to be compiled
+ Create_Map_File : Boolean := False;
+ -- Set to True by switch -M. The map file name is derived from
+ -- the ALI file name (mainprog.ali => mainprog.map).
+
Object_List_File_Supported : Boolean;
- pragma Import (C, Object_List_File_Supported, "objlist_file_supported");
+ pragma Import
+ (C, Object_List_File_Supported, "__gnat_objlist_file_supported");
-- Predicate indicating whether the linker has an option whereby the
-- names of object files can be passed to the linker in a file.
procedure Process_Binder_File (Name : in String);
-- Reads the binder file and extracts linker arguments.
- function Value (chars : chars_ptr) return String;
- -- Return NUL-terminated string chars as an Ada string.
-
procedure Write_Header;
-- Show user the program name, version and copyright.
procedure Delete (Name : in String) is
Status : int;
-
+ pragma Unreferenced (Status);
begin
Status := unlink (Name'Address);
+ -- Is it really right to ignore an error here ???
end Delete;
---------------
Binder_Options.Table (Binder_Options.Last) :=
Linker_Options.Table (Linker_Options.Last);
+ elsif Arg'Length >= 3 and then Arg (2) = 'M' then
+ declare
+ Switches : String_List_Access;
+ begin
+ Convert (Map_File, Arg (3 .. Arg'Last), Switches);
+
+ if Switches /= null then
+ for J in Switches'Range loop
+ Linker_Options.Increment_Last;
+ Linker_Options.Table (Linker_Options.Last) :=
+ Switches (J);
+ end loop;
+ end if;
+ end;
+
elsif Arg'Length = 2 then
case Arg (2) is
when 'A' =>
("Object list file not supported on this target");
end if;
+ when 'M' =>
+ Create_Map_File := True;
+
when 'n' =>
Compile_Bind_File := False;
-- Projected number of bytes for the linker command line
Link_Max : Integer;
- pragma Import (C, Link_Max, "link_max");
+ pragma Import (C, Link_Max, "__gnat_link_max");
-- Maximum number of bytes on the command line supported by the OS
-- linker. Passed this limit the response file mechanism must be used
-- if supported.
Nfirst : Integer;
-- Current line slice (the slice does not contain line terminator)
+ Last : Integer;
+ -- Current line last character for shared libraries (without version)
+
Objs_Begin : Integer := 0;
-- First object file index in Linker_Objects table
RB_Nlast : Integer; -- Slice last index
RB_Nfirst : Integer; -- Slice first index
- Run_Path_Option_Ptr : Address;
- pragma Import (C, Run_Path_Option_Ptr, "run_path_option");
+ Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
+ pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option");
-- Pointer to string representing the native linker option which
-- specifies the path where the dynamic loader should find shared
-- libraries. Equal to null string if this system doesn't support it.
- Object_Library_Ext_Ptr : Address;
- pragma Import (C, Object_Library_Ext_Ptr, "object_library_extension");
+ Object_Library_Ext_Ptr : Interfaces.C.Strings.chars_ptr;
+ pragma Import
+ (C, Object_Library_Ext_Ptr, "__gnat_object_library_extension");
-- Pointer to string specifying the default extension for
-- object libraries, e.g. Unix uses ".a", VMS uses ".olb".
- Object_File_Option_Ptr : Address;
- pragma Import (C, Object_File_Option_Ptr, "object_file_option");
+ Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr;
+ pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option");
-- Pointer to a string representing the linker option which specifies
-- the response file.
Using_GNU_Linker : Boolean;
- pragma Import (C, Using_GNU_Linker, "using_gnu_linker");
+ pragma Import (C, Using_GNU_Linker, "__gnat_using_gnu_linker");
-- Predicate indicating whether this target uses the GNU linker. In
-- this case we must output a GNU linker compatible response file.
+ Opening : aliased constant String := """";
+ Closing : aliased constant String := '"' & ASCII.LF;
+ -- Needed to quote object paths in object list files when GNU linker
+ -- is used.
+
procedure Get_Next_Line;
-- Read the next line from the binder file without the line
-- terminator.
function Index (S, Pattern : String) return Natural;
- -- Return the first occurrence of Pattern in S, or 0 if none.
+ -- Return the last occurrence of Pattern in S, or 0 if none.
function Is_Option_Present (Opt : in String) return Boolean;
-- Return true if the option Opt is already present in
function Index (S, Pattern : String) return Natural is
Len : constant Natural := Pattern'Length;
+
begin
- for J in S'First .. S'Last - Len + 1 loop
+ for J in reverse S'First .. S'Last - Len + 1 loop
if Pattern = S (J .. J + Len - 1) then
return J;
end if;
------------------------
procedure Store_File_Context is
+ use type System.CRTL.long;
begin
RB_Next_Line := Next_Line;
RB_Nfirst := Nfirst;
-- If target is using the GNU linker we must add a special header
-- and footer in the response file.
-- The syntax is : INPUT (object1.o object2.o ... )
+ -- Because the GNU linker does not like name with characters such
+ -- as '!', we must put the object paths between double quotes.
if Using_GNU_Linker then
declare
end if;
for J in Objs_Begin .. Objs_End loop
+
+ -- Opening quote for GNU linker
+
+ if Using_GNU_Linker then
+ Status := Write (Tname_FD, Opening'Address, 1);
+ end if;
+
Status := Write (Tname_FD, Linker_Objects.Table (J).all'Address,
- Linker_Objects.Table (J).all'Length);
- Status := Write (Tname_FD, ASCII.LF'Address, 1);
+ Linker_Objects.Table (J).all'Length);
+
+ -- Closing quote for GNU linker
+
+ if Using_GNU_Linker then
+ Status := Write (Tname_FD, Closing'Address, 2);
+
+ else
+ Status := Write (Tname_FD, ASCII.LF'Address, 1);
+ end if;
Response_File_Objects.Increment_Last;
Response_File_Objects.Table (Response_File_Objects.Last) :=
Linker_Objects.Table (J);
end loop;
- -- handle GNU linker response file footer.
+ -- Handle GNU linker response file footer
if Using_GNU_Linker then
declare
-- Add binder options only if not already set on the command
-- line. This rule is a way to control the linker options order.
- elsif not Is_Option_Present (Next_Line (Nfirst .. Nlast)) then
+ -- The following test needs comments, why is it VMS specific.
+ -- The above comment looks out of date ???
+
+ elsif not (Hostparm.OpenVMS
+ and then
+ Is_Option_Present (Next_Line (Nfirst .. Nlast)))
+ then
if Nlast > Nfirst + 2 and then
Next_Line (Nfirst .. Nfirst + 1) = "-L"
then
elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat"
or else Next_Line (Nfirst .. Nlast) = "-lgnarl"
or else Next_Line (Nfirst .. Nlast) = "-lgnat"
+ or else Next_Line
+ (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) =
+ Shared_Lib ("gnarl")
+ or else Next_Line
+ (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) =
+ Shared_Lib ("gnat")
then
+ -- If it is a shared library, remove the library version.
+ -- We will be looking for the static version of the library
+ -- as it is in the same directory as the shared version.
+
+ if Next_Line (Nlast - Library_Version'Length + 1 .. Nlast)
+ = Library_Version
+ then
+ -- Set Last to point to last character before the
+ -- library version.
+
+ Last := Nlast - Library_Version'Length - 1;
+ else
+ Last := Nlast;
+ end if;
+
-- Given a Gnat standard library, search the
-- library path to find the library location
declare
File_Path : String_Access;
+
Object_Lib_Extension : constant String :=
- Value (Object_Library_Ext_Ptr);
+ Value (Object_Library_Ext_Ptr);
+
File_Name : constant String := "lib" &
- Next_Line (Nfirst + 2 .. Nlast) &
- Object_Lib_Extension;
+ Next_Line (Nfirst + 2 .. Last) &
+ Object_Lib_Extension;
+
Run_Path_Opt : constant String :=
Value (Run_Path_Option_Ptr);
- GCC_Index : Natural;
+
+ GCC_Index : Natural;
Run_Path_Opt_Index : Natural := 0;
begin
-- Also add path to find libgcc_s.so, if
-- relevant.
- GCC_Index := Index (File_Path.all, "gcc-lib");
+ -- To find the location of the shared version
+ -- of libgcc, we look for "gcc-lib" in the
+ -- path of the library. However, this
+ -- subdirectory is no longer present in
+ -- in recent version of GCC. So, we look for
+ -- the last subdirectory "lib" in the path.
+
+ GCC_Index :=
+ Index (File_Path.all, "gcc-lib");
+
+ if GCC_Index /= 0 then
+ -- The shared version of libgcc is
+ -- located in the parent directory.
+
+ GCC_Index := GCC_Index - 1;
+
+ else
+ GCC_Index :=
+ Index (File_Path.all, "/lib/");
+
+ if GCC_Index = 0 then
+ GCC_Index :=
+ Index (File_Path.all,
+ Directory_Separator &
+ "lib" &
+ Directory_Separator);
+ end if;
+
+ -- We have found a subdirectory "lib",
+ -- this is where the shared version of
+ -- libgcc should be located.
+
+ if GCC_Index /= 0 then
+ GCC_Index := GCC_Index + 3;
+ end if;
+ end if;
-- Look for an eventual run_path_option in
-- the linker switches.
(1 .. File_Path'Length
- File_Name'Length)
& Path_Separator
- & File_Path (1 .. GCC_Index - 1));
+ & File_Path (1 .. GCC_Index));
else
Linker_Options.Table
(1 .. File_Path'Length
- File_Name'Length)
& Path_Separator
- & File_Path (1 .. GCC_Index - 1));
+ & File_Path (1 .. GCC_Index));
end if;
end if;
end if;
Status := fclose (Fd);
end Process_Binder_File;
- -----------
- -- Value --
- -----------
-
- function Value (chars : chars_ptr) return String is
- function Strlen (chars : chars_ptr) return Natural;
- pragma Import (C, Strlen);
-
- begin
- if chars = Null_Address then
- return "";
-
- else
- declare
- subtype Result_Type is String (1 .. Strlen (chars));
-
- Result : Result_Type;
- for Result'Address use chars;
-
- begin
- return Result;
- end;
- end if;
- end Value;
-
------------------
-- Write_Header --
------------------
Write_Eol;
Write_Str ("GNATLINK ");
Write_Str (Gnat_Version_String);
- Write_Str (" Copyright 1995-2003 Free Software Foundation, Inc");
+ Write_Eol;
+ Write_Str ("Copyright 1995-2004 Free Software Foundation, Inc");
Write_Eol;
end if;
end Write_Header;
Write_Line (" -o nam Use 'nam' as the name of the executable");
Write_Line (" -b target Compile the binder source to run on target");
Write_Line (" -Bdir Load compiler executables from dir");
+
+ if Is_Supported (Map_File) then
+ Write_Line (" -Mmap Create map file map");
+ Write_Line (" -M Create map file mainprog.map");
+ end if;
+
Write_Line (" --GCC=comp Use comp as the compiler");
Write_Line (" --LINK=nam Use 'nam' for the linking rather than 'gcc'");
Write_Eol;
-- Start of processing for Gnatlink
begin
+ -- Add the directory where gnatlink is invoked in front of the
+ -- path, if gnatlink is invoked with directory information.
+ -- Only do this if the platform is not VMS, where the notion of path
+ -- does not really exist.
+
+ if not Hostparm.OpenVMS then
+ declare
+ Command : constant String := Command_Name;
+
+ begin
+ for Index in reverse Command'Range loop
+ if Command (Index) = Directory_Separator then
+ declare
+ Absolute_Dir : constant String :=
+ Normalize_Pathname
+ (Command (Command'First .. Index));
+
+ PATH : constant String :=
+ Absolute_Dir &
+ Path_Separator &
+ Getenv ("PATH").all;
+
+ begin
+ Setenv ("PATH", PATH);
+ end;
+
+ exit;
+ end if;
+ end loop;
+ end;
+ end if;
+
Process_Args;
if Argument_Count = 0
T := Read_Library_Info (F, True);
- -- Read it
+ -- Read it. Note that we ignore errors, since we only want very
+ -- limited information from the ali file, and likely a slightly
+ -- wrong version will be just fine, though in normal operation
+ -- we don't expect this to happen!
- A := Scan_ALI (F, T, Ignore_ED => False, Err => False);
+ A := Scan_ALI
+ (F,
+ T,
+ Ignore_ED => False,
+ Err => False,
+ Ignore_Errors => True);
if A /= No_ALI_Id then
for
Units.Table (ALIs.Table (A).First_Unit).Last_Arg
loop
-- Do not compile with the front end switches except for --RTS
+ -- if the binder generated file is in Ada.
declare
Arg : String_Ptr renames Args.Table (Index);
begin
if not Is_Front_End_Switch (Arg.all)
- or else Arg (Arg'First + 2 .. Arg'First + 5) = "RTS="
+ or else
+ (Ada_Bind_File
+ and then Arg'Length > 5
+ and then Arg (Arg'First + 2 .. Arg'First + 5) = "RTS=")
then
Binder_Options_From_ALI.Increment_Last;
Binder_Options_From_ALI.Table
-- on Unix. On non-Unix systems executables have a suffix, so the warning
-- will not appear. However, do not warn in the case of a cross compiler.
- -- Assume that if the executable name is not gnatlink, this is a cross
- -- tool.
+ -- Assume this is a cross tool if the executable name is not gnatlink
if Base_Name (Command_Name) = "gnatlink"
and then Output_File_Name.all = "test"
& """ may conflict with shell command");
end if;
+ -- If -M switch was specified, add the switches to create the map file
+
+ if Create_Map_File then
+ declare
+ Map_Name : constant String := Base_Name (Ali_File_Name.all) & ".map";
+ Switches : String_List_Access;
+
+ begin
+ Convert (Map_File, Map_Name, Switches);
+
+ if Switches /= null then
+ for J in Switches'Range loop
+ Linker_Options.Increment_Last;
+ Linker_Options.Table (Linker_Options.Last) := Switches (J);
+ end loop;
+ end if;
+ end;
+ end if;
+
-- Perform consistency checks
- -- Transform the .ali file name into the binder output file name.
+ -- Transform the .ali file name into the binder output file name
Make_Binder_File_Names : declare
Fname : constant String := Base_Name (Ali_File_Name.all);
-- Remove duplicate IDENTIFICATION directives (VMS)
if Linker_Options.Table (J)'Length > 27
- and then Linker_Options.Table (J) (1 .. 27)
+ and then Linker_Options.Table (J) (1 .. 28)
= "--for-linker=IDENTIFICATION="
then
if IDENT_Op then
OSDN Git Service
