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-2007, 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 catenated 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          To   := Create_File (To_Name, Binary);
 456          Copy (From, To);
 457
 458          --  Copy attributes
 459
 460          C_From (1 .. Name'Length) := Name;
 461          C_From (C_From'Last) := ASCII.Nul;
 462
 463          C_To (1 .. To_Name'Length) := To_Name;
 464          C_To (C_To'Last) := ASCII.Nul;
 465
 466          case Preserve is
 467
 468             when Time_Stamps =>
 469                if Copy_Attributes (C_From'Address, C_To'Address, 0) = -1 then
 470                   raise Copy_Error;
 471                end if;
 472
 473             when Full =>
 474                if Copy_Attributes (C_From'Address, C_To'Address, 1) = -1 then
 475                   raise Copy_Error;
 476                end if;
 477
 478             when None =>
 479                null;
 480          end case;
 481
 482       end Copy_To;
 483
 484    --  Start of processing for Copy_File
 485
 486    begin
 487       Success := True;
 488
 489       --  The source file must exist
 490
 491       if not Is_Regular_File (Name) then
 492          raise Copy_Error;
 493       end if;
 494
 495       --  The source file exists
 496
 497       case Mode is
 498
 499          --  Copy case, target file must not exist
 500
 501          when Copy =>
 502
 503             --  If the target file exists, we have an error
 504
 505             if Is_Regular_File (Pathname) then
 506                raise Copy_Error;
 507
 508             --  Case of target is a directory
 509
 510             elsif Is_Directory (Pathname) then
 511                declare
 512                   Dest : constant String := Build_Path (Pathname, Name);
 513
 514                begin
 515                   --  If target file exists, we have an error, else do copy
 516
 517                   if Is_Regular_File (Dest) then
 518                      raise Copy_Error;
 519                   else
 520                      Copy_To (Dest);
 521                   end if;
 522                end;
 523
 524             --  Case of normal copy to file (destination does not exist)
 525
 526             else
 527                Copy_To (Pathname);
 528             end if;
 529
 530          --  Overwrite case (destination file may or may not exist)
 531
 532          when Overwrite =>
 533             if Is_Directory (Pathname) then
 534                Copy_To (Build_Path (Pathname, Name));
 535             else
 536                Copy_To (Pathname);
 537             end if;
 538
 539          --  Append case (destination file may or may not exist)
 540
 541          when Append =>
 542
 543             --  Appending to existing file
 544
 545             if Is_Regular_File (Pathname) then
 546
 547                --  Append mode and destination file exists, append data at the
 548                --  end of Pathname.
 549
 550                From := Open_Read (Name, Binary);
 551                To   := Open_Read_Write (Pathname, Binary);
 552                Lseek (To, 0, Seek_End);
 553
 554                Copy (From, To);
 555
 556             --  Appending to directory, not allowed
 557
 558             elsif Is_Directory (Pathname) then
 559                raise Copy_Error;
 560
 561             --  Appending when target file does not exist
 562
 563             else
 564                Copy_To (Pathname);
 565             end if;
 566       end case;
 567
 568    --  All error cases are caught here
 569
 570    exception
 571       when Copy_Error =>
 572          Success := False;
 573    end Copy_File;
 574
 575    procedure Copy_File
 576      (Name     : C_File_Name;
 577       Pathname : C_File_Name;
 578       Success  : out Boolean;
 579       Mode     : Copy_Mode := Copy;
 580       Preserve : Attribute := Time_Stamps)
 581    is
 582       Ada_Name : String_Access :=
 583                    To_Path_String_Access
 584                      (Name, C_String_Length (Name));
 585
 586       Ada_Pathname : String_Access :=
 587                        To_Path_String_Access
 588                          (Pathname, C_String_Length (Pathname));
 589
 590    begin
 591       Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve);
 592       Free (Ada_Name);
 593       Free (Ada_Pathname);
 594    end Copy_File;
 595
 596    ----------------------
 597    -- Copy_Time_Stamps --
 598    ----------------------
 599
 600    procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean) is
 601
 602       function Copy_Attributes
 603         (From, To : System.Address;
 604          Mode     : Integer) return Integer;
 605       pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
 606       --  Mode = 0 - copy only time stamps.
 607       --  Mode = 1 - copy time stamps and read/write/execute attributes
 608
 609    begin
 610       if Is_Regular_File (Source) and then Is_Writable_File (Dest) then
 611          declare
 612             C_Source : String (1 .. Source'Length + 1);
 613             C_Dest   : String (1 .. Dest'Length + 1);
 614          begin
 615             C_Source (1 .. Source'Length) := Source;
 616             C_Source (C_Source'Last)      := ASCII.NUL;
 617
 618             C_Dest (1 .. Dest'Length) := Dest;
 619             C_Dest (C_Dest'Last)      := ASCII.NUL;
 620
 621             if Copy_Attributes (C_Source'Address, C_Dest'Address, 0) = -1 then
 622                Success := False;
 623             else
 624                Success := True;
 625             end if;
 626          end;
 627
 628       else
 629          Success := False;
 630       end if;
 631    end Copy_Time_Stamps;
 632
 633    procedure Copy_Time_Stamps
 634      (Source, Dest : C_File_Name;
 635       Success      : out Boolean)
 636    is
 637       Ada_Source : String_Access :=
 638                      To_Path_String_Access
 639                        (Source, C_String_Length (Source));
 640
 641       Ada_Dest : String_Access :=
 642                    To_Path_String_Access
 643                      (Dest, C_String_Length (Dest));
 644    begin
 645       Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success);
 646       Free (Ada_Source);
 647       Free (Ada_Dest);
 648    end Copy_Time_Stamps;
 649
 650    -----------------
 651    -- Create_File --
 652    -----------------
 653
 654    function Create_File
 655      (Name  : C_File_Name;
 656       Fmode : Mode) return File_Descriptor
 657    is
 658       function C_Create_File
 659         (Name  : C_File_Name;
 660          Fmode : Mode) return File_Descriptor;
 661       pragma Import (C, C_Create_File, "__gnat_open_create");
 662
 663    begin
 664       return C_Create_File (Name, Fmode);
 665    end Create_File;
 666
 667    function Create_File
 668      (Name  : String;
 669       Fmode : Mode) return File_Descriptor
 670    is
 671       C_Name : String (1 .. Name'Length + 1);
 672
 673    begin
 674       C_Name (1 .. Name'Length) := Name;
 675       C_Name (C_Name'Last)      := ASCII.NUL;
 676       return Create_File (C_Name (C_Name'First)'Address, Fmode);
 677    end Create_File;
 678
 679    ---------------------
 680    -- Create_New_File --
 681    ---------------------
 682
 683    function Create_New_File
 684      (Name  : C_File_Name;
 685       Fmode : Mode) return File_Descriptor
 686    is
 687       function C_Create_New_File
 688         (Name  : C_File_Name;
 689          Fmode : Mode) return File_Descriptor;
 690       pragma Import (C, C_Create_New_File, "__gnat_open_new");
 691
 692    begin
 693       return C_Create_New_File (Name, Fmode);
 694    end Create_New_File;
 695
 696    function Create_New_File
 697      (Name  : String;
 698       Fmode : Mode) return File_Descriptor
 699    is
 700       C_Name : String (1 .. Name'Length + 1);
 701
 702    begin
 703       C_Name (1 .. Name'Length) := Name;
 704       C_Name (C_Name'Last)      := ASCII.NUL;
 705       return Create_New_File (C_Name (C_Name'First)'Address, Fmode);
 706    end Create_New_File;
 707
 708    -----------------------------
 709    -- Create_Output_Text_File --
 710    -----------------------------
 711
 712    function Create_Output_Text_File (Name : String) return File_Descriptor is
 713       function C_Create_File
 714         (Name : C_File_Name) return File_Descriptor;
 715       pragma Import (C, C_Create_File, "__gnat_create_output_file");
 716
 717       C_Name : String (1 .. Name'Length + 1);
 718
 719    begin
 720       C_Name (1 .. Name'Length) := Name;
 721       C_Name (C_Name'Last)      := ASCII.NUL;
 722       return C_Create_File (C_Name (C_Name'First)'Address);
 723    end Create_Output_Text_File;
 724
 725    ----------------------
 726    -- Create_Temp_File --
 727    ----------------------
 728
 729    procedure Create_Temp_File
 730      (FD   : out File_Descriptor;
 731       Name : out Temp_File_Name)
 732    is
 733       function Open_New_Temp
 734         (Name  : System.Address;
 735          Fmode : Mode) return File_Descriptor;
 736       pragma Import (C, Open_New_Temp, "__gnat_open_new_temp");
 737
 738    begin
 739       FD := Open_New_Temp (Name'Address, Binary);
 740    end Create_Temp_File;
 741
 742    procedure Create_Temp_File
 743      (FD   : out File_Descriptor;
 744       Name : out String_Access)
 745    is
 746       Pos      : Positive;
 747       Attempts : Natural := 0;
 748       Current  : String (Current_Temp_File_Name'Range);
 749
 750    begin
 751       --  Loop until a new temp file can be created
 752
 753       File_Loop : loop
 754          Locked : begin
 755             --  We need to protect global variable Current_Temp_File_Name
 756             --  against concurrent access by different tasks.
 757
 758             SSL.Lock_Task.all;
 759
 760             --  Start at the last digit
 761
 762             Pos := Temp_File_Name_Last_Digit;
 763
 764             Digit_Loop :
 765             loop
 766                --  Increment the digit by one
 767
 768                case Current_Temp_File_Name (Pos) is
 769                   when '0' .. '8' =>
 770                      Current_Temp_File_Name (Pos) :=
 771                        Character'Succ (Current_Temp_File_Name (Pos));
 772                      exit Digit_Loop;
 773
 774                   when '9' =>
 775
 776                      --  For 9, set the digit to 0 and go to the previous digit
 777
 778                      Current_Temp_File_Name (Pos) := '0';
 779                      Pos := Pos - 1;
 780
 781                   when others =>
 782
 783                      --  If it is not a digit, then there are no available
 784                      --  temp file names. Return Invalid_FD. There is almost
 785                      --  no that this code will be ever be executed, since
 786                      --  it would mean that there are one million temp files
 787                      --  in the same directory!
 788
 789                      SSL.Unlock_Task.all;
 790                      FD := Invalid_FD;
 791                      Name := null;
 792                      exit File_Loop;
 793                end case;
 794             end loop Digit_Loop;
 795
 796             Current := Current_Temp_File_Name;
 797
 798             --  We can now release the lock, because we are no longer
 799             --  accessing Current_Temp_File_Name.
 800
 801             SSL.Unlock_Task.all;
 802
 803          exception
 804             when others =>
 805                SSL.Unlock_Task.all;
 806                raise;
 807          end Locked;
 808
 809          --  Attempt to create the file
 810
 811          FD := Create_New_File (Current, Binary);
 812
 813          if FD /= Invalid_FD then
 814             Name := new String'(Current);
 815             exit File_Loop;
 816          end if;
 817
 818          if not Is_Regular_File (Current) then
 819
 820             --  If the file does not already exist and we are unable to create
 821             --  it, we give up after Max_Attempts. Otherwise, we try again with
 822             --  the next available file name.
 823
 824             Attempts := Attempts + 1;
 825
 826             if Attempts >= Max_Attempts then
 827                FD := Invalid_FD;
 828                Name := null;
 829                exit File_Loop;
 830             end if;
 831          end if;
 832       end loop File_Loop;
 833    end Create_Temp_File;
 834
 835    -----------------
 836    -- Delete_File --
 837    -----------------
 838
 839    procedure Delete_File (Name : Address; Success : out Boolean) is
 840       R : Integer;
 841
 842       function unlink (A : Address) return Integer;
 843       pragma Import (C, unlink, "unlink");
 844
 845    begin
 846       R := unlink (Name);
 847       Success := (R = 0);
 848    end Delete_File;
 849
 850    procedure Delete_File (Name : String; Success : out Boolean) is
 851       C_Name : String (1 .. Name'Length + 1);
 852
 853    begin
 854       C_Name (1 .. Name'Length) := Name;
 855       C_Name (C_Name'Last)      := ASCII.NUL;
 856
 857       Delete_File (C_Name'Address, Success);
 858    end Delete_File;
 859
 860    ---------------------
 861    -- File_Time_Stamp --
 862    ---------------------
 863
 864    function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
 865       function File_Time (FD    : File_Descriptor) return OS_Time;
 866       pragma Import (C, File_Time, "__gnat_file_time_fd");
 867    begin
 868       return File_Time (FD);
 869    end File_Time_Stamp;
 870
 871    function File_Time_Stamp (Name : C_File_Name) return OS_Time is
 872       function File_Time (Name : Address) return OS_Time;
 873       pragma Import (C, File_Time, "__gnat_file_time_name");
 874    begin
 875       return File_Time (Name);
 876    end File_Time_Stamp;
 877
 878    function File_Time_Stamp (Name : String) return OS_Time is
 879       F_Name : String (1 .. Name'Length + 1);
 880    begin
 881       F_Name (1 .. Name'Length) := Name;
 882       F_Name (F_Name'Last)      := ASCII.NUL;
 883       return File_Time_Stamp (F_Name'Address);
 884    end File_Time_Stamp;
 885
 886    ---------------------------
 887    -- Get_Debuggable_Suffix --
 888    ---------------------------
 889
 890    function Get_Debuggable_Suffix return String_Access is
 891       procedure Get_Suffix_Ptr (Length, Ptr : Address);
 892       pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
 893
 894       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
 895       pragma Import (C, Strncpy, "strncpy");
 896
 897       Suffix_Ptr    : Address;
 898       Suffix_Length : Integer;
 899       Result        : String_Access;
 900
 901    begin
 902       Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
 903
 904       Result := new String (1 .. Suffix_Length);
 905
 906       if Suffix_Length > 0 then
 907          Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
 908       end if;
 909
 910       return Result;
 911    end Get_Debuggable_Suffix;
 912
 913    ---------------------------
 914    -- Get_Executable_Suffix --
 915    ---------------------------
 916
 917    function Get_Executable_Suffix return String_Access is
 918       procedure Get_Suffix_Ptr (Length, Ptr : Address);
 919       pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
 920
 921       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
 922       pragma Import (C, Strncpy, "strncpy");
 923
 924       Suffix_Ptr    : Address;
 925       Suffix_Length : Integer;
 926       Result        : String_Access;
 927
 928    begin
 929       Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
 930
 931       Result := new String (1 .. Suffix_Length);
 932
 933       if Suffix_Length > 0 then
 934          Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
 935       end if;
 936
 937       return Result;
 938    end Get_Executable_Suffix;
 939
 940    -----------------------
 941    -- Get_Object_Suffix --
 942    -----------------------
 943
 944    function Get_Object_Suffix return String_Access is
 945       procedure Get_Suffix_Ptr (Length, Ptr : Address);
 946       pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_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_Object_Suffix;
 966
 967    ----------------------------------
 968    -- Get_Target_Debuggable_Suffix --
 969    ----------------------------------
 970
 971    function Get_Target_Debuggable_Suffix return String_Access is
 972       Target_Exec_Ext_Ptr : Address;
 973       pragma Import
 974         (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_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_Debuggable_Suffix;
 996
 997    ----------------------------------
 998    -- Get_Target_Executable_Suffix --
 999    ----------------------------------
1000
1001    function Get_Target_Executable_Suffix return String_Access is
1002       Target_Exec_Ext_Ptr : Address;
1003       pragma Import
1004         (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension");
1005
1006       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1007       pragma Import (C, Strncpy, "strncpy");
1008
1009       function Strlen (Cstring : Address) return Integer;
1010       pragma Import (C, Strlen, "strlen");
1011
1012       Suffix_Length : Integer;
1013       Result        : String_Access;
1014
1015    begin
1016       Suffix_Length := Strlen (Target_Exec_Ext_Ptr);
1017
1018       Result := new String (1 .. Suffix_Length);
1019
1020       if Suffix_Length > 0 then
1021          Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length);
1022       end if;
1023
1024       return Result;
1025    end Get_Target_Executable_Suffix;
1026
1027    ------------------------------
1028    -- Get_Target_Object_Suffix --
1029    ------------------------------
1030
1031    function Get_Target_Object_Suffix return String_Access is
1032       Target_Object_Ext_Ptr : Address;
1033       pragma Import
1034         (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension");
1035
1036       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1037       pragma Import (C, Strncpy, "strncpy");
1038
1039       function Strlen (Cstring : Address) return Integer;
1040       pragma Import (C, Strlen, "strlen");
1041
1042       Suffix_Length : Integer;
1043       Result        : String_Access;
1044
1045    begin
1046       Suffix_Length := Strlen (Target_Object_Ext_Ptr);
1047
1048       Result := new String (1 .. Suffix_Length);
1049
1050       if Suffix_Length > 0 then
1051          Strncpy (Result.all'Address, Target_Object_Ext_Ptr, Suffix_Length);
1052       end if;
1053
1054       return Result;
1055    end Get_Target_Object_Suffix;
1056
1057    ------------
1058    -- Getenv --
1059    ------------
1060
1061    function Getenv (Name : String) return String_Access is
1062       procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
1063       pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
1064
1065       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1066       pragma Import (C, Strncpy, "strncpy");
1067
1068       Env_Value_Ptr    : aliased Address;
1069       Env_Value_Length : aliased Integer;
1070       F_Name           : aliased String (1 .. Name'Length + 1);
1071       Result           : String_Access;
1072
1073    begin
1074       F_Name (1 .. Name'Length) := Name;
1075       F_Name (F_Name'Last)      := ASCII.NUL;
1076
1077       Get_Env_Value_Ptr
1078         (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
1079
1080       Result := new String (1 .. Env_Value_Length);
1081
1082       if Env_Value_Length > 0 then
1083          Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
1084       end if;
1085
1086       return Result;
1087    end Getenv;
1088
1089    ------------
1090    -- GM_Day --
1091    ------------
1092
1093    function GM_Day (Date : OS_Time) return Day_Type is
1094       Y  : Year_Type;
1095       Mo : Month_Type;
1096       D  : Day_Type;
1097       H  : Hour_Type;
1098       Mn : Minute_Type;
1099       S  : Second_Type;
1100
1101    begin
1102       GM_Split (Date, Y, Mo, D, H, Mn, S);
1103       return D;
1104    end GM_Day;
1105
1106    -------------
1107    -- GM_Hour --
1108    -------------
1109
1110    function GM_Hour (Date : OS_Time) return Hour_Type is
1111       Y  : Year_Type;
1112       Mo : Month_Type;
1113       D  : Day_Type;
1114       H  : Hour_Type;
1115       Mn : Minute_Type;
1116       S  : Second_Type;
1117
1118    begin
1119       GM_Split (Date, Y, Mo, D, H, Mn, S);
1120       return H;
1121    end GM_Hour;
1122
1123    ---------------
1124    -- GM_Minute --
1125    ---------------
1126
1127    function GM_Minute (Date : OS_Time) return Minute_Type is
1128       Y  : Year_Type;
1129       Mo : Month_Type;
1130       D  : Day_Type;
1131       H  : Hour_Type;
1132       Mn : Minute_Type;
1133       S  : Second_Type;
1134
1135    begin
1136       GM_Split (Date, Y, Mo, D, H, Mn, S);
1137       return Mn;
1138    end GM_Minute;
1139
1140    --------------
1141    -- GM_Month --
1142    --------------
1143
1144    function GM_Month (Date : OS_Time) return Month_Type is
1145       Y  : Year_Type;
1146       Mo : Month_Type;
1147       D  : Day_Type;
1148       H  : Hour_Type;
1149       Mn : Minute_Type;
1150       S  : Second_Type;
1151
1152    begin
1153       GM_Split (Date, Y, Mo, D, H, Mn, S);
1154       return Mo;
1155    end GM_Month;
1156
1157    ---------------
1158    -- GM_Second --
1159    ---------------
1160
1161    function GM_Second (Date : OS_Time) return Second_Type is
1162       Y  : Year_Type;
1163       Mo : Month_Type;
1164       D  : Day_Type;
1165       H  : Hour_Type;
1166       Mn : Minute_Type;
1167       S  : Second_Type;
1168
1169    begin
1170       GM_Split (Date, Y, Mo, D, H, Mn, S);
1171       return S;
1172    end GM_Second;
1173
1174    --------------
1175    -- GM_Split --
1176    --------------
1177
1178    procedure GM_Split
1179      (Date   : OS_Time;
1180       Year   : out Year_Type;
1181       Month  : out Month_Type;
1182       Day    : out Day_Type;
1183       Hour   : out Hour_Type;
1184       Minute : out Minute_Type;
1185       Second : out Second_Type)
1186    is
1187       procedure To_GM_Time
1188         (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
1189       pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
1190
1191       T  : OS_Time := Date;
1192       Y  : Integer;
1193       Mo : Integer;
1194       D  : Integer;
1195       H  : Integer;
1196       Mn : Integer;
1197       S  : Integer;
1198
1199    begin
1200       --  Use the global lock because To_GM_Time is not thread safe
1201
1202       Locked_Processing : begin
1203          SSL.Lock_Task.all;
1204          To_GM_Time
1205            (T'Address, Y'Address, Mo'Address, D'Address,
1206             H'Address, Mn'Address, S'Address);
1207          SSL.Unlock_Task.all;
1208
1209       exception
1210          when others =>
1211             SSL.Unlock_Task.all;
1212             raise;
1213       end Locked_Processing;
1214
1215       Year   := Y + 1900;
1216       Month  := Mo + 1;
1217       Day    := D;
1218       Hour   := H;
1219       Minute := Mn;
1220       Second := S;
1221    end GM_Split;
1222
1223    -------------
1224    -- GM_Year --
1225    -------------
1226
1227    function GM_Year (Date : OS_Time) return Year_Type is
1228       Y  : Year_Type;
1229       Mo : Month_Type;
1230       D  : Day_Type;
1231       H  : Hour_Type;
1232       Mn : Minute_Type;
1233       S  : Second_Type;
1234
1235    begin
1236       GM_Split (Date, Y, Mo, D, H, Mn, S);
1237       return Y;
1238    end GM_Year;
1239
1240    ----------------------
1241    -- Is_Absolute_Path --
1242    ----------------------
1243
1244    function Is_Absolute_Path (Name : String) return Boolean is
1245       function Is_Absolute_Path
1246         (Name   : Address;
1247          Length : Integer) return Integer;
1248       pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
1249    begin
1250       return Is_Absolute_Path (Name'Address, Name'Length) /= 0;
1251    end Is_Absolute_Path;
1252
1253    ------------------
1254    -- Is_Directory --
1255    ------------------
1256
1257    function Is_Directory (Name : C_File_Name) return Boolean is
1258       function Is_Directory (Name : Address) return Integer;
1259       pragma Import (C, Is_Directory, "__gnat_is_directory");
1260    begin
1261       return Is_Directory (Name) /= 0;
1262    end Is_Directory;
1263
1264    function Is_Directory (Name : String) return Boolean is
1265       F_Name : String (1 .. Name'Length + 1);
1266    begin
1267       F_Name (1 .. Name'Length) := Name;
1268       F_Name (F_Name'Last)      := ASCII.NUL;
1269       return Is_Directory (F_Name'Address);
1270    end Is_Directory;
1271
1272    ----------------------
1273    -- Is_Readable_File --
1274    ----------------------
1275
1276    function Is_Readable_File (Name : C_File_Name) return Boolean is
1277       function Is_Readable_File (Name : Address) return Integer;
1278       pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
1279    begin
1280       return Is_Readable_File (Name) /= 0;
1281    end Is_Readable_File;
1282
1283    function Is_Readable_File (Name : String) return Boolean is
1284       F_Name : String (1 .. Name'Length + 1);
1285    begin
1286       F_Name (1 .. Name'Length) := Name;
1287       F_Name (F_Name'Last)      := ASCII.NUL;
1288       return Is_Readable_File (F_Name'Address);
1289    end Is_Readable_File;
1290
1291    ---------------------
1292    -- Is_Regular_File --
1293    ---------------------
1294
1295    function Is_Regular_File (Name : C_File_Name) return Boolean is
1296       function Is_Regular_File (Name : Address) return Integer;
1297       pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
1298    begin
1299       return Is_Regular_File (Name) /= 0;
1300    end Is_Regular_File;
1301
1302    function Is_Regular_File (Name : String) return Boolean is
1303       F_Name : String (1 .. Name'Length + 1);
1304    begin
1305       F_Name (1 .. Name'Length) := Name;
1306       F_Name (F_Name'Last)      := ASCII.NUL;
1307       return Is_Regular_File (F_Name'Address);
1308    end Is_Regular_File;
1309
1310    ----------------------
1311    -- Is_Symbolic_Link --
1312    ----------------------
1313
1314    function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
1315       function Is_Symbolic_Link (Name : Address) return Integer;
1316       pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
1317    begin
1318       return Is_Symbolic_Link (Name) /= 0;
1319    end Is_Symbolic_Link;
1320
1321    function Is_Symbolic_Link (Name : String) return Boolean is
1322       F_Name : String (1 .. Name'Length + 1);
1323    begin
1324       F_Name (1 .. Name'Length) := Name;
1325       F_Name (F_Name'Last)      := ASCII.NUL;
1326       return Is_Symbolic_Link (F_Name'Address);
1327    end Is_Symbolic_Link;
1328
1329    ----------------------
1330    -- Is_Writable_File --
1331    ----------------------
1332
1333    function Is_Writable_File (Name : C_File_Name) return Boolean is
1334       function Is_Writable_File (Name : Address) return Integer;
1335       pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
1336    begin
1337       return Is_Writable_File (Name) /= 0;
1338    end Is_Writable_File;
1339
1340    function Is_Writable_File (Name : String) return Boolean is
1341       F_Name : String (1 .. Name'Length + 1);
1342    begin
1343       F_Name (1 .. Name'Length) := Name;
1344       F_Name (F_Name'Last)      := ASCII.NUL;
1345       return Is_Writable_File (F_Name'Address);
1346    end Is_Writable_File;
1347
1348    -------------------------
1349    -- Locate_Exec_On_Path --
1350    -------------------------
1351
1352    function Locate_Exec_On_Path
1353      (Exec_Name : String) return String_Access
1354    is
1355       function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
1356       pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
1357
1358       procedure Free (Ptr : System.Address);
1359       pragma Import (C, Free, "free");
1360
1361       C_Exec_Name  : String (1 .. Exec_Name'Length + 1);
1362       Path_Addr    : Address;
1363       Path_Len     : Integer;
1364       Result       : String_Access;
1365
1366    begin
1367       C_Exec_Name (1 .. Exec_Name'Length)   := Exec_Name;
1368       C_Exec_Name (C_Exec_Name'Last)        := ASCII.NUL;
1369
1370       Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
1371       Path_Len  := C_String_Length (Path_Addr);
1372
1373       if Path_Len = 0 then
1374          return null;
1375
1376       else
1377          Result := To_Path_String_Access (Path_Addr, Path_Len);
1378          Free (Path_Addr);
1379
1380          --  Always return an absolute path name
1381
1382          if not Is_Absolute_Path (Result.all) then
1383             declare
1384                Absolute_Path : constant String :=
1385                                  Normalize_Pathname (Result.all);
1386             begin
1387                Free (Result);
1388                Result := new String'(Absolute_Path);
1389             end;
1390          end if;
1391
1392          return Result;
1393       end if;
1394    end Locate_Exec_On_Path;
1395
1396    -------------------------
1397    -- Locate_Regular_File --
1398    -------------------------
1399
1400    function Locate_Regular_File
1401      (File_Name : C_File_Name;
1402       Path      : C_File_Name) return String_Access
1403    is
1404       function Locate_Regular_File
1405         (C_File_Name, Path_Val : Address) return Address;
1406       pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file");
1407
1408       procedure Free (Ptr : System.Address);
1409       pragma Import (C, Free, "free");
1410
1411       Path_Addr    : Address;
1412       Path_Len     : Integer;
1413       Result       : String_Access;
1414
1415    begin
1416       Path_Addr := Locate_Regular_File (File_Name, Path);
1417       Path_Len  := C_String_Length (Path_Addr);
1418
1419       if Path_Len = 0 then
1420          return null;
1421       else
1422          Result := To_Path_String_Access (Path_Addr, Path_Len);
1423          Free (Path_Addr);
1424          return Result;
1425       end if;
1426    end Locate_Regular_File;
1427
1428    function Locate_Regular_File
1429      (File_Name : String;
1430       Path      : String) return String_Access
1431    is
1432       C_File_Name : String (1 .. File_Name'Length + 1);
1433       C_Path      : String (1 .. Path'Length + 1);
1434       Result      : String_Access;
1435
1436    begin
1437       C_File_Name (1 .. File_Name'Length)   := File_Name;
1438       C_File_Name (C_File_Name'Last)        := ASCII.NUL;
1439
1440       C_Path    (1 .. Path'Length)          := Path;
1441       C_Path    (C_Path'Last)               := ASCII.NUL;
1442
1443       Result := Locate_Regular_File (C_File_Name'Address, C_Path'Address);
1444
1445       --  Always return an absolute path name
1446
1447       if Result /= null and then not Is_Absolute_Path (Result.all) then
1448          declare
1449             Absolute_Path : constant String := Normalize_Pathname (Result.all);
1450          begin
1451             Free (Result);
1452             Result := new String'(Absolute_Path);
1453          end;
1454       end if;
1455
1456       return Result;
1457    end Locate_Regular_File;
1458
1459    ------------------------
1460    -- Non_Blocking_Spawn --
1461    ------------------------
1462
1463    function Non_Blocking_Spawn
1464      (Program_Name : String;
1465       Args         : Argument_List) return Process_Id
1466    is
1467       Junk : Integer;
1468       Pid  : Process_Id;
1469
1470    begin
1471       Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
1472       return Pid;
1473    end Non_Blocking_Spawn;
1474
1475    function Non_Blocking_Spawn
1476      (Program_Name           : String;
1477       Args                   : Argument_List;
1478       Output_File_Descriptor : File_Descriptor;
1479       Err_To_Out             : Boolean := True) return Process_Id
1480    is
1481       Saved_Output : File_Descriptor;
1482       Saved_Error  : File_Descriptor := Invalid_FD; -- prevent warning
1483       Pid          : Process_Id;
1484
1485    begin
1486       if Output_File_Descriptor = Invalid_FD then
1487          return Invalid_Pid;
1488       end if;
1489
1490       --  Set standard output and, if specified, error to the temporary file
1491
1492       Saved_Output := Dup (Standout);
1493       Dup2 (Output_File_Descriptor, Standout);
1494
1495       if Err_To_Out then
1496          Saved_Error  := Dup (Standerr);
1497          Dup2 (Output_File_Descriptor, Standerr);
1498       end if;
1499
1500       --  Spawn the program
1501
1502       Pid := Non_Blocking_Spawn (Program_Name, Args);
1503
1504       --  Restore the standard output and error
1505
1506       Dup2 (Saved_Output, Standout);
1507
1508       if Err_To_Out then
1509          Dup2 (Saved_Error, Standerr);
1510       end if;
1511
1512       --  And close the saved standard output and error file descriptors
1513
1514       Close (Saved_Output);
1515
1516       if Err_To_Out then
1517          Close (Saved_Error);
1518       end if;
1519
1520       return Pid;
1521    end Non_Blocking_Spawn;
1522
1523    function Non_Blocking_Spawn
1524      (Program_Name : String;
1525       Args         : Argument_List;
1526       Output_File  : String;
1527       Err_To_Out   : Boolean := True) return Process_Id
1528    is
1529       Output_File_Descriptor : constant File_Descriptor :=
1530                                  Create_Output_Text_File (Output_File);
1531       Result : Process_Id;
1532
1533    begin
1534       --  Do not attempt to spawn if the output file could not be created
1535
1536       if Output_File_Descriptor = Invalid_FD then
1537          return Invalid_Pid;
1538
1539       else
1540          Result := Non_Blocking_Spawn
1541                      (Program_Name, Args, Output_File_Descriptor, Err_To_Out);
1542
1543          --  Close the file just created for the output, as the file descriptor
1544          --  cannot be used anywhere, being a local value. It is safe to do
1545          --  that, as the file descriptor has been duplicated to form
1546          --  standard output and error of the spawned process.
1547
1548          Close (Output_File_Descriptor);
1549
1550          return Result;
1551       end if;
1552    end Non_Blocking_Spawn;
1553
1554    -------------------------
1555    -- Normalize_Arguments --
1556    -------------------------
1557
1558    procedure Normalize_Arguments (Args : in out Argument_List) is
1559
1560       procedure Quote_Argument (Arg : in out String_Access);
1561       --  Add quote around argument if it contains spaces
1562
1563       C_Argument_Needs_Quote : Integer;
1564       pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
1565       Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
1566
1567       --------------------
1568       -- Quote_Argument --
1569       --------------------
1570
1571       procedure Quote_Argument (Arg : in out String_Access) is
1572          Res          : String (1 .. Arg'Length * 2);
1573          J            : Positive := 1;
1574          Quote_Needed : Boolean  := False;
1575
1576       begin
1577          if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
1578
1579             --  Starting quote
1580
1581             Res (J) := '"';
1582
1583             for K in Arg'Range loop
1584
1585                J := J + 1;
1586
1587                if Arg (K) = '"' then
1588                   Res (J) := '\';
1589                   J := J + 1;
1590                   Res (J) := '"';
1591                   Quote_Needed := True;
1592
1593                elsif Arg (K) = ' ' then
1594                   Res (J) := Arg (K);
1595                   Quote_Needed := True;
1596
1597                else
1598                   Res (J) := Arg (K);
1599                end if;
1600
1601             end loop;
1602
1603             if Quote_Needed then
1604
1605                --  If null terminated string, put the quote before
1606
1607                if Res (J) = ASCII.Nul then
1608                   Res (J) := '"';
1609                   J := J + 1;
1610                   Res (J) := ASCII.Nul;
1611
1612                --  If argument is terminated by '\', then double it. Otherwise
1613                --  the ending quote will be taken as-is. This is quite strange
1614                --  spawn behavior from Windows, but this is what we see!
1615
1616                else
1617                   if Res (J) = '\' then
1618                      J := J + 1;
1619                      Res (J) := '\';
1620                   end if;
1621
1622                   --  Ending quote
1623
1624                   J := J + 1;
1625                   Res (J) := '"';
1626                end if;
1627
1628                declare
1629                   Old : String_Access := Arg;
1630
1631                begin
1632                   Arg := new String'(Res (1 .. J));
1633                   Free (Old);
1634                end;
1635             end if;
1636
1637          end if;
1638       end Quote_Argument;
1639
1640    --  Start of processing for Normalize_Arguments
1641
1642    begin
1643       if Argument_Needs_Quote then
1644          for K in Args'Range loop
1645             if Args (K) /= null and then Args (K)'Length /= 0 then
1646                Quote_Argument (Args (K));
1647             end if;
1648          end loop;
1649       end if;
1650    end Normalize_Arguments;
1651
1652    ------------------------
1653    -- Normalize_Pathname --
1654    ------------------------
1655
1656    function Normalize_Pathname
1657      (Name           : String;
1658       Directory      : String  := "";
1659       Resolve_Links  : Boolean := True;
1660       Case_Sensitive : Boolean := True) return String
1661    is
1662       Max_Path : Integer;
1663       pragma Import (C, Max_Path, "__gnat_max_path_len");
1664       --  Maximum length of a path name
1665
1666       procedure Get_Current_Dir
1667         (Dir    : System.Address;
1668          Length : System.Address);
1669       pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
1670
1671       Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
1672       End_Path    : Natural := 0;
1673       Link_Buffer : String (1 .. Max_Path + 2);
1674       Status      : Integer;
1675       Last        : Positive;
1676       Start       : Natural;
1677       Finish      : Positive;
1678
1679       Max_Iterations : constant := 500;
1680
1681       function Get_File_Names_Case_Sensitive return Integer;
1682       pragma Import
1683         (C, Get_File_Names_Case_Sensitive,
1684          "__gnat_get_file_names_case_sensitive");
1685
1686       Fold_To_Lower_Case : constant Boolean :=
1687                              not Case_Sensitive
1688                                and then Get_File_Names_Case_Sensitive = 0;
1689
1690       function Readlink
1691         (Path   : System.Address;
1692          Buf    : System.Address;
1693          Bufsiz : Integer) return Integer;
1694       pragma Import (C, Readlink, "__gnat_readlink");
1695
1696       function To_Canonical_File_Spec
1697         (Host_File : System.Address) return System.Address;
1698       pragma Import
1699         (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
1700
1701       The_Name : String (1 .. Name'Length + 1);
1702       Canonical_File_Addr : System.Address;
1703       Canonical_File_Len  : Integer;
1704
1705       function Strlen (S : System.Address) return Integer;
1706       pragma Import (C, Strlen, "strlen");
1707
1708       function Final_Value (S : String) return String;
1709       --  Make final adjustment to the returned string. This function strips
1710       --  trailing directory separators, and folds returned string to lower
1711       --  case if required.
1712
1713       function Get_Directory  (Dir : String) return String;
1714       --  If Dir is not empty, return it, adding a directory separator
1715       --  if not already present, otherwise return current working directory
1716       --  with terminating directory separator.
1717
1718       -----------------
1719       -- Final_Value --
1720       -----------------
1721
1722       function Final_Value (S : String) return String is
1723          S1 : String := S;
1724          --  We may need to fold S to lower case, so we need a variable
1725
1726          Last : Natural;
1727
1728       begin
1729          if Fold_To_Lower_Case then
1730             System.Case_Util.To_Lower (S1);
1731          end if;
1732
1733          --  Remove trailing directory separator, if any
1734
1735          Last := S1'Last;
1736
1737          if Last > 1
1738            and then (S1 (Last) = '/'
1739                        or else
1740                      S1 (Last) = Directory_Separator)
1741          then
1742             --  Special case for Windows: C:\
1743
1744             if Last = 3
1745               and then S1 (1) /= Directory_Separator
1746               and then S1 (2) = ':'
1747             then
1748                null;
1749
1750             else
1751                Last := Last - 1;
1752             end if;
1753          end if;
1754
1755          return S1 (1 .. Last);
1756       end Final_Value;
1757
1758       -------------------
1759       -- Get_Directory --
1760       -------------------
1761
1762       function Get_Directory (Dir : String) return String is
1763       begin
1764          --  Directory given, add directory separator if needed
1765
1766          if Dir'Length > 0 then
1767             if Dir (Dir'Last) = Directory_Separator then
1768                return Dir;
1769             else
1770                declare
1771                   Result : String (1 .. Dir'Length + 1);
1772                begin
1773                   Result (1 .. Dir'Length) := Dir;
1774                   Result (Result'Length) := Directory_Separator;
1775                   return Result;
1776                end;
1777             end if;
1778
1779          --  Directory name not given, get current directory
1780
1781          else
1782             declare
1783                Buffer   : String (1 .. Max_Path + 2);
1784                Path_Len : Natural := Max_Path;
1785
1786             begin
1787                Get_Current_Dir (Buffer'Address, Path_Len'Address);
1788
1789                if Buffer (Path_Len) /= Directory_Separator then
1790                   Path_Len := Path_Len + 1;
1791                   Buffer (Path_Len) := Directory_Separator;
1792                end if;
1793
1794                --  By default, the drive letter on Windows is in upper case
1795
1796                if On_Windows and then Path_Len >= 2 and then
1797                  Buffer (2) = ':'
1798                then
1799                   System.Case_Util.To_Upper (Buffer (1 .. 1));
1800                end if;
1801
1802                return Buffer (1 .. Path_Len);
1803             end;
1804          end if;
1805       end Get_Directory;
1806
1807       Reference_Dir : constant String := Get_Directory (Directory);
1808       --  Current directory name specified
1809
1810    --  Start of processing for Normalize_Pathname
1811
1812    begin
1813       --  Special case, if name is null, then return null
1814
1815       if Name'Length = 0 then
1816          return "";
1817       end if;
1818
1819       --  First, convert VMS file spec to Unix file spec.
1820       --  If Name is not in VMS syntax, then this is equivalent
1821       --  to put Name at the begining of Path_Buffer.
1822
1823       VMS_Conversion : begin
1824          The_Name (1 .. Name'Length) := Name;
1825          The_Name (The_Name'Last) := ASCII.NUL;
1826
1827          Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1828          Canonical_File_Len  := Strlen (Canonical_File_Addr);
1829
1830          --  If VMS syntax conversion has failed, return an empty string
1831          --  to indicate the failure.
1832
1833          if Canonical_File_Len = 0 then
1834             return "";
1835          end if;
1836
1837          declare
1838             subtype Path_String is String (1 .. Canonical_File_Len);
1839             type    Path_String_Access is access Path_String;
1840
1841             function Address_To_Access is new
1842                Ada.Unchecked_Conversion (Source => Address,
1843                                      Target => Path_String_Access);
1844
1845             Path_Access : constant Path_String_Access :=
1846                             Address_To_Access (Canonical_File_Addr);
1847
1848          begin
1849             Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
1850             End_Path := Canonical_File_Len;
1851             Last := 1;
1852          end;
1853       end VMS_Conversion;
1854
1855       --  Replace all '/' by Directory Separators (this is for Windows)
1856
1857       if Directory_Separator /= '/' then
1858          for Index in 1 .. End_Path loop
1859             if Path_Buffer (Index) = '/' then
1860                Path_Buffer (Index) := Directory_Separator;
1861             end if;
1862          end loop;
1863       end if;
1864
1865       --  Resolve directory names for Windows (formerly also VMS)
1866
1867       --  On VMS, if we have a Unix path such as /temp/..., and TEMP is a
1868       --  logical name, we must not try to resolve this logical name, because
1869       --  it may have multiple equivalences and if resolved we will only
1870       --  get the first one.
1871
1872       --  On Windows, if we have an absolute path starting with a directory
1873       --  separator, we need to have the drive letter appended in front.
1874
1875       --  On Windows, Get_Current_Dir will return a suitable directory
1876       --  name (path starting with a drive letter on Windows). So we take this
1877       --  drive letter and prepend it to the current path.
1878
1879       if On_Windows
1880         and then Path_Buffer (1) = Directory_Separator
1881         and then Path_Buffer (2) /= Directory_Separator
1882       then
1883          declare
1884             Cur_Dir : String := Get_Directory ("");
1885             --  Get the current directory to get the drive letter
1886
1887          begin
1888             if Cur_Dir'Length > 2
1889               and then Cur_Dir (Cur_Dir'First + 1) = ':'
1890             then
1891                Path_Buffer (3 .. End_Path + 2) := Path_Buffer (1 .. End_Path);
1892                Path_Buffer (1 .. 2) :=
1893                  Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1);
1894                End_Path := End_Path + 2;
1895             end if;
1896          end;
1897       end if;
1898
1899       --  Start the conversions
1900
1901       --  If this is not finished after Max_Iterations, give up and return an
1902       --  empty string.
1903
1904       for J in 1 .. Max_Iterations loop
1905
1906          --  If we don't have an absolute pathname, prepend the directory
1907          --  Reference_Dir.
1908
1909          if Last = 1
1910            and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
1911          then
1912             Path_Buffer
1913               (Reference_Dir'Length + 1 .. Reference_Dir'Length + End_Path) :=
1914                  Path_Buffer (1 .. End_Path);
1915             End_Path := Reference_Dir'Length + End_Path;
1916             Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir;
1917             Last := Reference_Dir'Length;
1918          end if;
1919
1920          Start  := Last + 1;
1921          Finish := Last;
1922
1923          --  Ensure that Windows network drives are kept, e.g: \\server\drive-c
1924
1925          if Start = 2
1926            and then Directory_Separator = '\'
1927            and then Path_Buffer (1 .. 2) = "\\"
1928          then
1929             Start := 3;
1930          end if;
1931
1932          --  If we have traversed the full pathname, return it
1933
1934          if Start > End_Path then
1935             return Final_Value (Path_Buffer (1 .. End_Path));
1936          end if;
1937
1938          --  Remove duplicate directory separators
1939
1940          while Path_Buffer (Start) = Directory_Separator loop
1941             if Start = End_Path then
1942                return Final_Value (Path_Buffer (1 .. End_Path - 1));
1943
1944             else
1945                Path_Buffer (Start .. End_Path - 1) :=
1946                  Path_Buffer (Start + 1 .. End_Path);
1947                End_Path := End_Path - 1;
1948             end if;
1949          end loop;
1950
1951          --  Find the end of the current field: last character or the one
1952          --  preceding the next directory separator.
1953
1954          while Finish < End_Path
1955            and then Path_Buffer (Finish + 1) /= Directory_Separator
1956          loop
1957             Finish := Finish + 1;
1958          end loop;
1959
1960          --  Remove "." field
1961
1962          if Start = Finish and then Path_Buffer (Start) = '.' then
1963             if Start = End_Path then
1964                if Last = 1 then
1965                   return (1 => Directory_Separator);
1966                else
1967
1968                   if Fold_To_Lower_Case then
1969                      System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
1970                   end if;
1971
1972                   return Path_Buffer (1 .. Last - 1);
1973
1974                end if;
1975
1976             else
1977                Path_Buffer (Last + 1 .. End_Path - 2) :=
1978                  Path_Buffer (Last + 3 .. End_Path);
1979                End_Path := End_Path - 2;
1980             end if;
1981
1982          --  Remove ".." fields
1983
1984          elsif Finish = Start + 1
1985            and then Path_Buffer (Start .. Finish) = ".."
1986          then
1987             Start := Last;
1988             loop
1989                Start := Start - 1;
1990                exit when Start < 1 or else
1991                  Path_Buffer (Start) = Directory_Separator;
1992             end loop;
1993
1994             if Start <= 1 then
1995                if Finish = End_Path then
1996                   return (1 => Directory_Separator);
1997
1998                else
1999                   Path_Buffer (1 .. End_Path - Finish) :=
2000                     Path_Buffer (Finish + 1 .. End_Path);
2001                   End_Path := End_Path - Finish;
2002                   Last := 1;
2003                end if;
2004
2005             else
2006                if Finish = End_Path then
2007                   return Final_Value (Path_Buffer (1 .. Start - 1));
2008
2009                else
2010                   Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
2011                     Path_Buffer (Finish + 2 .. End_Path);
2012                   End_Path := Start + End_Path - Finish - 1;
2013                   Last := Start;
2014                end if;
2015             end if;
2016
2017          --  Check if current field is a symbolic link
2018
2019          elsif Resolve_Links then
2020             declare
2021                Saved : constant Character := Path_Buffer (Finish + 1);
2022
2023             begin
2024                Path_Buffer (Finish + 1) := ASCII.NUL;
2025                Status := Readlink (Path_Buffer'Address,
2026                                    Link_Buffer'Address,
2027                                    Link_Buffer'Length);
2028                Path_Buffer (Finish + 1) := Saved;
2029             end;
2030
2031             --  Not a symbolic link, move to the next field, if any
2032
2033             if Status <= 0 then
2034                Last := Finish + 1;
2035
2036             --  Replace symbolic link with its value
2037
2038             else
2039                if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
2040                   Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
2041                   Path_Buffer (Finish + 1 .. End_Path);
2042                   End_Path := End_Path - (Finish - Status);
2043                   Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
2044                   Last := 1;
2045
2046                else
2047                   Path_Buffer
2048                     (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
2049                     Path_Buffer (Finish + 1 .. End_Path);
2050                   End_Path := End_Path - Finish + Last + Status;
2051                   Path_Buffer (Last + 1 .. Last + Status) :=
2052                     Link_Buffer (1 .. Status);
2053                end if;
2054             end if;
2055
2056          else
2057             Last := Finish + 1;
2058          end if;
2059       end loop;
2060
2061       --  Too many iterations: give up
2062
2063       --  This can happen when there is a circularity in the symbolic links: A
2064       --  is a symbolic link for B, which itself is a symbolic link, and the
2065       --  target of B or of another symbolic link target of B is A. In this
2066       --  case, we return an empty string to indicate failure to resolve.
2067
2068       return "";
2069    end Normalize_Pathname;
2070
2071    ---------------
2072    -- Open_Read --
2073    ---------------
2074
2075    function Open_Read
2076      (Name  : C_File_Name;
2077       Fmode : Mode) return File_Descriptor
2078    is
2079       function C_Open_Read
2080         (Name  : C_File_Name;
2081          Fmode : Mode) return File_Descriptor;
2082       pragma Import (C, C_Open_Read, "__gnat_open_read");
2083    begin
2084       return C_Open_Read (Name, Fmode);
2085    end Open_Read;
2086
2087    function Open_Read
2088      (Name  : String;
2089       Fmode : Mode) return File_Descriptor
2090    is
2091       C_Name : String (1 .. Name'Length + 1);
2092    begin
2093       C_Name (1 .. Name'Length) := Name;
2094       C_Name (C_Name'Last)      := ASCII.NUL;
2095       return Open_Read (C_Name (C_Name'First)'Address, Fmode);
2096    end Open_Read;
2097
2098    ---------------------
2099    -- Open_Read_Write --
2100    ---------------------
2101
2102    function Open_Read_Write
2103      (Name  : C_File_Name;
2104       Fmode : Mode) return File_Descriptor
2105    is
2106       function C_Open_Read_Write
2107         (Name  : C_File_Name;
2108          Fmode : Mode) return File_Descriptor;
2109       pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
2110    begin
2111       return C_Open_Read_Write (Name, Fmode);
2112    end Open_Read_Write;
2113
2114    function Open_Read_Write
2115      (Name  : String;
2116       Fmode : Mode) return File_Descriptor
2117    is
2118       C_Name : String (1 .. Name'Length + 1);
2119    begin
2120       C_Name (1 .. Name'Length) := Name;
2121       C_Name (C_Name'Last)      := ASCII.NUL;
2122       return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
2123    end Open_Read_Write;
2124
2125    -------------
2126    -- OS_Exit --
2127    -------------
2128
2129    procedure OS_Exit (Status : Integer) is
2130    begin
2131       OS_Exit_Ptr (Status);
2132       raise Program_Error;
2133    end OS_Exit;
2134
2135    ---------------------
2136    -- OS_Exit_Default --
2137    ---------------------
2138
2139    procedure OS_Exit_Default (Status : Integer) is
2140       procedure GNAT_OS_Exit (Status : Integer);
2141       pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit");
2142       pragma No_Return (GNAT_OS_Exit);
2143    begin
2144       GNAT_OS_Exit (Status);
2145    end OS_Exit_Default;
2146
2147    --------------------
2148    -- Pid_To_Integer --
2149    --------------------
2150
2151    function Pid_To_Integer (Pid : Process_Id) return Integer is
2152    begin
2153       return Integer (Pid);
2154    end Pid_To_Integer;
2155
2156    ----------
2157    -- Read --
2158    ----------
2159
2160    function Read
2161      (FD : File_Descriptor;
2162       A  : System.Address;
2163       N  : Integer) return Integer
2164    is
2165    begin
2166       return Integer (System.CRTL.read
2167         (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
2168    end Read;
2169
2170    -----------------
2171    -- Rename_File --
2172    -----------------
2173
2174    procedure Rename_File
2175      (Old_Name : C_File_Name;
2176       New_Name : C_File_Name;
2177       Success  : out Boolean)
2178    is
2179       function rename (From, To : Address) return Integer;
2180       pragma Import (C, rename, "rename");
2181       R : Integer;
2182    begin
2183       R := rename (Old_Name, New_Name);
2184       Success := (R = 0);
2185    end Rename_File;
2186
2187    procedure Rename_File
2188      (Old_Name : String;
2189       New_Name : String;
2190       Success  : out Boolean)
2191    is
2192       C_Old_Name : String (1 .. Old_Name'Length + 1);
2193       C_New_Name : String (1 .. New_Name'Length + 1);
2194    begin
2195       C_Old_Name (1 .. Old_Name'Length) := Old_Name;
2196       C_Old_Name (C_Old_Name'Last)      := ASCII.NUL;
2197       C_New_Name (1 .. New_Name'Length) := New_Name;
2198       C_New_Name (C_New_Name'Last)      := ASCII.NUL;
2199       Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
2200    end Rename_File;
2201
2202    -----------------------
2203    -- Set_Close_On_Exec --
2204    -----------------------
2205
2206    procedure Set_Close_On_Exec
2207      (FD            : File_Descriptor;
2208       Close_On_Exec : Boolean;
2209       Status        : out Boolean)
2210    is
2211       function C_Set_Close_On_Exec
2212         (FD : File_Descriptor; Close_On_Exec : System.CRTL.int)
2213          return System.CRTL.int;
2214       pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
2215    begin
2216       Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0;
2217    end Set_Close_On_Exec;
2218
2219    --------------------
2220    -- Set_Executable --
2221    --------------------
2222
2223    procedure Set_Executable (Name : String) is
2224       procedure C_Set_Executable (Name : C_File_Name);
2225       pragma Import (C, C_Set_Executable, "__gnat_set_executable");
2226       C_Name : aliased String (Name'First .. Name'Last + 1);
2227    begin
2228       C_Name (Name'Range)  := Name;
2229       C_Name (C_Name'Last) := ASCII.NUL;
2230       C_Set_Executable (C_Name (C_Name'First)'Address);
2231    end Set_Executable;
2232
2233    --------------------
2234    -- Set_Read_Only --
2235    --------------------
2236
2237    procedure Set_Read_Only (Name : String) is
2238       procedure C_Set_Read_Only (Name : C_File_Name);
2239       pragma Import (C, C_Set_Read_Only, "__gnat_set_readonly");
2240       C_Name : aliased String (Name'First .. Name'Last + 1);
2241    begin
2242       C_Name (Name'Range)  := Name;
2243       C_Name (C_Name'Last) := ASCII.NUL;
2244       C_Set_Read_Only (C_Name (C_Name'First)'Address);
2245    end Set_Read_Only;
2246
2247    --------------------
2248    -- Set_Writable --
2249    --------------------
2250
2251    procedure Set_Writable (Name : String) is
2252       procedure C_Set_Writable (Name : C_File_Name);
2253       pragma Import (C, C_Set_Writable, "__gnat_set_writable");
2254       C_Name : aliased String (Name'First .. Name'Last + 1);
2255    begin
2256       C_Name (Name'Range)  := Name;
2257       C_Name (C_Name'Last) := ASCII.NUL;
2258       C_Set_Writable (C_Name (C_Name'First)'Address);
2259    end Set_Writable;
2260
2261    ------------
2262    -- Setenv --
2263    ------------
2264
2265    procedure Setenv (Name : String; Value : String) is
2266       F_Name  : String (1 .. Name'Length + 1);
2267       F_Value : String (1 .. Value'Length + 1);
2268
2269       procedure Set_Env_Value (Name, Value : System.Address);
2270       pragma Import (C, Set_Env_Value, "__gnat_setenv");
2271
2272    begin
2273       F_Name (1 .. Name'Length) := Name;
2274       F_Name (F_Name'Last)      := ASCII.NUL;
2275
2276       F_Value (1 .. Value'Length) := Value;
2277       F_Value (F_Value'Last)      := ASCII.NUL;
2278
2279       Set_Env_Value (F_Name'Address, F_Value'Address);
2280    end Setenv;
2281
2282    -----------
2283    -- Spawn --
2284    -----------
2285
2286    function Spawn
2287      (Program_Name : String;
2288       Args         : Argument_List) return Integer
2289    is
2290       Junk   : Process_Id;
2291       Result : Integer;
2292    begin
2293       Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
2294       return Result;
2295    end Spawn;
2296
2297    procedure Spawn
2298      (Program_Name : String;
2299       Args         : Argument_List;
2300       Success      : out Boolean)
2301    is
2302    begin
2303       Success := (Spawn (Program_Name, Args) = 0);
2304    end Spawn;
2305
2306    procedure Spawn
2307      (Program_Name           : String;
2308       Args                   : Argument_List;
2309       Output_File_Descriptor : File_Descriptor;
2310       Return_Code            : out Integer;
2311       Err_To_Out             : Boolean := True)
2312    is
2313       Saved_Output : File_Descriptor;
2314       Saved_Error  : File_Descriptor := Invalid_FD; -- prevent compiler warning
2315
2316    begin
2317       --  Set standard output and error to the temporary file
2318
2319       Saved_Output := Dup (Standout);
2320       Dup2 (Output_File_Descriptor, Standout);
2321
2322       if Err_To_Out then
2323          Saved_Error  := Dup (Standerr);
2324          Dup2 (Output_File_Descriptor, Standerr);
2325       end if;
2326
2327       --  Spawn the program
2328
2329       Return_Code := Spawn (Program_Name, Args);
2330
2331       --  Restore the standard output and error
2332
2333       Dup2 (Saved_Output, Standout);
2334
2335       if Err_To_Out then
2336          Dup2 (Saved_Error, Standerr);
2337       end if;
2338
2339       --  And close the saved standard output and error file descriptors
2340
2341       Close (Saved_Output);
2342
2343       if Err_To_Out then
2344          Close (Saved_Error);
2345       end if;
2346    end Spawn;
2347
2348    procedure Spawn
2349      (Program_Name  : String;
2350       Args          : Argument_List;
2351       Output_File   : String;
2352       Success       : out Boolean;
2353       Return_Code   : out Integer;
2354       Err_To_Out    : Boolean := True)
2355    is
2356       FD : File_Descriptor;
2357
2358    begin
2359       Success := True;
2360       Return_Code := 0;
2361
2362       FD := Create_Output_Text_File (Output_File);
2363
2364       if FD = Invalid_FD then
2365          Success := False;
2366          return;
2367       end if;
2368
2369       Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out);
2370
2371       Close (FD, Success);
2372    end Spawn;
2373
2374    --------------------
2375    -- Spawn_Internal --
2376    --------------------
2377
2378    procedure Spawn_Internal
2379      (Program_Name : String;
2380       Args         : Argument_List;
2381       Result       : out Integer;
2382       Pid          : out Process_Id;
2383       Blocking     : Boolean)
2384    is
2385
2386       procedure Spawn (Args : Argument_List);
2387       --  Call Spawn with given argument list
2388
2389       N_Args : Argument_List (Args'Range);
2390       --  Normalized arguments
2391
2392       -----------
2393       -- Spawn --
2394       -----------
2395
2396       procedure Spawn (Args : Argument_List) is
2397          type Chars is array (Positive range <>) of aliased Character;
2398          type Char_Ptr is access constant Character;
2399
2400          Command_Len : constant Positive := Program_Name'Length + 1
2401                                               + Args_Length (Args);
2402          Command_Last : Natural := 0;
2403          Command : aliased Chars (1 .. Command_Len);
2404          --  Command contains all characters of the Program_Name and Args, all
2405          --  terminated by ASCII.NUL characters
2406
2407          Arg_List_Len : constant Positive := Args'Length + 2;
2408          Arg_List_Last : Natural := 0;
2409          Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
2410          --  List with pointers to NUL-terminated strings of the Program_Name
2411          --  and the Args and terminated with a null pointer. We rely on the
2412          --  default initialization for the last null pointer.
2413
2414          procedure Add_To_Command (S : String);
2415          --  Add S and a NUL character to Command, updating Last
2416
2417          function Portable_Spawn (Args : Address) return Integer;
2418          pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
2419
2420          function Portable_No_Block_Spawn (Args : Address) return Process_Id;
2421          pragma Import
2422            (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
2423
2424          --------------------
2425          -- Add_To_Command --
2426          --------------------
2427
2428          procedure Add_To_Command (S : String) is
2429             First : constant Natural := Command_Last + 1;
2430
2431          begin
2432             Command_Last := Command_Last + S'Length;
2433
2434             --  Move characters one at a time, because Command has aliased
2435             --  components.
2436
2437             --  But not volatile, so why is this necessary ???
2438
2439             for J in S'Range loop
2440                Command (First + J - S'First) := S (J);
2441             end loop;
2442
2443             Command_Last := Command_Last + 1;
2444             Command (Command_Last) := ASCII.NUL;
2445
2446             Arg_List_Last := Arg_List_Last + 1;
2447             Arg_List (Arg_List_Last) := Command (First)'Access;
2448          end Add_To_Command;
2449
2450       --  Start of processing for Spawn
2451
2452       begin
2453          Add_To_Command (Program_Name);
2454
2455          for J in Args'Range loop
2456             Add_To_Command (Args (J).all);
2457          end loop;
2458
2459          if Blocking then
2460             Pid     := Invalid_Pid;
2461             Result  := Portable_Spawn (Arg_List'Address);
2462          else
2463             Pid     := Portable_No_Block_Spawn (Arg_List'Address);
2464             Result  := Boolean'Pos (Pid /= Invalid_Pid);
2465          end if;
2466       end Spawn;
2467
2468    --  Start of processing for Spawn_Internal
2469
2470    begin
2471       --  Copy arguments into a local structure
2472
2473       for K in N_Args'Range loop
2474          N_Args (K) := new String'(Args (K).all);
2475       end loop;
2476
2477       --  Normalize those arguments
2478
2479       Normalize_Arguments (N_Args);
2480
2481       --  Call spawn using the normalized arguments
2482
2483       Spawn (N_Args);
2484
2485       --  Free arguments list
2486
2487       for K in N_Args'Range loop
2488          Free (N_Args (K));
2489       end loop;
2490    end Spawn_Internal;
2491
2492    ---------------------------
2493    -- To_Path_String_Access --
2494    ---------------------------
2495
2496    function To_Path_String_Access
2497      (Path_Addr : Address;
2498       Path_Len  : Integer) return String_Access
2499    is
2500       subtype Path_String is String (1 .. Path_Len);
2501       type    Path_String_Access is access Path_String;
2502
2503       function Address_To_Access is new
2504         Ada.Unchecked_Conversion (Source => Address,
2505                               Target => Path_String_Access);
2506
2507       Path_Access : constant Path_String_Access :=
2508                       Address_To_Access (Path_Addr);
2509
2510       Return_Val  : String_Access;
2511
2512    begin
2513       Return_Val := new String (1 .. Path_Len);
2514
2515       for J in 1 .. Path_Len loop
2516          Return_Val (J) := Path_Access (J);
2517       end loop;
2518
2519       return Return_Val;
2520    end To_Path_String_Access;
2521
2522    ------------------
2523    -- Wait_Process --
2524    ------------------
2525
2526    procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
2527       Status : Integer;
2528
2529       function Portable_Wait (S : Address) return Process_Id;
2530       pragma Import (C, Portable_Wait, "__gnat_portable_wait");
2531
2532    begin
2533       Pid := Portable_Wait (Status'Address);
2534       Success := (Status = 0);
2535    end Wait_Process;
2536
2537    -----------
2538    -- Write --
2539    -----------
2540
2541    function Write
2542      (FD : File_Descriptor;
2543       A  : System.Address;
2544       N  : Integer) return Integer
2545    is
2546    begin
2547       return Integer (System.CRTL.write
2548         (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
2549    end Write;
2550
2551 end System.OS_Lib;