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