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