------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- O S I N T - C -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2013, 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. ---------------------- -- 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;