1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2012, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Ada.Characters.Conversions; use Ada.Characters.Conversions;
27 with Ada.Command_Line; use Ada.Command_Line;
28 with Ada.Directories; use Ada.Directories;
29 with Ada.Streams.Stream_IO; use Ada.Streams;
30 with Ada.Text_IO; use Ada.Text_IO;
31 with System.CRTL; use System; use System.CRTL;
33 with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark;
34 with GNAT.Command_Line; use GNAT.Command_Line;
35 with GNAT.OS_Lib; use GNAT.OS_Lib;
36 with GNAT.Heap_Sort_G;
40 with Switch; use Switch;
45 Config_File_Name : constant String_Access := new String'("gnat.adc");
46 -- The name of the file holding the GNAT configuration pragmas
48 Gcc : String_Access := new String'("gcc");
49 -- May be modified by switch --GCC=
51 Gcc_Set : Boolean := False;
52 -- True if a switch --GCC= is used
54 Gnat_Cmd : String_Access;
55 -- Command to execute the GNAT compiler
57 Gnat_Args : Argument_List_Access :=
62 new String'("-gnats"),
63 new String'("-gnatu"));
64 -- Arguments used in Gnat_Cmd call
66 EOF : constant Character := Character'Val (26);
67 -- Special character to signal end of file. Not required in input files,
68 -- but properly treated if present. Not generated in output files except
69 -- as a result of copying input file.
71 BOM_Length : Natural := 0;
72 -- Reset to non-zero value if BOM detected at start of file
78 subtype File_Num is Natural;
79 subtype File_Offset is Natural;
81 type File_Entry is record
83 -- Name of chop file or directory
85 SR_Name : String_Access;
86 -- Null unless the chop file starts with a source reference pragma
87 -- in which case this field points to the file name from this pragma.
90 package File is new GNAT.Table
91 (Table_Component_Type => File_Entry,
92 Table_Index_Type => File_Num,
95 Table_Increment => 100);
97 Directory : String_Access;
98 -- Record name of directory, or a null string if no directory given
100 Compilation_Mode : Boolean := False;
101 Overwrite_Files : Boolean := False;
102 Preserve_Mode : Boolean := False;
103 Quiet_Mode : Boolean := False;
104 Source_References : Boolean := False;
105 Verbose_Mode : Boolean := False;
106 Exit_On_Error : Boolean := False;
109 Write_gnat_adc : Boolean := False;
110 -- Gets set true if we append to gnat.adc or create a new gnat.adc.
111 -- Used to inhibit complaint about no units generated.
117 type Line_Num is new Natural;
118 -- Line number (for source reference pragmas)
120 type Unit_Count_Type is new Integer;
121 subtype Unit_Num is Unit_Count_Type range 1 .. Unit_Count_Type'Last;
122 -- Used to refer to unit number in unit table
124 type SUnit_Num is new Integer;
125 -- Used to refer to entry in sorted units table. Note that entry
126 -- zero is only for use by Heapsort, and is not otherwise referenced.
128 type Unit_Kind is (Unit_Spec, Unit_Body, Config_Pragmas);
130 -- Structure to contain all necessary information for one unit.
131 -- Entries are also temporarily used to record config pragma sequences.
133 type Unit_Info is record
134 File_Name : String_Access;
135 -- File name from GNAT output line
137 Chop_File : File_Num;
138 -- File number in chop file sequence
140 Start_Line : Line_Num;
141 -- Line number from GNAT output line
143 Offset : File_Offset;
144 -- Offset name from GNAT output line
146 SR_Present : Boolean;
147 -- Set True if SR parameter present
149 Length : File_Offset;
150 -- A length of 0 means that the Unit is the last one in the file
153 -- Indicates kind of unit
155 Sorted_Index : SUnit_Num;
156 -- Index of unit in sorted unit list
158 Bufferg : String_Access;
159 -- Pointer to buffer containing configuration pragmas to be prepended.
160 -- Null if no pragmas to be prepended.
163 -- The following table stores the unit offset information
165 package Unit is new GNAT.Table
166 (Table_Component_Type => Unit_Info,
167 Table_Index_Type => Unit_Count_Type,
168 Table_Low_Bound => 1,
169 Table_Initial => 500,
170 Table_Increment => 100);
172 -- The following table is used as a sorted index to the Unit.Table.
173 -- The entries in Unit.Table are not moved, instead we just shuffle
174 -- the entries in Sorted_Units. Note that the zeroeth entry in this
175 -- table is used by GNAT.Heap_Sort_G.
177 package Sorted_Units is new GNAT.Table
178 (Table_Component_Type => Unit_Num,
179 Table_Index_Type => SUnit_Num,
180 Table_Low_Bound => 0,
181 Table_Initial => 500,
182 Table_Increment => 100);
184 function Is_Duplicated (U : SUnit_Num) return Boolean;
185 -- Returns true if U is duplicated by a later unit.
186 -- Note that this function returns false for the last entry.
188 procedure Sort_Units;
189 -- Sort units and set up sorted unit table
191 ----------------------
192 -- File_Descriptors --
193 ----------------------
195 function dup (handle : File_Descriptor) return File_Descriptor;
196 function dup2 (from, to : File_Descriptor) return File_Descriptor;
198 ---------------------
199 -- Local variables --
200 ---------------------
202 Warning_Count : Natural := 0;
203 -- Count of warnings issued so far
205 -----------------------
206 -- Local subprograms --
207 -----------------------
209 procedure Error_Msg (Message : String; Warning : Boolean := False);
210 -- Produce an error message on standard error output
212 procedure File_Time_Stamp (Name : C_File_Name; Time : OS_Time);
213 -- Given the name of a file or directory, Name, set the
214 -- time stamp. This function must be used for an unopened file.
216 function Files_Exist return Boolean;
217 -- Check Unit.Table for possible file names that already exist
218 -- in the file system. Returns true if files exist, False otherwise
220 function Get_Maximum_File_Name_Length return Integer;
221 pragma Import (C, Get_Maximum_File_Name_Length,
222 "__gnat_get_maximum_file_name_length");
223 -- Function to get maximum file name length for system
225 Maximum_File_Name_Length : constant Integer := Get_Maximum_File_Name_Length;
226 Maximum_File_Name_Length_String : constant String :=
228 (Maximum_File_Name_Length);
230 function Locate_Executable
231 (Program_Name : String;
232 Look_For_Prefix : Boolean := True) return String_Access;
233 -- Locate executable for given program name. This takes into account
234 -- the target-prefix of the current command, if Look_For_Prefix is True.
236 subtype EOL_Length is Natural range 0 .. 2;
237 -- Possible lengths of end of line sequence
239 type EOL_String (Len : EOL_Length := 0) is record
240 Str : String (1 .. Len);
244 (Source : not null access String;
245 Start : Positive) return EOL_String;
246 -- Return the line terminator used in the passed string
249 (Source : not null access String;
250 Ptr : in out Positive);
251 -- On return Source (Ptr) is the first character of the next line
252 -- or EOF. Source.all must be terminated by EOF.
254 function Parse_File (Num : File_Num) return Boolean;
255 -- Calls the GNAT compiler to parse the given source file and parses the
256 -- output using Parse_Offset_Info. Returns True if parse operation
257 -- completes, False if some system error (e.g. failure to read the
258 -- offset information) occurs.
260 procedure Parse_Offset_Info
261 (Chop_File : File_Num;
262 Source : not null access String);
263 -- Parses the output of the compiler indicating the offsets
264 -- and names of the compilation units in Chop_File.
266 procedure Parse_Token
267 (Source : not null access String;
268 Ptr : in out Positive;
269 Token_Ptr : out Positive);
270 -- Skips any separators and stores the start of the token in Token_Ptr.
271 -- Then stores the position of the next separator in Ptr.
272 -- On return Source (Token_Ptr .. Ptr - 1) is the token.
275 (FD : File_Descriptor;
276 Contents : out String_Access;
277 Success : out Boolean);
278 -- Reads file associated with FS into the newly allocated
280 -- [VMS] Success is true iff the number of bytes read is less than or
281 -- equal to the file size.
282 -- [Other] Success is true iff the number of bytes read is equal to
285 function Report_Duplicate_Units return Boolean;
286 -- Output messages about duplicate units in the input files in Unit.Table
287 -- Returns True if any duplicates found, False if no duplicates found.
289 function Scan_Arguments return Boolean;
290 -- Scan command line options and set global variables accordingly.
291 -- Also scan out file and directory arguments. Returns True if scan
292 -- was successful, and False if the scan fails for any reason.
295 -- Output message on standard output describing syntax of gnatchop command
297 procedure Warning_Msg (Message : String);
298 -- Output a warning message on standard error and update warning count
300 function Write_Chopped_Files (Input : File_Num) return Boolean;
301 -- Write all units that result from chopping the Input file
303 procedure Write_Config_File (Input : File_Num; U : Unit_Num);
304 -- Call to write configuration pragmas (append them to gnat.adc)
305 -- Input is the file number for the chop file and U identifies the
306 -- unit entry for the configuration pragmas.
308 function Get_Config_Pragmas
310 U : Unit_Num) return String_Access;
311 -- Call to read configuration pragmas from given unit entry, and
312 -- return a buffer containing the pragmas to be appended to
313 -- following units. Input is the file number for the chop file and
314 -- U identifies the unit entry for the configuration pragmas.
316 procedure Write_Source_Reference_Pragma
319 File : Stream_IO.File_Type;
321 Success : in out Boolean);
322 -- If Success is True on entry, writes a source reference pragma using
323 -- the chop file from Info, and the given line number. On return Success
324 -- indicates whether the write succeeded. If Success is False on entry,
325 -- or if the global flag Source_References is False, then the call to
326 -- Write_Source_Reference_Pragma has no effect. EOL indicates the end
327 -- of line sequence to be written at the end of the pragma.
330 (Source : not null access String;
334 Success : out Boolean);
335 -- Write one compilation unit of the source to file. Source is the pointer
336 -- to the input string, Num is the unit number, TS_Time is the timestamp,
337 -- Write_BOM is set True to write a UTF-8 BOM at the start of the file.
338 -- Success is set True unless the write attempt fails.
344 function dup (handle : File_Descriptor) return File_Descriptor is
346 return File_Descriptor (System.CRTL.dup (int (handle)));
353 function dup2 (from, to : File_Descriptor) return File_Descriptor is
355 return File_Descriptor (System.CRTL.dup2 (int (from), int (to)));
362 procedure Error_Msg (Message : String; Warning : Boolean := False) is
364 Put_Line (Standard_Error, Message);
367 Set_Exit_Status (Failure);
369 if Exit_On_Error then
370 raise Types.Terminate_Program;
375 ---------------------
376 -- File_Time_Stamp --
377 ---------------------
379 procedure File_Time_Stamp (Name : C_File_Name; Time : OS_Time) is
380 procedure Set_File_Time (Name : C_File_Name; Time : OS_Time);
381 pragma Import (C, Set_File_Time, "__gnat_set_file_time_name");
384 Set_File_Time (Name, Time);
391 function Files_Exist return Boolean is
392 Exists : Boolean := False;
395 for SNum in 1 .. SUnit_Num (Unit.Last) loop
397 -- Only check and report for the last instance of duplicated files
399 if not Is_Duplicated (SNum) then
401 Info : constant Unit_Info :=
402 Unit.Table (Sorted_Units.Table (SNum));
405 if Is_Writable_File (Info.File_Name.all) then
406 if Hostparm.OpenVMS then
409 & " already exists, use /OVERWRITE to overwrite");
411 Error_Msg (Info.File_Name.all
412 & " already exists, use -w to overwrite");
424 ------------------------
425 -- Get_Config_Pragmas --
426 ------------------------
428 function Get_Config_Pragmas
430 U : Unit_Num) return String_Access
432 Info : Unit_Info renames Unit.Table (U);
433 FD : File_Descriptor;
434 Name : aliased constant String :=
435 File.Table (Input).Name.all & ASCII.NUL;
436 Length : File_Offset;
437 Buffer : String_Access;
438 Result : String_Access;
441 pragma Warnings (Off, Success);
444 FD := Open_Read (Name'Address, Binary);
446 if FD = Invalid_FD then
447 Error_Msg ("cannot open " & File.Table (Input).Name.all);
451 Read_File (FD, Buffer, Success);
453 -- A length of 0 indicates that the rest of the file belongs to
454 -- this unit. The actual length must be calculated now. Take into
455 -- account that the last character (EOF) must not be written.
457 if Info.Length = 0 then
458 Length := Buffer'Last - (Buffer'First + Info.Offset);
460 Length := Info.Length;
463 Result := new String'(Buffer (1 .. Length));
466 end Get_Config_Pragmas;
473 (Source : not null access String;
474 Start : Positive) return EOL_String
476 Ptr : Positive := Start;
481 -- Skip to end of line
483 while Source (Ptr) /= ASCII.CR and then
484 Source (Ptr) /= ASCII.LF and then
492 if Source (Ptr) /= EOF then
504 if Source (Ptr) = ASCII.CR and then Source (Ptr + 1) = ASCII.LF then
508 return (Len => Last + 1 - First, Str => Source (First .. Last));
515 function Is_Duplicated (U : SUnit_Num) return Boolean is
517 return U < SUnit_Num (Unit.Last)
519 Unit.Table (Sorted_Units.Table (U)).File_Name.all =
520 Unit.Table (Sorted_Units.Table (U + 1)).File_Name.all;
523 -----------------------
524 -- Locate_Executable --
525 -----------------------
527 function Locate_Executable
528 (Program_Name : String;
529 Look_For_Prefix : Boolean := True) return String_Access
531 Gnatchop_Str : constant String := "gnatchop";
532 Current_Command : constant String := Normalize_Pathname (Command_Name);
533 End_Of_Prefix : Natural;
534 Start_Of_Prefix : Positive;
535 Start_Of_Suffix : Positive;
536 Result : String_Access;
539 Start_Of_Prefix := Current_Command'First;
540 Start_Of_Suffix := Current_Command'Last + 1;
541 End_Of_Prefix := Start_Of_Prefix - 1;
543 if Look_For_Prefix then
545 -- Find Start_Of_Prefix
547 for J in reverse Current_Command'Range loop
548 if Current_Command (J) = '/' or else
549 Current_Command (J) = Directory_Separator or else
550 Current_Command (J) = ':'
552 Start_Of_Prefix := J + 1;
557 -- Find End_Of_Prefix
559 for J in Start_Of_Prefix ..
560 Current_Command'Last - Gnatchop_Str'Length + 1
562 if Current_Command (J .. J + Gnatchop_Str'Length - 1) =
565 End_Of_Prefix := J - 1;
571 if End_Of_Prefix > Current_Command'First then
572 Start_Of_Suffix := End_Of_Prefix + Gnatchop_Str'Length + 1;
576 Command : constant String :=
577 Current_Command (Start_Of_Prefix .. End_Of_Prefix)
579 & Current_Command (Start_Of_Suffix ..
580 Current_Command'Last);
582 Result := Locate_Exec_On_Path (Command);
584 if Result = null then
586 (Command & ": installation problem, executable not found");
591 end Locate_Executable;
598 (Source : not null access String;
599 Ptr : in out Positive) is
601 -- Skip to end of line
603 while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF
604 and then Source (Ptr) /= EOF
609 if Source (Ptr) /= EOF then
610 Ptr := Ptr + 1; -- skip CR or LF
613 -- Skip past CR/LF or LF/CR combination
615 if (Source (Ptr) = ASCII.CR or else Source (Ptr) = ASCII.LF)
616 and then Source (Ptr) /= Source (Ptr - 1)
626 function Parse_File (Num : File_Num) return Boolean is
627 Chop_Name : constant String_Access := File.Table (Num).Name;
628 Save_Stdout : constant File_Descriptor := dup (Standout);
629 Offset_Name : Temp_File_Name;
630 Offset_FD : File_Descriptor;
631 Buffer : String_Access;
636 -- Display copy of GNAT command if verbose mode
641 for J in 1 .. Gnat_Args'Length loop
643 Put (Gnat_Args (J).all);
647 Put_Line (Chop_Name.all);
650 -- Create temporary file
652 Create_Temp_File (Offset_FD, Offset_Name);
654 if Offset_FD = Invalid_FD then
655 Error_Msg ("gnatchop: cannot create temporary file");
660 -- Redirect Stdout to this temporary file in the Unix way
662 if dup2 (Offset_FD, Standout) = Invalid_FD then
663 Error_Msg ("gnatchop: cannot redirect stdout to temporary file");
669 -- Call Gnat on the source filename argument with special options
670 -- to generate offset information. If this special compilation completes
671 -- successfully then we can do the actual gnatchop operation.
673 Spawn (Gnat_Cmd.all, Gnat_Args.all & Chop_Name, Success);
676 Error_Msg (Chop_Name.all & ": parse errors detected");
677 Error_Msg (Chop_Name.all & ": chop may not be successful");
682 if dup2 (Save_Stdout, Standout) = Invalid_FD then
683 Error_Msg ("gnatchop: cannot restore stdout");
686 -- Reopen the file to start reading from the beginning
690 Offset_FD := Open_Read (Offset_Name'Address, Binary);
692 if Offset_FD = Invalid_FD then
693 Error_Msg ("gnatchop: cannot access offset info");
697 Read_File (Offset_FD, Buffer, Success);
700 Error_Msg ("gnatchop: error reading offset info");
704 Parse_Offset_Info (Num, Buffer);
707 -- Close and delete temporary file
710 Delete_File (Offset_Name'Address, Success);
715 when Failure | Types.Terminate_Program =>
717 Delete_File (Offset_Name'Address, Success);
722 -----------------------
723 -- Parse_Offset_Info --
724 -----------------------
726 procedure Parse_Offset_Info
727 (Chop_File : File_Num;
728 Source : not null access String)
730 First_Unit : constant Unit_Num := Unit.Last + 1;
731 Bufferg : String_Access := null;
732 Parse_Ptr : File_Offset := Source'First;
733 Token_Ptr : File_Offset;
736 function Match (Literal : String) return Boolean;
737 -- Checks if given string appears at the current Token_Ptr location
738 -- and if so, bumps Parse_Ptr past the token and returns True. If
739 -- the string is not present, sets Parse_Ptr to Token_Ptr and
746 function Match (Literal : String) return Boolean is
748 Parse_Token (Source, Parse_Ptr, Token_Ptr);
750 if Source'Last + 1 - Token_Ptr < Literal'Length
752 Source (Token_Ptr .. Token_Ptr + Literal'Length - 1) /= Literal
754 Parse_Ptr := Token_Ptr;
758 Parse_Ptr := Token_Ptr + Literal'Length;
762 -- Start of processing for Parse_Offset_Info
766 -- Set default values, should get changed for all
767 -- units/pragmas except for the last
769 Info.Chop_File := Chop_File;
772 -- Parse the current line of offset information into Info
773 -- and exit the loop if there are any errors or on EOF.
775 -- First case, parse a line in the following format:
777 -- Unit x (spec) line 7, file offset 142, [SR, ]file name x.ads
779 -- Note that the unit name can be an operator name in quotes.
780 -- This is of course illegal, but both GNAT and gnatchop handle
781 -- the case so that this error does not interfere with chopping.
783 -- The SR ir present indicates that a source reference pragma
784 -- was processed as part of this unit (and that therefore no
785 -- Source_Reference pragma should be generated.
787 if Match ("Unit") then
788 Parse_Token (Source, Parse_Ptr, Token_Ptr);
790 if Match ("(body)") then
791 Info.Kind := Unit_Body;
792 elsif Match ("(spec)") then
793 Info.Kind := Unit_Spec;
798 exit when not Match ("line");
799 Parse_Token (Source, Parse_Ptr, Token_Ptr);
800 Info.Start_Line := Line_Num'Value
801 (Source (Token_Ptr .. Parse_Ptr - 1));
803 exit when not Match ("file offset");
804 Parse_Token (Source, Parse_Ptr, Token_Ptr);
805 Info.Offset := File_Offset'Value
806 (Source (Token_Ptr .. Parse_Ptr - 1));
808 Info.SR_Present := Match ("SR, ");
810 exit when not Match ("file name");
811 Parse_Token (Source, Parse_Ptr, Token_Ptr);
812 Info.File_Name := new String'
813 (Directory.all & Source (Token_Ptr .. Parse_Ptr - 1));
814 Parse_EOL (Source, Parse_Ptr);
816 -- Second case, parse a line of the following form
818 -- Configuration pragmas at line 10, file offset 223
820 elsif Match ("Configuration pragmas at") then
821 Info.Kind := Config_Pragmas;
822 Info.File_Name := Config_File_Name;
824 exit when not Match ("line");
825 Parse_Token (Source, Parse_Ptr, Token_Ptr);
826 Info.Start_Line := Line_Num'Value
827 (Source (Token_Ptr .. Parse_Ptr - 1));
829 exit when not Match ("file offset");
830 Parse_Token (Source, Parse_Ptr, Token_Ptr);
831 Info.Offset := File_Offset'Value
832 (Source (Token_Ptr .. Parse_Ptr - 1));
834 Parse_EOL (Source, Parse_Ptr);
836 -- Third case, parse a line of the following form
838 -- Source_Reference pragma for file "filename"
840 -- This appears at the start of the file only, and indicates
841 -- the name to be used on any generated Source_Reference pragmas.
843 elsif Match ("Source_Reference pragma for file ") then
844 Parse_Token (Source, Parse_Ptr, Token_Ptr);
845 File.Table (Chop_File).SR_Name :=
846 new String'(Source (Token_Ptr + 1 .. Parse_Ptr - 2));
847 Parse_EOL (Source, Parse_Ptr);
850 -- Unrecognized keyword or end of file
856 -- Store the data in the Info record in the Unit.Table
859 Unit.Table (Unit.Last) := Info;
861 -- If this is not the first unit from the file, calculate
862 -- the length of the previous unit as difference of the offsets
864 if Unit.Last > First_Unit then
865 Unit.Table (Unit.Last - 1).Length :=
866 Info.Offset - Unit.Table (Unit.Last - 1).Offset;
869 -- If not in compilation mode combine current unit with any
870 -- preceding configuration pragmas.
872 if not Compilation_Mode
873 and then Unit.Last > First_Unit
874 and then Unit.Table (Unit.Last - 1).Kind = Config_Pragmas
876 Info.Start_Line := Unit.Table (Unit.Last - 1).Start_Line;
877 Info.Offset := Unit.Table (Unit.Last - 1).Offset;
879 -- Delete the configuration pragma entry
881 Unit.Table (Unit.Last - 1) := Info;
885 -- If in compilation mode, and previous entry is the initial
886 -- entry for the file and is for configuration pragmas, then
887 -- they are to be appended to every unit in the file.
890 and then Unit.Last = First_Unit + 1
891 and then Unit.Table (First_Unit).Kind = Config_Pragmas
895 (Unit.Table (Unit.Last - 1).Chop_File, First_Unit);
896 Unit.Table (Unit.Last - 1) := Info;
900 Unit.Table (Unit.Last).Bufferg := Bufferg;
902 -- If in compilation mode, and this is not the first item,
903 -- combine configuration pragmas with previous unit, which
904 -- will cause an error message to be generated when the unit
908 and then Unit.Last > First_Unit
909 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
919 -- Find out if the loop was exited prematurely because of
920 -- an error or if the EOF marker was found.
922 if Source (Parse_Ptr) /= EOF then
924 (File.Table (Chop_File).Name.all & ": error parsing offset info");
928 -- Handle case of a chop file consisting only of config pragmas
930 if Unit.Last = First_Unit
931 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
933 -- In compilation mode, we append such a file to gnat.adc
935 if Compilation_Mode then
936 Write_Config_File (Unit.Table (Unit.Last).Chop_File, First_Unit);
939 -- In default (non-compilation) mode, this is invalid
943 (File.Table (Chop_File).Name.all &
944 ": no units found (only pragmas)");
949 -- Handle case of a chop file ending with config pragmas. This can
950 -- happen only in default non-compilation mode, since in compilation
951 -- mode such configuration pragmas are part of the preceding unit.
952 -- We simply concatenate such pragmas to the previous file which
953 -- will cause a compilation error, which is appropriate.
955 if Unit.Last > First_Unit
956 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
960 end Parse_Offset_Info;
966 procedure Parse_Token
967 (Source : not null access String;
968 Ptr : in out Positive;
969 Token_Ptr : out Positive)
971 In_Quotes : Boolean := False;
976 while Source (Ptr) = ' ' or else Source (Ptr) = ',' loop
985 or else not (Source (Ptr) = ' ' or else Source (Ptr) = ','))
986 and then Source (Ptr) >= ' '
988 if Source (Ptr) = '"' then
989 In_Quotes := not In_Quotes;
1001 (FD : File_Descriptor;
1002 Contents : out String_Access;
1003 Success : out Boolean)
1005 Length : constant File_Offset := File_Offset (File_Length (FD));
1006 -- Include room for EOF char
1007 Buffer : String_Access := new String (1 .. Length + 1);
1009 This_Read : Integer;
1010 Read_Ptr : File_Offset := 1;
1015 This_Read := Read (FD,
1016 A => Buffer (Read_Ptr)'Address,
1017 N => Length + 1 - Read_Ptr);
1018 Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0);
1019 exit when This_Read <= 0;
1022 Buffer (Read_Ptr) := EOF;
1024 -- Comment needed for the following ???
1025 -- Under what circumstances can the test fail ???
1026 -- What is copy doing in that case???
1028 if Read_Ptr = Length then
1032 Contents := new String (1 .. Read_Ptr);
1033 Contents.all := Buffer (1 .. Read_Ptr);
1037 -- Things aren't simple on VMS due to the plethora of file types and
1038 -- organizations. It seems clear that there shouldn't be more bytes
1039 -- read than are contained in the file though.
1041 if Hostparm.OpenVMS then
1042 Success := Read_Ptr <= Length + 1;
1044 Success := Read_Ptr = Length + 1;
1048 ----------------------------
1049 -- Report_Duplicate_Units --
1050 ----------------------------
1052 function Report_Duplicate_Units return Boolean is
1056 Duplicates : Boolean := False;
1060 while US < SUnit_Num (Unit.Last) loop
1061 U := Sorted_Units.Table (US);
1063 if Is_Duplicated (US) then
1066 -- Move to last two versions of duplicated file to make it clearer
1067 -- to understand which file is retained in case of overwriting.
1069 while US + 1 < SUnit_Num (Unit.Last) loop
1070 exit when not Is_Duplicated (US + 1);
1074 U := Sorted_Units.Table (US);
1076 if Overwrite_Files then
1077 Warning_Msg (Unit.Table (U).File_Name.all
1078 & " is duplicated (all but last will be skipped)");
1080 elsif Unit.Table (U).Chop_File =
1081 Unit.Table (Sorted_Units.Table (US + 1)).Chop_File
1083 Error_Msg (Unit.Table (U).File_Name.all
1084 & " is duplicated in "
1085 & File.Table (Unit.Table (U).Chop_File).Name.all);
1088 Error_Msg (Unit.Table (U).File_Name.all
1090 & File.Table (Unit.Table (U).Chop_File).Name.all
1091 & " is duplicated in "
1094 (Sorted_Units.Table (US + 1)).Chop_File).Name.all);
1101 if Duplicates and not Overwrite_Files then
1102 if Hostparm.OpenVMS then
1104 ("use /OVERWRITE to overwrite files and keep last version");
1106 Put_Line ("use -w to overwrite files and keep last version");
1111 end Report_Duplicate_Units;
1113 --------------------
1114 -- Scan_Arguments --
1115 --------------------
1117 function Scan_Arguments return Boolean is
1118 Kset : Boolean := False;
1119 -- Set true if -k switch found
1122 Initialize_Option_Scan;
1124 -- Scan options first
1127 case Getopt ("c gnat? h k? p q r v w x -GCC=!") is
1132 Gcc := new String'(Parameter);
1136 Compilation_Mode := True;
1140 new Argument_List'(Gnat_Args.all &
1141 new String'("-gnat" & Parameter));
1145 raise Types.Terminate_Program;
1149 Param : String_Access := new String'(Parameter);
1152 if Param.all /= "" then
1153 for J in Param'Range loop
1154 if Param (J) not in '0' .. '9' then
1155 if Hostparm.OpenVMS then
1156 Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn" &
1157 " requires numeric parameter");
1159 Error_Msg ("-k# requires numeric parameter");
1167 if Hostparm.OpenVMS then
1168 Param := new String'("39");
1170 Param := new String'("8");
1175 new Argument_List'(Gnat_Args.all &
1176 new String'("-gnatk" & Param.all));
1181 Preserve_Mode := True;
1187 Source_References := True;
1190 Verbose_Mode := True;
1191 Display_Version ("GNATCHOP", "1998");
1194 Overwrite_Files := True;
1197 Exit_On_Error := True;
1204 if not Kset and then Maximum_File_Name_Length > 0 then
1206 -- If this system has restricted filename lengths, tell gnat1
1207 -- about them, removing the leading blank from the image string.
1210 new Argument_List'(Gnat_Args.all
1211 & new String'("-gnatk"
1212 & Maximum_File_Name_Length_String
1213 (Maximum_File_Name_Length_String'First + 1
1214 .. Maximum_File_Name_Length_String'Last)));
1221 S : constant String := Get_Argument (Do_Expansion => True);
1225 File.Increment_Last;
1226 File.Table (File.Last).Name := new String'(S);
1227 File.Table (File.Last).SR_Name := null;
1231 -- Case of more than one file where last file is a directory
1234 and then Is_Directory (File.Table (File.Last).Name.all)
1236 Directory := File.Table (File.Last).Name;
1237 File.Decrement_Last;
1239 -- Make sure Directory is terminated with a directory separator,
1240 -- so we can generate the output by just appending a filename.
1242 if Directory (Directory'Last) /= Directory_Separator
1243 and then Directory (Directory'Last) /= '/'
1245 Directory := new String'(Directory.all & Directory_Separator);
1248 -- At least one filename must be given
1250 elsif File.Last = 0 then
1254 -- No directory given, set directory to null, so that we can just
1255 -- concatenate the directory name to the file name unconditionally.
1258 Directory := new String'("");
1261 -- Finally check all filename arguments
1263 for File_Num in 1 .. File.Last loop
1265 F : constant String := File.Table (File_Num).Name.all;
1268 if Is_Directory (F) then
1269 Error_Msg (F & " is a directory, cannot be chopped");
1272 elsif not Is_Regular_File (F) then
1273 Error_Msg (F & " not found");
1282 when Invalid_Switch =>
1283 Error_Msg ("invalid switch " & Full_Switch);
1286 when Invalid_Parameter =>
1287 if Hostparm.OpenVMS then
1288 Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn qualifier" &
1289 " requires numeric parameter");
1291 Error_Msg ("-k switch requires numeric parameter");
1301 procedure Sort_Units is
1303 procedure Move (From : Natural; To : Natural);
1304 -- Procedure used to sort the unit list
1305 -- Unit.Table (To) := Unit_List (From); used by sort
1307 function Lt (Left, Right : Natural) return Boolean;
1308 -- Compares Left and Right units based on file name (first),
1309 -- Chop_File (second) and Offset (third). This ordering is
1310 -- important to keep the last version in case of duplicate files.
1312 package Unit_Sort is new GNAT.Heap_Sort_G (Move, Lt);
1313 -- Used for sorting on filename to detect duplicates
1319 function Lt (Left, Right : Natural) return Boolean is
1320 L : Unit_Info renames
1321 Unit.Table (Sorted_Units.Table (SUnit_Num (Left)));
1323 R : Unit_Info renames
1324 Unit.Table (Sorted_Units.Table (SUnit_Num (Right)));
1327 return L.File_Name.all < R.File_Name.all
1328 or else (L.File_Name.all = R.File_Name.all
1329 and then (L.Chop_File < R.Chop_File
1330 or else (L.Chop_File = R.Chop_File
1331 and then L.Offset < R.Offset)));
1338 procedure Move (From : Natural; To : Natural) is
1340 Sorted_Units.Table (SUnit_Num (To)) :=
1341 Sorted_Units.Table (SUnit_Num (From));
1344 -- Start of processing for Sort_Units
1347 Sorted_Units.Set_Last (SUnit_Num (Unit.Last));
1349 for J in 1 .. Unit.Last loop
1350 Sorted_Units.Table (SUnit_Num (J)) := J;
1353 -- Sort Unit.Table, using Sorted_Units.Table (0) as scratch
1355 Unit_Sort.Sort (Natural (Unit.Last));
1357 -- Set the Sorted_Index fields in the unit tables
1359 for J in 1 .. SUnit_Num (Unit.Last) loop
1360 Unit.Table (Sorted_Units.Table (J)).Sorted_Index := J;
1371 ("Usage: gnatchop [-c] [-h] [-k#] " &
1372 "[-r] [-p] [-q] [-v] [-w] [-x] [--GCC=xx] file [file ...] [dir]");
1376 Display_Usage_Version_And_Help;
1379 (" -c compilation mode, configuration pragmas " &
1383 (" -gnatxxx passes the -gnatxxx switch to gnat parser");
1386 (" -h help: output this usage information");
1389 (" -k# krunch file names of generated files to " &
1390 "no more than # characters");
1393 (" -k krunch file names of generated files to " &
1394 "no more than 8 characters");
1397 (" -p preserve time stamp, output files will " &
1398 "have same stamp as input");
1401 (" -q quiet mode, no output of generated file " &
1405 (" -r generate Source_Reference pragmas refer" &
1406 "encing original source file");
1409 (" -v verbose mode, output version and generat" &
1413 (" -w overwrite existing filenames");
1416 (" -x exit on error");
1419 (" --GCC=xx specify the path of the gnat parser to be used");
1423 (" file... list of source files to be chopped");
1426 (" dir directory location for split files (defa" &
1427 "ult = current directory)");
1434 procedure Warning_Msg (Message : String) is
1436 Warning_Count := Warning_Count + 1;
1437 Put_Line (Standard_Error, "warning: " & Message);
1440 -------------------------
1441 -- Write_Chopped_Files --
1442 -------------------------
1444 function Write_Chopped_Files (Input : File_Num) return Boolean is
1445 Name : aliased constant String :=
1446 File.Table (Input).Name.all & ASCII.NUL;
1447 FD : File_Descriptor;
1448 Buffer : String_Access;
1452 BOM_Present : Boolean;
1454 -- Record presence of UTF8 BOM in input
1457 FD := Open_Read (Name'Address, Binary);
1458 TS_Time := File_Time_Stamp (FD);
1460 if FD = Invalid_FD then
1461 Error_Msg ("cannot open " & File.Table (Input).Name.all);
1465 Read_File (FD, Buffer, Success);
1468 Error_Msg ("cannot read " & File.Table (Input).Name.all);
1473 if not Quiet_Mode then
1474 Put_Line ("splitting " & File.Table (Input).Name.all & " into:");
1477 -- Test for presence of BOM
1479 Read_BOM (Buffer.all, BOM_Length, BOM, False);
1480 BOM_Present := BOM /= Unknown;
1482 -- Only chop those units that come from this file
1484 for Unit_Number in 1 .. Unit.Last loop
1485 if Unit.Table (Unit_Number).Chop_File = Input then
1490 Write_BOM => BOM_Present and then Unit_Number /= 1,
1491 Success => Success);
1492 exit when not Success;
1498 end Write_Chopped_Files;
1500 -----------------------
1501 -- Write_Config_File --
1502 -----------------------
1504 procedure Write_Config_File (Input : File_Num; U : Unit_Num) is
1505 FD : File_Descriptor;
1506 Name : aliased constant String := "gnat.adc" & ASCII.NUL;
1507 Buffer : String_Access;
1510 Buffera : String_Access;
1514 Write_gnat_adc := True;
1515 FD := Open_Read_Write (Name'Address, Binary);
1517 if FD = Invalid_FD then
1518 FD := Create_File (Name'Address, Binary);
1521 if not Quiet_Mode then
1522 Put_Line ("writing configuration pragmas from " &
1523 File.Table (Input).Name.all & " to gnat.adc");
1529 if not Quiet_Mode then
1531 ("appending configuration pragmas from " &
1532 File.Table (Input).Name.all & " to gnat.adc");
1536 Success := FD /= Invalid_FD;
1539 Error_Msg ("cannot create gnat.adc");
1543 -- In append mode, acquire existing gnat.adc file
1546 Read_File (FD, Buffera, Success);
1549 Error_Msg ("cannot read gnat.adc");
1553 -- Find location of EOF byte if any to exclude from append
1556 while Bufferl <= Buffera'Last
1557 and then Buffera (Bufferl) /= EOF
1559 Bufferl := Bufferl + 1;
1562 Bufferl := Bufferl - 1;
1565 -- Write existing gnat.adc to new gnat.adc file
1567 FD := Create_File (Name'Address, Binary);
1568 Success := Write (FD, Buffera (1)'Address, Bufferl) = Bufferl;
1571 Error_Msg ("error writing gnat.adc");
1576 Buffer := Get_Config_Pragmas (Input, U);
1578 if Buffer /= null then
1579 Success := Write (FD, Buffer.all'Address, Buffer'Length) =
1583 Error_Msg ("disk full writing gnat.adc");
1589 end Write_Config_File;
1591 -----------------------------------
1592 -- Write_Source_Reference_Pragma --
1593 -----------------------------------
1595 procedure Write_Source_Reference_Pragma
1598 File : Stream_IO.File_Type;
1600 Success : in out Boolean)
1602 FTE : File_Entry renames Gnatchop.File.Table (Info.Chop_File);
1603 Nam : String_Access;
1606 if Success and then Source_References and then not Info.SR_Present then
1607 if FTE.SR_Name /= null then
1614 Reference : String :=
1615 "pragma Source_Reference (000000, """
1616 & Nam.all & """);" & EOL.Str;
1618 Pos : Positive := Reference'First;
1619 Lin : Line_Num := Line;
1622 while Reference (Pos + 1) /= ',' loop
1626 while Reference (Pos) = '0' loop
1627 Reference (Pos) := Character'Val
1628 (Character'Pos ('0') + Lin mod 10);
1633 -- Assume there are enough zeroes for any program length
1635 pragma Assert (Lin = 0);
1638 String'Write (Stream_IO.Stream (File), Reference);
1646 end Write_Source_Reference_Pragma;
1652 procedure Write_Unit
1653 (Source : not null access String;
1656 Write_BOM : Boolean;
1657 Success : out Boolean)
1660 procedure OS_Filename
1662 W_Name : Wide_String;
1664 N_Length : access Natural;
1666 E_Length : access Natural);
1667 pragma Import (C, OS_Filename, "__gnat_os_filename");
1668 -- Returns in OS_Name the proper name for the OS when used with the
1669 -- returned Encoding value. For example on Windows this will return the
1670 -- UTF-8 encoded name into OS_Name and set Encoding to encoding=utf8
1671 -- (the form parameter for Stream_IO).
1673 -- Name is the filename and W_Name the same filename in Unicode 16 bits
1674 -- (this corresponds to Win32 Unicode ISO/IEC 10646). N_Length/E_Length
1675 -- are the length returned in OS_Name/Encoding respectively.
1677 Info : Unit_Info renames Unit.Table (Num);
1678 Name : aliased constant String := Info.File_Name.all & ASCII.NUL;
1679 W_Name : aliased constant Wide_String := To_Wide_String (Name);
1680 EOL : constant EOL_String :=
1681 Get_EOL (Source, Source'First + Info.Offset);
1682 OS_Name : aliased String (1 .. Name'Length * 2);
1683 O_Length : aliased Natural := OS_Name'Length;
1684 Encoding : aliased String (1 .. 64);
1685 E_Length : aliased Natural := Encoding'Length;
1686 Length : File_Offset;
1689 -- Skip duplicated files
1691 if Is_Duplicated (Info.Sorted_Index) then
1692 Put_Line (" " & Info.File_Name.all & " skipped");
1693 Success := Overwrite_Files;
1701 OS_Name'Address, O_Length'Access,
1702 Encoding'Address, E_Length'Access);
1705 E_Name : constant String := OS_Name (1 .. O_Length);
1706 C_Name : aliased constant String := E_Name & ASCII.NUL;
1707 OS_Encoding : constant String := Encoding (1 .. E_Length);
1708 File : Stream_IO.File_Type;
1712 if not Overwrite_Files and then Exists (E_Name) then
1713 raise Stream_IO.Name_Error;
1716 (File, Stream_IO.Out_File, E_Name, OS_Encoding);
1721 when Stream_IO.Name_Error | Stream_IO.Use_Error =>
1722 Error_Msg ("cannot create " & Info.File_Name.all);
1726 -- A length of 0 indicates that the rest of the file belongs to
1727 -- this unit. The actual length must be calculated now. Take into
1728 -- account that the last character (EOF) must not be written.
1730 if Info.Length = 0 then
1731 Length := Source'Last - (Source'First + Info.Offset);
1733 Length := Info.Length;
1736 -- Write BOM if required
1740 (Stream_IO.Stream (File),
1741 Source.all (Source'First .. Source'First + BOM_Length - 1));
1744 -- Prepend configuration pragmas if necessary
1746 if Success and then Info.Bufferg /= null then
1747 Write_Source_Reference_Pragma (Info, 1, File, EOL, Success);
1748 String'Write (Stream_IO.Stream (File), Info.Bufferg.all);
1751 Write_Source_Reference_Pragma
1752 (Info, Info.Start_Line, File, EOL, Success);
1757 (Stream_IO.Stream (File),
1758 Source (Source'First + Info.Offset ..
1759 Source'First + Info.Offset + Length - 1));
1761 when Stream_IO.Use_Error | Stream_IO.Device_Error =>
1762 Error_Msg ("disk full writing " & Info.File_Name.all);
1767 if not Quiet_Mode then
1768 Put_Line (" " & Info.File_Name.all);
1771 Stream_IO.Close (File);
1773 if Preserve_Mode then
1774 File_Time_Stamp (C_Name'Address, TS_Time);
1779 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
1781 -- Start of processing for gnatchop
1784 -- Add the directory where gnatchop is invoked in front of the path, if
1785 -- gnatchop is invoked with directory information. Only do this if the
1786 -- platform is not VMS, where the notion of path does not really exist.
1788 if not Hostparm.OpenVMS then
1790 Command : constant String := Command_Name;
1793 for Index in reverse Command'Range loop
1794 if Command (Index) = Directory_Separator then
1796 Absolute_Dir : constant String :=
1798 (Command (Command'First .. Index));
1799 PATH : constant String :=
1802 & Getenv ("PATH").all;
1804 Setenv ("PATH", PATH);
1813 -- Process command line options and initialize global variables
1815 -- First, scan to detect --version and/or --help
1817 Check_Version_And_Help ("GNATCHOP", "1998");
1819 if not Scan_Arguments then
1820 Set_Exit_Status (Failure);
1824 -- Check presence of required executables
1826 Gnat_Cmd := Locate_Executable (Gcc.all, not Gcc_Set);
1828 if Gnat_Cmd = null then
1829 goto No_Files_Written;
1832 -- First parse all files and read offset information
1834 for Num in 1 .. File.Last loop
1835 if not Parse_File (Num) then
1836 goto No_Files_Written;
1840 -- Check if any units have been found (assumes non-empty Unit.Table)
1842 if Unit.Last = 0 then
1843 if not Write_gnat_adc then
1844 Error_Msg ("no compilation units found", Warning => True);
1847 goto No_Files_Written;
1852 -- Check if any duplicate files would be created. If so, emit a warning if
1853 -- Overwrite_Files is true, otherwise generate an error.
1855 if Report_Duplicate_Units and then not Overwrite_Files then
1856 goto No_Files_Written;
1859 -- Check if any files exist, if so do not write anything Because all files
1860 -- have been parsed and checked already, there won't be any duplicates
1862 if not Overwrite_Files and then Files_Exist then
1863 goto No_Files_Written;
1866 -- After this point, all source files are read in succession and chopped
1867 -- into their destination files.
1869 -- Source_File_Name pragmas are handled as logical file 0 so write it first
1871 for F in 1 .. File.Last loop
1872 if not Write_Chopped_Files (F) then
1873 Set_Exit_Status (Failure);
1878 if Warning_Count > 0 then
1880 Warnings_Msg : constant String := Warning_Count'Img & " warning(s)";
1882 Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last), Warning => True);
1888 <<No_Files_Written>>
1890 -- Special error exit for all situations where no files have
1893 if not Write_gnat_adc then
1894 Error_Msg ("no source files written", Warning => True);
1900 when Types.Terminate_Program =>