diff options
Diffstat (limited to 'gcc/ada/osint-c.adb')
| -rw-r--r-- | gcc/ada/osint-c.adb | 380 |
1 files changed, 380 insertions, 0 deletions
diff --git a/gcc/ada/osint-c.adb b/gcc/ada/osint-c.adb new file mode 100644 index 0000000..40198cd --- /dev/null +++ b/gcc/ada/osint-c.adb @@ -0,0 +1,380 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - C -- +-- -- +-- B o d y -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 2001 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- -- +-- ware Foundation; either version 2, 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 COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Hostparm; +with Namet; use Namet; +with Opt; use Opt; +with Tree_IO; use Tree_IO; + +package body Osint.C is + + Output_Object_File_Name : String_Ptr; + -- Argument of -o compiler option, if given. This is needed to + -- verify consistency with the ALI file name. + + procedure Adjust_OS_Resource_Limits; + pragma Import (C, Adjust_OS_Resource_Limits, + "__gnat_adjust_os_resource_limits"); + -- Procedure to make system specific adjustments to make GNAT + -- run better. + + function Create_Auxiliary_File + (Src : File_Name_Type; + Suffix : String) + return File_Name_Type; + -- Common processing for Creat_Repinfo_File and Create_Debug_File. + -- Src is the file name used to create the required output file and + -- Suffix is the desired suffic (dg/rep for debug/repinfo file). + + procedure Set_Library_Info_Name; + -- Sets a default ali file name from the main compiler source name. + -- This is used by Create_Output_Library_Info, and by the version of + -- Read_Library_Info that takes a default file name. + + ---------------------- + -- Close_Debug_File -- + ---------------------- + + procedure Close_Debug_File is + begin + Close (Output_FD); + end Close_Debug_File; + + ------------------------------- + -- Close_Output_Library_Info -- + ------------------------------- + + procedure Close_Output_Library_Info is + begin + Close (Output_FD); + end Close_Output_Library_Info; + + ------------------------ + -- Close_Repinfo_File -- + ------------------------ + + procedure Close_Repinfo_File is + begin + Close (Output_FD); + end Close_Repinfo_File; + + --------------------------- + -- Create_Auxiliary_File -- + --------------------------- + + function Create_Auxiliary_File + (Src : File_Name_Type; + Suffix : String) + return File_Name_Type + is + Result : File_Name_Type; + + begin + Get_Name_String (Src); + + if Hostparm.OpenVMS then + Name_Buffer (Name_Len + 1) := '_'; + else + Name_Buffer (Name_Len + 1) := '.'; + end if; + + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; + Name_Len := Name_Len + Suffix'Length; + + if Output_Object_File_Name /= null then + + for Index in reverse Output_Object_File_Name'Range loop + + if Output_Object_File_Name (Index) = Directory_Separator then + declare + File_Name : constant String := Name_Buffer (1 .. Name_Len); + + begin + Name_Len := Index - Output_Object_File_Name'First + 1; + Name_Buffer (1 .. Name_Len) := + Output_Object_File_Name + (Output_Object_File_Name'First .. Index); + Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) := + File_Name; + Name_Len := Name_Len + File_Name'Length; + end; + + exit; + end if; + end loop; + end if; + + Result := Name_Find; + Name_Buffer (Name_Len + 1) := ASCII.NUL; + Create_File_And_Check (Output_FD, Text); + return Result; + end Create_Auxiliary_File; + + ----------------------- + -- Create_Debug_File -- + ----------------------- + + function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is + begin + return Create_Auxiliary_File (Src, "dg"); + end Create_Debug_File; + + -------------------------------- + -- Create_Output_Library_Info -- + -------------------------------- + + procedure Create_Output_Library_Info is + begin + Set_Library_Info_Name; + Create_File_And_Check (Output_FD, Text); + end Create_Output_Library_Info; + + -------------------------- + -- Creat_Repinfo_File -- + -------------------------- + + procedure Creat_Repinfo_File (Src : File_Name_Type) is + S : constant File_Name_Type := Create_Auxiliary_File (Src, "rep"); + pragma Warnings (Off, S); + + begin + return; + end Creat_Repinfo_File; + + --------------------------- + -- Debug_File_Eol_Length -- + --------------------------- + + function Debug_File_Eol_Length return Nat is + begin + -- There has to be a cleaner way to do this! ??? + + if Directory_Separator = '/' then + return 1; + else + return 2; + end if; + end Debug_File_Eol_Length; + + ----------------------- + -- More_Source_Files -- + ----------------------- + + function More_Source_Files return Boolean renames More_Files; + + ---------------------- + -- Next_Main_Source -- + ---------------------- + + function Next_Main_Source return File_Name_Type renames Next_Main_File; + + ----------------------- + -- Read_Library_Info -- + ----------------------- + + -- Version with default file name + + procedure Read_Library_Info + (Name : out File_Name_Type; + Text : out Text_Buffer_Ptr) + is + begin + Set_Library_Info_Name; + Name := Name_Find; + Text := Read_Library_Info (Name, Fatal_Err => False); + end Read_Library_Info; + + --------------------------- + -- Set_Library_Info_Name -- + --------------------------- + + procedure Set_Library_Info_Name is + Dot_Index : Natural; + + begin + Get_Name_String (Current_Main); + + -- Find last dot since we replace the existing extension by .ali. The + -- initialization to Name_Len + 1 provides for simply adding the .ali + -- extension if the source file name has no extension. + + Dot_Index := Name_Len + 1; + + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Dot_Index := J; + exit; + end if; + end loop; + + -- Make sure that the output file name matches the source file name. + -- To compare them, remove file name directories and extensions. + + if Output_Object_File_Name /= null then + -- Make sure there is a dot at Dot_Index. This may not be the case + -- if the source file name has no extension. + + Name_Buffer (Dot_Index) := '.'; + + declare + Name : constant String := Name_Buffer (1 .. Dot_Index); + Len : constant Natural := Dot_Index; + + begin + Name_Buffer (1 .. Output_Object_File_Name'Length) + := Output_Object_File_Name.all; + Dot_Index := 0; + + for J in reverse Output_Object_File_Name'Range loop + if Name_Buffer (J) = '.' then + Dot_Index := J; + exit; + end if; + end loop; + + pragma Assert (Dot_Index /= 0); + -- We check for the extension elsewhere + + if Name /= Name_Buffer (Dot_Index - Len + 1 .. Dot_Index) then + Fail ("incorrect object file name"); + end if; + end; + end if; + + Name_Buffer (Dot_Index) := '.'; + Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all; + Name_Buffer (Dot_Index + 4) := ASCII.NUL; + Name_Len := Dot_Index + 3; + end Set_Library_Info_Name; + + --------------------------------- + -- Set_Output_Object_File_Name -- + --------------------------------- + + procedure Set_Output_Object_File_Name (Name : String) is + Ext : constant String := Object_Suffix; + NL : constant Natural := Name'Length; + EL : constant Natural := Ext'Length; + + begin + -- Make sure that the object file has the expected extension. + + if NL <= EL + or else + (Name (NL - EL + Name'First .. Name'Last) /= Ext + and then Name (NL - 2 + Name'First .. Name'Last) /= ".o") + then + Fail ("incorrect object file extension"); + end if; + + Output_Object_File_Name := new String'(Name); + end Set_Output_Object_File_Name; + + ---------------- + -- Tree_Close -- + ---------------- + + procedure Tree_Close is + begin + Tree_Write_Terminate; + Close (Output_FD); + end Tree_Close; + + ----------------- + -- Tree_Create -- + ----------------- + + procedure Tree_Create is + Dot_Index : Natural; + + begin + Get_Name_String (Current_Main); + + -- If an object file has been specified, then the ALI file + -- will be in the same directory as the object file; + -- so, we put the tree file in this same directory, + -- even though no object file needs to be generated. + + if Output_Object_File_Name /= null then + Name_Len := Output_Object_File_Name'Length; + Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all; + end if; + + Dot_Index := 0; + for J in reverse 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Dot_Index := J; + exit; + end if; + end loop; + + -- Should be impossible to not have an extension + + pragma Assert (Dot_Index /= 0); + + -- Change exctension to adt + + Name_Buffer (Dot_Index + 1) := 'a'; + Name_Buffer (Dot_Index + 2) := 'd'; + Name_Buffer (Dot_Index + 3) := 't'; + Name_Buffer (Dot_Index + 4) := ASCII.NUL; + Name_Len := Dot_Index + 3; + Create_File_And_Check (Output_FD, Binary); + + Tree_Write_Initialize (Output_FD); + end Tree_Create; + + ----------------------- + -- Write_Debug_Info -- + ----------------------- + + procedure Write_Debug_Info (Info : String) renames Write_Info; + + ------------------------ + -- Write_Library_Info -- + ------------------------ + + procedure Write_Library_Info (Info : String) renames Write_Info; + + ------------------------ + -- Write_Repinfo_Line -- + ------------------------ + + procedure Write_Repinfo_Line (Info : String) renames Write_Info; + +begin + + Adjust_OS_Resource_Limits; + Opt.Creat_Repinfo_File_Access := Creat_Repinfo_File'Access; + Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access; + Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access; + + Set_Program (Compiler); + +end Osint.C; |