projects / gcc.git / blob
? search:


6d444c1fb825692ae7435915fdcd56e19685ebd2
[gcc.git] / gcc / ada / gnatchop.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T C H O P --
6 -- --
7 -- B o d y --
8 -- --
9 -- $Revision: 1.1 $
10 -- --
11 -- Copyright (C) 1998-2001 Ada Core Technologies, Inc. --
12 -- --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
23 -- --
24 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
25 -- --
26 ------------------------------------------------------------------------------
27
28 with Ada.Command_Line; use Ada.Command_Line;
29 with Ada.Text_IO; use Ada.Text_IO;
30
31 with GNAT.Command_Line; use GNAT.Command_Line;
32 with GNAT.OS_Lib; use GNAT.OS_Lib;
33 with GNAT.Heap_Sort_G;
34 with GNAT.Table;
35
36 with Gnatvsn;
37 with Hostparm;
38
39 procedure Gnatchop is
40
41 Cwrite : constant String :=
42 "GNATCHOP " &
43 Gnatvsn.Gnat_Version_String &
44 " Copyright 1998-2000, Ada Core Technologies Inc.";
45
46 Terminate_Program : exception;
47 -- Used to terminate execution immediately
48
49 Config_File_Name : constant String_Access := new String'("gnat.adc");
50 -- The name of the file holding the GNAT configuration pragmas
51
52 Gnat_Cmd : String_Access;
53 -- Command to execute the GNAT compiler
54
55 Gnat_Args : Argument_List_Access := new Argument_List'
56 (new String'("-c"), new String'("-x"), new String'("ada"),
57 new String'("-gnats"), new String'("-gnatu"));
58 -- Arguments used in Gnat_Cmd call
59
60 EOF : constant Character := Character'Val (26);
61 -- Special character to signal end of file. Not required in input
62 -- files, but properly treated if present. Not generated in output
63 -- files except as a result of copying input file.
64
65 --------------------
66 -- File arguments --
67 --------------------
68
69 subtype File_Num is Natural;
70 subtype File_Offset is Natural;
71
72 type File_Entry is record
73 Name : String_Access;
74 -- Name of chop file or directory
75
76 SR_Name : String_Access;
77 -- Null unless the chop file starts with a source reference pragma
78 -- in which case this field points to the file name from this pragma.
79 end record;
80
81 package File is new GNAT.Table
82 (Table_Component_Type => File_Entry,
83 Table_Index_Type => File_Num,
84 Table_Low_Bound => 1,
85 Table_Initial => 100,
86 Table_Increment => 100);
87
88 Directory : String_Access;
89 -- Record name of directory, or a null string if no directory given
90
91 Compilation_Mode : Boolean := False;
92 Overwrite_Files : Boolean := False;
93 Quiet_Mode : Boolean := False;
94 Source_References : Boolean := False;
95 Verbose_Mode : Boolean := False;
96 Exit_On_Error : Boolean := False;
97 -- Global options
98
99 Write_gnat_adc : Boolean := False;
100 -- Gets set true if we append to gnat.adc or create a new gnat.adc.
101 -- Used to inhibit complaint about no units generated.
102
103 ---------------
104 -- Unit list --
105 ---------------
106
107 type Line_Num is new Natural;
108 -- Line number (for source reference pragmas)
109
110 type Unit_Count_Type is new Integer;
111 subtype Unit_Num is Unit_Count_Type range 1 .. Unit_Count_Type'Last;
112 -- Used to refer to unit number in unit table
113
114 type SUnit_Num is new Integer;
115 -- Used to refer to entry in sorted units table. Note that entry
116 -- zero is only for use by Heapsort, and is not otherwise referenced.
117
118 type Unit_Kind is (Unit_Spec, Unit_Body, Config_Pragmas);
119
120 -- Structure to contain all necessary information for one unit.
121 -- Entries are also temporarily used to record config pragma sequences.
122
123 type Unit_Info is record
124 File_Name : String_Access;
125 -- File name from GNAT output line
126
127 Chop_File : File_Num;
128 -- File number in chop file sequence
129
130 Start_Line : Line_Num;
131 -- Line number from GNAT output line
132
133 Offset : File_Offset;
134 -- Offset name from GNAT output line
135
136 SR_Present : Boolean;
137 -- Set True if SR parameter present
138
139 Length : File_Offset;
140 -- A length of 0 means that the Unit is the last one in the file
141
142 Kind : Unit_Kind;
143 -- Indicates kind of unit
144
145 Sorted_Index : SUnit_Num;
146 -- Index of unit in sorted unit list
147
148 Bufferg : String_Access;
149 -- Pointer to buffer containing configuration pragmas to be
150 -- prepended. Null if no pragmas to be prepended.
151
152 end record;
153
154 -- The following table stores the unit offset information
155
156 package Unit is new GNAT.Table
157 (Table_Component_Type => Unit_Info,
158 Table_Index_Type => Unit_Count_Type,
159 Table_Low_Bound => 1,
160 Table_Initial => 500,
161 Table_Increment => 100);
162
163 -- The following table is used as a sorted index to the Unit.Table.
164 -- The entries in Unit.Table are not moved, instead we just shuffle
165 -- the entries in Sorted_Units. Note that the zeroeth entry in this
166 -- table is used by GNAT.Heap_Sort_G.
167
168 package Sorted_Units is new GNAT.Table
169 (Table_Component_Type => Unit_Num,
170 Table_Index_Type => SUnit_Num,
171 Table_Low_Bound => 0,
172 Table_Initial => 500,
173 Table_Increment => 100);
174
175 function Is_Duplicated (U : SUnit_Num) return Boolean;
176 -- Returns true if U is duplicated by a later unit.
177 -- Note that this function returns false for the last entry.
178
179 procedure Sort_Units;
180 -- Sort units and set up sorted unit table.
181
182 ----------------------
183 -- File_Descriptors --
184 ----------------------
185
186 function dup (handle : File_Descriptor) return File_Descriptor;
187 function dup2 (from, to : File_Descriptor) return File_Descriptor;
188 -- File descriptor based functions needed for redirecting stdin/stdout
189
190 pragma Import (C, dup, "dup");
191 pragma Import (C, dup2, "dup2");
192
193 ---------------------
194 -- Local variables --
195 ---------------------
196
197 Warning_Count : Natural := 0;
198 -- Count of warnings issued so far
199
200 -----------------------
201 -- Local subprograms --
202 -----------------------
203
204 procedure Error_Msg (Message : String);
205 -- Produce an error message on standard error output
206
207 function Files_Exist return Boolean;
208 -- Check Unit.Table for possible file names that already exist
209 -- in the file system. Returns true if files exist, False otherwise
210
211 function Get_Maximum_File_Name_Length return Integer;
212 pragma Import (C, Get_Maximum_File_Name_Length,
213 "__gnat_get_maximum_file_name_length");
214 -- Function to get maximum file name length for system
215
216 Maximum_File_Name_Length : constant Integer := Get_Maximum_File_Name_Length;
217 Maximum_File_Name_Length_String : constant String :=
218 Integer'Image
219 (Maximum_File_Name_Length);
220
221 function Locate_Executable (Program_Name : String) return String_Access;
222 -- Locate executable for given program name. This takes into account
223 -- the target-prefix of the current command.
224
225 subtype EOL_Length is Natural range 0 .. 2;
226 -- Possible lengths of end of line sequence
227
228 type EOL_String (Len : EOL_Length := 0) is record
229 Str : String (1 .. Len);
230 end record;
231
232 function Get_EOL
233 (Source : access String;
234 Start : Positive)
235 return EOL_String;
236 -- Return the line terminator used in the passed string
237
238 procedure Parse_EOL (Source : access String; Ptr : in out Positive);
239 -- On return Source (Ptr) is the first character of the next line
240 -- or EOF. Source.all must be terminated by EOF.
241
242 function Parse_File (Num : File_Num) return Boolean;
243 -- Calls the GNAT compiler to parse the given source file and parses the
244 -- output using Parse_Offset_Info. Returns True if parse operation
245 -- completes, False if some system error (e.g. failure to read the
246 -- offset information) occurs.
247
248 procedure Parse_Offset_Info (Chop_File : File_Num; Source : access String);
249 -- Parses the output of the compiler indicating the offsets
250 -- and names of the compilation units in Chop_File.
251
252 procedure Parse_Token
253 (Source : access String;
254 Ptr : in out Positive;
255 Token_Ptr : out Positive);
256 -- Skips any separators and stores the start of the token in Token_Ptr.
257 -- Then stores the position of the next separator in Ptr.
258 -- On return Source (Token_Ptr .. Ptr - 1) is the token.
259
260 procedure Read_File
261 (FD : File_Descriptor;
262 Contents : out String_Access;
263 Success : out Boolean);
264 -- Reads file associated with FS into the newly allocated
265 -- string Contents.
266 -- [VMS] Success is true iff the number of bytes read is less than or
267 -- equal to the file size.
268 -- [Other] Success is true iff the number of bytes read is equal to
269 -- the file size.
270
271 function Report_Duplicate_Units return Boolean;
272 -- Output messages about duplicate units in the input files in Unit.Table
273 -- Returns True if any duplicates found, Fals if no duplicates found.
274
275 function Scan_Arguments return Boolean;
276 -- Scan command line options and set global variables accordingly.
277 -- Also scan out file and directory arguments. Returns True if scan
278 -- was successful, and False if the scan fails for any reason.
279
280 procedure Usage;
281 -- Output message on standard output describing syntax of gnatchop command
282
283 procedure Warning_Msg (Message : String);
284 -- Output a warning message on standard error and update warning count
285
286 function Write_Chopped_Files (Input : File_Num) return Boolean;
287 -- Write all units that result from chopping the Input file
288
289 procedure Write_Config_File (Input : File_Num; U : Unit_Num);
290 -- Call to write configuration pragmas (append them to gnat.adc)
291 -- Input is the file number for the chop file and U identifies the
292 -- unit entry for the configuration pragmas.
293
294 function Get_Config_Pragmas
295 (Input : File_Num;
296 U : Unit_Num)
297 return String_Access;
298 -- Call to read configuration pragmas from given unit entry, and
299 -- return a buffer containing the pragmas to be appended to
300 -- following units. Input is the file number for the chop file and
301 -- U identifies the unit entry for the configuration pragmas.
302
303 procedure Write_Source_Reference_Pragma
304 (Info : Unit_Info;
305 Line : Line_Num;
306 FD : File_Descriptor;
307 EOL : EOL_String;
308 Success : in out Boolean);
309 -- If Success is True on entry, writes a source reference pragma using
310 -- the chop file from Info, and the given line number. On return Sucess
311 -- indicates whether the write succeeded. If Success is False on entry,
312 -- or if the global flag Source_References is False, then the call to
313 -- Write_Source_Reference_Pragma has no effect. EOL indicates the end
314 -- of line sequence to be written at the end of the pragma.
315
316 procedure Write_Unit
317 (Source : access String;
318 Num : Unit_Num;
319 Success : out Boolean);
320 -- Write one compilation unit of the source to file
321
322 ---------------
323 -- Error_Msg --
324 ---------------
325
326 procedure Error_Msg (Message : String) is
327 begin
328 Put_Line (Standard_Error, Message);
329 Set_Exit_Status (Failure);
330
331 if Exit_On_Error then
332 raise Terminate_Program;
333 end if;
334 end Error_Msg;
335
336 -----------------
337 -- Files_Exist --
338 -----------------
339
340 function Files_Exist return Boolean is
341 Exists : Boolean := False;
342
343 begin
344 for SNum in 1 .. SUnit_Num (Unit.Last) loop
345
346 -- Only check and report for the last instance of duplicated files
347
348 if not Is_Duplicated (SNum) then
349 declare
350 Info : Unit_Info := Unit.Table (Sorted_Units.Table (SNum));
351
352 begin
353 if Is_Writable_File (Info.File_Name.all) then
354 if Hostparm.OpenVMS then
355 Error_Msg
356 (Info.File_Name.all
357 & " already exists, use /OVERWRITE to overwrite");
358 else
359 Error_Msg (Info.File_Name.all
360 & " already exists, use -w to overwrite");
361 end if;
362
363 Exists := True;
364 end if;
365 end;
366 end if;
367 end loop;
368
369 return Exists;
370 end Files_Exist;
371
372 ------------------------
373 -- Get_Config_Pragmas --
374 ------------------------
375
376 function Get_Config_Pragmas
377 (Input : File_Num;
378 U : Unit_Num)
379 return String_Access
380 is
381 Info : Unit_Info renames Unit.Table (U);
382 FD : File_Descriptor;
383 Name : aliased constant String :=
384 File.Table (Input).Name.all & ASCII.Nul;
385 Length : File_Offset;
386 Buffer : String_Access;
387 Success : Boolean;
388 Result : String_Access;
389
390 begin
391 FD := Open_Read (Name'Address, Binary);
392
393 if FD = Invalid_FD then
394 Error_Msg ("cannot open " & File.Table (Input).Name.all);
395 return null;
396 end if;
397
398 Read_File (FD, Buffer, Success);
399
400 -- A length of 0 indicates that the rest of the file belongs to
401 -- this unit. The actual length must be calculated now. Take into
402 -- account that the last character (EOF) must not be written.
403
404 if Info.Length = 0 then
405 Length := Buffer'Last - (Buffer'First + Info.Offset);
406 else
407 Length := Info.Length;
408 end if;
409
410 Result := new String'(Buffer (1 .. Length));
411 Close (FD);
412 return Result;
413 end Get_Config_Pragmas;
414
415 -------------
416 -- Get_EOL --
417 -------------
418
419 function Get_EOL
420 (Source : access String;
421 Start : Positive)
422 return EOL_String
423 is
424 Ptr : Positive := Start;
425 First : Positive;
426 Last : Natural;
427
428 begin
429 -- Skip to end of line
430
431 while Source (Ptr) /= ASCII.CR and then
432 Source (Ptr) /= ASCII.LF and then
433 Source (Ptr) /= EOF
434 loop
435 Ptr := Ptr + 1;
436 end loop;
437
438 Last := Ptr;
439
440 if Source (Ptr) /= EOF then
441
442 -- Found CR or LF
443
444 First := Ptr;
445
446 else
447 First := Ptr + 1;
448 end if;
449
450 -- Recognize CR/LF or LF/CR combination
451
452 if (Source (Ptr + 1) = ASCII.CR or Source (Ptr + 1) = ASCII.LF)
453 and then Source (Ptr) /= Source (Ptr + 1)
454 then
455 Last := First + 1;
456 end if;
457
458 return (Len => Last + 1 - First, Str => Source (First .. Last));
459 end Get_EOL;
460
461 -------------------
462 -- Is_Duplicated --
463 -------------------
464
465 function Is_Duplicated (U : SUnit_Num) return Boolean is
466 begin
467 return U < SUnit_Num (Unit.Last)
468 and then
469 Unit.Table (Sorted_Units.Table (U)).File_Name.all =
470 Unit.Table (Sorted_Units.Table (U + 1)).File_Name.all;
471 end Is_Duplicated;
472
473 -----------------------
474 -- Locate_Executable --
475 -----------------------
476
477 function Locate_Executable (Program_Name : String) return String_Access is
478 Current_Command : constant String := Command_Name;
479 End_Of_Prefix : Natural;
480 Start_Of_Prefix : Positive := Current_Command'First;
481 Result : String_Access;
482
483 begin
484 -- Find Start_Of_Prefix
485
486 for J in reverse Current_Command'Range loop
487 if Current_Command (J) = '/' or
488 Current_Command (J) = Directory_Separator or
489 Current_Command (J) = ':'
490 then
491 Start_Of_Prefix := J + 1;
492 exit;
493 end if;
494 end loop;
495
496 -- Find End_Of_Prefix
497
498 End_Of_Prefix := Start_Of_Prefix - 1;
499
500 for J in reverse Start_Of_Prefix .. Current_Command'Last loop
501 if Current_Command (J) = '-' then
502 End_Of_Prefix := J;
503 exit;
504 end if;
505 end loop;
506
507 declare
508 Command : constant String :=
509 Current_Command (Start_Of_Prefix .. End_Of_Prefix) &
510 Program_Name;
511 begin
512 Result := Locate_Exec_On_Path (Command);
513
514 if Result = null then
515 Error_Msg
516 (Command & ": installation problem, executable not found");
517 end if;
518 end;
519
520 return Result;
521 end Locate_Executable;
522
523 ---------------
524 -- Parse_EOL --
525 ---------------
526
527 procedure Parse_EOL (Source : access String; Ptr : in out Positive) is
528 begin
529 -- Skip to end of line
530
531 while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF
532 and then Source (Ptr) /= EOF
533 loop
534 Ptr := Ptr + 1;
535 end loop;
536
537 if Source (Ptr) /= EOF then
538 Ptr := Ptr + 1; -- skip CR or LF
539 end if;
540
541 -- Skip past CR/LF or LF/CR combination
542
543 if (Source (Ptr) = ASCII.CR or Source (Ptr) = ASCII.LF)
544 and then Source (Ptr) /= Source (Ptr - 1)
545 then
546 Ptr := Ptr + 1;
547 end if;
548 end Parse_EOL;
549
550 ----------------
551 -- Parse_File --
552 ----------------
553
554 function Parse_File (Num : File_Num) return Boolean is
555 Chop_Name : constant String_Access := File.Table (Num).Name;
556 Offset_Name : Temp_File_Name;
557 Offset_FD : File_Descriptor;
558 Save_Stdout : File_Descriptor := dup (Standout);
559 Buffer : String_Access;
560 Success : Boolean;
561 Failure : exception;
562
563 begin
564 -- Display copy of GNAT command if verbose mode
565
566 if Verbose_Mode then
567 Put (Gnat_Cmd.all);
568
569 for J in 1 .. Gnat_Args'Length loop
570 Put (' ');
571 Put (Gnat_Args (J).all);
572 end loop;
573
574 Put (' ');
575 Put_Line (Chop_Name.all);
576 end if;
577
578 -- Create temporary file
579
580 Create_Temp_File (Offset_FD, Offset_Name);
581
582 if Offset_FD = Invalid_FD then
583 Error_Msg ("gnatchop: cannot create temporary file");
584 Close (Save_Stdout);
585 return False;
586 end if;
587
588 -- Redirect Stdout to this temporary file in the Unix way
589
590 if dup2 (Offset_FD, Standout) = Invalid_FD then
591 Error_Msg ("gnatchop: cannot redirect stdout to temporary file");
592 Close (Save_Stdout);
593 Close (Offset_FD);
594 return False;
595 end if;
596
597 -- Call Gnat on the source filename argument with special options
598 -- to generate offset information. If this special compilation completes
599 -- successfully then we can do the actual gnatchop operation.
600
601 Spawn (Gnat_Cmd.all, Gnat_Args.all & Chop_Name, Success);
602
603 if not Success then
604 Error_Msg (Chop_Name.all & ": parse errors detected");
605 Error_Msg (Chop_Name.all & ": chop may not be successful");
606 end if;
607
608 -- Restore stdout
609
610 if dup2 (Save_Stdout, Standout) = Invalid_FD then
611 Error_Msg ("gnatchop: cannot restore stdout");
612 end if;
613
614 -- Reopen the file to start reading from the beginning
615
616 Close (Offset_FD);
617 Close (Save_Stdout);
618 Offset_FD := Open_Read (Offset_Name'Address, Binary);
619
620 if Offset_FD = Invalid_FD then
621 Error_Msg ("gnatchop: cannot access offset info");
622 raise Failure;
623 end if;
624
625 Read_File (Offset_FD, Buffer, Success);
626
627 if not Success then
628 Error_Msg ("gnatchop: error reading offset info");
629 Close (Offset_FD);
630 raise Failure;
631 else
632 Parse_Offset_Info (Num, Buffer);
633 end if;
634
635 -- Close and delete temporary file
636
637 Close (Offset_FD);
638 Delete_File (Offset_Name'Address, Success);
639
640 return Success;
641
642 exception
643 when Failure | Terminate_Program =>
644 Close (Offset_FD);
645 Delete_File (Offset_Name'Address, Success);
646 return False;
647
648 end Parse_File;
649
650 -----------------------
651 -- Parse_Offset_Info --
652 -----------------------
653
654 procedure Parse_Offset_Info
655 (Chop_File : File_Num;
656 Source : access String)
657 is
658 First_Unit : Unit_Num := Unit.Last + 1;
659 Bufferg : String_Access := null;
660 Parse_Ptr : File_Offset := Source'First;
661 Token_Ptr : File_Offset;
662 Info : Unit_Info;
663
664 function Match (Literal : String) return Boolean;
665 -- Checks if given string appears at the current Token_Ptr location
666 -- and if so, bumps Parse_Ptr past the token and returns True. If
667 -- the string is not present, sets Parse_Ptr to Token_Ptr and
668 -- returns False.
669
670 -----------
671 -- Match --
672 -----------
673
674 function Match (Literal : String) return Boolean is
675 begin
676 Parse_Token (Source, Parse_Ptr, Token_Ptr);
677
678 if Source'Last + 1 - Token_Ptr < Literal'Length
679 or else
680 Source (Token_Ptr .. Token_Ptr + Literal'Length - 1) /= Literal
681 then
682 Parse_Ptr := Token_Ptr;
683 return False;
684 end if;
685
686 Parse_Ptr := Token_Ptr + Literal'Length;
687 return True;
688 end Match;
689
690 -- Start of processing for Parse_Offset_Info
691
692 begin
693 loop
694 -- Set default values, should get changed for all
695 -- units/pragmas except for the last
696
697 Info.Chop_File := Chop_File;
698 Info.Length := 0;
699
700 -- Parse the current line of offset information into Info
701 -- and exit the loop if there are any errors or on EOF.
702
703 -- First case, parse a line in the following format:
704
705 -- Unit x (spec) line 7, file offset 142, [SR, ]file name x.ads
706
707 -- Note that the unit name can be an operator name in quotes.
708 -- This is of course illegal, but both GNAT and gnatchop handle
709 -- the case so that this error does not intefere with chopping.
710
711 -- The SR ir present indicates that a source reference pragma
712 -- was processed as part of this unit (and that therefore no
713 -- Source_Reference pragma should be generated.
714
715 if Match ("Unit") then
716 Parse_Token (Source, Parse_Ptr, Token_Ptr);
717
718 if Match ("(body)") then
719 Info.Kind := Unit_Body;
720 elsif Match ("(spec)") then
721 Info.Kind := Unit_Spec;
722 else
723 exit;
724 end if;
725
726 exit when not Match ("line");
727 Parse_Token (Source, Parse_Ptr, Token_Ptr);
728 Info.Start_Line := Line_Num'Value
729 (Source (Token_Ptr .. Parse_Ptr - 1));
730
731 exit when not Match ("file offset");
732 Parse_Token (Source, Parse_Ptr, Token_Ptr);
733 Info.Offset := File_Offset'Value
734 (Source (Token_Ptr .. Parse_Ptr - 1));
735
736 Info.SR_Present := Match ("SR, ");
737
738 exit when not Match ("file name");
739 Parse_Token (Source, Parse_Ptr, Token_Ptr);
740 Info.File_Name := new String'
741 (Directory.all & Source (Token_Ptr .. Parse_Ptr - 1));
742 Parse_EOL (Source, Parse_Ptr);
743
744 -- Second case, parse a line of the following form
745
746 -- Configuration pragmas at line 10, file offset 223
747
748 elsif Match ("Configuration pragmas at") then
749 Info.Kind := Config_Pragmas;
750 Info.File_Name := Config_File_Name;
751
752 exit when not Match ("line");
753 Parse_Token (Source, Parse_Ptr, Token_Ptr);
754 Info.Start_Line := Line_Num'Value
755 (Source (Token_Ptr .. Parse_Ptr - 1));
756
757 exit when not Match ("file offset");
758 Parse_Token (Source, Parse_Ptr, Token_Ptr);
759 Info.Offset := File_Offset'Value
760 (Source (Token_Ptr .. Parse_Ptr - 1));
761
762 Parse_EOL (Source, Parse_Ptr);
763
764 -- Third case, parse a line of the following form
765
766 -- Source_Reference pragma for file "filename"
767
768 -- This appears at the start of the file only, and indicates
769 -- the name to be used on any generated Source_Reference pragmas.
770
771 elsif Match ("Source_Reference pragma for file ") then
772 Parse_Token (Source, Parse_Ptr, Token_Ptr);
773 File.Table (Chop_File).SR_Name :=
774 new String'(Source (Token_Ptr + 1 .. Parse_Ptr - 2));
775 Parse_EOL (Source, Parse_Ptr);
776 goto Continue;
777
778 -- Unrecognized keyword or end of file
779
780 else
781 exit;
782 end if;
783
784 -- Store the data in the Info record in the Unit.Table
785
786 Unit.Increment_Last;
787 Unit.Table (Unit.Last) := Info;
788
789 -- If this is not the first unit from the file, calculate
790 -- the length of the previous unit as difference of the offsets
791
792 if Unit.Last > First_Unit then
793 Unit.Table (Unit.Last - 1).Length :=
794 Info.Offset - Unit.Table (Unit.Last - 1).Offset;
795 end if;
796
797 -- If not in compilation mode combine current unit with any
798 -- preceeding configuration pragmas.
799
800 if not Compilation_Mode
801 and then Unit.Last > First_Unit
802 and then Unit.Table (Unit.Last - 1).Kind = Config_Pragmas
803 then
804 Info.Start_Line := Unit.Table (Unit.Last - 1).Start_Line;
805 Info.Offset := Unit.Table (Unit.Last - 1).Offset;
806
807 -- Delete the configuration pragma entry
808
809 Unit.Table (Unit.Last - 1) := Info;
810 Unit.Decrement_Last;
811 end if;
812
813 -- If in compilation mode, and previous entry is the initial
814 -- entry for the file and is for configuration pragmas, then
815 -- they are to be appended to every unit in the file.
816
817 if Compilation_Mode
818 and then Unit.Last = First_Unit + 1
819 and then Unit.Table (First_Unit).Kind = Config_Pragmas
820 then
821 Bufferg :=
822 Get_Config_Pragmas
823 (Unit.Table (Unit.Last - 1).Chop_File, First_Unit);
824 Unit.Table (Unit.Last - 1) := Info;
825 Unit.Decrement_Last;
826 end if;
827
828 Unit.Table (Unit.Last).Bufferg := Bufferg;
829
830 -- If in compilation mode, and this is not the first item,
831 -- combine configuration pragmas with previous unit, which
832 -- will cause an error message to be generated when the unit
833 -- is compiled.
834
835 if Compilation_Mode
836 and then Unit.Last > First_Unit
837 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
838 then
839 Unit.Decrement_Last;
840 end if;
841
842 <<Continue>>
843 null;
844
845 end loop;
846
847 -- Find out if the loop was exited prematurely because of
848 -- an error or if the EOF marker was found.
849
850 if Source (Parse_Ptr) /= EOF then
851 Error_Msg
852 (File.Table (Chop_File).Name.all & ": error parsing offset info");
853 return;
854 end if;
855
856 -- Handle case of a chop file consisting only of config pragmas
857
858 if Unit.Last = First_Unit
859 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
860 then
861 -- In compilation mode, we append such a file to gnat.adc
862
863 if Compilation_Mode then
864 Write_Config_File (Unit.Table (Unit.Last).Chop_File, First_Unit);
865 Unit.Decrement_Last;
866
867 -- In default (non-compilation) mode, this is invalid
868
869 else
870 Error_Msg
871 (File.Table (Chop_File).Name.all &
872 ": no units found (only pragmas)");
873 Unit.Decrement_Last;
874 end if;
875 end if;
876
877 -- Handle case of a chop file ending with config pragmas. This can
878 -- happen only in default non-compilation mode, since in compilation
879 -- mode such configuration pragmas are part of the preceding unit.
880 -- We simply concatenate such pragmas to the previous file which
881 -- will cause a compilation error, which is appropriate.
882
883 if Unit.Last > First_Unit
884 and then Unit.Table (Unit.Last).Kind = Config_Pragmas
885 then
886 Unit.Decrement_Last;
887 end if;
888 end Parse_Offset_Info;
889
890 -----------------
891 -- Parse_Token --
892 -----------------
893
894 procedure Parse_Token
895 (Source : access String;
896 Ptr : in out Positive;
897 Token_Ptr : out Positive)
898 is
899 In_Quotes : Boolean := False;
900
901 begin
902 -- Skip separators
903
904 while Source (Ptr) = ' ' or Source (Ptr) = ',' loop
905 Ptr := Ptr + 1;
906 end loop;
907
908 Token_Ptr := Ptr;
909
910 -- Find end-of-token
911
912 while (In_Quotes or else not (Source (Ptr) = ' ' or Source (Ptr) = ','))
913 and then Source (Ptr) >= ' '
914 loop
915 if Source (Ptr) = '"' then
916 In_Quotes := not In_Quotes;
917 end if;
918
919 Ptr := Ptr + 1;
920 end loop;
921 end Parse_Token;
922
923 ---------------
924 -- Read_File --
925 ---------------
926
927 procedure Read_File
928 (FD : File_Descriptor;
929 Contents : out String_Access;
930 Success : out Boolean)
931 is
932 Length : constant File_Offset := File_Offset (File_Length (FD));
933 -- Include room for EOF char
934 Buffer : constant String_Access := new String (1 .. Length + 1);
935
936 This_Read : Integer;
937 Read_Ptr : File_Offset := 1;
938
939 begin
940
941 loop
942 This_Read := Read (FD,
943 A => Buffer (Read_Ptr)'Address,
944 N => Length + 1 - Read_Ptr);
945 Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0);
946 exit when This_Read <= 0;
947 end loop;
948
949 Buffer (Read_Ptr) := EOF;
950 Contents := new String (1 .. Read_Ptr);
951 Contents.all := Buffer (1 .. Read_Ptr);
952
953 -- Things aren't simple on VMS due to the plethora of file types
954 -- and organizations. It seems clear that there shouldn't be more
955 -- bytes read than are contained in the file though.
956
957 if Hostparm.OpenVMS then
958 Success := Read_Ptr <= Length + 1;
959 else
960 Success := Read_Ptr = Length + 1;
961 end if;
962 end Read_File;
963
964 ----------------------------
965 -- Report_Duplicate_Units --
966 ----------------------------
967
968 function Report_Duplicate_Units return Boolean is
969 US : SUnit_Num;
970 U : Unit_Num;
971
972 Duplicates : Boolean := False;
973
974 begin
975 US := 1;
976 while US < SUnit_Num (Unit.Last) loop
977 U := Sorted_Units.Table (US);
978
979 if Is_Duplicated (US) then
980 Duplicates := True;
981
982 -- Move to last two versions of duplicated file to make it clearer
983 -- to understand which file is retained in case of overwriting.
984
985 while US + 1 < SUnit_Num (Unit.Last) loop
986 exit when not Is_Duplicated (US + 1);
987 US := US + 1;
988 end loop;
989
990 U := Sorted_Units.Table (US);
991
992 if Overwrite_Files then
993 Warning_Msg (Unit.Table (U).File_Name.all
994 & " is duplicated (all but last will be skipped)");
995
996 elsif Unit.Table (U).Chop_File =
997 Unit.Table (Sorted_Units.Table (US + 1)).Chop_File
998 then
999 Error_Msg (Unit.Table (U).File_Name.all
1000 & " is duplicated in "
1001 & File.Table (Unit.Table (U).Chop_File).Name.all);
1002
1003 else
1004 Error_Msg (Unit.Table (U).File_Name.all
1005 & " in "
1006 & File.Table (Unit.Table (U).Chop_File).Name.all
1007 & " is duplicated in "
1008 & File.Table
1009 (Unit.Table
1010 (Sorted_Units.Table (US + 1)).Chop_File).Name.all);
1011 end if;
1012 end if;
1013
1014 US := US + 1;
1015 end loop;
1016
1017 if Duplicates and not Overwrite_Files then
1018 if Hostparm.OpenVMS then
1019 Put_Line
1020 ("use /OVERWRITE to overwrite files and keep last version");
1021 else
1022 Put_Line ("use -w to overwrite files and keep last version");
1023 end if;
1024 end if;
1025
1026 return Duplicates;
1027 end Report_Duplicate_Units;
1028
1029 --------------------
1030 -- Scan_Arguments --
1031 --------------------
1032
1033 function Scan_Arguments return Boolean is
1034 Kset : Boolean := False;
1035 -- Set true if -k switch found
1036
1037 begin
1038 Initialize_Option_Scan;
1039
1040 -- Scan options first
1041
1042 loop
1043 case Getopt ("c gnat? h k? q r v w x") is
1044 when ASCII.NUL =>
1045 exit;
1046
1047 when 'c' =>
1048 Compilation_Mode := True;
1049
1050 when 'g' =>
1051 Gnat_Args :=
1052 new Argument_List'(Gnat_Args.all &
1053 new String'("-gnat" & Parameter));
1054
1055 when 'h' =>
1056 Usage;
1057 raise Terminate_Program;
1058
1059 when 'k' =>
1060 declare
1061 Param : String_Access := new String'(Parameter);
1062
1063 begin
1064 if Param.all /= "" then
1065 for J in Param'Range loop
1066 if Param (J) not in '0' .. '9' then
1067 if Hostparm.OpenVMS then
1068 Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn" &
1069 " requires numeric parameter");
1070 else
1071 Error_Msg ("-k# requires numeric parameter");
1072 end if;
1073 return False;
1074 end if;
1075 end loop;
1076
1077 else
1078 if Hostparm.OpenVMS then
1079 Param := new String'("39");
1080 else
1081 Param := new String'("8");
1082 end if;
1083 end if;
1084
1085 Gnat_Args :=
1086 new Argument_List'(Gnat_Args.all &
1087 new String'("-gnatk" & Param.all));
1088 Kset := True;
1089 end;
1090
1091 when 'q' =>
1092 Quiet_Mode := True;
1093
1094 when 'r' =>
1095 Source_References := True;
1096
1097 when 'v' =>
1098 Verbose_Mode := True;
1099 Put_Line (Standard_Error, Cwrite);
1100
1101 when 'w' =>
1102 Overwrite_Files := True;
1103
1104 when 'x' =>
1105 Exit_On_Error := True;
1106
1107 when others =>
1108 null;
1109 end case;
1110 end loop;
1111
1112 if not Kset and then Maximum_File_Name_Length > 0 then
1113
1114 -- If this system has restricted filename lengths, tell gnat1
1115 -- about them, removing the leading blank from the image string.
1116
1117 Gnat_Args :=
1118 new Argument_List'(Gnat_Args.all
1119 & new String'("-gnatk"
1120 & Maximum_File_Name_Length_String
1121 (Maximum_File_Name_Length_String'First + 1
1122 .. Maximum_File_Name_Length_String'Last)));
1123 end if;
1124
1125 -- Scan file names
1126
1127 loop
1128 declare
1129 S : constant String := Get_Argument (Do_Expansion => True);
1130
1131 begin
1132 exit when S = "";
1133 File.Increment_Last;
1134 File.Table (File.Last).Name := new String'(S);
1135 File.Table (File.Last).SR_Name := null;
1136 end;
1137 end loop;
1138
1139 -- Case of more than one file where last file is a directory
1140
1141 if File.Last > 1
1142 and then Is_Directory (File.Table (File.Last).Name.all)
1143 then
1144 Directory := File.Table (File.Last).Name;
1145 File.Decrement_Last;
1146
1147 -- Make sure Directory is terminated with a directory separator,
1148 -- so we can generate the output by just appending a filename.
1149
1150 if Directory (Directory'Last) /= Directory_Separator
1151 and then Directory (Directory'Last) /= '/'
1152 then
1153 Directory := new String'(Directory.all & Directory_Separator);
1154 end if;
1155
1156 -- At least one filename must be given
1157
1158 elsif File.Last = 0 then
1159 Usage;
1160 return False;
1161
1162 -- No directory given, set directory to null, so that we can just
1163 -- concatenate the directory name to the file name unconditionally.
1164
1165 else
1166 Directory := new String'("");
1167 end if;
1168
1169 -- Finally check all filename arguments
1170
1171 for File_Num in 1 .. File.Last loop
1172 declare
1173 F : constant String := File.Table (File_Num).Name.all;
1174
1175 begin
1176
1177 if Is_Directory (F) then
1178 Error_Msg (F & " is a directory, cannot be chopped");
1179 return False;
1180
1181 elsif not Is_Regular_File (F) then
1182 Error_Msg (F & " not found");
1183 return False;
1184 end if;
1185 end;
1186 end loop;
1187
1188 return True;
1189
1190 exception
1191 when Invalid_Switch =>
1192 Error_Msg ("invalid switch " & Full_Switch);
1193 return False;
1194
1195 when Invalid_Parameter =>
1196 if Hostparm.OpenVMS then
1197 Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn qualifier" &
1198 " requires numeric parameter");
1199 else
1200 Error_Msg ("-k switch requires numeric parameter");
1201 end if;
1202
1203 return False;
1204
1205 end Scan_Arguments;
1206
1207 ----------------
1208 -- Sort_Units --
1209 ----------------
1210
1211 procedure Sort_Units is
1212
1213 procedure Move (From : Natural; To : Natural);
1214 -- Procedure used to sort the unit list
1215 -- Unit.Table (To) := Unit_List (From); used by sort
1216
1217 function Lt (Left, Right : Natural) return Boolean;
1218 -- Compares Left and Right units based on file name (first),
1219 -- Chop_File (second) and Offset (third). This ordering is
1220 -- important to keep the last version in case of duplicate files.
1221
1222 package Unit_Sort is new GNAT.Heap_Sort_G (Move, Lt);
1223 -- Used for sorting on filename to detect duplicates
1224
1225 --------
1226 -- Lt --
1227 --------
1228
1229 function Lt (Left, Right : Natural) return Boolean is
1230 L : Unit_Info renames
1231 Unit.Table (Sorted_Units.Table (SUnit_Num (Left)));
1232
1233 R : Unit_Info renames
1234 Unit.Table (Sorted_Units.Table (SUnit_Num (Right)));
1235
1236 begin
1237 return L.File_Name.all < R.File_Name.all
1238 or else (L.File_Name.all = R.File_Name.all
1239 and then (L.Chop_File < R.Chop_File
1240 or else (L.Chop_File = R.Chop_File
1241 and then L.Offset < R.Offset)));
1242 end Lt;
1243
1244 ----------
1245 -- Move --
1246 ----------
1247
1248 procedure Move (From : Natural; To : Natural) is
1249 begin
1250 Sorted_Units.Table (SUnit_Num (To)) :=
1251 Sorted_Units.Table (SUnit_Num (From));
1252 end Move;
1253
1254 -- Start of processing for Sort_Units
1255
1256 begin
1257 Sorted_Units.Set_Last (SUnit_Num (Unit.Last));
1258
1259 for J in 1 .. Unit.Last loop
1260 Sorted_Units.Table (SUnit_Num (J)) := J;
1261 end loop;
1262
1263 -- Sort Unit.Table, using Sorted_Units.Table (0) as scratch
1264
1265 Unit_Sort.Sort (Natural (Unit.Last));
1266
1267 -- Set the Sorted_Index fields in the unit tables.
1268
1269 for J in 1 .. SUnit_Num (Unit.Last) loop
1270 Unit.Table (Sorted_Units.Table (J)).Sorted_Index := J;
1271 end loop;
1272 end Sort_Units;
1273
1274 -----------
1275 -- Usage --
1276 -----------
1277
1278 procedure Usage is
1279 begin
1280 Put_Line
1281 ("Usage: gnatchop [-c] [-h] [-k#] " &
1282 "[-r] [-q] [-v] [-w] [-x] file [file ...] [dir]");
1283
1284 New_Line;
1285 Put_Line
1286 (" -c compilation mode, configuration pragmas " &
1287 "follow RM rules");
1288
1289 Put_Line
1290 (" -gnatxxx passes the -gnatxxx switch to gnat parser");
1291
1292 Put_Line
1293 (" -h help: output this usage information");
1294
1295 Put_Line
1296 (" -k# krunch file names of generated files to " &
1297 "no more than # characters");
1298
1299 Put_Line
1300 (" -k krunch file names of generated files to " &
1301 "no more than 8 characters");
1302
1303 Put_Line
1304 (" -q quiet mode, no output of generated file " &
1305 "names");
1306
1307 Put_Line
1308 (" -r generate Source_Reference pragmas refer" &
1309 "encing original source file");
1310
1311 Put_Line
1312 (" -v verbose mode, output version and generat" &
1313 "ed commands");
1314
1315 Put_Line
1316 (" -w overwrite existing filenames");
1317
1318 Put_Line
1319 (" -x exit on error");
1320
1321 New_Line;
1322 Put_Line
1323 (" file... list of source files to be chopped");
1324
1325 Put_Line
1326 (" dir directory location for split files (defa" &
1327 "ult = current directory)");
1328 end Usage;
1329
1330 -----------------
1331 -- Warning_Msg --
1332 -----------------
1333
1334 procedure Warning_Msg (Message : String) is
1335 begin
1336 Warning_Count := Warning_Count + 1;
1337 Put_Line (Standard_Error, "warning: " & Message);
1338 end Warning_Msg;
1339
1340 -------------------------
1341 -- Write_Chopped_Files --
1342 -------------------------
1343
1344 function Write_Chopped_Files (Input : File_Num) return Boolean is
1345 Name : aliased constant String :=
1346 File.Table (Input).Name.all & ASCII.Nul;
1347 FD : File_Descriptor;
1348 Buffer : String_Access;
1349 Success : Boolean;
1350
1351 begin
1352 FD := Open_Read (Name'Address, Binary);
1353
1354 if FD = Invalid_FD then
1355 Error_Msg ("cannot open " & File.Table (Input).Name.all);
1356 return False;
1357 end if;
1358
1359 Read_File (FD, Buffer, Success);
1360
1361 if not Success then
1362 Error_Msg ("cannot read " & File.Table (Input).Name.all);
1363 Close (FD);
1364 return False;
1365 end if;
1366
1367 if not Quiet_Mode then
1368 Put_Line ("splitting " & File.Table (Input).Name.all & " into:");
1369 end if;
1370
1371 -- Only chop those units that come from this file
1372
1373 for Num in 1 .. Unit.Last loop
1374 if Unit.Table (Num).Chop_File = Input then
1375 Write_Unit (Buffer, Num, Success);
1376 exit when not Success;
1377 end if;
1378 end loop;
1379
1380 Close (FD);
1381 return Success;
1382
1383 end Write_Chopped_Files;
1384
1385 -----------------------
1386 -- Write_Config_File --
1387 -----------------------
1388
1389 procedure Write_Config_File (Input : File_Num; U : Unit_Num) is
1390 FD : File_Descriptor;
1391 Name : aliased constant String := "gnat.adc" & ASCII.NUL;
1392 Buffer : String_Access;
1393 Success : Boolean;
1394 Append : Boolean;
1395 Buffera : String_Access;
1396 Bufferl : Natural;
1397
1398 begin
1399 Write_gnat_adc := True;
1400 FD := Open_Read_Write (Name'Address, Binary);
1401
1402 if FD = Invalid_FD then
1403 FD := Create_File (Name'Address, Binary);
1404 Append := False;
1405
1406 if not Quiet_Mode then
1407 Put_Line ("writing configuration pragmas from " &
1408 File.Table (Input).Name.all & " to gnat.adc");
1409 end if;
1410
1411 else
1412 Append := True;
1413
1414 if not Quiet_Mode then
1415 Put_Line
1416 ("appending configuration pragmas from " &
1417 File.Table (Input).Name.all & " to gnat.adc");
1418 end if;
1419 end if;
1420
1421 Success := FD /= Invalid_FD;
1422
1423 if not Success then
1424 Error_Msg ("cannot create gnat.adc");
1425 return;
1426 end if;
1427
1428 -- In append mode, acquire existing gnat.adc file
1429
1430 if Append then
1431 Read_File (FD, Buffera, Success);
1432
1433 if not Success then
1434 Error_Msg ("cannot read gnat.adc");
1435 return;
1436 end if;
1437
1438 -- Find location of EOF byte if any to exclude from append
1439
1440 Bufferl := 1;
1441 while Bufferl <= Buffera'Last
1442 and then Buffera (Bufferl) /= EOF
1443 loop
1444 Bufferl := Bufferl + 1;
1445 end loop;
1446
1447 Bufferl := Bufferl - 1;
1448 Close (FD);
1449
1450 -- Write existing gnat.adc to new gnat.adc file
1451
1452 FD := Create_File (Name'Address, Binary);
1453 Success := Write (FD, Buffera (1)'Address, Bufferl) = Bufferl;
1454
1455 if not Success then
1456 Error_Msg ("error writing gnat.adc");
1457 return;
1458 end if;
1459 end if;
1460
1461 Buffer := Get_Config_Pragmas (Input, U);
1462
1463 if Buffer /= null then
1464 Success := Write (FD, Buffer.all'Address, Buffer'Length) =
1465 Buffer'Length;
1466
1467 if not Success then
1468 Error_Msg ("disk full writing gnat.adc");
1469 return;
1470 end if;
1471 end if;
1472
1473 Close (FD);
1474 end Write_Config_File;
1475
1476 -----------------------------------
1477 -- Write_Source_Reference_Pragma --
1478 -----------------------------------
1479
1480 procedure Write_Source_Reference_Pragma
1481 (Info : Unit_Info;
1482 Line : Line_Num;
1483 FD : File_Descriptor;
1484 EOL : EOL_String;
1485 Success : in out Boolean)
1486 is
1487 FTE : File_Entry renames File.Table (Info.Chop_File);
1488 Nam : String_Access;
1489
1490 begin
1491 if Success and Source_References and not Info.SR_Present then
1492 if FTE.SR_Name /= null then
1493 Nam := FTE.SR_Name;
1494 else
1495 Nam := FTE.Name;
1496 end if;
1497
1498 declare
1499 Reference : aliased String :=
1500 "pragma Source_Reference (000000, """
1501 & Nam.all & """);" & EOL.Str;
1502
1503 Pos : Positive := Reference'First;
1504 Lin : Line_Num := Line;
1505
1506 begin
1507 while Reference (Pos + 1) /= ',' loop
1508 Pos := Pos + 1;
1509 end loop;
1510
1511 while Reference (Pos) = '0' loop
1512 Reference (Pos) := Character'Val
1513 (Character'Pos ('0') + Lin mod 10);
1514 Lin := Lin / 10;
1515 Pos := Pos - 1;
1516 end loop;
1517
1518 -- Assume there are enough zeroes for any program length
1519
1520 pragma Assert (Lin = 0);
1521
1522 Success :=
1523 Write (FD, Reference'Address, Reference'Length)
1524 = Reference'Length;
1525 end;
1526 end if;
1527 end Write_Source_Reference_Pragma;
1528
1529 ----------------
1530 -- Write_Unit --
1531 ----------------
1532
1533 procedure Write_Unit
1534 (Source : access String;
1535 Num : Unit_Num;
1536 Success : out Boolean)
1537 is
1538 Info : Unit_Info renames Unit.Table (Num);
1539 FD : File_Descriptor;
1540 Name : aliased constant String := Info.File_Name.all & ASCII.NUL;
1541 Length : File_Offset;
1542 EOL : constant EOL_String :=
1543 Get_EOL (Source, Source'First + Info.Offset);
1544
1545 begin
1546 -- Skip duplicated files
1547
1548 if Is_Duplicated (Info.Sorted_Index) then
1549 Put_Line (" " & Info.File_Name.all & " skipped");
1550 Success := Overwrite_Files;
1551 return;
1552 end if;
1553
1554 if Overwrite_Files then
1555 FD := Create_File (Name'Address, Binary);
1556 else
1557 FD := Create_New_File (Name'Address, Binary);
1558 end if;
1559
1560 Success := FD /= Invalid_FD;
1561
1562 if not Success then
1563 Error_Msg ("cannot create " & Info.File_Name.all);
1564 return;
1565 end if;
1566
1567 -- A length of 0 indicates that the rest of the file belongs to
1568 -- this unit. The actual length must be calculated now. Take into
1569 -- account that the last character (EOF) must not be written.
1570
1571 if Info.Length = 0 then
1572 Length := Source'Last - (Source'First + Info.Offset);
1573 else
1574 Length := Info.Length;
1575 end if;
1576
1577 -- Prepend configuration pragmas if necessary
1578
1579 if Success and then Info.Bufferg /= null then
1580 Write_Source_Reference_Pragma (Info, 1, FD, EOL, Success);
1581 Success :=
1582 Write (FD, Info.Bufferg.all'Address, Info.Bufferg'Length) =
1583 Info.Bufferg'Length;
1584 end if;
1585
1586 Write_Source_Reference_Pragma (Info, Info.Start_Line, FD, EOL, Success);
1587
1588 if Success then
1589 Success := Write (FD, Source (Source'First + Info.Offset)'Address,
1590 Length) = Length;
1591 end if;
1592
1593 if not Success then
1594 Error_Msg ("disk full writing " & Info.File_Name.all);
1595 return;
1596 end if;
1597
1598 if not Quiet_Mode then
1599 Put_Line (" " & Info.File_Name.all);
1600 end if;
1601
1602 Close (FD);
1603 end Write_Unit;
1604
1605 -- Start of processing for gnatchop
1606
1607 begin
1608 -- Check presence of required executables
1609
1610 Gnat_Cmd := Locate_Executable ("gcc");
1611
1612 if Gnat_Cmd = null then
1613 goto No_Files_Written;
1614 end if;
1615
1616 -- Process command line options and initialize global variables
1617
1618 if not Scan_Arguments then
1619 Set_Exit_Status (Failure);
1620 return;
1621 end if;
1622
1623 -- First parse all files and read offset information
1624
1625 for Num in 1 .. File.Last loop
1626 if not Parse_File (Num) then
1627 goto No_Files_Written;
1628 end if;
1629 end loop;
1630
1631 -- Check if any units have been found (assumes non-empty Unit.Table)
1632
1633 if Unit.Last = 0 then
1634 if not Write_gnat_adc then
1635 Error_Msg ("no compilation units found");
1636 end if;
1637
1638 goto No_Files_Written;
1639 end if;
1640
1641 Sort_Units;
1642
1643 -- Check if any duplicate files would be created. If so, emit
1644 -- a warning if Overwrite_Files is true, otherwise generate an error.
1645
1646 if Report_Duplicate_Units and then not Overwrite_Files then
1647 goto No_Files_Written;
1648 end if;
1649
1650 -- Check if any files exist, if so do not write anything
1651 -- Because all files have been parsed and checked already,
1652 -- there won't be any duplicates
1653
1654 if not Overwrite_Files and then Files_Exist then
1655 goto No_Files_Written;
1656 end if;
1657
1658 -- After this point, all source files are read in succession
1659 -- and chopped into their destination files.
1660
1661 -- As the Source_File_Name pragmas are handled as logical file 0,
1662 -- write it first.
1663
1664 for F in 1 .. File.Last loop
1665 if not Write_Chopped_Files (F) then
1666 Set_Exit_Status (Failure);
1667 return;
1668 end if;
1669 end loop;
1670
1671 if Warning_Count > 0 then
1672 declare
1673 Warnings_Msg : String := Warning_Count'Img & " warning(s)";
1674 begin
1675 Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last));
1676 end;
1677 end if;
1678
1679 return;
1680
1681 <<No_Files_Written>>
1682
1683 -- Special error exit for all situations where no files have
1684 -- been written.
1685
1686 if not Write_gnat_adc then
1687 Error_Msg ("no source files written");
1688 end if;
1689
1690 return;
1691
1692 exception
1693 when Terminate_Program =>
1694 null;
1695
1696 end Gnatchop;