Add <bit> and <version> to freestanding headers
[official-gcc.git] / gcc / ada / gnatchop.adb
blob96a5236bc28277290ec52579de4786cb7e732e4a
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T C H O P --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1998-2018, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Ada.Characters.Conversions; use Ada.Characters.Conversions;
27 with Ada.Command_Line; use Ada.Command_Line;
28 with Ada.Directories; use Ada.Directories;
29 with Ada.Streams.Stream_IO; use Ada.Streams;
30 with Ada.Text_IO; use Ada.Text_IO;
31 with System.CRTL; use System; use System.CRTL;
33 with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark;
34 with GNAT.Command_Line; use GNAT.Command_Line;
35 with GNAT.OS_Lib; use GNAT.OS_Lib;
36 with GNAT.Heap_Sort_G;
37 with GNAT.Table;
39 with Switch; use Switch;
40 with Types;
42 procedure Gnatchop is
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 :=
57 new Argument_List'
58 (new String'("-c"),
59 new String'("-x"),
60 new String'("ada"),
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 files,
67 -- but properly treated if present. Not generated in output files except
68 -- as a result of copying input file.
70 BOM_Length : Natural := 0;
71 -- Reset to non-zero value if BOM detected at start of file
73 --------------------
74 -- File arguments --
75 --------------------
77 subtype File_Num is Natural;
78 subtype File_Offset is Natural;
80 type File_Entry is record
81 Name : String_Access;
82 -- Name of chop file or directory
84 SR_Name : String_Access;
85 -- Null unless the chop file starts with a source reference pragma
86 -- in which case this field points to the file name from this pragma.
87 end record;
89 package File is new GNAT.Table
90 (Table_Component_Type => File_Entry,
91 Table_Index_Type => File_Num,
92 Table_Low_Bound => 1,
93 Table_Initial => 100,
94 Table_Increment => 100);
96 Directory : String_Access;
97 -- Record name of directory, or a null string if no directory given
99 Compilation_Mode : Boolean := False;
100 Overwrite_Files : Boolean := False;
101 Preserve_Mode : Boolean := False;
102 Quiet_Mode : Boolean := False;
103 Source_References : Boolean := False;
104 Verbose_Mode : Boolean := False;
105 Exit_On_Error : Boolean := False;
106 -- Global options
108 Write_gnat_adc : Boolean := False;
109 -- Gets set true if we append to gnat.adc or create a new gnat.adc.
110 -- Used to inhibit complaint about no units generated.
112 ---------------
113 -- Unit list --
114 ---------------
116 type Line_Num is new Natural;
117 -- Line number (for source reference pragmas)
119 type Unit_Count_Type is new Integer;
120 subtype Unit_Num is Unit_Count_Type range 1 .. Unit_Count_Type'Last;
121 -- Used to refer to unit number in unit table
123 type SUnit_Num is new Integer;
124 -- Used to refer to entry in sorted units table. Note that entry
125 -- zero is only for use by Heapsort, and is not otherwise referenced.
127 type Unit_Kind is (Unit_Spec, Unit_Body, Config_Pragmas);
129 -- Structure to contain all necessary information for one unit.
130 -- Entries are also temporarily used to record config pragma sequences.
132 type Unit_Info is record
133 File_Name : String_Access;
134 -- File name from GNAT output line
136 Chop_File : File_Num;
137 -- File number in chop file sequence
139 Start_Line : Line_Num;
140 -- Line number from GNAT output line
142 Offset : File_Offset;
143 -- Offset name from GNAT output line
145 SR_Present : Boolean;
146 -- Set True if SR parameter present
148 Length : File_Offset;
149 -- A length of 0 means that the Unit is the last one in the file
151 Kind : Unit_Kind;
152 -- Indicates kind of unit
154 Sorted_Index : SUnit_Num;
155 -- Index of unit in sorted unit list
157 Bufferg : String_Access;
158 -- Pointer to buffer containing configuration pragmas to be prepended.
159 -- Null if no pragmas to be prepended.
160 end record;
162 -- The following table stores the unit offset information
164 package Unit is new GNAT.Table
165 (Table_Component_Type => Unit_Info,
166 Table_Index_Type => Unit_Count_Type,
167 Table_Low_Bound => 1,
168 Table_Initial => 500,
169 Table_Increment => 100);
171 -- The following table is used as a sorted index to the Unit.Table.
172 -- The entries in Unit.Table are not moved, instead we just shuffle
173 -- the entries in Sorted_Units. Note that the zeroeth entry in this
174 -- table is used by GNAT.Heap_Sort_G.
176 package Sorted_Units is new GNAT.Table
177 (Table_Component_Type => Unit_Num,
178 Table_Index_Type => SUnit_Num,
179 Table_Low_Bound => 0,
180 Table_Initial => 500,
181 Table_Increment => 100);
183 function Is_Duplicated (U : SUnit_Num) return Boolean;
184 -- Returns true if U is duplicated by a later unit.
185 -- Note that this function returns false for the last entry.
187 procedure Sort_Units;
188 -- Sort units and set up sorted unit table
190 ----------------------
191 -- File_Descriptors --
192 ----------------------
194 function dup (handle : File_Descriptor) return File_Descriptor;
195 function dup2 (from, to : File_Descriptor) return File_Descriptor;
197 ---------------------
198 -- Local variables --
199 ---------------------
201 Warning_Count : Natural := 0;
202 -- Count of warnings issued so far
204 -----------------------
205 -- Local subprograms --
206 -----------------------
208 procedure Error_Msg (Message : String; Warning : Boolean := False);
209 -- Produce an error message on standard error output
211 function Files_Exist return Boolean;
212 -- Check Unit.Table for possible file names that already exist
213 -- in the file system. Returns true if files exist, False otherwise
215 function Get_Maximum_File_Name_Length return Integer;
216 pragma Import (C, Get_Maximum_File_Name_Length,
217 "__gnat_get_maximum_file_name_length");
218 -- Function to get maximum file name length for system
220 Maximum_File_Name_Length : constant Integer := Get_Maximum_File_Name_Length;
221 Maximum_File_Name_Length_String : constant String :=
222 Integer'Image
223 (Maximum_File_Name_Length);
225 function Locate_Executable
226 (Program_Name : String;
227 Look_For_Prefix : Boolean := True) return String_Access;
228 -- Locate executable for given program name. This takes into account
229 -- the target-prefix of the current command, if Look_For_Prefix is True.
231 subtype EOL_Length is Natural range 0 .. 2;
232 -- Possible lengths of end of line sequence
234 type EOL_String (Len : EOL_Length := 0) is record
235 Str : String (1 .. Len);
236 end record;
238 function Get_EOL
239 (Source : not null access String;
240 Start : Positive) return EOL_String;
241 -- Return the line terminator used in the passed string
243 procedure Parse_EOL
244 (Source : not null access String;
245 Ptr : in out Positive);
246 -- On return Source (Ptr) is the first character of the next line
247 -- or EOF. Source.all must be terminated by EOF.
249 function Parse_File (Num : File_Num) return Boolean;
250 -- Calls the GNAT compiler to parse the given source file and parses the
251 -- output using Parse_Offset_Info. Returns True if parse operation
252 -- completes, False if some system error (e.g. failure to read the
253 -- offset information) occurs.
255 procedure Parse_Offset_Info
256 (Chop_File : File_Num;
257 Source : not null access String);
258 -- Parses the output of the compiler indicating the offsets and names of
259 -- the compilation units in Chop_File.
261 procedure Parse_Token
262 (Source : not null access String;
263 Ptr : in out Positive;
264 Token_Ptr : out Positive);
265 -- Skips any separators and stores the start of the token in Token_Ptr.
266 -- Then stores the position of the next separator in Ptr. On return
267 -- Source (Token_Ptr .. Ptr - 1) is the token.
269 procedure Read_File
270 (FD : File_Descriptor;
271 Contents : out String_Access;
272 Success : out Boolean);
273 -- Reads file associated with FS into the newly allocated string Contents.
274 -- Success is true iff the number of bytes read is equal to the file size.
276 function Report_Duplicate_Units return Boolean;
277 -- Output messages about duplicate units in the input files in Unit.Table
278 -- Returns True if any duplicates found, False if no duplicates found.
280 function Scan_Arguments return Boolean;
281 -- Scan command line options and set global variables accordingly.
282 -- Also scan out file and directory arguments. Returns True if scan
283 -- was successful, and False if the scan fails for any reason.
285 procedure Usage;
286 -- Output message on standard output describing syntax of gnatchop command
288 procedure Warning_Msg (Message : String);
289 -- Output a warning message on standard error and update warning count
291 function Write_Chopped_Files (Input : File_Num) return Boolean;
292 -- Write all units that result from chopping the Input file
294 procedure Write_Config_File (Input : File_Num; U : Unit_Num);
295 -- Call to write configuration pragmas (append them to gnat.adc). Input is
296 -- the file number for the chop file and U identifies the unit entry for
297 -- the configuration pragmas.
299 function Get_Config_Pragmas
300 (Input : File_Num;
301 U : Unit_Num) return String_Access;
302 -- Call to read configuration pragmas from given unit entry, and return a
303 -- buffer containing the pragmas to be appended to following units. Input
304 -- is the file number for the chop file and U identifies the unit entry for
305 -- the configuration pragmas.
307 procedure Write_Source_Reference_Pragma
308 (Info : Unit_Info;
309 Line : Line_Num;
310 File : Stream_IO.File_Type;
311 EOL : EOL_String;
312 Success : in out Boolean);
313 -- If Success is True on entry, writes a source reference pragma using
314 -- the chop file from Info, and the given line number. On return Success
315 -- indicates whether the write succeeded. If Success is False on entry,
316 -- or if the global flag Source_References is False, then the call to
317 -- Write_Source_Reference_Pragma has no effect. EOL indicates the end
318 -- of line sequence to be written at the end of the pragma.
320 procedure Write_Unit
321 (Source : not null access String;
322 Num : Unit_Num;
323 TS_Time : OS_Time;
324 Write_BOM : Boolean;
325 Success : out Boolean);
326 -- Write one compilation unit of the source to file. Source is the pointer
327 -- to the input string, Num is the unit number, TS_Time is the timestamp,
328 -- Write_BOM is set True to write a UTF-8 BOM at the start of the file.
329 -- Success is set True unless the write attempt fails.
331 ---------
332 -- dup --
333 ---------
335 function dup (handle : File_Descriptor) return File_Descriptor is
336 begin
337 return File_Descriptor (System.CRTL.dup (int (handle)));
338 end dup;
340 ----------
341 -- dup2 --
342 ----------
344 function dup2 (from, to : File_Descriptor) return File_Descriptor is
345 begin
346 return File_Descriptor (System.CRTL.dup2 (int (from), int (to)));
347 end dup2;
349 ---------------
350 -- Error_Msg --
351 ---------------
353 procedure Error_Msg (Message : String; Warning : Boolean := False) is
354 begin
355 Put_Line (Standard_Error, Message);
357 if not Warning then
358 Set_Exit_Status (Failure);
360 if Exit_On_Error then
361 raise Types.Terminate_Program;
362 end if;
363 end if;
364 end Error_Msg;
366 -----------------
367 -- Files_Exist --
368 -----------------
370 function Files_Exist return Boolean is
371 Exists : Boolean := False;
373 begin
374 for SNum in 1 .. SUnit_Num (Unit.Last) loop
376 -- Only check and report for the last instance of duplicated files
378 if not Is_Duplicated (SNum) then
379 declare
380 Info : constant Unit_Info :=
381 Unit.Table (Sorted_Units.Table (SNum));
383 begin
384 if Is_Writable_File (Info.File_Name.all) then
385 Error_Msg (Info.File_Name.all
386 & " already exists, use -w to overwrite");
387 Exists := True;
388 end if;
389 end;
390 end if;
391 end loop;
393 return Exists;
394 end Files_Exist;
396 ------------------------
397 -- Get_Config_Pragmas --
398 ------------------------
400 function Get_Config_Pragmas
401 (Input : File_Num;
402 U : Unit_Num) return String_Access
404 Info : Unit_Info renames Unit.Table (U);
405 FD : File_Descriptor;
406 Name : aliased constant String :=
407 File.Table (Input).Name.all & ASCII.NUL;
408 Length : File_Offset;
409 Buffer : String_Access;
410 Result : String_Access;
412 Success : Boolean;
413 pragma Warnings (Off, Success);
415 begin
416 FD := Open_Read (Name'Address, Binary);
418 if FD = Invalid_FD then
419 Error_Msg ("cannot open " & File.Table (Input).Name.all);
420 return null;
421 end if;
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);
431 else
432 Length := Info.Length;
433 end if;
435 Result := new String'(Buffer (1 .. Length));
436 Close (FD);
437 return Result;
438 end Get_Config_Pragmas;
440 -------------
441 -- Get_EOL --
442 -------------
444 function Get_EOL
445 (Source : not null access String;
446 Start : Positive) return EOL_String
448 Ptr : Positive := Start;
449 First : Positive;
450 Last : Natural;
452 begin
453 -- Skip to end of line
455 while Source (Ptr) /= ASCII.CR and then
456 Source (Ptr) /= ASCII.LF and then
457 Source (Ptr) /= EOF
458 loop
459 Ptr := Ptr + 1;
460 end loop;
462 Last := Ptr;
464 if Source (Ptr) /= EOF then
466 -- Found CR or LF
468 First := Ptr;
470 else
471 First := Ptr + 1;
472 end if;
474 -- Recognize CR/LF
476 if Source (Ptr) = ASCII.CR and then Source (Ptr + 1) = ASCII.LF then
477 Last := First + 1;
478 end if;
480 return (Len => Last + 1 - First, Str => Source (First .. Last));
481 end Get_EOL;
483 -------------------
484 -- Is_Duplicated --
485 -------------------
487 function Is_Duplicated (U : SUnit_Num) return Boolean is
488 begin
489 return U < SUnit_Num (Unit.Last)
490 and then
491 Unit.Table (Sorted_Units.Table (U)).File_Name.all =
492 Unit.Table (Sorted_Units.Table (U + 1)).File_Name.all;
493 end Is_Duplicated;
495 -----------------------
496 -- Locate_Executable --
497 -----------------------
499 function Locate_Executable
500 (Program_Name : String;
501 Look_For_Prefix : Boolean := True) return String_Access
503 Gnatchop_Str : constant String := "gnatchop";
504 Current_Command : constant String := Normalize_Pathname (Command_Name);
505 End_Of_Prefix : Natural;
506 Start_Of_Prefix : Positive;
507 Start_Of_Suffix : Positive;
508 Result : String_Access;
510 begin
511 Start_Of_Prefix := Current_Command'First;
512 Start_Of_Suffix := Current_Command'Last + 1;
513 End_Of_Prefix := Start_Of_Prefix - 1;
515 if Look_For_Prefix then
517 -- Find Start_Of_Prefix
519 for J in reverse Current_Command'Range loop
520 if Current_Command (J) = '/' or else
521 Current_Command (J) = Directory_Separator or else
522 Current_Command (J) = ':'
523 then
524 Start_Of_Prefix := J + 1;
525 exit;
526 end if;
527 end loop;
529 -- Find End_Of_Prefix
531 for J in Start_Of_Prefix ..
532 Current_Command'Last - Gnatchop_Str'Length + 1
533 loop
534 if Current_Command (J .. J + Gnatchop_Str'Length - 1) =
535 Gnatchop_Str
536 then
537 End_Of_Prefix := J - 1;
538 exit;
539 end if;
540 end loop;
541 end if;
543 if End_Of_Prefix > Current_Command'First then
544 Start_Of_Suffix := End_Of_Prefix + Gnatchop_Str'Length + 1;
545 end if;
547 declare
548 Command : constant String :=
549 Current_Command (Start_Of_Prefix .. End_Of_Prefix)
550 & Program_Name
551 & Current_Command (Start_Of_Suffix ..
552 Current_Command'Last);
553 begin
554 Result := Locate_Exec_On_Path (Command);
556 if Result = null then
557 Error_Msg
558 (Command & ": installation problem, executable not found");
559 end if;
560 end;
562 return Result;
563 end Locate_Executable;
565 ---------------
566 -- Parse_EOL --
567 ---------------
569 procedure Parse_EOL
570 (Source : not null access String;
571 Ptr : in out Positive) is
572 begin
573 -- Skip to end of line
575 while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF
576 and then Source (Ptr) /= EOF
577 loop
578 Ptr := Ptr + 1;
579 end loop;
581 if Source (Ptr) /= EOF then
582 Ptr := Ptr + 1; -- skip CR or LF
583 end if;
585 -- Skip past CR/LF or LF/CR combination
587 if (Source (Ptr) = ASCII.CR or else Source (Ptr) = ASCII.LF)
588 and then Source (Ptr) /= Source (Ptr - 1)
589 then
590 Ptr := Ptr + 1;
591 end if;
592 end Parse_EOL;
594 ----------------
595 -- Parse_File --
596 ----------------
598 function Parse_File (Num : File_Num) return Boolean is
599 Chop_Name : constant String_Access := File.Table (Num).Name;
600 Save_Stdout : constant File_Descriptor := dup (Standout);
601 Offset_Name : Temp_File_Name;
602 Offset_FD : File_Descriptor := Invalid_FD;
603 Buffer : String_Access;
604 Success : Boolean;
605 Failure : exception;
607 begin
608 -- Display copy of GNAT command if verbose mode
610 if Verbose_Mode then
611 Put (Gnat_Cmd.all);
613 for J in 1 .. Gnat_Args'Length loop
614 Put (' ');
615 Put (Gnat_Args (J).all);
616 end loop;
618 Put (' ');
619 Put_Line (Chop_Name.all);
620 end if;
622 -- Create temporary file
624 Create_Temp_File (Offset_FD, Offset_Name);
626 if Offset_FD = Invalid_FD then
627 Error_Msg ("gnatchop: cannot create temporary file");
628 Close (Save_Stdout);
629 return False;
630 end if;
632 -- Redirect Stdout to this temporary file in the Unix way
634 if dup2 (Offset_FD, Standout) = Invalid_FD then
635 Error_Msg ("gnatchop: cannot redirect stdout to temporary file");
636 Close (Save_Stdout);
637 Close (Offset_FD);
638 return False;
639 end if;
641 -- Call Gnat on the source filename argument with special options
642 -- to generate offset information. If this special compilation completes
643 -- successfully then we can do the actual gnatchop operation.
645 Spawn (Gnat_Cmd.all, Gnat_Args.all & Chop_Name, Success);
647 if not Success then
648 Error_Msg (Chop_Name.all & ": parse errors detected");
649 Error_Msg (Chop_Name.all & ": chop may not be successful");
650 end if;
652 -- Restore stdout
654 if dup2 (Save_Stdout, Standout) = Invalid_FD then
655 Error_Msg ("gnatchop: cannot restore stdout");
656 end if;
658 -- Reopen the file to start reading from the beginning
660 Close (Offset_FD);
661 Close (Save_Stdout);
662 Offset_FD := Open_Read (Offset_Name'Address, Binary);
664 if Offset_FD = Invalid_FD then
665 Error_Msg ("gnatchop: cannot access offset info");
666 raise Failure;
667 end if;
669 Read_File (Offset_FD, Buffer, Success);
671 if not Success then
672 Error_Msg ("gnatchop: error reading offset info");
673 Close (Offset_FD);
674 raise Failure;
675 else
676 Parse_Offset_Info (Num, Buffer);
677 end if;
679 -- Close and delete temporary file
681 Close (Offset_FD);
682 Delete_File (Offset_Name'Address, Success);
684 return Success;
686 exception
687 when Failure | Types.Terminate_Program =>
688 if Offset_FD /= Invalid_FD then
689 Close (Offset_FD);
690 end if;
692 Delete_File (Offset_Name'Address, Success);
693 return False;
694 end Parse_File;
696 -----------------------
697 -- Parse_Offset_Info --
698 -----------------------
700 procedure Parse_Offset_Info
701 (Chop_File : File_Num;
702 Source : not null access String)
704 First_Unit : constant Unit_Num := Unit.Last + 1;
705 Bufferg : String_Access := null;
706 Parse_Ptr : File_Offset := Source'First;
707 Token_Ptr : File_Offset;
708 Info : Unit_Info;
710 function Match (Literal : String) return Boolean;
711 -- Checks if given string appears at the current Token_Ptr location
712 -- and if so, bumps Parse_Ptr past the token and returns True. If
713 -- the string is not present, sets Parse_Ptr to Token_Ptr and
714 -- returns False.
716 -----------
717 -- Match --
718 -----------
720 function Match (Literal : String) return Boolean is
721 begin
722 Parse_Token (Source, Parse_Ptr, Token_Ptr);
724 if Source'Last + 1 - Token_Ptr < Literal'Length
725 or else
726 Source (Token_Ptr .. Token_Ptr + Literal'Length - 1) /= Literal
727 then
728 Parse_Ptr := Token_Ptr;
729 return False;
730 end if;
732 Parse_Ptr := Token_Ptr + Literal'Length;
733 return True;
734 end Match;
736 -- Start of processing for Parse_Offset_Info
738 begin
739 loop
740 -- Set default values, should get changed for all
741 -- units/pragmas except for the last
743 Info.Chop_File := Chop_File;
744 Info.Length := 0;
746 -- Parse the current line of offset information into Info
747 -- and exit the loop if there are any errors or on EOF.
749 -- First case, parse a line in the following format:
751 -- Unit x (spec) line 7, file offset 142, [SR, ]file name x.ads
753 -- Note that the unit name can be an operator name in quotes.
754 -- This is of course illegal, but both GNAT and gnatchop handle
755 -- the case so that this error does not interfere with chopping.
757 -- The SR ir present indicates that a source reference pragma
758 -- was processed as part of this unit (and that therefore no
759 -- Source_Reference pragma should be generated.
761 if Match ("Unit") then
762 Parse_Token (Source, Parse_Ptr, Token_Ptr);
764 if Match ("(body)") then
765 Info.Kind := Unit_Body;
766 elsif Match ("(spec)") then
767 Info.Kind := Unit_Spec;
768 else
769 exit;
770 end if;
772 exit when not Match ("line");
773 Parse_Token (Source, Parse_Ptr, Token_Ptr);
774 Info.Start_Line := Line_Num'Value
775 (Source (Token_Ptr .. Parse_Ptr - 1));
777 exit when not Match ("file offset");
778 Parse_Token (Source, Parse_Ptr, Token_Ptr);
779 Info.Offset := File_Offset'Value
780 (Source (Token_Ptr .. Parse_Ptr - 1));
782 Info.SR_Present := Match ("SR, ");
784 exit when not Match ("file name");
785 Parse_Token (Source, Parse_Ptr, Token_Ptr);
786 Info.File_Name := new String'
787 (Directory.all & Source (Token_Ptr .. Parse_Ptr - 1));
788 Parse_EOL (Source, Parse_Ptr);
790 -- Second case, parse a line of the following form
792 -- Configuration pragmas at line 10, file offset 223
794 elsif Match ("Configuration pragmas at") then
795 Info.Kind := Config_Pragmas;
796 Info.File_Name := Config_File_Name;
798 exit when not Match ("line");
799 Parse_Token (Source, Parse_Ptr, Token_Ptr);
800 Info.Start_Line := Line_Num'Value
801 (Source (Token_Ptr .. Parse_Ptr - 1));
803 exit when not Match ("file offset");
804 Parse_Token (Source, Parse_Ptr, Token_Ptr);
805 Info.Offset := File_Offset'Value
806 (Source (Token_Ptr .. Parse_Ptr - 1));
808 Parse_EOL (Source, Parse_Ptr);
810 -- Third case, parse a line of the following form
812 -- Source_Reference pragma for file "filename"
814 -- This appears at the start of the file only, and indicates
815 -- the name to be used on any generated Source_Reference pragmas.
817 elsif Match ("Source_Reference pragma for file ") then
818 Parse_Token (Source, Parse_Ptr, Token_Ptr);
819 File.Table (Chop_File).SR_Name :=
820 new String'(Source (Token_Ptr + 1 .. Parse_Ptr - 2));
821 Parse_EOL (Source, Parse_Ptr);
822 goto Continue;
824 -- Unrecognized keyword or end of file
826 else
827 exit;
828 end if;
830 -- Store the data in the Info record in the Unit.Table
832 Unit.Increment_Last;
833 Unit.Table (Unit.Last) := Info;
835 -- If this is not the first unit from the file, calculate
836 -- the length of the previous unit as difference of the offsets
838 if Unit.Last > First_Unit then
839 Unit.Table (Unit.Last - 1).Length :=
840 Info.Offset - Unit.Table (Unit.Last - 1).Offset;
841 end if;
843 -- If not in compilation mode combine current unit with any
844 -- preceding configuration pragmas.
846 if not Compilation_Mode
847 and then Unit.Last > First_Unit
848 and then Unit.Table (Unit.Last - 1).Kind = Config_Pragmas
849 then
850 Info.Start_Line := Unit.Table (Unit.Last - 1).Start_Line;
851 Info.Offset := Unit.Table (Unit.Last - 1).Offset;
853 -- Delete the configuration pragma entry
855 Unit.Table (Unit.Last - 1) := Info;
856 Unit.Decrement_Last;
857 end if;
859 -- If in compilation mode, and previous entry is the initial
860 -- entry for the file and is for configuration pragmas, then
861 -- they are to be appended to every unit in the file.
863 if Compilation_Mode
864 and then Unit.Last = First_Unit + 1
865 and then Unit.Table (First_Unit).Kind = Config_Pragmas
866 then
867 Bufferg :=
868 Get_Config_Pragmas
869 (Unit.Table (Unit.Last - 1).Chop_File, First_Unit);
870 Unit.Table (Unit.Last - 1) := Info;
871 Unit.Decrement_Last;
872 end if;
874 Unit.Table (Unit.Last).Bufferg := Bufferg;
876 -- If in compilation mode, and this is not the first item,
877 -- combine configuration pragmas with previous unit, which
878 -- will cause an error message to be generated when the unit
879 -- is compiled.
881 if Compilation_Mode
882 and then Unit.Last > First_Unit
883 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
884 then
885 Unit.Decrement_Last;
886 end if;
888 <<Continue>>
889 null;
891 end loop;
893 -- Find out if the loop was exited prematurely because of
894 -- an error or if the EOF marker was found.
896 if Source (Parse_Ptr) /= EOF then
897 Error_Msg
898 (File.Table (Chop_File).Name.all & ": error parsing offset info");
899 return;
900 end if;
902 -- Handle case of a chop file consisting only of config pragmas
904 if Unit.Last = First_Unit
905 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
906 then
907 -- In compilation mode, we append such a file to gnat.adc
909 if Compilation_Mode then
910 Write_Config_File (Unit.Table (Unit.Last).Chop_File, First_Unit);
911 Unit.Decrement_Last;
913 -- In default (non-compilation) mode, this is invalid
915 else
916 Error_Msg
917 (File.Table (Chop_File).Name.all &
918 ": no units found (only pragmas)");
919 Unit.Decrement_Last;
920 end if;
921 end if;
923 -- Handle case of a chop file ending with config pragmas. This can
924 -- happen only in default non-compilation mode, since in compilation
925 -- mode such configuration pragmas are part of the preceding unit.
926 -- We simply concatenate such pragmas to the previous file which
927 -- will cause a compilation error, which is appropriate.
929 if Unit.Last > First_Unit
930 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
931 then
932 Unit.Decrement_Last;
933 end if;
934 end Parse_Offset_Info;
936 -----------------
937 -- Parse_Token --
938 -----------------
940 procedure Parse_Token
941 (Source : not null access String;
942 Ptr : in out Positive;
943 Token_Ptr : out Positive)
945 In_Quotes : Boolean := False;
947 begin
948 -- Skip separators
950 while Source (Ptr) = ' ' or else Source (Ptr) = ',' loop
951 Ptr := Ptr + 1;
952 end loop;
954 Token_Ptr := Ptr;
956 -- Find end-of-token
958 while (In_Quotes
959 or else not (Source (Ptr) = ' ' or else Source (Ptr) = ','))
960 and then Source (Ptr) >= ' '
961 loop
962 if Source (Ptr) = '"' then
963 In_Quotes := not In_Quotes;
964 end if;
966 Ptr := Ptr + 1;
967 end loop;
968 end Parse_Token;
970 ---------------
971 -- Read_File --
972 ---------------
974 procedure Read_File
975 (FD : File_Descriptor;
976 Contents : out String_Access;
977 Success : out Boolean)
979 Length : constant File_Offset := File_Offset (File_Length (FD));
980 -- Include room for EOF char
981 Buffer : String_Access := new String (1 .. Length + 1);
983 This_Read : Integer;
984 Read_Ptr : File_Offset := 1;
986 begin
988 loop
989 This_Read := Read (FD,
990 A => Buffer (Read_Ptr)'Address,
991 N => Length + 1 - Read_Ptr);
992 Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0);
993 exit when This_Read <= 0;
994 end loop;
996 Buffer (Read_Ptr) := EOF;
998 -- Comment needed for the following ???
999 -- Under what circumstances can the test fail ???
1000 -- What is copy doing in that case???
1002 if Read_Ptr = Length then
1003 Contents := Buffer;
1005 else
1006 Contents := new String (1 .. Read_Ptr);
1007 Contents.all := Buffer (1 .. Read_Ptr);
1008 Free (Buffer);
1009 end if;
1011 Success := Read_Ptr = Length + 1;
1012 end Read_File;
1014 ----------------------------
1015 -- Report_Duplicate_Units --
1016 ----------------------------
1018 function Report_Duplicate_Units return Boolean is
1019 US : SUnit_Num;
1020 U : Unit_Num;
1022 Duplicates : Boolean := False;
1024 begin
1025 US := 1;
1026 while US < SUnit_Num (Unit.Last) loop
1027 U := Sorted_Units.Table (US);
1029 if Is_Duplicated (US) then
1030 Duplicates := True;
1032 -- Move to last two versions of duplicated file to make it clearer
1033 -- to understand which file is retained in case of overwriting.
1035 while US + 1 < SUnit_Num (Unit.Last) loop
1036 exit when not Is_Duplicated (US + 1);
1037 US := US + 1;
1038 end loop;
1040 U := Sorted_Units.Table (US);
1042 if Overwrite_Files then
1043 Warning_Msg (Unit.Table (U).File_Name.all
1044 & " is duplicated (all but last will be skipped)");
1046 elsif Unit.Table (U).Chop_File =
1047 Unit.Table (Sorted_Units.Table (US + 1)).Chop_File
1048 then
1049 Error_Msg (Unit.Table (U).File_Name.all
1050 & " is duplicated in "
1051 & File.Table (Unit.Table (U).Chop_File).Name.all);
1053 else
1054 Error_Msg (Unit.Table (U).File_Name.all
1055 & " in "
1056 & File.Table (Unit.Table (U).Chop_File).Name.all
1057 & " is duplicated in "
1058 & File.Table
1059 (Unit.Table
1060 (Sorted_Units.Table (US + 1)).Chop_File).Name.all);
1061 end if;
1062 end if;
1064 US := US + 1;
1065 end loop;
1067 if Duplicates and not Overwrite_Files then
1068 Put_Line ("use -w to overwrite files and keep last version");
1069 end if;
1071 return Duplicates;
1072 end Report_Duplicate_Units;
1074 --------------------
1075 -- Scan_Arguments --
1076 --------------------
1078 function Scan_Arguments return Boolean is
1079 Kset : Boolean := False;
1080 -- Set true if -k switch found
1082 begin
1083 Initialize_Option_Scan;
1085 -- Scan options first
1087 loop
1088 case Getopt ("c gnat? h k? p q r v w x -GCC=!") is
1089 when ASCII.NUL =>
1090 exit;
1092 when '-' =>
1093 Gcc := new String'(Parameter);
1094 Gcc_Set := True;
1096 when 'c' =>
1097 Compilation_Mode := True;
1099 when 'g' =>
1100 Gnat_Args :=
1101 new Argument_List'(Gnat_Args.all &
1102 new String'("-gnat" & Parameter));
1104 when 'h' =>
1105 Usage;
1106 raise Types.Terminate_Program;
1108 when 'k' =>
1109 declare
1110 Param : String_Access := new String'(Parameter);
1112 begin
1113 if Param.all /= "" then
1114 for J in Param'Range loop
1115 if Param (J) not in '0' .. '9' then
1116 Error_Msg ("-k# requires numeric parameter");
1117 return False;
1118 end if;
1119 end loop;
1121 else
1122 Param := new String'("8");
1123 end if;
1125 Gnat_Args :=
1126 new Argument_List'(Gnat_Args.all &
1127 new String'("-gnatk" & Param.all));
1128 Kset := True;
1129 end;
1131 when 'p' =>
1132 Preserve_Mode := True;
1134 when 'q' =>
1135 Quiet_Mode := True;
1137 when 'r' =>
1138 Source_References := True;
1140 when 'v' =>
1141 Verbose_Mode := True;
1142 Display_Version ("GNATCHOP", "1998");
1144 when 'w' =>
1145 Overwrite_Files := True;
1147 when 'x' =>
1148 Exit_On_Error := True;
1150 when others =>
1151 null;
1152 end case;
1153 end loop;
1155 if not Kset and then Maximum_File_Name_Length > 0 then
1157 -- If this system has restricted filename lengths, tell gnat1
1158 -- about them, removing the leading blank from the image string.
1160 Gnat_Args :=
1161 new Argument_List'(Gnat_Args.all
1162 & new String'("-gnatk"
1163 & Maximum_File_Name_Length_String
1164 (Maximum_File_Name_Length_String'First + 1
1165 .. Maximum_File_Name_Length_String'Last)));
1166 end if;
1168 -- Scan file names
1170 loop
1171 declare
1172 S : constant String := Get_Argument (Do_Expansion => True);
1174 begin
1175 exit when S = "";
1176 File.Increment_Last;
1177 File.Table (File.Last).Name := new String'(S);
1178 File.Table (File.Last).SR_Name := null;
1179 end;
1180 end loop;
1182 -- Case of more than one file where last file is a directory
1184 if File.Last > 1
1185 and then Is_Directory (File.Table (File.Last).Name.all)
1186 then
1187 Directory := File.Table (File.Last).Name;
1188 File.Decrement_Last;
1190 -- Make sure Directory is terminated with a directory separator,
1191 -- so we can generate the output by just appending a filename.
1193 if Directory (Directory'Last) /= Directory_Separator
1194 and then Directory (Directory'Last) /= '/'
1195 then
1196 Directory := new String'(Directory.all & Directory_Separator);
1197 end if;
1199 -- At least one filename must be given
1201 elsif File.Last = 0 then
1202 if Argument_Count = 0 then
1203 Usage;
1204 else
1205 Try_Help;
1206 end if;
1208 return False;
1210 -- No directory given, set directory to null, so that we can just
1211 -- concatenate the directory name to the file name unconditionally.
1213 else
1214 Directory := new String'("");
1215 end if;
1217 -- Finally check all filename arguments
1219 for File_Num in 1 .. File.Last loop
1220 declare
1221 F : constant String := File.Table (File_Num).Name.all;
1223 begin
1224 if Is_Directory (F) then
1225 Error_Msg (F & " is a directory, cannot be chopped");
1226 return False;
1228 elsif not Is_Regular_File (F) then
1229 Error_Msg (F & " not found");
1230 return False;
1231 end if;
1232 end;
1233 end loop;
1235 return True;
1237 exception
1238 when Invalid_Switch =>
1239 Error_Msg ("invalid switch " & Full_Switch);
1240 return False;
1242 when Invalid_Parameter =>
1243 Error_Msg ("-k switch requires numeric parameter");
1244 return False;
1245 end Scan_Arguments;
1247 ----------------
1248 -- Sort_Units --
1249 ----------------
1251 procedure Sort_Units is
1253 procedure Move (From : Natural; To : Natural);
1254 -- Procedure used to sort the unit list
1255 -- Unit.Table (To) := Unit_List (From); used by sort
1257 function Lt (Left, Right : Natural) return Boolean;
1258 -- Compares Left and Right units based on file name (first),
1259 -- Chop_File (second) and Offset (third). This ordering is
1260 -- important to keep the last version in case of duplicate files.
1262 package Unit_Sort is new GNAT.Heap_Sort_G (Move, Lt);
1263 -- Used for sorting on filename to detect duplicates
1265 --------
1266 -- Lt --
1267 --------
1269 function Lt (Left, Right : Natural) return Boolean is
1270 L : Unit_Info renames
1271 Unit.Table (Sorted_Units.Table (SUnit_Num (Left)));
1273 R : Unit_Info renames
1274 Unit.Table (Sorted_Units.Table (SUnit_Num (Right)));
1276 begin
1277 return L.File_Name.all < R.File_Name.all
1278 or else (L.File_Name.all = R.File_Name.all
1279 and then (L.Chop_File < R.Chop_File
1280 or else (L.Chop_File = R.Chop_File
1281 and then L.Offset < R.Offset)));
1282 end Lt;
1284 ----------
1285 -- Move --
1286 ----------
1288 procedure Move (From : Natural; To : Natural) is
1289 begin
1290 Sorted_Units.Table (SUnit_Num (To)) :=
1291 Sorted_Units.Table (SUnit_Num (From));
1292 end Move;
1294 -- Start of processing for Sort_Units
1296 begin
1297 Sorted_Units.Set_Last (SUnit_Num (Unit.Last));
1299 for J in 1 .. Unit.Last loop
1300 Sorted_Units.Table (SUnit_Num (J)) := J;
1301 end loop;
1303 -- Sort Unit.Table, using Sorted_Units.Table (0) as scratch
1305 Unit_Sort.Sort (Natural (Unit.Last));
1307 -- Set the Sorted_Index fields in the unit tables
1309 for J in 1 .. SUnit_Num (Unit.Last) loop
1310 Unit.Table (Sorted_Units.Table (J)).Sorted_Index := J;
1311 end loop;
1312 end Sort_Units;
1314 -----------
1315 -- Usage --
1316 -----------
1318 procedure Usage is
1319 begin
1320 Put_Line
1321 ("Usage: gnatchop [-c] [-h] [-k#] " &
1322 "[-r] [-p] [-q] [-v] [-w] [-x] [--GCC=xx] file [file ...] [dir]");
1324 New_Line;
1326 Display_Usage_Version_And_Help;
1328 Put_Line
1329 (" -c compilation mode, configuration pragmas " &
1330 "follow RM rules");
1332 Put_Line
1333 (" -gnatxxx passes the -gnatxxx switch to gnat parser");
1335 Put_Line
1336 (" -h help: output this usage information");
1338 Put_Line
1339 (" -k# krunch file names of generated files to " &
1340 "no more than # characters");
1342 Put_Line
1343 (" -k krunch file names of generated files to " &
1344 "no more than 8 characters");
1346 Put_Line
1347 (" -p preserve time stamp, output files will " &
1348 "have same stamp as input");
1350 Put_Line
1351 (" -q quiet mode, no output of generated file " &
1352 "names");
1354 Put_Line
1355 (" -r generate Source_Reference pragmas refer" &
1356 "encing original source file");
1358 Put_Line
1359 (" -v verbose mode, output version and generat" &
1360 "ed commands");
1362 Put_Line
1363 (" -w overwrite existing filenames");
1365 Put_Line
1366 (" -x exit on error");
1368 Put_Line
1369 (" --GCC=xx specify the path of the gnat parser to be used");
1371 New_Line;
1372 Put_Line
1373 (" file... list of source files to be chopped");
1375 Put_Line
1376 (" dir directory location for split files (defa" &
1377 "ult = current directory)");
1378 end Usage;
1380 -----------------
1381 -- Warning_Msg --
1382 -----------------
1384 procedure Warning_Msg (Message : String) is
1385 begin
1386 Warning_Count := Warning_Count + 1;
1387 Put_Line (Standard_Error, "warning: " & Message);
1388 end Warning_Msg;
1390 -------------------------
1391 -- Write_Chopped_Files --
1392 -------------------------
1394 function Write_Chopped_Files (Input : File_Num) return Boolean is
1395 Name : aliased constant String :=
1396 File.Table (Input).Name.all & ASCII.NUL;
1397 FD : File_Descriptor;
1398 Buffer : String_Access;
1399 Success : Boolean;
1400 TS_Time : OS_Time;
1402 BOM_Present : Boolean;
1403 BOM : BOM_Kind;
1404 -- Record presence of UTF8 BOM in input
1406 begin
1407 FD := Open_Read (Name'Address, Binary);
1408 TS_Time := File_Time_Stamp (FD);
1410 if FD = Invalid_FD then
1411 Error_Msg ("cannot open " & File.Table (Input).Name.all);
1412 return False;
1413 end if;
1415 Read_File (FD, Buffer, Success);
1417 if not Success then
1418 Error_Msg ("cannot read " & File.Table (Input).Name.all);
1419 Close (FD);
1420 return False;
1421 end if;
1423 if not Quiet_Mode then
1424 Put_Line ("splitting " & File.Table (Input).Name.all & " into:");
1425 end if;
1427 -- Test for presence of BOM
1429 Read_BOM (Buffer.all, BOM_Length, BOM, XML_Support => False);
1430 BOM_Present := BOM /= Unknown;
1432 -- Only chop those units that come from this file
1434 for Unit_Number in 1 .. Unit.Last loop
1435 if Unit.Table (Unit_Number).Chop_File = Input then
1436 Write_Unit
1437 (Source => Buffer,
1438 Num => Unit_Number,
1439 TS_Time => TS_Time,
1440 Write_BOM => BOM_Present and then Unit_Number /= 1,
1441 Success => Success);
1442 exit when not Success;
1443 end if;
1444 end loop;
1446 Close (FD);
1447 return Success;
1448 end Write_Chopped_Files;
1450 -----------------------
1451 -- Write_Config_File --
1452 -----------------------
1454 procedure Write_Config_File (Input : File_Num; U : Unit_Num) is
1455 FD : File_Descriptor;
1456 Name : aliased constant String := "gnat.adc" & ASCII.NUL;
1457 Buffer : String_Access;
1458 Success : Boolean;
1459 Append : Boolean;
1460 Buffera : String_Access;
1461 Bufferl : Natural;
1463 begin
1464 Write_gnat_adc := True;
1465 FD := Open_Read_Write (Name'Address, Binary);
1467 if FD = Invalid_FD then
1468 FD := Create_File (Name'Address, Binary);
1469 Append := False;
1471 if not Quiet_Mode then
1472 Put_Line ("writing configuration pragmas from " &
1473 File.Table (Input).Name.all & " to gnat.adc");
1474 end if;
1476 else
1477 Append := True;
1479 if not Quiet_Mode then
1480 Put_Line
1481 ("appending configuration pragmas from " &
1482 File.Table (Input).Name.all & " to gnat.adc");
1483 end if;
1484 end if;
1486 Success := FD /= Invalid_FD;
1488 if not Success then
1489 Error_Msg ("cannot create gnat.adc");
1490 return;
1491 end if;
1493 -- In append mode, acquire existing gnat.adc file
1495 if Append then
1496 Read_File (FD, Buffera, Success);
1498 if not Success then
1499 Error_Msg ("cannot read gnat.adc");
1500 return;
1501 end if;
1503 -- Find location of EOF byte if any to exclude from append
1505 Bufferl := 1;
1506 while Bufferl <= Buffera'Last
1507 and then Buffera (Bufferl) /= EOF
1508 loop
1509 Bufferl := Bufferl + 1;
1510 end loop;
1512 Bufferl := Bufferl - 1;
1513 Close (FD);
1515 -- Write existing gnat.adc to new gnat.adc file
1517 FD := Create_File (Name'Address, Binary);
1518 Success := Write (FD, Buffera (1)'Address, Bufferl) = Bufferl;
1520 if not Success then
1521 Error_Msg ("error writing gnat.adc");
1522 return;
1523 end if;
1524 end if;
1526 Buffer := Get_Config_Pragmas (Input, U);
1528 if Buffer /= null then
1529 Success := Write (FD, Buffer.all'Address, Buffer'Length) =
1530 Buffer'Length;
1532 if not Success then
1533 Error_Msg ("disk full writing gnat.adc");
1534 return;
1535 end if;
1536 end if;
1538 Close (FD);
1539 end Write_Config_File;
1541 -----------------------------------
1542 -- Write_Source_Reference_Pragma --
1543 -----------------------------------
1545 procedure Write_Source_Reference_Pragma
1546 (Info : Unit_Info;
1547 Line : Line_Num;
1548 File : Stream_IO.File_Type;
1549 EOL : EOL_String;
1550 Success : in out Boolean)
1552 FTE : File_Entry renames Gnatchop.File.Table (Info.Chop_File);
1553 Nam : String_Access;
1555 begin
1556 if Success and then Source_References and then not Info.SR_Present then
1557 if FTE.SR_Name /= null then
1558 Nam := FTE.SR_Name;
1559 else
1560 Nam := FTE.Name;
1561 end if;
1563 declare
1564 Reference : String :=
1565 "pragma Source_Reference (000000, """
1566 & Nam.all & """);" & EOL.Str;
1568 Pos : Positive := Reference'First;
1569 Lin : Line_Num := Line;
1571 begin
1572 while Reference (Pos + 1) /= ',' loop
1573 Pos := Pos + 1;
1574 end loop;
1576 while Reference (Pos) = '0' loop
1577 Reference (Pos) := Character'Val
1578 (Character'Pos ('0') + Lin mod 10);
1579 Lin := Lin / 10;
1580 Pos := Pos - 1;
1581 end loop;
1583 -- Assume there are enough zeroes for any program length
1585 pragma Assert (Lin = 0);
1587 begin
1588 String'Write (Stream_IO.Stream (File), Reference);
1589 Success := True;
1590 exception
1591 when others =>
1592 Success := False;
1593 end;
1594 end;
1595 end if;
1596 end Write_Source_Reference_Pragma;
1598 ----------------
1599 -- Write_Unit --
1600 ----------------
1602 procedure Write_Unit
1603 (Source : not null access String;
1604 Num : Unit_Num;
1605 TS_Time : OS_Time;
1606 Write_BOM : Boolean;
1607 Success : out Boolean)
1610 procedure OS_Filename
1611 (Name : String;
1612 W_Name : Wide_String;
1613 OS_Name : Address;
1614 N_Length : access Natural;
1615 Encoding : Address;
1616 E_Length : access Natural);
1617 pragma Import (C, OS_Filename, "__gnat_os_filename");
1618 -- Returns in OS_Name the proper name for the OS when used with the
1619 -- returned Encoding value. For example on Windows this will return the
1620 -- UTF-8 encoded name into OS_Name and set Encoding to encoding=utf8
1621 -- (the form parameter for Stream_IO).
1623 -- Name is the filename and W_Name the same filename in Unicode 16 bits
1624 -- (this corresponds to Win32 Unicode ISO/IEC 10646). N_Length/E_Length
1625 -- are the length returned in OS_Name/Encoding respectively.
1627 Info : Unit_Info renames Unit.Table (Num);
1628 Name : aliased constant String := Info.File_Name.all & ASCII.NUL;
1629 W_Name : aliased constant Wide_String := To_Wide_String (Name);
1630 EOL : constant EOL_String :=
1631 Get_EOL (Source, Source'First + Info.Offset);
1632 OS_Name : aliased String (1 .. Name'Length * 2);
1633 O_Length : aliased Natural := OS_Name'Length;
1634 Encoding : aliased String (1 .. 64);
1635 E_Length : aliased Natural := Encoding'Length;
1636 Length : File_Offset;
1638 begin
1639 -- Skip duplicated files
1641 if Is_Duplicated (Info.Sorted_Index) then
1642 Put_Line (" " & Info.File_Name.all & " skipped");
1643 Success := Overwrite_Files;
1644 return;
1645 end if;
1647 -- Get OS filename
1649 OS_Filename
1650 (Name, W_Name,
1651 OS_Name'Address, O_Length'Access,
1652 Encoding'Address, E_Length'Access);
1654 declare
1655 E_Name : constant String := OS_Name (1 .. O_Length);
1656 OS_Encoding : constant String := Encoding (1 .. E_Length);
1657 File : Stream_IO.File_Type;
1659 begin
1660 begin
1661 if not Overwrite_Files and then Exists (E_Name) then
1662 raise Stream_IO.Name_Error;
1663 else
1664 Stream_IO.Create
1665 (File, Stream_IO.Out_File, E_Name, OS_Encoding);
1666 Success := True;
1667 end if;
1669 exception
1670 when Stream_IO.Name_Error | Stream_IO.Use_Error =>
1671 Error_Msg ("cannot create " & Info.File_Name.all);
1672 return;
1673 end;
1675 -- A length of 0 indicates that the rest of the file belongs to
1676 -- this unit. The actual length must be calculated now. Take into
1677 -- account that the last character (EOF) must not be written.
1679 if Info.Length = 0 then
1680 Length := Source'Last - (Source'First + Info.Offset);
1681 else
1682 Length := Info.Length;
1683 end if;
1685 -- Write BOM if required
1687 if Write_BOM then
1688 String'Write
1689 (Stream_IO.Stream (File),
1690 Source.all (Source'First .. Source'First + BOM_Length - 1));
1691 end if;
1693 -- Prepend configuration pragmas if necessary
1695 if Success and then Info.Bufferg /= null then
1696 Write_Source_Reference_Pragma (Info, 1, File, EOL, Success);
1697 String'Write (Stream_IO.Stream (File), Info.Bufferg.all);
1698 end if;
1700 Write_Source_Reference_Pragma
1701 (Info, Info.Start_Line, File, EOL, Success);
1703 if Success then
1704 begin
1705 String'Write
1706 (Stream_IO.Stream (File),
1707 Source (Source'First + Info.Offset ..
1708 Source'First + Info.Offset + Length - 1));
1709 exception
1710 when Stream_IO.Use_Error | Stream_IO.Device_Error =>
1711 Error_Msg ("disk full writing " & Info.File_Name.all);
1712 return;
1713 end;
1714 end if;
1716 if not Quiet_Mode then
1717 Put_Line (" " & Info.File_Name.all);
1718 end if;
1720 Stream_IO.Close (File);
1722 if Preserve_Mode then
1723 Set_File_Last_Modify_Time_Stamp (E_Name, TS_Time);
1724 end if;
1725 end;
1726 end Write_Unit;
1728 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
1730 -- Start of processing for gnatchop
1732 begin
1733 -- Add the directory where gnatchop is invoked in front of the path, if
1734 -- gnatchop is invoked with directory information.
1736 declare
1737 Command : constant String := Command_Name;
1739 begin
1740 for Index in reverse Command'Range loop
1741 if Command (Index) = Directory_Separator then
1742 declare
1743 Absolute_Dir : constant String :=
1744 Normalize_Pathname
1745 (Command (Command'First .. Index));
1746 PATH : constant String :=
1747 Absolute_Dir
1748 & Path_Separator
1749 & Getenv ("PATH").all;
1750 begin
1751 Setenv ("PATH", PATH);
1752 end;
1754 exit;
1755 end if;
1756 end loop;
1757 end;
1759 -- Process command line options and initialize global variables
1761 -- First, scan to detect --version and/or --help
1763 Check_Version_And_Help ("GNATCHOP", "1998");
1765 if not Scan_Arguments then
1766 Set_Exit_Status (Failure);
1767 return;
1768 end if;
1770 -- Check presence of required executables
1772 Gnat_Cmd := Locate_Executable (Gcc.all, not Gcc_Set);
1774 if Gnat_Cmd = null then
1775 goto No_Files_Written;
1776 end if;
1778 -- First parse all files and read offset information
1780 for Num in 1 .. File.Last loop
1781 if not Parse_File (Num) then
1782 goto No_Files_Written;
1783 end if;
1784 end loop;
1786 -- Check if any units have been found (assumes non-empty Unit.Table)
1788 if Unit.Last = 0 then
1789 if not Write_gnat_adc then
1790 Error_Msg ("no compilation units found", Warning => True);
1791 end if;
1793 goto No_Files_Written;
1794 end if;
1796 Sort_Units;
1798 -- Check if any duplicate files would be created. If so, emit a warning if
1799 -- Overwrite_Files is true, otherwise generate an error.
1801 if Report_Duplicate_Units and then not Overwrite_Files then
1802 goto No_Files_Written;
1803 end if;
1805 -- Check if any files exist, if so do not write anything Because all files
1806 -- have been parsed and checked already, there won't be any duplicates
1808 if not Overwrite_Files and then Files_Exist then
1809 goto No_Files_Written;
1810 end if;
1812 -- After this point, all source files are read in succession and chopped
1813 -- into their destination files.
1815 -- Source_File_Name pragmas are handled as logical file 0 so write it first
1817 for F in 1 .. File.Last loop
1818 if not Write_Chopped_Files (F) then
1819 Set_Exit_Status (Failure);
1820 return;
1821 end if;
1822 end loop;
1824 if Warning_Count > 0 then
1825 declare
1826 Warnings_Msg : constant String := Warning_Count'Img & " warning(s)";
1827 begin
1828 Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last), Warning => True);
1829 end;
1830 end if;
1832 return;
1834 <<No_Files_Written>>
1836 -- Special error exit for all situations where no files have
1837 -- been written.
1839 if not Write_gnat_adc then
1840 Error_Msg ("no source files written", Warning => True);
1841 end if;
1843 return;
1845 exception
1846 when Types.Terminate_Program =>
1847 null;
1849 end Gnatchop;