diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/gnatchop.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/gnatchop.adb | 1810 |
1 files changed, 0 insertions, 1810 deletions
diff --git a/gcc-4.2.1/gcc/ada/gnatchop.adb b/gcc-4.2.1/gcc/ada/gnatchop.adb deleted file mode 100644 index eab706325..000000000 --- a/gcc-4.2.1/gcc/ada/gnatchop.adb +++ /dev/null @@ -1,1810 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T C H O P -- --- -- --- B o d y -- --- -- --- 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- -- --- ware Foundation; either version 2, 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, 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 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; - -with System.CRTL; use System.CRTL; - -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 - - 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 : 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); - -- 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 : 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; - 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, Fals 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; - FD : File_Descriptor; - 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 : 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 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; - 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); - - -- 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 : 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 - 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 - 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 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; - - --------------- - -- Parse_EOL -- - --------------- - - procedure Parse_EOL (Source : 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 | 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 : 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 intefere 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 : 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 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; - - -- 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; - - 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; - 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; - - -- Assume there are enough zeroes for any program length - - pragma Assert (Lin = 0); - - Success := - Write (FD, Reference'Address, Reference'Length) - = Reference'Length; - end; - end if; - end Write_Source_Reference_Pragma; - - ---------------- - -- Write_Unit -- - ---------------- - - 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 - -- Skip duplicated files - - 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; - - -- 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, 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; - --- 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 - 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. - - -- As the Source_File_Name pragmas are handled as logical file 0, - -- 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 Terminate_Program => - null; - -end Gnatchop; |