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