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