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