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