OSDN Git Service

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