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