gcc/ada/g-os_lib.adb

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