aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.1/gcc/ada/mlib.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.1/gcc/ada/mlib.adb')
-rw-r--r--gcc-4.8.1/gcc/ada/mlib.adb470
1 files changed, 470 insertions, 0 deletions
diff --git a/gcc-4.8.1/gcc/ada/mlib.adb b/gcc-4.8.1/gcc/ada/mlib.adb
new file mode 100644
index 000000000..4c4d375f3
--- /dev/null
+++ b/gcc-4.8.1/gcc/ada/mlib.adb
@@ -0,0 +1,470 @@
+------------------------------------------------------------------------------
+-- --
+-- 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;