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-2012, 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 Ada.Unchecked_Conversion;
  35 with Ada.Unchecked_Deallocation;
  36 with System; use System;
  37 with System.Case_Util;
  38 with System.CRTL;
  39 with System.Soft_Links;
  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             end loop;
1699
1700             if Quote_Needed then
1701
1702                --  Case of null terminated string
1703
1704                if Res (J) = ASCII.NUL then
1705
1706                   --  If the string ends with \, double it
1707
1708                   if Res (J - 1) = '\' then
1709                      Res (J) := '\';
1710                      J := J + 1;
1711                   end if;
1712
1713                   --  Put a quote just before the null at the end
1714
1715                   Res (J) := '"';
1716                   J := J + 1;
1717                   Res (J) := ASCII.NUL;
1718
1719                --  If argument is terminated by '\', then double it. Otherwise
1720                --  the ending quote will be taken as-is. This is quite strange
1721                --  spawn behavior from Windows, but this is what we see!
1722
1723                else
1724                   if Res (J) = '\' then
1725                      J := J + 1;
1726                      Res (J) := '\';
1727                   end if;
1728
1729                   --  Ending quote
1730
1731                   J := J + 1;
1732                   Res (J) := '"';
1733                end if;
1734
1735                declare
1736                   Old : String_Access := Arg;
1737
1738                begin
1739                   Arg := new String'(Res (1 .. J));
1740                   Free (Old);
1741                end;
1742             end if;
1743
1744          end if;
1745       end Quote_Argument;
1746
1747    --  Start of processing for Normalize_Arguments
1748
1749    begin
1750       if Argument_Needs_Quote then
1751          for K in Args'Range loop
1752             if Args (K) /= null and then Args (K)'Length /= 0 then
1753                Quote_Argument (Args (K));
1754             end if;
1755          end loop;
1756       end if;
1757    end Normalize_Arguments;
1758
1759    ------------------------
1760    -- Normalize_Pathname --
1761    ------------------------
1762
1763    function Normalize_Pathname
1764      (Name           : String;
1765       Directory      : String  := "";
1766       Resolve_Links  : Boolean := True;
1767       Case_Sensitive : Boolean := True) return String
1768    is
1769       Max_Path : Integer;
1770       pragma Import (C, Max_Path, "__gnat_max_path_len");
1771       --  Maximum length of a path name
1772
1773       procedure Get_Current_Dir
1774         (Dir    : System.Address;
1775          Length : System.Address);
1776       pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
1777
1778       Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
1779       End_Path    : Natural := 0;
1780       Link_Buffer : String (1 .. Max_Path + 2);
1781       Status      : Integer;
1782       Last        : Positive;
1783       Start       : Natural;
1784       Finish      : Positive;
1785
1786       Max_Iterations : constant := 500;
1787
1788       function Get_File_Names_Case_Sensitive return Integer;
1789       pragma Import
1790         (C, Get_File_Names_Case_Sensitive,
1791          "__gnat_get_file_names_case_sensitive");
1792
1793       Fold_To_Lower_Case : constant Boolean :=
1794                              not Case_Sensitive
1795                                and then Get_File_Names_Case_Sensitive = 0;
1796
1797       function Readlink
1798         (Path   : System.Address;
1799          Buf    : System.Address;
1800          Bufsiz : Integer) return Integer;
1801       pragma Import (C, Readlink, "__gnat_readlink");
1802
1803       function To_Canonical_File_Spec
1804         (Host_File : System.Address) return System.Address;
1805       pragma Import
1806         (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
1807
1808       The_Name : String (1 .. Name'Length + 1);
1809       Canonical_File_Addr : System.Address;
1810       Canonical_File_Len  : Integer;
1811
1812       function Strlen (S : System.Address) return Integer;
1813       pragma Import (C, Strlen, "strlen");
1814
1815       function Final_Value (S : String) return String;
1816       --  Make final adjustment to the returned string. This function strips
1817       --  trailing directory separators, and folds returned string to lower
1818       --  case if required.
1819
1820       function Get_Directory  (Dir : String) return String;
1821       --  If Dir is not empty, return it, adding a directory separator
1822       --  if not already present, otherwise return current working directory
1823       --  with terminating directory separator.
1824
1825       -----------------
1826       -- Final_Value --
1827       -----------------
1828
1829       function Final_Value (S : String) return String is
1830          S1 : String := S;
1831          --  We may need to fold S to lower case, so we need a variable
1832
1833          Last : Natural;
1834
1835       begin
1836          if Fold_To_Lower_Case then
1837             System.Case_Util.To_Lower (S1);
1838          end if;
1839
1840          --  Remove trailing directory separator, if any
1841
1842          Last := S1'Last;
1843
1844          if Last > 1
1845            and then (S1 (Last) = '/'
1846                        or else
1847                      S1 (Last) = Directory_Separator)
1848          then
1849             --  Special case for Windows: C:\
1850
1851             if Last = 3
1852               and then S1 (1) /= Directory_Separator
1853               and then S1 (2) = ':'
1854             then
1855                null;
1856
1857             else
1858                Last := Last - 1;
1859             end if;
1860          end if;
1861
1862          return S1 (1 .. Last);
1863       end Final_Value;
1864
1865       -------------------
1866       -- Get_Directory --
1867       -------------------
1868
1869       function Get_Directory (Dir : String) return String is
1870          Result : String (1 .. Dir'Length + 1);
1871          Length : constant Natural := Dir'Length;
1872
1873       begin
1874          --  Directory given, add directory separator if needed
1875
1876          if Length > 0 then
1877             Result (1 .. Length) := Dir;
1878
1879             --  On Windows, change all '/' to '\'
1880
1881             if On_Windows then
1882                for J in 1 .. Length loop
1883                   if Result (J) = '/' then
1884                      Result (J) := Directory_Separator;
1885                   end if;
1886                end loop;
1887             end if;
1888
1889             --  Add directory separator, if needed
1890
1891             if Result (Length) = Directory_Separator then
1892                return Result (1 .. Length);
1893             else
1894                Result (Result'Length) := Directory_Separator;
1895                return Result;
1896             end if;
1897
1898          --  Directory name not given, get current directory
1899
1900          else
1901             declare
1902                Buffer   : String (1 .. Max_Path + 2);
1903                Path_Len : Natural := Max_Path;
1904
1905             begin
1906                Get_Current_Dir (Buffer'Address, Path_Len'Address);
1907
1908                if Buffer (Path_Len) /= Directory_Separator then
1909                   Path_Len := Path_Len + 1;
1910                   Buffer (Path_Len) := Directory_Separator;
1911                end if;
1912
1913                --  By default, the drive letter on Windows is in upper case
1914
1915                if On_Windows
1916                  and then Path_Len >= 2
1917                  and then Buffer (2) = ':'
1918                then
1919                   System.Case_Util.To_Upper (Buffer (1 .. 1));
1920                end if;
1921
1922                return Buffer (1 .. Path_Len);
1923             end;
1924          end if;
1925       end Get_Directory;
1926
1927    --  Start of processing for Normalize_Pathname
1928
1929    begin
1930       --  Special case, if name is null, then return null
1931
1932       if Name'Length = 0 then
1933          return "";
1934       end if;
1935
1936       --  First, convert VMS file spec to Unix file spec.
1937       --  If Name is not in VMS syntax, then this is equivalent
1938       --  to put Name at the beginning of Path_Buffer.
1939
1940       VMS_Conversion : begin
1941          The_Name (1 .. Name'Length) := Name;
1942          The_Name (The_Name'Last) := ASCII.NUL;
1943
1944          Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1945          Canonical_File_Len  := Strlen (Canonical_File_Addr);
1946
1947          --  If VMS syntax conversion has failed, return an empty string
1948          --  to indicate the failure.
1949
1950          if Canonical_File_Len = 0 then
1951             return "";
1952          end if;
1953
1954          declare
1955             subtype Path_String is String (1 .. Canonical_File_Len);
1956             type    Path_String_Access is access Path_String;
1957
1958             function Address_To_Access is new
1959                Ada.Unchecked_Conversion (Source => Address,
1960                                      Target => Path_String_Access);
1961
1962             Path_Access : constant Path_String_Access :=
1963                             Address_To_Access (Canonical_File_Addr);
1964
1965          begin
1966             Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
1967             End_Path := Canonical_File_Len;
1968             Last := 1;
1969          end;
1970       end VMS_Conversion;
1971
1972       --  Replace all '/' by Directory Separators (this is for Windows)
1973
1974       if Directory_Separator /= '/' then
1975          for Index in 1 .. End_Path loop
1976             if Path_Buffer (Index) = '/' then
1977                Path_Buffer (Index) := Directory_Separator;
1978             end if;
1979          end loop;
1980       end if;
1981
1982       --  Resolve directory names for Windows (formerly also VMS)
1983
1984       --  On VMS, if we have a Unix path such as /temp/..., and TEMP is a
1985       --  logical name, we must not try to resolve this logical name, because
1986       --  it may have multiple equivalences and if resolved we will only
1987       --  get the first one.
1988
1989       if On_Windows then
1990
1991          --  On Windows, if we have an absolute path starting with a directory
1992          --  separator, we need to have the drive letter appended in front.
1993
1994          --  On Windows, Get_Current_Dir will return a suitable directory name
1995          --  (path starting with a drive letter on Windows). So we take this
1996          --  drive letter and prepend it to the current path.
1997
1998          if Path_Buffer (1) = Directory_Separator
1999            and then Path_Buffer (2) /= Directory_Separator
2000          then
2001             declare
2002                Cur_Dir : constant String := Get_Directory ("");
2003                --  Get the current directory to get the drive letter
2004
2005             begin
2006                if Cur_Dir'Length > 2
2007                  and then Cur_Dir (Cur_Dir'First + 1) = ':'
2008                then
2009                   Path_Buffer (3 .. End_Path + 2) :=
2010                     Path_Buffer (1 .. End_Path);
2011                   Path_Buffer (1 .. 2) :=
2012                     Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1);
2013                   End_Path := End_Path + 2;
2014                end if;
2015             end;
2016
2017          --  We have a drive letter, ensure it is upper-case
2018
2019          elsif Path_Buffer (1) in 'a' .. 'z'
2020            and then Path_Buffer (2) = ':'
2021          then
2022             System.Case_Util.To_Upper (Path_Buffer (1 .. 1));
2023          end if;
2024       end if;
2025
2026       --  On Windows, remove all double-quotes that are possibly part of the
2027       --  path but can cause problems with other methods.
2028
2029       if On_Windows then
2030          declare
2031             Index : Natural;
2032
2033          begin
2034             Index := Path_Buffer'First;
2035             for Current in Path_Buffer'First .. End_Path loop
2036                if Path_Buffer (Current) /= '"' then
2037                   Path_Buffer (Index) := Path_Buffer (Current);
2038                   Index := Index + 1;
2039                end if;
2040             end loop;
2041
2042             End_Path := Index - 1;
2043          end;
2044       end if;
2045
2046       --  Start the conversions
2047
2048       --  If this is not finished after Max_Iterations, give up and return an
2049       --  empty string.
2050
2051       for J in 1 .. Max_Iterations loop
2052
2053          --  If we don't have an absolute pathname, prepend the directory
2054          --  Reference_Dir.
2055
2056          if Last = 1
2057            and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
2058          then
2059             declare
2060                Reference_Dir : constant String  := Get_Directory (Directory);
2061                Ref_Dir_Len   : constant Natural := Reference_Dir'Length;
2062                --  Current directory name specified and its length
2063
2064             begin
2065                Path_Buffer (Ref_Dir_Len + 1 .. Ref_Dir_Len + End_Path) :=
2066                  Path_Buffer (1 .. End_Path);
2067                End_Path := Ref_Dir_Len + End_Path;
2068                Path_Buffer (1 .. Ref_Dir_Len) := Reference_Dir;
2069                Last := Ref_Dir_Len;
2070             end;
2071          end if;
2072
2073          Start  := Last + 1;
2074          Finish := Last;
2075
2076          --  Ensure that Windows network drives are kept, e.g: \\server\drive-c
2077
2078          if Start = 2
2079            and then Directory_Separator = '\'
2080            and then Path_Buffer (1 .. 2) = "\\"
2081          then
2082             Start := 3;
2083          end if;
2084
2085          --  If we have traversed the full pathname, return it
2086
2087          if Start > End_Path then
2088             return Final_Value (Path_Buffer (1 .. End_Path));
2089          end if;
2090
2091          --  Remove duplicate directory separators
2092
2093          while Path_Buffer (Start) = Directory_Separator loop
2094             if Start = End_Path then
2095                return Final_Value (Path_Buffer (1 .. End_Path - 1));
2096
2097             else
2098                Path_Buffer (Start .. End_Path - 1) :=
2099                  Path_Buffer (Start + 1 .. End_Path);
2100                End_Path := End_Path - 1;
2101             end if;
2102          end loop;
2103
2104          --  Find the end of the current field: last character or the one
2105          --  preceding the next directory separator.
2106
2107          while Finish < End_Path
2108            and then Path_Buffer (Finish + 1) /= Directory_Separator
2109          loop
2110             Finish := Finish + 1;
2111          end loop;
2112
2113          --  Remove "." field
2114
2115          if Start = Finish and then Path_Buffer (Start) = '.' then
2116             if Start = End_Path then
2117                if Last = 1 then
2118                   return (1 => Directory_Separator);
2119                else
2120
2121                   if Fold_To_Lower_Case then
2122                      System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
2123                   end if;
2124
2125                   return Path_Buffer (1 .. Last - 1);
2126
2127                end if;
2128
2129             else
2130                Path_Buffer (Last + 1 .. End_Path - 2) :=
2131                  Path_Buffer (Last + 3 .. End_Path);
2132                End_Path := End_Path - 2;
2133             end if;
2134
2135          --  Remove ".." fields
2136
2137          elsif Finish = Start + 1
2138            and then Path_Buffer (Start .. Finish) = ".."
2139          then
2140             Start := Last;
2141             loop
2142                Start := Start - 1;
2143                exit when Start < 1
2144                  or else Path_Buffer (Start) = Directory_Separator;
2145             end loop;
2146
2147             if Start <= 1 then
2148                if Finish = End_Path then
2149                   return (1 => Directory_Separator);
2150
2151                else
2152                   Path_Buffer (1 .. End_Path - Finish) :=
2153                     Path_Buffer (Finish + 1 .. End_Path);
2154                   End_Path := End_Path - Finish;
2155                   Last := 1;
2156                end if;
2157
2158             else
2159                if Finish = End_Path then
2160                   return Final_Value (Path_Buffer (1 .. Start - 1));
2161
2162                else
2163                   Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
2164                     Path_Buffer (Finish + 2 .. End_Path);
2165                   End_Path := Start + End_Path - Finish - 1;
2166                   Last := Start;
2167                end if;
2168             end if;
2169
2170          --  Check if current field is a symbolic link
2171
2172          elsif Resolve_Links then
2173             declare
2174                Saved : constant Character := Path_Buffer (Finish + 1);
2175
2176             begin
2177                Path_Buffer (Finish + 1) := ASCII.NUL;
2178                Status := Readlink (Path_Buffer'Address,
2179                                    Link_Buffer'Address,
2180                                    Link_Buffer'Length);
2181                Path_Buffer (Finish + 1) := Saved;
2182             end;
2183
2184             --  Not a symbolic link, move to the next field, if any
2185
2186             if Status <= 0 then
2187                Last := Finish + 1;
2188
2189             --  Replace symbolic link with its value
2190
2191             else
2192                if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
2193                   Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
2194                   Path_Buffer (Finish + 1 .. End_Path);
2195                   End_Path := End_Path - (Finish - Status);
2196                   Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
2197                   Last := 1;
2198
2199                else
2200                   Path_Buffer
2201                     (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
2202                     Path_Buffer (Finish + 1 .. End_Path);
2203                   End_Path := End_Path - Finish + Last + Status;
2204                   Path_Buffer (Last + 1 .. Last + Status) :=
2205                     Link_Buffer (1 .. Status);
2206                end if;
2207             end if;
2208
2209          else
2210             Last := Finish + 1;
2211          end if;
2212       end loop;
2213
2214       --  Too many iterations: give up
2215
2216       --  This can happen when there is a circularity in the symbolic links: A
2217       --  is a symbolic link for B, which itself is a symbolic link, and the
2218       --  target of B or of another symbolic link target of B is A. In this
2219       --  case, we return an empty string to indicate failure to resolve.
2220
2221       return "";
2222    end Normalize_Pathname;
2223
2224    ---------------
2225    -- Open_Read --
2226    ---------------
2227
2228    function Open_Read
2229      (Name  : C_File_Name;
2230       Fmode : Mode) return File_Descriptor
2231    is
2232       function C_Open_Read
2233         (Name  : C_File_Name;
2234          Fmode : Mode) return File_Descriptor;
2235       pragma Import (C, C_Open_Read, "__gnat_open_read");
2236    begin
2237       return C_Open_Read (Name, Fmode);
2238    end Open_Read;
2239
2240    function Open_Read
2241      (Name  : String;
2242       Fmode : Mode) return File_Descriptor
2243    is
2244       C_Name : String (1 .. Name'Length + 1);
2245    begin
2246       C_Name (1 .. Name'Length) := Name;
2247       C_Name (C_Name'Last)      := ASCII.NUL;
2248       return Open_Read (C_Name (C_Name'First)'Address, Fmode);
2249    end Open_Read;
2250
2251    ---------------------
2252    -- Open_Read_Write --
2253    ---------------------
2254
2255    function Open_Read_Write
2256      (Name  : C_File_Name;
2257       Fmode : Mode) return File_Descriptor
2258    is
2259       function C_Open_Read_Write
2260         (Name  : C_File_Name;
2261          Fmode : Mode) return File_Descriptor;
2262       pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
2263    begin
2264       return C_Open_Read_Write (Name, Fmode);
2265    end Open_Read_Write;
2266
2267    function Open_Read_Write
2268      (Name  : String;
2269       Fmode : Mode) return File_Descriptor
2270    is
2271       C_Name : String (1 .. Name'Length + 1);
2272    begin
2273       C_Name (1 .. Name'Length) := Name;
2274       C_Name (C_Name'Last)      := ASCII.NUL;
2275       return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
2276    end Open_Read_Write;
2277
2278    -------------
2279    -- OS_Exit --
2280    -------------
2281
2282    procedure OS_Exit (Status : Integer) is
2283    begin
2284       OS_Exit_Ptr (Status);
2285       raise Program_Error;
2286    end OS_Exit;
2287
2288    ---------------------
2289    -- OS_Exit_Default --
2290    ---------------------
2291
2292    procedure OS_Exit_Default (Status : Integer) is
2293       procedure GNAT_OS_Exit (Status : Integer);
2294       pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit");
2295       pragma No_Return (GNAT_OS_Exit);
2296    begin
2297       GNAT_OS_Exit (Status);
2298    end OS_Exit_Default;
2299
2300    --------------------
2301    -- Pid_To_Integer --
2302    --------------------
2303
2304    function Pid_To_Integer (Pid : Process_Id) return Integer is
2305    begin
2306       return Integer (Pid);
2307    end Pid_To_Integer;
2308
2309    ----------
2310    -- Read --
2311    ----------
2312
2313    function Read
2314      (FD : File_Descriptor;
2315       A  : System.Address;
2316       N  : Integer) return Integer
2317    is
2318    begin
2319       return
2320         Integer (System.CRTL.read
2321                    (System.CRTL.int (FD),
2322                     System.CRTL.chars (A),
2323                     System.CRTL.size_t (N)));
2324    end Read;
2325
2326    -----------------
2327    -- Rename_File --
2328    -----------------
2329
2330    procedure Rename_File
2331      (Old_Name : C_File_Name;
2332       New_Name : C_File_Name;
2333       Success  : out Boolean)
2334    is
2335       function rename (From, To : Address) return Integer;
2336       pragma Import (C, rename, "__gnat_rename");
2337       R : Integer;
2338    begin
2339       R := rename (Old_Name, New_Name);
2340       Success := (R = 0);
2341    end Rename_File;
2342
2343    procedure Rename_File
2344      (Old_Name : String;
2345       New_Name : String;
2346       Success  : out Boolean)
2347    is
2348       C_Old_Name : String (1 .. Old_Name'Length + 1);
2349       C_New_Name : String (1 .. New_Name'Length + 1);
2350    begin
2351       C_Old_Name (1 .. Old_Name'Length) := Old_Name;
2352       C_Old_Name (C_Old_Name'Last)      := ASCII.NUL;
2353       C_New_Name (1 .. New_Name'Length) := New_Name;
2354       C_New_Name (C_New_Name'Last)      := ASCII.NUL;
2355       Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
2356    end Rename_File;
2357
2358    -----------------------
2359    -- Set_Close_On_Exec --
2360    -----------------------
2361
2362    procedure Set_Close_On_Exec
2363      (FD            : File_Descriptor;
2364       Close_On_Exec : Boolean;
2365       Status        : out Boolean)
2366    is
2367       function C_Set_Close_On_Exec
2368         (FD : File_Descriptor; Close_On_Exec : System.CRTL.int)
2369          return System.CRTL.int;
2370       pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
2371    begin
2372       Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0;
2373    end Set_Close_On_Exec;
2374
2375    --------------------
2376    -- Set_Executable --
2377    --------------------
2378
2379    procedure Set_Executable (Name : String) is
2380       procedure C_Set_Executable (Name : C_File_Name);
2381       pragma Import (C, C_Set_Executable, "__gnat_set_executable");
2382       C_Name : aliased String (Name'First .. Name'Last + 1);
2383    begin
2384       C_Name (Name'Range)  := Name;
2385       C_Name (C_Name'Last) := ASCII.NUL;
2386       C_Set_Executable (C_Name (C_Name'First)'Address);
2387    end Set_Executable;
2388
2389    ----------------------
2390    -- Set_Non_Readable --
2391    ----------------------
2392
2393    procedure Set_Non_Readable (Name : String) is
2394       procedure C_Set_Non_Readable (Name : C_File_Name);
2395       pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable");
2396       C_Name : aliased String (Name'First .. Name'Last + 1);
2397    begin
2398       C_Name (Name'Range)  := Name;
2399       C_Name (C_Name'Last) := ASCII.NUL;
2400       C_Set_Non_Readable (C_Name (C_Name'First)'Address);
2401    end Set_Non_Readable;
2402
2403    ----------------------
2404    -- Set_Non_Writable --
2405    ----------------------
2406
2407    procedure Set_Non_Writable (Name : String) is
2408       procedure C_Set_Non_Writable (Name : C_File_Name);
2409       pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable");
2410       C_Name : aliased String (Name'First .. Name'Last + 1);
2411    begin
2412       C_Name (Name'Range)  := Name;
2413       C_Name (C_Name'Last) := ASCII.NUL;
2414       C_Set_Non_Writable (C_Name (C_Name'First)'Address);
2415    end Set_Non_Writable;
2416
2417    ------------------
2418    -- Set_Readable --
2419    ------------------
2420
2421    procedure Set_Readable (Name : String) is
2422       procedure C_Set_Readable (Name : C_File_Name);
2423       pragma Import (C, C_Set_Readable, "__gnat_set_readable");
2424       C_Name : aliased String (Name'First .. Name'Last + 1);
2425    begin
2426       C_Name (Name'Range)  := Name;
2427       C_Name (C_Name'Last) := ASCII.NUL;
2428       C_Set_Readable (C_Name (C_Name'First)'Address);
2429    end Set_Readable;
2430
2431    --------------------
2432    -- Set_Writable --
2433    --------------------
2434
2435    procedure Set_Writable (Name : String) is
2436       procedure C_Set_Writable (Name : C_File_Name);
2437       pragma Import (C, C_Set_Writable, "__gnat_set_writable");
2438       C_Name : aliased String (Name'First .. Name'Last + 1);
2439    begin
2440       C_Name (Name'Range)  := Name;
2441       C_Name (C_Name'Last) := ASCII.NUL;
2442       C_Set_Writable (C_Name (C_Name'First)'Address);
2443    end Set_Writable;
2444
2445    ------------
2446    -- Setenv --
2447    ------------
2448
2449    procedure Setenv (Name : String; Value : String) is
2450       F_Name  : String (1 .. Name'Length + 1);
2451       F_Value : String (1 .. Value'Length + 1);
2452
2453       procedure Set_Env_Value (Name, Value : System.Address);
2454       pragma Import (C, Set_Env_Value, "__gnat_setenv");
2455
2456    begin
2457       F_Name (1 .. Name'Length) := Name;
2458       F_Name (F_Name'Last)      := ASCII.NUL;
2459
2460       F_Value (1 .. Value'Length) := Value;
2461       F_Value (F_Value'Last)      := ASCII.NUL;
2462
2463       Set_Env_Value (F_Name'Address, F_Value'Address);
2464    end Setenv;
2465
2466    -----------
2467    -- Spawn --
2468    -----------
2469
2470    function Spawn
2471      (Program_Name : String;
2472       Args         : Argument_List) return Integer
2473    is
2474       Result : Integer;
2475       Junk   : Process_Id;
2476       pragma Warnings (Off, Junk);
2477    begin
2478       Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
2479       return Result;
2480    end Spawn;
2481
2482    procedure Spawn
2483      (Program_Name : String;
2484       Args         : Argument_List;
2485       Success      : out Boolean)
2486    is
2487    begin
2488       Success := (Spawn (Program_Name, Args) = 0);
2489    end Spawn;
2490
2491    procedure Spawn
2492      (Program_Name           : String;
2493       Args                   : Argument_List;
2494       Output_File_Descriptor : File_Descriptor;
2495       Return_Code            : out Integer;
2496       Err_To_Out             : Boolean := True)
2497    is
2498       Saved_Output : File_Descriptor;
2499       Saved_Error  : File_Descriptor := Invalid_FD; -- prevent compiler warning
2500
2501    begin
2502       --  Set standard output and error to the temporary file
2503
2504       Saved_Output := Dup (Standout);
2505       Dup2 (Output_File_Descriptor, Standout);
2506
2507       if Err_To_Out then
2508          Saved_Error  := Dup (Standerr);
2509          Dup2 (Output_File_Descriptor, Standerr);
2510       end if;
2511
2512       --  Spawn the program
2513
2514       Return_Code := Spawn (Program_Name, Args);
2515
2516       --  Restore the standard output and error
2517
2518       Dup2 (Saved_Output, Standout);
2519
2520       if Err_To_Out then
2521          Dup2 (Saved_Error, Standerr);
2522       end if;
2523
2524       --  And close the saved standard output and error file descriptors
2525
2526       Close (Saved_Output);
2527
2528       if Err_To_Out then
2529          Close (Saved_Error);
2530       end if;
2531    end Spawn;
2532
2533    procedure Spawn
2534      (Program_Name : String;
2535       Args         : Argument_List;
2536       Output_File  : String;
2537       Success      : out Boolean;
2538       Return_Code  : out Integer;
2539       Err_To_Out   : Boolean := True)
2540    is
2541       FD : File_Descriptor;
2542
2543    begin
2544       Success := True;
2545       Return_Code := 0;
2546
2547       FD := Create_Output_Text_File (Output_File);
2548
2549       if FD = Invalid_FD then
2550          Success := False;
2551          return;
2552       end if;
2553
2554       Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out);
2555
2556       Close (FD, Success);
2557    end Spawn;
2558
2559    --------------------
2560    -- Spawn_Internal --
2561    --------------------
2562
2563    procedure Spawn_Internal
2564      (Program_Name : String;
2565       Args         : Argument_List;
2566       Result       : out Integer;
2567       Pid          : out Process_Id;
2568       Blocking     : Boolean)
2569    is
2570
2571       procedure Spawn (Args : Argument_List);
2572       --  Call Spawn with given argument list
2573
2574       N_Args : Argument_List (Args'Range);
2575       --  Normalized arguments
2576
2577       -----------
2578       -- Spawn --
2579       -----------
2580
2581       procedure Spawn (Args : Argument_List) is
2582          type Chars is array (Positive range <>) of aliased Character;
2583          type Char_Ptr is access constant Character;
2584
2585          Command_Len  : constant Positive := Program_Name'Length + 1
2586                                                + Args_Length (Args);
2587          Command_Last : Natural := 0;
2588          Command      : aliased Chars (1 .. Command_Len);
2589          --  Command contains all characters of the Program_Name and Args, all
2590          --  terminated by ASCII.NUL characters.
2591
2592          Arg_List_Len  : constant Positive := Args'Length + 2;
2593          Arg_List_Last : Natural := 0;
2594          Arg_List      : aliased array (1 .. Arg_List_Len) of Char_Ptr;
2595          --  List with pointers to NUL-terminated strings of the Program_Name
2596          --  and the Args and terminated with a null pointer. We rely on the
2597          --  default initialization for the last null pointer.
2598
2599          procedure Add_To_Command (S : String);
2600          --  Add S and a NUL character to Command, updating Last
2601
2602          function Portable_Spawn (Args : Address) return Integer;
2603          pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
2604
2605          function Portable_No_Block_Spawn (Args : Address) return Process_Id;
2606          pragma Import
2607            (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
2608
2609          --------------------
2610          -- Add_To_Command --
2611          --------------------
2612
2613          procedure Add_To_Command (S : String) is
2614             First : constant Natural := Command_Last + 1;
2615
2616          begin
2617             Command_Last := Command_Last + S'Length;
2618
2619             --  Move characters one at a time, because Command has aliased
2620             --  components.
2621
2622             --  But not volatile, so why is this necessary ???
2623
2624             for J in S'Range loop
2625                Command (First + J - S'First) := S (J);
2626             end loop;
2627
2628             Command_Last := Command_Last + 1;
2629             Command (Command_Last) := ASCII.NUL;
2630
2631             Arg_List_Last := Arg_List_Last + 1;
2632             Arg_List (Arg_List_Last) := Command (First)'Access;
2633          end Add_To_Command;
2634
2635       --  Start of processing for Spawn
2636
2637       begin
2638          Add_To_Command (Program_Name);
2639
2640          for J in Args'Range loop
2641             Add_To_Command (Args (J).all);
2642          end loop;
2643
2644          if Blocking then
2645             Pid     := Invalid_Pid;
2646             Result  := Portable_Spawn (Arg_List'Address);
2647          else
2648             Pid     := Portable_No_Block_Spawn (Arg_List'Address);
2649             Result  := Boolean'Pos (Pid /= Invalid_Pid);
2650          end if;
2651       end Spawn;
2652
2653    --  Start of processing for Spawn_Internal
2654
2655    begin
2656       --  Copy arguments into a local structure
2657
2658       for K in N_Args'Range loop
2659          N_Args (K) := new String'(Args (K).all);
2660       end loop;
2661
2662       --  Normalize those arguments
2663
2664       Normalize_Arguments (N_Args);
2665
2666       --  Call spawn using the normalized arguments
2667
2668       Spawn (N_Args);
2669
2670       --  Free arguments list
2671
2672       for K in N_Args'Range loop
2673          Free (N_Args (K));
2674       end loop;
2675    end Spawn_Internal;
2676
2677    ---------------------------
2678    -- To_Path_String_Access --
2679    ---------------------------
2680
2681    function To_Path_String_Access
2682      (Path_Addr : Address;
2683       Path_Len  : Integer) return String_Access
2684    is
2685       subtype Path_String is String (1 .. Path_Len);
2686       type    Path_String_Access is access Path_String;
2687
2688       function Address_To_Access is new Ada.Unchecked_Conversion
2689         (Source => Address, Target => Path_String_Access);
2690
2691       Path_Access : constant Path_String_Access :=
2692                       Address_To_Access (Path_Addr);
2693
2694       Return_Val  : String_Access;
2695
2696    begin
2697       Return_Val := new String (1 .. Path_Len);
2698
2699       for J in 1 .. Path_Len loop
2700          Return_Val (J) := Path_Access (J);
2701       end loop;
2702
2703       return Return_Val;
2704    end To_Path_String_Access;
2705
2706    ------------------
2707    -- Wait_Process --
2708    ------------------
2709
2710    procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
2711       Status : Integer;
2712
2713       function Portable_Wait (S : Address) return Process_Id;
2714       pragma Import (C, Portable_Wait, "__gnat_portable_wait");
2715
2716    begin
2717       Pid := Portable_Wait (Status'Address);
2718       Success := (Status = 0);
2719    end Wait_Process;
2720
2721    -----------
2722    -- Write --
2723    -----------
2724
2725    function Write
2726      (FD : File_Descriptor;
2727       A  : System.Address;
2728       N  : Integer) return Integer
2729    is
2730    begin
2731       return
2732         Integer (System.CRTL.write
2733                    (System.CRTL.int (FD),
2734                     System.CRTL.chars (A),
2735                     System.CRTL.size_t (N)));
2736    end Write;
2737
2738 end System.OS_Lib;