1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2008, 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
.Command_Line
; use GNAT
.Command_Line
;
34 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
35 with GNAT
.Heap_Sort_G
;
39 with Switch
; use Switch
;
44 Config_File_Name
: constant String_Access
:= new String'("gnat.adc");
45 -- The name of the file holding the GNAT configuration pragmas
47 Gcc : String_Access := new String'("gcc");
48 -- May be modified by switch --GCC=
50 Gcc_Set
: Boolean := False;
51 -- True if a switch --GCC= is used
53 Gnat_Cmd
: String_Access
;
54 -- Command to execute the GNAT compiler
56 Gnat_Args
: Argument_List_Access
:=
61 new String'("-gnats"),
62 new String'("-gnatu"));
63 -- Arguments used in Gnat_Cmd call
65 EOF
: constant Character := Character'Val (26);
66 -- Special character to signal end of file. Not required in input
67 -- files, but properly treated if present. Not generated in output
68 -- files except as a result of copying input file.
74 subtype File_Num
is Natural;
75 subtype File_Offset
is Natural;
77 type File_Entry
is record
79 -- Name of chop file or directory
81 SR_Name
: String_Access
;
82 -- Null unless the chop file starts with a source reference pragma
83 -- in which case this field points to the file name from this pragma.
86 package File
is new GNAT
.Table
87 (Table_Component_Type
=> File_Entry
,
88 Table_Index_Type
=> File_Num
,
91 Table_Increment
=> 100);
93 Directory
: String_Access
;
94 -- Record name of directory, or a null string if no directory given
96 Compilation_Mode
: Boolean := False;
97 Overwrite_Files
: Boolean := False;
98 Preserve_Mode
: Boolean := False;
99 Quiet_Mode
: Boolean := False;
100 Source_References
: Boolean := False;
101 Verbose_Mode
: Boolean := False;
102 Exit_On_Error
: Boolean := False;
105 Write_gnat_adc
: Boolean := False;
106 -- Gets set true if we append to gnat.adc or create a new gnat.adc.
107 -- Used to inhibit complaint about no units generated.
113 type Line_Num
is new Natural;
114 -- Line number (for source reference pragmas)
116 type Unit_Count_Type
is new Integer;
117 subtype Unit_Num
is Unit_Count_Type
range 1 .. Unit_Count_Type
'Last;
118 -- Used to refer to unit number in unit table
120 type SUnit_Num
is new Integer;
121 -- Used to refer to entry in sorted units table. Note that entry
122 -- zero is only for use by Heapsort, and is not otherwise referenced.
124 type Unit_Kind
is (Unit_Spec
, Unit_Body
, Config_Pragmas
);
126 -- Structure to contain all necessary information for one unit.
127 -- Entries are also temporarily used to record config pragma sequences.
129 type Unit_Info
is record
130 File_Name
: String_Access
;
131 -- File name from GNAT output line
133 Chop_File
: File_Num
;
134 -- File number in chop file sequence
136 Start_Line
: Line_Num
;
137 -- Line number from GNAT output line
139 Offset
: File_Offset
;
140 -- Offset name from GNAT output line
142 SR_Present
: Boolean;
143 -- Set True if SR parameter present
145 Length
: File_Offset
;
146 -- A length of 0 means that the Unit is the last one in the file
149 -- Indicates kind of unit
151 Sorted_Index
: SUnit_Num
;
152 -- Index of unit in sorted unit list
154 Bufferg
: String_Access
;
155 -- Pointer to buffer containing configuration pragmas to be
156 -- 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
;
194 ---------------------
195 -- Local variables --
196 ---------------------
198 Warning_Count
: Natural := 0;
199 -- Count of warnings issued so far
201 -----------------------
202 -- Local subprograms --
203 -----------------------
205 procedure Error_Msg
(Message
: String; Warning
: Boolean := False);
206 -- Produce an error message on standard error output
208 procedure File_Time_Stamp
(Name
: C_File_Name
; Time
: OS_Time
);
209 -- Given the name of a file or directory, Name, set the
210 -- time stamp. This function must be used for an unopened file.
212 function Files_Exist
return Boolean;
213 -- Check Unit.Table for possible file names that already exist
214 -- in the file system. Returns true if files exist, False otherwise
216 function Get_Maximum_File_Name_Length
return Integer;
217 pragma Import
(C
, Get_Maximum_File_Name_Length
,
218 "__gnat_get_maximum_file_name_length");
219 -- Function to get maximum file name length for system
221 Maximum_File_Name_Length
: constant Integer := Get_Maximum_File_Name_Length
;
222 Maximum_File_Name_Length_String
: constant String :=
224 (Maximum_File_Name_Length
);
226 function Locate_Executable
227 (Program_Name
: String;
228 Look_For_Prefix
: Boolean := True) return String_Access
;
229 -- Locate executable for given program name. This takes into account
230 -- the target-prefix of the current command, if Look_For_Prefix is True.
232 subtype EOL_Length
is Natural range 0 .. 2;
233 -- Possible lengths of end of line sequence
235 type EOL_String
(Len
: EOL_Length
:= 0) is record
236 Str
: String (1 .. Len
);
240 (Source
: not null access String;
241 Start
: Positive) return EOL_String
;
242 -- Return the line terminator used in the passed string
245 (Source
: not null access String;
246 Ptr
: in out Positive);
247 -- On return Source (Ptr) is the first character of the next line
248 -- or EOF. Source.all must be terminated by EOF.
250 function Parse_File
(Num
: File_Num
) return Boolean;
251 -- Calls the GNAT compiler to parse the given source file and parses the
252 -- output using Parse_Offset_Info. Returns True if parse operation
253 -- completes, False if some system error (e.g. failure to read the
254 -- offset information) occurs.
256 procedure Parse_Offset_Info
257 (Chop_File
: File_Num
;
258 Source
: not null access String);
259 -- Parses the output of the compiler indicating the offsets
260 -- and names of the compilation units in Chop_File.
262 procedure Parse_Token
263 (Source
: not null access String;
264 Ptr
: in out Positive;
265 Token_Ptr
: out Positive);
266 -- Skips any separators and stores the start of the token in Token_Ptr.
267 -- Then stores the position of the next separator in Ptr.
268 -- On return Source (Token_Ptr .. Ptr - 1) is the token.
271 (FD
: File_Descriptor
;
272 Contents
: out String_Access
;
273 Success
: out Boolean);
274 -- Reads file associated with FS into the newly allocated
276 -- [VMS] Success is true iff the number of bytes read is less than or
277 -- equal to the file size.
278 -- [Other] Success is true iff the number of bytes read is equal to
281 function Report_Duplicate_Units
return Boolean;
282 -- Output messages about duplicate units in the input files in Unit.Table
283 -- Returns True if any duplicates found, False if no duplicates found.
285 function Scan_Arguments
return Boolean;
286 -- Scan command line options and set global variables accordingly.
287 -- Also scan out file and directory arguments. Returns True if scan
288 -- was successful, and False if the scan fails for any reason.
291 -- Output message on standard output describing syntax of gnatchop command
293 procedure Warning_Msg
(Message
: String);
294 -- Output a warning message on standard error and update warning count
296 function Write_Chopped_Files
(Input
: File_Num
) return Boolean;
297 -- Write all units that result from chopping the Input file
299 procedure Write_Config_File
(Input
: File_Num
; U
: Unit_Num
);
300 -- Call to write configuration pragmas (append them to gnat.adc)
301 -- Input is the file number for the chop file and U identifies the
302 -- unit entry for the configuration pragmas.
304 function Get_Config_Pragmas
306 U
: Unit_Num
) return String_Access
;
307 -- Call to read configuration pragmas from given unit entry, and
308 -- return a buffer containing the pragmas to be appended to
309 -- following units. Input is the file number for the chop file and
310 -- U identifies the unit entry for the configuration pragmas.
312 procedure Write_Source_Reference_Pragma
315 File
: Stream_IO
.File_Type
;
317 Success
: in out Boolean);
318 -- If Success is True on entry, writes a source reference pragma using
319 -- the chop file from Info, and the given line number. On return Success
320 -- indicates whether the write succeeded. If Success is False on entry,
321 -- or if the global flag Source_References is False, then the call to
322 -- Write_Source_Reference_Pragma has no effect. EOL indicates the end
323 -- of line sequence to be written at the end of the pragma.
326 (Source
: not null access String;
329 Success
: out Boolean);
330 -- Write one compilation unit of the source to file
336 function dup
(handle
: File_Descriptor
) return File_Descriptor
is
338 return File_Descriptor
(System
.CRTL
.dup
(int
(handle
)));
345 function dup2
(from
, to
: File_Descriptor
) return File_Descriptor
is
347 return File_Descriptor
(System
.CRTL
.dup2
(int
(from
), int
(to
)));
354 procedure Error_Msg
(Message
: String; Warning
: Boolean := False) is
356 Put_Line
(Standard_Error
, Message
);
359 Set_Exit_Status
(Failure
);
361 if Exit_On_Error
then
362 raise Types
.Terminate_Program
;
367 ---------------------
368 -- File_Time_Stamp --
369 ---------------------
371 procedure File_Time_Stamp
(Name
: C_File_Name
; Time
: OS_Time
) is
372 procedure Set_File_Time
(Name
: C_File_Name
; Time
: OS_Time
);
373 pragma Import
(C
, Set_File_Time
, "__gnat_set_file_time_name");
376 Set_File_Time
(Name
, Time
);
383 function Files_Exist
return Boolean is
384 Exists
: Boolean := False;
387 for SNum
in 1 .. SUnit_Num
(Unit
.Last
) loop
389 -- Only check and report for the last instance of duplicated files
391 if not Is_Duplicated
(SNum
) then
393 Info
: constant Unit_Info
:=
394 Unit
.Table
(Sorted_Units
.Table
(SNum
));
397 if Is_Writable_File
(Info
.File_Name
.all) then
398 if Hostparm
.OpenVMS
then
401 & " already exists, use /OVERWRITE to overwrite");
403 Error_Msg
(Info
.File_Name
.all
404 & " already exists, use -w to overwrite");
416 ------------------------
417 -- Get_Config_Pragmas --
418 ------------------------
420 function Get_Config_Pragmas
425 Info
: Unit_Info
renames Unit
.Table
(U
);
426 FD
: File_Descriptor
;
427 Name
: aliased constant String :=
428 File
.Table
(Input
).Name
.all & ASCII
.NUL
;
429 Length
: File_Offset
;
430 Buffer
: String_Access
;
431 Result
: String_Access
;
434 pragma Warnings
(Off
, Success
);
437 FD
:= Open_Read
(Name
'Address, Binary
);
439 if FD
= Invalid_FD
then
440 Error_Msg
("cannot open " & File
.Table
(Input
).Name
.all);
444 Read_File
(FD
, Buffer
, Success
);
446 -- A length of 0 indicates that the rest of the file belongs to
447 -- this unit. The actual length must be calculated now. Take into
448 -- account that the last character (EOF) must not be written.
450 if Info
.Length
= 0 then
451 Length
:= Buffer
'Last - (Buffer
'First + Info
.Offset
);
453 Length
:= Info
.Length
;
456 Result
:= new String'(Buffer (1 .. Length));
459 end Get_Config_Pragmas;
466 (Source : not null access String;
470 Ptr : Positive := Start;
475 -- Skip to end of line
477 while Source (Ptr) /= ASCII.CR and then
478 Source (Ptr) /= ASCII.LF and then
486 if Source (Ptr) /= EOF then
496 -- Recognize CR/LF or LF/CR combination
498 if (Source (Ptr + 1) = ASCII.CR or Source (Ptr + 1) = ASCII.LF)
499 and then Source (Ptr) /= Source (Ptr + 1)
504 return (Len => Last + 1 - First, Str => Source (First .. Last));
511 function Is_Duplicated (U : SUnit_Num) return Boolean is
513 return U < SUnit_Num (Unit.Last)
515 Unit.Table (Sorted_Units.Table (U)).File_Name.all =
516 Unit.Table (Sorted_Units.Table (U + 1)).File_Name.all;
519 -----------------------
520 -- Locate_Executable --
521 -----------------------
523 function Locate_Executable
524 (Program_Name : String;
525 Look_For_Prefix : Boolean := True) return String_Access
527 Gnatchop_Str : constant String := "gnatchop";
528 Current_Command : constant String := Normalize_Pathname (Command_Name);
529 End_Of_Prefix : Natural;
530 Start_Of_Prefix : Positive;
531 Start_Of_Suffix : Positive;
532 Result : String_Access;
535 Start_Of_Prefix := Current_Command'First;
536 Start_Of_Suffix := Current_Command'Last + 1;
537 End_Of_Prefix := Start_Of_Prefix - 1;
539 if Look_For_Prefix then
541 -- Find Start_Of_Prefix
543 for J in reverse Current_Command'Range loop
544 if Current_Command (J) = '/' or
545 Current_Command (J) = Directory_Separator or
546 Current_Command (J) = ':'
548 Start_Of_Prefix := J + 1;
553 -- Find End_Of_Prefix
555 for J in Start_Of_Prefix ..
556 Current_Command'Last - Gnatchop_Str'Length + 1
558 if Current_Command (J .. J + Gnatchop_Str'Length - 1) =
561 End_Of_Prefix := J - 1;
567 if End_Of_Prefix > Current_Command'First then
568 Start_Of_Suffix := End_Of_Prefix + Gnatchop_Str'Length + 1;
572 Command : constant String :=
573 Current_Command (Start_Of_Prefix .. End_Of_Prefix)
575 & Current_Command (Start_Of_Suffix ..
576 Current_Command'Last);
578 Result := Locate_Exec_On_Path (Command);
580 if Result = null then
582 (Command & ": installation problem, executable not found");
587 end Locate_Executable;
594 (Source : not null access String;
595 Ptr : in out Positive) is
597 -- Skip to end of line
599 while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF
600 and then Source (Ptr) /= EOF
605 if Source (Ptr) /= EOF then
606 Ptr := Ptr + 1; -- skip CR or LF
609 -- Skip past CR/LF or LF/CR combination
611 if (Source (Ptr) = ASCII.CR or Source (Ptr) = ASCII.LF)
612 and then Source (Ptr) /= Source (Ptr - 1)
622 function Parse_File (Num : File_Num) return Boolean is
623 Chop_Name : constant String_Access := File.Table (Num).Name;
624 Save_Stdout : constant File_Descriptor := dup (Standout);
625 Offset_Name : Temp_File_Name;
626 Offset_FD : File_Descriptor;
627 Buffer : String_Access;
632 -- Display copy of GNAT command if verbose mode
637 for J in 1 .. Gnat_Args'Length loop
639 Put (Gnat_Args (J).all);
643 Put_Line (Chop_Name.all);
646 -- Create temporary file
648 Create_Temp_File (Offset_FD, Offset_Name);
650 if Offset_FD = Invalid_FD then
651 Error_Msg ("gnatchop: cannot create temporary file");
656 -- Redirect Stdout to this temporary file in the Unix way
658 if dup2 (Offset_FD, Standout) = Invalid_FD then
659 Error_Msg ("gnatchop: cannot redirect stdout to temporary file");
665 -- Call Gnat on the source filename argument with special options
666 -- to generate offset information. If this special compilation completes
667 -- successfully then we can do the actual gnatchop operation.
669 Spawn (Gnat_Cmd.all, Gnat_Args.all & Chop_Name, Success);
672 Error_Msg (Chop_Name.all & ": parse errors detected");
673 Error_Msg (Chop_Name.all & ": chop may not be successful");
678 if dup2 (Save_Stdout, Standout) = Invalid_FD then
679 Error_Msg ("gnatchop: cannot restore stdout");
682 -- Reopen the file to start reading from the beginning
686 Offset_FD := Open_Read (Offset_Name'Address, Binary);
688 if Offset_FD = Invalid_FD then
689 Error_Msg ("gnatchop: cannot access offset info");
693 Read_File (Offset_FD, Buffer, Success);
696 Error_Msg ("gnatchop: error reading offset info");
700 Parse_Offset_Info (Num, Buffer);
703 -- Close and delete temporary file
706 Delete_File (Offset_Name'Address, Success);
711 when Failure | Types.Terminate_Program =>
713 Delete_File (Offset_Name'Address, Success);
718 -----------------------
719 -- Parse_Offset_Info --
720 -----------------------
722 procedure Parse_Offset_Info
723 (Chop_File : File_Num;
724 Source : not null access String)
726 First_Unit : constant Unit_Num := Unit.Last + 1;
727 Bufferg : String_Access := null;
728 Parse_Ptr : File_Offset := Source'First;
729 Token_Ptr : File_Offset;
732 function Match (Literal : String) return Boolean;
733 -- Checks if given string appears at the current Token_Ptr location
734 -- and if so, bumps Parse_Ptr past the token and returns True. If
735 -- the string is not present, sets Parse_Ptr to Token_Ptr and
742 function Match (Literal : String) return Boolean is
744 Parse_Token (Source, Parse_Ptr, Token_Ptr);
746 if Source'Last + 1 - Token_Ptr < Literal'Length
748 Source (Token_Ptr .. Token_Ptr + Literal'Length - 1) /= Literal
750 Parse_Ptr := Token_Ptr;
754 Parse_Ptr := Token_Ptr + Literal'Length;
758 -- Start of processing for Parse_Offset_Info
762 -- Set default values, should get changed for all
763 -- units/pragmas except for the last
765 Info.Chop_File := Chop_File;
768 -- Parse the current line of offset information into Info
769 -- and exit the loop if there are any errors or on EOF.
771 -- First case, parse a line in the following format:
773 -- Unit x (spec) line 7, file offset 142, [SR, ]file name x.ads
775 -- Note that the unit name can be an operator name in quotes.
776 -- This is of course illegal, but both GNAT and gnatchop handle
777 -- the case so that this error does not interfere with chopping.
779 -- The SR ir present indicates that a source reference pragma
780 -- was processed as part of this unit (and that therefore no
781 -- Source_Reference pragma should be generated.
783 if Match ("Unit") then
784 Parse_Token (Source, Parse_Ptr, Token_Ptr);
786 if Match ("(body)") then
787 Info.Kind := Unit_Body;
788 elsif Match ("(spec)") then
789 Info.Kind := Unit_Spec;
794 exit when not Match ("line");
795 Parse_Token (Source, Parse_Ptr, Token_Ptr);
796 Info.Start_Line := Line_Num'Value
797 (Source (Token_Ptr .. Parse_Ptr - 1));
799 exit when not Match ("file offset");
800 Parse_Token (Source, Parse_Ptr, Token_Ptr);
801 Info.Offset := File_Offset'Value
802 (Source (Token_Ptr .. Parse_Ptr - 1));
804 Info.SR_Present := Match ("SR, ");
806 exit when not Match ("file name");
807 Parse_Token (Source, Parse_Ptr, Token_Ptr);
808 Info.File_Name := new String'
809 (Directory
.all & Source
(Token_Ptr
.. Parse_Ptr
- 1));
810 Parse_EOL
(Source
, Parse_Ptr
);
812 -- Second case, parse a line of the following form
814 -- Configuration pragmas at line 10, file offset 223
816 elsif Match
("Configuration pragmas at") then
817 Info
.Kind
:= Config_Pragmas
;
818 Info
.File_Name
:= Config_File_Name
;
820 exit when not Match
("line");
821 Parse_Token
(Source
, Parse_Ptr
, Token_Ptr
);
822 Info
.Start_Line
:= Line_Num
'Value
823 (Source
(Token_Ptr
.. Parse_Ptr
- 1));
825 exit when not Match
("file offset");
826 Parse_Token
(Source
, Parse_Ptr
, Token_Ptr
);
827 Info
.Offset
:= File_Offset
'Value
828 (Source
(Token_Ptr
.. Parse_Ptr
- 1));
830 Parse_EOL
(Source
, Parse_Ptr
);
832 -- Third case, parse a line of the following form
834 -- Source_Reference pragma for file "filename"
836 -- This appears at the start of the file only, and indicates
837 -- the name to be used on any generated Source_Reference pragmas.
839 elsif Match
("Source_Reference pragma for file ") then
840 Parse_Token
(Source
, Parse_Ptr
, Token_Ptr
);
841 File
.Table
(Chop_File
).SR_Name
:=
842 new String'(Source (Token_Ptr + 1 .. Parse_Ptr - 2));
843 Parse_EOL (Source, Parse_Ptr);
846 -- Unrecognized keyword or end of file
852 -- Store the data in the Info record in the Unit.Table
855 Unit.Table (Unit.Last) := Info;
857 -- If this is not the first unit from the file, calculate
858 -- the length of the previous unit as difference of the offsets
860 if Unit.Last > First_Unit then
861 Unit.Table (Unit.Last - 1).Length :=
862 Info.Offset - Unit.Table (Unit.Last - 1).Offset;
865 -- If not in compilation mode combine current unit with any
866 -- preceding configuration pragmas.
868 if not Compilation_Mode
869 and then Unit.Last > First_Unit
870 and then Unit.Table (Unit.Last - 1).Kind = Config_Pragmas
872 Info.Start_Line := Unit.Table (Unit.Last - 1).Start_Line;
873 Info.Offset := Unit.Table (Unit.Last - 1).Offset;
875 -- Delete the configuration pragma entry
877 Unit.Table (Unit.Last - 1) := Info;
881 -- If in compilation mode, and previous entry is the initial
882 -- entry for the file and is for configuration pragmas, then
883 -- they are to be appended to every unit in the file.
886 and then Unit.Last = First_Unit + 1
887 and then Unit.Table (First_Unit).Kind = Config_Pragmas
891 (Unit.Table (Unit.Last - 1).Chop_File, First_Unit);
892 Unit.Table (Unit.Last - 1) := Info;
896 Unit.Table (Unit.Last).Bufferg := Bufferg;
898 -- If in compilation mode, and this is not the first item,
899 -- combine configuration pragmas with previous unit, which
900 -- will cause an error message to be generated when the unit
904 and then Unit.Last > First_Unit
905 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
915 -- Find out if the loop was exited prematurely because of
916 -- an error or if the EOF marker was found.
918 if Source (Parse_Ptr) /= EOF then
920 (File.Table (Chop_File).Name.all & ": error parsing offset info");
924 -- Handle case of a chop file consisting only of config pragmas
926 if Unit.Last = First_Unit
927 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
929 -- In compilation mode, we append such a file to gnat.adc
931 if Compilation_Mode then
932 Write_Config_File (Unit.Table (Unit.Last).Chop_File, First_Unit);
935 -- In default (non-compilation) mode, this is invalid
939 (File.Table (Chop_File).Name.all &
940 ": no units found (only pragmas)");
945 -- Handle case of a chop file ending with config pragmas. This can
946 -- happen only in default non-compilation mode, since in compilation
947 -- mode such configuration pragmas are part of the preceding unit.
948 -- We simply concatenate such pragmas to the previous file which
949 -- will cause a compilation error, which is appropriate.
951 if Unit.Last > First_Unit
952 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
956 end Parse_Offset_Info;
962 procedure Parse_Token
963 (Source : not null access String;
964 Ptr : in out Positive;
965 Token_Ptr : out Positive)
967 In_Quotes : Boolean := False;
972 while Source (Ptr) = ' ' or Source (Ptr) = ',' loop
980 while (In_Quotes or else not (Source (Ptr) = ' ' or Source (Ptr) = ','))
981 and then Source (Ptr) >= ' '
983 if Source (Ptr) = '"' then
984 In_Quotes := not In_Quotes;
996 (FD : File_Descriptor;
997 Contents : out String_Access;
998 Success : out Boolean)
1000 Length : constant File_Offset := File_Offset (File_Length (FD));
1001 -- Include room for EOF char
1002 Buffer : constant String_Access := new String (1 .. Length + 1);
1004 This_Read : Integer;
1005 Read_Ptr : File_Offset := 1;
1010 This_Read := Read (FD,
1011 A => Buffer (Read_Ptr)'Address,
1012 N => Length + 1 - Read_Ptr);
1013 Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0);
1014 exit when This_Read <= 0;
1017 Buffer (Read_Ptr) := EOF;
1018 Contents := new String (1 .. Read_Ptr);
1019 Contents.all := Buffer (1 .. Read_Ptr);
1021 -- Things aren't simple on VMS due to the plethora of file types
1022 -- and organizations. It seems clear that there shouldn't be more
1023 -- bytes read than are contained in the file though.
1025 if Hostparm.OpenVMS then
1026 Success := Read_Ptr <= Length + 1;
1028 Success := Read_Ptr = Length + 1;
1032 ----------------------------
1033 -- Report_Duplicate_Units --
1034 ----------------------------
1036 function Report_Duplicate_Units return Boolean is
1040 Duplicates : Boolean := False;
1044 while US < SUnit_Num (Unit.Last) loop
1045 U := Sorted_Units.Table (US);
1047 if Is_Duplicated (US) then
1050 -- Move to last two versions of duplicated file to make it clearer
1051 -- to understand which file is retained in case of overwriting.
1053 while US + 1 < SUnit_Num (Unit.Last) loop
1054 exit when not Is_Duplicated (US + 1);
1058 U := Sorted_Units.Table (US);
1060 if Overwrite_Files then
1061 Warning_Msg (Unit.Table (U).File_Name.all
1062 & " is duplicated
(all but last will be skipped
)");
1064 elsif Unit.Table (U).Chop_File =
1065 Unit.Table (Sorted_Units.Table (US + 1)).Chop_File
1067 Error_Msg (Unit.Table (U).File_Name.all
1068 & " is duplicated
in "
1069 & File.Table (Unit.Table (U).Chop_File).Name.all);
1072 Error_Msg (Unit.Table (U).File_Name.all
1074 & File.Table (Unit.Table (U).Chop_File).Name.all
1075 & " is duplicated
in "
1078 (Sorted_Units.Table (US + 1)).Chop_File).Name.all);
1085 if Duplicates and not Overwrite_Files then
1086 if Hostparm.OpenVMS then
1088 ("use /OVERWRITE to overwrite files
and keep last version
");
1090 Put_Line ("use -w to overwrite files
and keep last version
");
1095 end Report_Duplicate_Units;
1097 --------------------
1098 -- Scan_Arguments --
1099 --------------------
1101 function Scan_Arguments return Boolean is
1102 Kset : Boolean := False;
1103 -- Set true if -k switch found
1106 Initialize_Option_Scan;
1108 -- Scan options first
1111 case Getopt ("c gnat? h k? p q r v w x
-GCC
=!") is
1116 Gcc := new String'(Parameter);
1120 Compilation_Mode := True;
1124 new Argument_List'(Gnat_Args.all &
1125 new String'("-gnat
" & Parameter));
1129 raise Types.Terminate_Program;
1133 Param : String_Access := new String'(Parameter);
1136 if Param.all /= "" then
1137 for J in Param'Range loop
1138 if Param (J) not in '0' .. '9' then
1139 if Hostparm.OpenVMS then
1140 Error_Msg ("/FILE_NAME_MAX_LENGTH
=nnn
" &
1141 " requires numeric parameter
");
1143 Error_Msg ("-k# requires numeric parameter
");
1151 if Hostparm.OpenVMS then
1152 Param := new String'("39");
1154 Param := new String'("8");
1159 new Argument_List'(Gnat_Args.all &
1160 new String'("-gnatk
" & Param.all));
1165 Preserve_Mode := True;
1171 Source_References := True;
1174 Verbose_Mode := True;
1175 Display_Version ("GNATCHOP
", "1998");
1178 Overwrite_Files := True;
1181 Exit_On_Error := True;
1188 if not Kset and then Maximum_File_Name_Length > 0 then
1190 -- If this system has restricted filename lengths, tell gnat1
1191 -- about them, removing the leading blank from the image string.
1194 new Argument_List'(Gnat_Args.all
1195 & new String'("-gnatk
"
1196 & Maximum_File_Name_Length_String
1197 (Maximum_File_Name_Length_String'First + 1
1198 .. Maximum_File_Name_Length_String'Last)));
1205 S : constant String := Get_Argument (Do_Expansion => True);
1209 File.Increment_Last;
1210 File.Table (File.Last).Name := new String'(S);
1211 File.Table (File.Last).SR_Name := null;
1215 -- Case of more than one file where last file is a directory
1218 and then Is_Directory (File.Table (File.Last).Name.all)
1220 Directory := File.Table (File.Last).Name;
1221 File.Decrement_Last;
1223 -- Make sure Directory is terminated with a directory separator,
1224 -- so we can generate the output by just appending a filename.
1226 if Directory (Directory'Last) /= Directory_Separator
1227 and then Directory (Directory'Last) /= '/'
1229 Directory := new String'(Directory.all & Directory_Separator);
1232 -- At least one filename must be given
1234 elsif File.Last = 0 then
1238 -- No directory given, set directory to null, so that we can just
1239 -- concatenate the directory name to the file name unconditionally.
1242 Directory := new String'("");
1245 -- Finally check all filename arguments
1247 for File_Num in 1 .. File.Last loop
1249 F : constant String := File.Table (File_Num).Name.all;
1253 if Is_Directory (F) then
1254 Error_Msg (F & " is a directory
, cannot be chopped
");
1257 elsif not Is_Regular_File (F) then
1258 Error_Msg (F & " not found
");
1267 when Invalid_Switch =>
1268 Error_Msg ("invalid switch
" & Full_Switch);
1271 when Invalid_Parameter =>
1272 if Hostparm.OpenVMS then
1273 Error_Msg ("/FILE_NAME_MAX_LENGTH
=nnn qualifier
" &
1274 " requires numeric parameter
");
1276 Error_Msg ("-k switch requires numeric parameter
");
1287 procedure Sort_Units is
1289 procedure Move (From : Natural; To : Natural);
1290 -- Procedure used to sort the unit list
1291 -- Unit.Table (To) := Unit_List (From); used by sort
1293 function Lt (Left, Right : Natural) return Boolean;
1294 -- Compares Left and Right units based on file name (first),
1295 -- Chop_File (second) and Offset (third). This ordering is
1296 -- important to keep the last version in case of duplicate files.
1298 package Unit_Sort is new GNAT.Heap_Sort_G (Move, Lt);
1299 -- Used for sorting on filename to detect duplicates
1305 function Lt (Left, Right : Natural) return Boolean is
1306 L : Unit_Info renames
1307 Unit.Table (Sorted_Units.Table (SUnit_Num (Left)));
1309 R : Unit_Info renames
1310 Unit.Table (Sorted_Units.Table (SUnit_Num (Right)));
1313 return L.File_Name.all < R.File_Name.all
1314 or else (L.File_Name.all = R.File_Name.all
1315 and then (L.Chop_File < R.Chop_File
1316 or else (L.Chop_File = R.Chop_File
1317 and then L.Offset < R.Offset)));
1324 procedure Move (From : Natural; To : Natural) is
1326 Sorted_Units.Table (SUnit_Num (To)) :=
1327 Sorted_Units.Table (SUnit_Num (From));
1330 -- Start of processing for Sort_Units
1333 Sorted_Units.Set_Last (SUnit_Num (Unit.Last));
1335 for J in 1 .. Unit.Last loop
1336 Sorted_Units.Table (SUnit_Num (J)) := J;
1339 -- Sort Unit.Table, using Sorted_Units.Table (0) as scratch
1341 Unit_Sort.Sort (Natural (Unit.Last));
1343 -- Set the Sorted_Index fields in the unit tables
1345 for J in 1 .. SUnit_Num (Unit.Last) loop
1346 Unit.Table (Sorted_Units.Table (J)).Sorted_Index := J;
1357 ("Usage
: gnatchop
[-c
] [-h
] [-k#
] " &
1358 "[-r
] [-p
] [-q
] [-v
] [-w
] [-x
] [--GCC=xx] file [file ...] [dir]");
1362 (" -c compilation mode, configuration pragmas " &
1366 (" -gnatxxx passes the -gnatxxx switch to gnat parser");
1369 (" -h help: output this usage information");
1372 (" -k# krunch file names of generated files to " &
1373 "no more than # characters");
1376 (" -k krunch file names of generated files to " &
1377 "no more than 8 characters");
1380 (" -p preserve time stamp, output files will " &
1381 "have same stamp as input");
1384 (" -q quiet mode, no output of generated file " &
1388 (" -r generate Source_Reference pragmas refer" &
1389 "encing original source file");
1392 (" -v verbose mode, output version and generat" &
1396 (" -w overwrite existing filenames");
1399 (" -x exit on error");
1402 (" --GCC=xx specify the path of the gnat parser to be used");
1406 (" file... list of source files to be chopped");
1409 (" dir directory location for split files (defa" &
1410 "ult = current directory)");
1417 procedure Warning_Msg
(Message
: String) is
1419 Warning_Count
:= Warning_Count
+ 1;
1420 Put_Line
(Standard_Error
, "warning: " & Message
);
1423 -------------------------
1424 -- Write_Chopped_Files --
1425 -------------------------
1427 function Write_Chopped_Files
(Input
: File_Num
) return Boolean is
1428 Name
: aliased constant String :=
1429 File
.Table
(Input
).Name
.all & ASCII
.NUL
;
1430 FD
: File_Descriptor
;
1431 Buffer
: String_Access
;
1436 FD
:= Open_Read
(Name
'Address, Binary
);
1437 TS_Time
:= File_Time_Stamp
(FD
);
1439 if FD
= Invalid_FD
then
1440 Error_Msg
("cannot open " & File
.Table
(Input
).Name
.all);
1444 Read_File
(FD
, Buffer
, Success
);
1447 Error_Msg
("cannot read " & File
.Table
(Input
).Name
.all);
1452 if not Quiet_Mode
then
1453 Put_Line
("splitting " & File
.Table
(Input
).Name
.all & " into:");
1456 -- Only chop those units that come from this file
1458 for Num
in 1 .. Unit
.Last
loop
1459 if Unit
.Table
(Num
).Chop_File
= Input
then
1460 Write_Unit
(Buffer
, Num
, TS_Time
, Success
);
1461 exit when not Success
;
1467 end Write_Chopped_Files
;
1469 -----------------------
1470 -- Write_Config_File --
1471 -----------------------
1473 procedure Write_Config_File
(Input
: File_Num
; U
: Unit_Num
) is
1474 FD
: File_Descriptor
;
1475 Name
: aliased constant String := "gnat.adc" & ASCII
.NUL
;
1476 Buffer
: String_Access
;
1479 Buffera
: String_Access
;
1483 Write_gnat_adc
:= True;
1484 FD
:= Open_Read_Write
(Name
'Address, Binary
);
1486 if FD
= Invalid_FD
then
1487 FD
:= Create_File
(Name
'Address, Binary
);
1490 if not Quiet_Mode
then
1491 Put_Line
("writing configuration pragmas from " &
1492 File
.Table
(Input
).Name
.all & " to gnat.adc");
1498 if not Quiet_Mode
then
1500 ("appending configuration pragmas from " &
1501 File
.Table
(Input
).Name
.all & " to gnat.adc");
1505 Success
:= FD
/= Invalid_FD
;
1508 Error_Msg
("cannot create gnat.adc");
1512 -- In append mode, acquire existing gnat.adc file
1515 Read_File
(FD
, Buffera
, Success
);
1518 Error_Msg
("cannot read gnat.adc");
1522 -- Find location of EOF byte if any to exclude from append
1525 while Bufferl
<= Buffera
'Last
1526 and then Buffera
(Bufferl
) /= EOF
1528 Bufferl
:= Bufferl
+ 1;
1531 Bufferl
:= Bufferl
- 1;
1534 -- Write existing gnat.adc to new gnat.adc file
1536 FD
:= Create_File
(Name
'Address, Binary
);
1537 Success
:= Write
(FD
, Buffera
(1)'Address, Bufferl
) = Bufferl
;
1540 Error_Msg
("error writing gnat.adc");
1545 Buffer
:= Get_Config_Pragmas
(Input
, U
);
1547 if Buffer
/= null then
1548 Success
:= Write
(FD
, Buffer
.all'Address, Buffer
'Length) =
1552 Error_Msg
("disk full writing gnat.adc");
1558 end Write_Config_File
;
1560 -----------------------------------
1561 -- Write_Source_Reference_Pragma --
1562 -----------------------------------
1564 procedure Write_Source_Reference_Pragma
1567 File
: Stream_IO
.File_Type
;
1569 Success
: in out Boolean)
1571 FTE
: File_Entry
renames Gnatchop
.File
.Table
(Info
.Chop_File
);
1572 Nam
: String_Access
;
1575 if Success
and Source_References
and not Info
.SR_Present
then
1576 if FTE
.SR_Name
/= null then
1583 Reference
: String :=
1584 "pragma Source_Reference (000000, """
1585 & Nam
.all & """);" & EOL
.Str
;
1587 Pos
: Positive := Reference
'First;
1588 Lin
: Line_Num
:= Line
;
1591 while Reference
(Pos
+ 1) /= ',' loop
1595 while Reference
(Pos
) = '0' loop
1596 Reference
(Pos
) := Character'Val
1597 (Character'Pos ('0') + Lin
mod 10);
1602 -- Assume there are enough zeroes for any program length
1604 pragma Assert
(Lin
= 0);
1607 String'Write (Stream_IO
.Stream
(File
), Reference
);
1615 end Write_Source_Reference_Pragma
;
1621 procedure Write_Unit
1622 (Source
: not null access String;
1625 Success
: out Boolean)
1628 procedure OS_Filename
1630 W_Name
: Wide_String;
1632 N_Length
: access Natural;
1634 E_Length
: access Natural);
1635 pragma Import
(C
, OS_Filename
, "__gnat_os_filename");
1636 -- Returns in OS_Name the proper name for the OS when used with the
1637 -- returned Encoding value. For example on Windows this will return the
1638 -- UTF-8 encoded name into OS_Name and set Encoding to encoding=utf8
1639 -- (form parameter Stream_IO).
1640 -- Name is the filename and W_Name the same filename in Unicode 16 bits
1641 -- (this corresponds to Win32 Unicode ISO/IEC 10646). N_Length and
1642 -- E_Length are the length returned in OS_Name and Encoding
1645 Info
: Unit_Info
renames Unit
.Table
(Num
);
1646 Name
: aliased constant String := Info
.File_Name
.all & ASCII
.NUL
;
1647 W_Name
: aliased constant Wide_String := To_Wide_String
(Name
);
1648 EOL
: constant EOL_String
:=
1649 Get_EOL
(Source
, Source
'First + Info
.Offset
);
1651 OS_Name
: aliased String (1 .. Name
'Length * 2);
1652 O_Length
: aliased Natural := OS_Name
'Length;
1653 Encoding
: aliased String (1 .. 64);
1654 E_Length
: aliased Natural := Encoding
'Length;
1656 Length
: File_Offset
;
1659 -- Skip duplicated files
1661 if Is_Duplicated
(Info
.Sorted_Index
) then
1662 Put_Line
(" " & Info
.File_Name
.all & " skipped");
1663 Success
:= Overwrite_Files
;
1671 OS_Name
'Address, O_Length
'Access,
1672 Encoding
'Address, E_Length
'Access);
1675 E_Name
: constant String := OS_Name
(1 .. O_Length
);
1676 C_Name
: aliased constant String := E_Name
& ASCII
.NUL
;
1677 OS_Encoding
: constant String := Encoding
(1 .. E_Length
);
1678 File
: Stream_IO
.File_Type
;
1681 if not Overwrite_Files
and then Exists
(E_Name
) then
1682 raise Stream_IO
.Name_Error
;
1685 (File
, Stream_IO
.Out_File
, E_Name
, OS_Encoding
);
1689 when Stream_IO
.Name_Error | Stream_IO
.Use_Error
=>
1690 Error_Msg
("cannot create " & Info
.File_Name
.all);
1694 -- A length of 0 indicates that the rest of the file belongs to
1695 -- this unit. The actual length must be calculated now. Take into
1696 -- account that the last character (EOF) must not be written.
1698 if Info
.Length
= 0 then
1699 Length
:= Source
'Last - (Source
'First + Info
.Offset
);
1701 Length
:= Info
.Length
;
1704 -- Prepend configuration pragmas if necessary
1706 if Success
and then Info
.Bufferg
/= null then
1707 Write_Source_Reference_Pragma
(Info
, 1, File
, EOL
, Success
);
1709 String'Write (Stream_IO
.Stream
(File
), Info
.Bufferg
.all);
1712 Write_Source_Reference_Pragma
1713 (Info
, Info
.Start_Line
, File
, EOL
, Success
);
1718 (Stream_IO
.Stream
(File
),
1719 Source
(Source
'First + Info
.Offset
..
1720 Source
'First + Info
.Offset
+ Length
- 1));
1722 when Stream_IO
.Use_Error | Stream_IO
.Device_Error
=>
1723 Error_Msg
("disk full writing " & Info
.File_Name
.all);
1728 if not Quiet_Mode
then
1729 Put_Line
(" " & Info
.File_Name
.all);
1732 Stream_IO
.Close
(File
);
1734 if Preserve_Mode
then
1735 File_Time_Stamp
(C_Name
'Address, TS_Time
);
1740 procedure Check_Version_And_Help
is new Check_Version_And_Help_G
(Usage
);
1742 -- Start of processing for gnatchop
1745 -- Add the directory where gnatchop is invoked in front of the
1746 -- path, if gnatchop is invoked with directory information.
1747 -- Only do this if the platform is not VMS, where the notion of path
1748 -- does not really exist.
1750 if not Hostparm
.OpenVMS
then
1752 Command
: constant String := Command_Name
;
1755 for Index
in reverse Command
'Range loop
1756 if Command
(Index
) = Directory_Separator
then
1758 Absolute_Dir
: constant String :=
1760 (Command
(Command
'First .. Index
));
1762 PATH
: constant String :=
1765 Getenv
("PATH").all;
1768 Setenv
("PATH", PATH
);
1777 -- Process command line options and initialize global variables
1779 -- First, scan to detect --version and/or --help
1781 Check_Version_And_Help
("GNATCHOP", "1998");
1783 if not Scan_Arguments
then
1784 Set_Exit_Status
(Failure
);
1788 -- Check presence of required executables
1790 Gnat_Cmd
:= Locate_Executable
(Gcc
.all, not Gcc_Set
);
1792 if Gnat_Cmd
= null then
1793 goto No_Files_Written
;
1796 -- First parse all files and read offset information
1798 for Num
in 1 .. File
.Last
loop
1799 if not Parse_File
(Num
) then
1800 goto No_Files_Written
;
1804 -- Check if any units have been found (assumes non-empty Unit.Table)
1806 if Unit
.Last
= 0 then
1807 if not Write_gnat_adc
then
1808 Error_Msg
("no compilation units found", Warning
=> True);
1811 goto No_Files_Written
;
1816 -- Check if any duplicate files would be created. If so, emit
1817 -- a warning if Overwrite_Files is true, otherwise generate an error.
1819 if Report_Duplicate_Units
and then not Overwrite_Files
then
1820 goto No_Files_Written
;
1823 -- Check if any files exist, if so do not write anything
1824 -- Because all files have been parsed and checked already,
1825 -- there won't be any duplicates
1827 if not Overwrite_Files
and then Files_Exist
then
1828 goto No_Files_Written
;
1831 -- After this point, all source files are read in succession
1832 -- and chopped into their destination files.
1834 -- As the Source_File_Name pragmas are handled as logical file 0,
1837 for F
in 1 .. File
.Last
loop
1838 if not Write_Chopped_Files
(F
) then
1839 Set_Exit_Status
(Failure
);
1844 if Warning_Count
> 0 then
1846 Warnings_Msg
: constant String := Warning_Count
'Img & " warning(s)";
1848 Error_Msg
(Warnings_Msg
(2 .. Warnings_Msg
'Last), Warning
=> True);
1854 <<No_Files_Written
>>
1856 -- Special error exit for all situations where no files have
1859 if not Write_gnat_adc
then
1860 Error_Msg
("no source files written", Warning
=> True);
1866 when Types
.Terminate_Program
=>