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