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