------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- M L I B -- -- -- -- B o d y -- -- -- -- Copyright (C) 1999-2009, AdaCore -- -- -- -- 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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Interfaces.C.Strings; with System; with Hostparm; with Opt; with Output; use Output; with MLib.Utl; use MLib.Utl; with Prj.Com; with GNAT.Directory_Operations; use GNAT.Directory_Operations; package body MLib is ------------------- -- Build_Library -- ------------------- procedure Build_Library (Ofiles : Argument_List; Output_File : String; Output_Dir : String) is begin if Opt.Verbose_Mode and not Opt.Quiet_Output then Write_Line ("building a library..."); Write_Str (" make "); Write_Line (Output_File); end if; Ar (Output_Dir & "lib" & Output_File & ".a", Objects => Ofiles); end Build_Library; ------------------------ -- Check_Library_Name -- ------------------------ procedure Check_Library_Name (Name : String) is begin if Name'Length = 0 then Prj.Com.Fail ("library name cannot be empty"); end if; if Name'Length > Max_Characters_In_Library_Name then Prj.Com.Fail ("illegal library name """ & Name & """: too long"); end if; if not Is_Letter (Name (Name'First)) then Prj.Com.Fail ("illegal library name """ & Name & """: should start with a letter"); end if; for Index in Name'Range loop if not Is_Alphanumeric (Name (Index)) then Prj.Com.Fail ("illegal library name """ & Name & """: should include only letters and digits"); end if; end loop; end Check_Library_Name; -------------------- -- Copy_ALI_Files -- -------------------- procedure Copy_ALI_Files (Files : Argument_List; To : Path_Name_Type; Interfaces : String_List) is Success : Boolean := False; To_Dir : constant String := Get_Name_String (To); Is_Interface : Boolean := False; procedure Verbose_Copy (Index : Positive); -- In verbose mode, output a message that the indexed file is copied -- to the destination directory. ------------------ -- Verbose_Copy -- ------------------ procedure Verbose_Copy (Index : Positive) is begin if Opt.Verbose_Mode then Write_Str ("Copying """); Write_Str (Files (Index).all); Write_Str (""" to """); Write_Str (To_Dir); Write_Line (""""); end if; end Verbose_Copy; -- Start of processing for Copy_ALI_Files begin if Interfaces'Length = 0 then -- If there are no Interfaces, copy all the ALI files as is for Index in Files'Range loop Verbose_Copy (Index); Set_Writable (To_Dir & Directory_Separator & Base_Name (Files (Index).all)); Copy_File (Files (Index).all, To_Dir, Success, Mode => Overwrite, Preserve => Preserve); exit when not Success; end loop; else -- Copy only the interface ALI file, and put the special indicator -- "SL" on the P line. for Index in Files'Range loop declare File_Name : String := Base_Name (Files (Index).all); begin Canonical_Case_File_Name (File_Name); -- Check if this is one of the interface ALIs Is_Interface := False; for Index in Interfaces'Range loop if File_Name = Interfaces (Index).all then Is_Interface := True; exit; end if; end loop; -- If it is an interface ALI, copy line by line. Insert -- the interface indication at the end of the P line. -- Do not copy ALI files that are not Interfaces. if Is_Interface then Success := False; Verbose_Copy (Index); Set_Writable (To_Dir & Directory_Separator & Base_Name (Files (Index).all)); declare FD : File_Descriptor; Len : Integer; Actual_Len : Integer; S : String_Access; Curr : Natural; P_Line_Found : Boolean; Status : Boolean; begin -- Open the file Name_Len := Files (Index)'Length; Name_Buffer (1 .. Name_Len) := Files (Index).all; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.NUL; FD := Open_Read (Name_Buffer'Address, Binary); if FD /= Invalid_FD then Len := Integer (File_Length (FD)); -- ??? Why "+3" here S := new String (1 .. Len + 3); -- Read the file. Note that the loop is not necessary -- since the whole file is read at once except on VMS. Curr := S'First; while Curr <= Len loop Actual_Len := Read (FD, S (Curr)'Address, Len); -- Exit if we could not read for some reason exit when Actual_Len = 0; Curr := Curr + Actual_Len; end loop; -- We are done with the input file, so we close it -- ignoring any bad status. Close (FD, Status); P_Line_Found := False; -- Look for the P line. When found, add marker SL -- at the beginning of the P line. for Index in 1 .. Len - 3 loop if (S (Index) = ASCII.LF or else S (Index) = ASCII.CR) and then S (Index + 1) = 'P' then S (Index + 5 .. Len + 3) := S (Index + 2 .. Len); S (Index + 2 .. Index + 4) := " SL"; P_Line_Found := True; exit; end if; end loop; if P_Line_Found then -- Create new modified ALI file Name_Len := To_Dir'Length; Name_Buffer (1 .. Name_Len) := To_Dir; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Directory_Separator; Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) := File_Name; Name_Len := Name_Len + File_Name'Length + 1; Name_Buffer (Name_Len) := ASCII.NUL; FD := Create_File (Name_Buffer'Address, Binary); -- Write the modified text and close the newly -- created file. if FD /= Invalid_FD then Actual_Len := Write (FD, S (1)'Address, Len + 3); Close (FD, Status); -- Set Success to True only if the newly -- created file has been correctly written. Success := Status and then Actual_Len = Len + 3; if Success then -- Set_Read_Only is used here, rather than -- Set_Non_Writable, so that gprbuild can -- he compiled with older compilers. Set_Read_Only (Name_Buffer (1 .. Name_Len - 1)); end if; end if; end if; end if; end; -- This is not an interface ALI else Success := True; end if; end; if not Success then Prj.Com.Fail ("could not copy ALI files to library dir"); end if; end loop; end if; end Copy_ALI_Files; ---------------------- -- Create_Sym_Links -- ---------------------- procedure Create_Sym_Links (Lib_Path : String; Lib_Version : String; Lib_Dir : String; Maj_Version : String) is function Symlink (Oldpath : System.Address; Newpath : System.Address) return Integer; pragma Import (C, Symlink, "__gnat_symlink"); Version_Path : String_Access; Success : Boolean; Result : Integer; pragma Unreferenced (Success, Result); begin Version_Path := new String (1 .. Lib_Version'Length + 1); Version_Path (1 .. Lib_Version'Length) := Lib_Version; Version_Path (Version_Path'Last) := ASCII.NUL; if Maj_Version'Length = 0 then declare Newpath : String (1 .. Lib_Path'Length + 1); begin Newpath (1 .. Lib_Path'Length) := Lib_Path; Newpath (Newpath'Last) := ASCII.NUL; Delete_File (Lib_Path, Success); Result := Symlink (Version_Path (1)'Address, Newpath'Address); end; else declare Newpath1 : String (1 .. Lib_Path'Length + 1); Maj_Path : constant String := Lib_Dir & Directory_Separator & Maj_Version; Newpath2 : String (1 .. Maj_Path'Length + 1); Maj_Ver : String (1 .. Maj_Version'Length + 1); begin Newpath1 (1 .. Lib_Path'Length) := Lib_Path; Newpath1 (Newpath1'Last) := ASCII.NUL; Newpath2 (1 .. Maj_Path'Length) := Maj_Path; Newpath2 (Newpath2'Last) := ASCII.NUL; Maj_Ver (1 .. Maj_Version'Length) := Maj_Version; Maj_Ver (Maj_Ver'Last) := ASCII.NUL; Delete_File (Maj_Path, Success); Result := Symlink (Version_Path (1)'Address, Newpath2'Address); Delete_File (Lib_Path, Success); Result := Symlink (Maj_Ver'Address, Newpath1'Address); end; end if; end Create_Sym_Links; -------------------------------- -- Linker_Library_Path_Option -- -------------------------------- function Linker_Library_Path_Option return String_Access is 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. S : constant String := Interfaces.C.Strings.Value (Run_Path_Option_Ptr); begin if S'Length = 0 then return null; else return new String'(S); end if; end Linker_Library_Path_Option; ------------------- -- Major_Id_Name -- ------------------- function Major_Id_Name (Lib_Filename : String; Lib_Version : String) return String is Maj_Version : constant String := Lib_Version; Last_Maj : Positive; Last : Positive; Ok_Maj : Boolean := False; begin Last_Maj := Maj_Version'Last; while Last_Maj > Maj_Version'First loop if Maj_Version (Last_Maj) in '0' .. '9' then Last_Maj := Last_Maj - 1; else Ok_Maj := Last_Maj /= Maj_Version'Last and then Maj_Version (Last_Maj) = '.'; if Ok_Maj then Last_Maj := Last_Maj - 1; end if; exit; end if; end loop; if Ok_Maj then Last := Last_Maj; while Last > Maj_Version'First loop if Maj_Version (Last) in '0' .. '9' then Last := Last - 1; else Ok_Maj := Last /= Last_Maj and then Maj_Version (Last) = '.'; if Ok_Maj then Last := Last - 1; Ok_Maj := Maj_Version (Maj_Version'First .. Last) = Lib_Filename; end if; exit; end if; end loop; end if; if Ok_Maj then return Maj_Version (Maj_Version'First .. Last_Maj); else return ""; end if; end Major_Id_Name; ------------------------------- -- Separate_Run_Path_Options -- ------------------------------- function Separate_Run_Path_Options return Boolean is Separate_Paths : Boolean; for Separate_Paths'Size use Character'Size; pragma Import (C, Separate_Paths, "__gnat_separate_run_path_options"); begin return Separate_Paths; end Separate_Run_Path_Options; -- Package elaboration begin -- Copy_Attributes always fails on VMS if Hostparm.OpenVMS then Preserve := None; end if; end MLib;