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 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       D  : Day_Type;
1095
1096       pragma Warnings (Off);
1097       Y  : Year_Type;
1098       Mo : Month_Type;
1099       H  : Hour_Type;
1100       Mn : Minute_Type;
1101       S  : Second_Type;
1102       pragma Warnings (On);
1103
1104    begin
1105       GM_Split (Date, Y, Mo, D, H, Mn, S);
1106       return D;
1107    end GM_Day;
1108
1109    -------------
1110    -- GM_Hour --
1111    -------------
1112
1113    function GM_Hour (Date : OS_Time) return Hour_Type is
1114       H  : Hour_Type;
1115
1116       pragma Warnings (Off);
1117       Y  : Year_Type;
1118       Mo : Month_Type;
1119       D  : Day_Type;
1120       Mn : Minute_Type;
1121       S  : Second_Type;
1122       pragma Warnings (On);
1123
1124    begin
1125       GM_Split (Date, Y, Mo, D, H, Mn, S);
1126       return H;
1127    end GM_Hour;
1128
1129    ---------------
1130    -- GM_Minute --
1131    ---------------
1132
1133    function GM_Minute (Date : OS_Time) return Minute_Type is
1134       Mn : Minute_Type;
1135
1136       pragma Warnings (Off);
1137       Y  : Year_Type;
1138       Mo : Month_Type;
1139       D  : Day_Type;
1140       H  : Hour_Type;
1141       S  : Second_Type;
1142       pragma Warnings (On);
1143
1144    begin
1145       GM_Split (Date, Y, Mo, D, H, Mn, S);
1146       return Mn;
1147    end GM_Minute;
1148
1149    --------------
1150    -- GM_Month --
1151    --------------
1152
1153    function GM_Month (Date : OS_Time) return Month_Type is
1154       Mo : Month_Type;
1155
1156       pragma Warnings (Off);
1157       Y  : Year_Type;
1158       D  : Day_Type;
1159       H  : Hour_Type;
1160       Mn : Minute_Type;
1161       S  : Second_Type;
1162       pragma Warnings (On);
1163
1164    begin
1165       GM_Split (Date, Y, Mo, D, H, Mn, S);
1166       return Mo;
1167    end GM_Month;
1168
1169    ---------------
1170    -- GM_Second --
1171    ---------------
1172
1173    function GM_Second (Date : OS_Time) return Second_Type is
1174       S  : Second_Type;
1175
1176       pragma Warnings (Off);
1177       Y  : Year_Type;
1178       Mo : Month_Type;
1179       D  : Day_Type;
1180       H  : Hour_Type;
1181       Mn : Minute_Type;
1182       pragma Warnings (On);
1183
1184    begin
1185       GM_Split (Date, Y, Mo, D, H, Mn, S);
1186       return S;
1187    end GM_Second;
1188
1189    --------------
1190    -- GM_Split --
1191    --------------
1192
1193    procedure GM_Split
1194      (Date   : OS_Time;
1195       Year   : out Year_Type;
1196       Month  : out Month_Type;
1197       Day    : out Day_Type;
1198       Hour   : out Hour_Type;
1199       Minute : out Minute_Type;
1200       Second : out Second_Type)
1201    is
1202       procedure To_GM_Time
1203         (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
1204       pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
1205
1206       T  : OS_Time := Date;
1207       Y  : Integer;
1208       Mo : Integer;
1209       D  : Integer;
1210       H  : Integer;
1211       Mn : Integer;
1212       S  : Integer;
1213
1214    begin
1215       --  Use the global lock because To_GM_Time is not thread safe
1216
1217       Locked_Processing : begin
1218          SSL.Lock_Task.all;
1219          To_GM_Time
1220            (T'Address, Y'Address, Mo'Address, D'Address,
1221             H'Address, Mn'Address, S'Address);
1222          SSL.Unlock_Task.all;
1223
1224       exception
1225          when others =>
1226             SSL.Unlock_Task.all;
1227             raise;
1228       end Locked_Processing;
1229
1230       Year   := Y + 1900;
1231       Month  := Mo + 1;
1232       Day    := D;
1233       Hour   := H;
1234       Minute := Mn;
1235       Second := S;
1236    end GM_Split;
1237
1238    -------------
1239    -- GM_Year --
1240    -------------
1241
1242    function GM_Year (Date : OS_Time) return Year_Type is
1243       Y  : Year_Type;
1244
1245       pragma Warnings (Off);
1246       Mo : Month_Type;
1247       D  : Day_Type;
1248       H  : Hour_Type;
1249       Mn : Minute_Type;
1250       S  : Second_Type;
1251       pragma Warnings (On);
1252
1253    begin
1254       GM_Split (Date, Y, Mo, D, H, Mn, S);
1255       return Y;
1256    end GM_Year;
1257
1258    ----------------------
1259    -- Is_Absolute_Path --
1260    ----------------------
1261
1262    function Is_Absolute_Path (Name : String) return Boolean is
1263       function Is_Absolute_Path
1264         (Name   : Address;
1265          Length : Integer) return Integer;
1266       pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
1267    begin
1268       return Is_Absolute_Path (Name'Address, Name'Length) /= 0;
1269    end Is_Absolute_Path;
1270
1271    ------------------
1272    -- Is_Directory --
1273    ------------------
1274
1275    function Is_Directory (Name : C_File_Name) return Boolean is
1276       function Is_Directory (Name : Address) return Integer;
1277       pragma Import (C, Is_Directory, "__gnat_is_directory");
1278    begin
1279       return Is_Directory (Name) /= 0;
1280    end Is_Directory;
1281
1282    function Is_Directory (Name : String) return Boolean is
1283       F_Name : String (1 .. Name'Length + 1);
1284    begin
1285       F_Name (1 .. Name'Length) := Name;
1286       F_Name (F_Name'Last)      := ASCII.NUL;
1287       return Is_Directory (F_Name'Address);
1288    end Is_Directory;
1289
1290    ----------------------
1291    -- Is_Readable_File --
1292    ----------------------
1293
1294    function Is_Readable_File (Name : C_File_Name) return Boolean is
1295       function Is_Readable_File (Name : Address) return Integer;
1296       pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
1297    begin
1298       return Is_Readable_File (Name) /= 0;
1299    end Is_Readable_File;
1300
1301    function Is_Readable_File (Name : String) return Boolean is
1302       F_Name : String (1 .. Name'Length + 1);
1303    begin
1304       F_Name (1 .. Name'Length) := Name;
1305       F_Name (F_Name'Last)      := ASCII.NUL;
1306       return Is_Readable_File (F_Name'Address);
1307    end Is_Readable_File;
1308
1309    ---------------------
1310    -- Is_Regular_File --
1311    ---------------------
1312
1313    function Is_Regular_File (Name : C_File_Name) return Boolean is
1314       function Is_Regular_File (Name : Address) return Integer;
1315       pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
1316    begin
1317       return Is_Regular_File (Name) /= 0;
1318    end Is_Regular_File;
1319
1320    function Is_Regular_File (Name : String) return Boolean is
1321       F_Name : String (1 .. Name'Length + 1);
1322    begin
1323       F_Name (1 .. Name'Length) := Name;
1324       F_Name (F_Name'Last)      := ASCII.NUL;
1325       return Is_Regular_File (F_Name'Address);
1326    end Is_Regular_File;
1327
1328    ----------------------
1329    -- Is_Symbolic_Link --
1330    ----------------------
1331
1332    function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
1333       function Is_Symbolic_Link (Name : Address) return Integer;
1334       pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
1335    begin
1336       return Is_Symbolic_Link (Name) /= 0;
1337    end Is_Symbolic_Link;
1338
1339    function Is_Symbolic_Link (Name : String) return Boolean is
1340       F_Name : String (1 .. Name'Length + 1);
1341    begin
1342       F_Name (1 .. Name'Length) := Name;
1343       F_Name (F_Name'Last)      := ASCII.NUL;
1344       return Is_Symbolic_Link (F_Name'Address);
1345    end Is_Symbolic_Link;
1346
1347    ----------------------
1348    -- Is_Writable_File --
1349    ----------------------
1350
1351    function Is_Writable_File (Name : C_File_Name) return Boolean is
1352       function Is_Writable_File (Name : Address) return Integer;
1353       pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
1354    begin
1355       return Is_Writable_File (Name) /= 0;
1356    end Is_Writable_File;
1357
1358    function Is_Writable_File (Name : String) return Boolean is
1359       F_Name : String (1 .. Name'Length + 1);
1360    begin
1361       F_Name (1 .. Name'Length) := Name;
1362       F_Name (F_Name'Last)      := ASCII.NUL;
1363       return Is_Writable_File (F_Name'Address);
1364    end Is_Writable_File;
1365
1366    -------------------------
1367    -- Locate_Exec_On_Path --
1368    -------------------------
1369
1370    function Locate_Exec_On_Path
1371      (Exec_Name : String) return String_Access
1372    is
1373       function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
1374       pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
1375
1376       procedure Free (Ptr : System.Address);
1377       pragma Import (C, Free, "free");
1378
1379       C_Exec_Name  : String (1 .. Exec_Name'Length + 1);
1380       Path_Addr    : Address;
1381       Path_Len     : Integer;
1382       Result       : String_Access;
1383
1384    begin
1385       C_Exec_Name (1 .. Exec_Name'Length)   := Exec_Name;
1386       C_Exec_Name (C_Exec_Name'Last)        := ASCII.NUL;
1387
1388       Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
1389       Path_Len  := C_String_Length (Path_Addr);
1390
1391       if Path_Len = 0 then
1392          return null;
1393
1394       else
1395          Result := To_Path_String_Access (Path_Addr, Path_Len);
1396          Free (Path_Addr);
1397
1398          --  Always return an absolute path name
1399
1400          if not Is_Absolute_Path (Result.all) then
1401             declare
1402                Absolute_Path : constant String :=
1403                                  Normalize_Pathname (Result.all);
1404             begin
1405                Free (Result);
1406                Result := new String'(Absolute_Path);
1407             end;
1408          end if;
1409
1410          return Result;
1411       end if;
1412    end Locate_Exec_On_Path;
1413
1414    -------------------------
1415    -- Locate_Regular_File --
1416    -------------------------
1417
1418    function Locate_Regular_File
1419      (File_Name : C_File_Name;
1420       Path      : C_File_Name) return String_Access
1421    is
1422       function Locate_Regular_File
1423         (C_File_Name, Path_Val : Address) return Address;
1424       pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file");
1425
1426       procedure Free (Ptr : System.Address);
1427       pragma Import (C, Free, "free");
1428
1429       Path_Addr    : Address;
1430       Path_Len     : Integer;
1431       Result       : String_Access;
1432
1433    begin
1434       Path_Addr := Locate_Regular_File (File_Name, Path);
1435       Path_Len  := C_String_Length (Path_Addr);
1436
1437       if Path_Len = 0 then
1438          return null;
1439       else
1440          Result := To_Path_String_Access (Path_Addr, Path_Len);
1441          Free (Path_Addr);
1442          return Result;
1443       end if;
1444    end Locate_Regular_File;
1445
1446    function Locate_Regular_File
1447      (File_Name : String;
1448       Path      : String) return String_Access
1449    is
1450       C_File_Name : String (1 .. File_Name'Length + 1);
1451       C_Path      : String (1 .. Path'Length + 1);
1452       Result      : String_Access;
1453
1454    begin
1455       C_File_Name (1 .. File_Name'Length)   := File_Name;
1456       C_File_Name (C_File_Name'Last)        := ASCII.NUL;
1457
1458       C_Path    (1 .. Path'Length)          := Path;
1459       C_Path    (C_Path'Last)               := ASCII.NUL;
1460
1461       Result := Locate_Regular_File (C_File_Name'Address, C_Path'Address);
1462
1463       --  Always return an absolute path name
1464
1465       if Result /= null and then not Is_Absolute_Path (Result.all) then
1466          declare
1467             Absolute_Path : constant String := Normalize_Pathname (Result.all);
1468          begin
1469             Free (Result);
1470             Result := new String'(Absolute_Path);
1471          end;
1472       end if;
1473
1474       return Result;
1475    end Locate_Regular_File;
1476
1477    ------------------------
1478    -- Non_Blocking_Spawn --
1479    ------------------------
1480
1481    function Non_Blocking_Spawn
1482      (Program_Name : String;
1483       Args         : Argument_List) return Process_Id
1484    is
1485       Pid  : Process_Id;
1486       Junk : Integer;
1487       pragma Warnings (Off, Junk);
1488    begin
1489       Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
1490       return Pid;
1491    end Non_Blocking_Spawn;
1492
1493    function Non_Blocking_Spawn
1494      (Program_Name           : String;
1495       Args                   : Argument_List;
1496       Output_File_Descriptor : File_Descriptor;
1497       Err_To_Out             : Boolean := True) return Process_Id
1498    is
1499       Saved_Output : File_Descriptor;
1500       Saved_Error  : File_Descriptor := Invalid_FD; -- prevent warning
1501       Pid          : Process_Id;
1502
1503    begin
1504       if Output_File_Descriptor = Invalid_FD then
1505          return Invalid_Pid;
1506       end if;
1507
1508       --  Set standard output and, if specified, error to the temporary file
1509
1510       Saved_Output := Dup (Standout);
1511       Dup2 (Output_File_Descriptor, Standout);
1512
1513       if Err_To_Out then
1514          Saved_Error  := Dup (Standerr);
1515          Dup2 (Output_File_Descriptor, Standerr);
1516       end if;
1517
1518       --  Spawn the program
1519
1520       Pid := Non_Blocking_Spawn (Program_Name, Args);
1521
1522       --  Restore the standard output and error
1523
1524       Dup2 (Saved_Output, Standout);
1525
1526       if Err_To_Out then
1527          Dup2 (Saved_Error, Standerr);
1528       end if;
1529
1530       --  And close the saved standard output and error file descriptors
1531
1532       Close (Saved_Output);
1533
1534       if Err_To_Out then
1535          Close (Saved_Error);
1536       end if;
1537
1538       return Pid;
1539    end Non_Blocking_Spawn;
1540
1541    function Non_Blocking_Spawn
1542      (Program_Name : String;
1543       Args         : Argument_List;
1544       Output_File  : String;
1545       Err_To_Out   : Boolean := True) return Process_Id
1546    is
1547       Output_File_Descriptor : constant File_Descriptor :=
1548                                  Create_Output_Text_File (Output_File);
1549       Result : Process_Id;
1550
1551    begin
1552       --  Do not attempt to spawn if the output file could not be created
1553
1554       if Output_File_Descriptor = Invalid_FD then
1555          return Invalid_Pid;
1556
1557       else
1558          Result := Non_Blocking_Spawn
1559                      (Program_Name, Args, Output_File_Descriptor, Err_To_Out);
1560
1561          --  Close the file just created for the output, as the file descriptor
1562          --  cannot be used anywhere, being a local value. It is safe to do
1563          --  that, as the file descriptor has been duplicated to form
1564          --  standard output and error of the spawned process.
1565
1566          Close (Output_File_Descriptor);
1567
1568          return Result;
1569       end if;
1570    end Non_Blocking_Spawn;
1571
1572    -------------------------
1573    -- Normalize_Arguments --
1574    -------------------------
1575
1576    procedure Normalize_Arguments (Args : in out Argument_List) is
1577
1578       procedure Quote_Argument (Arg : in out String_Access);
1579       --  Add quote around argument if it contains spaces
1580
1581       C_Argument_Needs_Quote : Integer;
1582       pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
1583       Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
1584
1585       --------------------
1586       -- Quote_Argument --
1587       --------------------
1588
1589       procedure Quote_Argument (Arg : in out String_Access) is
1590          Res          : String (1 .. Arg'Length * 2);
1591          J            : Positive := 1;
1592          Quote_Needed : Boolean  := False;
1593
1594       begin
1595          if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
1596
1597             --  Starting quote
1598
1599             Res (J) := '"';
1600
1601             for K in Arg'Range loop
1602
1603                J := J + 1;
1604
1605                if Arg (K) = '"' then
1606                   Res (J) := '\';
1607                   J := J + 1;
1608                   Res (J) := '"';
1609                   Quote_Needed := True;
1610
1611                elsif Arg (K) = ' ' then
1612                   Res (J) := Arg (K);
1613                   Quote_Needed := True;
1614
1615                else
1616                   Res (J) := Arg (K);
1617                end if;
1618
1619             end loop;
1620
1621             if Quote_Needed then
1622
1623                --  If null terminated string, put the quote before
1624
1625                if Res (J) = ASCII.NUL then
1626                   Res (J) := '"';
1627                   J := J + 1;
1628                   Res (J) := ASCII.NUL;
1629
1630                --  If argument is terminated by '\', then double it. Otherwise
1631                --  the ending quote will be taken as-is. This is quite strange
1632                --  spawn behavior from Windows, but this is what we see!
1633
1634                else
1635                   if Res (J) = '\' then
1636                      J := J + 1;
1637                      Res (J) := '\';
1638                   end if;
1639
1640                   --  Ending quote
1641
1642                   J := J + 1;
1643                   Res (J) := '"';
1644                end if;
1645
1646                declare
1647                   Old : String_Access := Arg;
1648
1649                begin
1650                   Arg := new String'(Res (1 .. J));
1651                   Free (Old);
1652                end;
1653             end if;
1654
1655          end if;
1656       end Quote_Argument;
1657
1658    --  Start of processing for Normalize_Arguments
1659
1660    begin
1661       if Argument_Needs_Quote then
1662          for K in Args'Range loop
1663             if Args (K) /= null and then Args (K)'Length /= 0 then
1664                Quote_Argument (Args (K));
1665             end if;
1666          end loop;
1667       end if;
1668    end Normalize_Arguments;
1669
1670    ------------------------
1671    -- Normalize_Pathname --
1672    ------------------------
1673
1674    function Normalize_Pathname
1675      (Name           : String;
1676       Directory      : String  := "";
1677       Resolve_Links  : Boolean := True;
1678       Case_Sensitive : Boolean := True) return String
1679    is
1680       Max_Path : Integer;
1681       pragma Import (C, Max_Path, "__gnat_max_path_len");
1682       --  Maximum length of a path name
1683
1684       procedure Get_Current_Dir
1685         (Dir    : System.Address;
1686          Length : System.Address);
1687       pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
1688
1689       Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
1690       End_Path    : Natural := 0;
1691       Link_Buffer : String (1 .. Max_Path + 2);
1692       Status      : Integer;
1693       Last        : Positive;
1694       Start       : Natural;
1695       Finish      : Positive;
1696
1697       Max_Iterations : constant := 500;
1698
1699       function Get_File_Names_Case_Sensitive return Integer;
1700       pragma Import
1701         (C, Get_File_Names_Case_Sensitive,
1702          "__gnat_get_file_names_case_sensitive");
1703
1704       Fold_To_Lower_Case : constant Boolean :=
1705                              not Case_Sensitive
1706                                and then Get_File_Names_Case_Sensitive = 0;
1707
1708       function Readlink
1709         (Path   : System.Address;
1710          Buf    : System.Address;
1711          Bufsiz : Integer) return Integer;
1712       pragma Import (C, Readlink, "__gnat_readlink");
1713
1714       function To_Canonical_File_Spec
1715         (Host_File : System.Address) return System.Address;
1716       pragma Import
1717         (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
1718
1719       The_Name : String (1 .. Name'Length + 1);
1720       Canonical_File_Addr : System.Address;
1721       Canonical_File_Len  : Integer;
1722
1723       function Strlen (S : System.Address) return Integer;
1724       pragma Import (C, Strlen, "strlen");
1725
1726       function Final_Value (S : String) return String;
1727       --  Make final adjustment to the returned string. This function strips
1728       --  trailing directory separators, and folds returned string to lower
1729       --  case if required.
1730
1731       function Get_Directory  (Dir : String) return String;
1732       --  If Dir is not empty, return it, adding a directory separator
1733       --  if not already present, otherwise return current working directory
1734       --  with terminating directory separator.
1735
1736       -----------------
1737       -- Final_Value --
1738       -----------------
1739
1740       function Final_Value (S : String) return String is
1741          S1 : String := S;
1742          --  We may need to fold S to lower case, so we need a variable
1743
1744          Last : Natural;
1745
1746       begin
1747          if Fold_To_Lower_Case then
1748             System.Case_Util.To_Lower (S1);
1749          end if;
1750
1751          --  Remove trailing directory separator, if any
1752
1753          Last := S1'Last;
1754
1755          if Last > 1
1756            and then (S1 (Last) = '/'
1757                        or else
1758                      S1 (Last) = Directory_Separator)
1759          then
1760             --  Special case for Windows: C:\
1761
1762             if Last = 3
1763               and then S1 (1) /= Directory_Separator
1764               and then S1 (2) = ':'
1765             then
1766                null;
1767
1768             else
1769                Last := Last - 1;
1770             end if;
1771          end if;
1772
1773          return S1 (1 .. Last);
1774       end Final_Value;
1775
1776       -------------------
1777       -- Get_Directory --
1778       -------------------
1779
1780       function Get_Directory (Dir : String) return String is
1781       begin
1782          --  Directory given, add directory separator if needed
1783
1784          if Dir'Length > 0 then
1785             if Dir (Dir'Last) = Directory_Separator then
1786                return Dir;
1787             else
1788                declare
1789                   Result : String (1 .. Dir'Length + 1);
1790                begin
1791                   Result (1 .. Dir'Length) := Dir;
1792                   Result (Result'Length) := Directory_Separator;
1793                   return Result;
1794                end;
1795             end if;
1796
1797          --  Directory name not given, get current directory
1798
1799          else
1800             declare
1801                Buffer   : String (1 .. Max_Path + 2);
1802                Path_Len : Natural := Max_Path;
1803
1804             begin
1805                Get_Current_Dir (Buffer'Address, Path_Len'Address);
1806
1807                if Buffer (Path_Len) /= Directory_Separator then
1808                   Path_Len := Path_Len + 1;
1809                   Buffer (Path_Len) := Directory_Separator;
1810                end if;
1811
1812                --  By default, the drive letter on Windows is in upper case
1813
1814                if On_Windows and then Path_Len >= 2 and then
1815                  Buffer (2) = ':'
1816                then
1817                   System.Case_Util.To_Upper (Buffer (1 .. 1));
1818                end if;
1819
1820                return Buffer (1 .. Path_Len);
1821             end;
1822          end if;
1823       end Get_Directory;
1824
1825    --  Start of processing for Normalize_Pathname
1826
1827    begin
1828       --  Special case, if name is null, then return null
1829
1830       if Name'Length = 0 then
1831          return "";
1832       end if;
1833
1834       --  First, convert VMS file spec to Unix file spec.
1835       --  If Name is not in VMS syntax, then this is equivalent
1836       --  to put Name at the begining of Path_Buffer.
1837
1838       VMS_Conversion : begin
1839          The_Name (1 .. Name'Length) := Name;
1840          The_Name (The_Name'Last) := ASCII.NUL;
1841
1842          Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1843          Canonical_File_Len  := Strlen (Canonical_File_Addr);
1844
1845          --  If VMS syntax conversion has failed, return an empty string
1846          --  to indicate the failure.
1847
1848          if Canonical_File_Len = 0 then
1849             return "";
1850          end if;
1851
1852          declare
1853             subtype Path_String is String (1 .. Canonical_File_Len);
1854             type    Path_String_Access is access Path_String;
1855
1856             function Address_To_Access is new
1857                Ada.Unchecked_Conversion (Source => Address,
1858                                      Target => Path_String_Access);
1859
1860             Path_Access : constant Path_String_Access :=
1861                             Address_To_Access (Canonical_File_Addr);
1862
1863          begin
1864             Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
1865             End_Path := Canonical_File_Len;
1866             Last := 1;
1867          end;
1868       end VMS_Conversion;
1869
1870       --  Replace all '/' by Directory Separators (this is for Windows)
1871
1872       if Directory_Separator /= '/' then
1873          for Index in 1 .. End_Path loop
1874             if Path_Buffer (Index) = '/' then
1875                Path_Buffer (Index) := Directory_Separator;
1876             end if;
1877          end loop;
1878       end if;
1879
1880       --  Resolve directory names for Windows (formerly also VMS)
1881
1882       --  On VMS, if we have a Unix path such as /temp/..., and TEMP is a
1883       --  logical name, we must not try to resolve this logical name, because
1884       --  it may have multiple equivalences and if resolved we will only
1885       --  get the first one.
1886
1887       --  On Windows, if we have an absolute path starting with a directory
1888       --  separator, we need to have the drive letter appended in front.
1889
1890       --  On Windows, Get_Current_Dir will return a suitable directory
1891       --  name (path starting with a drive letter on Windows). So we take this
1892       --  drive letter and prepend it to the current path.
1893
1894       if On_Windows
1895         and then Path_Buffer (1) = Directory_Separator
1896         and then Path_Buffer (2) /= Directory_Separator
1897       then
1898          declare
1899             Cur_Dir : String := Get_Directory ("");
1900             --  Get the current directory to get the drive letter
1901
1902          begin
1903             if Cur_Dir'Length > 2
1904               and then Cur_Dir (Cur_Dir'First + 1) = ':'
1905             then
1906                Path_Buffer (3 .. End_Path + 2) := Path_Buffer (1 .. End_Path);
1907                Path_Buffer (1 .. 2) :=
1908                  Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1);
1909                End_Path := End_Path + 2;
1910             end if;
1911          end;
1912       end if;
1913
1914       --  Start the conversions
1915
1916       --  If this is not finished after Max_Iterations, give up and return an
1917       --  empty string.
1918
1919       for J in 1 .. Max_Iterations loop
1920
1921          --  If we don't have an absolute pathname, prepend the directory
1922          --  Reference_Dir.
1923
1924          if Last = 1
1925            and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
1926          then
1927             declare
1928                Reference_Dir : constant String  := Get_Directory (Directory);
1929                Ref_Dir_Len   : constant Natural := Reference_Dir'Length;
1930                --  Current directory name specified and its length
1931
1932             begin
1933                Path_Buffer (Ref_Dir_Len + 1 .. Ref_Dir_Len + End_Path) :=
1934                  Path_Buffer (1 .. End_Path);
1935                End_Path := Ref_Dir_Len + End_Path;
1936                Path_Buffer (1 .. Ref_Dir_Len) := Reference_Dir;
1937                Last := Ref_Dir_Len;
1938             end;
1939          end if;
1940
1941          Start  := Last + 1;
1942          Finish := Last;
1943
1944          --  Ensure that Windows network drives are kept, e.g: \\server\drive-c
1945
1946          if Start = 2
1947            and then Directory_Separator = '\'
1948            and then Path_Buffer (1 .. 2) = "\\"
1949          then
1950             Start := 3;
1951          end if;
1952
1953          --  If we have traversed the full pathname, return it
1954
1955          if Start > End_Path then
1956             return Final_Value (Path_Buffer (1 .. End_Path));
1957          end if;
1958
1959          --  Remove duplicate directory separators
1960
1961          while Path_Buffer (Start) = Directory_Separator loop
1962             if Start = End_Path then
1963                return Final_Value (Path_Buffer (1 .. End_Path - 1));
1964
1965             else
1966                Path_Buffer (Start .. End_Path - 1) :=
1967                  Path_Buffer (Start + 1 .. End_Path);
1968                End_Path := End_Path - 1;
1969             end if;
1970          end loop;
1971
1972          --  Find the end of the current field: last character or the one
1973          --  preceding the next directory separator.
1974
1975          while Finish < End_Path
1976            and then Path_Buffer (Finish + 1) /= Directory_Separator
1977          loop
1978             Finish := Finish + 1;
1979          end loop;
1980
1981          --  Remove "." field
1982
1983          if Start = Finish and then Path_Buffer (Start) = '.' then
1984             if Start = End_Path then
1985                if Last = 1 then
1986                   return (1 => Directory_Separator);
1987                else
1988
1989                   if Fold_To_Lower_Case then
1990                      System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
1991                   end if;
1992
1993                   return Path_Buffer (1 .. Last - 1);
1994
1995                end if;
1996
1997             else
1998                Path_Buffer (Last + 1 .. End_Path - 2) :=
1999                  Path_Buffer (Last + 3 .. End_Path);
2000                End_Path := End_Path - 2;
2001             end if;
2002
2003          --  Remove ".." fields
2004
2005          elsif Finish = Start + 1
2006            and then Path_Buffer (Start .. Finish) = ".."
2007          then
2008             Start := Last;
2009             loop
2010                Start := Start - 1;
2011                exit when Start < 1 or else
2012                  Path_Buffer (Start) = Directory_Separator;
2013             end loop;
2014
2015             if Start <= 1 then
2016                if Finish = End_Path then
2017                   return (1 => Directory_Separator);
2018
2019                else
2020                   Path_Buffer (1 .. End_Path - Finish) :=
2021                     Path_Buffer (Finish + 1 .. End_Path);
2022                   End_Path := End_Path - Finish;
2023                   Last := 1;
2024                end if;
2025
2026             else
2027                if Finish = End_Path then
2028                   return Final_Value (Path_Buffer (1 .. Start - 1));
2029
2030                else
2031                   Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
2032                     Path_Buffer (Finish + 2 .. End_Path);
2033                   End_Path := Start + End_Path - Finish - 1;
2034                   Last := Start;
2035                end if;
2036             end if;
2037
2038          --  Check if current field is a symbolic link
2039
2040          elsif Resolve_Links then
2041             declare
2042                Saved : constant Character := Path_Buffer (Finish + 1);
2043
2044             begin
2045                Path_Buffer (Finish + 1) := ASCII.NUL;
2046                Status := Readlink (Path_Buffer'Address,
2047                                    Link_Buffer'Address,
2048                                    Link_Buffer'Length);
2049                Path_Buffer (Finish + 1) := Saved;
2050             end;
2051
2052             --  Not a symbolic link, move to the next field, if any
2053
2054             if Status <= 0 then
2055                Last := Finish + 1;
2056
2057             --  Replace symbolic link with its value
2058
2059             else
2060                if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
2061                   Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
2062                   Path_Buffer (Finish + 1 .. End_Path);
2063                   End_Path := End_Path - (Finish - Status);
2064                   Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
2065                   Last := 1;
2066
2067                else
2068                   Path_Buffer
2069                     (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
2070                     Path_Buffer (Finish + 1 .. End_Path);
2071                   End_Path := End_Path - Finish + Last + Status;
2072                   Path_Buffer (Last + 1 .. Last + Status) :=
2073                     Link_Buffer (1 .. Status);
2074                end if;
2075             end if;
2076
2077          else
2078             Last := Finish + 1;
2079          end if;
2080       end loop;
2081
2082       --  Too many iterations: give up
2083
2084       --  This can happen when there is a circularity in the symbolic links: A
2085       --  is a symbolic link for B, which itself is a symbolic link, and the
2086       --  target of B or of another symbolic link target of B is A. In this
2087       --  case, we return an empty string to indicate failure to resolve.
2088
2089       return "";
2090    end Normalize_Pathname;
2091
2092    ---------------
2093    -- Open_Read --
2094    ---------------
2095
2096    function Open_Read
2097      (Name  : C_File_Name;
2098       Fmode : Mode) return File_Descriptor
2099    is
2100       function C_Open_Read
2101         (Name  : C_File_Name;
2102          Fmode : Mode) return File_Descriptor;
2103       pragma Import (C, C_Open_Read, "__gnat_open_read");
2104    begin
2105       return C_Open_Read (Name, Fmode);
2106    end Open_Read;
2107
2108    function Open_Read
2109      (Name  : String;
2110       Fmode : Mode) return File_Descriptor
2111    is
2112       C_Name : String (1 .. Name'Length + 1);
2113    begin
2114       C_Name (1 .. Name'Length) := Name;
2115       C_Name (C_Name'Last)      := ASCII.NUL;
2116       return Open_Read (C_Name (C_Name'First)'Address, Fmode);
2117    end Open_Read;
2118
2119    ---------------------
2120    -- Open_Read_Write --
2121    ---------------------
2122
2123    function Open_Read_Write
2124      (Name  : C_File_Name;
2125       Fmode : Mode) return File_Descriptor
2126    is
2127       function C_Open_Read_Write
2128         (Name  : C_File_Name;
2129          Fmode : Mode) return File_Descriptor;
2130       pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
2131    begin
2132       return C_Open_Read_Write (Name, Fmode);
2133    end Open_Read_Write;
2134
2135    function Open_Read_Write
2136      (Name  : String;
2137       Fmode : Mode) return File_Descriptor
2138    is
2139       C_Name : String (1 .. Name'Length + 1);
2140    begin
2141       C_Name (1 .. Name'Length) := Name;
2142       C_Name (C_Name'Last)      := ASCII.NUL;
2143       return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
2144    end Open_Read_Write;
2145
2146    -------------
2147    -- OS_Exit --
2148    -------------
2149
2150    procedure OS_Exit (Status : Integer) is
2151    begin
2152       OS_Exit_Ptr (Status);
2153       raise Program_Error;
2154    end OS_Exit;
2155
2156    ---------------------
2157    -- OS_Exit_Default --
2158    ---------------------
2159
2160    procedure OS_Exit_Default (Status : Integer) is
2161       procedure GNAT_OS_Exit (Status : Integer);
2162       pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit");
2163       pragma No_Return (GNAT_OS_Exit);
2164    begin
2165       GNAT_OS_Exit (Status);
2166    end OS_Exit_Default;
2167
2168    --------------------
2169    -- Pid_To_Integer --
2170    --------------------
2171
2172    function Pid_To_Integer (Pid : Process_Id) return Integer is
2173    begin
2174       return Integer (Pid);
2175    end Pid_To_Integer;
2176
2177    ----------
2178    -- Read --
2179    ----------
2180
2181    function Read
2182      (FD : File_Descriptor;
2183       A  : System.Address;
2184       N  : Integer) return Integer
2185    is
2186    begin
2187       return Integer (System.CRTL.read
2188         (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
2189    end Read;
2190
2191    -----------------
2192    -- Rename_File --
2193    -----------------
2194
2195    procedure Rename_File
2196      (Old_Name : C_File_Name;
2197       New_Name : C_File_Name;
2198       Success  : out Boolean)
2199    is
2200       function rename (From, To : Address) return Integer;
2201       pragma Import (C, rename, "rename");
2202       R : Integer;
2203    begin
2204       R := rename (Old_Name, New_Name);
2205       Success := (R = 0);
2206    end Rename_File;
2207
2208    procedure Rename_File
2209      (Old_Name : String;
2210       New_Name : String;
2211       Success  : out Boolean)
2212    is
2213       C_Old_Name : String (1 .. Old_Name'Length + 1);
2214       C_New_Name : String (1 .. New_Name'Length + 1);
2215    begin
2216       C_Old_Name (1 .. Old_Name'Length) := Old_Name;
2217       C_Old_Name (C_Old_Name'Last)      := ASCII.NUL;
2218       C_New_Name (1 .. New_Name'Length) := New_Name;
2219       C_New_Name (C_New_Name'Last)      := ASCII.NUL;
2220       Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
2221    end Rename_File;
2222
2223    -----------------------
2224    -- Set_Close_On_Exec --
2225    -----------------------
2226
2227    procedure Set_Close_On_Exec
2228      (FD            : File_Descriptor;
2229       Close_On_Exec : Boolean;
2230       Status        : out Boolean)
2231    is
2232       function C_Set_Close_On_Exec
2233         (FD : File_Descriptor; Close_On_Exec : System.CRTL.int)
2234          return System.CRTL.int;
2235       pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
2236    begin
2237       Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0;
2238    end Set_Close_On_Exec;
2239
2240    --------------------
2241    -- Set_Executable --
2242    --------------------
2243
2244    procedure Set_Executable (Name : String) is
2245       procedure C_Set_Executable (Name : C_File_Name);
2246       pragma Import (C, C_Set_Executable, "__gnat_set_executable");
2247       C_Name : aliased String (Name'First .. Name'Last + 1);
2248    begin
2249       C_Name (Name'Range)  := Name;
2250       C_Name (C_Name'Last) := ASCII.NUL;
2251       C_Set_Executable (C_Name (C_Name'First)'Address);
2252    end Set_Executable;
2253
2254    --------------------
2255    -- Set_Read_Only --
2256    --------------------
2257
2258    procedure Set_Read_Only (Name : String) is
2259       procedure C_Set_Read_Only (Name : C_File_Name);
2260       pragma Import (C, C_Set_Read_Only, "__gnat_set_readonly");
2261       C_Name : aliased String (Name'First .. Name'Last + 1);
2262    begin
2263       C_Name (Name'Range)  := Name;
2264       C_Name (C_Name'Last) := ASCII.NUL;
2265       C_Set_Read_Only (C_Name (C_Name'First)'Address);
2266    end Set_Read_Only;
2267
2268    --------------------
2269    -- Set_Writable --
2270    --------------------
2271
2272    procedure Set_Writable (Name : String) is
2273       procedure C_Set_Writable (Name : C_File_Name);
2274       pragma Import (C, C_Set_Writable, "__gnat_set_writable");
2275       C_Name : aliased String (Name'First .. Name'Last + 1);
2276    begin
2277       C_Name (Name'Range)  := Name;
2278       C_Name (C_Name'Last) := ASCII.NUL;
2279       C_Set_Writable (C_Name (C_Name'First)'Address);
2280    end Set_Writable;
2281
2282    ------------
2283    -- Setenv --
2284    ------------
2285
2286    procedure Setenv (Name : String; Value : String) is
2287       F_Name  : String (1 .. Name'Length + 1);
2288       F_Value : String (1 .. Value'Length + 1);
2289
2290       procedure Set_Env_Value (Name, Value : System.Address);
2291       pragma Import (C, Set_Env_Value, "__gnat_setenv");
2292
2293    begin
2294       F_Name (1 .. Name'Length) := Name;
2295       F_Name (F_Name'Last)      := ASCII.NUL;
2296
2297       F_Value (1 .. Value'Length) := Value;
2298       F_Value (F_Value'Last)      := ASCII.NUL;
2299
2300       Set_Env_Value (F_Name'Address, F_Value'Address);
2301    end Setenv;
2302
2303    -----------
2304    -- Spawn --
2305    -----------
2306
2307    function Spawn
2308      (Program_Name : String;
2309       Args         : Argument_List) return Integer
2310    is
2311       Result : Integer;
2312       Junk   : Process_Id;
2313       pragma Warnings (Off, Junk);
2314    begin
2315       Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
2316       return Result;
2317    end Spawn;
2318
2319    procedure Spawn
2320      (Program_Name : String;
2321       Args         : Argument_List;
2322       Success      : out Boolean)
2323    is
2324    begin
2325       Success := (Spawn (Program_Name, Args) = 0);
2326    end Spawn;
2327
2328    procedure Spawn
2329      (Program_Name           : String;
2330       Args                   : Argument_List;
2331       Output_File_Descriptor : File_Descriptor;
2332       Return_Code            : out Integer;
2333       Err_To_Out             : Boolean := True)
2334    is
2335       Saved_Output : File_Descriptor;
2336       Saved_Error  : File_Descriptor := Invalid_FD; -- prevent compiler warning
2337
2338    begin
2339       --  Set standard output and error to the temporary file
2340
2341       Saved_Output := Dup (Standout);
2342       Dup2 (Output_File_Descriptor, Standout);
2343
2344       if Err_To_Out then
2345          Saved_Error  := Dup (Standerr);
2346          Dup2 (Output_File_Descriptor, Standerr);
2347       end if;
2348
2349       --  Spawn the program
2350
2351       Return_Code := Spawn (Program_Name, Args);
2352
2353       --  Restore the standard output and error
2354
2355       Dup2 (Saved_Output, Standout);
2356
2357       if Err_To_Out then
2358          Dup2 (Saved_Error, Standerr);
2359       end if;
2360
2361       --  And close the saved standard output and error file descriptors
2362
2363       Close (Saved_Output);
2364
2365       if Err_To_Out then
2366          Close (Saved_Error);
2367       end if;
2368    end Spawn;
2369
2370    procedure Spawn
2371      (Program_Name  : String;
2372       Args          : Argument_List;
2373       Output_File   : String;
2374       Success       : out Boolean;
2375       Return_Code   : out Integer;
2376       Err_To_Out    : Boolean := True)
2377    is
2378       FD : File_Descriptor;
2379
2380    begin
2381       Success := True;
2382       Return_Code := 0;
2383
2384       FD := Create_Output_Text_File (Output_File);
2385
2386       if FD = Invalid_FD then
2387          Success := False;
2388          return;
2389       end if;
2390
2391       Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out);
2392
2393       Close (FD, Success);
2394    end Spawn;
2395
2396    --------------------
2397    -- Spawn_Internal --
2398    --------------------
2399
2400    procedure Spawn_Internal
2401      (Program_Name : String;
2402       Args         : Argument_List;
2403       Result       : out Integer;
2404       Pid          : out Process_Id;
2405       Blocking     : Boolean)
2406    is
2407
2408       procedure Spawn (Args : Argument_List);
2409       --  Call Spawn with given argument list
2410
2411       N_Args : Argument_List (Args'Range);
2412       --  Normalized arguments
2413
2414       -----------
2415       -- Spawn --
2416       -----------
2417
2418       procedure Spawn (Args : Argument_List) is
2419          type Chars is array (Positive range <>) of aliased Character;
2420          type Char_Ptr is access constant Character;
2421
2422          Command_Len : constant Positive := Program_Name'Length + 1
2423                                               + Args_Length (Args);
2424          Command_Last : Natural := 0;
2425          Command : aliased Chars (1 .. Command_Len);
2426          --  Command contains all characters of the Program_Name and Args, all
2427          --  terminated by ASCII.NUL characters
2428
2429          Arg_List_Len : constant Positive := Args'Length + 2;
2430          Arg_List_Last : Natural := 0;
2431          Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
2432          --  List with pointers to NUL-terminated strings of the Program_Name
2433          --  and the Args and terminated with a null pointer. We rely on the
2434          --  default initialization for the last null pointer.
2435
2436          procedure Add_To_Command (S : String);
2437          --  Add S and a NUL character to Command, updating Last
2438
2439          function Portable_Spawn (Args : Address) return Integer;
2440          pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
2441
2442          function Portable_No_Block_Spawn (Args : Address) return Process_Id;
2443          pragma Import
2444            (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
2445
2446          --------------------
2447          -- Add_To_Command --
2448          --------------------
2449
2450          procedure Add_To_Command (S : String) is
2451             First : constant Natural := Command_Last + 1;
2452
2453          begin
2454             Command_Last := Command_Last + S'Length;
2455
2456             --  Move characters one at a time, because Command has aliased
2457             --  components.
2458
2459             --  But not volatile, so why is this necessary ???
2460
2461             for J in S'Range loop
2462                Command (First + J - S'First) := S (J);
2463             end loop;
2464
2465             Command_Last := Command_Last + 1;
2466             Command (Command_Last) := ASCII.NUL;
2467
2468             Arg_List_Last := Arg_List_Last + 1;
2469             Arg_List (Arg_List_Last) := Command (First)'Access;
2470          end Add_To_Command;
2471
2472       --  Start of processing for Spawn
2473
2474       begin
2475          Add_To_Command (Program_Name);
2476
2477          for J in Args'Range loop
2478             Add_To_Command (Args (J).all);
2479          end loop;
2480
2481          if Blocking then
2482             Pid     := Invalid_Pid;
2483             Result  := Portable_Spawn (Arg_List'Address);
2484          else
2485             Pid     := Portable_No_Block_Spawn (Arg_List'Address);
2486             Result  := Boolean'Pos (Pid /= Invalid_Pid);
2487          end if;
2488       end Spawn;
2489
2490    --  Start of processing for Spawn_Internal
2491
2492    begin
2493       --  Copy arguments into a local structure
2494
2495       for K in N_Args'Range loop
2496          N_Args (K) := new String'(Args (K).all);
2497       end loop;
2498
2499       --  Normalize those arguments
2500
2501       Normalize_Arguments (N_Args);
2502
2503       --  Call spawn using the normalized arguments
2504
2505       Spawn (N_Args);
2506
2507       --  Free arguments list
2508
2509       for K in N_Args'Range loop
2510          Free (N_Args (K));
2511       end loop;
2512    end Spawn_Internal;
2513
2514    ---------------------------
2515    -- To_Path_String_Access --
2516    ---------------------------
2517
2518    function To_Path_String_Access
2519      (Path_Addr : Address;
2520       Path_Len  : Integer) return String_Access
2521    is
2522       subtype Path_String is String (1 .. Path_Len);
2523       type    Path_String_Access is access Path_String;
2524
2525       function Address_To_Access is new
2526         Ada.Unchecked_Conversion (Source => Address,
2527                               Target => Path_String_Access);
2528
2529       Path_Access : constant Path_String_Access :=
2530                       Address_To_Access (Path_Addr);
2531
2532       Return_Val  : String_Access;
2533
2534    begin
2535       Return_Val := new String (1 .. Path_Len);
2536
2537       for J in 1 .. Path_Len loop
2538          Return_Val (J) := Path_Access (J);
2539       end loop;
2540
2541       return Return_Val;
2542    end To_Path_String_Access;
2543
2544    ------------------
2545    -- Wait_Process --
2546    ------------------
2547
2548    procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
2549       Status : Integer;
2550
2551       function Portable_Wait (S : Address) return Process_Id;
2552       pragma Import (C, Portable_Wait, "__gnat_portable_wait");
2553
2554    begin
2555       Pid := Portable_Wait (Status'Address);
2556       Success := (Status = 0);
2557    end Wait_Process;
2558
2559    -----------
2560    -- Write --
2561    -----------
2562
2563    function Write
2564      (FD : File_Descriptor;
2565       A  : System.Address;
2566       N  : Integer) return Integer
2567    is
2568    begin
2569       return Integer (System.CRTL.write
2570         (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
2571    end Write;
2572
2573 end System.OS_Lib;