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