OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [gnatchop.adb] - Blame information for rev 826

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
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-2009, 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      : constant 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
      Contents := new String (1 .. Read_Ptr);
1024
      Contents.all := Buffer (1 .. Read_Ptr);
1025
 
1026
      --  Things aren't simple on VMS due to the plethora of file types and
1027
      --  organizations. It seems clear that there shouldn't be more bytes
1028
      --  read than are contained in the file though.
1029
 
1030
      if Hostparm.OpenVMS then
1031
         Success := Read_Ptr <= Length + 1;
1032
      else
1033
         Success := Read_Ptr = Length + 1;
1034
      end if;
1035
   end Read_File;
1036
 
1037
   ----------------------------
1038
   -- Report_Duplicate_Units --
1039
   ----------------------------
1040
 
1041
   function Report_Duplicate_Units return Boolean is
1042
      US : SUnit_Num;
1043
      U  : Unit_Num;
1044
 
1045
      Duplicates : Boolean  := False;
1046
 
1047
   begin
1048
      US := 1;
1049
      while US < SUnit_Num (Unit.Last) loop
1050
         U := Sorted_Units.Table (US);
1051
 
1052
         if Is_Duplicated (US) then
1053
            Duplicates := True;
1054
 
1055
            --  Move to last two versions of duplicated file to make it clearer
1056
            --  to understand which file is retained in case of overwriting.
1057
 
1058
            while US + 1 < SUnit_Num (Unit.Last) loop
1059
               exit when not Is_Duplicated (US + 1);
1060
               US := US + 1;
1061
            end loop;
1062
 
1063
            U := Sorted_Units.Table (US);
1064
 
1065
            if Overwrite_Files then
1066
               Warning_Msg (Unit.Table (U).File_Name.all
1067
                 & " is duplicated (all but last will be skipped)");
1068
 
1069
            elsif Unit.Table (U).Chop_File =
1070
                    Unit.Table (Sorted_Units.Table (US + 1)).Chop_File
1071
            then
1072
               Error_Msg (Unit.Table (U).File_Name.all
1073
                 & " is duplicated in "
1074
                 & File.Table (Unit.Table (U).Chop_File).Name.all);
1075
 
1076
            else
1077
               Error_Msg (Unit.Table (U).File_Name.all
1078
                  & " in "
1079
                  & File.Table (Unit.Table (U).Chop_File).Name.all
1080
                  & " is duplicated in "
1081
                  & File.Table
1082
                      (Unit.Table
1083
                        (Sorted_Units.Table (US + 1)).Chop_File).Name.all);
1084
            end if;
1085
         end if;
1086
 
1087
         US := US + 1;
1088
      end loop;
1089
 
1090
      if Duplicates and not Overwrite_Files then
1091
         if Hostparm.OpenVMS then
1092
            Put_Line
1093
              ("use /OVERWRITE to overwrite files and keep last version");
1094
         else
1095
            Put_Line ("use -w to overwrite files and keep last version");
1096
         end if;
1097
      end if;
1098
 
1099
      return Duplicates;
1100
   end Report_Duplicate_Units;
1101
 
1102
   --------------------
1103
   -- Scan_Arguments --
1104
   --------------------
1105
 
1106
   function Scan_Arguments return Boolean is
1107
      Kset : Boolean := False;
1108
      --  Set true if -k switch found
1109
 
1110
   begin
1111
      Initialize_Option_Scan;
1112
 
1113
      --  Scan options first
1114
 
1115
      loop
1116
         case Getopt ("c gnat? h k? p q r v w x -GCC=!") is
1117
            when ASCII.NUL =>
1118
               exit;
1119
 
1120
            when '-' =>
1121
               Gcc     := new String'(Parameter);
1122
               Gcc_Set := True;
1123
 
1124
            when 'c' =>
1125
               Compilation_Mode := True;
1126
 
1127
            when 'g' =>
1128
               Gnat_Args :=
1129
                 new Argument_List'(Gnat_Args.all &
1130
                                      new String'("-gnat" & Parameter));
1131
 
1132
            when 'h' =>
1133
               Usage;
1134
               raise Types.Terminate_Program;
1135
 
1136
            when 'k' =>
1137
               declare
1138
                  Param : String_Access := new String'(Parameter);
1139
 
1140
               begin
1141
                  if Param.all /= "" then
1142
                     for J in Param'Range loop
