| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |
