-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
+-- 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 2, or (at your option) any later ver- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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 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.
+ -- 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.
+ -- 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).
+ -- 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.
+ -- 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
+ -- Name_Buffer (with length in Name_Len) on return from the call.
----------------------
-- Close_Debug_File --
if not Status then
Fail
- ("error while closing expanded source file ",
- Get_Name_String (Output_File_Name));
+ ("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 --
-------------------------------
if not Status then
Fail
- ("error while closing ALI file ",
- Get_Name_String (Output_File_Name));
+ ("error while closing ALI file "
+ & Get_Name_String (Output_File_Name));
end if;
end Close_Output_Library_Info;
if not Status then
Fail
- ("error while closing representation info file ",
- Get_Name_String (Output_File_Name));
+ ("error while closing representation info file "
+ & Get_Name_String (Output_File_Name));
end if;
end Close_Repinfo_File;
function Create_Auxiliary_File
(Src : File_Name_Type;
- Suffix : String) return File_Name_Type
+ Suffix : String) return File_Name_Type
is
Result : File_Name_Type;
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) :=
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;
- --------------------------
- -- 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);
+ -------------------------
+ -- 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 Creat_Repinfo_File;
+ end Create_Repinfo_File;
---------------------------
-- Debug_File_Eol_Length --
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 --
-----------------------
-- Remove extension preparing to replace it
declare
- Name : constant String := Name_Buffer (1 .. Dot_Index);
- Len : constant Natural := Dot_Index;
+ Name : String := Name_Buffer (1 .. Dot_Index);
+ First : Positive;
begin
Name_Buffer (1 .. Output_Object_File_Name'Length) :=
Output_Object_File_Name.all;
- Dot_Index := 0;
+ -- 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;
end if;
end loop;
- -- Dot_Index should be zero now (we check for extension elsewhere)
+ -- 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 (Dot_Index - Len + 1 .. Dot_Index) then
+ if Name /= Name_Buffer (First .. Dot_Index) then
Fail ("incorrect object file name");
end if;
end;
---------------------------------
procedure Set_Output_Object_File_Name (Name : String) is
- Ext : constant String := Object_Suffix;
+ 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.
+ -- Make sure that the object file has the expected extension
if NL <= EL
or else
if not Status then
Fail
- ("error while closing tree file ",
- Get_Name_String (Output_File_Name));
+ ("error while closing tree file "
+ & Get_Name_String (Output_File_Name));
end if;
end Tree_Close;
pragma Assert (Dot_Index /= 0);
- -- Change exctension to adt
+ -- Change extension to adt
Name_Buffer (Dot_Index) := '.';
Name_Buffer (Dot_Index + 1) := 'a';
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.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);
+ 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;
OSDN Git Service
