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       function Strlen (S : System.Address) return Integer;
1702       pragma Import (C, Strlen, "strlen");
1703
1704       function Final_Value (S : String) return String;
1705       --  Make final adjustment to the returned string. This function strips
1706       --  trailing directory separators, and folds returned string to lower
1707       --  case if required.
1708
1709       function Get_Directory  (Dir : String) return String;
1710       --  If Dir is not empty, return it, adding a directory separator
1711       --  if not already present, otherwise return current working directory
1712       --  with terminating directory separator.
1713
1714       -----------------
1715       -- Final_Value --
1716       -----------------
1717
1718       function Final_Value (S : String) return String is
1719          S1 : String := S;
1720          --  We may need to fold S to lower case, so we need a variable
1721
1722          Last : Natural;
1723
1724       begin
1725          if Fold_To_Lower_Case then
1726             System.Case_Util.To_Lower (S1);
1727          end if;
1728
1729          --  Remove trailing directory separator, if any
1730
1731          Last := S1'Last;
1732
1733          if Last > 1
1734            and then (S1 (Last) = '/'
1735                        or else
1736                      S1 (Last) = Directory_Separator)
1737          then
1738             --  Special case for Windows: C:\
1739
1740             if Last = 3
1741               and then S1 (1) /= Directory_Separator
1742               and then S1 (2) = ':'
1743             then
1744                null;
1745
1746             else
1747                Last := Last - 1;
1748             end if;
1749          end if;
1750
1751          return S1 (1 .. Last);
1752       end Final_Value;
1753
1754       -------------------
1755       -- Get_Directory --
1756       -------------------
1757
1758       function Get_Directory (Dir : String) return String is
1759       begin
1760          --  Directory given, add directory separator if needed
1761
1762          if Dir'Length > 0 then
1763             if Dir (Dir'Last) = Directory_Separator then
1764                return Dir;
1765             else
1766                declare
1767                   Result : String (1 .. Dir'Length + 1);
1768                begin
1769                   Result (1 .. Dir'Length) := Dir;
1770                   Result (Result'Length) := Directory_Separator;
1771                   return Result;
1772                end;
1773             end if;
1774
1775          --  Directory name not given, get current directory
1776
1777          else
1778             declare
1779                Buffer   : String (1 .. Max_Path + 2);
1780                Path_Len : Natural := Max_Path;
1781
1782             begin
1783                Get_Current_Dir (Buffer'Address, Path_Len'Address);
1784
1785                if Buffer (Path_Len) /= Directory_Separator then
1786                   Path_Len := Path_Len + 1;
1787                   Buffer (Path_Len) := Directory_Separator;
1788                end if;
1789
1790                --  By default, the drive letter on Windows is in upper case
1791
1792                if On_Windows and then Path_Len >= 2 and then
1793                  Buffer (2) = ':'
1794                then
1795                   System.Case_Util.To_Upper (Buffer (1 .. 1));
1796                end if;
1797
1798                return Buffer (1 .. Path_Len);
1799             end;
1800          end if;
1801       end Get_Directory;
1802
1803       Reference_Dir : constant String := Get_Directory (Directory);
1804       --  Current directory name specified
1805
1806    --  Start of processing for Normalize_Pathname
1807
1808    begin
1809       --  Special case, if name is null, then return null
1810
1811       if Name'Length = 0 then
1812          return "";
1813       end if;
1814
1815       --  First, convert VMS file spec to Unix file spec.
1816       --  If Name is not in VMS syntax, then this is equivalent
1817       --  to put Name at the begining of Path_Buffer.
1818
1819       VMS_Conversion : begin
1820          The_Name (1 .. Name'Length) := Name;
1821          The_Name (The_Name'Last) := ASCII.NUL;
1822
1823          Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1824          Canonical_File_Len  := Strlen (Canonical_File_Addr);
1825
1826          --  If VMS syntax conversion has failed, return an empty string
1827          --  to indicate the failure.
1828
1829          if Canonical_File_Len = 0 then
1830             return "";
1831          end if;
1832
1833          declare
1834             subtype Path_String is String (1 .. Canonical_File_Len);
1835             type    Path_String_Access is access Path_String;
1836
1837             function Address_To_Access is new
1838                Ada.Unchecked_Conversion (Source => Address,
1839                                      Target => Path_String_Access);
1840
1841             Path_Access : constant Path_String_Access :=
1842                             Address_To_Access (Canonical_File_Addr);
1843
1844          begin
1845             Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
1846             End_Path := Canonical_File_Len;
1847             Last := 1;
1848          end;
1849       end VMS_Conversion;
1850
1851       --  Replace all '/' by Directory Separators (this is for Windows)
1852
1853       if Directory_Separator /= '/' then
1854          for Index in 1 .. End_Path loop
1855             if Path_Buffer (Index) = '/' then
1856                Path_Buffer (Index) := Directory_Separator;
1857             end if;
1858          end loop;
1859       end if;
1860
1861       --  Resolve directory names for Windows (formerly also VMS)
1862
1863       --  On VMS, if we have a Unix path such as /temp/..., and TEMP is a
1864       --  logical name, we must not try to resolve this logical name, because
1865       --  it may have multiple equivalences and if resolved we will only
1866       --  get the first one.
1867
1868       --  On Windows, if we have an absolute path starting with a directory
1869       --  separator, we need to have the drive letter appended in front.
1870
1871       --  On Windows, Get_Current_Dir will return a suitable directory
1872       --  name (path starting with a drive letter on Windows). So we take this
1873       --  drive letter and prepend it to the current path.
1874
1875       if On_Windows
1876         and then Path_Buffer (1) = Directory_Separator
1877         and then Path_Buffer (2) /= Directory_Separator
1878       then
1879          declare
1880             Cur_Dir : String := Get_Directory ("");
1881             --  Get the current directory to get the drive letter
1882
1883          begin
1884             if Cur_Dir'Length > 2
1885               and then Cur_Dir (Cur_Dir'First + 1) = ':'
1886             then
1887                Path_Buffer (3 .. End_Path + 2) := Path_Buffer (1 .. End_Path);
1888                Path_Buffer (1 .. 2) :=
1889                  Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1);
1890                End_Path := End_Path + 2;
1891             end if;
1892          end;
1893       end if;
1894
1895       --  Start the conversions
1896
1897       --  If this is not finished after Max_Iterations, give up and return an
1898       --  empty string.
1899
1900       for J in 1 .. Max_Iterations loop
1901
1902          --  If we don't have an absolute pathname, prepend the directory
1903          --  Reference_Dir.
1904
1905          if Last = 1
1906            and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
1907          then
1908             Path_Buffer
1909               (Reference_Dir'Length + 1 .. Reference_Dir'Length + End_Path) :=
1910                  Path_Buffer (1 .. End_Path);
1911             End_Path := Reference_Dir'Length + End_Path;
1912             Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir;
1913             Last := Reference_Dir'Length;
1914          end if;
1915
1916          Start  := Last + 1;
1917          Finish := Last;
1918
1919          --  Ensure that Windows network drives are kept, e.g: \\server\drive-c
1920
1921          if Start = 2
1922            and then Directory_Separator = '\'
1923            and then Path_Buffer (1 .. 2) = "\\"
1924          then
1925             Start := 3;
1926          end if;
1927
1928          --  If we have traversed the full pathname, return it
1929
1930          if Start > End_Path then
1931             return Final_Value (Path_Buffer (1 .. End_Path));
1932          end if;
1933
1934          --  Remove duplicate directory separators
1935
1936          while Path_Buffer (Start) = Directory_Separator loop
1937             if Start = End_Path then
1938                return Final_Value (Path_Buffer (1 .. End_Path - 1));
1939
1940             else
1941                Path_Buffer (Start .. End_Path - 1) :=
1942                  Path_Buffer (Start + 1 .. End_Path);
1943                End_Path := End_Path - 1;
1944             end if;
1945          end loop;
1946
1947          --  Find the end of the current field: last character or the one
1948          --  preceding the next directory separator.
1949
1950          while Finish < End_Path
1951            and then Path_Buffer (Finish + 1) /= Directory_Separator
1952          loop
1953             Finish := Finish + 1;
1954          end loop;
1955
1956          --  Remove "." field
1957
1958          if Start = Finish and then Path_Buffer (Start) = '.' then
1959             if Start = End_Path then
1960                if Last = 1 then
1961                   return (1 => Directory_Separator);
1962                else
1963
1964                   if Fold_To_Lower_Case then
1965                      System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
1966                   end if;
1967
1968                   return Path_Buffer (1 .. Last - 1);
1969
1970                end if;
1971
1972             else
1973                Path_Buffer (Last + 1 .. End_Path - 2) :=
1974                  Path_Buffer (Last + 3 .. End_Path);
1975                End_Path := End_Path - 2;
1976             end if;
1977
1978          --  Remove ".." fields
1979
1980          elsif Finish = Start + 1
1981            and then Path_Buffer (Start .. Finish) = ".."
1982          then
1983             Start := Last;
1984             loop
1985                Start := Start - 1;
1986                exit when Start < 1 or else
1987                  Path_Buffer (Start) = Directory_Separator;
1988             end loop;
1989
1990             if Start <= 1 then
1991                if Finish = End_Path then
1992                   return (1 => Directory_Separator);
1993
1994                else
1995                   Path_Buffer (1 .. End_Path - Finish) :=
1996                     Path_Buffer (Finish + 1 .. End_Path);
1997                   End_Path := End_Path - Finish;
1998                   Last := 1;
1999                end if;
2000
2001             else
2002                if Finish = End_Path then
2003                   return Final_Value (Path_Buffer (1 .. Start - 1));
2004
2005                else
2006                   Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
2007                     Path_Buffer (Finish + 2 .. End_Path);
2008                   End_Path := Start + End_Path - Finish - 1;
2009                   Last := Start;
2010                end if;
2011             end if;
2012
2013          --  Check if current field is a symbolic link
2014
2015          elsif Resolve_Links then
2016             declare
2017                Saved : constant Character := Path_Buffer (Finish + 1);
2018
2019             begin
2020                Path_Buffer (Finish + 1) := ASCII.NUL;
2021                Status := Readlink (Path_Buffer'Address,
2022                                    Link_Buffer'Address,
2023                                    Link_Buffer'Length);
2024                Path_Buffer (Finish + 1) := Saved;
2025             end;
2026
2027             --  Not a symbolic link, move to the next field, if any
2028
2029             if Status <= 0 then
2030                Last := Finish + 1;
2031
2032             --  Replace symbolic link with its value
2033
2034             else
2035                if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
2036                   Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
2037                   Path_Buffer (Finish + 1 .. End_Path);
2038                   End_Path := End_Path - (Finish - Status);
2039                   Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
2040                   Last := 1;
2041
2042                else
2043                   Path_Buffer
2044                     (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
2045                     Path_Buffer (Finish + 1 .. End_Path);
2046                   End_Path := End_Path - Finish + Last + Status;
2047                   Path_Buffer (Last + 1 .. Last + Status) :=
2048                     Link_Buffer (1 .. Status);
2049                end if;
2050             end if;
2051
2052          else
2053             Last := Finish + 1;
2054          end if;
2055       end loop;
2056
2057       --  Too many iterations: give up
2058
2059       --  This can happen when there is a circularity in the symbolic links: A
2060       --  is a symbolic link for B, which itself is a symbolic link, and the
2061       --  target of B or of another symbolic link target of B is A. In this
2062       --  case, we return an empty string to indicate failure to resolve.
2063
2064       return "";
2065    end Normalize_Pathname;
2066
2067    ---------------
2068    -- Open_Read --
2069    ---------------
2070
2071    function Open_Read
2072      (Name  : C_File_Name;
2073       Fmode : Mode) return File_Descriptor
2074    is
2075       function C_Open_Read
2076         (Name  : C_File_Name;
2077          Fmode : Mode) return File_Descriptor;
2078       pragma Import (C, C_Open_Read, "__gnat_open_read");
2079    begin
2080       return C_Open_Read (Name, Fmode);
2081    end Open_Read;
2082
2083    function Open_Read
2084      (Name  : String;
2085       Fmode : Mode) return File_Descriptor
2086    is
2087       C_Name : String (1 .. Name'Length + 1);
2088    begin
2089       C_Name (1 .. Name'Length) := Name;
2090       C_Name (C_Name'Last)      := ASCII.NUL;
2091       return Open_Read (C_Name (C_Name'First)'Address, Fmode);
2092    end Open_Read;
2093
2094    ---------------------
2095    -- Open_Read_Write --
2096    ---------------------
2097
2098    function Open_Read_Write
2099      (Name  : C_File_Name;
2100       Fmode : Mode) return File_Descriptor
2101    is
2102       function C_Open_Read_Write
2103         (Name  : C_File_Name;
2104          Fmode : Mode) return File_Descriptor;
2105       pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
2106    begin
2107       return C_Open_Read_Write (Name, Fmode);
2108    end Open_Read_Write;
2109
2110    function Open_Read_Write
2111      (Name  : String;
2112       Fmode : Mode) return File_Descriptor
2113    is
2114       C_Name : String (1 .. Name'Length + 1);
2115    begin
2116       C_Name (1 .. Name'Length) := Name;
2117       C_Name (C_Name'Last)      := ASCII.NUL;
2118       return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
2119    end Open_Read_Write;
2120
2121    -------------
2122    -- OS_Exit --
2123    -------------
2124
2125    procedure OS_Exit (Status : Integer) is
2126    begin
2127       OS_Exit_Ptr (Status);
2128       raise Program_Error;
2129    end OS_Exit;
2130
2131    ---------------------
2132    -- OS_Exit_Default --
2133    ---------------------
2134
2135    procedure OS_Exit_Default (Status : Integer) is
2136       procedure GNAT_OS_Exit (Status : Integer);
2137       pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit");
2138       pragma No_Return (GNAT_OS_Exit);
2139    begin
2140       GNAT_OS_Exit (Status);
2141    end OS_Exit_Default;
2142
2143    --------------------
2144    -- Pid_To_Integer --
2145    --------------------
2146
2147    function Pid_To_Integer (Pid : Process_Id) return Integer is
2148    begin
2149       return Integer (Pid);
2150    end Pid_To_Integer;
2151
2152    ----------
2153    -- Read --
2154    ----------
2155
2156    function Read
2157      (FD : File_Descriptor;
2158       A  : System.Address;
2159       N  : Integer) return Integer
2160    is
2161    begin
2162       return Integer (System.CRTL.read
2163         (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
2164    end Read;
2165
2166    -----------------
2167    -- Rename_File --
2168    -----------------
2169
2170    procedure Rename_File
2171      (Old_Name : C_File_Name;
2172       New_Name : C_File_Name;
2173       Success  : out Boolean)
2174    is
2175       function rename (From, To : Address) return Integer;
2176       pragma Import (C, rename, "rename");
2177       R : Integer;
2178    begin
2179       R := rename (Old_Name, New_Name);
2180       Success := (R = 0);
2181    end Rename_File;
2182
2183    procedure Rename_File
2184      (Old_Name : String;
2185       New_Name : String;
2186       Success  : out Boolean)
2187    is
2188       C_Old_Name : String (1 .. Old_Name'Length + 1);
2189       C_New_Name : String (1 .. New_Name'Length + 1);
2190    begin
2191       C_Old_Name (1 .. Old_Name'Length) := Old_Name;
2192       C_Old_Name (C_Old_Name'Last)      := ASCII.NUL;
2193       C_New_Name (1 .. New_Name'Length) := New_Name;
2194       C_New_Name (C_New_Name'Last)      := ASCII.NUL;
2195       Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
2196    end Rename_File;
2197
2198    -----------------------
2199    -- Set_Close_On_Exec --
2200    -----------------------
2201
2202    procedure Set_Close_On_Exec
2203      (FD            : File_Descriptor;
2204       Close_On_Exec : Boolean;
2205       Status        : out Boolean)
2206    is
2207       function C_Set_Close_On_Exec
2208         (FD : File_Descriptor; Close_On_Exec : System.CRTL.int)
2209          return System.CRTL.int;
2210       pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
2211    begin
2212       Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0;
2213    end Set_Close_On_Exec;
2214
2215    --------------------
2216    -- Set_Executable --
2217    --------------------
2218
2219    procedure Set_Executable (Name : String) is
2220       procedure C_Set_Executable (Name : C_File_Name);
2221       pragma Import (C, C_Set_Executable, "__gnat_set_executable");
2222       C_Name : aliased String (Name'First .. Name'Last + 1);
2223    begin
2224       C_Name (Name'Range)  := Name;
2225       C_Name (C_Name'Last) := ASCII.NUL;
2226       C_Set_Executable (C_Name (C_Name'First)'Address);
2227    end Set_Executable;
2228
2229    --------------------
2230    -- Set_Read_Only --
2231    --------------------
2232
2233    procedure Set_Read_Only (Name : String) is
2234       procedure C_Set_Read_Only (Name : C_File_Name);
2235       pragma Import (C, C_Set_Read_Only, "__gnat_set_readonly");
2236       C_Name : aliased String (Name'First .. Name'Last + 1);
2237    begin
2238       C_Name (Name'Range)  := Name;
2239       C_Name (C_Name'Last) := ASCII.NUL;
2240       C_Set_Read_Only (C_Name (C_Name'First)'Address);
2241    end Set_Read_Only;
2242
2243    --------------------
2244    -- Set_Writable --
2245    --------------------
2246
2247    procedure Set_Writable (Name : String) is
2248       procedure C_Set_Writable (Name : C_File_Name);
2249       pragma Import (C, C_Set_Writable, "__gnat_set_writable");
2250       C_Name : aliased String (Name'First .. Name'Last + 1);
2251    begin
2252       C_Name (Name'Range)  := Name;
2253       C_Name (C_Name'Last) := ASCII.NUL;
2254       C_Set_Writable (C_Name (C_Name'First)'Address);
2255    end Set_Writable;
2256
2257    ------------
2258    -- Setenv --
2259    ------------
2260
2261    procedure Setenv (Name : String; Value : String) is
2262       F_Name  : String (1 .. Name'Length + 1);
2263       F_Value : String (1 .. Value'Length + 1);
2264
2265       procedure Set_Env_Value (Name, Value : System.Address);
2266       pragma Import (C, Set_Env_Value, "__gnat_setenv");
2267
2268    begin
2269       F_Name (1 .. Name'Length) := Name;
2270       F_Name (F_Name'Last)      := ASCII.NUL;
2271
2272       F_Value (1 .. Value'Length) := Value;
2273       F_Value (F_Value'Last)      := ASCII.NUL;
2274
2275       Set_Env_Value (F_Name'Address, F_Value'Address);
2276    end Setenv;
2277
2278    -----------
2279    -- Spawn --
2280    -----------
2281
2282    function Spawn
2283      (Program_Name : String;
2284       Args         : Argument_List) return Integer
2285    is
2286       Junk   : Process_Id;
2287       Result : Integer;
2288    begin
2289       Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
2290       return Result;
2291    end Spawn;
2292
2293    procedure Spawn
2294      (Program_Name : String;
2295       Args         : Argument_List;
2296       Success      : out Boolean)
2297    is
2298    begin
2299       Success := (Spawn (Program_Name, Args) = 0);
2300    end Spawn;
2301
2302    procedure Spawn
2303      (Program_Name           : String;
2304       Args                   : Argument_List;
2305       Output_File_Descriptor : File_Descriptor;
2306       Return_Code            : out Integer;
2307       Err_To_Out             : Boolean := True)
2308    is
2309       Saved_Output : File_Descriptor;
2310       Saved_Error  : File_Descriptor := Invalid_FD; -- prevent compiler warning
2311
2312    begin
2313       --  Set standard output and error to the temporary file
2314
2315       Saved_Output := Dup (Standout);
2316       Dup2 (Output_File_Descriptor, Standout);
2317
2318       if Err_To_Out then
2319          Saved_Error  := Dup (Standerr);
2320          Dup2 (Output_File_Descriptor, Standerr);
2321       end if;
2322
2323       --  Spawn the program
2324
2325       Return_Code := Spawn (Program_Name, Args);
2326
2327       --  Restore the standard output and error
2328
2329       Dup2 (Saved_Output, Standout);
2330
2331       if Err_To_Out then
2332          Dup2 (Saved_Error, Standerr);
2333       end if;
2334
2335       --  And close the saved standard output and error file descriptors
2336
2337       Close (Saved_Output);
2338
2339       if Err_To_Out then
2340          Close (Saved_Error);
2341       end if;
2342    end Spawn;
2343
2344    procedure Spawn
2345      (Program_Name  : String;
2346       Args          : Argument_List;
2347       Output_File   : String;
2348       Success       : out Boolean;
2349       Return_Code   : out Integer;
2350       Err_To_Out    : Boolean := True)
2351    is
2352       FD : File_Descriptor;
2353
2354    begin
2355       Success := True;
2356       Return_Code := 0;
2357
2358       FD := Create_Output_Text_File (Output_File);
2359
2360       if FD = Invalid_FD then
2361          Success := False;
2362          return;
2363       end if;
2364
2365       Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out);
2366
2367       Close (FD, Success);
2368    end Spawn;
2369
2370    --------------------
2371    -- Spawn_Internal --
2372    --------------------
2373
2374    procedure Spawn_Internal
2375      (Program_Name : String;
2376       Args         : Argument_List;
2377       Result       : out Integer;
2378       Pid          : out Process_Id;
2379       Blocking     : Boolean)
2380    is
2381
2382       procedure Spawn (Args : Argument_List);
2383       --  Call Spawn with given argument list
2384
2385       N_Args : Argument_List (Args'Range);
2386       --  Normalized arguments
2387
2388       -----------
2389       -- Spawn --
2390       -----------
2391
2392       procedure Spawn (Args : Argument_List) is
2393          type Chars is array (Positive range <>) of aliased Character;
2394          type Char_Ptr is access constant Character;
2395
2396          Command_Len : constant Positive := Program_Name'Length + 1
2397                                               + Args_Length (Args);
2398          Command_Last : Natural := 0;
2399          Command : aliased Chars (1 .. Command_Len);
2400          --  Command contains all characters of the Program_Name and Args, all
2401          --  terminated by ASCII.NUL characters
2402
2403          Arg_List_Len : constant Positive := Args'Length + 2;
2404          Arg_List_Last : Natural := 0;
2405          Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
2406          --  List with pointers to NUL-terminated strings of the Program_Name
2407          --  and the Args and terminated with a null pointer. We rely on the
2408          --  default initialization for the last null pointer.
2409
2410          procedure Add_To_Command (S : String);
2411          --  Add S and a NUL character to Command, updating Last
2412
2413          function Portable_Spawn (Args : Address) return Integer;
2414          pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
2415
2416          function Portable_No_Block_Spawn (Args : Address) return Process_Id;
2417          pragma Import
2418            (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
2419
2420          --------------------
2421          -- Add_To_Command --
2422          --------------------
2423
2424          procedure Add_To_Command (S : String) is
2425             First : constant Natural := Command_Last + 1;
2426
2427          begin
2428             Command_Last := Command_Last + S'Length;
2429
2430             --  Move characters one at a time, because Command has aliased
2431             --  components.
2432
2433             --  But not volatile, so why is this necessary ???
2434
2435             for J in S'Range loop
2436                Command (First + J - S'First) := S (J);
2437             end loop;
2438
2439             Command_Last := Command_Last + 1;
2440             Command (Command_Last) := ASCII.NUL;
2441
2442             Arg_List_Last := Arg_List_Last + 1;
2443             Arg_List (Arg_List_Last) := Command (First)'Access;
2444          end Add_To_Command;
2445
2446       --  Start of processing for Spawn
2447
2448       begin
2449          Add_To_Command (Program_Name);
2450
2451          for J in Args'Range loop
2452             Add_To_Command (Args (J).all);
2453          end loop;
2454
2455          if Blocking then
2456             Pid     := Invalid_Pid;
2457             Result  := Portable_Spawn (Arg_List'Address);
2458          else
2459             Pid     := Portable_No_Block_Spawn (Arg_List'Address);
2460             Result  := Boolean'Pos (Pid /= Invalid_Pid);
2461          end if;
2462       end Spawn;
2463
2464    --  Start of processing for Spawn_Internal
2465
2466    begin
2467       --  Copy arguments into a local structure
2468
2469       for K in N_Args'Range loop
2470          N_Args (K) := new String'(Args (K).all);
2471       end loop;
2472
2473       --  Normalize those arguments
2474
2475       Normalize_Arguments (N_Args);
2476
2477       --  Call spawn using the normalized arguments
2478
2479       Spawn (N_Args);
2480
2481       --  Free arguments list
2482
2483       for K in N_Args'Range loop
2484          Free (N_Args (K));
2485       end loop;
2486    end Spawn_Internal;
2487
2488    ---------------------------
2489    -- To_Path_String_Access --
2490    ---------------------------
2491
2492    function To_Path_String_Access
2493      (Path_Addr : Address;
2494       Path_Len  : Integer) return String_Access
2495    is
2496       subtype Path_String is String (1 .. Path_Len);
2497       type    Path_String_Access is access Path_String;
2498
2499       function Address_To_Access is new
2500         Ada.Unchecked_Conversion (Source => Address,
2501                               Target => Path_String_Access);
2502
2503       Path_Access : constant Path_String_Access :=
2504                       Address_To_Access (Path_Addr);
2505
2506       Return_Val  : String_Access;
2507
2508    begin
2509       Return_Val := new String (1 .. Path_Len);
2510
2511       for J in 1 .. Path_Len loop
2512          Return_Val (J) := Path_Access (J);
2513       end loop;
2514
2515       return Return_Val;
2516    end To_Path_String_Access;
2517
2518    ------------------
2519    -- Wait_Process --
2520    ------------------
2521
2522    procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
2523       Status : Integer;
2524
2525       function Portable_Wait (S : Address) return Process_Id;
2526       pragma Import (C, Portable_Wait, "__gnat_portable_wait");
2527
2528    begin
2529       Pid := Portable_Wait (Status'Address);
2530       Success := (Status = 0);
2531    end Wait_Process;
2532
2533    -----------
2534    -- Write --
2535    -----------
2536
2537    function Write
2538      (FD : File_Descriptor;
2539       A  : System.Address;
2540       N  : Integer) return Integer
2541    is
2542    begin
2543       return Integer (System.CRTL.write
2544         (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
2545    end Write;
2546
2547 end System.OS_Lib;