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