with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
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;
procedure Gnatchop is
Cwrite : constant String :=
"GNATCHOP " &
Gnatvsn.Gnat_Version_String &
" Copyright 1998-2000, Ada Core Technologies Inc.";
Terminate_Program : exception;
Config_File_Name : constant String_Access := new String'("gnat.adc");
Gcc : String_Access := new String'("gcc");
Gcc_Set : Boolean := False;
Gnat_Cmd : String_Access;
Gnat_Args : Argument_List_Access := new Argument_List'
(new String'("-c"), new String'("-x"), new String'("ada"),
new String'("-gnats"), new String'("-gnatu"));
EOF : constant Character := Character'Val (26);
subtype File_Num is Natural;
subtype File_Offset is Natural;
type File_Entry is record
Name : String_Access;
SR_Name : String_Access;
end record;
package File is new GNAT.Table
(Table_Component_Type => File_Entry,
Table_Index_Type => File_Num,
Table_Low_Bound => 1,
Table_Initial => 100,
Table_Increment => 100);
Directory : String_Access;
Compilation_Mode : Boolean := False;
Overwrite_Files : Boolean := False;
Preserve_Mode : Boolean := False;
Quiet_Mode : Boolean := False;
Source_References : Boolean := False;
Verbose_Mode : Boolean := False;
Exit_On_Error : Boolean := False;
Write_gnat_adc : Boolean := False;
type Line_Num is new Natural;
type Unit_Count_Type is new Integer;
subtype Unit_Num is Unit_Count_Type range 1 .. Unit_Count_Type'Last;
type SUnit_Num is new Integer;
type Unit_Kind is (Unit_Spec, Unit_Body, Config_Pragmas);
type Unit_Info is record
File_Name : String_Access;
Chop_File : File_Num;
Start_Line : Line_Num;
Offset : File_Offset;
SR_Present : Boolean;
Length : File_Offset;
Kind : Unit_Kind;
Sorted_Index : SUnit_Num;
Bufferg : String_Access;
end record;
package Unit is new GNAT.Table
(Table_Component_Type => Unit_Info,
Table_Index_Type => Unit_Count_Type,
Table_Low_Bound => 1,
Table_Initial => 500,
Table_Increment => 100);
package Sorted_Units is new GNAT.Table
(Table_Component_Type => Unit_Num,
Table_Index_Type => SUnit_Num,
Table_Low_Bound => 0,
Table_Initial => 500,
Table_Increment => 100);
function Is_Duplicated (U : SUnit_Num) return Boolean;
procedure Sort_Units;
function dup (handle : File_Descriptor) return File_Descriptor;
function dup2 (from, to : File_Descriptor) return File_Descriptor;
pragma Import (C, dup, "dup");
pragma Import (C, dup2, "dup2");
Warning_Count : Natural := 0;
procedure Error_Msg (Message : String);
procedure File_Time_Stamp (Name : C_File_Name; Time : OS_Time);
function Files_Exist return Boolean;
function Get_Maximum_File_Name_Length return Integer;
pragma Import (C, Get_Maximum_File_Name_Length,
"__gnat_get_maximum_file_name_length");
Maximum_File_Name_Length : constant Integer := Get_Maximum_File_Name_Length;
Maximum_File_Name_Length_String : constant String :=
Integer'Image
(Maximum_File_Name_Length);
function Locate_Executable
(Program_Name : String;
Look_For_Prefix : Boolean := True)
return String_Access;
subtype EOL_Length is Natural range 0 .. 2;
type EOL_String (Len : EOL_Length := 0) is record
Str : String (1 .. Len);
end record;
function Get_EOL
(Source : access String;
Start : Positive)
return EOL_String;
procedure Parse_EOL (Source : access String; Ptr : in out Positive);
function Parse_File (Num : File_Num) return Boolean;
procedure Parse_Offset_Info (Chop_File : File_Num; Source : access String);
procedure Parse_Token
(Source : access String;
Ptr : in out Positive;
Token_Ptr : out Positive);
procedure Read_File
(FD : File_Descriptor;
Contents : out String_Access;
Success : out Boolean);
function Report_Duplicate_Units return Boolean;
function Scan_Arguments return Boolean;
procedure Usage;
procedure Warning_Msg (Message : String);
function Write_Chopped_Files (Input : File_Num) return Boolean;
procedure Write_Config_File (Input : File_Num; U : Unit_Num);
function Get_Config_Pragmas
(Input : File_Num;
U : Unit_Num)
return String_Access;
procedure Write_Source_Reference_Pragma
(Info : Unit_Info;
Line : Line_Num;
FD : File_Descriptor;
EOL : EOL_String;
Success : in out Boolean);
procedure Write_Unit
(Source : access String;
Num : Unit_Num;
TS_Time : OS_Time;
Success : out Boolean);
procedure Error_Msg (Message : String) is
begin
Put_Line (Standard_Error, Message);
Set_Exit_Status (Failure);
if Exit_On_Error then
raise Terminate_Program;
end if;
end Error_Msg;
procedure File_Time_Stamp (Name : C_File_Name; Time : OS_Time) is
procedure Set_File_Time (Name : C_File_Name; Time : OS_Time);
pragma Import (C, Set_File_Time, "__gnat_set_file_time_name");
begin
Set_File_Time (Name, Time);
end File_Time_Stamp;
function Files_Exist return Boolean is
Exists : Boolean := False;
begin
for SNum in 1 .. SUnit_Num (Unit.Last) loop
if not Is_Duplicated (SNum) then
declare
Info : Unit_Info := Unit.Table (Sorted_Units.Table (SNum));
begin
if Is_Writable_File (Info.File_Name.all) then
if Hostparm.OpenVMS then
Error_Msg
(Info.File_Name.all
& " already exists, use /OVERWRITE to overwrite");
else
Error_Msg (Info.File_Name.all
& " already exists, use -w to overwrite");
end if;
Exists := True;
end if;
end;
end if;
end loop;
return Exists;
end Files_Exist;
function Get_Config_Pragmas
(Input : File_Num;
U : Unit_Num)
return String_Access
is
Info : Unit_Info renames Unit.Table (U);
FD : File_Descriptor;
Name : aliased constant String :=
File.Table (Input).Name.all & ASCII.Nul;
Length : File_Offset;
Buffer : String_Access;
Success : Boolean;
Result : String_Access;
begin
FD := Open_Read (Name'Address, Binary);
if FD = Invalid_FD then
Error_Msg ("cannot open " & File.Table (Input).Name.all);
return null;
end if;
Read_File (FD, Buffer, Success);
if Info.Length = 0 then
Length := Buffer'Last - (Buffer'First + Info.Offset);
else
Length := Info.Length;
end if;
Result := new String'(Buffer (1 .. Length));
Close (FD);
return Result;
end Get_Config_Pragmas;
function Get_EOL
(Source : access String;
Start : Positive)
return EOL_String
is
Ptr : Positive := Start;
First : Positive;
Last : Natural;
begin
while Source (Ptr) /= ASCII.CR and then
Source (Ptr) /= ASCII.LF and then
Source (Ptr) /= EOF
loop
Ptr := Ptr + 1;
end loop;
Last := Ptr;
if Source (Ptr) /= EOF then
First := Ptr;
else
First := Ptr + 1;
end if;
if (Source (Ptr + 1) = ASCII.CR or Source (Ptr + 1) = ASCII.LF)
and then Source (Ptr) /= Source (Ptr + 1)
then
Last := First + 1;
end if;
return (Len => Last + 1 - First, Str => Source (First .. Last));
end Get_EOL;
function Is_Duplicated (U : SUnit_Num) return Boolean is
begin
return U < SUnit_Num (Unit.Last)
and then
Unit.Table (Sorted_Units.Table (U)).File_Name.all =
Unit.Table (Sorted_Units.Table (U + 1)).File_Name.all;
end Is_Duplicated;
function Locate_Executable
(Program_Name : String;
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;
Result : String_Access;
begin
if Look_For_Prefix then
for J in reverse Current_Command'Range loop
if Current_Command (J) = '/' or
Current_Command (J) = Directory_Separator or
Current_Command (J) = ':'
then
Start_Of_Prefix := J + 1;
exit;
end if;
end loop;
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;
exit;
end if;
end loop;
end if;
declare
Command : constant String :=
Current_Command (Start_Of_Prefix .. End_Of_Prefix) &
Program_Name;
begin
Result := Locate_Exec_On_Path (Command);
if Result = null then
Error_Msg
(Command & ": installation problem, executable not found");
end if;
end;
return Result;
end Locate_Executable;
procedure Parse_EOL (Source : access String; Ptr : in out Positive) is
begin
while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF
and then Source (Ptr) /= EOF
loop
Ptr := Ptr + 1;
end loop;
if Source (Ptr) /= EOF then
Ptr := Ptr + 1; end if;
if (Source (Ptr) = ASCII.CR or Source (Ptr) = ASCII.LF)
and then Source (Ptr) /= Source (Ptr - 1)
then
Ptr := Ptr + 1;
end if;
end Parse_EOL;
function Parse_File (Num : File_Num) return Boolean is
Chop_Name : constant String_Access := File.Table (Num).Name;
Offset_Name : Temp_File_Name;
Offset_FD : File_Descriptor;
Save_Stdout : File_Descriptor := dup (Standout);
Buffer : String_Access;
Success : Boolean;
Failure : exception;
begin
if Verbose_Mode then
Put (Gnat_Cmd.all);
for J in 1 .. Gnat_Args'Length loop
Put (' ');
Put (Gnat_Args (J).all);
end loop;
Put (' ');
Put_Line (Chop_Name.all);
end if;
Create_Temp_File (Offset_FD, Offset_Name);
if Offset_FD = Invalid_FD then
Error_Msg ("gnatchop: cannot create temporary file");
Close (Save_Stdout);
return False;
end if;
if dup2 (Offset_FD, Standout) = Invalid_FD then
Error_Msg ("gnatchop: cannot redirect stdout to temporary file");
Close (Save_Stdout);
Close (Offset_FD);
return False;
end if;
Spawn (Gnat_Cmd.all, Gnat_Args.all & Chop_Name, Success);
if not Success then
Error_Msg (Chop_Name.all & ": parse errors detected");
Error_Msg (Chop_Name.all & ": chop may not be successful");
end if;
if dup2 (Save_Stdout, Standout) = Invalid_FD then
Error_Msg ("gnatchop: cannot restore stdout");
end if;
Close (Offset_FD);
Close (Save_Stdout);
Offset_FD := Open_Read (Offset_Name'Address, Binary);
if Offset_FD = Invalid_FD then
Error_Msg ("gnatchop: cannot access offset info");
raise Failure;
end if;
Read_File (Offset_FD, Buffer, Success);
if not Success then
Error_Msg ("gnatchop: error reading offset info");
Close (Offset_FD);
raise Failure;
else
Parse_Offset_Info (Num, Buffer);
end if;
Close (Offset_FD);
Delete_File (Offset_Name'Address, Success);
return Success;
exception
when Failure | Terminate_Program =>
Close (Offset_FD);
Delete_File (Offset_Name'Address, Success);
return False;
end Parse_File;
procedure Parse_Offset_Info
(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;
Token_Ptr : File_Offset;
Info : Unit_Info;
function Match (Literal : String) return Boolean;
function Match (Literal : String) return Boolean is
begin
Parse_Token (Source, Parse_Ptr, Token_Ptr);
if Source'Last + 1 - Token_Ptr < Literal'Length
or else
Source (Token_Ptr .. Token_Ptr + Literal'Length - 1) /= Literal
then
Parse_Ptr := Token_Ptr;
return False;
end if;
Parse_Ptr := Token_Ptr + Literal'Length;
return True;
end Match;
begin
loop
Info.Chop_File := Chop_File;
Info.Length := 0;
if Match ("Unit") then
Parse_Token (Source, Parse_Ptr, Token_Ptr);
if Match ("(body)") then
Info.Kind := Unit_Body;
elsif Match ("(spec)") then
Info.Kind := Unit_Spec;
else
exit;
end if;
exit when not Match ("line");
Parse_Token (Source, Parse_Ptr, Token_Ptr);
Info.Start_Line := Line_Num'Value
(Source (Token_Ptr .. Parse_Ptr - 1));
exit when not Match ("file offset");
Parse_Token (Source, Parse_Ptr, Token_Ptr);
Info.Offset := File_Offset'Value
(Source (Token_Ptr .. Parse_Ptr - 1));
Info.SR_Present := Match ("SR, ");
exit when not Match ("file name");
Parse_Token (Source, Parse_Ptr, Token_Ptr);
Info.File_Name := new String'
(Directory.all & Source (Token_Ptr .. Parse_Ptr - 1));
Parse_EOL (Source, Parse_Ptr);
elsif Match ("Configuration pragmas at") then
Info.Kind := Config_Pragmas;
Info.File_Name := Config_File_Name;
exit when not Match ("line");
Parse_Token (Source, Parse_Ptr, Token_Ptr);
Info.Start_Line := Line_Num'Value
(Source (Token_Ptr .. Parse_Ptr - 1));
exit when not Match ("file offset");
Parse_Token (Source, Parse_Ptr, Token_Ptr);
Info.Offset := File_Offset'Value
(Source (Token_Ptr .. Parse_Ptr - 1));
Parse_EOL (Source, Parse_Ptr);
elsif Match ("Source_Reference pragma for file ") then
Parse_Token (Source, Parse_Ptr, Token_Ptr);
File.Table (Chop_File).SR_Name :=
new String'(Source (Token_Ptr + 1 .. Parse_Ptr - 2));
Parse_EOL (Source, Parse_Ptr);
goto Continue;
else
exit;
end if;
Unit.Increment_Last;
Unit.Table (Unit.Last) := Info;
if Unit.Last > First_Unit then
Unit.Table (Unit.Last - 1).Length :=
Info.Offset - Unit.Table (Unit.Last - 1).Offset;
end if;
if not Compilation_Mode
and then Unit.Last > First_Unit
and then Unit.Table (Unit.Last - 1).Kind = Config_Pragmas
then
Info.Start_Line := Unit.Table (Unit.Last - 1).Start_Line;
Info.Offset := Unit.Table (Unit.Last - 1).Offset;
Unit.Table (Unit.Last - 1) := Info;
Unit.Decrement_Last;
end if;
if Compilation_Mode
and then Unit.Last = First_Unit + 1
and then Unit.Table (First_Unit).Kind = Config_Pragmas
then
Bufferg :=
Get_Config_Pragmas
(Unit.Table (Unit.Last - 1).Chop_File, First_Unit);
Unit.Table (Unit.Last - 1) := Info;
Unit.Decrement_Last;
end if;
Unit.Table (Unit.Last).Bufferg := Bufferg;
if Compilation_Mode
and then Unit.Last > First_Unit
and then Unit.Table (Unit.Last).Kind = Config_Pragmas
then
Unit.Decrement_Last;
end if;
<<Continue>>
null;
end loop;
if Source (Parse_Ptr) /= EOF then
Error_Msg
(File.Table (Chop_File).Name.all & ": error parsing offset info");
return;
end if;
if Unit.Last = First_Unit
and then Unit.Table (Unit.Last).Kind = Config_Pragmas
then
if Compilation_Mode then
Write_Config_File (Unit.Table (Unit.Last).Chop_File, First_Unit);
Unit.Decrement_Last;
else
Error_Msg
(File.Table (Chop_File).Name.all &
": no units found (only pragmas)");
Unit.Decrement_Last;
end if;
end if;
if Unit.Last > First_Unit
and then Unit.Table (Unit.Last).Kind = Config_Pragmas
then
Unit.Decrement_Last;
end if;
end Parse_Offset_Info;
procedure Parse_Token
(Source : access String;
Ptr : in out Positive;
Token_Ptr : out Positive)
is
In_Quotes : Boolean := False;
begin
while Source (Ptr) = ' ' or Source (Ptr) = ',' loop
Ptr := Ptr + 1;
end loop;
Token_Ptr := Ptr;
while (In_Quotes or else not (Source (Ptr) = ' ' or Source (Ptr) = ','))
and then Source (Ptr) >= ' '
loop
if Source (Ptr) = '"' then
In_Quotes := not In_Quotes;
end if;
Ptr := Ptr + 1;
end loop;
end Parse_Token;
procedure Read_File
(FD : File_Descriptor;
Contents : out String_Access;
Success : out Boolean)
is
Length : constant File_Offset := File_Offset (File_Length (FD));
Buffer : constant String_Access := new String (1 .. Length + 1);
This_Read : Integer;
Read_Ptr : File_Offset := 1;
begin
loop
This_Read := Read (FD,
A => Buffer (Read_Ptr)'Address,
N => Length + 1 - Read_Ptr);
Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0);
exit when This_Read <= 0;
end loop;
Buffer (Read_Ptr) := EOF;
Contents := new String (1 .. Read_Ptr);
Contents.all := Buffer (1 .. Read_Ptr);
if Hostparm.OpenVMS then
Success := Read_Ptr <= Length + 1;
else
Success := Read_Ptr = Length + 1;
end if;
end Read_File;
function Report_Duplicate_Units return Boolean is
US : SUnit_Num;
U : Unit_Num;
Duplicates : Boolean := False;
begin
US := 1;
while US < SUnit_Num (Unit.Last) loop
U := Sorted_Units.Table (US);
if Is_Duplicated (US) then
Duplicates := True;
while US + 1 < SUnit_Num (Unit.Last) loop
exit when not Is_Duplicated (US + 1);
US := US + 1;
end loop;
U := Sorted_Units.Table (US);
if Overwrite_Files then
Warning_Msg (Unit.Table (U).File_Name.all
& " is duplicated (all but last will be skipped)");
elsif Unit.Table (U).Chop_File =
Unit.Table (Sorted_Units.Table (US + 1)).Chop_File
then
Error_Msg (Unit.Table (U).File_Name.all
& " is duplicated in "
& File.Table (Unit.Table (U).Chop_File).Name.all);
else
Error_Msg (Unit.Table (U).File_Name.all
& " in "
& File.Table (Unit.Table (U).Chop_File).Name.all
& " is duplicated in "
& File.Table
(Unit.Table
(Sorted_Units.Table (US + 1)).Chop_File).Name.all);
end if;
end if;
US := US + 1;
end loop;
if Duplicates and not Overwrite_Files then
if Hostparm.OpenVMS then
Put_Line
("use /OVERWRITE to overwrite files and keep last version");
else
Put_Line ("use -w to overwrite files and keep last version");
end if;
end if;
return Duplicates;
end Report_Duplicate_Units;
function Scan_Arguments return Boolean is
Kset : Boolean := False;
begin
Initialize_Option_Scan;
loop
case Getopt ("c gnat? h k? p q r v w x -GCC=!") is
when ASCII.NUL =>
exit;
when '-' =>
Gcc := new String'(Parameter);
Gcc_Set := True;
when 'c' =>
Compilation_Mode := True;
when 'g' =>
Gnat_Args :=
new Argument_List'(Gnat_Args.all &
new String'("-gnat" & Parameter));
when 'h' =>
Usage;
raise Terminate_Program;
when 'k' =>
declare
Param : String_Access := new String'(Parameter);
begin
if Param.all /= "" then
for J in Param'Range loop
if Param (J) not in '0' .. '9' then
if Hostparm.OpenVMS then
Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn" &
" requires numeric parameter");
else
Error_Msg ("-k# requires numeric parameter");
end if;
return False;
end if;
end loop;
else
if Hostparm.OpenVMS then
Param := new String'("39");
else
Param := new String'("8");
end if;
end if;
Gnat_Args :=
new Argument_List'(Gnat_Args.all &
new String'("-gnatk" & Param.all));
Kset := True;
end;
when 'p' =>
Preserve_Mode := True;
when 'q' =>
Quiet_Mode := True;
when 'r' =>
Source_References := True;
when 'v' =>
Verbose_Mode := True;
Put_Line (Standard_Error, Cwrite);
when 'w' =>
Overwrite_Files := True;
when 'x' =>
Exit_On_Error := True;
when others =>
null;
end case;
end loop;
if not Kset and then Maximum_File_Name_Length > 0 then
Gnat_Args :=
new Argument_List'(Gnat_Args.all
& new String'("-gnatk"
& Maximum_File_Name_Length_String
(Maximum_File_Name_Length_String'First + 1
.. Maximum_File_Name_Length_String'Last)));
end if;
loop
declare
S : constant String := Get_Argument (Do_Expansion => True);
begin
exit when S = "";
File.Increment_Last;
File.Table (File.Last).Name := new String'(S);
File.Table (File.Last).SR_Name := null;
end;
end loop;
if File.Last > 1
and then Is_Directory (File.Table (File.Last).Name.all)
then
Directory := File.Table (File.Last).Name;
File.Decrement_Last;
if Directory (Directory'Last) /= Directory_Separator
and then Directory (Directory'Last) /= '/'
then
Directory := new String'(Directory.all & Directory_Separator);
end if;
elsif File.Last = 0 then
Usage;
return False;
else
Directory := new String'("");
end if;
for File_Num in 1 .. File.Last loop
declare
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;
elsif not Is_Regular_File (F) then
Error_Msg (F & " not found");
return False;
end if;
end;
end loop;
return True;
exception
when Invalid_Switch =>
Error_Msg ("invalid switch " & Full_Switch);
return False;
when Invalid_Parameter =>
if Hostparm.OpenVMS then
Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn qualifier" &
" requires numeric parameter");
else
Error_Msg ("-k switch requires numeric parameter");
end if;
return False;
end Scan_Arguments;
procedure Sort_Units is
procedure Move (From : Natural; To : Natural);
function Lt (Left, Right : Natural) return Boolean;
package Unit_Sort is new GNAT.Heap_Sort_G (Move, Lt);
function Lt (Left, Right : Natural) return Boolean is
L : Unit_Info renames
Unit.Table (Sorted_Units.Table (SUnit_Num (Left)));
R : Unit_Info renames
Unit.Table (Sorted_Units.Table (SUnit_Num (Right)));
begin
return L.File_Name.all < R.File_Name.all
or else (L.File_Name.all = R.File_Name.all
and then (L.Chop_File < R.Chop_File
or else (L.Chop_File = R.Chop_File
and then L.Offset < R.Offset)));
end Lt;
procedure Move (From : Natural; To : Natural) is
begin
Sorted_Units.Table (SUnit_Num (To)) :=
Sorted_Units.Table (SUnit_Num (From));
end Move;
begin
Sorted_Units.Set_Last (SUnit_Num (Unit.Last));
for J in 1 .. Unit.Last loop
Sorted_Units.Table (SUnit_Num (J)) := J;
end loop;
Unit_Sort.Sort (Natural (Unit.Last));
for J in 1 .. SUnit_Num (Unit.Last) loop
Unit.Table (Sorted_Units.Table (J)).Sorted_Index := J;
end loop;
end Sort_Units;
procedure Usage is
begin
Put_Line
("Usage: gnatchop [-c] [-h] [-k#] " &
"[-r] [-p] [-q] [-v] [-w] [-x] [--GCC=xx] file [file ...] [dir]");
New_Line;
Put_Line
(" -c compilation mode, configuration pragmas " &
"follow RM rules");
Put_Line
(" -gnatxxx passes the -gnatxxx switch to gnat parser");
Put_Line
(" -h help: output this usage information");
Put_Line
(" -k# krunch file names of generated files to " &
"no more than # characters");
Put_Line
(" -k krunch file names of generated files to " &
"no more than 8 characters");
Put_Line
(" -p preserve time stamp, output files will " &
"have same stamp as input");
Put_Line
(" -q quiet mode, no output of generated file " &
"names");
Put_Line
(" -r generate Source_Reference pragmas refer" &
"encing original source file");
Put_Line
(" -v verbose mode, output version and generat" &
"ed commands");
Put_Line
(" -w overwrite existing filenames");
Put_Line
(" -x exit on error");
Put_Line
(" --GCC=xx specify the path of the gnat parser to be used");
New_Line;
Put_Line
(" file... list of source files to be chopped");
Put_Line
(" dir directory location for split files (defa" &
"ult = current directory)");
end Usage;
procedure Warning_Msg (Message : String) is
begin
Warning_Count := Warning_Count + 1;
Put_Line (Standard_Error, "warning: " & Message);
end Warning_Msg;
function Write_Chopped_Files (Input : File_Num) return Boolean is
Name : aliased constant String :=
File.Table (Input).Name.all & ASCII.Nul;
FD : File_Descriptor;
Buffer : String_Access;
Success : Boolean;
TS_Time : OS_Time;
begin
FD := Open_Read (Name'Address, Binary);
TS_Time := File_Time_Stamp (FD);
if FD = Invalid_FD then
Error_Msg ("cannot open " & File.Table (Input).Name.all);
return False;
end if;
Read_File (FD, Buffer, Success);
if not Success then
Error_Msg ("cannot read " & File.Table (Input).Name.all);
Close (FD);
return False;
end if;
if not Quiet_Mode then
Put_Line ("splitting " & File.Table (Input).Name.all & " into:");
end if;
for Num in 1 .. Unit.Last loop
if Unit.Table (Num).Chop_File = Input then
Write_Unit (Buffer, Num, TS_Time, Success);
exit when not Success;
end if;
end loop;
Close (FD);
return Success;
end Write_Chopped_Files;
procedure Write_Config_File (Input : File_Num; U : Unit_Num) is
FD : File_Descriptor;
Name : aliased constant String := "gnat.adc" & ASCII.NUL;
Buffer : String_Access;
Success : Boolean;
Append : Boolean;
Buffera : String_Access;
Bufferl : Natural;
begin
Write_gnat_adc := True;
FD := Open_Read_Write (Name'Address, Binary);
if FD = Invalid_FD then
FD := Create_File (Name'Address, Binary);
Append := False;
if not Quiet_Mode then
Put_Line ("writing configuration pragmas from " &
File.Table (Input).Name.all & " to gnat.adc");
end if;
else
Append := True;
if not Quiet_Mode then
Put_Line
("appending configuration pragmas from " &
File.Table (Input).Name.all & " to gnat.adc");
end if;
end if;
Success := FD /= Invalid_FD;
if not Success then
Error_Msg ("cannot create gnat.adc");
return;
end if;
if Append then
Read_File (FD, Buffera, Success);
if not Success then
Error_Msg ("cannot read gnat.adc");
return;
end if;
Bufferl := 1;
while Bufferl <= Buffera'Last
and then Buffera (Bufferl) /= EOF
loop
Bufferl := Bufferl + 1;
end loop;
Bufferl := Bufferl - 1;
Close (FD);
FD := Create_File (Name'Address, Binary);
Success := Write (FD, Buffera (1)'Address, Bufferl) = Bufferl;
if not Success then
Error_Msg ("error writing gnat.adc");
return;
end if;
end if;
Buffer := Get_Config_Pragmas (Input, U);
if Buffer /= null then
Success := Write (FD, Buffer.all'Address, Buffer'Length) =
Buffer'Length;
if not Success then
Error_Msg ("disk full writing gnat.adc");
return;
end if;
end if;
Close (FD);
end Write_Config_File;
procedure Write_Source_Reference_Pragma
(Info : Unit_Info;
Line : Line_Num;
FD : File_Descriptor;
EOL : EOL_String;
Success : in out Boolean)
is
FTE : File_Entry renames File.Table (Info.Chop_File);
Nam : String_Access;
begin
if Success and Source_References and not Info.SR_Present then
if FTE.SR_Name /= null then
Nam := FTE.SR_Name;
else
Nam := FTE.Name;
end if;
declare
Reference : aliased String :=
"pragma Source_Reference (000000, """
& Nam.all & """);" & EOL.Str;
Pos : Positive := Reference'First;
Lin : Line_Num := Line;
begin
while Reference (Pos + 1) /= ',' loop
Pos := Pos + 1;
end loop;
while Reference (Pos) = '0' loop
Reference (Pos) := Character'Val
(Character'Pos ('0') + Lin mod 10);
Lin := Lin / 10;
Pos := Pos - 1;
end loop;
pragma Assert (Lin = 0);
Success :=
Write (FD, Reference'Address, Reference'Length)
= Reference'Length;
end;
end if;
end Write_Source_Reference_Pragma;
procedure Write_Unit
(Source : 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);
begin
if Is_Duplicated (Info.Sorted_Index) then
Put_Line (" " & Info.File_Name.all & " skipped");
Success := Overwrite_Files;
return;
end if;
if Overwrite_Files then
FD := Create_File (Name'Address, Binary);
else
FD := Create_New_File (Name'Address, Binary);
end if;
Success := FD /= Invalid_FD;
if not Success then
Error_Msg ("cannot create " & Info.File_Name.all);
return;
end if;
if Info.Length = 0 then
Length := Source'Last - (Source'First + Info.Offset);
else
Length := Info.Length;
end if;
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;
Write_Source_Reference_Pragma (Info, Info.Start_Line, FD, EOL, Success);
if Success then
Success := Write (FD, Source (Source'First + Info.Offset)'Address,
Length) = Length;
end if;
if not Success then
Error_Msg ("disk full writing " & Info.File_Name.all);
return;
end if;
if not Quiet_Mode then
Put_Line (" " & Info.File_Name.all);
end if;
Close (FD);
if Preserve_Mode then
File_Time_Stamp (Name'Address, TS_Time);
end if;
end Write_Unit;
begin
if not Scan_Arguments then
Set_Exit_Status (Failure);
return;
end if;
Gnat_Cmd := Locate_Executable (Gcc.all, not Gcc_Set);
if Gnat_Cmd = null then
goto No_Files_Written;
end if;
for Num in 1 .. File.Last loop
if not Parse_File (Num) then
goto No_Files_Written;
end if;
end loop;
if Unit.Last = 0 then
if not Write_gnat_adc then
Error_Msg ("no compilation units found");
end if;
goto No_Files_Written;
end if;
Sort_Units;
if Report_Duplicate_Units and then not Overwrite_Files then
goto No_Files_Written;
end if;
if not Overwrite_Files and then Files_Exist then
goto No_Files_Written;
end if;
for F in 1 .. File.Last loop
if not Write_Chopped_Files (F) then
Set_Exit_Status (Failure);
return;
end if;
end loop;
if Warning_Count > 0 then
declare
Warnings_Msg : String := Warning_Count'Img & " warning(s)";
begin
Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last));
end;
end if;
return;
<<No_Files_Written>>
if not Write_gnat_adc then
Error_Msg ("no source files written");
end if;
return;
exception
when Terminate_Program =>
null;
end Gnatchop;