diff options
Diffstat (limited to 'gcc/ada/gnatchop.adb')
| -rw-r--r-- | gcc/ada/gnatchop.adb | 1696 |
1 files changed, 1696 insertions, 0 deletions
diff --git a/gcc/ada/gnatchop.adb b/gcc/ada/gnatchop.adb new file mode 100644 index 00000000000..acb644460f8 --- /dev/null +++ b/gcc/ada/gnatchop.adb @@ -0,0 +1,1696 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T C H O P -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.44 $ +-- -- +-- Copyright (C) 1998-2001 Ada Core Technologies, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Command_Line; use GNAT.Command_Line; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Heap_Sort_G; +with GNAT.Table; + +with Gnatvsn; +with Hostparm; + +procedure Gnatchop is + + Cwrite : constant String := + "GNATCHOP " & + Gnatvsn.Gnat_Version_String & + " Copyright 1998-2000, Ada Core Technologies Inc."; + + Terminate_Program : exception; + -- 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 + + 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; + 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; + -- File descriptor based functions needed for redirecting stdin/stdout + + pragma Import (C, dup, "dup"); + pragma Import (C, dup2, "dup2"); + + --------------------- + -- Local variables -- + --------------------- + + Warning_Count : Natural := 0; + -- Count of warnings issued so far + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Error_Msg (Message : String); + -- Produce an error message on standard error output + + 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) return String_Access; + -- Locate executable for given program name. This takes into account + -- the target-prefix of the current command. + + 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 Sucess + -- 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; + Success : out Boolean); + -- Write one compilation unit of the source to file + + --------------- + -- Error_Msg -- + --------------- + + procedure Error_Msg (Message : String) is + begin + Put_Line (Standard_Error, Message); + Set_Exit_Status (Failure); + + if Exit_On_Error then + raise Terminate_Program; + end if; + end Error_Msg; + + ----------------- + -- 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 : 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) return String_Access is + Current_Command : constant String := Command_Name; + End_Of_Prefix : Natural; + Start_Of_Prefix : Positive := Current_Command'First; + Result : String_Access; + + begin + -- 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 + + End_Of_Prefix := Start_Of_Prefix - 1; + + for J in reverse Start_Of_Prefix .. Current_Command'Last loop + if Current_Command (J) = '-' then + End_Of_Prefix := J; + exit; + end if; + end loop; + + 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; + Offset_Name : Temp_File_Name; + Offset_FD : File_Descriptor; + Save_Stdout : File_Descriptor := dup (Standout); + 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 + -- succesfully 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 : 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 + -- preceeding 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? q r v w x") is + when ASCII.NUL => + exit; + + 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 'q' => + Quiet_Mode := True; + + when 'r' => + Source_References := True; + + when 'v' => + Verbose_Mode := True; + Put_Line (Standard_Error, Cwrite); + + when 'w' => + Overwrite_Files := True; + + when 'x' => + Exit_On_Error := True; + + when others => + null; + end case; + end loop; + + if not Kset and then Maximum_File_Name_Length > 0 then + + -- 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] [-q] [-v] [-w] [-x] 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 + (" -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"); + + 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; + + begin + FD := Open_Read (Name'Address, Binary); + + 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, 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; + 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); + end Write_Unit; + +-- Start of processing for gnatchop + +begin + -- Check presence of required executables + + Gnat_Cmd := Locate_Executable ("gcc"); + + if Gnat_Cmd = null then + goto No_Files_Written; + end if; + + -- Process command line options and initialize global variables + + if not Scan_Arguments then + Set_Exit_Status (Failure); + return; + 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"); + 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 : String := Warning_Count'Img & " warning(s)"; + begin + Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last)); + 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"); + end if; + + return; + +exception + when Terminate_Program => + null; + +end Gnatchop; |