gcc/ada/s-os_lib.adb

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