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