1143
                        if Param (J) not in '0' .. '9' then
1144
                           if Hostparm.OpenVMS then
1145
                              Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn" &
1146
                                         " requires numeric parameter");
1147
                           else
1148
                              Error_Msg ("-k# requires numeric parameter");
1149
                           end if;
1150
 
1151
                           return False;
1152
                        end if;
1153
                     end loop;
1154
 
1155
                  else
1156
                     if Hostparm.OpenVMS then
1157
                        Param := new String'("39");
1158
                     else
1159
                        Param := new String'("8");
1160
                     end if;
1161
                  end if;
1162
 
1163
                  Gnat_Args :=
1164
                    new Argument_List'(Gnat_Args.all &
1165
                                         new String'("-gnatk" & Param.all));
1166
                  Kset := True;
1167
               end;
1168
 
1169
            when 'p' =>
1170
               Preserve_Mode := True;
1171
 
1172
            when 'q' =>
1173
               Quiet_Mode := True;
1174
 
1175
            when 'r' =>
1176
               Source_References := True;
1177
 
1178
            when 'v' =>
1179
               Verbose_Mode := True;
1180
               Display_Version ("GNATCHOP", "1998");
1181
 
1182
            when 'w' =>
1183
               Overwrite_Files := True;
1184
 
1185
            when 'x' =>
1186
               Exit_On_Error := True;
1187
 
1188
            when others =>
1189
               null;
1190
         end case;
1191
      end loop;
1192
 
1193
      if not Kset and then Maximum_File_Name_Length > 0 then
1194
 
1195
         --  If this system has restricted filename lengths, tell gnat1
1196
         --  about them, removing the leading blank from the image string.
1197
 
1198
         Gnat_Args :=
1199
           new Argument_List'(Gnat_Args.all
1200
             & new String'("-gnatk"
1201
               & Maximum_File_Name_Length_String
