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-2002 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  30 --                                                                          --
  31 ------------------------------------------------------------------------------
  32
  33 with System.Soft_Links;
  34 with Unchecked_Conversion;
  35 with System; use System;
  36
  37 package body GNAT.OS_Lib is
  38
  39    package SSL renames System.Soft_Links;
  40
  41    -----------------------
  42    -- Local Subprograms --
  43    -----------------------
  44
  45    function Args_Length (Args : Argument_List) return Natural;
  46    --  Returns total number of characters needed to create a string
  47    --  of all Args terminated by ASCII.NUL characters
  48
  49    function C_String_Length (S : Address) return Integer;
  50    --  Returns the length of a C string. Does check for null address
  51    --  (returns 0).
  52
  53    procedure Spawn_Internal
  54      (Program_Name : String;
  55       Args         : Argument_List;
  56       Result       : out Integer;
  57       Pid          : out Process_Id;
  58       Blocking     : Boolean);
  59    --  Internal routine to implement the two Spawn (blocking/non blocking)
  60    --  routines. If Blocking is set to True then the spawn is blocking
  61    --  otherwise it is non blocking. In this latter case the Pid contains
  62    --  the process id number. The first three parameters are as in Spawn.
  63    --  Note that Spawn_Internal normalizes the argument list before calling
  64    --  the low level system spawn routines (see Normalize_Arguments). Note
  65    --  that Normalize_Arguments is designed to do nothing if it is called
  66    --  more than once, so calling Normalize_Arguments before calling one
  67    --  of the spawn routines is fine.
  68
  69    function To_Path_String_Access
  70      (Path_Addr : Address;
  71       Path_Len  : Integer)
  72       return      String_Access;
  73    --  Converts a C String to an Ada String. We could do this making use of
  74    --  Interfaces.C.Strings but we prefer not to import that entire package
  75
  76    -----------------
  77    -- Args_Length --
  78    -----------------
  79
  80    function Args_Length (Args : Argument_List) return Natural is
  81       Len : Natural := 0;
  82
  83    begin
  84       for J in Args'Range loop
  85          Len := Len + Args (J)'Length + 1; --  One extra for ASCII.NUL
  86       end loop;
  87
  88       return Len;
  89    end Args_Length;
  90
  91    -----------------------------
  92    -- Argument_String_To_List --
  93    -----------------------------
  94
  95    function Argument_String_To_List
  96      (Arg_String : String)
  97       return       Argument_List_Access
  98    is
  99       Max_Args : Integer := Arg_String'Length;
 100       New_Argv : Argument_List (1 .. Max_Args);
 101       New_Argc : Natural := 0;
 102       Idx      : Integer;
 103
 104    begin
 105       Idx := Arg_String'First;
 106
 107       loop
 108          declare
 109             Quoted  : Boolean := False;
 110             Backqd  : Boolean := False;
 111             Old_Idx : Integer;
 112
 113          begin
 114             Old_Idx := Idx;
 115
 116             loop
 117                --  An unquoted space is the end of an argument
 118
 119                if not (Backqd or Quoted)
 120                  and then Arg_String (Idx) = ' '
 121                then
 122                   exit;
 123
 124                --  Start of a quoted string
 125
 126                elsif not (Backqd or Quoted)
 127                  and then Arg_String (Idx) = '"'
 128                then
 129                   Quoted := True;
 130
 131                --  End of a quoted string and end of an argument
 132
 133                elsif (Quoted and not Backqd)
 134                  and then Arg_String (Idx) = '"'
 135                then
 136                   Idx := Idx + 1;
 137                   exit;
 138
 139                --  Following character is backquoted
 140
 141                elsif Arg_String (Idx) = '\' then
 142                   Backqd := True;
 143
 144                --  Turn off backquoting after advancing one character
 145
 146                elsif Backqd then
 147                   Backqd := False;
 148
 149                end if;
 150
 151                Idx := Idx + 1;
 152                exit when Idx > Arg_String'Last;
 153             end loop;
 154
 155             --  Found an argument
 156
 157             New_Argc := New_Argc + 1;
 158             New_Argv (New_Argc) :=
 159               new String'(Arg_String (Old_Idx .. Idx - 1));
 160
 161             --  Skip extraneous spaces
 162
 163             while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop
 164                Idx := Idx + 1;
 165             end loop;
 166          end;
 167
 168          exit when Idx > Arg_String'Last;
 169       end loop;
 170
 171       return new Argument_List'(New_Argv (1 .. New_Argc));
 172    end Argument_String_To_List;
 173
 174    ---------------------
 175    -- C_String_Length --
 176    ---------------------
 177
 178    function C_String_Length (S : Address) return Integer is
 179       function Strlen (S : Address) return Integer;
 180       pragma Import (C, Strlen, "strlen");
 181
 182    begin
 183       if S = Null_Address then
 184          return 0;
 185       else
 186          return Strlen (S);
 187       end if;
 188    end C_String_Length;
 189
 190    -----------------
 191    -- Create_File --
 192    -----------------
 193
 194    function Create_File
 195      (Name  : C_File_Name;
 196       Fmode : Mode)
 197       return  File_Descriptor
 198    is
 199       function C_Create_File
 200         (Name  : C_File_Name;
 201          Fmode : Mode)
 202          return  File_Descriptor;
 203       pragma Import (C, C_Create_File, "__gnat_open_create");
 204
 205    begin
 206       return C_Create_File (Name, Fmode);
 207    end Create_File;
 208
 209    function Create_File
 210      (Name  : String;
 211       Fmode : Mode)
 212       return  File_Descriptor
 213    is
 214       C_Name : String (1 .. Name'Length + 1);
 215
 216    begin
 217       C_Name (1 .. Name'Length) := Name;
 218       C_Name (C_Name'Last)      := ASCII.NUL;
 219       return Create_File (C_Name (C_Name'First)'Address, Fmode);
 220    end Create_File;
 221
 222    ---------------------
 223    -- Create_New_File --
 224    ---------------------
 225
 226    function Create_New_File
 227      (Name  : C_File_Name;
 228       Fmode : Mode)
 229       return  File_Descriptor
 230    is
 231       function C_Create_New_File
 232         (Name  : C_File_Name;
 233          Fmode : Mode)
 234          return  File_Descriptor;
 235       pragma Import (C, C_Create_New_File, "__gnat_open_new");
 236
 237    begin
 238       return C_Create_New_File (Name, Fmode);
 239    end Create_New_File;
 240
 241    function Create_New_File
 242      (Name  : String;
 243       Fmode : Mode)
 244       return  File_Descriptor
 245    is
 246       C_Name : String (1 .. Name'Length + 1);
 247
 248    begin
 249       C_Name (1 .. Name'Length) := Name;
 250       C_Name (C_Name'Last)      := ASCII.NUL;
 251       return Create_New_File (C_Name (C_Name'First)'Address, Fmode);
 252    end Create_New_File;
 253
 254    ----------------------
 255    -- Create_Temp_File --
 256    ----------------------
 257
 258    procedure Create_Temp_File
 259      (FD   : out File_Descriptor;
 260       Name : out Temp_File_Name)
 261    is
 262       function Open_New_Temp
 263         (Name  : System.Address;
 264          Fmode : Mode)
 265          return  File_Descriptor;
 266       pragma Import (C, Open_New_Temp, "__gnat_open_new_temp");
 267
 268    begin
 269       FD := Open_New_Temp (Name'Address, Binary);
 270    end Create_Temp_File;
 271
 272    -----------------
 273    -- Delete_File --
 274    -----------------
 275
 276    procedure Delete_File (Name : Address; Success : out Boolean) is
 277       R : Integer;
 278
 279       function unlink (A : Address) return Integer;
 280       pragma Import (C, unlink, "unlink");
 281
 282    begin
 283       R := unlink (Name);
 284       Success := (R = 0);
 285    end Delete_File;
 286
 287    procedure Delete_File (Name : String; Success : out Boolean) is
 288       C_Name : String (1 .. Name'Length + 1);
 289
 290    begin
 291       C_Name (1 .. Name'Length) := Name;
 292       C_Name (C_Name'Last)      := ASCII.NUL;
 293
 294       Delete_File (C_Name'Address, Success);
 295    end Delete_File;
 296
 297    ---------------------
 298    -- File_Time_Stamp --
 299    ---------------------
 300
 301    function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
 302       function File_Time (FD    : File_Descriptor) return OS_Time;
 303       pragma Import (C, File_Time, "__gnat_file_time_fd");
 304
 305    begin
 306       return File_Time (FD);
 307    end File_Time_Stamp;
 308
 309    function File_Time_Stamp (Name : C_File_Name) return OS_Time is
 310       function File_Time (Name : Address) return OS_Time;
 311       pragma Import (C, File_Time, "__gnat_file_time_name");
 312
 313    begin
 314       return File_Time (Name);
 315    end File_Time_Stamp;
 316
 317    function File_Time_Stamp (Name : String) return OS_Time is
 318       F_Name : String (1 .. Name'Length + 1);
 319
 320    begin
 321       F_Name (1 .. Name'Length) := Name;
 322       F_Name (F_Name'Last)      := ASCII.NUL;
 323       return File_Time_Stamp (F_Name'Address);
 324    end File_Time_Stamp;
 325
 326    ----------
 327    -- Free --
 328    ----------
 329
 330    procedure Free (Arg : in out String_List_Access) is
 331       X : String_Access;
 332
 333       procedure Free_Array is new Unchecked_Deallocation
 334         (Object => String_List, Name => String_List_Access);
 335
 336    begin
 337       for J in Arg'Range loop
 338          X := Arg (J);
 339          Free (X);
 340       end loop;
 341
 342       Free_Array (Arg);
 343    end Free;
 344
 345    ---------------------------
 346    -- Get_Debuggable_Suffix --
 347    ---------------------------
 348
 349    function Get_Debuggable_Suffix return String_Access is
 350       procedure Get_Suffix_Ptr (Length, Ptr : Address);
 351       pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
 352
 353       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
 354       pragma Import (C, Strncpy, "strncpy");
 355
 356       Suffix_Ptr    : Address;
 357       Suffix_Length : Integer;
 358       Result        : String_Access;
 359
 360    begin
 361       Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
 362
 363       Result := new String (1 .. Suffix_Length);
 364
 365       if Suffix_Length > 0 then
 366          Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
 367       end if;
 368
 369       return Result;
 370    end Get_Debuggable_Suffix;
 371
 372    ---------------------------
 373    -- Get_Executable_Suffix --
 374    ---------------------------
 375
 376    function Get_Executable_Suffix return String_Access is
 377       procedure Get_Suffix_Ptr (Length, Ptr : Address);
 378       pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
 379
 380       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
 381       pragma Import (C, Strncpy, "strncpy");
 382
 383       Suffix_Ptr    : Address;
 384       Suffix_Length : Integer;
 385       Result        : String_Access;
 386
 387    begin
 388       Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
 389
 390       Result := new String (1 .. Suffix_Length);
 391
 392       if Suffix_Length > 0 then
 393          Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
 394       end if;
 395
 396       return Result;
 397    end Get_Executable_Suffix;
 398
 399    -----------------------
 400    -- Get_Object_Suffix --
 401    -----------------------
 402
 403    function Get_Object_Suffix return String_Access is
 404       procedure Get_Suffix_Ptr (Length, Ptr : Address);
 405       pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
 406
 407       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
 408       pragma Import (C, Strncpy, "strncpy");
 409
 410       Suffix_Ptr    : Address;
 411       Suffix_Length : Integer;
 412       Result        : String_Access;
 413
 414    begin
 415       Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
 416
 417       Result := new String (1 .. Suffix_Length);
 418
 419       if Suffix_Length > 0 then
 420          Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
 421       end if;
 422
 423       return Result;
 424    end Get_Object_Suffix;
 425
 426    ------------
 427    -- Getenv --
 428    ------------
 429
 430    function Getenv (Name : String) return String_Access is
 431       procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
 432       pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr");
 433
 434       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
 435       pragma Import (C, Strncpy, "strncpy");
 436
 437       Env_Value_Ptr    : Address;
 438       Env_Value_Length : Integer;
 439       F_Name           : String (1 .. Name'Length + 1);
 440       Result           : String_Access;
 441
 442    begin
 443       F_Name (1 .. Name'Length) := Name;
 444       F_Name (F_Name'Last)      := ASCII.NUL;
 445
 446       Get_Env_Value_Ptr
 447         (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
 448
 449       Result := new String (1 .. Env_Value_Length);
 450
 451       if Env_Value_Length > 0 then
 452          Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
 453       end if;
 454
 455       return Result;
 456    end Getenv;
 457
 458    ------------
 459    -- GM_Day --
 460    ------------
 461
 462    function GM_Day (Date : OS_Time) return Day_Type is
 463       Y  : Year_Type;
 464       Mo : Month_Type;
 465       D  : Day_Type;
 466       H  : Hour_Type;
 467       Mn : Minute_Type;
 468       S  : Second_Type;
 469
 470    begin
 471       GM_Split (Date, Y, Mo, D, H, Mn, S);
 472       return D;
 473    end GM_Day;
 474
 475    -------------
 476    -- GM_Hour --
 477    -------------
 478
 479    function GM_Hour (Date : OS_Time) return Hour_Type is
 480       Y  : Year_Type;
 481       Mo : Month_Type;
 482       D  : Day_Type;
 483       H  : Hour_Type;
 484       Mn : Minute_Type;
 485       S  : Second_Type;
 486
 487    begin
 488       GM_Split (Date, Y, Mo, D, H, Mn, S);
 489       return H;
 490    end GM_Hour;
 491
 492    ---------------
 493    -- GM_Minute --
 494    ---------------
 495
 496    function GM_Minute (Date : OS_Time) return Minute_Type is
 497       Y  : Year_Type;
 498       Mo : Month_Type;
 499       D  : Day_Type;
 500       H  : Hour_Type;
 501       Mn : Minute_Type;
 502       S  : Second_Type;
 503
 504    begin
 505       GM_Split (Date, Y, Mo, D, H, Mn, S);
 506       return Mn;
 507    end GM_Minute;
 508
 509    --------------
 510    -- GM_Month --
 511    --------------
 512
 513    function GM_Month (Date : OS_Time) return Month_Type is
 514       Y  : Year_Type;
 515       Mo : Month_Type;
 516       D  : Day_Type;
 517       H  : Hour_Type;
 518       Mn : Minute_Type;
 519       S  : Second_Type;
 520
 521    begin
 522       GM_Split (Date, Y, Mo, D, H, Mn, S);
 523       return Mo;
 524    end GM_Month;
 525
 526    ---------------
 527    -- GM_Second --
 528    ---------------
 529
 530    function GM_Second (Date : OS_Time) return Second_Type is
 531       Y  : Year_Type;
 532       Mo : Month_Type;
 533       D  : Day_Type;
 534       H  : Hour_Type;
 535       Mn : Minute_Type;
 536       S  : Second_Type;
 537
 538    begin
 539       GM_Split (Date, Y, Mo, D, H, Mn, S);
 540       return S;
 541    end GM_Second;
 542
 543    --------------
 544    -- GM_Split --
 545    --------------
 546
 547    procedure GM_Split
 548      (Date   : OS_Time;
 549       Year   : out Year_Type;
 550       Month  : out Month_Type;
 551       Day    : out Day_Type;
 552       Hour   : out Hour_Type;
 553       Minute : out Minute_Type;
 554       Second : out Second_Type)
 555    is
 556       procedure To_GM_Time
 557         (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
 558       pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
 559
 560       T  : OS_Time := Date;
 561       Y  : Integer;
 562       Mo : Integer;
 563       D  : Integer;
 564       H  : Integer;
 565       Mn : Integer;
 566       S  : Integer;
 567
 568    begin
 569       --  Use the global lock because To_GM_Time is not thread safe.
 570
 571       Locked_Processing : begin
 572          SSL.Lock_Task.all;
 573          To_GM_Time
 574            (T'Address, Y'Address, Mo'Address, D'Address,
 575             H'Address, Mn'Address, S'Address);
 576          SSL.Unlock_Task.all;
 577
 578       exception
 579          when others =>
 580             SSL.Unlock_Task.all;
 581             raise;
 582       end Locked_Processing;
 583
 584       Year   := Y + 1900;
 585       Month  := Mo + 1;
 586       Day    := D;
 587       Hour   := H;
 588       Minute := Mn;
 589       Second := S;
 590    end GM_Split;
 591
 592    -------------
 593    -- GM_Year --
 594    -------------
 595
 596    function GM_Year (Date : OS_Time) return Year_Type is
 597       Y  : Year_Type;
 598       Mo : Month_Type;
 599       D  : Day_Type;
 600       H  : Hour_Type;
 601       Mn : Minute_Type;
 602       S  : Second_Type;
 603
 604    begin
 605       GM_Split (Date, Y, Mo, D, H, Mn, S);
 606       return Y;
 607    end GM_Year;
 608
 609    ----------------------
 610    -- Is_Absolute_Path --
 611    ----------------------
 612
 613    function Is_Absolute_Path (Name : String) return Boolean is
 614       function Is_Absolute_Path (Name : Address) return Integer;
 615       pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
 616
 617       F_Name : String (1 .. Name'Length + 1);
 618
 619    begin
 620       F_Name (1 .. Name'Length) := Name;
 621       F_Name (F_Name'Last)      := ASCII.NUL;
 622
 623       return Is_Absolute_Path (F_Name'Address) /= 0;
 624    end Is_Absolute_Path;
 625
 626    ------------------
 627    -- Is_Directory --
 628    ------------------
 629
 630    function Is_Directory (Name : C_File_Name) return Boolean is
 631       function Is_Directory (Name : Address) return Integer;
 632       pragma Import (C, Is_Directory, "__gnat_is_directory");
 633
 634    begin
 635       return Is_Directory (Name) /= 0;
 636    end Is_Directory;
 637
 638    function Is_Directory (Name : String) return Boolean is
 639       F_Name : String (1 .. Name'Length + 1);
 640
 641    begin
 642       F_Name (1 .. Name'Length) := Name;
 643       F_Name (F_Name'Last)      := ASCII.NUL;
 644       return Is_Directory (F_Name'Address);
 645    end Is_Directory;
 646
 647    ---------------------
 648    -- Is_Regular_File --
 649    ---------------------
 650
 651    function Is_Regular_File (Name : C_File_Name) return Boolean is
 652       function Is_Regular_File (Name : Address) return Integer;
 653       pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
 654
 655    begin
 656       return Is_Regular_File (Name) /= 0;
 657    end Is_Regular_File;
 658
 659    function Is_Regular_File (Name : String) return Boolean is
 660       F_Name : String (1 .. Name'Length + 1);
 661
 662    begin
 663       F_Name (1 .. Name'Length) := Name;
 664       F_Name (F_Name'Last)      := ASCII.NUL;
 665       return Is_Regular_File (F_Name'Address);
 666    end Is_Regular_File;
 667
 668    ----------------------
 669    -- Is_Writable_File --
 670    ----------------------
 671
 672    function Is_Writable_File (Name : C_File_Name) return Boolean is
 673       function Is_Writable_File (Name : Address) return Integer;
 674       pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
 675
 676    begin
 677       return Is_Writable_File (Name) /= 0;
 678    end Is_Writable_File;
 679
 680    function Is_Writable_File (Name : String) return Boolean is
 681       F_Name : String (1 .. Name'Length + 1);
 682
 683    begin
 684       F_Name (1 .. Name'Length) := Name;
 685       F_Name (F_Name'Last)      := ASCII.NUL;
 686       return Is_Writable_File (F_Name'Address);
 687    end Is_Writable_File;
 688
 689    -------------------------
 690    -- Locate_Exec_On_Path --
 691    -------------------------
 692
 693    function Locate_Exec_On_Path
 694      (Exec_Name : String)
 695       return      String_Access
 696    is
 697       function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
 698       pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
 699
 700       procedure Free (Ptr : System.Address);
 701       pragma Import (C, Free, "free");
 702
 703       C_Exec_Name  : String (1 .. Exec_Name'Length + 1);
 704       Path_Addr    : Address;
 705       Path_Len     : Integer;
 706       Result       : String_Access;
 707
 708    begin
 709       C_Exec_Name (1 .. Exec_Name'Length)   := Exec_Name;
 710       C_Exec_Name (C_Exec_Name'Last)        := ASCII.NUL;
 711
 712       Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
 713       Path_Len  := C_String_Length (Path_Addr);
 714
 715       if Path_Len = 0 then
 716          return null;
 717
 718       else
 719          Result := To_Path_String_Access (Path_Addr, Path_Len);
 720          Free (Path_Addr);
 721          return Result;
 722       end if;
 723    end Locate_Exec_On_Path;
 724
 725    -------------------------
 726    -- Locate_Regular_File --
 727    -------------------------
 728
 729    function Locate_Regular_File
 730      (File_Name : C_File_Name;
 731       Path      : C_File_Name)
 732       return      String_Access
 733    is
 734       function Locate_Regular_File
 735         (C_File_Name, Path_Val : Address) return Address;
 736       pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file");
 737
 738       procedure Free (Ptr : System.Address);
 739       pragma Import (C, Free, "free");
 740
 741       Path_Addr    : Address;
 742       Path_Len     : Integer;
 743       Result       : String_Access;
 744
 745    begin
 746       Path_Addr := Locate_Regular_File (File_Name, Path);
 747       Path_Len  := C_String_Length (Path_Addr);
 748
 749       if Path_Len = 0 then
 750          return null;
 751       else
 752          Result := To_Path_String_Access (Path_Addr, Path_Len);
 753          Free (Path_Addr);
 754          return Result;
 755       end if;
 756    end Locate_Regular_File;
 757
 758    function Locate_Regular_File
 759      (File_Name : String;
 760       Path      : String)
 761       return      String_Access
 762    is
 763       C_File_Name : String (1 .. File_Name'Length + 1);
 764       C_Path      : String (1 .. Path'Length + 1);
 765
 766    begin
 767       C_File_Name (1 .. File_Name'Length)   := File_Name;
 768       C_File_Name (C_File_Name'Last)        := ASCII.NUL;
 769
 770       C_Path    (1 .. Path'Length)          := Path;
 771       C_Path    (C_Path'Last)               := ASCII.NUL;
 772
 773       return Locate_Regular_File (C_File_Name'Address, C_Path'Address);
 774    end Locate_Regular_File;
 775
 776    ------------------------
 777    -- Non_Blocking_Spawn --
 778    ------------------------
 779
 780    function Non_Blocking_Spawn
 781      (Program_Name : String;
 782       Args         : Argument_List)
 783       return         Process_Id
 784    is
 785       Junk : Integer;
 786       Pid  : Process_Id;
 787
 788    begin
 789       Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
 790       return Pid;
 791    end Non_Blocking_Spawn;
 792
 793    -------------------------
 794    -- Normalize_Arguments --
 795    -------------------------
 796
 797    procedure Normalize_Arguments (Args : in out Argument_List) is
 798
 799       procedure Quote_Argument (Arg : in out String_Access);
 800       --  Add quote around argument if it contains spaces.
 801
 802       Argument_Needs_Quote : Boolean;
 803       pragma Import (C, Argument_Needs_Quote, "__gnat_argument_needs_quote");
 804
 805       --------------------
 806       -- Quote_Argument --
 807       --------------------
 808
 809       procedure Quote_Argument (Arg : in out String_Access) is
 810          Res          : String (1 .. Arg'Length * 2);
 811          J            : Positive := 1;
 812          Quote_Needed : Boolean  := False;
 813
 814       begin
 815          if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
 816
 817             --  Starting quote
 818
 819             Res (J) := '"';
 820
 821             for K in Arg'Range loop
 822
 823                J := J + 1;
 824
 825                if Arg (K) = '"' then
 826                   Res (J) := '\';
 827                   J := J + 1;
 828                   Res (J) := '"';
 829
 830                elsif Arg (K) = ' ' then
 831                   Res (J) := Arg (K);
 832                   Quote_Needed := True;
 833
 834                else
 835                   Res (J) := Arg (K);
 836                end if;
 837
 838             end loop;
 839
 840             if Quote_Needed then
 841
 842                --  Ending quote
 843
 844                J := J + 1;
 845                Res (J) := '"';
 846
 847                declare
 848                   Old : String_Access := Arg;
 849
 850                begin
 851                   Arg := new String'(Res (1 .. J));
 852                   Free (Old);
 853                end;
 854             end if;
 855
 856          end if;
 857       end Quote_Argument;
 858
 859    begin
 860       if Argument_Needs_Quote then
 861          for K in Args'Range loop
 862             if Args (K) /= null then
 863                Quote_Argument (Args (K));
 864             end if;
 865          end loop;
 866       end if;
 867    end Normalize_Arguments;
 868
 869    ------------------------
 870    -- Normalize_Pathname --
 871    ------------------------
 872
 873    function Normalize_Pathname
 874      (Name      : String;
 875       Directory : String := "")
 876       return      String
 877    is
 878       Max_Path : Integer;
 879       pragma Import (C, Max_Path, "__gnat_max_path_len");
 880       --  Maximum length of a path name
 881
 882       procedure Get_Current_Dir
 883         (Dir    : System.Address;
 884          Length : System.Address);
 885       pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
 886
 887       Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
 888       End_Path    : Natural := 0;
 889       Link_Buffer : String (1 .. Max_Path + 2);
 890       Status      : Integer;
 891       Last        : Positive;
 892       Start       : Natural;
 893       Finish      : Positive;
 894
 895       Max_Iterations : constant := 500;
 896
 897       function Readlink
 898         (Path   : System.Address;
 899          Buf    : System.Address;
 900          Bufsiz : Integer)
 901          return   Integer;
 902       pragma Import (C, Readlink, "__gnat_readlink");
 903
 904       function To_Canonical_File_Spec
 905         (Host_File : System.Address)
 906          return      System.Address;
 907       pragma Import
 908         (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
 909
 910       The_Name : String (1 .. Name'Length + 1);
 911       Canonical_File_Addr : System.Address;
 912       Canonical_File_Len  : Integer;
 913
 914       Need_To_Check_Drive_Letter : Boolean := False;
 915       --  Set to true if Name is an absolute path that starts with "//"
 916
 917       function Strlen (S : System.Address) return Integer;
 918       pragma Import (C, Strlen, "strlen");
 919
 920       function Get_Directory return String;
 921       --  If Directory is not empty, return it, adding a directory separator
 922       --  if not already present, otherwise return current working directory
 923       --  with terminating directory separator.
 924
 925       function Final_Value (S : String) return String;
 926       --  Make final adjustment to the returned string.
 927       --  To compensate for non standard path name in Interix,
 928       --  if S is "/x" or starts with "/x", where x is a capital
 929       --  letter 'A' to 'Z', add an additional '/' at the beginning
 930       --  so that the returned value starts with "//x".
 931
 932       -------------------
 933       -- Get_Directory --
 934       -------------------
 935
 936       function Get_Directory return String is
 937       begin
 938          --  Directory given, add directory separator if needed
 939
 940          if Directory'Length > 0 then
 941             if Directory (Directory'Length) = Directory_Separator then
 942                return Directory;
 943             else
 944                declare
 945                   Result : String (1 .. Directory'Length + 1);
 946
 947                begin
 948                   Result (1 .. Directory'Length) := Directory;
 949                   Result (Result'Length) := Directory_Separator;
 950                   return Result;
 951                end;
 952             end if;
 953
 954          --  Directory name not given, get current directory
 955
 956          else
 957             declare
 958                Buffer   : String (1 .. Max_Path + 2);
 959                Path_Len : Natural := Max_Path;
 960
 961             begin
 962                Get_Current_Dir (Buffer'Address, Path_Len'Address);
 963
 964                if Buffer (Path_Len) /= Directory_Separator then
 965                   Path_Len := Path_Len + 1;
 966                   Buffer (Path_Len) := Directory_Separator;
 967                end if;
 968
 969                return Buffer (1 .. Path_Len);
 970             end;
 971          end if;
 972       end Get_Directory;
 973
 974       Reference_Dir : constant String := Get_Directory;
 975       --  Current directory name specified
 976
 977       -----------------
 978       -- Final_Value --
 979       -----------------
 980
 981       function Final_Value (S : String) return String is
 982       begin
 983          --  Interix has the non standard notion of disk drive
 984          --  indicated by two '/' followed by a capital letter
 985          --  'A' .. 'Z'. One of the two '/' may have been removed
 986          --  by Normalize_Pathname. It has to be added again.
 987          --  For other OSes, this should not make no difference.
 988
 989          if Need_To_Check_Drive_Letter
 990            and then S'Length >= 2
 991            and then S (S'First) = '/'
 992            and then S (S'First + 1) in 'A' .. 'Z'
 993            and then (S'Length = 2 or else S (S'First + 2) = '/')
 994          then
 995             declare
 996                Result : String (1 .. S'Length + 1);
 997
 998             begin
 999                Result (1) := '/';
1000                Result (2 .. Result'Last) := S;
1001                return Result;
1002             end;
1003
1004          else
1005             return S;
1006          end if;
1007
1008       end Final_Value;
1009
1010    --  Start of processing for Normalize_Pathname
1011
1012    begin
1013       --  Special case, if name is null, then return null
1014
1015       if Name'Length = 0 then
1016          return "";
1017       end if;
1018
1019       --  First, convert VMS file spec to Unix file spec.
1020       --  If Name is not in VMS syntax, then this is equivalent
1021       --  to put Name at the begining of Path_Buffer.
1022
1023       VMS_Conversion : begin
1024          The_Name (1 .. Name'Length) := Name;
1025          The_Name (The_Name'Last) := ASCII.NUL;
1026
1027          Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1028          Canonical_File_Len  := Strlen (Canonical_File_Addr);
1029
1030          --  If VMS syntax conversion has failed, return an empty string
1031          --  to indicate the failure.
1032
1033          if Canonical_File_Len = 0 then
1034             return "";
1035          end if;
1036
1037          declare
1038             subtype Path_String is String (1 .. Canonical_File_Len);
1039             type    Path_String_Access is access Path_String;
1040
1041             function Address_To_Access is new
1042                Unchecked_Conversion (Source => Address,
1043                                      Target => Path_String_Access);
1044
1045             Path_Access : Path_String_Access :=
1046                          Address_To_Access (Canonical_File_Addr);
1047
1048          begin
1049             Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
1050             End_Path := Canonical_File_Len;
1051             Last := 1;
1052          end;
1053       end VMS_Conversion;
1054
1055       --  Replace all '/' by Directory Separators (this is for Windows)
1056
1057       if Directory_Separator /= '/' then
1058          for Index in 1 .. End_Path loop
1059             if Path_Buffer (Index) = '/' then
1060                Path_Buffer (Index) := Directory_Separator;
1061             end if;
1062          end loop;
1063       end if;
1064
1065       --  Start the conversions
1066
1067       --  If this is not finished after Max_Iterations, give up and
1068       --  return an empty string.
1069
1070       for J in 1 .. Max_Iterations loop
1071
1072          --  If we don't have an absolute pathname, prepend
1073          --  the directory Reference_Dir.
1074
1075          if Last = 1
1076            and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
1077          then
1078             Path_Buffer
1079               (Reference_Dir'Last + 1 .. Reference_Dir'Length + End_Path) :=
1080                  Path_Buffer (1 .. End_Path);
1081             End_Path := Reference_Dir'Length + End_Path;
1082             Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir;
1083             Last := Reference_Dir'Length;
1084          end if;
1085
1086          --  If name starts with "//", we may have a drive letter on Interix
1087
1088          if Last = 1 and then End_Path >= 3 then
1089             Need_To_Check_Drive_Letter := (Path_Buffer (1 .. 2)) = "//";
1090          end if;
1091
1092          Start  := Last + 1;
1093          Finish := Last;
1094
1095          --  If we have traversed the full pathname, return it
1096
1097          if Start > End_Path then
1098             return Final_Value (Path_Buffer (1 .. End_Path));
1099          end if;
1100
1101          --  Remove duplicate directory separators
1102
1103          while Path_Buffer (Start) = Directory_Separator loop
1104             if Start = End_Path then
1105                return Final_Value (Path_Buffer (1 .. End_Path - 1));
1106
1107             else
1108                Path_Buffer (Start .. End_Path - 1) :=
1109                  Path_Buffer (Start + 1 .. End_Path);
1110                End_Path := End_Path - 1;
1111             end if;
1112          end loop;
1113
1114          --  Find the end of the current field: last character
1115          --  or the one preceding the next directory separator.
1116
1117          while Finish < End_Path
1118            and then Path_Buffer (Finish + 1) /= Directory_Separator
1119          loop
1120             Finish := Finish + 1;
1121          end loop;
1122
1123          --  Remove "." field
1124
1125          if Start = Finish and then Path_Buffer (Start) = '.' then
1126             if Start = End_Path then
1127                if Last = 1 then
1128                   return (1 => Directory_Separator);
1129                else
1130                   return Path_Buffer (1 .. Last - 1);
1131                end if;
1132
1133             else
1134                Path_Buffer (Last + 1 .. End_Path - 2) :=
1135                  Path_Buffer (Last + 3 .. End_Path);
1136                End_Path := End_Path - 2;
1137             end if;
1138
1139          --  Remove ".." fields
1140
1141          elsif Finish = Start + 1
1142            and then Path_Buffer (Start .. Finish) = ".."
1143          then
1144             Start := Last;
1145             loop
1146                Start := Start - 1;
1147                exit when Start < 1 or else
1148                  Path_Buffer (Start) = Directory_Separator;
1149             end loop;
1150
1151             if Start <= 1 then
1152                if Finish = End_Path then
1153                   return (1 => Directory_Separator);
1154
1155                else
1156                   Path_Buffer (1 .. End_Path - Finish) :=
1157                     Path_Buffer (Finish + 1 .. End_Path);
1158                   End_Path := End_Path - Finish;
1159                   Last := 1;
1160                end if;
1161
1162             else
1163                if Finish = End_Path then
1164                   return Final_Value (Path_Buffer (1 .. Start - 1));
1165
1166                else
1167                   Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
1168                     Path_Buffer (Finish + 2 .. End_Path);
1169                   End_Path := Start + End_Path - Finish - 1;
1170                   Last := Start;
1171                end if;
1172             end if;
1173
1174          --  Check if current field is a symbolic link
1175
1176          else
1177             declare
1178                Saved : Character := Path_Buffer (Finish + 1);
1179
1180             begin
1181                Path_Buffer (Finish + 1) := ASCII.NUL;
1182                Status := Readlink (Path_Buffer'Address,
1183                                    Link_Buffer'Address,
1184                                    Link_Buffer'Length);
1185                Path_Buffer (Finish + 1) := Saved;
1186             end;
1187
1188             --  Not a symbolic link, move to the next field, if any
1189
1190             if Status <= 0 then
1191                Last := Finish + 1;
1192
1193             --  Replace symbolic link with its value.
1194
1195             else
1196                if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
1197                   Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
1198                   Path_Buffer (Finish + 1 .. End_Path);
1199                   End_Path := End_Path - (Finish - Status);
1200                   Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
1201                   Last := 1;
1202
1203                else
1204                   Path_Buffer
1205                     (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
1206                     Path_Buffer (Finish + 1 .. End_Path);
1207                   End_Path := End_Path - Finish + Last + Status;
1208                   Path_Buffer (Last + 1 .. Last + Status) :=
1209                     Link_Buffer (1 .. Status);
1210                end if;
1211             end if;
1212          end if;
1213       end loop;
1214
1215       --  Too many iterations: give up
1216
1217       --  This can happen when there is a circularity in the symbolic links:
1218       --  A is a symbolic link for B, which itself is a symbolic link, and
1219       --  the target of B or of another symbolic link target of B is A.
1220       --  In this case, we return an empty string to indicate failure to
1221       --  resolve.
1222
1223       return "";
1224    end Normalize_Pathname;
1225
1226    ---------------
1227    -- Open_Read --
1228    ---------------
1229
1230    function Open_Read
1231      (Name  : C_File_Name;
1232       Fmode : Mode)
1233       return  File_Descriptor
1234    is
1235       function C_Open_Read
1236         (Name  : C_File_Name;
1237          Fmode : Mode)
1238          return  File_Descriptor;
1239       pragma Import (C, C_Open_Read, "__gnat_open_read");
1240
1241    begin
1242       return C_Open_Read (Name, Fmode);
1243    end Open_Read;
1244
1245    function Open_Read
1246      (Name  : String;
1247       Fmode : Mode)
1248       return  File_Descriptor
1249    is
1250       C_Name : String (1 .. Name'Length + 1);
1251
1252    begin
1253       C_Name (1 .. Name'Length) := Name;
1254       C_Name (C_Name'Last)      := ASCII.NUL;
1255       return Open_Read (C_Name (C_Name'First)'Address, Fmode);
1256    end Open_Read;
1257
1258    ---------------------
1259    -- Open_Read_Write --
1260    ---------------------
1261
1262    function Open_Read_Write
1263      (Name  : C_File_Name;
1264       Fmode : Mode)
1265       return  File_Descriptor
1266    is
1267       function C_Open_Read_Write
1268         (Name  : C_File_Name;
1269          Fmode : Mode)
1270          return  File_Descriptor;
1271       pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
1272
1273    begin
1274       return C_Open_Read_Write (Name, Fmode);
1275    end Open_Read_Write;
1276
1277    function Open_Read_Write
1278      (Name  : String;
1279       Fmode : Mode)
1280       return  File_Descriptor
1281    is
1282       C_Name : String (1 .. Name'Length + 1);
1283
1284    begin
1285       C_Name (1 .. Name'Length) := Name;
1286       C_Name (C_Name'Last)      := ASCII.NUL;
1287       return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
1288    end Open_Read_Write;
1289
1290    -----------------
1291    -- Rename_File --
1292    -----------------
1293
1294    procedure Rename_File
1295      (Old_Name : C_File_Name;
1296       New_Name : C_File_Name;
1297       Success  : out Boolean)
1298    is
1299       function rename (From, To : Address) return Integer;
1300       pragma Import (C, rename, "rename");
1301
1302       R : Integer;
1303
1304    begin
1305       R := rename (Old_Name, New_Name);
1306       Success := (R = 0);
1307    end Rename_File;
1308
1309    procedure Rename_File
1310      (Old_Name : String;
1311       New_Name : String;
1312       Success  : out Boolean)
1313    is
1314       C_Old_Name : String (1 .. Old_Name'Length + 1);
1315       C_New_Name : String (1 .. New_Name'Length + 1);
1316
1317    begin
1318       C_Old_Name (1 .. Old_Name'Length) := Old_Name;
1319       C_Old_Name (C_Old_Name'Last)      := ASCII.NUL;
1320
1321       C_New_Name (1 .. New_Name'Length) := New_Name;
1322       C_New_Name (C_New_Name'Last)      := ASCII.NUL;
1323
1324       Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
1325    end Rename_File;
1326
1327    ------------
1328    -- Setenv --
1329    ------------
1330
1331    procedure Setenv (Name : String; Value : String) is
1332       F_Name  : String (1 .. Name'Length + 1);
1333       F_Value : String (1 .. Value'Length + 1);
1334
1335       procedure Set_Env_Value (Name, Value : System.Address);
1336       pragma Import (C, Set_Env_Value, "__gnat_set_env_value");
1337
1338    begin
1339       F_Name (1 .. Name'Length) := Name;
1340       F_Name (F_Name'Last)      := ASCII.NUL;
1341
1342       F_Value (1 .. Value'Length) := Value;
1343       F_Value (F_Value'Last)      := ASCII.NUL;
1344
1345       Set_Env_Value (F_Name'Address, F_Value'Address);
1346    end Setenv;
1347
1348    -----------
1349    -- Spawn --
1350    -----------
1351
1352    function Spawn
1353      (Program_Name : String;
1354       Args         : Argument_List)
1355       return         Integer
1356    is
1357       Junk   : Process_Id;
1358       Result : Integer;
1359
1360    begin
1361       Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
1362       return Result;
1363    end Spawn;
1364
1365    procedure Spawn
1366      (Program_Name : String;
1367       Args         : Argument_List;
1368       Success      : out Boolean)
1369    is
1370    begin
1371       Success := (Spawn (Program_Name, Args) = 0);
1372    end Spawn;
1373
1374    --------------------
1375    -- Spawn_Internal --
1376    --------------------
1377
1378    procedure Spawn_Internal
1379      (Program_Name : String;
1380       Args         : Argument_List;
1381       Result       : out Integer;
1382       Pid          : out Process_Id;
1383       Blocking     : Boolean)
1384    is
1385
1386       procedure Spawn (Args : Argument_List);
1387       --  Call Spawn.
1388
1389       N_Args : Argument_List (Args'Range);
1390       --  Normalized arguments
1391
1392       -----------
1393       -- Spawn --
1394       -----------
1395
1396       procedure Spawn (Args : Argument_List) is
1397          type Chars is array (Positive range <>) of aliased Character;
1398          type Char_Ptr is access constant Character;
1399
1400          Command_Len : constant Positive := Program_Name'Length + 1
1401                                               + Args_Length (Args);
1402          Command_Last : Natural := 0;
1403          Command : aliased Chars (1 .. Command_Len);
1404          --  Command contains all characters of the Program_Name and Args,
1405          --  all terminated by ASCII.NUL characters
1406
1407          Arg_List_Len : constant Positive := Args'Length + 2;
1408          Arg_List_Last : Natural := 0;
1409          Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
1410          --  List with pointers to NUL-terminated strings of the
1411          --  Program_Name and the Args and terminated with a null pointer.
1412          --  We rely on the default initialization for the last null pointer.
1413
1414          procedure Add_To_Command (S : String);
1415          --  Add S and a NUL character to Command, updating Last
1416
1417          function Portable_Spawn (Args : Address) return Integer;
1418          pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
1419
1420          function Portable_No_Block_Spawn (Args : Address) return Process_Id;
1421          pragma Import
1422            (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
1423
1424          --------------------
1425          -- Add_To_Command --
1426          --------------------
1427
1428          procedure Add_To_Command (S : String) is
1429             First : constant Natural := Command_Last + 1;
1430
1431          begin
1432             Command_Last := Command_Last + S'Length;
1433
1434             --  Move characters one at a time, because Command has
1435             --  aliased components.
1436
1437             for J in S'Range loop
1438                Command (First + J - S'First) := S (J);
1439             end loop;
1440
1441             Command_Last := Command_Last + 1;
1442             Command (Command_Last) := ASCII.NUL;
1443
1444             Arg_List_Last := Arg_List_Last + 1;
1445             Arg_List (Arg_List_Last) := Command (First)'Access;
1446          end Add_To_Command;
1447
1448       --  Start of processing for Spawn
1449
1450       begin
1451          Add_To_Command (Program_Name);
1452
1453          for J in Args'Range loop
1454             Add_To_Command (Args (J).all);
1455          end loop;
1456
1457          if Blocking then
1458             Pid     := Invalid_Pid;
1459             Result  := Portable_Spawn (Arg_List'Address);
1460          else
1461             Pid     := Portable_No_Block_Spawn (Arg_List'Address);
1462             Result  := Boolean'Pos (Pid /= Invalid_Pid);
1463          end if;
1464       end Spawn;
1465
1466    --  Start of processing for Spawn_Internal
1467
1468    begin
1469       --  Copy arguments into a local structure
1470
1471       for K in N_Args'Range loop
1472          N_Args (K) := new String'(Args (K).all);
1473       end loop;
1474
1475       --  Normalize those arguments
1476
1477       Normalize_Arguments (N_Args);
1478
1479       --  Call spawn using the normalized arguments
1480
1481       Spawn (N_Args);
1482
1483       --  Free arguments list
1484
1485       for K in N_Args'Range loop
1486          Free (N_Args (K));
1487       end loop;
1488    end Spawn_Internal;
1489
1490    ---------------------------
1491    -- To_Path_String_Access --
1492    ---------------------------
1493
1494    function To_Path_String_Access
1495      (Path_Addr : Address;
1496       Path_Len  : Integer)
1497       return      String_Access
1498    is
1499       subtype Path_String is String (1 .. Path_Len);
1500       type    Path_String_Access is access Path_String;
1501
1502       function Address_To_Access is new
1503         Unchecked_Conversion (Source => Address,
1504                               Target => Path_String_Access);
1505
1506       Path_Access : Path_String_Access := Address_To_Access (Path_Addr);
1507
1508       Return_Val  : String_Access;
1509
1510    begin
1511       Return_Val := new String (1 .. Path_Len);
1512
1513       for J in 1 .. Path_Len loop
1514          Return_Val (J) := Path_Access (J);
1515       end loop;
1516
1517       return Return_Val;
1518    end To_Path_String_Access;
1519
1520    ------------------
1521    -- Wait_Process --
1522    ------------------
1523
1524    procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
1525       Status : Integer;
1526
1527       function Portable_Wait (S : Address) return Process_Id;
1528       pragma Import (C, Portable_Wait, "__gnat_portable_wait");
1529
1530    begin
1531       Pid := Portable_Wait (Status'Address);
1532       Success := (Status = 0);
1533    end Wait_Process;
1534
1535 end GNAT.OS_Lib;