1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2001 Ada Core Technologies, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
24 ------------------------------------------------------------------------------
26 with Ada.Command_Line; use Ada.Command_Line;
27 with Ada.Text_IO; use Ada.Text_IO;
29 with GNAT.Command_Line; use GNAT.Command_Line;
30 with GNAT.OS_Lib; use GNAT.OS_Lib;
31 with GNAT.Heap_Sort_G;
39 Cwrite : constant String :=
41 Gnatvsn.Gnat_Version_String &
42 " Copyright 1998-2000, Ada Core Technologies Inc.";
44 Terminate_Program : exception;
45 -- Used to terminate execution immediately
47 Config_File_Name : constant String_Access := new String'("gnat.adc");
48 -- The name of the file holding the GNAT configuration pragmas
50 Gcc : String_Access := new String'("gcc");
51 -- May be modified by switch --GCC=
53 Gcc_Set : Boolean := False;
54 -- True if a switch --GCC= is used
56 Gnat_Cmd : String_Access;
57 -- Command to execute the GNAT compiler
59 Gnat_Args : Argument_List_Access := new Argument_List'
60 (new String'("-c"), new String'("-x"), new String'("ada"),
61 new String'("-gnats"), new String'("-gnatu"));
62 -- Arguments used in Gnat_Cmd call
64 EOF : constant Character := Character'Val (26);
65 -- Special character to signal end of file. Not required in input
66 -- files, but properly treated if present. Not generated in output
67 -- files except as a result of copying input file.
73 subtype File_Num is Natural;
74 subtype File_Offset is Natural;
76 type File_Entry is record
78 -- Name of chop file or directory
80 SR_Name : String_Access;
81 -- Null unless the chop file starts with a source reference pragma
82 -- in which case this field points to the file name from this pragma.
85 package File is new GNAT.Table
86 (Table_Component_Type => File_Entry,
87 Table_Index_Type => File_Num,
90 Table_Increment => 100);
92 Directory : String_Access;
93 -- Record name of directory, or a null string if no directory given
95 Compilation_Mode : Boolean := False;
96 Overwrite_Files : Boolean := False;
97 Preserve_Mode : Boolean := False;
98 Quiet_Mode : Boolean := False;
99 Source_References : Boolean := False;
100 Verbose_Mode : Boolean := False;
101 Exit_On_Error : Boolean := False;
104 Write_gnat_adc : Boolean := False;
105 -- Gets set true if we append to gnat.adc or create a new gnat.adc.
106 -- Used to inhibit complaint about no units generated.
112 type Line_Num is new Natural;
113 -- Line number (for source reference pragmas)
115 type Unit_Count_Type is new Integer;
116 subtype Unit_Num is Unit_Count_Type range 1 .. Unit_Count_Type'Last;
117 -- Used to refer to unit number in unit table
119 type SUnit_Num is new Integer;
120 -- Used to refer to entry in sorted units table. Note that entry
121 -- zero is only for use by Heapsort, and is not otherwise referenced.
123 type Unit_Kind is (Unit_Spec, Unit_Body, Config_Pragmas);
125 -- Structure to contain all necessary information for one unit.
126 -- Entries are also temporarily used to record config pragma sequences.
128 type Unit_Info is record
129 File_Name : String_Access;
130 -- File name from GNAT output line
132 Chop_File : File_Num;
133 -- File number in chop file sequence
135 Start_Line : Line_Num;
136 -- Line number from GNAT output line
138 Offset : File_Offset;
139 -- Offset name from GNAT output line
141 SR_Present : Boolean;
142 -- Set True if SR parameter present
144 Length : File_Offset;
145 -- A length of 0 means that the Unit is the last one in the file
148 -- Indicates kind of unit
150 Sorted_Index : SUnit_Num;
151 -- Index of unit in sorted unit list
153 Bufferg : String_Access;
154 -- Pointer to buffer containing configuration pragmas to be
155 -- prepended. Null if no pragmas to be prepended.
159 -- The following table stores the unit offset information
161 package Unit is new GNAT.Table
162 (Table_Component_Type => Unit_Info,
163 Table_Index_Type => Unit_Count_Type,
164 Table_Low_Bound => 1,
165 Table_Initial => 500,
166 Table_Increment => 100);
168 -- The following table is used as a sorted index to the Unit.Table.
169 -- The entries in Unit.Table are not moved, instead we just shuffle
170 -- the entries in Sorted_Units. Note that the zeroeth entry in this
171 -- table is used by GNAT.Heap_Sort_G.
173 package Sorted_Units is new GNAT.Table
174 (Table_Component_Type => Unit_Num,
175 Table_Index_Type => SUnit_Num,
176 Table_Low_Bound => 0,
177 Table_Initial => 500,
178 Table_Increment => 100);
180 function Is_Duplicated (U : SUnit_Num) return Boolean;
181 -- Returns true if U is duplicated by a later unit.
182 -- Note that this function returns false for the last entry.
184 procedure Sort_Units;
185 -- Sort units and set up sorted unit table.
187 ----------------------
188 -- File_Descriptors --
189 ----------------------
191 function dup (handle : File_Descriptor) return File_Descriptor;
192 function dup2 (from, to : File_Descriptor) return File_Descriptor;
193 -- File descriptor based functions needed for redirecting stdin/stdout
195 pragma Import (C, dup, "dup");
196 pragma Import (C, dup2, "dup2");
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);
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)
233 return String_Access;
234 -- Locate executable for given program name. This takes into account
235 -- the target-prefix of the current command, if Look_For_Prefix is True.
237 subtype EOL_Length is Natural range 0 .. 2;
238 -- Possible lengths of end of line sequence
240 type EOL_String (Len : EOL_Length := 0) is record
241 Str : String (1 .. Len);
245 (Source : access String;
248 -- Return the line terminator used in the passed string
250 procedure Parse_EOL (Source : access String; 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 (Chop_File : File_Num; Source : access String);
261 -- Parses the output of the compiler indicating the offsets
262 -- and names of the compilation units in Chop_File.
264 procedure Parse_Token
265 (Source : access String;
266 Ptr : in out Positive;
267 Token_Ptr : out Positive);
268 -- Skips any separators and stores the start of the token in Token_Ptr.
269 -- Then stores the position of the next separator in Ptr.
270 -- On return Source (Token_Ptr .. Ptr - 1) is the token.
273 (FD : File_Descriptor;
274 Contents : out String_Access;
275 Success : out Boolean);
276 -- Reads file associated with FS into the newly allocated
278 -- [VMS] Success is true iff the number of bytes read is less than or
279 -- equal to the file size.
280 -- [Other] Success is true iff the number of bytes read is equal to
283 function Report_Duplicate_Units return Boolean;
284 -- Output messages about duplicate units in the input files in Unit.Table
285 -- Returns True if any duplicates found, Fals if no duplicates found.
287 function Scan_Arguments return Boolean;
288 -- Scan command line options and set global variables accordingly.
289 -- Also scan out file and directory arguments. Returns True if scan
290 -- was successful, and False if the scan fails for any reason.
293 -- Output message on standard output describing syntax of gnatchop command
295 procedure Warning_Msg (Message : String);
296 -- Output a warning message on standard error and update warning count
298 function Write_Chopped_Files (Input : File_Num) return Boolean;
299 -- Write all units that result from chopping the Input file
301 procedure Write_Config_File (Input : File_Num; U : Unit_Num);
302 -- Call to write configuration pragmas (append them to gnat.adc)
303 -- Input is the file number for the chop file and U identifies the
304 -- unit entry for the configuration pragmas.
306 function Get_Config_Pragmas
309 return String_Access;
310 -- Call to read configuration pragmas from given unit entry, and
311 -- return a buffer containing the pragmas to be appended to
312 -- following units. Input is the file number for the chop file and
313 -- U identifies the unit entry for the configuration pragmas.
315 procedure Write_Source_Reference_Pragma
318 FD : File_Descriptor;
320 Success : in out Boolean);
321 -- If Success is True on entry, writes a source reference pragma using
322 -- the chop file from Info, and the given line number. On return Success
323 -- indicates whether the write succeeded. If Success is False on entry,
324 -- or if the global flag Source_References is False, then the call to
325 -- Write_Source_Reference_Pragma has no effect. EOL indicates the end
326 -- of line sequence to be written at the end of the pragma.
329 (Source : access String;
332 Success : out Boolean);
333 -- Write one compilation unit of the source to file
339 procedure Error_Msg (Message : String) is
341 Put_Line (Standard_Error, Message);
342 Set_Exit_Status (Failure);
344 if Exit_On_Error then
345 raise Terminate_Program;
349 ---------------------
350 -- File_Time_Stamp --
351 ---------------------
353 procedure File_Time_Stamp (Name : C_File_Name; Time : OS_Time) is
354 procedure Set_File_Time (Name : C_File_Name; Time : OS_Time);
355 pragma Import (C, Set_File_Time, "__gnat_set_file_time_name");
358 Set_File_Time (Name, Time);
365 function Files_Exist return Boolean is
366 Exists : Boolean := False;
369 for SNum in 1 .. SUnit_Num (Unit.Last) loop
371 -- Only check and report for the last instance of duplicated files
373 if not Is_Duplicated (SNum) then
375 Info : Unit_Info := Unit.Table (Sorted_Units.Table (SNum));
378 if Is_Writable_File (Info.File_Name.all) then
379 if Hostparm.OpenVMS then
382 & " already exists, use /OVERWRITE to overwrite");
384 Error_Msg (Info.File_Name.all
385 & " already exists, use -w to overwrite");
397 ------------------------
398 -- Get_Config_Pragmas --
399 ------------------------
401 function Get_Config_Pragmas
406 Info : Unit_Info renames Unit.Table (U);
407 FD : File_Descriptor;
408 Name : aliased constant String :=
409 File.Table (Input).Name.all & ASCII.Nul;
410 Length : File_Offset;
411 Buffer : String_Access;
413 Result : String_Access;
416 FD := Open_Read (Name'Address, Binary);
418 if FD = Invalid_FD then
419 Error_Msg ("cannot open " & File.Table (Input).Name.all);
423 Read_File (FD, Buffer, Success);
425 -- A length of 0 indicates that the rest of the file belongs to
426 -- this unit. The actual length must be calculated now. Take into
427 -- account that the last character (EOF) must not be written.
429 if Info.Length = 0 then
430 Length := Buffer'Last - (Buffer'First + Info.Offset);
432 Length := Info.Length;
435 Result := new String'(Buffer (1 .. Length));
438 end Get_Config_Pragmas;
445 (Source : access String;
449 Ptr : Positive := Start;
454 -- Skip to end of line
456 while Source (Ptr) /= ASCII.CR and then
457 Source (Ptr) /= ASCII.LF and then
465 if Source (Ptr) /= EOF then
475 -- Recognize CR/LF or LF/CR combination
477 if (Source (Ptr + 1) = ASCII.CR or Source (Ptr + 1) = ASCII.LF)
478 and then Source (Ptr) /= Source (Ptr + 1)
483 return (Len => Last + 1 - First, Str => Source (First .. Last));
490 function Is_Duplicated (U : SUnit_Num) return Boolean is
492 return U < SUnit_Num (Unit.Last)
494 Unit.Table (Sorted_Units.Table (U)).File_Name.all =
495 Unit.Table (Sorted_Units.Table (U + 1)).File_Name.all;
498 -----------------------
499 -- Locate_Executable --
500 -----------------------
502 function Locate_Executable
503 (Program_Name : String;
504 Look_For_Prefix : Boolean := True)
507 Current_Command : constant String := Command_Name;
508 End_Of_Prefix : Natural := Current_Command'First - 1;
509 Start_Of_Prefix : Positive := Current_Command'First;
510 Result : String_Access;
514 if Look_For_Prefix then
515 -- Find Start_Of_Prefix
517 for J in reverse Current_Command'Range loop
518 if Current_Command (J) = '/' or
519 Current_Command (J) = Directory_Separator or
520 Current_Command (J) = ':'
522 Start_Of_Prefix := J + 1;
527 -- Find End_Of_Prefix
529 End_Of_Prefix := Start_Of_Prefix - 1;
531 for J in reverse Start_Of_Prefix .. Current_Command'Last loop
532 if Current_Command (J) = '-' then
540 Command : constant String :=
541 Current_Command (Start_Of_Prefix .. End_Of_Prefix) &
544 Result := Locate_Exec_On_Path (Command);
546 if Result = null then
548 (Command & ": installation problem, executable not found");
553 end Locate_Executable;
559 procedure Parse_EOL (Source : access String; Ptr : in out Positive) is
561 -- Skip to end of line
563 while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF
564 and then Source (Ptr) /= EOF
569 if Source (Ptr) /= EOF then
570 Ptr := Ptr + 1; -- skip CR or LF
573 -- Skip past CR/LF or LF/CR combination
575 if (Source (Ptr) = ASCII.CR or Source (Ptr) = ASCII.LF)
576 and then Source (Ptr) /= Source (Ptr - 1)
586 function Parse_File (Num : File_Num) return Boolean is
587 Chop_Name : constant String_Access := File.Table (Num).Name;
588 Offset_Name : Temp_File_Name;
589 Offset_FD : File_Descriptor;
590 Save_Stdout : File_Descriptor := dup (Standout);
591 Buffer : String_Access;
596 -- Display copy of GNAT command if verbose mode
601 for J in 1 .. Gnat_Args'Length loop
603 Put (Gnat_Args (J).all);
607 Put_Line (Chop_Name.all);
610 -- Create temporary file
612 Create_Temp_File (Offset_FD, Offset_Name);
614 if Offset_FD = Invalid_FD then
615 Error_Msg ("gnatchop: cannot create temporary file");
620 -- Redirect Stdout to this temporary file in the Unix way
622 if dup2 (Offset_FD, Standout) = Invalid_FD then
623 Error_Msg ("gnatchop: cannot redirect stdout to temporary file");
629 -- Call Gnat on the source filename argument with special options
630 -- to generate offset information. If this special compilation completes
631 -- successfully then we can do the actual gnatchop operation.
633 Spawn (Gnat_Cmd.all, Gnat_Args.all & Chop_Name, Success);
636 Error_Msg (Chop_Name.all & ": parse errors detected");
637 Error_Msg (Chop_Name.all & ": chop may not be successful");
642 if dup2 (Save_Stdout, Standout) = Invalid_FD then
643 Error_Msg ("gnatchop: cannot restore stdout");
646 -- Reopen the file to start reading from the beginning
650 Offset_FD := Open_Read (Offset_Name'Address, Binary);
652 if Offset_FD = Invalid_FD then
653 Error_Msg ("gnatchop: cannot access offset info");
657 Read_File (Offset_FD, Buffer, Success);
660 Error_Msg ("gnatchop: error reading offset info");
664 Parse_Offset_Info (Num, Buffer);
667 -- Close and delete temporary file
670 Delete_File (Offset_Name'Address, Success);
675 when Failure | Terminate_Program =>
677 Delete_File (Offset_Name'Address, Success);
682 -----------------------
683 -- Parse_Offset_Info --
684 -----------------------
686 procedure Parse_Offset_Info
687 (Chop_File : File_Num;
688 Source : access String)
690 First_Unit : Unit_Num := Unit.Last + 1;
691 Bufferg : String_Access := null;
692 Parse_Ptr : File_Offset := Source'First;
693 Token_Ptr : File_Offset;
696 function Match (Literal : String) return Boolean;
697 -- Checks if given string appears at the current Token_Ptr location
698 -- and if so, bumps Parse_Ptr past the token and returns True. If
699 -- the string is not present, sets Parse_Ptr to Token_Ptr and
706 function Match (Literal : String) return Boolean is
708 Parse_Token (Source, Parse_Ptr, Token_Ptr);
710 if Source'Last + 1 - Token_Ptr < Literal'Length
712 Source (Token_Ptr .. Token_Ptr + Literal'Length - 1) /= Literal
714 Parse_Ptr := Token_Ptr;
718 Parse_Ptr := Token_Ptr + Literal'Length;
722 -- Start of processing for Parse_Offset_Info
726 -- Set default values, should get changed for all
727 -- units/pragmas except for the last
729 Info.Chop_File := Chop_File;
732 -- Parse the current line of offset information into Info
733 -- and exit the loop if there are any errors or on EOF.
735 -- First case, parse a line in the following format:
737 -- Unit x (spec) line 7, file offset 142, [SR, ]file name x.ads
739 -- Note that the unit name can be an operator name in quotes.
740 -- This is of course illegal, but both GNAT and gnatchop handle
741 -- the case so that this error does not intefere with chopping.
743 -- The SR ir present indicates that a source reference pragma
744 -- was processed as part of this unit (and that therefore no
745 -- Source_Reference pragma should be generated.
747 if Match ("Unit") then
748 Parse_Token (Source, Parse_Ptr, Token_Ptr);
750 if Match ("(body)") then
751 Info.Kind := Unit_Body;
752 elsif Match ("(spec)") then
753 Info.Kind := Unit_Spec;
758 exit when not Match ("line");
759 Parse_Token (Source, Parse_Ptr, Token_Ptr);
760 Info.Start_Line := Line_Num'Value
761 (Source (Token_Ptr .. Parse_Ptr - 1));
763 exit when not Match ("file offset");
764 Parse_Token (Source, Parse_Ptr, Token_Ptr);
765 Info.Offset := File_Offset'Value
766 (Source (Token_Ptr .. Parse_Ptr - 1));
768 Info.SR_Present := Match ("SR, ");
770 exit when not Match ("file name");
771 Parse_Token (Source, Parse_Ptr, Token_Ptr);
772 Info.File_Name := new String'
773 (Directory.all & Source (Token_Ptr .. Parse_Ptr - 1));
774 Parse_EOL (Source, Parse_Ptr);
776 -- Second case, parse a line of the following form
778 -- Configuration pragmas at line 10, file offset 223
780 elsif Match ("Configuration pragmas at") then
781 Info.Kind := Config_Pragmas;
782 Info.File_Name := Config_File_Name;
784 exit when not Match ("line");
785 Parse_Token (Source, Parse_Ptr, Token_Ptr);
786 Info.Start_Line := Line_Num'Value
787 (Source (Token_Ptr .. Parse_Ptr - 1));
789 exit when not Match ("file offset");
790 Parse_Token (Source, Parse_Ptr, Token_Ptr);
791 Info.Offset := File_Offset'Value
792 (Source (Token_Ptr .. Parse_Ptr - 1));
794 Parse_EOL (Source, Parse_Ptr);
796 -- Third case, parse a line of the following form
798 -- Source_Reference pragma for file "filename"
800 -- This appears at the start of the file only, and indicates
801 -- the name to be used on any generated Source_Reference pragmas.
803 elsif Match ("Source_Reference pragma for file ") then
804 Parse_Token (Source, Parse_Ptr, Token_Ptr);
805 File.Table (Chop_File).SR_Name :=
806 new String'(Source (Token_Ptr + 1 .. Parse_Ptr - 2));
807 Parse_EOL (Source, Parse_Ptr);
810 -- Unrecognized keyword or end of file
816 -- Store the data in the Info record in the Unit.Table
819 Unit.Table (Unit.Last) := Info;
821 -- If this is not the first unit from the file, calculate
822 -- the length of the previous unit as difference of the offsets
824 if Unit.Last > First_Unit then
825 Unit.Table (Unit.Last - 1).Length :=
826 Info.Offset - Unit.Table (Unit.Last - 1).Offset;
829 -- If not in compilation mode combine current unit with any
830 -- preceding configuration pragmas.
832 if not Compilation_Mode
833 and then Unit.Last > First_Unit
834 and then Unit.Table (Unit.Last - 1).Kind = Config_Pragmas
836 Info.Start_Line := Unit.Table (Unit.Last - 1).Start_Line;
837 Info.Offset := Unit.Table (Unit.Last - 1).Offset;
839 -- Delete the configuration pragma entry
841 Unit.Table (Unit.Last - 1) := Info;
845 -- If in compilation mode, and previous entry is the initial
846 -- entry for the file and is for configuration pragmas, then
847 -- they are to be appended to every unit in the file.
850 and then Unit.Last = First_Unit + 1
851 and then Unit.Table (First_Unit).Kind = Config_Pragmas
855 (Unit.Table (Unit.Last - 1).Chop_File, First_Unit);
856 Unit.Table (Unit.Last - 1) := Info;
860 Unit.Table (Unit.Last).Bufferg := Bufferg;
862 -- If in compilation mode, and this is not the first item,
863 -- combine configuration pragmas with previous unit, which
864 -- will cause an error message to be generated when the unit
868 and then Unit.Last > First_Unit
869 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
879 -- Find out if the loop was exited prematurely because of
880 -- an error or if the EOF marker was found.
882 if Source (Parse_Ptr) /= EOF then
884 (File.Table (Chop_File).Name.all & ": error parsing offset info");
888 -- Handle case of a chop file consisting only of config pragmas
890 if Unit.Last = First_Unit
891 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
893 -- In compilation mode, we append such a file to gnat.adc
895 if Compilation_Mode then
896 Write_Config_File (Unit.Table (Unit.Last).Chop_File, First_Unit);
899 -- In default (non-compilation) mode, this is invalid
903 (File.Table (Chop_File).Name.all &
904 ": no units found (only pragmas)");
909 -- Handle case of a chop file ending with config pragmas. This can
910 -- happen only in default non-compilation mode, since in compilation
911 -- mode such configuration pragmas are part of the preceding unit.
912 -- We simply concatenate such pragmas to the previous file which
913 -- will cause a compilation error, which is appropriate.
915 if Unit.Last > First_Unit
916 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
920 end Parse_Offset_Info;
926 procedure Parse_Token
927 (Source : access String;
928 Ptr : in out Positive;
929 Token_Ptr : out Positive)
931 In_Quotes : Boolean := False;
936 while Source (Ptr) = ' ' or Source (Ptr) = ',' loop
944 while (In_Quotes or else not (Source (Ptr) = ' ' or Source (Ptr) = ','))
945 and then Source (Ptr) >= ' '
947 if Source (Ptr) = '"' then
948 In_Quotes := not In_Quotes;
960 (FD : File_Descriptor;
961 Contents : out String_Access;
962 Success : out Boolean)
964 Length : constant File_Offset := File_Offset (File_Length (FD));
965 -- Include room for EOF char
966 Buffer : constant String_Access := new String (1 .. Length + 1);
969 Read_Ptr : File_Offset := 1;
974 This_Read := Read (FD,
975 A => Buffer (Read_Ptr)'Address,
976 N => Length + 1 - Read_Ptr);
977 Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0);
978 exit when This_Read <= 0;
981 Buffer (Read_Ptr) := EOF;
982 Contents := new String (1 .. Read_Ptr);
983 Contents.all := Buffer (1 .. Read_Ptr);
985 -- Things aren't simple on VMS due to the plethora of file types
986 -- and organizations. It seems clear that there shouldn't be more
987 -- bytes read than are contained in the file though.
989 if Hostparm.OpenVMS then
990 Success := Read_Ptr <= Length + 1;
992 Success := Read_Ptr = Length + 1;
996 ----------------------------
997 -- Report_Duplicate_Units --
998 ----------------------------
1000 function Report_Duplicate_Units return Boolean is
1004 Duplicates : Boolean := False;
1008 while US < SUnit_Num (Unit.Last) loop
1009 U := Sorted_Units.Table (US);
1011 if Is_Duplicated (US) then
1014 -- Move to last two versions of duplicated file to make it clearer
1015 -- to understand which file is retained in case of overwriting.
1017 while US + 1 < SUnit_Num (Unit.Last) loop
1018 exit when not Is_Duplicated (US + 1);
1022 U := Sorted_Units.Table (US);
1024 if Overwrite_Files then
1025 Warning_Msg (Unit.Table (U).File_Name.all
1026 & " is duplicated (all but last will be skipped)");
1028 elsif Unit.Table (U).Chop_File =
1029 Unit.Table (Sorted_Units.Table (US + 1)).Chop_File
1031 Error_Msg (Unit.Table (U).File_Name.all
1032 & " is duplicated in "
1033 & File.Table (Unit.Table (U).Chop_File).Name.all);
1036 Error_Msg (Unit.Table (U).File_Name.all
1038 & File.Table (Unit.Table (U).Chop_File).Name.all
1039 & " is duplicated in "
1042 (Sorted_Units.Table (US + 1)).Chop_File).Name.all);
1049 if Duplicates and not Overwrite_Files then
1050 if Hostparm.OpenVMS then
1052 ("use /OVERWRITE to overwrite files and keep last version");
1054 Put_Line ("use -w to overwrite files and keep last version");
1059 end Report_Duplicate_Units;
1061 --------------------
1062 -- Scan_Arguments --
1063 --------------------
1065 function Scan_Arguments return Boolean is
1066 Kset : Boolean := False;
1067 -- Set true if -k switch found
1070 Initialize_Option_Scan;
1072 -- Scan options first
1075 case Getopt ("c gnat? h k? p q r v w x -GCC=!") is
1080 Gcc := new String'(Parameter);
1084 Compilation_Mode := True;
1088 new Argument_List'(Gnat_Args.all &
1089 new String'("-gnat" & Parameter));
1093 raise Terminate_Program;
1097 Param : String_Access := new String'(Parameter);
1100 if Param.all /= "" then
1101 for J in Param'Range loop
1102 if Param (J) not in '0' .. '9' then
1103 if Hostparm.OpenVMS then
1104 Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn" &
1105 " requires numeric parameter");
1107 Error_Msg ("-k# requires numeric parameter");
1114 if Hostparm.OpenVMS then
1115 Param := new String'("39");
1117 Param := new String'("8");
1122 new Argument_List'(Gnat_Args.all &
1123 new String'("-gnatk" & Param.all));
1128 Preserve_Mode := True;
1134 Source_References := True;
1137 Verbose_Mode := True;
1138 Put_Line (Standard_Error, Cwrite);
1141 Overwrite_Files := True;
1144 Exit_On_Error := True;
1151 if not Kset and then Maximum_File_Name_Length > 0 then
1153 -- If this system has restricted filename lengths, tell gnat1
1154 -- about them, removing the leading blank from the image string.
1157 new Argument_List'(Gnat_Args.all
1158 & new String'("-gnatk"
1159 & Maximum_File_Name_Length_String
1160 (Maximum_File_Name_Length_String'First + 1
1161 .. Maximum_File_Name_Length_String'Last)));
1168 S : constant String := Get_Argument (Do_Expansion => True);
1172 File.Increment_Last;
1173 File.Table (File.Last).Name := new String'(S);
1174 File.Table (File.Last).SR_Name := null;
1178 -- Case of more than one file where last file is a directory
1181 and then Is_Directory (File.Table (File.Last).Name.all)
1183 Directory := File.Table (File.Last).Name;
1184 File.Decrement_Last;
1186 -- Make sure Directory is terminated with a directory separator,
1187 -- so we can generate the output by just appending a filename.
1189 if Directory (Directory'Last) /= Directory_Separator
1190 and then Directory (Directory'Last) /= '/'
1192 Directory := new String'(Directory.all & Directory_Separator);
1195 -- At least one filename must be given
1197 elsif File.Last = 0 then
1201 -- No directory given, set directory to null, so that we can just
1202 -- concatenate the directory name to the file name unconditionally.
1205 Directory := new String'("");
1208 -- Finally check all filename arguments
1210 for File_Num in 1 .. File.Last loop
1212 F : constant String := File.Table (File_Num).Name.all;
1216 if Is_Directory (F) then
1217 Error_Msg (F & " is a directory, cannot be chopped");
1220 elsif not Is_Regular_File (F) then
1221 Error_Msg (F & " not found");
1230 when Invalid_Switch =>
1231 Error_Msg ("invalid switch " & Full_Switch);
1234 when Invalid_Parameter =>
1235 if Hostparm.OpenVMS then
1236 Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn qualifier" &
1237 " requires numeric parameter");
1239 Error_Msg ("-k switch requires numeric parameter");
1250 procedure Sort_Units is
1252 procedure Move (From : Natural; To : Natural);
1253 -- Procedure used to sort the unit list
1254 -- Unit.Table (To) := Unit_List (From); used by sort
1256 function Lt (Left, Right : Natural) return Boolean;
1257 -- Compares Left and Right units based on file name (first),
1258 -- Chop_File (second) and Offset (third). This ordering is
1259 -- important to keep the last version in case of duplicate files.
1261 package Unit_Sort is new GNAT.Heap_Sort_G (Move, Lt);
1262 -- Used for sorting on filename to detect duplicates
1268 function Lt (Left, Right : Natural) return Boolean is
1269 L : Unit_Info renames
1270 Unit.Table (Sorted_Units.Table (SUnit_Num (Left)));
1272 R : Unit_Info renames
1273 Unit.Table (Sorted_Units.Table (SUnit_Num (Right)));
1276 return L.File_Name.all < R.File_Name.all
1277 or else (L.File_Name.all = R.File_Name.all
1278 and then (L.Chop_File < R.Chop_File
1279 or else (L.Chop_File = R.Chop_File
1280 and then L.Offset < R.Offset)));
1287 procedure Move (From : Natural; To : Natural) is
1289 Sorted_Units.Table (SUnit_Num (To)) :=
1290 Sorted_Units.Table (SUnit_Num (From));
1293 -- Start of processing for Sort_Units
1296 Sorted_Units.Set_Last (SUnit_Num (Unit.Last));
1298 for J in 1 .. Unit.Last loop
1299 Sorted_Units.Table (SUnit_Num (J)) := J;
1302 -- Sort Unit.Table, using Sorted_Units.Table (0) as scratch
1304 Unit_Sort.Sort (Natural (Unit.Last));
1306 -- Set the Sorted_Index fields in the unit tables.
1308 for J in 1 .. SUnit_Num (Unit.Last) loop
1309 Unit.Table (Sorted_Units.Table (J)).Sorted_Index := J;
1320 ("Usage: gnatchop [-c] [-h] [-k#] " &
1321 "[-r] [-p] [-q] [-v] [-w] [-x] [--GCC=xx] file [file ...] [dir]");
1325 (" -c compilation mode, configuration pragmas " &
1329 (" -gnatxxx passes the -gnatxxx switch to gnat parser");
1332 (" -h help: output this usage information");
1335 (" -k# krunch file names of generated files to " &
1336 "no more than # characters");
1339 (" -k krunch file names of generated files to " &
1340 "no more than 8 characters");
1343 (" -p preserve time stamp, output files will " &
1344 "have same stamp as input");
1347 (" -q quiet mode, no output of generated file " &
1351 (" -r generate Source_Reference pragmas refer" &
1352 "encing original source file");
1355 (" -v verbose mode, output version and generat" &
1359 (" -w overwrite existing filenames");
1362 (" -x exit on error");
1365 (" --GCC=xx specify the path of the gnat parser to be used");
1369 (" file... list of source files to be chopped");
1372 (" dir directory location for split files (defa" &
1373 "ult = current directory)");
1380 procedure Warning_Msg (Message : String) is
1382 Warning_Count := Warning_Count + 1;
1383 Put_Line (Standard_Error, "warning: " & Message);
1386 -------------------------
1387 -- Write_Chopped_Files --
1388 -------------------------
1390 function Write_Chopped_Files (Input : File_Num) return Boolean is
1391 Name : aliased constant String :=
1392 File.Table (Input).Name.all & ASCII.Nul;
1393 FD : File_Descriptor;
1394 Buffer : String_Access;
1399 FD := Open_Read (Name'Address, Binary);
1400 TS_Time := File_Time_Stamp (FD);
1402 if FD = Invalid_FD then
1403 Error_Msg ("cannot open " & File.Table (Input).Name.all);
1407 Read_File (FD, Buffer, Success);
1410 Error_Msg ("cannot read " & File.Table (Input).Name.all);
1415 if not Quiet_Mode then
1416 Put_Line ("splitting " & File.Table (Input).Name.all & " into:");
1419 -- Only chop those units that come from this file
1421 for Num in 1 .. Unit.Last loop
1422 if Unit.Table (Num).Chop_File = Input then
1423 Write_Unit (Buffer, Num, TS_Time, Success);
1424 exit when not Success;
1431 end Write_Chopped_Files;
1433 -----------------------
1434 -- Write_Config_File --
1435 -----------------------
1437 procedure Write_Config_File (Input : File_Num; U : Unit_Num) is
1438 FD : File_Descriptor;
1439 Name : aliased constant String := "gnat.adc" & ASCII.NUL;
1440 Buffer : String_Access;
1443 Buffera : String_Access;
1447 Write_gnat_adc := True;
1448 FD := Open_Read_Write (Name'Address, Binary);
1450 if FD = Invalid_FD then
1451 FD := Create_File (Name'Address, Binary);
1454 if not Quiet_Mode then
1455 Put_Line ("writing configuration pragmas from " &
1456 File.Table (Input).Name.all & " to gnat.adc");
1462 if not Quiet_Mode then
1464 ("appending configuration pragmas from " &
1465 File.Table (Input).Name.all & " to gnat.adc");
1469 Success := FD /= Invalid_FD;
1472 Error_Msg ("cannot create gnat.adc");
1476 -- In append mode, acquire existing gnat.adc file
1479 Read_File (FD, Buffera, Success);
1482 Error_Msg ("cannot read gnat.adc");
1486 -- Find location of EOF byte if any to exclude from append
1489 while Bufferl <= Buffera'Last
1490 and then Buffera (Bufferl) /= EOF
1492 Bufferl := Bufferl + 1;
1495 Bufferl := Bufferl - 1;
1498 -- Write existing gnat.adc to new gnat.adc file
1500 FD := Create_File (Name'Address, Binary);
1501 Success := Write (FD, Buffera (1)'Address, Bufferl) = Bufferl;
1504 Error_Msg ("error writing gnat.adc");
1509 Buffer := Get_Config_Pragmas (Input, U);
1511 if Buffer /= null then
1512 Success := Write (FD, Buffer.all'Address, Buffer'Length) =
1516 Error_Msg ("disk full writing gnat.adc");
1522 end Write_Config_File;
1524 -----------------------------------
1525 -- Write_Source_Reference_Pragma --
1526 -----------------------------------
1528 procedure Write_Source_Reference_Pragma
1531 FD : File_Descriptor;
1533 Success : in out Boolean)
1535 FTE : File_Entry renames File.Table (Info.Chop_File);
1536 Nam : String_Access;
1539 if Success and Source_References and not Info.SR_Present then
1540 if FTE.SR_Name /= null then
1547 Reference : aliased String :=
1548 "pragma Source_Reference (000000, """
1549 & Nam.all & """);" & EOL.Str;
1551 Pos : Positive := Reference'First;
1552 Lin : Line_Num := Line;
1555 while Reference (Pos + 1) /= ',' loop
1559 while Reference (Pos) = '0' loop
1560 Reference (Pos) := Character'Val
1561 (Character'Pos ('0') + Lin mod 10);
1566 -- Assume there are enough zeroes for any program length
1568 pragma Assert (Lin = 0);
1571 Write (FD, Reference'Address, Reference'Length)
1575 end Write_Source_Reference_Pragma;
1581 procedure Write_Unit
1582 (Source : access String;
1585 Success : out Boolean)
1587 Info : Unit_Info renames Unit.Table (Num);
1588 FD : File_Descriptor;
1589 Name : aliased constant String := Info.File_Name.all & ASCII.NUL;
1590 Length : File_Offset;
1591 EOL : constant EOL_String :=
1592 Get_EOL (Source, Source'First + Info.Offset);
1595 -- Skip duplicated files
1597 if Is_Duplicated (Info.Sorted_Index) then
1598 Put_Line (" " & Info.File_Name.all & " skipped");
1599 Success := Overwrite_Files;
1603 if Overwrite_Files then
1604 FD := Create_File (Name'Address, Binary);
1606 FD := Create_New_File (Name'Address, Binary);
1609 Success := FD /= Invalid_FD;
1612 Error_Msg ("cannot create " & Info.File_Name.all);
1616 -- A length of 0 indicates that the rest of the file belongs to
1617 -- this unit. The actual length must be calculated now. Take into
1618 -- account that the last character (EOF) must not be written.
1620 if Info.Length = 0 then
1621 Length := Source'Last - (Source'First + Info.Offset);
1623 Length := Info.Length;
1626 -- Prepend configuration pragmas if necessary
1628 if Success and then Info.Bufferg /= null then
1629 Write_Source_Reference_Pragma (Info, 1, FD, EOL, Success);
1631 Write (FD, Info.Bufferg.all'Address, Info.Bufferg'Length) =
1632 Info.Bufferg'Length;
1635 Write_Source_Reference_Pragma (Info, Info.Start_Line, FD, EOL, Success);
1638 Success := Write (FD, Source (Source'First + Info.Offset)'Address,
1643 Error_Msg ("disk full writing " & Info.File_Name.all);
1647 if not Quiet_Mode then
1648 Put_Line (" " & Info.File_Name.all);
1653 if Preserve_Mode then
1654 File_Time_Stamp (Name'Address, TS_Time);
1659 -- Start of processing for gnatchop
1662 -- Process command line options and initialize global variables
1664 if not Scan_Arguments then
1665 Set_Exit_Status (Failure);
1669 -- Check presence of required executables
1671 Gnat_Cmd := Locate_Executable (Gcc.all, not Gcc_Set);
1673 if Gnat_Cmd = null then
1674 goto No_Files_Written;
1677 -- First parse all files and read offset information
1679 for Num in 1 .. File.Last loop
1680 if not Parse_File (Num) then
1681 goto No_Files_Written;
1685 -- Check if any units have been found (assumes non-empty Unit.Table)
1687 if Unit.Last = 0 then
1688 if not Write_gnat_adc then
1689 Error_Msg ("no compilation units found");
1692 goto No_Files_Written;
1697 -- Check if any duplicate files would be created. If so, emit
1698 -- a warning if Overwrite_Files is true, otherwise generate an error.
1700 if Report_Duplicate_Units and then not Overwrite_Files then
1701 goto No_Files_Written;
1704 -- Check if any files exist, if so do not write anything
1705 -- Because all files have been parsed and checked already,
1706 -- there won't be any duplicates
1708 if not Overwrite_Files and then Files_Exist then
1709 goto No_Files_Written;
1712 -- After this point, all source files are read in succession
1713 -- and chopped into their destination files.
1715 -- As the Source_File_Name pragmas are handled as logical file 0,
1718 for F in 1 .. File.Last loop
1719 if not Write_Chopped_Files (F) then
1720 Set_Exit_Status (Failure);
1725 if Warning_Count > 0 then
1727 Warnings_Msg : String := Warning_Count'Img & " warning(s)";
1729 Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last));
1735 <<No_Files_Written>>
1737 -- Special error exit for all situations where no files have
1740 if not Write_gnat_adc then
1741 Error_Msg ("no source files written");
1747 when Terminate_Program =>