-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2005, AdaCore --
-- --
-- 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- --
-- 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. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Gnatvsn;
with Hostparm;
-procedure Gnatchop is
+with System.CRTL; use System.CRTL;
- Cwrite : constant String :=
- "GNATCHOP " &
- Gnatvsn.Gnat_Version_String &
- " Copyright 1998-2000, Ada Core Technologies Inc.";
+procedure Gnatchop is
Terminate_Program : exception;
-- Used to terminate execution immediately
Gnat_Cmd : String_Access;
-- Command to execute the GNAT compiler
- Gnat_Args : Argument_List_Access := new Argument_List'
- (new String'("-c"), new String'("-x"), new String'("ada"),
- new String'("-gnats"), new String'("-gnatu"));
+ Gnat_Args : Argument_List_Access :=
+ new Argument_List'
+ (new String'("-c"),
+ new String'("-x"),
+ new String'("ada"),
+ new String'("-gnats"),
+ new String'("-gnatu"));
-- Arguments used in Gnat_Cmd call
EOF : constant Character := Character'Val (26);
-- 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 --
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 --
---------------
if not Warning then
Set_Exit_Status (Failure);
- end if;
- if Exit_On_Error then
- raise Terminate_Program;
+ if Exit_On_Error then
+ raise Terminate_Program;
+ end if;
end if;
end Error_Msg;
if not Is_Duplicated (SNum) then
declare
- Info : Unit_Info := Unit.Table (Sorted_Units.Table (SNum));
+ Info : constant Unit_Info :=
+ Unit.Table (Sorted_Units.Table (SNum));
begin
if Is_Writable_File (Info.File_Name.all) then
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;
+ Current_Command : constant String := Normalize_Pathname (Command_Name);
+ End_Of_Prefix : Natural;
+ Start_Of_Prefix : Positive;
Result : String_Access;
begin
+ Start_Of_Prefix := Current_Command'First;
+ 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;
----------------
function Parse_File (Num : File_Num) return Boolean is
- Chop_Name : constant String_Access := File.Table (Num).Name;
+ Chop_Name : constant String_Access := File.Table (Num).Name;
+ Save_Stdout : constant File_Descriptor := dup (Standout);
Offset_Name : Temp_File_Name;
Offset_FD : File_Descriptor;
- Save_Stdout : File_Descriptor := dup (Standout);
Buffer : String_Access;
Success : Boolean;
Failure : exception;
(Chop_File : File_Num;
Source : access String)
is
- First_Unit : Unit_Num := Unit.Last + 1;
- Bufferg : String_Access := null;
- Parse_Ptr : File_Offset := Source'First;
+ First_Unit : constant Unit_Num := Unit.Last + 1;
+ Bufferg : String_Access := null;
+ Parse_Ptr : File_Offset := Source'First;
Token_Ptr : File_Offset;
Info : Unit_Info;
else
Error_Msg ("-k# requires numeric parameter");
end if;
+
return False;
end if;
end loop;
end;
when 'p' =>
- Preserve_Mode := True;
+ Preserve_Mode := True;
when 'q' =>
- Quiet_Mode := True;
+ Quiet_Mode := True;
when 'r' =>
Source_References := True;
when 'v' =>
- Verbose_Mode := True;
- Put_Line (Standard_Error, Cwrite);
+ Verbose_Mode := True;
+
+ -- Why is following written to standard error. Most other
+ -- tools write to standard output ???
+
+ Put (Standard_Error, "GNATCHOP ");
+ Put_Line (Standard_Error, Gnatvsn.Gnat_Version_String);
+ Put_Line
+ (Standard_Error, "Copyright 1998-2005, AdaCore");
when 'w' =>
- Overwrite_Files := True;
+ Overwrite_Files := True;
when 'x' =>
- Exit_On_Error := True;
+ Exit_On_Error := True;
when others =>
null;
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;
-- 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.
+
+ if not Hostparm.OpenVMS then
+ declare
+ Command : constant String := Command_Name;
+
+ begin
+ for Index in reverse Command'Range loop
+ if Command (Index) = Directory_Separator then
+ declare
+ Absolute_Dir : constant String :=
+ Normalize_Pathname
+ (Command (Command'First .. Index));
+
+ PATH : constant String :=
+ Absolute_Dir &
+ Path_Separator &
+ Getenv ("PATH").all;
+
+ begin
+ Setenv ("PATH", PATH);
+ end;
+
+ exit;
+ end if;
+ end loop;
+ end;
+ end if;
+
-- Process command line options and initialize global variables
if not Scan_Arguments then
if Warning_Count > 0 then
declare
- Warnings_Msg : String := Warning_Count'Img & " warning(s)";
+ Warnings_Msg : constant String := Warning_Count'Img & " warning(s)";
begin
- Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last));
+ Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last), Warning => True);
end;
end if;
OSDN Git Service
