-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2004 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2008, 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 Ada.Command_Line; use Ada.Command_Line;
-with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Characters.Conversions; use Ada.Characters.Conversions;
+with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Directories; use Ada.Directories;
+with Ada.Streams.Stream_IO; use Ada.Streams;
+with Ada.Text_IO; use Ada.Text_IO;
+with System.CRTL; use System; use System.CRTL;
-with GNAT.Command_Line; use GNAT.Command_Line;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Command_Line; use GNAT.Command_Line;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Heap_Sort_G;
with GNAT.Table;
-with Gnatvsn;
with Hostparm;
+with Switch; use Switch;
+with Types;
procedure Gnatchop is
- Terminate_Program : exception;
- -- Used to terminate execution immediately
-
Config_File_Name : constant String_Access := new String'("gnat.adc");
-- The name of the file holding the GNAT configuration pragmas
-- Arguments used in Gnat_Cmd call
EOF : constant Character := Character'Val (26);
- -- Special character to signal end of file. Not required in input
- -- files, but properly treated if present. Not generated in output
- -- files except as a result of copying input file.
+ -- Special character to signal end of file. Not required in input files,
+ -- but properly treated if present. Not generated in output files except
+ -- as a result of copying input file.
--------------------
-- File arguments --
-- Index of unit in sorted unit list
Bufferg : String_Access;
- -- Pointer to buffer containing configuration pragmas to be
- -- prepended. Null if no pragmas to be prepended.
-
+ -- Pointer to buffer containing configuration pragmas to be prepended.
+ -- Null if no pragmas to be prepended.
end record;
-- The following table stores the unit offset information
-- Note that this function returns false for the last entry.
procedure Sort_Units;
- -- Sort units and set up sorted unit table.
+ -- Sort units and set up sorted unit table
----------------------
-- File_Descriptors --
function dup (handle : File_Descriptor) return File_Descriptor;
function dup2 (from, to : File_Descriptor) return File_Descriptor;
- -- File descriptor based functions needed for redirecting stdin/stdout
-
- pragma Import (C, dup, "dup");
- pragma Import (C, dup2, "dup2");
---------------------
-- Local variables --
function Locate_Executable
(Program_Name : String;
- Look_For_Prefix : Boolean := True)
- return String_Access;
+ Look_For_Prefix : Boolean := True) return String_Access;
-- Locate executable for given program name. This takes into account
-- the target-prefix of the current command, if Look_For_Prefix is True.
end record;
function Get_EOL
- (Source : access String;
- Start : Positive)
- return EOL_String;
+ (Source : not null access String;
+ Start : Positive) return EOL_String;
-- Return the line terminator used in the passed string
- procedure Parse_EOL (Source : access String; Ptr : in out Positive);
+ procedure Parse_EOL
+ (Source : not null access String;
+ Ptr : in out Positive);
-- On return Source (Ptr) is the first character of the next line
-- or EOF. Source.all must be terminated by EOF.
-- completes, False if some system error (e.g. failure to read the
-- offset information) occurs.
- procedure Parse_Offset_Info (Chop_File : File_Num; Source : access String);
+ procedure Parse_Offset_Info
+ (Chop_File : File_Num;
+ Source : not null access String);
-- Parses the output of the compiler indicating the offsets
-- and names of the compilation units in Chop_File.
procedure Parse_Token
- (Source : access String;
+ (Source : not null access String;
Ptr : in out Positive;
Token_Ptr : out Positive);
-- Skips any separators and stores the start of the token in Token_Ptr.
function Report_Duplicate_Units return Boolean;
-- Output messages about duplicate units in the input files in Unit.Table
- -- Returns True if any duplicates found, Fals if no duplicates found.
+ -- Returns True if any duplicates found, False if no duplicates found.
function Scan_Arguments return Boolean;
-- Scan command line options and set global variables accordingly.
function Get_Config_Pragmas
(Input : File_Num;
- U : Unit_Num)
- return String_Access;
+ U : Unit_Num) return String_Access;
-- Call to read configuration pragmas from given unit entry, and
-- return a buffer containing the pragmas to be appended to
-- following units. Input is the file number for the chop file and
procedure Write_Source_Reference_Pragma
(Info : Unit_Info;
Line : Line_Num;
- FD : File_Descriptor;
+ File : Stream_IO.File_Type;
EOL : EOL_String;
Success : in out Boolean);
-- If Success is True on entry, writes a source reference pragma using
-- of line sequence to be written at the end of the pragma.
procedure Write_Unit
- (Source : access String;
+ (Source : not null access String;
Num : Unit_Num;
TS_Time : OS_Time;
Success : out Boolean);
-- Write one compilation unit of the source to file
+ ---------
+ -- dup --
+ ---------
+
+ function dup (handle : File_Descriptor) return File_Descriptor is
+ begin
+ return File_Descriptor (System.CRTL.dup (int (handle)));
+ end dup;
+
+ ----------
+ -- dup2 --
+ ----------
+
+ function dup2 (from, to : File_Descriptor) return File_Descriptor is
+ begin
+ return File_Descriptor (System.CRTL.dup2 (int (from), int (to)));
+ end dup2;
+
---------------
-- Error_Msg --
---------------
Set_Exit_Status (Failure);
if Exit_On_Error then
- raise Terminate_Program;
+ raise Types.Terminate_Program;
end if;
end if;
end Error_Msg;
Info : Unit_Info renames Unit.Table (U);
FD : File_Descriptor;
Name : aliased constant String :=
- File.Table (Input).Name.all & ASCII.Nul;
+ File.Table (Input).Name.all & ASCII.NUL;
Length : File_Offset;
Buffer : String_Access;
- Success : Boolean;
Result : String_Access;
+ Success : Boolean;
+ pragma Warnings (Off, Success);
+
begin
FD := Open_Read (Name'Address, Binary);
-------------
function Get_EOL
- (Source : access String;
+ (Source : not null access String;
Start : Positive)
return EOL_String
is
First := Ptr + 1;
end if;
- -- Recognize CR/LF or LF/CR combination
+ -- Recognize CR/LF
- if (Source (Ptr + 1) = ASCII.CR or Source (Ptr + 1) = ASCII.LF)
- and then Source (Ptr) /= Source (Ptr + 1)
- then
+ if Source (Ptr) = ASCII.CR and then Source (Ptr + 1) = ASCII.LF then
Last := First + 1;
end if;
function Locate_Executable
(Program_Name : String;
- Look_For_Prefix : Boolean := True)
- return String_Access
+ Look_For_Prefix : Boolean := True) return String_Access
is
- Current_Command : constant String := Command_Name;
- End_Of_Prefix : Natural := Current_Command'First - 1;
- Start_Of_Prefix : Positive := Current_Command'First;
+ Gnatchop_Str : constant String := "gnatchop";
+ Current_Command : constant String := Normalize_Pathname (Command_Name);
+ End_Of_Prefix : Natural;
+ Start_Of_Prefix : Positive;
+ Start_Of_Suffix : Positive;
Result : String_Access;
begin
+ Start_Of_Prefix := Current_Command'First;
+ Start_Of_Suffix := Current_Command'Last + 1;
+ End_Of_Prefix := Start_Of_Prefix - 1;
if Look_For_Prefix then
+
-- Find Start_Of_Prefix
for J in reverse Current_Command'Range loop
-- Find End_Of_Prefix
- End_Of_Prefix := Start_Of_Prefix - 1;
-
- for J in reverse Start_Of_Prefix .. Current_Command'Last loop
- if Current_Command (J) = '-' then
- End_Of_Prefix := J;
+ for J in Start_Of_Prefix ..
+ Current_Command'Last - Gnatchop_Str'Length + 1
+ loop
+ if Current_Command (J .. J + Gnatchop_Str'Length - 1) =
+ Gnatchop_Str
+ then
+ End_Of_Prefix := J - 1;
exit;
end if;
end loop;
end if;
+ if End_Of_Prefix > Current_Command'First then
+ Start_Of_Suffix := End_Of_Prefix + Gnatchop_Str'Length + 1;
+ end if;
+
declare
Command : constant String :=
- Current_Command (Start_Of_Prefix .. End_Of_Prefix) &
- Program_Name;
+ Current_Command (Start_Of_Prefix .. End_Of_Prefix)
+ & Program_Name
+ & Current_Command (Start_Of_Suffix ..
+ Current_Command'Last);
begin
Result := Locate_Exec_On_Path (Command);
-- Parse_EOL --
---------------
- procedure Parse_EOL (Source : access String; Ptr : in out Positive) is
+ procedure Parse_EOL
+ (Source : not null access String;
+ Ptr : in out Positive) is
begin
-- Skip to end of line
return Success;
exception
- when Failure | Terminate_Program =>
+ when Failure | Types.Terminate_Program =>
Close (Offset_FD);
Delete_File (Offset_Name'Address, Success);
return False;
procedure Parse_Offset_Info
(Chop_File : File_Num;
- Source : access String)
+ Source : not null access String)
is
First_Unit : constant Unit_Num := Unit.Last + 1;
Bufferg : String_Access := null;
-- Note that the unit name can be an operator name in quotes.
-- This is of course illegal, but both GNAT and gnatchop handle
- -- the case so that this error does not intefere with chopping.
+ -- the case so that this error does not interfere with chopping.
-- The SR ir present indicates that a source reference pragma
-- was processed as part of this unit (and that therefore no
-----------------
procedure Parse_Token
- (Source : access String;
+ (Source : not null access String;
Ptr : in out Positive;
Token_Ptr : out Positive)
is
Contents := new String (1 .. Read_Ptr);
Contents.all := Buffer (1 .. Read_Ptr);
- -- Things aren't simple on VMS due to the plethora of file types
- -- and organizations. It seems clear that there shouldn't be more
- -- bytes read than are contained in the file though.
+ -- Things aren't simple on VMS due to the plethora of file types and
+ -- organizations. It seems clear that there shouldn't be more bytes
+ -- read than are contained in the file though.
if Hostparm.OpenVMS then
Success := Read_Ptr <= Length + 1;
when 'h' =>
Usage;
- raise Terminate_Program;
+ raise Types.Terminate_Program;
when 'k' =>
declare
when 'v' =>
Verbose_Mode := True;
-
- -- Why is following written to standard error. Most other
- -- tools write to standard output ???
-
- Put (Standard_Error, "GNATCHOP ");
- Put (Standard_Error, Gnatvsn.Gnat_Version_String);
- Put_Line
- (Standard_Error,
- " Copyright 1998-2004, Ada Core Technologies Inc.");
+ Display_Version ("GNATCHOP", "1998");
when 'w' =>
Overwrite_Files := True;
F : constant String := File.Table (File_Num).Name.all;
begin
-
if Is_Directory (F) then
Error_Msg (F & " is a directory, cannot be chopped");
return False;
end if;
return False;
-
end Scan_Arguments;
----------------
Unit_Sort.Sort (Natural (Unit.Last));
- -- Set the Sorted_Index fields in the unit tables.
+ -- Set the Sorted_Index fields in the unit tables
for J in 1 .. SUnit_Num (Unit.Last) loop
Unit.Table (Sorted_Units.Table (J)).Sorted_Index := J;
function Write_Chopped_Files (Input : File_Num) return Boolean is
Name : aliased constant String :=
- File.Table (Input).Name.all & ASCII.Nul;
+ File.Table (Input).Name.all & ASCII.NUL;
FD : File_Descriptor;
Buffer : String_Access;
Success : Boolean;
Close (FD);
return Success;
-
end Write_Chopped_Files;
-----------------------
procedure Write_Source_Reference_Pragma
(Info : Unit_Info;
Line : Line_Num;
- FD : File_Descriptor;
+ File : Stream_IO.File_Type;
EOL : EOL_String;
Success : in out Boolean)
is
- FTE : File_Entry renames File.Table (Info.Chop_File);
+ FTE : File_Entry renames Gnatchop.File.Table (Info.Chop_File);
Nam : String_Access;
begin
end if;
declare
- Reference : aliased String :=
+ Reference : String :=
"pragma Source_Reference (000000, """
& Nam.all & """);" & EOL.Str;
pragma Assert (Lin = 0);
- Success :=
- Write (FD, Reference'Address, Reference'Length)
- = Reference'Length;
+ begin
+ String'Write (Stream_IO.Stream (File), Reference);
+ Success := True;
+ exception
+ when others =>
+ Success := False;
+ end;
end;
end if;
end Write_Source_Reference_Pragma;
----------------
procedure Write_Unit
- (Source : access String;
+ (Source : not null access String;
Num : Unit_Num;
TS_Time : OS_Time;
Success : out Boolean)
is
- Info : Unit_Info renames Unit.Table (Num);
- FD : File_Descriptor;
- Name : aliased constant String := Info.File_Name.all & ASCII.NUL;
- Length : File_Offset;
- EOL : constant EOL_String :=
- Get_EOL (Source, Source'First + Info.Offset);
+
+ procedure OS_Filename
+ (Name : String;
+ W_Name : Wide_String;
+ OS_Name : Address;
+ N_Length : access Natural;
+ Encoding : Address;
+ E_Length : access Natural);
+ pragma Import (C, OS_Filename, "__gnat_os_filename");
+ -- Returns in OS_Name the proper name for the OS when used with the
+ -- returned Encoding value. For example on Windows this will return the
+ -- UTF-8 encoded name into OS_Name and set Encoding to encoding=utf8
+ -- (the form parameter for Stream_IO).
+ --
+ -- Name is the filename and W_Name the same filename in Unicode 16 bits
+ -- (this corresponds to Win32 Unicode ISO/IEC 10646). N_Length/E_Length
+ -- are the length returned in OS_Name/Encoding respectively.
+
+ Info : Unit_Info renames Unit.Table (Num);
+ Name : aliased constant String := Info.File_Name.all & ASCII.NUL;
+ W_Name : aliased constant Wide_String := To_Wide_String (Name);
+ EOL : constant EOL_String :=
+ Get_EOL (Source, Source'First + Info.Offset);
+
+ OS_Name : aliased String (1 .. Name'Length * 2);
+ O_Length : aliased Natural := OS_Name'Length;
+ Encoding : aliased String (1 .. 64);
+ E_Length : aliased Natural := Encoding'Length;
+
+ Length : File_Offset;
begin
-- Skip duplicated files
return;
end if;
- if Overwrite_Files then
- FD := Create_File (Name'Address, Binary);
- else
- FD := Create_New_File (Name'Address, Binary);
- end if;
+ -- Get OS filename
- Success := FD /= Invalid_FD;
+ OS_Filename
+ (Name, W_Name,
+ OS_Name'Address, O_Length'Access,
+ Encoding'Address, E_Length'Access);
- if not Success then
- Error_Msg ("cannot create " & Info.File_Name.all);
- return;
- end if;
+ declare
+ E_Name : constant String := OS_Name (1 .. O_Length);
+ C_Name : aliased constant String := E_Name & ASCII.NUL;
+ OS_Encoding : constant String := Encoding (1 .. E_Length);
+ File : Stream_IO.File_Type;
- -- A length of 0 indicates that the rest of the file belongs to
- -- this unit. The actual length must be calculated now. Take into
- -- account that the last character (EOF) must not be written.
+ begin
+ begin
+ if not Overwrite_Files and then Exists (E_Name) then
+ raise Stream_IO.Name_Error;
+ else
+ Stream_IO.Create
+ (File, Stream_IO.Out_File, E_Name, OS_Encoding);
+ Success := True;
+ end if;
- if Info.Length = 0 then
- Length := Source'Last - (Source'First + Info.Offset);
- else
- Length := Info.Length;
- end if;
+ exception
+ when Stream_IO.Name_Error | Stream_IO.Use_Error =>
+ Error_Msg ("cannot create " & Info.File_Name.all);
+ return;
+ end;
- -- Prepend configuration pragmas if necessary
+ -- A length of 0 indicates that the rest of the file belongs to
+ -- this unit. The actual length must be calculated now. Take into
+ -- account that the last character (EOF) must not be written.
- if Success and then Info.Bufferg /= null then
- Write_Source_Reference_Pragma (Info, 1, FD, EOL, Success);
- Success :=
- Write (FD, Info.Bufferg.all'Address, Info.Bufferg'Length) =
- Info.Bufferg'Length;
- end if;
+ if Info.Length = 0 then
+ Length := Source'Last - (Source'First + Info.Offset);
+ else
+ Length := Info.Length;
+ end if;
- Write_Source_Reference_Pragma (Info, Info.Start_Line, FD, EOL, Success);
+ -- Prepend configuration pragmas if necessary
- if Success then
- Success := Write (FD, Source (Source'First + Info.Offset)'Address,
- Length) = Length;
- end if;
+ if Success and then Info.Bufferg /= null then
+ Write_Source_Reference_Pragma (Info, 1, File, EOL, Success);
+ String'Write (Stream_IO.Stream (File), Info.Bufferg.all);
+ end if;
- if not Success then
- Error_Msg ("disk full writing " & Info.File_Name.all);
- return;
- end if;
+ Write_Source_Reference_Pragma
+ (Info, Info.Start_Line, File, EOL, Success);
- if not Quiet_Mode then
- Put_Line (" " & Info.File_Name.all);
- end if;
+ if Success then
+ begin
+ String'Write
+ (Stream_IO.Stream (File),
+ Source (Source'First + Info.Offset ..
+ Source'First + Info.Offset + Length - 1));
+ exception
+ when Stream_IO.Use_Error | Stream_IO.Device_Error =>
+ Error_Msg ("disk full writing " & Info.File_Name.all);
+ return;
+ end;
+ end if;
- Close (FD);
+ if not Quiet_Mode then
+ Put_Line (" " & Info.File_Name.all);
+ end if;
- if Preserve_Mode then
- File_Time_Stamp (Name'Address, TS_Time);
- end if;
+ Stream_IO.Close (File);
+ if Preserve_Mode then
+ File_Time_Stamp (C_Name'Address, TS_Time);
+ end if;
+ end;
end Write_Unit;
+ procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
+
-- Start of processing for gnatchop
begin
- -- Add the directory where gnatchop is invoked in front of the
- -- path, if gnatchop is invoked with directory information.
- -- Only do this if the platform is not VMS, where the notion of path
- -- does not really exist.
+ -- Add the directory where gnatchop is invoked in front of the path, if
+ -- gnatchop is invoked with directory information. Only do this if the
+ -- platform is not VMS, where the notion of path does not really exist.
if not Hostparm.OpenVMS then
declare
Absolute_Dir : constant String :=
Normalize_Pathname
(Command (Command'First .. Index));
-
PATH : constant String :=
- Absolute_Dir &
- Path_Separator &
- Getenv ("PATH").all;
-
+ Absolute_Dir
+ & Path_Separator
+ & Getenv ("PATH").all;
begin
Setenv ("PATH", PATH);
end;
-- Process command line options and initialize global variables
+ -- First, scan to detect --version and/or --help
+
+ Check_Version_And_Help ("GNATCHOP", "1998");
+
if not Scan_Arguments then
Set_Exit_Status (Failure);
return;
Sort_Units;
- -- Check if any duplicate files would be created. If so, emit
- -- a warning if Overwrite_Files is true, otherwise generate an error.
+ -- Check if any duplicate files would be created. If so, emit a warning if
+ -- Overwrite_Files is true, otherwise generate an error.
if Report_Duplicate_Units and then not Overwrite_Files then
goto No_Files_Written;
end if;
- -- Check if any files exist, if so do not write anything
- -- Because all files have been parsed and checked already,
- -- there won't be any duplicates
+ -- Check if any files exist, if so do not write anything Because all files
+ -- have been parsed and checked already, there won't be any duplicates
if not Overwrite_Files and then Files_Exist then
goto No_Files_Written;
end if;
- -- After this point, all source files are read in succession
- -- and chopped into their destination files.
+ -- After this point, all source files are read in succession and chopped
+ -- into their destination files.
- -- As the Source_File_Name pragmas are handled as logical file 0,
- -- write it first.
+ -- Source_File_Name pragmas are handled as logical file 0 so write it first
for F in 1 .. File.Last loop
if not Write_Chopped_Files (F) then
return;
exception
- when Terminate_Program =>
+ when Types.Terminate_Program =>
null;
end Gnatchop;
OSDN Git Service
