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