gcc/ada/g-os_lib.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                          G N A T . O S _ L I B                           --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 1995-2006, AdaCore                     --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with System.Case_Util;
  35 with System.CRTL;
  36 with System.Soft_Links;
  37 with Unchecked_Conversion;
  38 with Unchecked_Deallocation;
  39 with System; use System;
  40
  41 package body GNAT.OS_Lib is
  42
  43    --  Imported procedures Dup and Dup2 are used in procedures Spawn and
  44    --  Non_Blocking_Spawn.
  45
  46    function Dup (Fd : File_Descriptor) return File_Descriptor;
  47    pragma Import (C, Dup, "__gnat_dup");
  48
  49    procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
  50    pragma Import (C, Dup2, "__gnat_dup2");
  51
  52    OpenVMS : Boolean;
  53    --  Note: OpenVMS should be a constant, but it cannot be, because it
  54    --        prevents bootstrapping on some platforms.
  55
  56    pragma Import (Ada, OpenVMS, "system__openvms");
  57    --  Needed to avoid doing useless checks when non on a VMS platform (see
  58    --  Normalize_Pathname).
  59
  60    On_Windows : constant Boolean := Directory_Separator = '\';
  61    --  An indication that we are on Windows. Used in Normalize_Pathname, to
  62    --  deal with drive letters in the beginning of absolute paths.
  63
  64    package SSL renames System.Soft_Links;
  65
  66    --  The following are used by Create_Temp_File
  67
  68    First_Temp_File_Name : constant String := "GNAT-TEMP-000000.TMP";
  69    --  Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit
  70
  71    Current_Temp_File_Name : String := First_Temp_File_Name;
  72    --  Name of the temp file last created
  73
  74    Temp_File_Name_Last_Digit : constant Positive :=
  75                                  First_Temp_File_Name'Last - 4;
  76    --  Position of the last digit in Current_Temp_File_Name
  77
  78    Max_Attempts : constant := 100;
  79    --  The maximum number of attempts to create a new temp file
  80
  81    -----------------------
  82    -- Local Subprograms --
  83    -----------------------
  84
  85    function Args_Length (Args : Argument_List) return Natural;
  86    --  Returns total number of characters needed to create a string
  87    --  of all Args terminated by ASCII.NUL characters
  88
  89    function C_String_Length (S : Address) return Integer;
  90    --  Returns the length of a C string. Does check for null address
  91    --  (returns 0).
  92
  93    procedure Spawn_Internal
  94      (Program_Name : String;
  95       Args         : Argument_List;
  96       Result       : out Integer;
  97       Pid          : out Process_Id;
  98       Blocking     : Boolean);
  99    --  Internal routine to implement the two Spawn (blocking/non blocking)
 100    --  routines. If Blocking is set to True then the spawn is blocking
 101    --  otherwise it is non blocking. In this latter case the Pid contains the
 102    --  process id number. The first three parameters are as in Spawn. Note that
 103    --  Spawn_Internal normalizes the argument list before calling the low level
 104    --  system spawn routines (see Normalize_Arguments).
 105    --
 106    --  Note: Normalize_Arguments is designed to do nothing if it is called more
 107    --  than once, so calling Normalize_Arguments before calling one of the
 108    --  spawn routines is fine.
 109
 110    function To_Path_String_Access
 111      (Path_Addr : Address;
 112       Path_Len  : Integer) return String_Access;
 113    --  Converts a C String to an Ada String. We could do this making use of
 114    --  Interfaces.C.Strings but we prefer not to import that entire package
 115
 116    ---------
 117    -- "<" --
 118    ---------
 119
 120    function "<"  (X, Y : OS_Time) return Boolean is
 121    begin
 122       return Long_Integer (X) < Long_Integer (Y);
 123    end "<";
 124
 125    ----------
 126    -- "<=" --
 127    ----------
 128
 129    function "<="  (X, Y : OS_Time) return Boolean is
 130    begin
 131       return Long_Integer (X) <= Long_Integer (Y);
 132    end "<=";
 133
 134    ---------
 135    -- ">" --
 136    ---------
 137
 138    function ">"  (X, Y : OS_Time) return Boolean is
 139    begin
 140       return Long_Integer (X) > Long_Integer (Y);
 141    end ">";
 142
 143    ----------
 144    -- ">=" --
 145    ----------
 146
 147    function ">="  (X, Y : OS_Time) return Boolean is
 148    begin
 149       return Long_Integer (X) >= Long_Integer (Y);
 150    end ">=";
 151
 152    -----------------
 153    -- Args_Length --
 154    -----------------
 155
 156    function Args_Length (Args : Argument_List) return Natural is
 157       Len : Natural := 0;
 158
 159    begin
 160       for J in Args'Range loop
 161          Len := Len + Args (J)'Length + 1; --  One extra for ASCII.NUL
 162       end loop;
 163
 164       return Len;
 165    end Args_Length;
 166
 167    -----------------------------
 168    -- Argument_String_To_List --
 169    -----------------------------
 170
 171    function Argument_String_To_List
 172      (Arg_String : String) return Argument_List_Access
 173    is
 174       Max_Args : constant Integer := Arg_String'Length;
 175       New_Argv : Argument_List (1 .. Max_Args);
 176       New_Argc : Natural := 0;
 177       Idx      : Integer;
 178
 179    begin
 180       Idx := Arg_String'First;
 181
 182       loop
 183          exit when Idx > Arg_String'Last;
 184
 185          declare
 186             Quoted  : Boolean := False;
 187             Backqd  : Boolean := False;
 188             Old_Idx : Integer;
 189
 190          begin
 191             Old_Idx := Idx;
 192
 193             loop
 194                --  An unquoted space is the end of an argument
 195
 196                if not (Backqd or Quoted)
 197                  and then Arg_String (Idx) = ' '
 198                then
 199                   exit;
 200
 201                --  Start of a quoted string
 202
 203                elsif not (Backqd or Quoted)
 204                  and then Arg_String (Idx) = '"'
 205                then
 206                   Quoted := True;
 207
 208                --  End of a quoted string and end of an argument
 209
 210                elsif (Quoted and not Backqd)
 211                  and then Arg_String (Idx) = '"'
 212                then
 213                   Idx := Idx + 1;
 214                   exit;
 215
 216                --  Following character is backquoted
 217
 218                elsif Arg_String (Idx) = '\' then
 219                   Backqd := True;
 220
 221                --  Turn off backquoting after advancing one character
 222
 223                elsif Backqd then
 224                   Backqd := False;
 225
 226                end if;
 227
 228                Idx := Idx + 1;
 229                exit when Idx > Arg_String'Last;
 230             end loop;
 231
 232             --  Found an argument
 233
 234             New_Argc := New_Argc + 1;
 235             New_Argv (New_Argc) :=
 236               new String'(Arg_String (Old_Idx .. Idx - 1));
 237
 238             --  Skip extraneous spaces
 239
 240             while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop
 241                Idx := Idx + 1;
 242             end loop;
 243          end;
 244       end loop;
 245
 246       return new Argument_List'(New_Argv (1 .. New_Argc));
 247    end Argument_String_To_List;
 248
 249    ---------------------
 250    -- C_String_Length --
 251    ---------------------
 252
 253    function C_String_Length (S : Address) return Integer is
 254       function Strlen (S : Address) return Integer;
 255       pragma Import (C, Strlen, "strlen");
 256    begin
 257       if S = Null_Address then
 258          return 0;
 259       else
 260          return Strlen (S);
 261       end if;
 262    end C_String_Length;
 263
 264    -----------
 265    -- Close --
 266    -----------
 267
 268    procedure Close (FD : File_Descriptor) is
 269       procedure C_Close (FD : File_Descriptor);
 270       pragma Import (C, C_Close, "close");
 271    begin
 272       C_Close (FD);
 273    end Close;
 274
 275    procedure Close (FD : File_Descriptor; Status : out Boolean) is
 276       function C_Close (FD : File_Descriptor) return Integer;
 277       pragma Import (C, C_Close, "close");
 278    begin
 279       Status := (C_Close (FD) = 0);
 280    end Close;
 281
 282    ---------------
 283    -- Copy_File --
 284    ---------------
 285
 286    procedure Copy_File
 287      (Name     : String;
 288       Pathname : String;
 289       Success  : out Boolean;
 290       Mode     : Copy_Mode := Copy;
 291       Preserve : Attribute := Time_Stamps)
 292    is
 293       From : File_Descriptor;
 294       To   : File_Descriptor;
 295
 296       Copy_Error : exception;
 297       --  Internal exception raised to signal error in copy
 298
 299       function Build_Path (Dir : String; File : String) return String;
 300       --  Returns pathname Dir catenated with File adding the directory
 301       --  separator only if needed.
 302
 303       procedure Copy (From, To : File_Descriptor);
 304       --  Read data from From and place them into To. In both cases the
 305       --  operations uses the current file position. Raises Constraint_Error
 306       --  if a problem occurs during the copy.
 307
 308       procedure Copy_To (To_Name : String);
 309       --  Does a straight copy from source to designated destination file
 310
 311       ----------------
 312       -- Build_Path --
 313       ----------------
 314
 315       function Build_Path (Dir : String; File : String) return String is
 316          Res : String (1 .. Dir'Length + File'Length + 1);
 317
 318          Base_File_Ptr : Integer;
 319          --  The base file name is File (Base_File_Ptr + 1 .. File'Last)
 320
 321          function Is_Dirsep (C : Character) return Boolean;
 322          pragma Inline (Is_Dirsep);
 323          --  Returns True if C is a directory separator. On Windows we
 324          --  handle both styles of directory separator.
 325
 326          ---------------
 327          -- Is_Dirsep --
 328          ---------------
 329
 330          function Is_Dirsep (C : Character) return Boolean is
 331          begin
 332             return C = Directory_Separator or else C = '/';
 333          end Is_Dirsep;
 334
 335       --  Start of processing for Build_Path
 336
 337       begin
 338          --  Find base file name
 339
 340          Base_File_Ptr := File'Last;
 341          while Base_File_Ptr >= File'First loop
 342             exit when Is_Dirsep (File (Base_File_Ptr));
 343             Base_File_Ptr := Base_File_Ptr - 1;
 344          end loop;
 345
 346          declare
 347             Base_File : String renames
 348                           File (Base_File_Ptr + 1 .. File'Last);
 349
 350          begin
 351             Res (1 .. Dir'Length) := Dir;
 352
 353             if Is_Dirsep (Dir (Dir'Last)) then
 354                Res (Dir'Length + 1 .. Dir'Length + Base_File'Length) :=
 355                  Base_File;
 356                return Res (1 .. Dir'Length + Base_File'Length);
 357
 358             else
 359                Res (Dir'Length + 1) := Directory_Separator;
 360                Res (Dir'Length + 2 .. Dir'Length + 1 + Base_File'Length) :=
 361                  Base_File;
 362                return Res (1 .. Dir'Length + 1 + Base_File'Length);
 363             end if;
 364          end;
 365       end Build_Path;
 366
 367       ----------
 368       -- Copy --
 369       ----------
 370
 371       procedure Copy (From, To : File_Descriptor) is
 372          Buf_Size : constant := 200_000;
 373          type Buf is array (1 .. Buf_Size) of Character;
 374          type Buf_Ptr is access Buf;
 375
 376          Buffer : Buf_Ptr;
 377          R      : Integer;
 378          W      : Integer;
 379
 380          Status_From : Boolean;
 381          Status_To   : Boolean;
 382          --  Statuses for the calls to Close
 383
 384          procedure Free is new Unchecked_Deallocation (Buf, Buf_Ptr);
 385
 386       begin
 387          if From = Invalid_FD then
 388             raise Copy_Error;
 389
 390          elsif To = Invalid_FD then
 391             Close (From, Status_From);
 392             raise Copy_Error;
 393          end if;
 394
 395          --  Allocate the buffer on the heap
 396
 397          Buffer := new Buf;
 398
 399          loop
 400             R := Read (From, Buffer (1)'Address, Buf_Size);
 401
 402             --  For VMS, the buffer may not be full. So, we need to try again
 403             --  until there is nothing to read.
 404
 405             exit when R = 0;
 406
 407             W := Write (To, Buffer (1)'Address, R);
 408
 409             if W < R then
 410
 411                --  Problem writing data, could be a disk full. Close files
 412                --  without worrying about status, since we are raising a
 413                --  Copy_Error exception in any case.
 414
 415                Close (From, Status_From);
 416                Close (To, Status_To);
 417
 418                Free (Buffer);
 419
 420                raise Copy_Error;
 421             end if;
 422          end loop;
 423
 424          Close (From, Status_From);
 425          Close (To, Status_To);
 426
 427          Free (Buffer);
 428
 429          if not (Status_From and Status_To) then
 430             raise Copy_Error;
 431          end if;
 432       end Copy;
 433
 434       -------------
 435       -- Copy_To --
 436       -------------
 437
 438       procedure Copy_To (To_Name : String) is
 439
 440          function Copy_Attributes
 441            (From, To : System.Address;
 442             Mode     : Integer) return Integer;
 443          pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
 444          --  Mode = 0 - copy only time stamps.
 445          --  Mode = 1 - copy time stamps and read/write/execute attributes
 446
 447          C_From : String (1 .. Name'Length + 1);
 448          C_To   : String (1 .. To_Name'Length + 1);
 449
 450       begin
 451          From := Open_Read (Name, Binary);
 452          To   := Create_File (To_Name, Binary);
 453          Copy (From, To);
 454
 455          --  Copy attributes
 456
 457          C_From (1 .. Name'Length) := Name;
 458          C_From (C_From'Last) := ASCII.Nul;
 459
 460          C_To (1 .. To_Name'Length) := To_Name;
 461          C_To (C_To'Last) := ASCII.Nul;
 462
 463          case Preserve is
 464
 465             when Time_Stamps =>
 466                if Copy_Attributes (C_From'Address, C_To'Address, 0) = -1 then
 467                   raise Copy_Error;
 468                end if;
 469
 470             when Full =>
 471                if Copy_Attributes (C_From'Address, C_To'Address, 1) = -1 then
 472                   raise Copy_Error;
 473                end if;
 474
 475             when None =>
 476                null;
 477          end case;
 478
 479       end Copy_To;
 480
 481    --  Start of processing for Copy_File
 482
 483    begin
 484       Success := True;
 485
 486       --  The source file must exist
 487
 488       if not Is_Regular_File (Name) then
 489          raise Copy_Error;
 490       end if;
 491
 492       --  The source file exists
 493
 494       case Mode is
 495
 496          --  Copy case, target file must not exist
 497
 498          when Copy =>
 499
 500             --  If the target file exists, we have an error
 501
 502             if Is_Regular_File (Pathname) then
 503                raise Copy_Error;
 504
 505             --  Case of target is a directory
 506
 507             elsif Is_Directory (Pathname) then
 508                declare
 509                   Dest : constant String := Build_Path (Pathname, Name);
 510
 511                begin
 512                   --  If target file exists, we have an error, else do copy
 513
 514                   if Is_Regular_File (Dest) then
 515                      raise Copy_Error;
 516                   else
 517                      Copy_To (Dest);
 518                   end if;
 519                end;
 520
 521             --  Case of normal copy to file (destination does not exist)
 522
 523             else
 524                Copy_To (Pathname);
 525             end if;
 526
 527          --  Overwrite case (destination file may or may not exist)
 528
 529          when Overwrite =>
 530             if Is_Directory (Pathname) then
 531                Copy_To (Build_Path (Pathname, Name));
 532             else
 533                Copy_To (Pathname);
 534             end if;
 535
 536          --  Append case (destination file may or may not exist)
 537
 538          when Append =>
 539
 540             --  Appending to existing file
 541
 542             if Is_Regular_File (Pathname) then
 543
 544                --  Append mode and destination file exists, append data at the
 545                --  end of Pathname.
 546
 547                From := Open_Read (Name, Binary);
 548                To   := Open_Read_Write (Pathname, Binary);
 549                Lseek (To, 0, Seek_End);
 550
 551                Copy (From, To);
 552
 553             --  Appending to directory, not allowed
 554
 555             elsif Is_Directory (Pathname) then
 556                raise Copy_Error;
 557
 558             --  Appending when target file does not exist
 559
 560             else
 561                Copy_To (Pathname);
 562             end if;
 563       end case;
 564
 565    --  All error cases are caught here
 566
 567    exception
 568       when Copy_Error =>
 569          Success := False;
 570    end Copy_File;
 571
 572    procedure Copy_File
 573      (Name     : C_File_Name;
 574       Pathname : C_File_Name;
 575       Success  : out Boolean;
 576       Mode     : Copy_Mode := Copy;
 577       Preserve : Attribute := Time_Stamps)
 578    is
 579       Ada_Name : String_Access :=
 580                    To_Path_String_Access
 581                      (Name, C_String_Length (Name));
 582
 583       Ada_Pathname : String_Access :=
 584                        To_Path_String_Access
 585                          (Pathname, C_String_Length (Pathname));
 586
 587    begin
 588       Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve);
 589       Free (Ada_Name);
 590       Free (Ada_Pathname);
 591    end Copy_File;
 592
 593    ----------------------
 594    -- Copy_Time_Stamps --
 595    ----------------------
 596
 597    procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean) is
 598
 599       function Copy_Attributes
 600         (From, To : System.Address;
 601          Mode     : Integer) return Integer;
 602       pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
 603       --  Mode = 0 - copy only time stamps.
 604       --  Mode = 1 - copy time stamps and read/write/execute attributes
 605
 606    begin
 607       if Is_Regular_File (Source) and then Is_Writable_File (Dest) then
 608          declare
 609             C_Source : String (1 .. Source'Length + 1);
 610             C_Dest   : String (1 .. Dest'Length + 1);
 611          begin
 612             C_Source (1 .. Source'Length) := Source;
 613             C_Source (C_Source'Last)      := ASCII.NUL;
 614
 615             C_Dest (1 .. Dest'Length) := Dest;
 616             C_Dest (C_Dest'Last)      := ASCII.NUL;
 617
 618             if Copy_Attributes (C_Source'Address, C_Dest'Address, 0) = -1 then
 619                Success := False;
 620             else
 621                Success := True;
 622             end if;
 623          end;
 624
 625       else
 626          Success := False;
 627       end if;
 628    end Copy_Time_Stamps;
 629
 630    procedure Copy_Time_Stamps
 631      (Source, Dest : C_File_Name;
 632       Success      : out Boolean)
 633    is
 634       Ada_Source : String_Access :=
 635                      To_Path_String_Access
 636                        (Source, C_String_Length (Source));
 637
 638       Ada_Dest : String_Access :=
 639                    To_Path_String_Access
 640                      (Dest, C_String_Length (Dest));
 641    begin
 642       Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success);
 643       Free (Ada_Source);
 644       Free (Ada_Dest);
 645    end Copy_Time_Stamps;
 646
 647    -----------------
 648    -- Create_File --
 649    -----------------
 650
 651    function Create_File
 652      (Name  : C_File_Name;
 653       Fmode : Mode) return File_Descriptor
 654    is
 655       function C_Create_File
 656         (Name  : C_File_Name;
 657          Fmode : Mode) return File_Descriptor;
 658       pragma Import (C, C_Create_File, "__gnat_open_create");
 659
 660    begin
 661       return C_Create_File (Name, Fmode);
 662    end Create_File;
 663
 664    function Create_File
 665      (Name  : String;
 666       Fmode : Mode) return File_Descriptor
 667    is
 668       C_Name : String (1 .. Name'Length + 1);
 669
 670    begin
 671       C_Name (1 .. Name'Length) := Name;
 672       C_Name (C_Name'Last)      := ASCII.NUL;
 673       return Create_File (C_Name (C_Name'First)'Address, Fmode);
 674    end Create_File;
 675
 676    ---------------------
 677    -- Create_New_File --
 678    ---------------------
 679
 680    function Create_New_File
 681      (Name  : C_File_Name;
 682       Fmode : Mode) return File_Descriptor
 683    is
 684       function C_Create_New_File
 685         (Name  : C_File_Name;
 686          Fmode : Mode) return File_Descriptor;
 687       pragma Import (C, C_Create_New_File, "__gnat_open_new");
 688
 689    begin
 690       return C_Create_New_File (Name, Fmode);
 691    end Create_New_File;
 692
 693    function Create_New_File
 694      (Name  : String;
 695       Fmode : Mode) return File_Descriptor
 696    is
 697       C_Name : String (1 .. Name'Length + 1);
 698
 699    begin
 700       C_Name (1 .. Name'Length) := Name;
 701       C_Name (C_Name'Last)      := ASCII.NUL;
 702       return Create_New_File (C_Name (C_Name'First)'Address, Fmode);
 703    end Create_New_File;
 704
 705    -----------------------------
 706    -- Create_Output_Text_File --
 707    -----------------------------
 708
 709    function Create_Output_Text_File (Name  : String) return File_Descriptor is
 710       function C_Create_File
 711         (Name  : C_File_Name) return File_Descriptor;
 712       pragma Import (C, C_Create_File, "__gnat_create_output_file");
 713
 714       C_Name : String (1 .. Name'Length + 1);
 715
 716    begin
 717       C_Name (1 .. Name'Length) := Name;
 718       C_Name (C_Name'Last)      := ASCII.NUL;
 719       return C_Create_File (C_Name (C_Name'First)'Address);
 720    end Create_Output_Text_File;
 721
 722    ----------------------
 723    -- Create_Temp_File --
 724    ----------------------
 725
 726    procedure Create_Temp_File
 727      (FD   : out File_Descriptor;
 728       Name : out Temp_File_Name)
 729    is
 730       function Open_New_Temp
 731         (Name  : System.Address;
 732          Fmode : Mode) return File_Descriptor;
 733       pragma Import (C, Open_New_Temp, "__gnat_open_new_temp");
 734
 735    begin
 736       FD := Open_New_Temp (Name'Address, Binary);
 737    end Create_Temp_File;
 738
 739    procedure Create_Temp_File
 740      (FD   : out File_Descriptor;
 741       Name : out String_Access)
 742    is
 743       Pos      : Positive;
 744       Attempts : Natural := 0;
 745       Current  : String (Current_Temp_File_Name'Range);
 746
 747    begin
 748       --  Loop until a new temp file can be created
 749
 750       File_Loop : loop
 751          Locked : begin
 752             --  We need to protect global variable Current_Temp_File_Name
 753             --  against concurrent access by different tasks.
 754
 755             SSL.Lock_Task.all;
 756
 757             --  Start at the last digit
 758
 759             Pos := Temp_File_Name_Last_Digit;
 760
 761             Digit_Loop :
 762             loop
 763                --  Increment the digit by one
 764
 765                case Current_Temp_File_Name (Pos) is
 766                   when '0' .. '8' =>
 767                      Current_Temp_File_Name (Pos) :=
 768                        Character'Succ (Current_Temp_File_Name (Pos));
 769                      exit Digit_Loop;
 770
 771                   when '9' =>
 772
 773                      --  For 9, set the digit to 0 and go to the previous digit
 774
 775                      Current_Temp_File_Name (Pos) := '0';
 776                      Pos := Pos - 1;
 777
 778                   when others =>
 779
 780                      --  If it is not a digit, then there are no available
 781                      --  temp file names. Return Invalid_FD. There is almost
 782                      --  no that this code will be ever be executed, since
 783                      --  it would mean that there are one million temp files
 784                      --  in the same directory!
 785
 786                      SSL.Unlock_Task.all;
 787                      FD := Invalid_FD;
 788                      Name := null;
 789                      exit File_Loop;
 790                end case;
 791             end loop Digit_Loop;
 792
 793             Current := Current_Temp_File_Name;
 794
 795             --  We can now release the lock, because we are no longer
 796             --  accessing Current_Temp_File_Name.
 797
 798             SSL.Unlock_Task.all;
 799
 800          exception
 801             when others =>
 802                SSL.Unlock_Task.all;
 803                raise;
 804          end Locked;
 805
 806          --  Attempt to create the file
 807
 808          FD := Create_New_File (Current, Binary);
 809
 810          if FD /= Invalid_FD then
 811             Name := new String'(Current);
 812             exit File_Loop;
 813          end if;
 814
 815          if not Is_Regular_File (Current) then
 816
 817             --  If the file does not already exist and we are unable to create
 818             --  it, we give up after Max_Attempts. Otherwise, we try again with
 819             --  the next available file name.
 820
 821             Attempts := Attempts + 1;
 822
 823             if Attempts >= Max_Attempts then
 824                FD := Invalid_FD;
 825                Name := null;
 826                exit File_Loop;
 827             end if;
 828          end if;
 829       end loop File_Loop;
 830    end Create_Temp_File;
 831
 832    -----------------
 833    -- Delete_File --
 834    -----------------
 835
 836    procedure Delete_File (Name : Address; Success : out Boolean) is
 837       R : Integer;
 838
 839       function unlink (A : Address) return Integer;
 840       pragma Import (C, unlink, "unlink");
 841
 842    begin
 843       R := unlink (Name);
 844       Success := (R = 0);
 845    end Delete_File;
 846
 847    procedure Delete_File (Name : String; Success : out Boolean) is
 848       C_Name : String (1 .. Name'Length + 1);
 849
 850    begin
 851       C_Name (1 .. Name'Length) := Name;
 852       C_Name (C_Name'Last)      := ASCII.NUL;
 853
 854       Delete_File (C_Name'Address, Success);
 855    end Delete_File;
 856
 857    ---------------------
 858    -- File_Time_Stamp --
 859    ---------------------
 860
 861    function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
 862       function File_Time (FD    : File_Descriptor) return OS_Time;
 863       pragma Import (C, File_Time, "__gnat_file_time_fd");
 864    begin
 865       return File_Time (FD);
 866    end File_Time_Stamp;
 867
 868    function File_Time_Stamp (Name : C_File_Name) return OS_Time is
 869       function File_Time (Name : Address) return OS_Time;
 870       pragma Import (C, File_Time, "__gnat_file_time_name");
 871    begin
 872       return File_Time (Name);
 873    end File_Time_Stamp;
 874
 875    function File_Time_Stamp (Name : String) return OS_Time is
 876       F_Name : String (1 .. Name'Length + 1);
 877    begin
 878       F_Name (1 .. Name'Length) := Name;
 879       F_Name (F_Name'Last)      := ASCII.NUL;
 880       return File_Time_Stamp (F_Name'Address);
 881    end File_Time_Stamp;
 882
 883    ---------------------------
 884    -- Get_Debuggable_Suffix --
 885    ---------------------------
 886
 887    function Get_Debuggable_Suffix return String_Access is
 888       procedure Get_Suffix_Ptr (Length, Ptr : Address);
 889       pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
 890
 891       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
 892       pragma Import (C, Strncpy, "strncpy");
 893
 894       Suffix_Ptr    : Address;
 895       Suffix_Length : Integer;
 896       Result        : String_Access;
 897
 898    begin
 899       Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
 900
 901       Result := new String (1 .. Suffix_Length);
 902
 903       if Suffix_Length > 0 then
 904          Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
 905       end if;
 906
 907       return Result;
 908    end Get_Debuggable_Suffix;
 909
 910    ----------------------------------
 911    -- Get_Target_Debuggable_Suffix --
 912    ----------------------------------
 913
 914    function Get_Target_Debuggable_Suffix return String_Access is
 915       Target_Exec_Ext_Ptr : Address;
 916       pragma Import
 917         (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension");
 918
 919       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
 920       pragma Import (C, Strncpy, "strncpy");
 921
 922       function Strlen (Cstring : Address) return Integer;
 923       pragma Import (C, Strlen, "strlen");
 924
 925       Suffix_Length : Integer;
 926       Result        : String_Access;
 927
 928    begin
 929       Suffix_Length := Strlen (Target_Exec_Ext_Ptr);
 930
 931       Result := new String (1 .. Suffix_Length);
 932
 933       if Suffix_Length > 0 then
 934          Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length);
 935       end if;
 936
 937       return Result;
 938    end Get_Target_Debuggable_Suffix;
 939
 940    ---------------------------
 941    -- Get_Executable_Suffix --
 942    ---------------------------
 943
 944    function Get_Executable_Suffix return String_Access is
 945       procedure Get_Suffix_Ptr (Length, Ptr : Address);
 946       pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
 947
 948       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
 949       pragma Import (C, Strncpy, "strncpy");
 950
 951       Suffix_Ptr    : Address;
 952       Suffix_Length : Integer;
 953       Result        : String_Access;
 954
 955    begin
 956       Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
 957
 958       Result := new String (1 .. Suffix_Length);
 959
 960       if Suffix_Length > 0 then
 961          Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
 962       end if;
 963
 964       return Result;
 965    end Get_Executable_Suffix;
 966
 967    ----------------------------------
 968    -- Get_Target_Executable_Suffix --
 969    ----------------------------------
 970
 971    function Get_Target_Executable_Suffix return String_Access is
 972       Target_Exec_Ext_Ptr : Address;
 973       pragma Import
 974         (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension");
 975
 976       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
 977       pragma Import (C, Strncpy, "strncpy");
 978
 979       function Strlen (Cstring : Address) return Integer;
 980       pragma Import (C, Strlen, "strlen");
 981
 982       Suffix_Length : Integer;
 983       Result        : String_Access;
 984
 985    begin
 986       Suffix_Length := Strlen (Target_Exec_Ext_Ptr);
 987
 988       Result := new String (1 .. Suffix_Length);
 989
 990       if Suffix_Length > 0 then
 991          Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length);
 992       end if;
 993
 994       return Result;
 995    end Get_Target_Executable_Suffix;
 996
 997    -----------------------
 998    -- Get_Object_Suffix --
 999    -----------------------
1000
1001    function Get_Object_Suffix return String_Access is
1002       procedure Get_Suffix_Ptr (Length, Ptr : Address);
1003       pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
1004
1005       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1006       pragma Import (C, Strncpy, "strncpy");
1007
1008       Suffix_Ptr    : Address;
1009       Suffix_Length : Integer;
1010       Result        : String_Access;
1011
1012    begin
1013       Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
1014
1015       Result := new String (1 .. Suffix_Length);
1016
1017       if Suffix_Length > 0 then
1018          Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
1019       end if;
1020
1021       return Result;
1022    end Get_Object_Suffix;
1023
1024    ------------------------------
1025    -- Get_Target_Object_Suffix --
1026    ------------------------------
1027
1028    function Get_Target_Object_Suffix return String_Access is
1029       Target_Object_Ext_Ptr : Address;
1030       pragma Import
1031         (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension");
1032
1033       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1034       pragma Import (C, Strncpy, "strncpy");
1035
1036       function Strlen (Cstring : Address) return Integer;
1037       pragma Import (C, Strlen, "strlen");
1038
1039       Suffix_Length : Integer;
1040       Result        : String_Access;
1041
1042    begin
1043       Suffix_Length := Strlen (Target_Object_Ext_Ptr);
1044
1045       Result := new String (1 .. Suffix_Length);
1046
1047       if Suffix_Length > 0 then
1048          Strncpy (Result.all'Address, Target_Object_Ext_Ptr, Suffix_Length);
1049       end if;
1050
1051       return Result;
1052    end Get_Target_Object_Suffix;
1053
1054    ------------
1055    -- Getenv --
1056    ------------
1057
1058    function Getenv (Name : String) return String_Access is
1059       procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
1060       pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
1061
1062       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1063       pragma Import (C, Strncpy, "strncpy");
1064
1065       Env_Value_Ptr    : aliased Address;
1066       Env_Value_Length : aliased Integer;
1067       F_Name           : aliased String (1 .. Name'Length + 1);
1068       Result           : String_Access;
1069
1070    begin
1071       F_Name (1 .. Name'Length) := Name;
1072       F_Name (F_Name'Last)      := ASCII.NUL;
1073
1074       Get_Env_Value_Ptr
1075         (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
1076
1077       Result := new String (1 .. Env_Value_Length);
1078
1079       if Env_Value_Length > 0 then
1080          Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
1081       end if;
1082
1083       return Result;
1084    end Getenv;
1085
1086    ------------
1087    -- GM_Day --
1088    ------------
1089
1090    function GM_Day (Date : OS_Time) return Day_Type is
1091       Y  : Year_Type;
1092       Mo : Month_Type;
1093       D  : Day_Type;
1094       H  : Hour_Type;
1095       Mn : Minute_Type;
1096       S  : Second_Type;
1097
1098    begin
1099       GM_Split (Date, Y, Mo, D, H, Mn, S);
1100       return D;
1101    end GM_Day;
1102
1103    -------------
1104    -- GM_Hour --
1105    -------------
1106
1107    function GM_Hour (Date : OS_Time) return Hour_Type is
1108       Y  : Year_Type;
1109       Mo : Month_Type;
1110       D  : Day_Type;
1111       H  : Hour_Type;
1112       Mn : Minute_Type;
1113       S  : Second_Type;
1114
1115    begin
1116       GM_Split (Date, Y, Mo, D, H, Mn, S);
1117       return H;
1118    end GM_Hour;
1119
1120    ---------------
1121    -- GM_Minute --
1122    ---------------
1123
1124    function GM_Minute (Date : OS_Time) return Minute_Type is
1125       Y  : Year_Type;
1126       Mo : Month_Type;
1127       D  : Day_Type;
1128       H  : Hour_Type;
1129       Mn : Minute_Type;
1130       S  : Second_Type;
1131
1132    begin
1133       GM_Split (Date, Y, Mo, D, H, Mn, S);
1134       return Mn;
1135    end GM_Minute;
1136
1137    --------------
1138    -- GM_Month --
1139    --------------
1140
1141    function GM_Month (Date : OS_Time) return Month_Type is
1142       Y  : Year_Type;
1143       Mo : Month_Type;
1144       D  : Day_Type;
1145       H  : Hour_Type;
1146       Mn : Minute_Type;
1147       S  : Second_Type;
1148
1149    begin
1150       GM_Split (Date, Y, Mo, D, H, Mn, S);
1151       return Mo;
1152    end GM_Month;
1153
1154    ---------------
1155    -- GM_Second --
1156    ---------------
1157
1158    function GM_Second (Date : OS_Time) return Second_Type is
1159       Y  : Year_Type;
1160       Mo : Month_Type;
1161       D  : Day_Type;
1162       H  : Hour_Type;
1163       Mn : Minute_Type;
1164       S  : Second_Type;
1165
1166    begin
1167       GM_Split (Date, Y, Mo, D, H, Mn, S);
1168       return S;
1169    end GM_Second;
1170
1171    --------------
1172    -- GM_Split --
1173    --------------
1174
1175    procedure GM_Split
1176      (Date   : OS_Time;
1177       Year   : out Year_Type;
1178       Month  : out Month_Type;
1179       Day    : out Day_Type;
1180       Hour   : out Hour_Type;
1181       Minute : out Minute_Type;
1182       Second : out Second_Type)
1183    is
1184       procedure To_GM_Time
1185         (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
1186       pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
1187
1188       T  : OS_Time := Date;
1189       Y  : Integer;
1190       Mo : Integer;
1191       D  : Integer;
1192       H  : Integer;
1193       Mn : Integer;
1194       S  : Integer;
1195
1196    begin
1197       --  Use the global lock because To_GM_Time is not thread safe
1198
1199       Locked_Processing : begin
1200          SSL.Lock_Task.all;
1201          To_GM_Time
1202            (T'Address, Y'Address, Mo'Address, D'Address,
1203             H'Address, Mn'Address, S'Address);
1204          SSL.Unlock_Task.all;
1205
1206       exception
1207          when others =>
1208             SSL.Unlock_Task.all;
1209             raise;
1210       end Locked_Processing;
1211
1212       Year   := Y + 1900;
1213       Month  := Mo + 1;
1214       Day    := D;
1215       Hour   := H;
1216       Minute := Mn;
1217       Second := S;
1218    end GM_Split;
1219
1220    -------------
1221    -- GM_Year --
1222    -------------
1223
1224    function GM_Year (Date : OS_Time) return Year_Type is
1225       Y  : Year_Type;
1226       Mo : Month_Type;
1227       D  : Day_Type;
1228       H  : Hour_Type;
1229       Mn : Minute_Type;
1230       S  : Second_Type;
1231
1232    begin
1233       GM_Split (Date, Y, Mo, D, H, Mn, S);
1234       return Y;
1235    end GM_Year;
1236
1237    ----------------------
1238    -- Is_Absolute_Path --
1239    ----------------------
1240
1241    function Is_Absolute_Path (Name : String) return Boolean is
1242       function Is_Absolute_Path
1243         (Name   : Address;
1244          Length : Integer) return Integer;
1245       pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
1246    begin
1247       return Is_Absolute_Path (Name'Address, Name'Length) /= 0;
1248    end Is_Absolute_Path;
1249
1250    ------------------
1251    -- Is_Directory --
1252    ------------------
1253
1254    function Is_Directory (Name : C_File_Name) return Boolean is
1255       function Is_Directory (Name : Address) return Integer;
1256       pragma Import (C, Is_Directory, "__gnat_is_directory");
1257    begin
1258       return Is_Directory (Name) /= 0;
1259    end Is_Directory;
1260
1261    function Is_Directory (Name : String) return Boolean is
1262       F_Name : String (1 .. Name'Length + 1);
1263    begin
1264       F_Name (1 .. Name'Length) := Name;
1265       F_Name (F_Name'Last)      := ASCII.NUL;
1266       return Is_Directory (F_Name'Address);
1267    end Is_Directory;
1268
1269    ---------------------
1270    -- Is_Regular_File --
1271    ---------------------
1272
1273    function Is_Regular_File (Name : C_File_Name) return Boolean is
1274       function Is_Regular_File (Name : Address) return Integer;
1275       pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
1276    begin
1277       return Is_Regular_File (Name) /= 0;
1278    end Is_Regular_File;
1279
1280    function Is_Regular_File (Name : String) return Boolean is
1281       F_Name : String (1 .. Name'Length + 1);
1282    begin
1283       F_Name (1 .. Name'Length) := Name;
1284       F_Name (F_Name'Last)      := ASCII.NUL;
1285       return Is_Regular_File (F_Name'Address);
1286    end Is_Regular_File;
1287
1288    ----------------------
1289    -- Is_Readable_File --
1290    ----------------------
1291
1292    function Is_Readable_File (Name : C_File_Name) return Boolean is
1293       function Is_Readable_File (Name : Address) return Integer;
1294       pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
1295    begin
1296       return Is_Readable_File (Name) /= 0;
1297    end Is_Readable_File;
1298
1299    function Is_Readable_File (Name : String) return Boolean is
1300       F_Name : String (1 .. Name'Length + 1);
1301    begin
1302       F_Name (1 .. Name'Length) := Name;
1303       F_Name (F_Name'Last)      := ASCII.NUL;
1304       return Is_Readable_File (F_Name'Address);
1305    end Is_Readable_File;
1306
1307    ----------------------
1308    -- Is_Writable_File --
1309    ----------------------
1310
1311    function Is_Writable_File (Name : C_File_Name) return Boolean is
1312       function Is_Writable_File (Name : Address) return Integer;
1313       pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
1314    begin
1315       return Is_Writable_File (Name) /= 0;
1316    end Is_Writable_File;
1317
1318    function Is_Writable_File (Name : String) return Boolean is
1319       F_Name : String (1 .. Name'Length + 1);
1320    begin
1321       F_Name (1 .. Name'Length) := Name;
1322       F_Name (F_Name'Last)      := ASCII.NUL;
1323       return Is_Writable_File (F_Name'Address);
1324    end Is_Writable_File;
1325
1326    ----------------------
1327    -- Is_Symbolic_Link --
1328    ----------------------
1329
1330    function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
1331       function Is_Symbolic_Link (Name : Address) return Integer;
1332       pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
1333    begin
1334       return Is_Symbolic_Link (Name) /= 0;
1335    end Is_Symbolic_Link;
1336
1337    function Is_Symbolic_Link (Name : String) return Boolean is
1338       F_Name : String (1 .. Name'Length + 1);
1339    begin
1340       F_Name (1 .. Name'Length) := Name;
1341       F_Name (F_Name'Last)      := ASCII.NUL;
1342       return Is_Symbolic_Link (F_Name'Address);
1343    end Is_Symbolic_Link;
1344
1345    -------------------------
1346    -- Locate_Exec_On_Path --
1347    -------------------------
1348
1349    function Locate_Exec_On_Path
1350      (Exec_Name : String) return String_Access
1351    is
1352       function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
1353       pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
1354
1355       procedure Free (Ptr : System.Address);
1356       pragma Import (C, Free, "free");
1357
1358       C_Exec_Name  : String (1 .. Exec_Name'Length + 1);
1359       Path_Addr    : Address;
1360       Path_Len     : Integer;
1361       Result       : String_Access;
1362
1363    begin
1364       C_Exec_Name (1 .. Exec_Name'Length)   := Exec_Name;
1365       C_Exec_Name (C_Exec_Name'Last)        := ASCII.NUL;
1366
1367       Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
1368       Path_Len  := C_String_Length (Path_Addr);
1369
1370       if Path_Len = 0 then
1371          return null;
1372
1373       else
1374          Result := To_Path_String_Access (Path_Addr, Path_Len);
1375          Free (Path_Addr);
1376          return Result;
1377       end if;
1378    end Locate_Exec_On_Path;
1379
1380    -------------------------
1381    -- Locate_Regular_File --
1382    -------------------------
1383
1384    function Locate_Regular_File
1385      (File_Name : C_File_Name;
1386       Path      : C_File_Name) return String_Access
1387    is
1388       function Locate_Regular_File
1389         (C_File_Name, Path_Val : Address) return Address;
1390       pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file");
1391
1392       procedure Free (Ptr : System.Address);
1393       pragma Import (C, Free, "free");
1394
1395       Path_Addr    : Address;
1396       Path_Len     : Integer;
1397       Result       : String_Access;
1398
1399    begin
1400       Path_Addr := Locate_Regular_File (File_Name, Path);
1401       Path_Len  := C_String_Length (Path_Addr);
1402
1403       if Path_Len = 0 then
1404          return null;
1405       else
1406          Result := To_Path_String_Access (Path_Addr, Path_Len);
1407          Free (Path_Addr);
1408          return Result;
1409       end if;
1410    end Locate_Regular_File;
1411
1412    function Locate_Regular_File
1413      (File_Name : String;
1414       Path      : String) return String_Access
1415    is
1416       C_File_Name : String (1 .. File_Name'Length + 1);
1417       C_Path      : String (1 .. Path'Length + 1);
1418
1419    begin
1420       C_File_Name (1 .. File_Name'Length)   := File_Name;
1421       C_File_Name (C_File_Name'Last)        := ASCII.NUL;
1422
1423       C_Path    (1 .. Path'Length)          := Path;
1424       C_Path    (C_Path'Last)               := ASCII.NUL;
1425
1426       return Locate_Regular_File (C_File_Name'Address, C_Path'Address);
1427    end Locate_Regular_File;
1428
1429    ------------------------
1430    -- Non_Blocking_Spawn --
1431    ------------------------
1432
1433    function Non_Blocking_Spawn
1434      (Program_Name : String;
1435       Args         : Argument_List) return Process_Id
1436    is
1437       Junk : Integer;
1438       Pid  : Process_Id;
1439
1440    begin
1441       Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
1442       return Pid;
1443    end Non_Blocking_Spawn;
1444
1445    function Non_Blocking_Spawn
1446      (Program_Name           : String;
1447       Args                   : Argument_List;
1448       Output_File_Descriptor : File_Descriptor;
1449       Err_To_Out             : Boolean := True)
1450       return                   Process_Id
1451    is
1452       Saved_Output : File_Descriptor;
1453       Saved_Error  : File_Descriptor := Invalid_FD; -- prevent warning
1454       Pid          : Process_Id;
1455    begin
1456       if Output_File_Descriptor = Invalid_FD then
1457          return Invalid_Pid;
1458       end if;
1459
1460       --  Set standard output and, if specified, error to the temporary file
1461
1462       Saved_Output := Dup (Standout);
1463       Dup2 (Output_File_Descriptor, Standout);
1464
1465       if Err_To_Out then
1466          Saved_Error  := Dup (Standerr);
1467          Dup2 (Output_File_Descriptor, Standerr);
1468       end if;
1469
1470       --  Spawn the program
1471
1472       Pid := Non_Blocking_Spawn (Program_Name, Args);
1473
1474       --  Restore the standard output and error
1475
1476       Dup2 (Saved_Output, Standout);
1477
1478       if Err_To_Out then
1479          Dup2 (Saved_Error, Standerr);
1480       end if;
1481
1482       --  And close the saved standard output and error file descriptors
1483
1484       Close (Saved_Output);
1485
1486       if Err_To_Out then
1487          Close (Saved_Error);
1488       end if;
1489
1490       return Pid;
1491    end Non_Blocking_Spawn;
1492
1493    function Non_Blocking_Spawn
1494      (Program_Name : String;
1495       Args         : Argument_List;
1496       Output_File  : String;
1497       Err_To_Out   : Boolean := True) return Process_Id
1498    is
1499       Output_File_Descriptor : constant File_Descriptor :=
1500                                  Create_Output_Text_File (Output_File);
1501       Result : Process_Id;
1502
1503    begin
1504       --  Do not attempt to spawn if the output file could not be created
1505
1506       if Output_File_Descriptor = Invalid_FD then
1507          return Invalid_Pid;
1508
1509       else
1510          Result := Non_Blocking_Spawn
1511                      (Program_Name, Args, Output_File_Descriptor, Err_To_Out);
1512
1513          --  Close the file just created for the output, as the file descriptor
1514          --  cannot be used anywhere, being a local value. It is safe to do
1515          --  that, as the file descriptor has been duplicated to form
1516          --  standard output and error of the spawned process.
1517
1518          Close (Output_File_Descriptor);
1519
1520          return Result;
1521       end if;
1522    end Non_Blocking_Spawn;
1523
1524    -------------------------
1525    -- Normalize_Arguments --
1526    -------------------------
1527
1528    procedure Normalize_Arguments (Args : in out Argument_List) is
1529
1530       procedure Quote_Argument (Arg : in out String_Access);
1531       --  Add quote around argument if it contains spaces
1532
1533       C_Argument_Needs_Quote : Integer;
1534       pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
1535       Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
1536
1537       --------------------
1538       -- Quote_Argument --
1539       --------------------
1540
1541       procedure Quote_Argument (Arg : in out String_Access) is
1542          Res          : String (1 .. Arg'Length * 2);
1543          J            : Positive := 1;
1544          Quote_Needed : Boolean  := False;
1545
1546       begin
1547          if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
1548
1549             --  Starting quote
1550
1551             Res (J) := '"';
1552
1553             for K in Arg'Range loop
1554
1555                J := J + 1;
1556
1557                if Arg (K) = '"' then
1558                   Res (J) := '\';
1559                   J := J + 1;
1560                   Res (J) := '"';
1561                   Quote_Needed := True;
1562
1563                elsif Arg (K) = ' ' then
1564                   Res (J) := Arg (K);
1565                   Quote_Needed := True;
1566
1567                else
1568                   Res (J) := Arg (K);
1569                end if;
1570
1571             end loop;
1572
1573             if Quote_Needed then
1574
1575                --  If null terminated string, put the quote before
1576
1577                if Res (J) = ASCII.Nul then
1578                   Res (J) := '"';
1579                   J := J + 1;
1580                   Res (J) := ASCII.Nul;
1581
1582                --  If argument is terminated by '\', then double it. Otherwise
1583                --  the ending quote will be taken as-is. This is quite strange
1584                --  spawn behavior from Windows, but this is what we see!
1585
1586                else
1587                   if Res (J) = '\' then
1588                      J := J + 1;
1589                      Res (J) := '\';
1590                   end if;
1591
1592                   --  Ending quote
1593
1594                   J := J + 1;
1595                   Res (J) := '"';
1596                end if;
1597
1598                declare
1599                   Old : String_Access := Arg;
1600
1601                begin
1602                   Arg := new String'(Res (1 .. J));
1603                   Free (Old);
1604                end;
1605             end if;
1606
1607          end if;
1608       end Quote_Argument;
1609
1610    --  Start of processing for Normalize_Arguments
1611
1612    begin
1613       if Argument_Needs_Quote then
1614          for K in Args'Range loop
1615             if Args (K) /= null and then Args (K)'Length /= 0 then
1616                Quote_Argument (Args (K));
1617             end if;
1618          end loop;
1619       end if;
1620    end Normalize_Arguments;
1621
1622    ------------------------
1623    -- Normalize_Pathname --
1624    ------------------------
1625
1626    function Normalize_Pathname
1627      (Name           : String;
1628       Directory      : String  := "";
1629       Resolve_Links  : Boolean := True;
1630       Case_Sensitive : Boolean := True) return String
1631    is
1632       Max_Path : Integer;
1633       pragma Import (C, Max_Path, "__gnat_max_path_len");
1634       --  Maximum length of a path name
1635
1636       procedure Get_Current_Dir
1637         (Dir    : System.Address;
1638          Length : System.Address);
1639       pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
1640
1641       function Change_Dir (Dir_Name : String) return Integer;
1642       pragma Import (C, Change_Dir, "chdir");
1643
1644       Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
1645       End_Path    : Natural := 0;
1646       Link_Buffer : String (1 .. Max_Path + 2);
1647       Status      : Integer;
1648       Last        : Positive;
1649       Start       : Natural;
1650       Finish      : Positive;
1651
1652       Max_Iterations : constant := 500;
1653
1654       function Get_File_Names_Case_Sensitive return Integer;
1655       pragma Import
1656         (C, Get_File_Names_Case_Sensitive,
1657          "__gnat_get_file_names_case_sensitive");
1658
1659       Fold_To_Lower_Case : constant Boolean :=
1660                              not Case_Sensitive
1661                                and then Get_File_Names_Case_Sensitive = 0;
1662
1663       function Readlink
1664         (Path   : System.Address;
1665          Buf    : System.Address;
1666          Bufsiz : Integer) return Integer;
1667       pragma Import (C, Readlink, "__gnat_readlink");
1668
1669       function To_Canonical_File_Spec
1670         (Host_File : System.Address) return System.Address;
1671       pragma Import
1672         (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
1673
1674       The_Name : String (1 .. Name'Length + 1);
1675       Canonical_File_Addr : System.Address;
1676       Canonical_File_Len  : Integer;
1677
1678       Need_To_Check_Drive_Letter : Boolean := False;
1679       --  Set to true if Name is an absolute path that starts with "//"
1680
1681       function Strlen (S : System.Address) return Integer;
1682       pragma Import (C, Strlen, "strlen");
1683
1684       function Get_Directory  (Dir : String) return String;
1685       --  If Dir is not empty, return it, adding a directory separator
1686       --  if not already present, otherwise return current working directory
1687       --  with terminating directory separator.
1688
1689       function Final_Value (S : String) return String;
1690       --  Make final adjustment to the returned string.
1691       --  To compensate for non standard path name in Interix,
1692       --  if S is "/x" or starts with "/x", where x is a capital
1693       --  letter 'A' to 'Z', add an additional '/' at the beginning
1694       --  so that the returned value starts with "//x".
1695
1696       -------------------
1697       -- Get_Directory --
1698       -------------------
1699
1700       function Get_Directory (Dir : String) return String is
1701       begin
1702          --  Directory given, add directory separator if needed
1703
1704          if Dir'Length > 0 then
1705             if Dir (Dir'Last) = Directory_Separator then
1706                return Directory;
1707             else
1708                declare
1709                   Result : String (1 .. Dir'Length + 1);
1710                begin
1711                   Result (1 .. Dir'Length) := Dir;
1712                   Result (Result'Length) := Directory_Separator;
1713                   return Result;
1714                end;
1715             end if;
1716
1717          --  Directory name not given, get current directory
1718
1719          else
1720             declare
1721                Buffer   : String (1 .. Max_Path + 2);
1722                Path_Len : Natural := Max_Path;
1723
1724             begin
1725                Get_Current_Dir (Buffer'Address, Path_Len'Address);
1726
1727                if Buffer (Path_Len) /= Directory_Separator then
1728                   Path_Len := Path_Len + 1;
1729                   Buffer (Path_Len) := Directory_Separator;
1730                end if;
1731
1732                --  By default, the drive letter on Windows is in upper case
1733
1734                if On_Windows and then Path_Len >= 2 and then
1735                  Buffer (2) = ':'
1736                then
1737                   System.Case_Util.To_Upper (Buffer (1 .. 1));
1738                end if;
1739
1740                return Buffer (1 .. Path_Len);
1741             end;
1742          end if;
1743       end Get_Directory;
1744
1745       Reference_Dir : constant String := Get_Directory (Directory);
1746       --  Current directory name specified
1747
1748       -----------------
1749       -- Final_Value --
1750       -----------------
1751
1752       function Final_Value (S : String) return String is
1753          S1 : String := S;
1754          --  We may need to fold S to lower case, so we need a variable
1755
1756          Last : Natural;
1757
1758       begin
1759          --  Interix has the non standard notion of disk drive
1760          --  indicated by two '/' followed by a capital letter
1761          --  'A' .. 'Z'. One of the two '/' may have been removed
1762          --  by Normalize_Pathname. It has to be added again.
1763          --  For other OSes, this should not make no difference.
1764
1765          if Need_To_Check_Drive_Letter
1766            and then S'Length >= 2
1767            and then S (S'First) = '/'
1768            and then S (S'First + 1) in 'A' .. 'Z'
1769            and then (S'Length = 2 or else S (S'First + 2) = '/')
1770          then
1771             declare
1772                Result : String (1 .. S'Length + 1);
1773
1774             begin
1775                Result (1) := '/';
1776                Result (2 .. Result'Last) := S;
1777                Last := Result'Last;
1778
1779                if Fold_To_Lower_Case then
1780                   System.Case_Util.To_Lower (Result);
1781                end if;
1782
1783                --  Remove trailing directory separator, if any
1784
1785                if Last > 1 and then
1786                  (Result (Last) = '/' or else
1787                   Result (Last) = Directory_Separator)
1788                then
1789                   Last := Last - 1;
1790                end if;
1791
1792                return Result (1 .. Last);
1793             end;
1794
1795          else
1796             if Fold_To_Lower_Case then
1797                System.Case_Util.To_Lower (S1);
1798             end if;
1799
1800             --  Remove trailing directory separator, if any
1801
1802             Last := S1'Last;
1803
1804             if Last > 1
1805               and then (S1 (Last) = '/'
1806                           or else
1807                         S1 (Last) = Directory_Separator)
1808             then
1809                --  Special case for Windows: C:\
1810
1811                if Last = 3
1812                  and then S1 (1) /= Directory_Separator
1813                  and then S1 (2) = ':'
1814                then
1815                   null;
1816
1817                else
1818                   Last := Last - 1;
1819                end if;
1820             end if;
1821
1822             return S1 (1 .. Last);
1823          end if;
1824       end Final_Value;
1825
1826    --  Start of processing for Normalize_Pathname
1827
1828    begin
1829       --  Special case, if name is null, then return null
1830
1831       if Name'Length = 0 then
1832          return "";
1833       end if;
1834
1835       --  First, convert VMS file spec to Unix file spec.
1836       --  If Name is not in VMS syntax, then this is equivalent
1837       --  to put Name at the begining of Path_Buffer.
1838
1839       VMS_Conversion : begin
1840          The_Name (1 .. Name'Length) := Name;
1841          The_Name (The_Name'Last) := ASCII.NUL;
1842
1843          Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1844          Canonical_File_Len  := Strlen (Canonical_File_Addr);
1845
1846          --  If VMS syntax conversion has failed, return an empty string
1847          --  to indicate the failure.
1848
1849          if Canonical_File_Len = 0 then
1850             return "";
1851          end if;
1852
1853          declare
1854             subtype Path_String is String (1 .. Canonical_File_Len);
1855             type    Path_String_Access is access Path_String;
1856
1857             function Address_To_Access is new
1858                Unchecked_Conversion (Source => Address,
1859                                      Target => Path_String_Access);
1860
1861             Path_Access : constant Path_String_Access :=
1862                             Address_To_Access (Canonical_File_Addr);
1863
1864          begin
1865             Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
1866             End_Path := Canonical_File_Len;
1867             Last := 1;
1868          end;
1869       end VMS_Conversion;
1870
1871       --  Replace all '/' by Directory Separators (this is for Windows)
1872
1873       if Directory_Separator /= '/' then
1874          for Index in 1 .. End_Path loop
1875             if Path_Buffer (Index) = '/' then
1876                Path_Buffer (Index) := Directory_Separator;
1877             end if;
1878          end loop;
1879       end if;
1880
1881       --  Resolve directory names for VMS and Windows
1882
1883       --  On VMS, if we have a Unix path such as /temp/..., and TEMP is a
1884       --  logical name, we need to resolve this logical name.
1885
1886       --  On Windows, if we have an absolute path starting with a directory
1887       --  separator, we need to have the drive letter appended in front.
1888
1889       --  For both platforms, Get_Current_Dir will return a suitable
1890       --  directory name (logical names resolved on VMS, path starting with
1891       --  a drive letter on Windows). So we find the directory, change to it,
1892       --  call Get_Current_Dir and change the directory to the returned value.
1893       --  Then, of course, we return to the previous directory.
1894
1895       if (OpenVMS or On_Windows)
1896         and then Path_Buffer (1) = Directory_Separator
1897       then
1898          declare
1899             Cur_Dir : String := Get_Directory ("");
1900             --  Save the current directory, so that we can change dir back to
1901             --  it. It is not a constant, because the last character (a
1902             --  directory separator) is changed to ASCII.NUL to call the C
1903             --  function chdir.
1904
1905             Path : String := Path_Buffer (1 .. End_Path + 1);
1906             --  Copy of the current path. One character is added that may be
1907             --  set to ASCII.NUL to call chdir.
1908
1909             Pos : Positive := End_Path;
1910             --  Position of the last directory separator
1911
1912             Status : Integer;
1913             --  Value returned by chdir
1914
1915          begin
1916             --  Look for the last directory separator
1917
1918             while Path (Pos) /= Directory_Separator loop
1919                Pos := Pos - 1;
1920             end loop;
1921
1922             --  Get the previous character that is not a directory separator
1923
1924             while Pos > 1 and then Path (Pos) = Directory_Separator loop
1925                Pos := Pos - 1;
1926             end loop;
1927
1928             --  If we are at the start of the path, take the full path.
1929             --  It may be a file in the root directory, but it may also be
1930             --  a subdirectory of the root directory.
1931
1932             if Pos = 1 then
1933                Pos := End_Path;
1934             end if;
1935
1936             --  Add the ASCII.NUL to be able to call the C function chdir
1937
1938             Path (Pos + 1) := ASCII.NUL;
1939
1940             Status := Change_Dir (Path (1 .. Pos + 1));
1941
1942             --  If Status is not zero, then we do nothing: this is a file
1943             --  path or it is not a valid directory path.
1944
1945             if Status = 0 then
1946                declare
1947                   New_Dir : constant String := Get_Directory ("");
1948                   --  The directory path
1949
1950                   New_Path : String (1 .. New_Dir'Length + End_Path - Pos);
1951                   --  The new complete path, that is built below
1952
1953                begin
1954                   New_Path (1 .. New_Dir'Length) := New_Dir;
1955                   New_Path (New_Dir'Length + 1 .. New_Path'Last) :=
1956                     Path_Buffer (Pos + 1 .. End_Path);
1957                   End_Path := New_Path'Length;
1958                   Path_Buffer (1 .. End_Path) := New_Path;
1959                end;
1960
1961                --  Back to where we were before
1962
1963                Cur_Dir (Cur_Dir'Last) := ASCII.NUL;
1964                Status := Change_Dir (Cur_Dir);
1965             end if;
1966          end;
1967       end if;
1968
1969       --  Start the conversions
1970
1971       --  If this is not finished after Max_Iterations, give up and return an
1972       --  empty string.
1973
1974       for J in 1 .. Max_Iterations loop
1975
1976          --  If we don't have an absolute pathname, prepend the directory
1977          --  Reference_Dir.
1978
1979          if Last = 1
1980            and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
1981          then
1982             Path_Buffer
1983               (Reference_Dir'Last + 1 .. Reference_Dir'Length + End_Path) :=
1984                  Path_Buffer (1 .. End_Path);
1985             End_Path := Reference_Dir'Length + End_Path;
1986             Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir;
1987             Last := Reference_Dir'Length;
1988          end if;
1989
1990          --  If name starts with "//", we may have a drive letter on Interix
1991
1992          if Last = 1 and then End_Path >= 3 then
1993             Need_To_Check_Drive_Letter := (Path_Buffer (1 .. 2)) = "//";
1994          end if;
1995
1996          Start  := Last + 1;
1997          Finish := Last;
1998
1999          --  Ensure that Windows network drives are kept, e.g: \\server\drive-c
2000
2001          if Start = 2
2002            and then Directory_Separator = '\'
2003            and then Path_Buffer (1 .. 2) = "\\"
2004          then
2005             Start := 3;
2006          end if;
2007
2008          --  If we have traversed the full pathname, return it
2009
2010          if Start > End_Path then
2011             return Final_Value (Path_Buffer (1 .. End_Path));
2012          end if;
2013
2014          --  Remove duplicate directory separators
2015
2016          while Path_Buffer (Start) = Directory_Separator loop
2017             if Start = End_Path then
2018                return Final_Value (Path_Buffer (1 .. End_Path - 1));
2019
2020             else
2021                Path_Buffer (Start .. End_Path - 1) :=
2022                  Path_Buffer (Start + 1 .. End_Path);
2023                End_Path := End_Path - 1;
2024             end if;
2025          end loop;
2026
2027          --  Find the end of the current field: last character or the one
2028          --  preceding the next directory separator.
2029
2030          while Finish < End_Path
2031            and then Path_Buffer (Finish + 1) /= Directory_Separator
2032          loop
2033             Finish := Finish + 1;
2034          end loop;
2035
2036          --  Remove "." field
2037
2038          if Start = Finish and then Path_Buffer (Start) = '.' then
2039             if Start = End_Path then
2040                if Last = 1 then
2041                   return (1 => Directory_Separator);
2042                else
2043
2044                   if Fold_To_Lower_Case then
2045                      System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
2046                   end if;
2047
2048                   return Path_Buffer (1 .. Last - 1);
2049
2050                end if;
2051
2052             else
2053                Path_Buffer (Last + 1 .. End_Path - 2) :=
2054                  Path_Buffer (Last + 3 .. End_Path);
2055                End_Path := End_Path - 2;
2056             end if;
2057
2058          --  Remove ".." fields
2059
2060          elsif Finish = Start + 1
2061            and then Path_Buffer (Start .. Finish) = ".."
2062          then
2063             Start := Last;
2064             loop
2065                Start := Start - 1;
2066                exit when Start < 1 or else
2067                  Path_Buffer (Start) = Directory_Separator;
2068             end loop;
2069
2070             if Start <= 1 then
2071                if Finish = End_Path then
2072                   return (1 => Directory_Separator);
2073
2074                else
2075                   Path_Buffer (1 .. End_Path - Finish) :=
2076                     Path_Buffer (Finish + 1 .. End_Path);
2077                   End_Path := End_Path - Finish;
2078                   Last := 1;
2079                end if;
2080
2081             else
2082                if Finish = End_Path then
2083                   return Final_Value (Path_Buffer (1 .. Start - 1));
2084
2085                else
2086                   Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
2087                     Path_Buffer (Finish + 2 .. End_Path);
2088                   End_Path := Start + End_Path - Finish - 1;
2089                   Last := Start;
2090                end if;
2091             end if;
2092
2093          --  Check if current field is a symbolic link
2094
2095          elsif Resolve_Links then
2096             declare
2097                Saved : constant Character := Path_Buffer (Finish + 1);
2098
2099             begin
2100                Path_Buffer (Finish + 1) := ASCII.NUL;
2101                Status := Readlink (Path_Buffer'Address,
2102                                    Link_Buffer'Address,
2103                                    Link_Buffer'Length);
2104                Path_Buffer (Finish + 1) := Saved;
2105             end;
2106
2107             --  Not a symbolic link, move to the next field, if any
2108
2109             if Status <= 0 then
2110                Last := Finish + 1;
2111
2112             --  Replace symbolic link with its value
2113
2114             else
2115                if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
2116                   Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
2117                   Path_Buffer (Finish + 1 .. End_Path);
2118                   End_Path := End_Path - (Finish - Status);
2119                   Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
2120                   Last := 1;
2121
2122                else
2123                   Path_Buffer
2124                     (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
2125                     Path_Buffer (Finish + 1 .. End_Path);
2126                   End_Path := End_Path - Finish + Last + Status;
2127                   Path_Buffer (Last + 1 .. Last + Status) :=
2128                     Link_Buffer (1 .. Status);
2129                end if;
2130             end if;
2131
2132          else
2133             Last := Finish + 1;
2134          end if;
2135       end loop;
2136
2137       --  Too many iterations: give up
2138
2139       --  This can happen when there is a circularity in the symbolic links: A
2140       --  is a symbolic link for B, which itself is a symbolic link, and the
2141       --  target of B or of another symbolic link target of B is A. In this
2142       --  case, we return an empty string to indicate failure to resolve.
2143
2144       return "";
2145    end Normalize_Pathname;
2146
2147    ---------------
2148    -- Open_Read --
2149    ---------------
2150
2151    function Open_Read
2152      (Name  : C_File_Name;
2153       Fmode : Mode) return File_Descriptor
2154    is
2155       function C_Open_Read
2156         (Name  : C_File_Name;
2157          Fmode : Mode) return File_Descriptor;
2158       pragma Import (C, C_Open_Read, "__gnat_open_read");
2159    begin
2160       return C_Open_Read (Name, Fmode);
2161    end Open_Read;
2162
2163    function Open_Read
2164      (Name  : String;
2165       Fmode : Mode) return File_Descriptor
2166    is
2167       C_Name : String (1 .. Name'Length + 1);
2168    begin
2169       C_Name (1 .. Name'Length) := Name;
2170       C_Name (C_Name'Last)      := ASCII.NUL;
2171       return Open_Read (C_Name (C_Name'First)'Address, Fmode);
2172    end Open_Read;
2173
2174    ---------------------
2175    -- Open_Read_Write --
2176    ---------------------
2177
2178    function Open_Read_Write
2179      (Name  : C_File_Name;
2180       Fmode : Mode) return File_Descriptor
2181    is
2182       function C_Open_Read_Write
2183         (Name  : C_File_Name;
2184          Fmode : Mode) return File_Descriptor;
2185       pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
2186    begin
2187       return C_Open_Read_Write (Name, Fmode);
2188    end Open_Read_Write;
2189
2190    function Open_Read_Write
2191      (Name  : String;
2192       Fmode : Mode) return File_Descriptor
2193    is
2194       C_Name : String (1 .. Name'Length + 1);
2195    begin
2196       C_Name (1 .. Name'Length) := Name;
2197       C_Name (C_Name'Last)      := ASCII.NUL;
2198       return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
2199    end Open_Read_Write;
2200
2201    ----------
2202    -- Read --
2203    ----------
2204
2205    function Read
2206      (FD : File_Descriptor;
2207       A  : System.Address;
2208       N  : Integer) return Integer
2209    is
2210    begin
2211       return Integer (System.CRTL.read
2212         (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
2213    end Read;
2214
2215    -----------------
2216    -- Rename_File --
2217    -----------------
2218
2219    procedure Rename_File
2220      (Old_Name : C_File_Name;
2221       New_Name : C_File_Name;
2222       Success  : out Boolean)
2223    is
2224       function rename (From, To : Address) return Integer;
2225       pragma Import (C, rename, "rename");
2226       R : Integer;
2227    begin
2228       R := rename (Old_Name, New_Name);
2229       Success := (R = 0);
2230    end Rename_File;
2231
2232    procedure Rename_File
2233      (Old_Name : String;
2234       New_Name : String;
2235       Success  : out Boolean)
2236    is
2237       C_Old_Name : String (1 .. Old_Name'Length + 1);
2238       C_New_Name : String (1 .. New_Name'Length + 1);
2239    begin
2240       C_Old_Name (1 .. Old_Name'Length) := Old_Name;
2241       C_Old_Name (C_Old_Name'Last)      := ASCII.NUL;
2242       C_New_Name (1 .. New_Name'Length) := New_Name;
2243       C_New_Name (C_New_Name'Last)      := ASCII.NUL;
2244       Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
2245    end Rename_File;
2246
2247    -----------------------
2248    -- Set_Close_On_Exec --
2249    -----------------------
2250
2251    procedure Set_Close_On_Exec
2252      (FD            : File_Descriptor;
2253       Close_On_Exec : Boolean;
2254       Status        : out Boolean)
2255    is
2256       function C_Set_Close_On_Exec
2257         (FD : File_Descriptor; Close_On_Exec : System.CRTL.int)
2258          return System.CRTL.int;
2259       pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
2260    begin
2261       Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0;
2262    end Set_Close_On_Exec;
2263
2264    --------------------
2265    -- Set_Executable --
2266    --------------------
2267
2268    procedure Set_Executable (Name : String) is
2269       procedure C_Set_Executable (Name : C_File_Name);
2270       pragma Import (C, C_Set_Executable, "__gnat_set_executable");
2271       C_Name : aliased String (Name'First .. Name'Last + 1);
2272    begin
2273       C_Name (Name'Range)  := Name;
2274       C_Name (C_Name'Last) := ASCII.NUL;
2275       C_Set_Executable (C_Name (C_Name'First)'Address);
2276    end Set_Executable;
2277
2278    --------------------
2279    -- Set_Read_Only --
2280    --------------------
2281
2282    procedure Set_Read_Only (Name : String) is
2283       procedure C_Set_Read_Only (Name : C_File_Name);
2284       pragma Import (C, C_Set_Read_Only, "__gnat_set_readonly");
2285       C_Name : aliased String (Name'First .. Name'Last + 1);
2286    begin
2287       C_Name (Name'Range)  := Name;
2288       C_Name (C_Name'Last) := ASCII.NUL;
2289       C_Set_Read_Only (C_Name (C_Name'First)'Address);
2290    end Set_Read_Only;
2291
2292    --------------------
2293    -- Set_Writable --
2294    --------------------
2295
2296    procedure Set_Writable (Name : String) is
2297       procedure C_Set_Writable (Name : C_File_Name);
2298       pragma Import (C, C_Set_Writable, "__gnat_set_writable");
2299       C_Name : aliased String (Name'First .. Name'Last + 1);
2300    begin
2301       C_Name (Name'Range)  := Name;
2302       C_Name (C_Name'Last) := ASCII.NUL;
2303       C_Set_Writable (C_Name (C_Name'First)'Address);
2304    end Set_Writable;
2305
2306    ------------
2307    -- Setenv --
2308    ------------
2309
2310    procedure Setenv (Name : String; Value : String) is
2311       F_Name  : String (1 .. Name'Length + 1);
2312       F_Value : String (1 .. Value'Length + 1);
2313
2314       procedure Set_Env_Value (Name, Value : System.Address);
2315       pragma Import (C, Set_Env_Value, "__gnat_setenv");
2316
2317    begin
2318       F_Name (1 .. Name'Length) := Name;
2319       F_Name (F_Name'Last)      := ASCII.NUL;
2320
2321       F_Value (1 .. Value'Length) := Value;
2322       F_Value (F_Value'Last)      := ASCII.NUL;
2323
2324       Set_Env_Value (F_Name'Address, F_Value'Address);
2325    end Setenv;
2326
2327    -----------
2328    -- Spawn --
2329    -----------
2330
2331    function Spawn
2332      (Program_Name : String;
2333       Args         : Argument_List) return Integer
2334    is
2335       Junk   : Process_Id;
2336       Result : Integer;
2337    begin
2338       Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
2339       return Result;
2340    end Spawn;
2341
2342    procedure Spawn
2343      (Program_Name : String;
2344       Args         : Argument_List;
2345       Success      : out Boolean)
2346    is
2347    begin
2348       Success := (Spawn (Program_Name, Args) = 0);
2349    end Spawn;
2350
2351    procedure Spawn
2352      (Program_Name           : String;
2353       Args                   : Argument_List;
2354       Output_File_Descriptor : File_Descriptor;
2355       Return_Code            : out Integer;
2356       Err_To_Out             : Boolean := True)
2357    is
2358       Saved_Output : File_Descriptor;
2359       Saved_Error  : File_Descriptor := Invalid_FD; -- prevent compiler warning
2360
2361    begin
2362       --  Set standard output and error to the temporary file
2363
2364       Saved_Output := Dup (Standout);
2365       Dup2 (Output_File_Descriptor, Standout);
2366
2367       if Err_To_Out then
2368          Saved_Error  := Dup (Standerr);
2369          Dup2 (Output_File_Descriptor, Standerr);
2370       end if;
2371
2372       --  Spawn the program
2373
2374       Return_Code := Spawn (Program_Name, Args);
2375
2376       --  Restore the standard output and error
2377
2378       Dup2 (Saved_Output, Standout);
2379
2380       if Err_To_Out then
2381          Dup2 (Saved_Error, Standerr);
2382       end if;
2383
2384       --  And close the saved standard output and error file descriptors
2385
2386       Close (Saved_Output);
2387
2388       if Err_To_Out then
2389          Close (Saved_Error);
2390       end if;
2391    end Spawn;
2392
2393    procedure Spawn
2394      (Program_Name  : String;
2395       Args          : Argument_List;
2396       Output_File   : String;
2397       Success       : out Boolean;
2398       Return_Code   : out Integer;
2399       Err_To_Out    : Boolean := True)
2400    is
2401       FD : File_Descriptor;
2402
2403    begin
2404       Success := True;
2405       Return_Code := 0;
2406
2407       FD := Create_Output_Text_File (Output_File);
2408
2409       if FD = Invalid_FD then
2410          Success := False;
2411          return;
2412       end if;
2413
2414       Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out);
2415
2416       Close (FD, Success);
2417    end Spawn;
2418
2419    --------------------
2420    -- Spawn_Internal --
2421    --------------------
2422
2423    procedure Spawn_Internal
2424      (Program_Name : String;
2425       Args         : Argument_List;
2426       Result       : out Integer;
2427       Pid          : out Process_Id;
2428       Blocking     : Boolean)
2429    is
2430
2431       procedure Spawn (Args : Argument_List);
2432       --  Call Spawn with given argument list
2433
2434       N_Args : Argument_List (Args'Range);
2435       --  Normalized arguments
2436
2437       -----------
2438       -- Spawn --
2439       -----------
2440
2441       procedure Spawn (Args : Argument_List) is
2442          type Chars is array (Positive range <>) of aliased Character;
2443          type Char_Ptr is access constant Character;
2444
2445          Command_Len : constant Positive := Program_Name'Length + 1
2446                                               + Args_Length (Args);
2447          Command_Last : Natural := 0;
2448          Command : aliased Chars (1 .. Command_Len);
2449          --  Command contains all characters of the Program_Name and Args, all
2450          --  terminated by ASCII.NUL characters
2451
2452          Arg_List_Len : constant Positive := Args'Length + 2;
2453          Arg_List_Last : Natural := 0;
2454          Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
2455          --  List with pointers to NUL-terminated strings of the Program_Name
2456          --  and the Args and terminated with a null pointer. We rely on the
2457          --  default initialization for the last null pointer.
2458
2459          procedure Add_To_Command (S : String);
2460          --  Add S and a NUL character to Command, updating Last
2461
2462          function Portable_Spawn (Args : Address) return Integer;
2463          pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
2464
2465          function Portable_No_Block_Spawn (Args : Address) return Process_Id;
2466          pragma Import
2467            (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
2468
2469          --------------------
2470          -- Add_To_Command --
2471          --------------------
2472
2473          procedure Add_To_Command (S : String) is
2474             First : constant Natural := Command_Last + 1;
2475
2476          begin
2477             Command_Last := Command_Last + S'Length;
2478
2479             --  Move characters one at a time, because Command has aliased
2480             --  components.
2481
2482             --  But not volatile, so why is this necessary ???
2483
2484             for J in S'Range loop
2485                Command (First + J - S'First) := S (J);
2486             end loop;
2487
2488             Command_Last := Command_Last + 1;
2489             Command (Command_Last) := ASCII.NUL;
2490
2491             Arg_List_Last := Arg_List_Last + 1;
2492             Arg_List (Arg_List_Last) := Command (First)'Access;
2493          end Add_To_Command;
2494
2495       --  Start of processing for Spawn
2496
2497       begin
2498          Add_To_Command (Program_Name);
2499
2500          for J in Args'Range loop
2501             Add_To_Command (Args (J).all);
2502          end loop;
2503
2504          if Blocking then
2505             Pid     := Invalid_Pid;
2506             Result  := Portable_Spawn (Arg_List'Address);
2507          else
2508             Pid     := Portable_No_Block_Spawn (Arg_List'Address);
2509             Result  := Boolean'Pos (Pid /= Invalid_Pid);
2510          end if;
2511       end Spawn;
2512
2513    --  Start of processing for Spawn_Internal
2514
2515    begin
2516       --  Copy arguments into a local structure
2517
2518       for K in N_Args'Range loop
2519          N_Args (K) := new String'(Args (K).all);
2520       end loop;
2521
2522       --  Normalize those arguments
2523
2524       Normalize_Arguments (N_Args);
2525
2526       --  Call spawn using the normalized arguments
2527
2528       Spawn (N_Args);
2529
2530       --  Free arguments list
2531
2532       for K in N_Args'Range loop
2533          Free (N_Args (K));
2534       end loop;
2535    end Spawn_Internal;
2536
2537    ---------------------------
2538    -- To_Path_String_Access --
2539    ---------------------------
2540
2541    function To_Path_String_Access
2542      (Path_Addr : Address;
2543       Path_Len  : Integer) return String_Access
2544    is
2545       subtype Path_String is String (1 .. Path_Len);
2546       type    Path_String_Access is access Path_String;
2547
2548       function Address_To_Access is new
2549         Unchecked_Conversion (Source => Address,
2550                               Target => Path_String_Access);
2551
2552       Path_Access : constant Path_String_Access :=
2553                       Address_To_Access (Path_Addr);
2554
2555       Return_Val  : String_Access;
2556
2557    begin
2558       Return_Val := new String (1 .. Path_Len);
2559
2560       for J in 1 .. Path_Len loop
2561          Return_Val (J) := Path_Access (J);
2562       end loop;
2563
2564       return Return_Val;
2565    end To_Path_String_Access;
2566
2567    ------------------
2568    -- Wait_Process --
2569    ------------------
2570
2571    procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
2572       Status : Integer;
2573
2574       function Portable_Wait (S : Address) return Process_Id;
2575       pragma Import (C, Portable_Wait, "__gnat_portable_wait");
2576
2577    begin
2578       Pid := Portable_Wait (Status'Address);
2579       Success := (Status = 0);
2580    end Wait_Process;
2581
2582    -----------
2583    -- Write --
2584    -----------
2585
2586    function Write
2587      (FD : File_Descriptor;
2588       A  : System.Address;
2589       N  : Integer) return Integer
2590    is
2591    begin
2592       return Integer (System.CRTL.write
2593         (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
2594    end Write;
2595
2596 end GNAT.OS_Lib;