From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/osint-c.adb | 509 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 509 insertions(+) create mode 100644 gcc/ada/osint-c.adb (limited to 'gcc/ada/osint-c.adb') diff --git a/gcc/ada/osint-c.adb b/gcc/ada/osint-c.adb new file mode 100644 index 000000000..8b67befc6 --- /dev/null +++ b/gcc/ada/osint-c.adb @@ -0,0 +1,509 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- O S I N T - C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2009, 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 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 Hostparm; +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 Create_List_File, Create_Repinfo_File and + -- Create_Debug_File. Src is the file name used to create the required + -- output file and Suffix is the desired suffix (dg/rep/xxx for debug/ + -- repinfo/list file where xxx is specified extension. + + 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. The name is in + -- Name_Buffer (with length in Name_Len) on return from the call. + + ---------------------- + -- Close_Debug_File -- + ---------------------- + + procedure Close_Debug_File is + Status : Boolean; + + begin + Close (Output_FD, Status); + + if not Status then + Fail + ("error while closing expanded source file " + & Get_Name_String (Output_File_Name)); + end if; + end Close_Debug_File; + + --------------------- + -- Close_List_File -- + --------------------- + + procedure Close_List_File is + Status : Boolean; + + begin + Close (Output_FD, Status); + + if not Status then + Fail + ("error while closing list file " + & Get_Name_String (Output_File_Name)); + end if; + end Close_List_File; + + ------------------------------- + -- Close_Output_Library_Info -- + ------------------------------- + + procedure Close_Output_Library_Info is + Status : Boolean; + + begin + Close (Output_FD, Status); + + if not Status then + Fail + ("error while closing ALI file " + & Get_Name_String (Output_File_Name)); + end if; + end Close_Output_Library_Info; + + ------------------------ + -- Close_Repinfo_File -- + ------------------------ + + procedure Close_Repinfo_File is + Status : Boolean; + + begin + Close (Output_FD, Status); + + if not Status then + Fail + ("error while closing representation info file " + & Get_Name_String (Output_File_Name)); + end if; + 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_List_File -- + ---------------------- + + procedure Create_List_File (S : String) is + F : File_Name_Type; + pragma Warnings (Off, F); + begin + if S (S'First) = '.' then + F := Create_Auxiliary_File (Current_Main, S (S'First + 1 .. S'Last)); + + else + Name_Buffer (1 .. S'Length) := S; + Name_Len := S'Length + 1; + Name_Buffer (Name_Len) := ASCII.NUL; + Create_File_And_Check (Output_FD, Text); + end if; + end Create_List_File; + + -------------------------------- + -- Create_Output_Library_Info -- + -------------------------------- + + procedure Create_Output_Library_Info is + Dummy : Boolean; + pragma Unreferenced (Dummy); + + begin + Set_Library_Info_Name; + Delete_File (Name_Buffer (1 .. Name_Len), Dummy); + Create_File_And_Check (Output_FD, Text); + end Create_Output_Library_Info; + + ------------------------- + -- Create_Repinfo_File -- + ------------------------- + + procedure Create_Repinfo_File (Src : String) is + Discard : File_Name_Type; + pragma Warnings (Off, Discard); + begin + Name_Buffer (1 .. Src'Length) := Src; + Name_Len := Src'Length; + Discard := Create_Auxiliary_File (Name_Find, "rep"); + return; + end Create_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; + + --------------------------------- + -- Get_Output_Object_File_Name -- + --------------------------------- + + function Get_Output_Object_File_Name return String is + begin + pragma Assert (Output_Object_File_Name /= null); + + return Output_Object_File_Name.all; + end Get_Output_Object_File_Name; + + ----------------------- + -- 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) := '.'; + + -- If we are in multiple unit per file mode, then add ~nnn + -- extension to the name before doing the comparison. + + if Multiple_Unit_Index /= 0 then + declare + Exten : constant String := Name_Buffer (Dot_Index .. Name_Len); + begin + Name_Len := Dot_Index - 1; + Add_Char_To_Name_Buffer (Multi_Unit_Index_Character); + Add_Nat_To_Name_Buffer (Multiple_Unit_Index); + Dot_Index := Name_Len + 1; + Add_Str_To_Name_Buffer (Exten); + end; + end if; + + -- Remove extension preparing to replace it + + declare + Name : String := Name_Buffer (1 .. Dot_Index); + First : Positive; + + begin + Name_Buffer (1 .. Output_Object_File_Name'Length) := + Output_Object_File_Name.all; + + -- Put two names in canonical case, to allow object file names + -- with upper-case letters on Windows. + + Canonical_Case_File_Name (Name); + Canonical_Case_File_Name + (Name_Buffer (1 .. Output_Object_File_Name'Length)); + + 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; + + -- Dot_Index should not be zero now (we check for extension + -- elsewhere). + + pragma Assert (Dot_Index /= 0); + + -- Look for first character of file name + + First := Dot_Index; + while First > 1 + and then Name_Buffer (First - 1) /= Directory_Separator + and then Name_Buffer (First - 1) /= '/' + loop + First := First - 1; + end loop; + + -- Check name of object file is what we expect + + if Name /= Name_Buffer (First .. 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 := Target_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 + Status : Boolean; + begin + Tree_Write_Terminate; + Close (Output_FD, Status); + + if not Status then + Fail + ("error while closing tree file " + & Get_Name_String (Output_File_Name)); + end if; + 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 := Name_Len + 1; + + 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 extension to adt + + Name_Buffer (Dot_Index) := '.'; + 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_List_Info -- + --------------------- + + procedure Write_List_Info (S : String) is + begin + Write_With_Check (S'Address, S'Length); + end Write_List_Info; + + ------------------------ + -- Write_Repinfo_Line -- + ------------------------ + + procedure Write_Repinfo_Line (Info : String) renames Write_Info; + +begin + Adjust_OS_Resource_Limits; + + Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access; + Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access; + Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access; + + Opt.Create_List_File_Access := Create_List_File'Access; + Opt.Write_List_Info_Access := Write_List_Info'Access; + Opt.Close_List_File_Access := Close_List_File'Access; + + Set_Program (Compiler); +end Osint.C; -- cgit v1.2.3