gcc/ada/g-os_lib.adb

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