projects / gcc.git / blob
? search:


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