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