aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.3/gcc/ada/gnatchop.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.3/gcc/ada/gnatchop.adb')
-rw-r--r--gcc-4.4.3/gcc/ada/gnatchop.adb1863
1 files changed, 1863 insertions, 0 deletions
diff --git a/gcc-4.4.3/gcc/ada/gnatchop.adb b/gcc-4.4.3/gcc/ada/gnatchop.adb
new file mode 100644
index 000000000..7c17beb58
--- /dev/null
+++ b/gcc-4.4.3/gcc/ada/gnatchop.adb
@@ -0,0 +1,1863 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T C H O P --
+-- --
+-- B o d y --
+-- --
+-- 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 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 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.Heap_Sort_G;
+with GNAT.Table;
+
+with Hostparm;
+with Switch; use Switch;
+with Types;
+
+procedure Gnatchop is
+
+ Config_File_Name : constant String_Access := new String'("gnat.adc");
+ -- The name of the file holding the GNAT configuration pragmas
+
+ Gcc : String_Access := new String'("gcc");
+ -- May be modified by switch --GCC=
+
+ Gcc_Set : Boolean := False;
+ -- True if a switch --GCC= is used
+
+ 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"));
+ -- 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.
+
+ --------------------
+ -- File arguments --
+ --------------------
+
+ subtype File_Num is Natural;
+ subtype File_Offset is Natural;
+
+ type File_Entry is record
+ Name : String_Access;
+ -- Name of chop file or directory
+
+ SR_Name : String_Access;
+ -- Null unless the chop file starts with a source reference pragma
+ -- in which case this field points to the file name from this pragma.
+ 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;
+ -- Record name of directory, or a null string if no directory given
+
+ 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;
+ -- Global options
+
+ Write_gnat_adc : Boolean := False;
+ -- Gets set true if we append to gnat.adc or create a new gnat.adc.
+ -- Used to inhibit complaint about no units generated.
+
+ ---------------
+ -- Unit list --
+ ---------------
+
+ type Line_Num is new Natural;
+ -- Line number (for source reference pragmas)
+
+ type Unit_Count_Type is new Integer;
+ subtype Unit_Num is Unit_Count_Type range 1 .. Unit_Count_Type'Last;
+ -- Used to refer to unit number in unit table
+
+ type SUnit_Num is new Integer;
+ -- Used to refer to entry in sorted units table. Note that entry
+ -- zero is only for use by Heapsort, and is not otherwise referenced.
+
+ type Unit_Kind is (Unit_Spec, Unit_Body, Config_Pragmas);
+
+ -- Structure to contain all necessary information for one unit.
+ -- Entries are also temporarily used to record config pragma sequences.
+
+ type Unit_Info is record
+ File_Name : String_Access;
+ -- File name from GNAT output line
+
+ Chop_File : File_Num;
+ -- File number in chop file sequence
+
+ Start_Line : Line_Num;
+ -- Line number from GNAT output line
+
+ Offset : File_Offset;
+ -- Offset name from GNAT output line
+
+ SR_Present : Boolean;
+ -- Set True if SR parameter present
+
+ Length : File_Offset;
+ -- A length of 0 means that the Unit is the last one in the file
+
+ Kind : Unit_Kind;
+ -- Indicates kind of unit
+
+ Sorted_Index : SUnit_Num;
+ -- 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.
+ end record;
+
+ -- The following table stores the unit offset information
+
+ 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);
+
+ -- The following table is used as a sorted index to the Unit.Table.
+ -- The entries in Unit.Table are not moved, instead we just shuffle
+ -- the entries in Sorted_Units. Note that the zeroeth entry in this
+ -- table is used by GNAT.Heap_Sort_G.
+
+ 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;
+ -- Returns true if U is duplicated by a later unit.
+ -- Note that this function returns false for the last entry.
+
+ procedure Sort_Units;
+ -- 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;
+
+ ---------------------
+ -- Local variables --
+ ---------------------
+
+ Warning_Count : Natural := 0;
+ -- Count of warnings issued so far
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ procedure Error_Msg (Message : String; Warning : Boolean := False);
+ -- Produce an error message on standard error output
+
+ procedure File_Time_Stamp (Name : C_File_Name; Time : OS_Time);
+ -- Given the name of a file or directory, Name, set the
+ -- time stamp. This function must be used for an unopened file.
+
+ function Files_Exist return Boolean;
+ -- Check Unit.Table for possible file names that already exist
+ -- in the file system. Returns true if files exist, False otherwise
+
+ function Get_Maximum_File_Name_Length return Integer;
+ pragma Import (C, Get_Maximum_File_Name_Length,
+ "__gnat_get_maximum_file_name_length");
+ -- Function to get maximum file name length for system
+
+ 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;
+ -- Locate executable for given program name. This takes into account
+ -- the target-prefix of the current command, if Look_For_Prefix is True.
+
+ subtype EOL_Length is Natural range 0 .. 2;
+ -- Possible lengths of end of line sequence
+
+ type EOL_String (Len : EOL_Length := 0) is record
+ Str : String (1 .. Len);
+ end record;
+
+ function Get_EOL
+ (Source : not null access String;
+ Start : Positive) return EOL_String;
+ -- Return the line terminator used in the passed string
+
+ 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.
+
+ function Parse_File (Num : File_Num) return Boolean;
+ -- Calls the GNAT compiler to parse the given source file and parses the
+ -- output using Parse_Offset_Info. Returns True if parse operation
+ -- completes, False if some system error (e.g. failure to read the
+ -- offset information) occurs.
+
+ 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 : 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.
+ -- Then stores the position of the next separator in Ptr.
+ -- On return Source (Token_Ptr .. Ptr - 1) is the token.
+
+ procedure Read_File
+ (FD : File_Descriptor;
+ Contents : out String_Access;
+ Success : out Boolean);
+ -- Reads file associated with FS into the newly allocated
+ -- string Contents.
+ -- [VMS] Success is true iff the number of bytes read is less than or
+ -- equal to the file size.
+ -- [Other] Success is true iff the number of bytes read is equal to
+ -- the file size.
+
+ function Report_Duplicate_Units return Boolean;
+ -- Output messages about duplicate units in the input files in Unit.Table
+ -- 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.
+ -- Also scan out file and directory arguments. Returns True if scan
+ -- was successful, and False if the scan fails for any reason.
+
+ procedure Usage;
+ -- Output message on standard output describing syntax of gnatchop command
+
+ procedure Warning_Msg (Message : String);
+ -- Output a warning message on standard error and update warning count
+
+ function Write_Chopped_Files (Input : File_Num) return Boolean;
+ -- Write all units that result from chopping the Input file
+
+ procedure Write_Config_File (Input : File_Num; U : Unit_Num);
+ -- Call to write configuration pragmas (append them to gnat.adc)
+ -- Input is the file number for the chop file and U identifies the
+ -- unit entry for the configuration pragmas.
+
+ function Get_Config_Pragmas
+ (Input : File_Num;
+ 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
+ -- U identifies the unit entry for the configuration pragmas.
+
+ procedure Write_Source_Reference_Pragma
+ (Info : Unit_Info;
+ Line : Line_Num;
+ File : Stream_IO.File_Type;
+ EOL : EOL_String;
+ Success : in out Boolean);
+ -- If Success is True on entry, writes a source reference pragma using
+ -- the chop file from Info, and the given line number. On return Success
+ -- indicates whether the write succeeded. If Success is False on entry,
+ -- or if the global flag Source_References is False, then the call to
+ -- Write_Source_Reference_Pragma has no effect. EOL indicates the end
+ -- of line sequence to be written at the end of the pragma.
+
+ procedure Write_Unit
+ (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 --
+ ---------------
+
+ procedure Error_Msg (Message : String; Warning : Boolean := False) is
+ begin
+ Put_Line (Standard_Error, Message);
+
+ if not Warning then
+ Set_Exit_Status (Failure);
+
+ if Exit_On_Error then
+ raise Types.Terminate_Program;
+ end if;
+ end if;
+ end Error_Msg;
+
+ ---------------------
+ -- File_Time_Stamp --
+ ---------------------
+
+ 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;
+
+ -----------------
+ -- Files_Exist --
+ -----------------
+
+ function Files_Exist return Boolean is
+ Exists : Boolean := False;
+
+ begin
+ for SNum in 1 .. SUnit_Num (Unit.Last) loop
+
+ -- Only check and report for the last instance of duplicated files
+
+ if not Is_Duplicated (SNum) then
+ declare
+ Info : constant 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;
+
+ ------------------------
+ -- Get_Config_Pragmas --
+ ------------------------
+
+ 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;
+ Result : String_Access;
+
+ Success : Boolean;
+ pragma Warnings (Off, Success);
+
+ 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);
+
+ -- 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 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;
+
+ -------------
+ -- Get_EOL --
+ -------------
+
+ function Get_EOL
+ (Source : not null access String;
+ Start : Positive)
+ return EOL_String
+ is
+ Ptr : Positive := Start;
+ First : Positive;
+ Last : Natural;
+
+ begin
+ -- Skip to end of line
+
+ 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
+
+ -- Found CR or LF
+
+ First := Ptr;
+
+ else
+ First := Ptr + 1;
+ end if;
+
+ -- Recognize CR/LF or LF/CR combination
+
+ 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;
+
+ -------------------
+ -- Is_Duplicated --
+ -------------------
+
+ 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;
+
+ -----------------------
+ -- Locate_Executable --
+ -----------------------
+
+ function Locate_Executable
+ (Program_Name : String;
+ Look_For_Prefix : Boolean := True) return String_Access
+ is
+ 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
+ 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;
+
+ -- Find End_Of_Prefix
+
+ 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_Suffix ..
+ Current_Command'Last);
+ 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;
+
+ ---------------
+ -- Parse_EOL --
+ ---------------
+
+ procedure Parse_EOL
+ (Source : not null access String;
+ Ptr : in out Positive) is
+ begin
+ -- Skip to end of line
+
+ 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; -- skip CR or LF
+ end if;
+
+ -- Skip past CR/LF or LF/CR combination
+
+ 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;
+
+ ----------------
+ -- Parse_File --
+ ----------------
+
+ function Parse_File (Num : File_Num) return Boolean is
+ 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;
+ Buffer : String_Access;
+ Success : Boolean;
+ Failure : exception;
+
+ begin
+ -- Display copy of GNAT command if verbose mode
+
+ 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 temporary file
+
+ 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;
+
+ -- Redirect Stdout to this temporary file in the Unix way
+
+ 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;
+
+ -- Call Gnat on the source filename argument with special options
+ -- to generate offset information. If this special compilation completes
+ -- successfully then we can do the actual gnatchop operation.
+
+ 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;
+
+ -- Restore stdout
+
+ if dup2 (Save_Stdout, Standout) = Invalid_FD then
+ Error_Msg ("gnatchop: cannot restore stdout");
+ end if;
+
+ -- Reopen the file to start reading from the beginning
+
+ 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 and delete temporary file
+
+ Close (Offset_FD);
+ Delete_File (Offset_Name'Address, Success);
+
+ return Success;
+
+ exception
+ when Failure | Types.Terminate_Program =>
+ Close (Offset_FD);
+ Delete_File (Offset_Name'Address, Success);
+ return False;
+
+ end Parse_File;
+
+ -----------------------
+ -- Parse_Offset_Info --
+ -----------------------
+
+ procedure Parse_Offset_Info
+ (Chop_File : File_Num;
+ Source : not null access String)
+ is
+ 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;
+
+ function Match (Literal : String) return Boolean;
+ -- Checks if given string appears at the current Token_Ptr location
+ -- and if so, bumps Parse_Ptr past the token and returns True. If
+ -- the string is not present, sets Parse_Ptr to Token_Ptr and
+ -- returns False.
+
+ -----------
+ -- Match --
+ -----------
+
+ 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;
+
+ -- Start of processing for Parse_Offset_Info
+
+ begin
+ loop
+ -- Set default values, should get changed for all
+ -- units/pragmas except for the last
+
+ Info.Chop_File := Chop_File;
+ Info.Length := 0;
+
+ -- Parse the current line of offset information into Info
+ -- and exit the loop if there are any errors or on EOF.
+
+ -- First case, parse a line in the following format:
+
+ -- Unit x (spec) line 7, file offset 142, [SR, ]file name x.ads
+
+ -- 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 interfere with chopping.
+
+ -- The SR ir present indicates that a source reference pragma
+ -- was processed as part of this unit (and that therefore no
+ -- Source_Reference pragma should be generated.
+
+ 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);
+
+ -- Second case, parse a line of the following form
+
+ -- Configuration pragmas at line 10, file offset 223
+
+ 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);
+
+ -- Third case, parse a line of the following form
+
+ -- Source_Reference pragma for file "filename"
+
+ -- This appears at the start of the file only, and indicates
+ -- the name to be used on any generated Source_Reference pragmas.
+
+ 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;
+
+ -- Unrecognized keyword or end of file
+
+ else
+ exit;
+ end if;
+
+ -- Store the data in the Info record in the Unit.Table
+
+ Unit.Increment_Last;
+ Unit.Table (Unit.Last) := Info;
+
+ -- If this is not the first unit from the file, calculate
+ -- the length of the previous unit as difference of the offsets
+
+ if Unit.Last > First_Unit then
+ Unit.Table (Unit.Last - 1).Length :=
+ Info.Offset - Unit.Table (Unit.Last - 1).Offset;
+ end if;
+
+ -- If not in compilation mode combine current unit with any
+ -- preceding configuration pragmas.
+
+ 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;
+
+ -- Delete the configuration pragma entry
+
+ Unit.Table (Unit.Last - 1) := Info;
+ Unit.Decrement_Last;
+ end if;
+
+ -- If in compilation mode, and previous entry is the initial
+ -- entry for the file and is for configuration pragmas, then
+ -- they are to be appended to every unit in the file.
+
+ 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 in compilation mode, and this is not the first item,
+ -- combine configuration pragmas with previous unit, which
+ -- will cause an error message to be generated when the unit
+ -- is compiled.
+
+ 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;
+
+ -- Find out if the loop was exited prematurely because of
+ -- an error or if the EOF marker was found.
+
+ if Source (Parse_Ptr) /= EOF then
+ Error_Msg
+ (File.Table (Chop_File).Name.all & ": error parsing offset info");
+ return;
+ end if;
+
+ -- Handle case of a chop file consisting only of config pragmas
+
+ if Unit.Last = First_Unit
+ and then Unit.Table (Unit.Last).Kind = Config_Pragmas
+ then
+ -- In compilation mode, we append such a file to gnat.adc
+
+ if Compilation_Mode then
+ Write_Config_File (Unit.Table (Unit.Last).Chop_File, First_Unit);
+ Unit.Decrement_Last;
+
+ -- In default (non-compilation) mode, this is invalid
+
+ else
+ Error_Msg
+ (File.Table (Chop_File).Name.all &
+ ": no units found (only pragmas)");
+ Unit.Decrement_Last;
+ end if;
+ end if;
+
+ -- Handle case of a chop file ending with config pragmas. This can
+ -- happen only in default non-compilation mode, since in compilation
+ -- mode such configuration pragmas are part of the preceding unit.
+ -- We simply concatenate such pragmas to the previous file which
+ -- will cause a compilation error, which is appropriate.
+
+ if Unit.Last > First_Unit
+ and then Unit.Table (Unit.Last).Kind = Config_Pragmas
+ then
+ Unit.Decrement_Last;
+ end if;
+ end Parse_Offset_Info;
+
+ -----------------
+ -- Parse_Token --
+ -----------------
+
+ procedure Parse_Token
+ (Source : not null access String;
+ Ptr : in out Positive;
+ Token_Ptr : out Positive)
+ is
+ In_Quotes : Boolean := False;
+
+ begin
+ -- Skip separators
+
+ while Source (Ptr) = ' ' or Source (Ptr) = ',' loop
+ Ptr := Ptr + 1;
+ end loop;
+
+ Token_Ptr := Ptr;
+
+ -- Find end-of-token
+
+ 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;
+
+ ---------------
+ -- Read_File --
+ ---------------
+
+ procedure Read_File
+ (FD : File_Descriptor;
+ Contents : out String_Access;
+ Success : out Boolean)
+ is
+ Length : constant File_Offset := File_Offset (File_Length (FD));
+ -- Include room for EOF char
+ 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);
+
+ -- 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;
+ else
+ Success := Read_Ptr = Length + 1;
+ end if;
+ end Read_File;
+
+ ----------------------------
+ -- Report_Duplicate_Units --
+ ----------------------------
+
+ 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;
+
+ -- Move to last two versions of duplicated file to make it clearer
+ -- to understand which file is retained in case of overwriting.
+
+ 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;
+
+ --------------------
+ -- Scan_Arguments --
+ --------------------
+
+ function Scan_Arguments return Boolean is
+ Kset : Boolean := False;
+ -- Set true if -k switch found
+
+ begin
+ Initialize_Option_Scan;
+
+ -- Scan options first
+
+ 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 Types.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;
+ Display_Version ("GNATCHOP", "1998");
+
+ 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
+
+ -- If this system has restricted filename lengths, tell gnat1
+ -- about them, removing the leading blank from the image string.
+
+ 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;
+
+ -- Scan file names
+
+ 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;
+
+ -- Case of more than one file where last file is a directory
+
+ if File.Last > 1
+ and then Is_Directory (File.Table (File.Last).Name.all)
+ then
+ Directory := File.Table (File.Last).Name;
+ File.Decrement_Last;
+
+ -- Make sure Directory is terminated with a directory separator,
+ -- so we can generate the output by just appending a filename.
+
+ if Directory (Directory'Last) /= Directory_Separator
+ and then Directory (Directory'Last) /= '/'
+ then
+ Directory := new String'(Directory.all & Directory_Separator);
+ end if;
+
+ -- At least one filename must be given
+
+ elsif File.Last = 0 then
+ Usage;
+ return False;
+
+ -- No directory given, set directory to null, so that we can just
+ -- concatenate the directory name to the file name unconditionally.
+
+ else
+ Directory := new String'("");
+ end if;
+
+ -- Finally check all filename arguments
+
+ 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;
+
+ ----------------
+ -- Sort_Units --
+ ----------------
+
+ procedure Sort_Units is
+
+ procedure Move (From : Natural; To : Natural);
+ -- Procedure used to sort the unit list
+ -- Unit.Table (To) := Unit_List (From); used by sort
+
+ function Lt (Left, Right : Natural) return Boolean;
+ -- Compares Left and Right units based on file name (first),
+ -- Chop_File (second) and Offset (third). This ordering is
+ -- important to keep the last version in case of duplicate files.
+
+ package Unit_Sort is new GNAT.Heap_Sort_G (Move, Lt);
+ -- Used for sorting on filename to detect duplicates
+
+ --------
+ -- 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;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ Sorted_Units.Table (SUnit_Num (To)) :=
+ Sorted_Units.Table (SUnit_Num (From));
+ end Move;
+
+ -- Start of processing for Sort_Units
+
+ 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;
+
+ -- Sort Unit.Table, using Sorted_Units.Table (0) as scratch
+
+ Unit_Sort.Sort (Natural (Unit.Last));
+
+ -- 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;
+ end loop;
+ end Sort_Units;
+
+ -----------
+ -- Usage --
+ -----------
+
+ 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;
+
+ -----------------
+ -- Warning_Msg --
+ -----------------
+
+ procedure Warning_Msg (Message : String) is
+ begin
+ Warning_Count := Warning_Count + 1;
+ Put_Line (Standard_Error, "warning: " & Message);
+ end Warning_Msg;
+
+ -------------------------
+ -- Write_Chopped_Files --
+ -------------------------
+
+ 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;
+
+ -- Only chop those units that come from this file
+
+ 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;
+
+ -----------------------
+ -- Write_Config_File --
+ -----------------------
+
+ 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;
+
+ -- In append mode, acquire existing gnat.adc file
+
+ if Append then
+ Read_File (FD, Buffera, Success);
+
+ if not Success then
+ Error_Msg ("cannot read gnat.adc");
+ return;
+ end if;
+
+ -- Find location of EOF byte if any to exclude from append
+
+ Bufferl := 1;
+ while Bufferl <= Buffera'Last
+ and then Buffera (Bufferl) /= EOF
+ loop
+ Bufferl := Bufferl + 1;
+ end loop;
+
+ Bufferl := Bufferl - 1;
+ Close (FD);
+
+ -- Write existing gnat.adc to new gnat.adc file
+
+ 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;
+
+ -----------------------------------
+ -- Write_Source_Reference_Pragma --
+ -----------------------------------
+
+ procedure Write_Source_Reference_Pragma
+ (Info : Unit_Info;
+ Line : Line_Num;
+ File : Stream_IO.File_Type;
+ EOL : EOL_String;
+ Success : in out Boolean)
+ is
+ FTE : File_Entry renames Gnatchop.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 : 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;
+
+ -- Assume there are enough zeroes for any program length
+
+ pragma Assert (Lin = 0);
+
+ begin
+ String'Write (Stream_IO.Stream (File), Reference);
+ Success := True;
+ exception
+ when others =>
+ Success := False;
+ end;
+ end;
+ end if;
+ end Write_Source_Reference_Pragma;
+
+ ----------------
+ -- Write_Unit --
+ ----------------
+
+ procedure Write_Unit
+ (Source : not null access String;
+ Num : Unit_Num;
+ TS_Time : OS_Time;
+ Success : out Boolean)
+ is
+
+ 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
+
+ if Is_Duplicated (Info.Sorted_Index) then
+ Put_Line (" " & Info.File_Name.all & " skipped");
+ Success := Overwrite_Files;
+ return;
+ end if;
+
+ -- Get OS filename
+
+ OS_Filename
+ (Name, W_Name,
+ OS_Name'Address, O_Length'Access,
+ Encoding'Address, E_Length'Access);
+
+ 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;
+
+ 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;
+
+ exception
+ when Stream_IO.Name_Error | Stream_IO.Use_Error =>
+ Error_Msg ("cannot create " & Info.File_Name.all);
+ return;
+ end;
+
+ -- 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 Info.Length = 0 then
+ Length := Source'Last - (Source'First + Info.Offset);
+ else
+ Length := Info.Length;
+ end if;
+
+ -- Prepend configuration pragmas if necessary
+
+ 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;
+
+ Write_Source_Reference_Pragma
+ (Info, Info.Start_Line, File, EOL, Success);
+
+ 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;
+
+ if not Quiet_Mode then
+ Put_Line (" " & Info.File_Name.all);
+ 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.
+
+ 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
+
+ -- First, scan to detect --version and/or --help
+
+ Check_Version_And_Help ("GNATCHOP", "1998");
+
+ if not Scan_Arguments then
+ Set_Exit_Status (Failure);
+ return;
+ end if;
+
+ -- Check presence of required executables
+
+ Gnat_Cmd := Locate_Executable (Gcc.all, not Gcc_Set);
+
+ if Gnat_Cmd = null then
+ goto No_Files_Written;
+ end if;
+
+ -- First parse all files and read offset information
+
+ for Num in 1 .. File.Last loop
+ if not Parse_File (Num) then
+ goto No_Files_Written;
+ end if;
+ end loop;
+
+ -- Check if any units have been found (assumes non-empty Unit.Table)
+
+ if Unit.Last = 0 then
+ if not Write_gnat_adc then
+ Error_Msg ("no compilation units found", Warning => True);
+ end if;
+
+ goto No_Files_Written;
+ end if;
+
+ Sort_Units;
+
+ -- 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
+
+ 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.
+
+ -- 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
+ Set_Exit_Status (Failure);
+ return;
+ end if;
+ end loop;
+
+ if Warning_Count > 0 then
+ declare
+ Warnings_Msg : constant String := Warning_Count'Img & " warning(s)";
+ begin
+ Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last), Warning => True);
+ end;
+ end if;
+
+ return;
+
+<<No_Files_Written>>
+
+ -- Special error exit for all situations where no files have
+ -- been written.
+
+ if not Write_gnat_adc then
+ Error_Msg ("no source files written", Warning => True);
+ end if;
+
+ return;
+
+exception
+ when Types.Terminate_Program =>
+ null;
+
+end Gnatchop;