| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- O S I N T - C -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-2014, 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 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); |
| |
| Name_Buffer (Name_Len + 1) := '.'; |
| 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; |
| 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; |
| |
| ------------------------------ |
| -- Open_Output_Library_Info -- |
| ------------------------------ |
| |
| procedure Open_Output_Library_Info is |
| begin |
| Set_Library_Info_Name; |
| Open_File_To_Append_And_Check (Output_FD, Text); |
| end Open_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; |
