gcc/ada/s-os_lib.adb

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