gcc/ada/s-os_lib.adb

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