gcc/ada/g-os_lib.adb

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