1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2003 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 was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Ada
.Command_Line
; use Ada
.Command_Line
;
28 with Ada
.Text_IO
; use Ada
.Text_IO
;
30 with GNAT
.Command_Line
; use GNAT
.Command_Line
;
31 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
32 with GNAT
.Heap_Sort_G
;
40 Terminate_Program
: exception;
41 -- Used to terminate execution immediately
43 Config_File_Name
: constant String_Access
:= new String'("gnat.adc");
44 -- The name of the file holding the GNAT configuration pragmas
46 Gcc : String_Access := new String'("gcc");
47 -- May be modified by switch --GCC=
49 Gcc_Set
: Boolean := False;
50 -- True if a switch --GCC= is used
52 Gnat_Cmd
: String_Access
;
53 -- Command to execute the GNAT compiler
55 Gnat_Args
: Argument_List_Access
:=
60 new String'("-gnats"),
61 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; 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)
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; Warning
: Boolean := False) is
341 Put_Line
(Standard_Error
, Message
);
344 Set_Exit_Status
(Failure
);
346 if Exit_On_Error
then
347 raise Terminate_Program
;
352 ---------------------
353 -- File_Time_Stamp --
354 ---------------------
356 procedure File_Time_Stamp
(Name
: C_File_Name
; Time
: OS_Time
) is
357 procedure Set_File_Time
(Name
: C_File_Name
; Time
: OS_Time
);
358 pragma Import
(C
, Set_File_Time
, "__gnat_set_file_time_name");
361 Set_File_Time
(Name
, Time
);
368 function Files_Exist
return Boolean is
369 Exists
: Boolean := False;
372 for SNum
in 1 .. SUnit_Num
(Unit
.Last
) loop
374 -- Only check and report for the last instance of duplicated files
376 if not Is_Duplicated
(SNum
) then
378 Info
: Unit_Info
:= Unit
.Table
(Sorted_Units
.Table
(SNum
));
381 if Is_Writable_File
(Info
.File_Name
.all) then
382 if Hostparm
.OpenVMS
then
385 & " already exists, use /OVERWRITE to overwrite");
387 Error_Msg
(Info
.File_Name
.all
388 & " already exists, use -w to overwrite");
400 ------------------------
401 -- Get_Config_Pragmas --
402 ------------------------
404 function Get_Config_Pragmas
409 Info
: Unit_Info
renames Unit
.Table
(U
);
410 FD
: File_Descriptor
;
411 Name
: aliased constant String :=
412 File
.Table
(Input
).Name
.all & ASCII
.Nul
;
413 Length
: File_Offset
;
414 Buffer
: String_Access
;
416 Result
: String_Access
;
419 FD
:= Open_Read
(Name
'Address, Binary
);
421 if FD
= Invalid_FD
then
422 Error_Msg
("cannot open " & File
.Table
(Input
).Name
.all);
426 Read_File
(FD
, Buffer
, Success
);
428 -- A length of 0 indicates that the rest of the file belongs to
429 -- this unit. The actual length must be calculated now. Take into
430 -- account that the last character (EOF) must not be written.
432 if Info
.Length
= 0 then
433 Length
:= Buffer
'Last - (Buffer
'First + Info
.Offset
);
435 Length
:= Info
.Length
;
438 Result
:= new String'(Buffer (1 .. Length));
441 end Get_Config_Pragmas;
448 (Source : access String;
452 Ptr : Positive := Start;
457 -- Skip to end of line
459 while Source (Ptr) /= ASCII.CR and then
460 Source (Ptr) /= ASCII.LF and then
468 if Source (Ptr) /= EOF then
478 -- Recognize CR/LF or LF/CR combination
480 if (Source (Ptr + 1) = ASCII.CR or Source (Ptr + 1) = ASCII.LF)
481 and then Source (Ptr) /= Source (Ptr + 1)
486 return (Len => Last + 1 - First, Str => Source (First .. Last));
493 function Is_Duplicated (U : SUnit_Num) return Boolean is
495 return U < SUnit_Num (Unit.Last)
497 Unit.Table (Sorted_Units.Table (U)).File_Name.all =
498 Unit.Table (Sorted_Units.Table (U + 1)).File_Name.all;
501 -----------------------
502 -- Locate_Executable --
503 -----------------------
505 function Locate_Executable
506 (Program_Name : String;
507 Look_For_Prefix : Boolean := True)
510 Current_Command : constant String := Command_Name;
511 End_Of_Prefix : Natural := Current_Command'First - 1;
512 Start_Of_Prefix : Positive := Current_Command'First;
513 Result : String_Access;
517 if Look_For_Prefix then
518 -- Find Start_Of_Prefix
520 for J in reverse Current_Command'Range loop
521 if Current_Command (J) = '/' or
522 Current_Command (J) = Directory_Separator or
523 Current_Command (J) = ':'
525 Start_Of_Prefix := J + 1;
530 -- Find End_Of_Prefix
532 End_Of_Prefix := Start_Of_Prefix - 1;
534 for J in reverse Start_Of_Prefix .. Current_Command'Last loop
535 if Current_Command (J) = '-' then
543 Command : constant String :=
544 Current_Command (Start_Of_Prefix .. End_Of_Prefix) &
547 Result := Locate_Exec_On_Path (Command);
549 if Result = null then
551 (Command & ": installation problem, executable not found");
556 end Locate_Executable;
562 procedure Parse_EOL (Source : access String; Ptr : in out Positive) is
564 -- Skip to end of line
566 while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF
567 and then Source (Ptr) /= EOF
572 if Source (Ptr) /= EOF then
573 Ptr := Ptr + 1; -- skip CR or LF
576 -- Skip past CR/LF or LF/CR combination
578 if (Source (Ptr) = ASCII.CR or Source (Ptr) = ASCII.LF)
579 and then Source (Ptr) /= Source (Ptr - 1)
589 function Parse_File (Num : File_Num) return Boolean is
590 Chop_Name : constant String_Access := File.Table (Num).Name;
591 Offset_Name : Temp_File_Name;
592 Offset_FD : File_Descriptor;
593 Save_Stdout : File_Descriptor := dup (Standout);
594 Buffer : String_Access;
599 -- Display copy of GNAT command if verbose mode
604 for J in 1 .. Gnat_Args'Length loop
606 Put (Gnat_Args (J).all);
610 Put_Line (Chop_Name.all);
613 -- Create temporary file
615 Create_Temp_File (Offset_FD, Offset_Name);
617 if Offset_FD = Invalid_FD then
618 Error_Msg ("gnatchop: cannot create temporary file");
623 -- Redirect Stdout to this temporary file in the Unix way
625 if dup2 (Offset_FD, Standout) = Invalid_FD then
626 Error_Msg ("gnatchop: cannot redirect stdout to temporary file");
632 -- Call Gnat on the source filename argument with special options
633 -- to generate offset information. If this special compilation completes
634 -- successfully then we can do the actual gnatchop operation.
636 Spawn (Gnat_Cmd.all, Gnat_Args.all & Chop_Name, Success);
639 Error_Msg (Chop_Name.all & ": parse errors detected");
640 Error_Msg (Chop_Name.all & ": chop may not be successful");
645 if dup2 (Save_Stdout, Standout) = Invalid_FD then
646 Error_Msg ("gnatchop: cannot restore stdout");
649 -- Reopen the file to start reading from the beginning
653 Offset_FD := Open_Read (Offset_Name'Address, Binary);
655 if Offset_FD = Invalid_FD then
656 Error_Msg ("gnatchop: cannot access offset info");
660 Read_File (Offset_FD, Buffer, Success);
663 Error_Msg ("gnatchop: error reading offset info");
667 Parse_Offset_Info (Num, Buffer);
670 -- Close and delete temporary file
673 Delete_File (Offset_Name'Address, Success);
678 when Failure | Terminate_Program =>
680 Delete_File (Offset_Name'Address, Success);
685 -----------------------
686 -- Parse_Offset_Info --
687 -----------------------
689 procedure Parse_Offset_Info
690 (Chop_File : File_Num;
691 Source : access String)
693 First_Unit : Unit_Num := Unit.Last + 1;
694 Bufferg : String_Access := null;
695 Parse_Ptr : File_Offset := Source'First;
696 Token_Ptr : File_Offset;
699 function Match (Literal : String) return Boolean;
700 -- Checks if given string appears at the current Token_Ptr location
701 -- and if so, bumps Parse_Ptr past the token and returns True. If
702 -- the string is not present, sets Parse_Ptr to Token_Ptr and
709 function Match (Literal : String) return Boolean is
711 Parse_Token (Source, Parse_Ptr, Token_Ptr);
713 if Source'Last + 1 - Token_Ptr < Literal'Length
715 Source (Token_Ptr .. Token_Ptr + Literal'Length - 1) /= Literal
717 Parse_Ptr := Token_Ptr;
721 Parse_Ptr := Token_Ptr + Literal'Length;
725 -- Start of processing for Parse_Offset_Info
729 -- Set default values, should get changed for all
730 -- units/pragmas except for the last
732 Info.Chop_File := Chop_File;
735 -- Parse the current line of offset information into Info
736 -- and exit the loop if there are any errors or on EOF.
738 -- First case, parse a line in the following format:
740 -- Unit x (spec) line 7, file offset 142, [SR, ]file name x.ads
742 -- Note that the unit name can be an operator name in quotes.
743 -- This is of course illegal, but both GNAT and gnatchop handle
744 -- the case so that this error does not intefere with chopping.
746 -- The SR ir present indicates that a source reference pragma
747 -- was processed as part of this unit (and that therefore no
748 -- Source_Reference pragma should be generated.
750 if Match ("Unit") then
751 Parse_Token (Source, Parse_Ptr, Token_Ptr);
753 if Match ("(body)") then
754 Info.Kind := Unit_Body;
755 elsif Match ("(spec)") then
756 Info.Kind := Unit_Spec;
761 exit when not Match ("line");
762 Parse_Token (Source, Parse_Ptr, Token_Ptr);
763 Info.Start_Line := Line_Num'Value
764 (Source (Token_Ptr .. Parse_Ptr - 1));
766 exit when not Match ("file offset");
767 Parse_Token (Source, Parse_Ptr, Token_Ptr);
768 Info.Offset := File_Offset'Value
769 (Source (Token_Ptr .. Parse_Ptr - 1));
771 Info.SR_Present := Match ("SR, ");
773 exit when not Match ("file name");
774 Parse_Token (Source, Parse_Ptr, Token_Ptr);
775 Info.File_Name := new String'
776 (Directory
.all & Source
(Token_Ptr
.. Parse_Ptr
- 1));
777 Parse_EOL
(Source
, Parse_Ptr
);
779 -- Second case, parse a line of the following form
781 -- Configuration pragmas at line 10, file offset 223
783 elsif Match
("Configuration pragmas at") then
784 Info
.Kind
:= Config_Pragmas
;
785 Info
.File_Name
:= Config_File_Name
;
787 exit when not Match
("line");
788 Parse_Token
(Source
, Parse_Ptr
, Token_Ptr
);
789 Info
.Start_Line
:= Line_Num
'Value
790 (Source
(Token_Ptr
.. Parse_Ptr
- 1));
792 exit when not Match
("file offset");
793 Parse_Token
(Source
, Parse_Ptr
, Token_Ptr
);
794 Info
.Offset
:= File_Offset
'Value
795 (Source
(Token_Ptr
.. Parse_Ptr
- 1));
797 Parse_EOL
(Source
, Parse_Ptr
);
799 -- Third case, parse a line of the following form
801 -- Source_Reference pragma for file "filename"
803 -- This appears at the start of the file only, and indicates
804 -- the name to be used on any generated Source_Reference pragmas.
806 elsif Match
("Source_Reference pragma for file ") then
807 Parse_Token
(Source
, Parse_Ptr
, Token_Ptr
);
808 File
.Table
(Chop_File
).SR_Name
:=
809 new String'(Source (Token_Ptr + 1 .. Parse_Ptr - 2));
810 Parse_EOL (Source, Parse_Ptr);
813 -- Unrecognized keyword or end of file
819 -- Store the data in the Info record in the Unit.Table
822 Unit.Table (Unit.Last) := Info;
824 -- If this is not the first unit from the file, calculate
825 -- the length of the previous unit as difference of the offsets
827 if Unit.Last > First_Unit then
828 Unit.Table (Unit.Last - 1).Length :=
829 Info.Offset - Unit.Table (Unit.Last - 1).Offset;
832 -- If not in compilation mode combine current unit with any
833 -- preceding configuration pragmas.
835 if not Compilation_Mode
836 and then Unit.Last > First_Unit
837 and then Unit.Table (Unit.Last - 1).Kind = Config_Pragmas
839 Info.Start_Line := Unit.Table (Unit.Last - 1).Start_Line;
840 Info.Offset := Unit.Table (Unit.Last - 1).Offset;
842 -- Delete the configuration pragma entry
844 Unit.Table (Unit.Last - 1) := Info;
848 -- If in compilation mode, and previous entry is the initial
849 -- entry for the file and is for configuration pragmas, then
850 -- they are to be appended to every unit in the file.
853 and then Unit.Last = First_Unit + 1
854 and then Unit.Table (First_Unit).Kind = Config_Pragmas
858 (Unit.Table (Unit.Last - 1).Chop_File, First_Unit);
859 Unit.Table (Unit.Last - 1) := Info;
863 Unit.Table (Unit.Last).Bufferg := Bufferg;
865 -- If in compilation mode, and this is not the first item,
866 -- combine configuration pragmas with previous unit, which
867 -- will cause an error message to be generated when the unit
871 and then Unit.Last > First_Unit
872 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
882 -- Find out if the loop was exited prematurely because of
883 -- an error or if the EOF marker was found.
885 if Source (Parse_Ptr) /= EOF then
887 (File.Table (Chop_File).Name.all & ": error parsing offset info");
891 -- Handle case of a chop file consisting only of config pragmas
893 if Unit.Last = First_Unit
894 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
896 -- In compilation mode, we append such a file to gnat.adc
898 if Compilation_Mode then
899 Write_Config_File (Unit.Table (Unit.Last).Chop_File, First_Unit);
902 -- In default (non-compilation) mode, this is invalid
906 (File.Table (Chop_File).Name.all &
907 ": no units found (only pragmas)");
912 -- Handle case of a chop file ending with config pragmas. This can
913 -- happen only in default non-compilation mode, since in compilation
914 -- mode such configuration pragmas are part of the preceding unit.
915 -- We simply concatenate such pragmas to the previous file which
916 -- will cause a compilation error, which is appropriate.
918 if Unit.Last > First_Unit
919 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
923 end Parse_Offset_Info;
929 procedure Parse_Token
930 (Source : access String;
931 Ptr : in out Positive;
932 Token_Ptr : out Positive)
934 In_Quotes : Boolean := False;
939 while Source (Ptr) = ' ' or Source (Ptr) = ',' loop
947 while (In_Quotes or else not (Source (Ptr) = ' ' or Source (Ptr) = ','))
948 and then Source (Ptr) >= ' '
950 if Source (Ptr) = '"' then
951 In_Quotes := not In_Quotes;
963 (FD : File_Descriptor;
964 Contents : out String_Access;
965 Success : out Boolean)
967 Length : constant File_Offset := File_Offset (File_Length (FD));
968 -- Include room for EOF char
969 Buffer : constant String_Access := new String (1 .. Length + 1);
972 Read_Ptr : File_Offset := 1;
977 This_Read := Read (FD,
978 A => Buffer (Read_Ptr)'Address,
979 N => Length + 1 - Read_Ptr);
980 Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0);
981 exit when This_Read <= 0;
984 Buffer (Read_Ptr) := EOF;
985 Contents := new String (1 .. Read_Ptr);
986 Contents.all := Buffer (1 .. Read_Ptr);
988 -- Things aren't simple on VMS due to the plethora of file types
989 -- and organizations. It seems clear that there shouldn't be more
990 -- bytes read than are contained in the file though.
992 if Hostparm.OpenVMS then
993 Success := Read_Ptr <= Length + 1;
995 Success := Read_Ptr = Length + 1;
999 ----------------------------
1000 -- Report_Duplicate_Units --
1001 ----------------------------
1003 function Report_Duplicate_Units return Boolean is
1007 Duplicates : Boolean := False;
1011 while US < SUnit_Num (Unit.Last) loop
1012 U := Sorted_Units.Table (US);
1014 if Is_Duplicated (US) then
1017 -- Move to last two versions of duplicated file to make it clearer
1018 -- to understand which file is retained in case of overwriting.
1020 while US + 1 < SUnit_Num (Unit.Last) loop
1021 exit when not Is_Duplicated (US + 1);
1025 U := Sorted_Units.Table (US);
1027 if Overwrite_Files then
1028 Warning_Msg (Unit.Table (U).File_Name.all
1029 & " is duplicated
(all but last will be skipped
)");
1031 elsif Unit.Table (U).Chop_File =
1032 Unit.Table (Sorted_Units.Table (US + 1)).Chop_File
1034 Error_Msg (Unit.Table (U).File_Name.all
1035 & " is duplicated
in "
1036 & File.Table (Unit.Table (U).Chop_File).Name.all);
1039 Error_Msg (Unit.Table (U).File_Name.all
1041 & File.Table (Unit.Table (U).Chop_File).Name.all
1042 & " is duplicated
in "
1045 (Sorted_Units.Table (US + 1)).Chop_File).Name.all);
1052 if Duplicates and not Overwrite_Files then
1053 if Hostparm.OpenVMS then
1055 ("use /OVERWRITE to overwrite files
and keep last version
");
1057 Put_Line ("use -w to overwrite files
and keep last version
");
1062 end Report_Duplicate_Units;
1064 --------------------
1065 -- Scan_Arguments --
1066 --------------------
1068 function Scan_Arguments return Boolean is
1069 Kset : Boolean := False;
1070 -- Set true if -k switch found
1073 Initialize_Option_Scan;
1075 -- Scan options first
1078 case Getopt ("c gnat? h k? p q r v w x
-GCC
=!") is
1083 Gcc := new String'(Parameter);
1087 Compilation_Mode := True;
1091 new Argument_List'(Gnat_Args.all &
1092 new String'("-gnat
" & Parameter));
1096 raise Terminate_Program;
1100 Param : String_Access := new String'(Parameter);
1103 if Param.all /= "" then
1104 for J in Param'Range loop
1105 if Param (J) not in '0' .. '9' then
1106 if Hostparm.OpenVMS then
1107 Error_Msg ("/FILE_NAME_MAX_LENGTH
=nnn
" &
1108 " requires numeric parameter
");
1110 Error_Msg ("-k# requires numeric parameter
");
1118 if Hostparm.OpenVMS then
1119 Param := new String'("39");
1121 Param := new String'("8");
1126 new Argument_List'(Gnat_Args.all &
1127 new String'("-gnatk
" & Param.all));
1132 Preserve_Mode := True;
1138 Source_References := True;
1141 Verbose_Mode := True;
1143 -- Why is following written to standard error. Most other
1144 -- tools write to standard output ???
1146 Put (Standard_Error, "GNATCHOP
");
1147 Put (Standard_Error, Gnatvsn.Gnat_Version_String);
1150 " Copyright
1998-2000, Ada Core Technologies Inc
.");
1153 Overwrite_Files := True;
1156 Exit_On_Error := True;
1163 if not Kset and then Maximum_File_Name_Length > 0 then
1165 -- If this system has restricted filename lengths, tell gnat1
1166 -- about them, removing the leading blank from the image string.
1169 new Argument_List'(Gnat_Args.all
1170 & new String'("-gnatk
"
1171 & Maximum_File_Name_Length_String
1172 (Maximum_File_Name_Length_String'First + 1
1173 .. Maximum_File_Name_Length_String'Last)));
1180 S : constant String := Get_Argument (Do_Expansion => True);
1184 File.Increment_Last;
1185 File.Table (File.Last).Name := new String'(S);
1186 File.Table (File.Last).SR_Name := null;
1190 -- Case of more than one file where last file is a directory
1193 and then Is_Directory (File.Table (File.Last).Name.all)
1195 Directory := File.Table (File.Last).Name;
1196 File.Decrement_Last;
1198 -- Make sure Directory is terminated with a directory separator,
1199 -- so we can generate the output by just appending a filename.
1201 if Directory (Directory'Last) /= Directory_Separator
1202 and then Directory (Directory'Last) /= '/'
1204 Directory := new String'(Directory.all & Directory_Separator);
1207 -- At least one filename must be given
1209 elsif File.Last = 0 then
1213 -- No directory given, set directory to null, so that we can just
1214 -- concatenate the directory name to the file name unconditionally.
1217 Directory := new String'("");
1220 -- Finally check all filename arguments
1222 for File_Num in 1 .. File.Last loop
1224 F : constant String := File.Table (File_Num).Name.all;
1228 if Is_Directory (F) then
1229 Error_Msg (F & " is a directory
, cannot be chopped
");
1232 elsif not Is_Regular_File (F) then
1233 Error_Msg (F & " not found
");
1242 when Invalid_Switch =>
1243 Error_Msg ("invalid switch
" & Full_Switch);
1246 when Invalid_Parameter =>
1247 if Hostparm.OpenVMS then
1248 Error_Msg ("/FILE_NAME_MAX_LENGTH
=nnn qualifier
" &
1249 " requires numeric parameter
");
1251 Error_Msg ("-k switch requires numeric parameter
");
1262 procedure Sort_Units is
1264 procedure Move (From : Natural; To : Natural);
1265 -- Procedure used to sort the unit list
1266 -- Unit.Table (To) := Unit_List (From); used by sort
1268 function Lt (Left, Right : Natural) return Boolean;
1269 -- Compares Left and Right units based on file name (first),
1270 -- Chop_File (second) and Offset (third). This ordering is
1271 -- important to keep the last version in case of duplicate files.
1273 package Unit_Sort is new GNAT.Heap_Sort_G (Move, Lt);
1274 -- Used for sorting on filename to detect duplicates
1280 function Lt (Left, Right : Natural) return Boolean is
1281 L : Unit_Info renames
1282 Unit.Table (Sorted_Units.Table (SUnit_Num (Left)));
1284 R : Unit_Info renames
1285 Unit.Table (Sorted_Units.Table (SUnit_Num (Right)));
1288 return L.File_Name.all < R.File_Name.all
1289 or else (L.File_Name.all = R.File_Name.all
1290 and then (L.Chop_File < R.Chop_File
1291 or else (L.Chop_File = R.Chop_File
1292 and then L.Offset < R.Offset)));
1299 procedure Move (From : Natural; To : Natural) is
1301 Sorted_Units.Table (SUnit_Num (To)) :=
1302 Sorted_Units.Table (SUnit_Num (From));
1305 -- Start of processing for Sort_Units
1308 Sorted_Units.Set_Last (SUnit_Num (Unit.Last));
1310 for J in 1 .. Unit.Last loop
1311 Sorted_Units.Table (SUnit_Num (J)) := J;
1314 -- Sort Unit.Table, using Sorted_Units.Table (0) as scratch
1316 Unit_Sort.Sort (Natural (Unit.Last));
1318 -- Set the Sorted_Index fields in the unit tables.
1320 for J in 1 .. SUnit_Num (Unit.Last) loop
1321 Unit.Table (Sorted_Units.Table (J)).Sorted_Index := J;
1332 ("Usage
: gnatchop
[-c
] [-h
] [-k#
] " &
1333 "[-r
] [-p
] [-q
] [-v
] [-w
] [-x
] [--GCC=xx] file [file ...] [dir]");
1337 (" -c compilation mode, configuration pragmas " &
1341 (" -gnatxxx passes the -gnatxxx switch to gnat parser");
1344 (" -h help: output this usage information");
1347 (" -k# krunch file names of generated files to " &
1348 "no more than # characters");
1351 (" -k krunch file names of generated files to " &
1352 "no more than 8 characters");
1355 (" -p preserve time stamp, output files will " &
1356 "have same stamp as input");
1359 (" -q quiet mode, no output of generated file " &
1363 (" -r generate Source_Reference pragmas refer" &
1364 "encing original source file");
1367 (" -v verbose mode, output version and generat" &
1371 (" -w overwrite existing filenames");
1374 (" -x exit on error");
1377 (" --GCC=xx specify the path of the gnat parser to be used");
1381 (" file... list of source files to be chopped");
1384 (" dir directory location for split files (defa" &
1385 "ult = current directory)");
1392 procedure Warning_Msg
(Message
: String) is
1394 Warning_Count
:= Warning_Count
+ 1;
1395 Put_Line
(Standard_Error
, "warning: " & Message
);
1398 -------------------------
1399 -- Write_Chopped_Files --
1400 -------------------------
1402 function Write_Chopped_Files
(Input
: File_Num
) return Boolean is
1403 Name
: aliased constant String :=
1404 File
.Table
(Input
).Name
.all & ASCII
.Nul
;
1405 FD
: File_Descriptor
;
1406 Buffer
: String_Access
;
1411 FD
:= Open_Read
(Name
'Address, Binary
);
1412 TS_Time
:= File_Time_Stamp
(FD
);
1414 if FD
= Invalid_FD
then
1415 Error_Msg
("cannot open " & File
.Table
(Input
).Name
.all);
1419 Read_File
(FD
, Buffer
, Success
);
1422 Error_Msg
("cannot read " & File
.Table
(Input
).Name
.all);
1427 if not Quiet_Mode
then
1428 Put_Line
("splitting " & File
.Table
(Input
).Name
.all & " into:");
1431 -- Only chop those units that come from this file
1433 for Num
in 1 .. Unit
.Last
loop
1434 if Unit
.Table
(Num
).Chop_File
= Input
then
1435 Write_Unit
(Buffer
, Num
, TS_Time
, Success
);
1436 exit when not Success
;
1443 end Write_Chopped_Files
;
1445 -----------------------
1446 -- Write_Config_File --
1447 -----------------------
1449 procedure Write_Config_File
(Input
: File_Num
; U
: Unit_Num
) is
1450 FD
: File_Descriptor
;
1451 Name
: aliased constant String := "gnat.adc" & ASCII
.NUL
;
1452 Buffer
: String_Access
;
1455 Buffera
: String_Access
;
1459 Write_gnat_adc
:= True;
1460 FD
:= Open_Read_Write
(Name
'Address, Binary
);
1462 if FD
= Invalid_FD
then
1463 FD
:= Create_File
(Name
'Address, Binary
);
1466 if not Quiet_Mode
then
1467 Put_Line
("writing configuration pragmas from " &
1468 File
.Table
(Input
).Name
.all & " to gnat.adc");
1474 if not Quiet_Mode
then
1476 ("appending configuration pragmas from " &
1477 File
.Table
(Input
).Name
.all & " to gnat.adc");
1481 Success
:= FD
/= Invalid_FD
;
1484 Error_Msg
("cannot create gnat.adc");
1488 -- In append mode, acquire existing gnat.adc file
1491 Read_File
(FD
, Buffera
, Success
);
1494 Error_Msg
("cannot read gnat.adc");
1498 -- Find location of EOF byte if any to exclude from append
1501 while Bufferl
<= Buffera
'Last
1502 and then Buffera
(Bufferl
) /= EOF
1504 Bufferl
:= Bufferl
+ 1;
1507 Bufferl
:= Bufferl
- 1;
1510 -- Write existing gnat.adc to new gnat.adc file
1512 FD
:= Create_File
(Name
'Address, Binary
);
1513 Success
:= Write
(FD
, Buffera
(1)'Address, Bufferl
) = Bufferl
;
1516 Error_Msg
("error writing gnat.adc");
1521 Buffer
:= Get_Config_Pragmas
(Input
, U
);
1523 if Buffer
/= null then
1524 Success
:= Write
(FD
, Buffer
.all'Address, Buffer
'Length) =
1528 Error_Msg
("disk full writing gnat.adc");
1534 end Write_Config_File
;
1536 -----------------------------------
1537 -- Write_Source_Reference_Pragma --
1538 -----------------------------------
1540 procedure Write_Source_Reference_Pragma
1543 FD
: File_Descriptor
;
1545 Success
: in out Boolean)
1547 FTE
: File_Entry
renames File
.Table
(Info
.Chop_File
);
1548 Nam
: String_Access
;
1551 if Success
and Source_References
and not Info
.SR_Present
then
1552 if FTE
.SR_Name
/= null then
1559 Reference
: aliased String :=
1560 "pragma Source_Reference (000000, """
1561 & Nam
.all & """);" & EOL
.Str
;
1563 Pos
: Positive := Reference
'First;
1564 Lin
: Line_Num
:= Line
;
1567 while Reference
(Pos
+ 1) /= ',' loop
1571 while Reference
(Pos
) = '0' loop
1572 Reference
(Pos
) := Character'Val
1573 (Character'Pos ('0') + Lin
mod 10);
1578 -- Assume there are enough zeroes for any program length
1580 pragma Assert
(Lin
= 0);
1583 Write
(FD
, Reference
'Address, Reference
'Length)
1587 end Write_Source_Reference_Pragma
;
1593 procedure Write_Unit
1594 (Source
: access String;
1597 Success
: out Boolean)
1599 Info
: Unit_Info
renames Unit
.Table
(Num
);
1600 FD
: File_Descriptor
;
1601 Name
: aliased constant String := Info
.File_Name
.all & ASCII
.NUL
;
1602 Length
: File_Offset
;
1603 EOL
: constant EOL_String
:=
1604 Get_EOL
(Source
, Source
'First + Info
.Offset
);
1607 -- Skip duplicated files
1609 if Is_Duplicated
(Info
.Sorted_Index
) then
1610 Put_Line
(" " & Info
.File_Name
.all & " skipped");
1611 Success
:= Overwrite_Files
;
1615 if Overwrite_Files
then
1616 FD
:= Create_File
(Name
'Address, Binary
);
1618 FD
:= Create_New_File
(Name
'Address, Binary
);
1621 Success
:= FD
/= Invalid_FD
;
1624 Error_Msg
("cannot create " & Info
.File_Name
.all);
1628 -- A length of 0 indicates that the rest of the file belongs to
1629 -- this unit. The actual length must be calculated now. Take into
1630 -- account that the last character (EOF) must not be written.
1632 if Info
.Length
= 0 then
1633 Length
:= Source
'Last - (Source
'First + Info
.Offset
);
1635 Length
:= Info
.Length
;
1638 -- Prepend configuration pragmas if necessary
1640 if Success
and then Info
.Bufferg
/= null then
1641 Write_Source_Reference_Pragma
(Info
, 1, FD
, EOL
, Success
);
1643 Write
(FD
, Info
.Bufferg
.all'Address, Info
.Bufferg
'Length) =
1644 Info
.Bufferg
'Length;
1647 Write_Source_Reference_Pragma
(Info
, Info
.Start_Line
, FD
, EOL
, Success
);
1650 Success
:= Write
(FD
, Source
(Source
'First + Info
.Offset
)'Address,
1655 Error_Msg
("disk full writing " & Info
.File_Name
.all);
1659 if not Quiet_Mode
then
1660 Put_Line
(" " & Info
.File_Name
.all);
1665 if Preserve_Mode
then
1666 File_Time_Stamp
(Name
'Address, TS_Time
);
1671 -- Start of processing for gnatchop
1674 -- Process command line options and initialize global variables
1676 if not Scan_Arguments
then
1677 Set_Exit_Status
(Failure
);
1681 -- Check presence of required executables
1683 Gnat_Cmd
:= Locate_Executable
(Gcc
.all, not Gcc_Set
);
1685 if Gnat_Cmd
= null then
1686 goto No_Files_Written
;
1689 -- First parse all files and read offset information
1691 for Num
in 1 .. File
.Last
loop
1692 if not Parse_File
(Num
) then
1693 goto No_Files_Written
;
1697 -- Check if any units have been found (assumes non-empty Unit.Table)
1699 if Unit
.Last
= 0 then
1700 if not Write_gnat_adc
then
1701 Error_Msg
("no compilation units found", Warning
=> True);
1704 goto No_Files_Written
;
1709 -- Check if any duplicate files would be created. If so, emit
1710 -- a warning if Overwrite_Files is true, otherwise generate an error.
1712 if Report_Duplicate_Units
and then not Overwrite_Files
then
1713 goto No_Files_Written
;
1716 -- Check if any files exist, if so do not write anything
1717 -- Because all files have been parsed and checked already,
1718 -- there won't be any duplicates
1720 if not Overwrite_Files
and then Files_Exist
then
1721 goto No_Files_Written
;
1724 -- After this point, all source files are read in succession
1725 -- and chopped into their destination files.
1727 -- As the Source_File_Name pragmas are handled as logical file 0,
1730 for F
in 1 .. File
.Last
loop
1731 if not Write_Chopped_Files
(F
) then
1732 Set_Exit_Status
(Failure
);
1737 if Warning_Count
> 0 then
1739 Warnings_Msg
: String := Warning_Count
'Img & " warning(s)";
1741 Error_Msg
(Warnings_Msg
(2 .. Warnings_Msg
'Last), Warning
=> True);
1747 <<No_Files_Written
>>
1749 -- Special error exit for all situations where no files have
1752 if not Write_gnat_adc
then
1753 Error_Msg
("no source files written", Warning
=> True);
1759 when Terminate_Program
=>