gcc/ada/gnatchop.adb

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