1202
                 (Maximum_File_Name_Length_String'First + 1
1203
                  .. Maximum_File_Name_Length_String'Last)));
1204
      end if;
1205
 
1206
      --  Scan file names
1207
 
1208
      loop
1209
         declare
1210
            S : constant String := Get_Argument (Do_Expansion => True);
1211
 
1212
         begin
1213
            exit when S = "";
1214
            File.Increment_Last;
1215
            File.Table (File.Last).Name    := new String'(S);
1216
            File.Table (File.Last).SR_Name := null;
1217
         end;
1218
      end loop;
1219
 
1220
      --  Case of more than one file where last file is a directory
1221
 
1222
      if File.Last > 1
1223
        and then Is_Directory (File.Table (File.Last).Name.all)
1224
      then
1225
         Directory := File.Table (File.Last).Name;
1226
         File.Decrement_Last;
1227
 
1228
         --  Make sure Directory is terminated with a directory separator,
1229
         --  so we can generate the output by just appending a filename.
1230
 
1231
         if Directory (Directory'Last) /= Directory_Separator
1232
            and then Directory (Directory'Last) /= '/'
1233
         then
1234
            Directory := new String'(Directory.all & Directory_Separator);
1235
         end if;
1236
 
1237
      --  At least one filename must be given
1238
 
1239
      elsif File.Last = 0 then
1240
         Usage;
1241
         return False;
1242
 
1243
      --  No directory given, set directory to null, so that we can just
1244
      --  concatenate the directory name to the file name unconditionally.
1245
 
1246
      else
1247
         Directory := new String'("");
1248
      end if;
1249
 
1250
      --  Finally check all filename arguments
1251
 
1252
      for File_Num in 1 .. File.Last loop
1253
         declare
1254
            F : constant String := File.Table (File_Num).Name.all;
1255
 
1256
         begin
1257
            if Is_Directory (F) then
1258
               Error_Msg (F & " is a directory, cannot be chopped");
1259
               return False;
1260
 
1261
            elsif not Is_Regular_File (F) then
1262
               Error_Msg (F & " not found");
1263
               return False;
1264
            end if;
1265
         end;
1266
      end loop;
1267
 
1268
      return True;
1269
 
1270
   exception
1271
      when Invalid_Switch =>
1272
         Error_Msg ("invalid switch " & Full_Switch);
1273
         return False;
1274
 
1275
      when Invalid_Parameter =>
1276
         if Hostparm.OpenVMS then
1277
            Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn qualifier" &
1278
                       " requires numeric parameter");
1279
         else
1280
            Error_Msg ("-k switch requires numeric parameter");
1281
         end if;
1282
 
1283
         return False;
1284
   end Scan_Arguments;
1285
 
1286
   ----------------
1287
   -- Sort_Units --
1288
   ----------------
1289
 
1290
   procedure Sort_Units is
1291
 
1292
      procedure Move (From : Natural; To : Natural);
1293
      --  Procedure used to sort the unit list
1294
      --  Unit.Table (To) := Unit_List (From); used by sort
1295
 
1296
      function Lt (Left, Right : Natural) return Boolean;
1297
      --  Compares Left and Right units based on file name (first),
1298
      --  Chop_File (second) and Offset (third). This ordering is
1299
      --  important to keep the last version in case of duplicate files.
1300
 
1301
      package Unit_Sort is new GNAT.Heap_Sort_G (Move, Lt);
1302
      --  Used for sorting on filename to detect duplicates
1303
 
1304
      --------
1305
      -- Lt --
1306
      --------
1307
 
1308
      function Lt (Left, Right : Natural) return Boolean is
1309
         L : Unit_Info renames
1310
               Unit.Table (Sorted_Units.Table (SUnit_Num (Left)));
1311
 
1312
         R : Unit_Info renames
1313
               Unit.Table (Sorted_Units.Table (SUnit_Num (Right)));
1314
 
1315
      begin
1316
         return L.File_Name.all < R.File_Name.all
1317
           or else (L.File_Name.all = R.File_Name.all
1318
                     and then (L.Chop_File < R.Chop_File
1319
                                 or else (L.Chop_File = R.Chop_File
1320
                                            and then L.Offset < R.Offset)));
1321
      end Lt;
1322
 
1323
      ----------
1324
      -- Move --
1325
      ----------
1326
 
1327
      procedure Move (From : Natural; To : Natural) is
1328
      begin
1329
         Sorted_Units.Table (SUnit_Num (To)) :=
1330
           Sorted_Units.Table (SUnit_Num (From));
1331
      end Move;
1332
 
1333
   --  Start of processing for Sort_Units
1334
 
1335
   begin
1336
      Sorted_Units.Set_Last (SUnit_Num (Unit.Last));
1337
 
1338
      for J in 1 .. Unit.Last loop
1339
         Sorted_Units.Table (SUnit_Num (J)) := J;
1340
      end loop;
1341
 
1342
      --  Sort Unit.Table, using Sorted_Units.Table (0) as scratch
1343
 
1344
      Unit_Sort.Sort (Natural (Unit.Last));
1345
 
1346
      --  Set the Sorted_Index fields in the unit tables
1347
 
1348
      for J in 1 .. SUnit_Num (Unit.Last) loop
1349
         Unit.Table (Sorted_Units.Table (J)).Sorted_Index := J;
1350
      end loop;
1351
   end Sort_Units;
1352
 
1353
   -----------
1354
   -- Usage --
1355
   -----------
1356
 
1357
   procedure Usage is
1358
   begin
1359
      Put_Line
1360
        ("Usage: gnatchop [-c] [-h] [-k#] " &
1361
         "[-r] [-p] [-q] [-v] [-w] [-x] [--GCC=xx] file [file ...] [dir]");
1362
 
1363
      New_Line;
1364
      Put_Line
1365
        ("  -c       compilation mode, configuration pragmas " &
1366
         "follow RM rules");
1367
 
1368
      Put_Line
1369
        ("  -gnatxxx passes the -gnatxxx switch to gnat parser");
1370
 
1371
      Put_Line
1372
        ("  -h       help: output this usage information");
1373
 
1374
      Put_Line
1375
        ("  -k#      krunch file names of generated files to " &
1376
         "no more than # characters");
1377
 
1378
      Put_Line
1379
        ("  -k       krunch file names of generated files to " &
1380
         "no more than 8 characters");
1381
 
1382
      Put_Line
1383
        ("  -p       preserve time stamp, output files will " &
1384
         "have same stamp as input");
1385
 
1386
      Put_Line
1387
        ("  -q       quiet mode, no output of generated file " &
1388
         "names");
1389
 
1390
      Put_Line
1391
        ("  -r       generate Source_Reference pragmas refer" &
1392
         "encing original source file");
1393
 
1394
      Put_Line
1395
        ("  -v       verbose mode, output version and generat" &
1396
         "ed commands");
1397
 
1398
      Put_Line
1399
        ("  -w       overwrite existing filenames");
1400
 
1401
      Put_Line
1402
        ("  -x       exit on error");
1403
 
1404
      Put_Line
1405
        ("  --GCC=xx specify the path of the gnat parser to be used");
1406
 
1407
      New_Line;
1408
      Put_Line
1409
        ("  file...  list of source files to be chopped");
1410
 
1411
      Put_Line
1412
        ("  dir      directory location for split files (defa" &
1413
         "ult = current directory)");
1414
   end Usage;
1415
 
1416
   -----------------
1417
   -- Warning_Msg --
1418
   -----------------
1419
 
1420
   procedure Warning_Msg (Message : String) is
1421
   begin
1422
      Warning_Count := Warning_Count + 1;
1423
      Put_Line (Standard_Error, "warning: " & Message);
1424
   end Warning_Msg;
1425
 
1426
   -------------------------
1427
   -- Write_Chopped_Files --
1428
   -------------------------
1429
 
1430
   function Write_Chopped_Files (Input : File_Num) return Boolean is
1431
      Name    : aliased constant String :=
1432
                  File.Table (Input).Name.all & ASCII.NUL;
1433
      FD      : File_Descriptor;
1434
      Buffer  : String_Access;
1435
      Success : Boolean;
1436
      TS_Time : OS_Time;
1437
 
1438
      BOM_Present : Boolean;
1439
      BOM         : BOM_Kind;
1440
      --  Record presence of UTF8 BOM in input
1441
 
1442
   begin
1443
      FD := Open_Read (Name'Address, Binary);
1444
      TS_Time := File_Time_Stamp (FD);
1445
 
1446
      if FD = Invalid_FD then
1447
         Error_Msg ("cannot open " & File.Table (Input).Name.all);
1448
         return False;
1449
      end if;
1450
 
1451
      Read_File (FD, Buffer, Success);
1452
 
1453
      if not Success then
1454
         Error_Msg ("cannot read " & File.Table (Input).Name.all);
1455
         Close (FD);
1456
         return False;
1457
      end if;
1458
 
1459
      if not Quiet_Mode then
1460
         Put_Line ("splitting " & File.Table (Input).Name.all & " into:");
1461
      end if;
1462
 
1463
      --  Test for presence of BOM
1464
 
1465
      Read_BOM (Buffer.all, BOM_Length, BOM, False);
1466
      BOM_Present := BOM /= Unknown;
1467
 
1468
      --  Only chop those units that come from this file
1469
 
1470
      for Unit_Number in 1 .. Unit.Last loop
1471
         if Unit.Table (Unit_Number).Chop_File = Input then
1472
            Write_Unit
1473
              (Source    => Buffer,
1474
               Num       => Unit_Number,
1475
               TS_Time   => TS_Time,
1476
               Write_BOM => BOM_Present and then Unit_Number /= 1,
1477
               Success   => Success);
1478
            exit when not Success;
1479
         end if;
1480
      end loop;
1481
 
1482
      Close (FD);
1483
      return Success;
1484
   end Write_Chopped_Files;
1485
 
1486
   -----------------------
1487
   -- Write_Config_File --
1488
   -----------------------
1489
 
1490
   procedure Write_Config_File (Input : File_Num; U : Unit_Num) is
1491
      FD      : File_Descriptor;
1492
      Name    : aliased constant String := "gnat.adc" & ASCII.NUL;
1493
      Buffer  : String_Access;
1494
      Success : Boolean;
1495
      Append  : Boolean;
1496
      Buffera : String_Access;
1497
      Bufferl : Natural;
1498
 
1499
   begin
1500
      Write_gnat_adc := True;
1501
      FD := Open_Read_Write (Name'Address, Binary);
1502
 
1503
      if FD = Invalid_FD then
1504
         FD := Create_File (Name'Address, Binary);
1505
         Append := False;
1506
 
1507
         if not Quiet_Mode then
1508
            Put_Line ("writing configuration pragmas from " &
1509
               File.Table (Input).Name.all & " to gnat.adc");
1510
         end if;
1511
 
1512
      else
1513
         Append := True;
1514
 
1515
         if not Quiet_Mode then
1516
            Put_Line
1517
              ("appending configuration pragmas from " &
1518
               File.Table (Input).Name.all & " to gnat.adc");
1519
         end if;
1520
      end if;
1521
 
1522
      Success := FD /= Invalid_FD;
1523
 
1524
      if not Success then
1525
         Error_Msg ("cannot create gnat.adc");
1526
         return;
1527
      end if;
1528
 
1529
      --  In append mode, acquire existing gnat.adc file
1530
 
1531
      if Append then
1532
         Read_File (FD, Buffera, Success);
1533
 
1534
         if not Success then
1535
            Error_Msg ("cannot read gnat.adc");
1536
            return;
1537
         end if;
1538
 
1539
         --  Find location of EOF byte if any to exclude from append
1540
 
1541
         Bufferl := 1;
1542
         while Bufferl <= Buffera'Last
1543
           and then Buffera (Bufferl) /= EOF
1544
         loop
1545
            Bufferl := Bufferl + 1;
1546
         end loop;
1547
 
1548
         Bufferl := Bufferl - 1;
1549
         Close (FD);
1550
 
1551
         --  Write existing gnat.adc to new gnat.adc file
1552
 
1553
         FD := Create_File (Name'Address, Binary);
1554
         Success := Write (FD, Buffera (1)'Address, Bufferl) = Bufferl;
1555
 
1556
         if not Success then
1557
            Error_Msg ("error writing gnat.adc");
1558
            return;
1559
         end if;
1560
      end if;
1561
 
1562
      Buffer := Get_Config_Pragmas  (Input, U);
1563
 
1564
      if Buffer /= null then
1565
         Success := Write (FD, Buffer.all'Address, Buffer'Length) =
1566
                                 Buffer'Length;
1567
 
1568
         if not Success then
1569
            Error_Msg ("disk full writing gnat.adc");
1570
            return;
1571
         end if;
1572
      end if;
1573
 
1574
      Close (FD);
1575
   end Write_Config_File;
1576
 
1577
   -----------------------------------
1578
   -- Write_Source_Reference_Pragma --
1579
   -----------------------------------
1580
 
1581
   procedure Write_Source_Reference_Pragma
1582
     (Info    : Unit_Info;
1583
      Line    : Line_Num;
1584
      File    : Stream_IO.File_Type;
1585
      EOL     : EOL_String;
1586
      Success : in out Boolean)
1587
   is
1588
      FTE : File_Entry renames Gnatchop.File.Table (Info.Chop_File);
1589
      Nam : String_Access;
1590
 
1591
   begin
1592
      if Success and then Source_References and then not Info.SR_Present then
1593
         if FTE.SR_Name /= null then
1594
            Nam := FTE.SR_Name;
1595
         else
1596
            Nam := FTE.Name;
1597
         end if;
1598
 
1599
         declare
1600
            Reference : String :=
1601
                          "pragma Source_Reference (000000, """
1602
                            & Nam.all & """);" & EOL.Str;
1603
 
1604
            Pos : Positive := Reference'First;
1605
            Lin : Line_Num := Line;
1606
 
1607
         begin
1608
            while Reference (Pos + 1) /= ',' loop
1609
               Pos := Pos + 1;
1610
            end loop;
1611
 
1612
            while Reference (Pos) = '0' loop
1613
               Reference (Pos) := Character'Val
1614
                 (Character'Pos ('0') + Lin mod 10);
1615
               Lin := Lin / 10;
1616
               Pos := Pos - 1;
1617
            end loop;
1618
 
1619
            --  Assume there are enough zeroes for any program length
1620
 
1621
            pragma Assert (Lin = 0);
1622
 
1623
            begin
1624
               String'Write (Stream_IO.Stream (File), Reference);
1625
               Success := True;
1626
            exception
1627
               when others =>
1628
                  Success := False;
1629
            end;
1630
         end;
1631
      end if;
1632
   end Write_Source_Reference_Pragma;
1633
 
1634
   ----------------
1635
   -- Write_Unit --
1636
   ----------------
1637
 
1638
   procedure Write_Unit
1639
     (Source    : not null access String;
1640
      Num       : Unit_Num;
1641
      TS_Time   : OS_Time;
1642
      Write_BOM : Boolean;
1643
      Success   : out Boolean)
1644
   is
1645
 
1646
      procedure OS_Filename
1647
        (Name     : String;
1648
         W_Name   : Wide_String;
1649
         OS_Name  : Address;
1650
         N_Length : access Natural;
1651
         Encoding : Address;
1652
         E_Length : access Natural);
1653
      pragma Import (C, OS_Filename, "__gnat_os_filename");
1654
      --  Returns in OS_Name the proper name for the OS when used with the
1655
      --  returned Encoding value. For example on Windows this will return the
1656
      --  UTF-8 encoded name into OS_Name and set Encoding to encoding=utf8
1657
      --  (the form parameter for Stream_IO).
1658
      --
1659
      --  Name is the filename and W_Name the same filename in Unicode 16 bits
1660
      --  (this corresponds to Win32 Unicode ISO/IEC 10646). N_Length/E_Length
1661
      --  are the length returned in OS_Name/Encoding respectively.
1662
 
1663
      Info     : Unit_Info renames Unit.Table (Num);
1664
      Name     : aliased constant String := Info.File_Name.all & ASCII.NUL;
1665
      W_Name   : aliased constant Wide_String := To_Wide_String (Name);
1666
      EOL      : constant EOL_String :=
1667
                   Get_EOL (Source, Source'First + Info.Offset);
1668
      OS_Name  : aliased String (1 .. Name'Length * 2);
1669
      O_Length : aliased Natural := OS_Name'Length;
1670
      Encoding : aliased String (1 .. 64);
1671
      E_Length : aliased Natural := Encoding'Length;
1672
      Length   : File_Offset;
1673
 
1674
   begin
1675
      --  Skip duplicated files
1676
 
1677
      if Is_Duplicated (Info.Sorted_Index) then
1678
         Put_Line ("   " & Info.File_Name.all & " skipped");
1679
         Success := Overwrite_Files;
1680
         return;
1681
      end if;
1682
 
1683
      --  Get OS filename
1684
 
1685
      OS_Filename
1686
        (Name, W_Name,
1687
         OS_Name'Address, O_Length'Access,
1688
         Encoding'Address, E_Length'Access);
1689
 
1690
      declare
1691
         E_Name      : constant String := OS_Name (1 .. O_Length);
1692
         C_Name      : aliased constant String := E_Name & ASCII.NUL;
1693
         OS_Encoding : constant String := Encoding (1 .. E_Length);
1694
         File        : Stream_IO.File_Type;
1695
 
1696
      begin
1697
         begin
1698
            if not Overwrite_Files and then Exists (E_Name) then
1699
               raise Stream_IO.Name_Error;
1700
            else
1701
               Stream_IO.Create
1702
                 (File, Stream_IO.Out_File, E_Name, OS_Encoding);
1703
               Success := True;
1704
            end if;
1705
 
1706
         exception
1707
            when Stream_IO.Name_Error | Stream_IO.Use_Error =>
1708
               Error_Msg ("cannot create " & Info.File_Name.all);
1709
               return;
1710
         end;
1711
 
1712
         --  A length of 0 indicates that the rest of the file belongs to
1713
         --  this unit. The actual length must be calculated now. Take into
1714
         --  account that the last character (EOF) must not be written.
1715
 
1716
         if Info.Length = 0 then
1717
            Length := Source'Last - (Source'First + Info.Offset);
1718
         else
1719
            Length := Info.Length;
1720
         end if;
1721
 
1722
         --  Write BOM if required
1723
 
1724
         if Write_BOM then
1725
            String'Write
1726
              (Stream_IO.Stream (File),
1727
               Source.all (Source'First .. Source'First + BOM_Length - 1));
1728
         end if;
1729
 
1730
         --  Prepend configuration pragmas if necessary
1731
 
1732
         if Success and then Info.Bufferg /= null then
1733
            Write_Source_Reference_Pragma (Info, 1, File, EOL, Success);
1734
            String'Write (Stream_IO.Stream (File), Info.Bufferg.all);
1735
         end if;
1736
 
1737
         Write_Source_Reference_Pragma
1738
           (Info, Info.Start_Line, File, EOL, Success);
1739
 
1740
         if Success then
1741
            begin
1742
               String'Write
1743
                 (Stream_IO.Stream (File),
1744
                  Source (Source'First + Info.Offset ..
1745
                      Source'First + Info.Offset + Length - 1));
1746
            exception
1747
               when Stream_IO.Use_Error | Stream_IO.Device_Error =>
1748
                  Error_Msg ("disk full writing " & Info.File_Name.all);
1749
                  return;
1750
            end;
1751
         end if;
1752
 
1753
         if not Quiet_Mode then
1754
            Put_Line ("   " & Info.File_Name.all);
1755
         end if;
1756
 
1757
         Stream_IO.Close (File);
1758
 
1759
         if Preserve_Mode then
1760
            File_Time_Stamp (C_Name'Address, TS_Time);
1761
         end if;
1762
      end;
1763
   end Write_Unit;
1764
 
1765
      procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
1766
 
1767
--  Start of processing for gnatchop
1768
 
1769
begin
1770
   --  Add the directory where gnatchop is invoked in front of the path, if
1771
   --  gnatchop is invoked with directory information. Only do this if the
1772
   --  platform is not VMS, where the notion of path does not really exist.
1773
 
1774
   if not Hostparm.OpenVMS then
1775
      declare
1776
         Command : constant String := Command_Name;
1777
 
1778
      begin
1779
         for Index in reverse Command'Range loop
1780
            if Command (Index) = Directory_Separator then
1781
               declare
1782
                  Absolute_Dir : constant String :=
1783
                                   Normalize_Pathname
1784
                                     (Command (Command'First .. Index));
1785
                  PATH         : constant String :=
1786
                                   Absolute_Dir
1787
                                   & Path_Separator
1788
                                   & Getenv ("PATH").all;
1789
               begin
1790
                  Setenv ("PATH", PATH);
1791
               end;
1792
 
1793
               exit;
1794
            end if;
1795
         end loop;
1796
      end;
1797
   end if;
1798
 
1799
   --  Process command line options and initialize global variables
1800
 
1801
   --  First, scan to detect --version and/or --help
1802
 
1803
   Check_Version_And_Help ("GNATCHOP", "1998");
1804
 
1805
   if not Scan_Arguments then
1806
      Set_Exit_Status (Failure);
1807
      return;
1808
   end if;
1809
 
1810
   --  Check presence of required executables
1811
 
1812
   Gnat_Cmd := Locate_Executable (Gcc.all, not Gcc_Set);
1813
 
1814
   if Gnat_Cmd = null then
1815
      goto No_Files_Written;
1816
   end if;
1817
 
1818
   --  First parse all files and read offset information
1819
 
1820
   for Num in 1 .. File.Last loop
1821
      if not Parse_File (Num) then
1822
         goto No_Files_Written;
1823
      end if;
1824
   end loop;
1825
 
1826
   --  Check if any units have been found (assumes non-empty Unit.Table)
1827
 
1828
   if Unit.Last = 0 then
1829
      if not Write_gnat_adc then
1830
         Error_Msg ("no compilation units found", Warning => True);
1831
      end if;
1832
 
1833
      goto No_Files_Written;
1834
   end if;
1835
 
1836
   Sort_Units;
1837
 
1838
   --  Check if any duplicate files would be created. If so, emit a warning if
1839
   --  Overwrite_Files is true, otherwise generate an error.
1840
 
1841
   if Report_Duplicate_Units and then not Overwrite_Files then
1842
      goto No_Files_Written;
1843
   end if;
1844
 
1845
   --  Check if any files exist, if so do not write anything Because all files
1846
   --  have been parsed and checked already, there won't be any duplicates
1847
 
1848
   if not Overwrite_Files and then Files_Exist then
1849
      goto No_Files_Written;
1850
   end if;
1851
 
1852
   --  After this point, all source files are read in succession and chopped
1853
   --  into their destination files.
1854
 
1855
   --  Source_File_Name pragmas are handled as logical file 0 so write it first
1856
 
1857
   for F in 1 .. File.Last loop
1858
      if not Write_Chopped_Files (F) then
1859
         Set_Exit_Status (Failure);
1860
         return;
1861
      end if;
1862
   end loop;
1863
 
1864
   if Warning_Count > 0 then
1865
      declare
1866
         Warnings_Msg : constant String := Warning_Count'Img & " warning(s)";
1867
      begin
1868
         Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last), Warning => True);
1869
      end;
1870
   end if;
1871
 
1872
   return;
1873
 
1874
<<No_Files_Written>>
1875
 
1876
   --  Special error exit for all situations where no files have
1877
   --  been written.
1878
 
1879
   if not Write_gnat_adc then
1880
      Error_Msg ("no source files written", Warning => True);
1881
   end if;
1882
 
1883
   return;
1884
 
1885
exception
1886
   when Types.Terminate_Program =>
1887
      null;
1888
 
1889
end Gnatchop;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.