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 (Name : Address) return Integer;
1114       pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
1115
1116       F_Name : String (1 .. Name'Length + 1);
1117
1118    begin
1119       F_Name (1 .. Name'Length) := Name;
1120       F_Name (F_Name'Last)      := ASCII.NUL;
1121
1122       return Is_Absolute_Path (F_Name'Address) /= 0;
1123    end Is_Absolute_Path;
1124
1125    ------------------
1126    -- Is_Directory --
1127    ------------------
1128
1129    function Is_Directory (Name : C_File_Name) return Boolean is
1130       function Is_Directory (Name : Address) return Integer;
1131       pragma Import (C, Is_Directory, "__gnat_is_directory");
1132
1133    begin
1134       return Is_Directory (Name) /= 0;
1135    end Is_Directory;
1136
1137    function Is_Directory (Name : String) return Boolean is
1138       F_Name : String (1 .. Name'Length + 1);
1139
1140    begin
1141       F_Name (1 .. Name'Length) := Name;
1142       F_Name (F_Name'Last)      := ASCII.NUL;
1143       return Is_Directory (F_Name'Address);
1144    end Is_Directory;
1145
1146    ---------------------
1147    -- Is_Regular_File --
1148    ---------------------
1149
1150    function Is_Regular_File (Name : C_File_Name) return Boolean is
1151       function Is_Regular_File (Name : Address) return Integer;
1152       pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
1153
1154    begin
1155       return Is_Regular_File (Name) /= 0;
1156    end Is_Regular_File;
1157
1158    function Is_Regular_File (Name : String) return Boolean is
1159       F_Name : String (1 .. Name'Length + 1);
1160
1161    begin
1162       F_Name (1 .. Name'Length) := Name;
1163       F_Name (F_Name'Last)      := ASCII.NUL;
1164       return Is_Regular_File (F_Name'Address);
1165    end Is_Regular_File;
1166
1167    ----------------------
1168    -- Is_Readable_File --
1169    ----------------------
1170
1171    function Is_Readable_File (Name : C_File_Name) return Boolean is
1172       function Is_Readable_File (Name : Address) return Integer;
1173       pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
1174
1175    begin
1176       return Is_Readable_File (Name) /= 0;
1177    end Is_Readable_File;
1178
1179    function Is_Readable_File (Name : String) return Boolean is
1180       F_Name : String (1 .. Name'Length + 1);
1181
1182    begin
1183       F_Name (1 .. Name'Length) := Name;
1184       F_Name (F_Name'Last)      := ASCII.NUL;
1185       return Is_Readable_File (F_Name'Address);
1186    end Is_Readable_File;
1187
1188    ----------------------
1189    -- Is_Writable_File --
1190    ----------------------
1191
1192    function Is_Writable_File (Name : C_File_Name) return Boolean is
1193       function Is_Writable_File (Name : Address) return Integer;
1194       pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
1195
1196    begin
1197       return Is_Writable_File (Name) /= 0;
1198    end Is_Writable_File;
1199
1200    function Is_Writable_File (Name : String) return Boolean is
1201       F_Name : String (1 .. Name'Length + 1);
1202
1203    begin
1204       F_Name (1 .. Name'Length) := Name;
1205       F_Name (F_Name'Last)      := ASCII.NUL;
1206       return Is_Writable_File (F_Name'Address);
1207    end Is_Writable_File;
1208
1209    ----------------------
1210    -- Is_Symbolic_Link --
1211    ----------------------
1212
1213    function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
1214       function Is_Symbolic_Link (Name : Address) return Integer;
1215       pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
1216
1217    begin
1218       return Is_Symbolic_Link (Name) /= 0;
1219    end Is_Symbolic_Link;
1220
1221    function Is_Symbolic_Link (Name : String) return Boolean is
1222       F_Name : String (1 .. Name'Length + 1);
1223
1224    begin
1225       F_Name (1 .. Name'Length) := Name;
1226       F_Name (F_Name'Last)      := ASCII.NUL;
1227       return Is_Symbolic_Link (F_Name'Address);
1228    end Is_Symbolic_Link;
1229
1230    -------------------------
1231    -- Locate_Exec_On_Path --
1232    -------------------------
1233
1234    function Locate_Exec_On_Path
1235      (Exec_Name : String) return String_Access
1236    is
1237       function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
1238       pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
1239
1240       procedure Free (Ptr : System.Address);
1241       pragma Import (C, Free, "free");
1242
1243       C_Exec_Name  : String (1 .. Exec_Name'Length + 1);
1244       Path_Addr    : Address;
1245       Path_Len     : Integer;
1246       Result       : String_Access;
1247
1248    begin
1249       C_Exec_Name (1 .. Exec_Name'Length)   := Exec_Name;
1250       C_Exec_Name (C_Exec_Name'Last)        := ASCII.NUL;
1251
1252       Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
1253       Path_Len  := C_String_Length (Path_Addr);
1254
1255       if Path_Len = 0 then
1256          return null;
1257
1258       else
1259          Result := To_Path_String_Access (Path_Addr, Path_Len);
1260          Free (Path_Addr);
1261          return Result;
1262       end if;
1263    end Locate_Exec_On_Path;
1264
1265    -------------------------
1266    -- Locate_Regular_File --
1267    -------------------------
1268
1269    function Locate_Regular_File
1270      (File_Name : C_File_Name;
1271       Path      : C_File_Name) return String_Access
1272    is
1273       function Locate_Regular_File
1274         (C_File_Name, Path_Val : Address) return Address;
1275       pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file");
1276
1277       procedure Free (Ptr : System.Address);
1278       pragma Import (C, Free, "free");
1279
1280       Path_Addr    : Address;
1281       Path_Len     : Integer;
1282       Result       : String_Access;
1283
1284    begin
1285       Path_Addr := Locate_Regular_File (File_Name, Path);
1286       Path_Len  := C_String_Length (Path_Addr);
1287
1288       if Path_Len = 0 then
1289          return null;
1290       else
1291          Result := To_Path_String_Access (Path_Addr, Path_Len);
1292          Free (Path_Addr);
1293          return Result;
1294       end if;
1295    end Locate_Regular_File;
1296
1297    function Locate_Regular_File
1298      (File_Name : String;
1299       Path      : String) return String_Access
1300    is
1301       C_File_Name : String (1 .. File_Name'Length + 1);
1302       C_Path      : String (1 .. Path'Length + 1);
1303
1304    begin
1305       C_File_Name (1 .. File_Name'Length)   := File_Name;
1306       C_File_Name (C_File_Name'Last)        := ASCII.NUL;
1307
1308       C_Path    (1 .. Path'Length)          := Path;
1309       C_Path    (C_Path'Last)               := ASCII.NUL;
1310
1311       return Locate_Regular_File (C_File_Name'Address, C_Path'Address);
1312    end Locate_Regular_File;
1313
1314    ------------------------
1315    -- Non_Blocking_Spawn --
1316    ------------------------
1317
1318    function Non_Blocking_Spawn
1319      (Program_Name : String;
1320       Args         : Argument_List) return Process_Id
1321    is
1322       Junk : Integer;
1323       Pid  : Process_Id;
1324
1325    begin
1326       Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
1327       return Pid;
1328    end Non_Blocking_Spawn;
1329
1330    -------------------------
1331    -- Normalize_Arguments --
1332    -------------------------
1333
1334    procedure Normalize_Arguments (Args : in out Argument_List) is
1335
1336       procedure Quote_Argument (Arg : in out String_Access);
1337       --  Add quote around argument if it contains spaces
1338
1339       C_Argument_Needs_Quote : Integer;
1340       pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
1341       Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
1342
1343       --------------------
1344       -- Quote_Argument --
1345       --------------------
1346
1347       procedure Quote_Argument (Arg : in out String_Access) is
1348          Res          : String (1 .. Arg'Length * 2);
1349          J            : Positive := 1;
1350          Quote_Needed : Boolean  := False;
1351
1352       begin
1353          if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
1354
1355             --  Starting quote
1356
1357             Res (J) := '"';
1358
1359             for K in Arg'Range loop
1360
1361                J := J + 1;
1362
1363                if Arg (K) = '"' then
1364                   Res (J) := '\';
1365                   J := J + 1;
1366                   Res (J) := '"';
1367                   Quote_Needed := True;
1368
1369                elsif Arg (K) = ' ' then
1370                   Res (J) := Arg (K);
1371                   Quote_Needed := True;
1372
1373                else
1374                   Res (J) := Arg (K);
1375                end if;
1376
1377             end loop;
1378
1379             if Quote_Needed then
1380
1381                --  If null terminated string, put the quote before
1382
1383                if Res (J) = ASCII.Nul then
1384                   Res (J) := '"';
1385                   J := J + 1;
1386                   Res (J) := ASCII.Nul;
1387
1388                --  If argument is terminated by '\', then double it. Otherwise
1389                --  the ending quote will be taken as-is. This is quite strange
1390                --  spawn behavior from Windows, but this is what we see!
1391
1392                else
1393                   if Res (J) = '\' then
1394                      J := J + 1;
1395                      Res (J) := '\';
1396                   end if;
1397
1398                   --  Ending quote
1399
1400                   J := J + 1;
1401                   Res (J) := '"';
1402                end if;
1403
1404                declare
1405                   Old : String_Access := Arg;
1406
1407                begin
1408                   Arg := new String'(Res (1 .. J));
1409                   Free (Old);
1410                end;
1411             end if;
1412
1413          end if;
1414       end Quote_Argument;
1415
1416    begin
1417       if Argument_Needs_Quote then
1418          for K in Args'Range loop
1419             if Args (K) /= null and then Args (K)'Length /= 0 then
1420                Quote_Argument (Args (K));
1421             end if;
1422          end loop;
1423       end if;
1424    end Normalize_Arguments;
1425
1426    ------------------------
1427    -- Normalize_Pathname --
1428    ------------------------
1429
1430    function Normalize_Pathname
1431      (Name           : String;
1432       Directory      : String  := "";
1433       Resolve_Links  : Boolean := True;
1434       Case_Sensitive : Boolean := True) return String
1435    is
1436       Max_Path : Integer;
1437       pragma Import (C, Max_Path, "__gnat_max_path_len");
1438       --  Maximum length of a path name
1439
1440       procedure Get_Current_Dir
1441         (Dir    : System.Address;
1442          Length : System.Address);
1443       pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
1444
1445       function Change_Dir (Dir_Name : String) return Integer;
1446       pragma Import (C, Change_Dir, "chdir");
1447
1448       Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
1449       End_Path    : Natural := 0;
1450       Link_Buffer : String (1 .. Max_Path + 2);
1451       Status      : Integer;
1452       Last        : Positive;
1453       Start       : Natural;
1454       Finish      : Positive;
1455
1456       Max_Iterations : constant := 500;
1457
1458       function Get_File_Names_Case_Sensitive return Integer;
1459       pragma Import
1460         (C, Get_File_Names_Case_Sensitive,
1461          "__gnat_get_file_names_case_sensitive");
1462
1463       Fold_To_Lower_Case : constant Boolean :=
1464                              not Case_Sensitive
1465                                and then Get_File_Names_Case_Sensitive = 0;
1466
1467       function Readlink
1468         (Path   : System.Address;
1469          Buf    : System.Address;
1470          Bufsiz : Integer) return Integer;
1471       pragma Import (C, Readlink, "__gnat_readlink");
1472
1473       function To_Canonical_File_Spec
1474         (Host_File : System.Address) return System.Address;
1475       pragma Import
1476         (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
1477
1478       The_Name : String (1 .. Name'Length + 1);
1479       Canonical_File_Addr : System.Address;
1480       Canonical_File_Len  : Integer;
1481
1482       Need_To_Check_Drive_Letter : Boolean := False;
1483       --  Set to true if Name is an absolute path that starts with "//"
1484
1485       function Strlen (S : System.Address) return Integer;
1486       pragma Import (C, Strlen, "strlen");
1487
1488       function Get_Directory  (Dir : String) return String;
1489       --  If Dir is not empty, return it, adding a directory separator
1490       --  if not already present, otherwise return current working directory
1491       --  with terminating directory separator.
1492
1493       function Final_Value (S : String) return String;
1494       --  Make final adjustment to the returned string.
1495       --  To compensate for non standard path name in Interix,
1496       --  if S is "/x" or starts with "/x", where x is a capital
1497       --  letter 'A' to 'Z', add an additional '/' at the beginning
1498       --  so that the returned value starts with "//x".
1499
1500       -------------------
1501       -- Get_Directory --
1502       -------------------
1503
1504       function Get_Directory (Dir : String) return String is
1505       begin
1506          --  Directory given, add directory separator if needed
1507
1508          if Dir'Length > 0 then
1509             if Dir (Dir'Length) = Directory_Separator then
1510                return Directory;
1511             else
1512                declare
1513                   Result : String (1 .. Dir'Length + 1);
1514
1515                begin
1516                   Result (1 .. Dir'Length) := Dir;
1517                   Result (Result'Length) := Directory_Separator;
1518                   return Result;
1519                end;
1520             end if;
1521
1522          --  Directory name not given, get current directory
1523
1524          else
1525             declare
1526                Buffer   : String (1 .. Max_Path + 2);
1527                Path_Len : Natural := Max_Path;
1528
1529             begin
1530                Get_Current_Dir (Buffer'Address, Path_Len'Address);
1531
1532                if Buffer (Path_Len) /= Directory_Separator then
1533                   Path_Len := Path_Len + 1;
1534                   Buffer (Path_Len) := Directory_Separator;
1535                end if;
1536
1537                return Buffer (1 .. Path_Len);
1538             end;
1539          end if;
1540       end Get_Directory;
1541
1542       Reference_Dir : constant String := Get_Directory (Directory);
1543       --  Current directory name specified
1544
1545       -----------------
1546       -- Final_Value --
1547       -----------------
1548
1549       function Final_Value (S : String) return String is
1550          S1 : String := S;
1551          --  We may need to fold S to lower case, so we need a variable
1552
1553       begin
1554          --  Interix has the non standard notion of disk drive
1555          --  indicated by two '/' followed by a capital letter
1556          --  'A' .. 'Z'. One of the two '/' may have been removed
1557          --  by Normalize_Pathname. It has to be added again.
1558          --  For other OSes, this should not make no difference.
1559
1560          if Need_To_Check_Drive_Letter
1561            and then S'Length >= 2
1562            and then S (S'First) = '/'
1563            and then S (S'First + 1) in 'A' .. 'Z'
1564            and then (S'Length = 2 or else S (S'First + 2) = '/')
1565          then
1566             declare
1567                Result : String (1 .. S'Length + 1);
1568
1569             begin
1570                Result (1) := '/';
1571                Result (2 .. Result'Last) := S;
1572
1573                if Fold_To_Lower_Case then
1574                   System.Case_Util.To_Lower (Result);
1575                end if;
1576
1577                return Result;
1578
1579             end;
1580
1581          else
1582
1583             if Fold_To_Lower_Case then
1584                System.Case_Util.To_Lower (S1);
1585             end if;
1586
1587             return S1;
1588
1589          end if;
1590
1591       end Final_Value;
1592
1593    --  Start of processing for Normalize_Pathname
1594
1595    begin
1596       --  Special case, if name is null, then return null
1597
1598       if Name'Length = 0 then
1599          return "";
1600       end if;
1601
1602       --  First, convert VMS file spec to Unix file spec.
1603       --  If Name is not in VMS syntax, then this is equivalent
1604       --  to put Name at the begining of Path_Buffer.
1605
1606       VMS_Conversion : begin
1607          The_Name (1 .. Name'Length) := Name;
1608          The_Name (The_Name'Last) := ASCII.NUL;
1609
1610          Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1611          Canonical_File_Len  := Strlen (Canonical_File_Addr);
1612
1613          --  If VMS syntax conversion has failed, return an empty string
1614          --  to indicate the failure.
1615
1616          if Canonical_File_Len = 0 then
1617             return "";
1618          end if;
1619
1620          declare
1621             subtype Path_String is String (1 .. Canonical_File_Len);
1622             type    Path_String_Access is access Path_String;
1623
1624             function Address_To_Access is new
1625                Unchecked_Conversion (Source => Address,
1626                                      Target => Path_String_Access);
1627
1628             Path_Access : constant Path_String_Access :=
1629                             Address_To_Access (Canonical_File_Addr);
1630
1631          begin
1632             Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
1633             End_Path := Canonical_File_Len;
1634             Last := 1;
1635          end;
1636       end VMS_Conversion;
1637
1638       --  Replace all '/' by Directory Separators (this is for Windows)
1639
1640       if Directory_Separator /= '/' then
1641          for Index in 1 .. End_Path loop
1642             if Path_Buffer (Index) = '/' then
1643                Path_Buffer (Index) := Directory_Separator;
1644             end if;
1645          end loop;
1646       end if;
1647
1648       --  Resolving logical names from VMS.
1649       --  If we have a Unix path on VMS such as /temp/..., and TEMP is a
1650       --  logical name, we need to resolve this logical name.
1651       --  As we have no means to know if we are on VMS, we need to do that
1652       --  for absolute paths starting with '/'.
1653       --  We find the directory, change to it, get the current directory,
1654       --  and change the directory to this value.
1655
1656       if Path_Buffer (1) = '/' then
1657          declare
1658             Cur_Dir : String := Get_Directory ("");
1659             --  Save the current directory, so that we can change dir back to
1660             --  it. It is not a constant, because the last character (a
1661             --  directory separator) is changed to ASCII.NUL to call the C
1662             --  function chdir.
1663
1664             Path : String := Path_Buffer (1 .. End_Path + 1);
1665             --  Copy of the current path. One character is added that may be
1666             --  set to ASCII.NUL to call chdir.
1667
1668             Pos : Positive := End_Path;
1669             --  Position of the last directory separator ('/')
1670
1671             Status : Integer;
1672             --  Value returned by chdir
1673
1674          begin
1675             --  Look for the last '/'
1676
1677             while Path (Pos) /= '/' loop
1678                Pos := Pos - 1;
1679             end loop;
1680
1681             --  Get the previous character that is not a '/'
1682
1683             while Pos > 1 and then Path (Pos) = '/' loop
1684                Pos := Pos - 1;
1685             end loop;
1686
1687             --  If we are at the start of the path, take the full path.
1688             --  It may be a file in the root directory, but it may also be
1689             --  a subdirectory of the root directory.
1690
1691             if Pos = 1 then
1692                Pos := End_Path;
1693             end if;
1694
1695             --  Add the ASCII.NUL to be able to call the C function chdir
1696             Path (Pos + 1) := ASCII.NUL;
1697
1698             Status := Change_Dir (Path (1 .. Pos + 1));
1699
1700             --  If Status is not zero, then we do nothing: this is a file
1701             --  path or it is not a valid directory path.
1702
1703             if Status = 0 then
1704                declare
1705                   New_Dir : constant String := Get_Directory ("");
1706                   --  The directory path
1707
1708                   New_Path : String (1 .. New_Dir'Length + End_Path - Pos);
1709                   --  The new complete path, that is built below
1710
1711                begin
1712                   New_Path (1 .. New_Dir'Length) := New_Dir;
1713                   New_Path (New_Dir'Length + 1 .. New_Path'Last) :=
1714                     Path_Buffer (Pos + 1 .. End_Path);
1715                   End_Path := New_Path'Length;
1716                   Path_Buffer (1 .. End_Path) := New_Path;
1717                end;
1718
1719                --  Back to where we were before
1720
1721                Cur_Dir (Cur_Dir'Last) := ASCII.NUL;
1722                Status := Change_Dir (Cur_Dir);
1723             end if;
1724          end;
1725       end if;
1726
1727       --  Start the conversions
1728
1729       --  If this is not finished after Max_Iterations, give up and
1730       --  return an empty string.
1731
1732       for J in 1 .. Max_Iterations loop
1733
1734          --  If we don't have an absolute pathname, prepend
1735          --  the directory Reference_Dir.
1736
1737          if Last = 1
1738            and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
1739          then
1740             Path_Buffer
1741               (Reference_Dir'Last + 1 .. Reference_Dir'Length + End_Path) :=
1742                  Path_Buffer (1 .. End_Path);
1743             End_Path := Reference_Dir'Length + End_Path;
1744             Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir;
1745             Last := Reference_Dir'Length;
1746          end if;
1747
1748          --  If name starts with "//", we may have a drive letter on Interix
1749
1750          if Last = 1 and then End_Path >= 3 then
1751             Need_To_Check_Drive_Letter := (Path_Buffer (1 .. 2)) = "//";
1752          end if;
1753
1754          Start  := Last + 1;
1755          Finish := Last;
1756
1757          --  Ensure that Windows network drives are kept, e.g: \\server\drive-c
1758
1759          if Start = 2
1760            and then Directory_Separator = '\'
1761            and then Path_Buffer (1 .. 2) = "\\"
1762          then
1763             Start := 3;
1764          end if;
1765
1766          --  If we have traversed the full pathname, return it
1767
1768          if Start > End_Path then
1769             return Final_Value (Path_Buffer (1 .. End_Path));
1770          end if;
1771
1772          --  Remove duplicate directory separators
1773
1774          while Path_Buffer (Start) = Directory_Separator loop
1775             if Start = End_Path then
1776                return Final_Value (Path_Buffer (1 .. End_Path - 1));
1777
1778             else
1779                Path_Buffer (Start .. End_Path - 1) :=
1780                  Path_Buffer (Start + 1 .. End_Path);
1781                End_Path := End_Path - 1;
1782             end if;
1783          end loop;
1784
1785          --  Find the end of the current field: last character
1786          --  or the one preceding the next directory separator.
1787
1788          while Finish < End_Path
1789            and then Path_Buffer (Finish + 1) /= Directory_Separator
1790          loop
1791             Finish := Finish + 1;
1792          end loop;
1793
1794          --  Remove "." field
1795
1796          if Start = Finish and then Path_Buffer (Start) = '.' then
1797             if Start = End_Path then
1798                if Last = 1 then
1799                   return (1 => Directory_Separator);
1800                else
1801
1802                   if Fold_To_Lower_Case then
1803                      System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
1804                   end if;
1805
1806                   return Path_Buffer (1 .. Last - 1);
1807
1808                end if;
1809
1810             else
1811                Path_Buffer (Last + 1 .. End_Path - 2) :=
1812                  Path_Buffer (Last + 3 .. End_Path);
1813                End_Path := End_Path - 2;
1814             end if;
1815
1816          --  Remove ".." fields
1817
1818          elsif Finish = Start + 1
1819            and then Path_Buffer (Start .. Finish) = ".."
1820          then
1821             Start := Last;
1822             loop
1823                Start := Start - 1;
1824                exit when Start < 1 or else
1825                  Path_Buffer (Start) = Directory_Separator;
1826             end loop;
1827
1828             if Start <= 1 then
1829                if Finish = End_Path then
1830                   return (1 => Directory_Separator);
1831
1832                else
1833                   Path_Buffer (1 .. End_Path - Finish) :=
1834                     Path_Buffer (Finish + 1 .. End_Path);
1835                   End_Path := End_Path - Finish;
1836                   Last := 1;
1837                end if;
1838
1839             else
1840                if Finish = End_Path then
1841                   return Final_Value (Path_Buffer (1 .. Start - 1));
1842
1843                else
1844                   Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
1845                     Path_Buffer (Finish + 2 .. End_Path);
1846                   End_Path := Start + End_Path - Finish - 1;
1847                   Last := Start;
1848                end if;
1849             end if;
1850
1851          --  Check if current field is a symbolic link
1852
1853          elsif Resolve_Links then
1854             declare
1855                Saved : constant Character := Path_Buffer (Finish + 1);
1856
1857             begin
1858                Path_Buffer (Finish + 1) := ASCII.NUL;
1859                Status := Readlink (Path_Buffer'Address,
1860                                    Link_Buffer'Address,
1861                                    Link_Buffer'Length);
1862                Path_Buffer (Finish + 1) := Saved;
1863             end;
1864
1865             --  Not a symbolic link, move to the next field, if any
1866
1867             if Status <= 0 then
1868                Last := Finish + 1;
1869
1870             --  Replace symbolic link with its value.
1871
1872             else
1873                if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
1874                   Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
1875                   Path_Buffer (Finish + 1 .. End_Path);
1876                   End_Path := End_Path - (Finish - Status);
1877                   Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
1878                   Last := 1;
1879
1880                else
1881                   Path_Buffer
1882                     (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
1883                     Path_Buffer (Finish + 1 .. End_Path);
1884                   End_Path := End_Path - Finish + Last + Status;
1885                   Path_Buffer (Last + 1 .. Last + Status) :=
1886                     Link_Buffer (1 .. Status);
1887                end if;
1888             end if;
1889
1890          else
1891             Last := Finish + 1;
1892          end if;
1893       end loop;
1894
1895       --  Too many iterations: give up
1896
1897       --  This can happen when there is a circularity in the symbolic links:
1898       --  A is a symbolic link for B, which itself is a symbolic link, and
1899       --  the target of B or of another symbolic link target of B is A.
1900       --  In this case, we return an empty string to indicate failure to
1901       --  resolve.
1902
1903       return "";
1904    end Normalize_Pathname;
1905
1906    ---------------
1907    -- Open_Read --
1908    ---------------
1909
1910    function Open_Read
1911      (Name  : C_File_Name;
1912       Fmode : Mode) return File_Descriptor
1913    is
1914       function C_Open_Read
1915         (Name  : C_File_Name;
1916          Fmode : Mode) return File_Descriptor;
1917       pragma Import (C, C_Open_Read, "__gnat_open_read");
1918
1919    begin
1920       return C_Open_Read (Name, Fmode);
1921    end Open_Read;
1922
1923    function Open_Read
1924      (Name  : String;
1925       Fmode : Mode) return File_Descriptor
1926    is
1927       C_Name : String (1 .. Name'Length + 1);
1928
1929    begin
1930       C_Name (1 .. Name'Length) := Name;
1931       C_Name (C_Name'Last)      := ASCII.NUL;
1932       return Open_Read (C_Name (C_Name'First)'Address, Fmode);
1933    end Open_Read;
1934
1935    ---------------------
1936    -- Open_Read_Write --
1937    ---------------------
1938
1939    function Open_Read_Write
1940      (Name  : C_File_Name;
1941       Fmode : Mode) return File_Descriptor
1942    is
1943       function C_Open_Read_Write
1944         (Name  : C_File_Name;
1945          Fmode : Mode) return File_Descriptor;
1946       pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
1947
1948    begin
1949       return C_Open_Read_Write (Name, Fmode);
1950    end Open_Read_Write;
1951
1952    function Open_Read_Write
1953      (Name  : String;
1954       Fmode : Mode) return File_Descriptor
1955    is
1956       C_Name : String (1 .. Name'Length + 1);
1957
1958    begin
1959       C_Name (1 .. Name'Length) := Name;
1960       C_Name (C_Name'Last)      := ASCII.NUL;
1961       return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
1962    end Open_Read_Write;
1963
1964    ----------
1965    -- Read --
1966    ----------
1967
1968    function Read
1969      (FD   : File_Descriptor;
1970       A    : System.Address;
1971       N    : Integer) return Integer
1972    is
1973    begin
1974       return Integer (System.CRTL.read
1975         (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
1976    end Read;
1977
1978    -----------------
1979    -- Rename_File --
1980    -----------------
1981
1982    procedure Rename_File
1983      (Old_Name : C_File_Name;
1984       New_Name : C_File_Name;
1985       Success  : out Boolean)
1986    is
1987       function rename (From, To : Address) return Integer;
1988       pragma Import (C, rename, "rename");
1989
1990       R : Integer;
1991
1992    begin
1993       R := rename (Old_Name, New_Name);
1994       Success := (R = 0);
1995    end Rename_File;
1996
1997    procedure Rename_File
1998      (Old_Name : String;
1999       New_Name : String;
2000       Success  : out Boolean)
2001    is
2002       C_Old_Name : String (1 .. Old_Name'Length + 1);
2003       C_New_Name : String (1 .. New_Name'Length + 1);
2004
2005    begin
2006       C_Old_Name (1 .. Old_Name'Length) := Old_Name;
2007       C_Old_Name (C_Old_Name'Last)      := ASCII.NUL;
2008
2009       C_New_Name (1 .. New_Name'Length) := New_Name;
2010       C_New_Name (C_New_Name'Last)      := ASCII.NUL;
2011
2012       Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
2013    end Rename_File;
2014
2015    ------------
2016    -- Setenv --
2017    ------------
2018
2019    procedure Setenv (Name : String; Value : String) is
2020       F_Name  : String (1 .. Name'Length + 1);
2021       F_Value : String (1 .. Value'Length + 1);
2022
2023       procedure Set_Env_Value (Name, Value : System.Address);
2024       pragma Import (C, Set_Env_Value, "__gnat_set_env_value");
2025
2026    begin
2027       F_Name (1 .. Name'Length) := Name;
2028       F_Name (F_Name'Last)      := ASCII.NUL;
2029
2030       F_Value (1 .. Value'Length) := Value;
2031       F_Value (F_Value'Last)      := ASCII.NUL;
2032
2033       Set_Env_Value (F_Name'Address, F_Value'Address);
2034    end Setenv;
2035
2036    -----------
2037    -- Spawn --
2038    -----------
2039
2040    function Spawn
2041      (Program_Name : String;
2042       Args         : Argument_List) return Integer
2043    is
2044       Junk   : Process_Id;
2045       Result : Integer;
2046
2047    begin
2048       Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
2049       return Result;
2050    end Spawn;
2051
2052    procedure Spawn
2053      (Program_Name : String;
2054       Args         : Argument_List;
2055       Success      : out Boolean)
2056    is
2057    begin
2058       Success := (Spawn (Program_Name, Args) = 0);
2059    end Spawn;
2060
2061    --------------------
2062    -- Spawn_Internal --
2063    --------------------
2064
2065    procedure Spawn_Internal
2066      (Program_Name : String;
2067       Args         : Argument_List;
2068       Result       : out Integer;
2069       Pid          : out Process_Id;
2070       Blocking     : Boolean)
2071    is
2072
2073       procedure Spawn (Args : Argument_List);
2074       --  Call Spawn.
2075
2076       N_Args : Argument_List (Args'Range);
2077       --  Normalized arguments
2078
2079       -----------
2080       -- Spawn --
2081       -----------
2082
2083       procedure Spawn (Args : Argument_List) is
2084          type Chars is array (Positive range <>) of aliased Character;
2085          type Char_Ptr is access constant Character;
2086
2087          Command_Len : constant Positive := Program_Name'Length + 1
2088                                               + Args_Length (Args);
2089          Command_Last : Natural := 0;
2090          Command : aliased Chars (1 .. Command_Len);
2091          --  Command contains all characters of the Program_Name and Args,
2092          --  all terminated by ASCII.NUL characters
2093
2094          Arg_List_Len : constant Positive := Args'Length + 2;
2095          Arg_List_Last : Natural := 0;
2096          Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
2097          --  List with pointers to NUL-terminated strings of the
2098          --  Program_Name and the Args and terminated with a null pointer.
2099          --  We rely on the default initialization for the last null pointer.
2100
2101          procedure Add_To_Command (S : String);
2102          --  Add S and a NUL character to Command, updating Last
2103
2104          function Portable_Spawn (Args : Address) return Integer;
2105          pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
2106
2107          function Portable_No_Block_Spawn (Args : Address) return Process_Id;
2108          pragma Import
2109            (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
2110
2111          --------------------
2112          -- Add_To_Command --
2113          --------------------
2114
2115          procedure Add_To_Command (S : String) is
2116             First : constant Natural := Command_Last + 1;
2117
2118          begin
2119             Command_Last := Command_Last + S'Length;
2120
2121             --  Move characters one at a time, because Command has
2122             --  aliased components.
2123
2124             for J in S'Range loop
2125                Command (First + J - S'First) := S (J);
2126             end loop;
2127
2128             Command_Last := Command_Last + 1;
2129             Command (Command_Last) := ASCII.NUL;
2130
2131             Arg_List_Last := Arg_List_Last + 1;
2132             Arg_List (Arg_List_Last) := Command (First)'Access;
2133          end Add_To_Command;
2134
2135       --  Start of processing for Spawn
2136
2137       begin
2138          Add_To_Command (Program_Name);
2139
2140          for J in Args'Range loop
2141             Add_To_Command (Args (J).all);
2142          end loop;
2143
2144          if Blocking then
2145             Pid     := Invalid_Pid;
2146             Result  := Portable_Spawn (Arg_List'Address);
2147          else
2148             Pid     := Portable_No_Block_Spawn (Arg_List'Address);
2149             Result  := Boolean'Pos (Pid /= Invalid_Pid);
2150          end if;
2151       end Spawn;
2152
2153    --  Start of processing for Spawn_Internal
2154
2155    begin
2156       --  Copy arguments into a local structure
2157
2158       for K in N_Args'Range loop
2159          N_Args (K) := new String'(Args (K).all);
2160       end loop;
2161
2162       --  Normalize those arguments
2163
2164       Normalize_Arguments (N_Args);
2165
2166       --  Call spawn using the normalized arguments
2167
2168       Spawn (N_Args);
2169
2170       --  Free arguments list
2171
2172       for K in N_Args'Range loop
2173          Free (N_Args (K));
2174       end loop;
2175    end Spawn_Internal;
2176
2177    ---------------------------
2178    -- To_Path_String_Access --
2179    ---------------------------
2180
2181    function To_Path_String_Access
2182      (Path_Addr : Address;
2183       Path_Len  : Integer) return String_Access
2184    is
2185       subtype Path_String is String (1 .. Path_Len);
2186       type    Path_String_Access is access Path_String;
2187
2188       function Address_To_Access is new
2189         Unchecked_Conversion (Source => Address,
2190                               Target => Path_String_Access);
2191
2192       Path_Access : constant Path_String_Access :=
2193                       Address_To_Access (Path_Addr);
2194
2195       Return_Val  : String_Access;
2196
2197    begin
2198       Return_Val := new String (1 .. Path_Len);
2199
2200       for J in 1 .. Path_Len loop
2201          Return_Val (J) := Path_Access (J);
2202       end loop;
2203
2204       return Return_Val;
2205    end To_Path_String_Access;
2206
2207    ------------------
2208    -- Wait_Process --
2209    ------------------
2210
2211    procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
2212       Status : Integer;
2213
2214       function Portable_Wait (S : Address) return Process_Id;
2215       pragma Import (C, Portable_Wait, "__gnat_portable_wait");
2216
2217    begin
2218       Pid := Portable_Wait (Status'Address);
2219       Success := (Status = 0);
2220    end Wait_Process;
2221
2222    -----------
2223    -- Write --
2224    -----------
2225
2226    function Write
2227      (FD   : File_Descriptor;
2228       A    : System.Address;
2229       N    : Integer) return Integer
2230    is
2231    begin
2232       return Integer (System.CRTL.write
2233         (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
2234    end Write;
2235
2236 end GNAT.OS_Lib;