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