1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . O S _ L I B --
9 -- Copyright (C) 1995-2018, AdaCore --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 pragma Compiler_Unit_Warning
;
34 with Ada
.Unchecked_Conversion
;
35 with Ada
.Unchecked_Deallocation
;
36 with System
; use System
;
37 with System
.Case_Util
;
39 with System
.Soft_Links
;
41 package body System
.OS_Lib
is
43 subtype size_t
is CRTL
.size_t
;
45 procedure Strncpy
(dest
, src
: System
.Address
; n
: size_t
)
48 -- Imported procedures Dup and Dup2 are used in procedures Spawn and
49 -- Non_Blocking_Spawn.
51 function Dup
(Fd
: File_Descriptor
) return File_Descriptor
;
52 pragma Import
(C
, Dup
, "__gnat_dup");
54 procedure Dup2
(Old_Fd
, New_Fd
: File_Descriptor
);
55 pragma Import
(C
, Dup2
, "__gnat_dup2");
57 function Copy_Attributes
58 (From
: System
.Address
;
60 Mode
: Integer) return Integer;
61 pragma Import
(C
, Copy_Attributes
, "__gnat_copy_attribs");
62 -- Mode = 0 - copy only time stamps.
63 -- Mode = 1 - copy time stamps and read/write/execute attributes
64 -- Mode = 2 - copy read/write/execute attributes
66 On_Windows
: constant Boolean := Directory_Separator
= '\';
67 -- An indication that we are on Windows. Used in Normalize_Pathname, to
68 -- deal with drive letters in the beginning of absolute paths.
70 package SSL
renames System
.Soft_Links
;
72 -- The following are used by Create_Temp_File
74 First_Temp_File_Name
: constant String := "GNAT-TEMP-000000.TMP";
75 -- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit
77 Current_Temp_File_Name
: String := First_Temp_File_Name
;
78 -- Name of the temp file last created
80 Temp_File_Name_Last_Digit
: constant Positive :=
81 First_Temp_File_Name
'Last - 4;
82 -- Position of the last digit in Current_Temp_File_Name
84 Max_Attempts
: constant := 100;
85 -- The maximum number of attempts to create a new temp file
87 -----------------------
88 -- Local Subprograms --
89 -----------------------
91 function Args_Length
(Args
: Argument_List
) return Natural;
92 -- Returns total number of characters needed to create a string of all Args
93 -- terminated by ASCII.NUL characters.
95 procedure Create_Temp_File_Internal
96 (FD
: out File_Descriptor
;
97 Name
: out String_Access
;
99 -- Internal routine to implement two Create_Temp_File routines. If Stdout
100 -- is set to True the created descriptor is stdout-compatible, otherwise
101 -- it might not be depending on the OS. The first two parameters are as
102 -- in Create_Temp_File.
104 function C_String_Length
(S
: Address
) return Integer;
105 -- Returns the length of C (null-terminated) string at S, or 0 for
108 procedure Spawn_Internal
109 (Program_Name
: String;
110 Args
: Argument_List
;
111 Result
: out Integer;
112 Pid
: out Process_Id
;
114 -- Internal routine to implement the two Spawn (blocking/non blocking)
115 -- routines. If Blocking is set to True then the spawn is blocking
116 -- otherwise it is non blocking. In this latter case the Pid contains the
117 -- process id number. The first three parameters are as in Spawn. Note that
118 -- Spawn_Internal normalizes the argument list before calling the low level
119 -- system spawn routines (see Normalize_Arguments).
121 -- Note: Normalize_Arguments is designed to do nothing if it is called more
122 -- than once, so calling Normalize_Arguments before calling one of the
123 -- spawn routines is fine.
125 function To_Path_String_Access
126 (Path_Addr
: Address
;
127 Path_Len
: Integer) return String_Access
;
128 -- Converts a C String to an Ada String. We could do this making use of
129 -- Interfaces.C.Strings but we prefer not to import that entire package
135 function "<" (X
, Y
: OS_Time
) return Boolean is
137 return Long_Integer (X
) < Long_Integer (Y
);
144 function "<=" (X
, Y
: OS_Time
) return Boolean is
146 return Long_Integer (X
) <= Long_Integer (Y
);
153 function ">" (X
, Y
: OS_Time
) return Boolean is
155 return Long_Integer (X
) > Long_Integer (Y
);
162 function ">=" (X
, Y
: OS_Time
) return Boolean is
164 return Long_Integer (X
) >= Long_Integer (Y
);
171 function Args_Length
(Args
: Argument_List
) return Natural is
175 for J
in Args
'Range loop
176 Len
:= Len
+ Args
(J
)'Length + 1; -- One extra for ASCII.NUL
182 -----------------------------
183 -- Argument_String_To_List --
184 -----------------------------
186 function Argument_String_To_List
187 (Arg_String
: String) return Argument_List_Access
189 Max_Args
: constant Integer := Arg_String
'Length;
190 New_Argv
: Argument_List
(1 .. Max_Args
);
192 New_Argc
: Natural := 0;
194 Cleaned
: String (1 .. Arg_String
'Length);
195 Cleaned_Idx
: Natural;
196 -- A cleaned up version of the argument. This function is taking
197 -- backslash escapes when computing the bounds for arguments. It is
198 -- then removing the extra backslashes from the argument.
200 Backslash_Is_Sep
: constant Boolean := Directory_Separator
= '\';
201 -- Whether '\' is a directory separator (as on Windows), or a way to
202 -- quote special characters.
205 Idx
:= Arg_String
'First;
208 exit when Idx
> Arg_String
'Last;
211 Backqd
: Boolean := False;
212 Quoted
: Boolean := False;
215 Cleaned_Idx
:= Cleaned
'First;
218 -- An unquoted space is the end of an argument
220 if not (Backqd
or Quoted
)
221 and then Arg_String
(Idx
) = ' '
225 -- Start of a quoted string
227 elsif not (Backqd
or Quoted
)
228 and then Arg_String
(Idx
) = '"'
231 Cleaned
(Cleaned_Idx
) := Arg_String
(Idx
);
232 Cleaned_Idx
:= Cleaned_Idx
+ 1;
234 -- End of a quoted string and end of an argument
236 elsif (Quoted
and not Backqd
)
237 and then Arg_String
(Idx
) = '"'
239 Cleaned
(Cleaned_Idx
) := Arg_String
(Idx
);
240 Cleaned_Idx
:= Cleaned_Idx
+ 1;
244 -- Turn off backquoting after advancing one character
248 Cleaned
(Cleaned_Idx
) := Arg_String
(Idx
);
249 Cleaned_Idx
:= Cleaned_Idx
+ 1;
251 -- Following character is backquoted
253 elsif not Backslash_Is_Sep
and then Arg_String
(Idx
) = '\' then
257 Cleaned
(Cleaned_Idx
) := Arg_String
(Idx
);
258 Cleaned_Idx
:= Cleaned_Idx
+ 1;
262 exit when Idx
> Arg_String
'Last;
267 New_Argc
:= New_Argc
+ 1;
268 New_Argv
(New_Argc
) :=
269 new String'(Cleaned (Cleaned'First .. Cleaned_Idx - 1));
271 -- Skip extraneous spaces
273 while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop
279 return new Argument_List'(New_Argv
(1 .. New_Argc
));
280 end Argument_String_To_List
;
282 ---------------------
283 -- C_String_Length --
284 ---------------------
286 function C_String_Length
(S
: Address
) return Integer is
288 if S
= Null_Address
then
291 return Integer (CRTL
.strlen
(S
));
299 procedure Close
(FD
: File_Descriptor
) is
301 Discard
: constant int
:= close
(int
(FD
));
306 procedure Close
(FD
: File_Descriptor
; Status
: out Boolean) is
309 Status
:= (close
(int
(FD
)) = 0);
319 Success
: out Boolean;
320 Mode
: Copy_Mode
:= Copy
;
321 Preserve
: Attribute
:= Time_Stamps
)
323 From
: File_Descriptor
;
324 To
: File_Descriptor
;
326 Copy_Error
: exception;
327 -- Internal exception raised to signal error in copy
329 function Build_Path
(Dir
: String; File
: String) return String;
330 -- Returns pathname Dir concatenated with File adding the directory
331 -- separator only if needed.
333 procedure Copy
(From
: File_Descriptor
; To
: File_Descriptor
);
334 -- Read data from From and place them into To. In both cases the
335 -- operations uses the current file position. Raises Constraint_Error
336 -- if a problem occurs during the copy.
338 procedure Copy_To
(To_Name
: String);
339 -- Does a straight copy from source to designated destination file
345 function Build_Path
(Dir
: String; File
: String) return String is
346 function Is_Dirsep
(C
: Character) return Boolean;
347 pragma Inline
(Is_Dirsep
);
348 -- Returns True if C is a directory separator. On Windows we
349 -- handle both styles of directory separator.
355 function Is_Dirsep
(C
: Character) return Boolean is
357 return C
= Directory_Separator
or else C
= '/';
362 Base_File_Ptr
: Integer;
363 -- The base file name is File (Base_File_Ptr + 1 .. File'Last)
365 Res
: String (1 .. Dir
'Length + File
'Length + 1);
367 -- Start of processing for Build_Path
370 -- Find base file name
372 Base_File_Ptr
:= File
'Last;
373 while Base_File_Ptr
>= File
'First loop
374 exit when Is_Dirsep
(File
(Base_File_Ptr
));
375 Base_File_Ptr
:= Base_File_Ptr
- 1;
379 Base_File
: String renames
380 File
(Base_File_Ptr
+ 1 .. File
'Last);
383 Res
(1 .. Dir
'Length) := Dir
;
385 if Is_Dirsep
(Dir
(Dir
'Last)) then
386 Res
(Dir
'Length + 1 .. Dir
'Length + Base_File
'Length) :=
388 return Res
(1 .. Dir
'Length + Base_File
'Length);
391 Res
(Dir
'Length + 1) := Directory_Separator
;
392 Res
(Dir
'Length + 2 .. Dir
'Length + 1 + Base_File
'Length) :=
394 return Res
(1 .. Dir
'Length + 1 + Base_File
'Length);
403 procedure Copy
(From
: File_Descriptor
; To
: File_Descriptor
) is
404 Buf_Size
: constant := 200_000
;
405 type Buf
is array (1 .. Buf_Size
) of Character;
406 type Buf_Ptr
is access Buf
;
412 Status_From
: Boolean;
414 -- Statuses for the calls to Close
416 procedure Free
is new Ada
.Unchecked_Deallocation
(Buf
, Buf_Ptr
);
419 -- Check for invalid descriptors, making sure that we do not
420 -- accidentally leave an open file descriptor around.
422 if From
= Invalid_FD
then
423 if To
/= Invalid_FD
then
424 Close
(To
, Status_To
);
429 elsif To
= Invalid_FD
then
430 Close
(From
, Status_From
);
434 -- Allocate the buffer on the heap
439 R
:= Read
(From
, Buffer
(1)'Address, Buf_Size
);
441 -- On some systems, the buffer may not be full. So, we need to try
442 -- again until there is nothing to read.
446 W
:= Write
(To
, Buffer
(1)'Address, R
);
450 -- Problem writing data, could be a disk full. Close files
451 -- without worrying about status, since we are raising a
452 -- Copy_Error exception in any case.
454 Close
(From
, Status_From
);
455 Close
(To
, Status_To
);
463 Close
(From
, Status_From
);
464 Close
(To
, Status_To
);
468 if not (Status_From
and Status_To
) then
477 procedure Copy_To
(To_Name
: String) is
478 C_From
: String (1 .. Name
'Length + 1);
479 C_To
: String (1 .. To_Name
'Length + 1);
482 From
:= Open_Read
(Name
, Binary
);
484 -- Do not clobber destination file if source file could not be opened
486 if From
/= Invalid_FD
then
487 To
:= Create_File
(To_Name
, Binary
);
494 C_From
(1 .. Name
'Length) := Name
;
495 C_From
(C_From
'Last) := ASCII
.NUL
;
497 C_To
(1 .. To_Name
'Length) := To_Name
;
498 C_To
(C_To
'Last) := ASCII
.NUL
;
502 if Copy_Attributes
(C_From
'Address, C_To
'Address, 0) = -1 then
507 if Copy_Attributes
(C_From
'Address, C_To
'Address, 1) = -1 then
516 -- Start of processing for Copy_File
521 -- The source file must exist
523 if not Is_Regular_File
(Name
) then
527 -- The source file exists
531 -- Copy case, target file must not exist
535 -- If the target file exists, we have an error
537 if Is_Regular_File
(Pathname
) then
540 -- Case of target is a directory
542 elsif Is_Directory
(Pathname
) then
544 Dest
: constant String := Build_Path
(Pathname
, Name
);
547 -- If target file exists, we have an error, else do copy
549 if Is_Regular_File
(Dest
) then
556 -- Case of normal copy to file (destination does not exist)
562 -- Overwrite case (destination file may or may not exist)
565 if Is_Directory
(Pathname
) then
566 Copy_To
(Build_Path
(Pathname
, Name
));
571 -- Append case (destination file may or may not exist)
575 -- Appending to existing file
577 if Is_Regular_File
(Pathname
) then
579 -- Append mode and destination file exists, append data at the
580 -- end of Pathname. But if we fail to open source file, do not
581 -- touch destination file at all.
583 From
:= Open_Read
(Name
, Binary
);
584 if From
/= Invalid_FD
then
585 To
:= Open_Read_Write
(Pathname
, Binary
);
588 Lseek
(To
, 0, Seek_End
);
592 -- Appending to directory, not allowed
594 elsif Is_Directory
(Pathname
) then
597 -- Appending when target file does not exist
604 -- All error cases are caught here
613 Pathname
: C_File_Name
;
614 Success
: out Boolean;
615 Mode
: Copy_Mode
:= Copy
;
616 Preserve
: Attribute
:= Time_Stamps
)
618 Ada_Name
: String_Access
:=
619 To_Path_String_Access
620 (Name
, C_String_Length
(Name
));
621 Ada_Pathname
: String_Access
:=
622 To_Path_String_Access
623 (Pathname
, C_String_Length
(Pathname
));
626 Copy_File
(Ada_Name
.all, Ada_Pathname
.all, Success
, Mode
, Preserve
);
631 --------------------------
632 -- Copy_File_Attributes --
633 --------------------------
635 procedure Copy_File_Attributes
638 Success
: out Boolean;
639 Copy_Timestamp
: Boolean := True;
640 Copy_Permissions
: Boolean := True)
642 F
: aliased String (1 .. From
'Length + 1);
643 T
: aliased String (1 .. To
'Length + 1);
648 if Copy_Timestamp
then
649 if Copy_Permissions
then
655 if Copy_Permissions
then
659 return; -- nothing to do
663 F
(1 .. From
'Length) := From
;
664 F
(F
'Last) := ASCII
.NUL
;
666 T
(1 .. To
'Length) := To
;
667 T
(T
'Last) := ASCII
.NUL
;
669 Success
:= Copy_Attributes
(F
'Address, T
'Address, Mode
) /= -1;
670 end Copy_File_Attributes
;
672 ----------------------
673 -- Copy_Time_Stamps --
674 ----------------------
676 procedure Copy_Time_Stamps
679 Success
: out Boolean)
682 if Is_Regular_File
(Source
) and then Is_Writable_File
(Dest
) then
684 C_Source
: String (1 .. Source
'Length + 1);
685 C_Dest
: String (1 .. Dest
'Length + 1);
688 C_Source
(1 .. Source
'Length) := Source
;
689 C_Source
(C_Source
'Last) := ASCII
.NUL
;
691 C_Dest
(1 .. Dest
'Length) := Dest
;
692 C_Dest
(C_Dest
'Last) := ASCII
.NUL
;
694 if Copy_Attributes
(C_Source
'Address, C_Dest
'Address, 0) = -1 then
704 end Copy_Time_Stamps
;
706 procedure Copy_Time_Stamps
707 (Source
: C_File_Name
;
709 Success
: out Boolean)
711 Ada_Source
: String_Access
:=
712 To_Path_String_Access
713 (Source
, C_String_Length
(Source
));
714 Ada_Dest
: String_Access
:=
715 To_Path_String_Access
716 (Dest
, C_String_Length
(Dest
));
719 Copy_Time_Stamps
(Ada_Source
.all, Ada_Dest
.all, Success
);
722 end Copy_Time_Stamps
;
730 Fmode
: Mode
) return File_Descriptor
732 function C_Create_File
734 Fmode
: Mode
) return File_Descriptor
;
735 pragma Import
(C
, C_Create_File
, "__gnat_open_create");
737 return C_Create_File
(Name
, Fmode
);
742 Fmode
: Mode
) return File_Descriptor
744 C_Name
: String (1 .. Name
'Length + 1);
746 C_Name
(1 .. Name
'Length) := Name
;
747 C_Name
(C_Name
'Last) := ASCII
.NUL
;
748 return Create_File
(C_Name
(C_Name
'First)'Address, Fmode
);
751 ---------------------
752 -- Create_New_File --
753 ---------------------
755 function Create_New_File
757 Fmode
: Mode
) return File_Descriptor
759 function C_Create_New_File
761 Fmode
: Mode
) return File_Descriptor
;
762 pragma Import
(C
, C_Create_New_File
, "__gnat_open_new");
764 return C_Create_New_File
(Name
, Fmode
);
767 function Create_New_File
769 Fmode
: Mode
) return File_Descriptor
771 C_Name
: String (1 .. Name
'Length + 1);
773 C_Name
(1 .. Name
'Length) := Name
;
774 C_Name
(C_Name
'Last) := ASCII
.NUL
;
775 return Create_New_File
(C_Name
(C_Name
'First)'Address, Fmode
);
778 -----------------------------
779 -- Create_Output_Text_File --
780 -----------------------------
782 function Create_Output_Text_File
(Name
: String) return File_Descriptor
is
783 function C_Create_File
(Name
: C_File_Name
) return File_Descriptor
;
784 pragma Import
(C
, C_Create_File
, "__gnat_create_output_file");
786 C_Name
: String (1 .. Name
'Length + 1);
789 C_Name
(1 .. Name
'Length) := Name
;
790 C_Name
(C_Name
'Last) := ASCII
.NUL
;
791 return C_Create_File
(C_Name
(C_Name
'First)'Address);
792 end Create_Output_Text_File
;
794 ----------------------
795 -- Create_Temp_File --
796 ----------------------
798 procedure Create_Temp_File
799 (FD
: out File_Descriptor
;
800 Name
: out Temp_File_Name
)
802 function Open_New_Temp
803 (Name
: System
.Address
;
804 Fmode
: Mode
) return File_Descriptor
;
805 pragma Import
(C
, Open_New_Temp
, "__gnat_open_new_temp");
808 FD
:= Open_New_Temp
(Name
'Address, Binary
);
809 end Create_Temp_File
;
811 procedure Create_Temp_File
812 (FD
: out File_Descriptor
;
813 Name
: out String_Access
)
816 Create_Temp_File_Internal
(FD
, Name
, Stdout
=> False);
817 end Create_Temp_File
;
819 -----------------------------
820 -- Create_Temp_Output_File --
821 -----------------------------
823 procedure Create_Temp_Output_File
824 (FD
: out File_Descriptor
;
825 Name
: out String_Access
)
828 Create_Temp_File_Internal
(FD
, Name
, Stdout
=> True);
829 end Create_Temp_Output_File
;
831 -------------------------------
832 -- Create_Temp_File_Internal --
833 -------------------------------
835 procedure Create_Temp_File_Internal
836 (FD
: out File_Descriptor
;
837 Name
: out String_Access
;
841 Attempts
: Natural := 0;
842 Current
: String (Current_Temp_File_Name
'Range);
844 function Create_New_Output_Text_File
845 (Name
: String) return File_Descriptor
;
846 -- Similar to Create_Output_Text_File, except it fails if the file
847 -- already exists. We need this behavior to ensure we don't accidentally
848 -- open a temp file that has just been created by a concurrently running
849 -- process. There is no point exposing this function, as it's generally
850 -- not particularly useful.
852 ---------------------------------
853 -- Create_New_Output_Text_File --
854 ---------------------------------
856 function Create_New_Output_Text_File
857 (Name
: String) return File_Descriptor
859 function C_Create_File
(Name
: C_File_Name
) return File_Descriptor
;
860 pragma Import
(C
, C_Create_File
, "__gnat_create_output_file_new");
862 C_Name
: String (1 .. Name
'Length + 1);
865 C_Name
(1 .. Name
'Length) := Name
;
866 C_Name
(C_Name
'Last) := ASCII
.NUL
;
867 return C_Create_File
(C_Name
(C_Name
'First)'Address);
868 end Create_New_Output_Text_File
;
870 -- Start of processing for Create_Temp_File_Internal
873 -- Loop until a new temp file can be created
878 -- We need to protect global variable Current_Temp_File_Name
879 -- against concurrent access by different tasks.
883 -- Start at the last digit
885 Pos
:= Temp_File_Name_Last_Digit
;
889 -- Increment the digit by one
891 case Current_Temp_File_Name
(Pos
) is
893 Current_Temp_File_Name
(Pos
) :=
894 Character'Succ (Current_Temp_File_Name
(Pos
));
899 -- For 9, set the digit to 0 and go to the previous digit
901 Current_Temp_File_Name
(Pos
) := '0';
906 -- If it is not a digit, then there are no available
907 -- temp file names. Return Invalid_FD. There is almost no
908 -- chance that this code will be ever be executed, since
909 -- it would mean that there are one million temp files in
910 -- the same directory.
919 Current
:= Current_Temp_File_Name
;
921 -- We can now release the lock, because we are no longer accessing
922 -- Current_Temp_File_Name.
932 -- Attempt to create the file
935 FD
:= Create_New_Output_Text_File
(Current
);
937 FD
:= Create_New_File
(Current
, Binary
);
940 if FD
/= Invalid_FD
then
941 Name
:= new String'(Current);
945 if not Is_Regular_File (Current) then
947 -- If the file does not already exist and we are unable to create
948 -- it, we give up after Max_Attempts. Otherwise, we try again with
949 -- the next available file name.
951 Attempts := Attempts + 1;
953 if Attempts >= Max_Attempts then
960 end Create_Temp_File_Internal;
962 -------------------------
963 -- Current_Time_String --
964 -------------------------
966 function Current_Time_String return String is
967 subtype S23 is String (1 .. 23);
968 -- Holds current time in ISO 8601 format YYYY-MM-DD HH:MM:SS.SS + NUL
970 procedure Current_Time_String (Time : System.Address);
971 pragma Import (C, Current_Time_String, "__gnat_current_time_string");
972 -- Puts current time into Time in above ISO 8601 format
974 Result23 : aliased S23;
975 -- Current time in ISO 8601 format
978 Current_Time_String (Result23'Address);
979 return Result23 (1 .. 19);
980 end Current_Time_String;
986 procedure Delete_File (Name : Address; Success : out Boolean) is
989 R := System.CRTL.unlink (Name);
993 procedure Delete_File (Name : String; Success : out Boolean) is
994 C_Name : String (1 .. Name'Length + 1);
996 C_Name (1 .. Name'Length) := Name;
997 C_Name (C_Name'Last) := ASCII.NUL;
998 Delete_File (C_Name'Address, Success);
1005 function Errno_Message
1006 (Err : Integer := Errno;
1007 Default : String := "") return String
1009 function strerror (errnum : Integer) return System.Address;
1010 pragma Import (C, strerror, "strerror");
1012 C_Msg : constant System.Address := strerror (Err);
1015 if C_Msg = Null_Address then
1016 if Default /= "" then
1020 -- Note: for bootstrap reasons, it is impractical
1021 -- to use Integer'Image here.
1027 Buf : String (1 .. 20);
1028 -- Buffer large enough to hold image of largest Integer values
1035 Character'Val (Character'Pos ('0') + Val mod 10);
1046 return "errno = " & Buf (First .. Buf'Last);
1052 Msg : String (1 .. Integer (CRTL.strlen (C_Msg)));
1053 for Msg'Address use C_Msg;
1054 pragma Import (Ada, Msg);
1061 ---------------------
1062 -- File_Time_Stamp --
1063 ---------------------
1065 function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
1066 function File_Time (FD : File_Descriptor) return OS_Time;
1067 pragma Import (C, File_Time, "__gnat_file_time_fd");
1069 return File_Time (FD);
1070 end File_Time_Stamp;
1072 function File_Time_Stamp (Name : C_File_Name) return OS_Time is
1073 function File_Time (Name : Address) return OS_Time;
1074 pragma Import (C, File_Time, "__gnat_file_time_name");
1076 return File_Time (Name);
1077 end File_Time_Stamp;
1079 function File_Time_Stamp (Name : String) return OS_Time is
1080 F_Name : String (1 .. Name'Length + 1);
1082 F_Name (1 .. Name'Length) := Name;
1083 F_Name (F_Name'Last) := ASCII.NUL;
1084 return File_Time_Stamp (F_Name'Address);
1085 end File_Time_Stamp;
1087 ---------------------------
1088 -- Get_Debuggable_Suffix --
1089 ---------------------------
1091 function Get_Debuggable_Suffix return String_Access is
1092 procedure Get_Suffix_Ptr (Length, Ptr : Address);
1093 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
1095 Result : String_Access;
1096 Suffix_Length : Integer;
1097 Suffix_Ptr : Address;
1100 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
1101 Result := new String (1 .. Suffix_Length);
1103 if Suffix_Length > 0 then
1104 Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
1108 end Get_Debuggable_Suffix;
1110 ---------------------------
1111 -- Get_Executable_Suffix --
1112 ---------------------------
1114 function Get_Executable_Suffix return String_Access is
1115 procedure Get_Suffix_Ptr (Length, Ptr : Address);
1116 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
1118 Result : String_Access;
1119 Suffix_Length : Integer;
1120 Suffix_Ptr : Address;
1123 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
1124 Result := new String (1 .. Suffix_Length);
1126 if Suffix_Length > 0 then
1127 Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
1131 end Get_Executable_Suffix;
1133 -----------------------
1134 -- Get_Object_Suffix --
1135 -----------------------
1137 function Get_Object_Suffix return String_Access is
1138 procedure Get_Suffix_Ptr (Length, Ptr : Address);
1139 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
1141 Result : String_Access;
1142 Suffix_Length : Integer;
1143 Suffix_Ptr : Address;
1146 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
1147 Result := new String (1 .. Suffix_Length);
1149 if Suffix_Length > 0 then
1150 Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
1154 end Get_Object_Suffix;
1156 ----------------------------------
1157 -- Get_Target_Debuggable_Suffix --
1158 ----------------------------------
1160 function Get_Target_Debuggable_Suffix return String_Access is
1161 Target_Exec_Ext_Ptr : Address;
1163 (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension");
1165 Result : String_Access;
1166 Suffix_Length : Integer;
1169 Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr));
1170 Result := new String (1 .. Suffix_Length);
1172 if Suffix_Length > 0 then
1174 (Result.all'Address, Target_Exec_Ext_Ptr, size_t (Suffix_Length));
1178 end Get_Target_Debuggable_Suffix;
1180 ----------------------------------
1181 -- Get_Target_Executable_Suffix --
1182 ----------------------------------
1184 function Get_Target_Executable_Suffix return String_Access is
1185 Target_Exec_Ext_Ptr : Address;
1187 (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension");
1189 Result : String_Access;
1190 Suffix_Length : Integer;
1193 Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr));
1194 Result := new String (1 .. Suffix_Length);
1196 if Suffix_Length > 0 then
1198 (Result.all'Address, Target_Exec_Ext_Ptr, size_t (Suffix_Length));
1202 end Get_Target_Executable_Suffix;
1204 ------------------------------
1205 -- Get_Target_Object_Suffix --
1206 ------------------------------
1208 function Get_Target_Object_Suffix return String_Access is
1209 Target_Object_Ext_Ptr : Address;
1211 (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension");
1213 Result : String_Access;
1214 Suffix_Length : Integer;
1217 Suffix_Length := Integer (CRTL.strlen (Target_Object_Ext_Ptr));
1218 Result := new String (1 .. Suffix_Length);
1220 if Suffix_Length > 0 then
1222 (Result.all'Address, Target_Object_Ext_Ptr, size_t (Suffix_Length));
1226 end Get_Target_Object_Suffix;
1232 function Getenv (Name : String) return String_Access is
1233 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
1234 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
1236 Env_Value_Ptr : aliased Address;
1237 Env_Value_Length : aliased Integer;
1238 F_Name : aliased String (1 .. Name'Length + 1);
1239 Result : String_Access;
1242 F_Name (1 .. Name'Length) := Name;
1243 F_Name (F_Name'Last) := ASCII.NUL;
1246 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
1248 Result := new String (1 .. Env_Value_Length);
1250 if Env_Value_Length > 0 then
1252 (Result.all'Address, Env_Value_Ptr, size_t (Env_Value_Length));
1262 function GM_Day (Date : OS_Time) return Day_Type is
1270 pragma Unreferenced (Y, Mo, H, Mn, S);
1273 GM_Split (Date, Y, Mo, D, H, Mn, S);
1281 function GM_Hour (Date : OS_Time) return Hour_Type is
1289 pragma Unreferenced (Y, Mo, D, Mn, S);
1292 GM_Split (Date, Y, Mo, D, H, Mn, S);
1300 function GM_Minute (Date : OS_Time) return Minute_Type is
1308 pragma Unreferenced (Y, Mo, D, H, S);
1311 GM_Split (Date, Y, Mo, D, H, Mn, S);
1319 function GM_Month (Date : OS_Time) return Month_Type is
1327 pragma Unreferenced (Y, D, H, Mn, S);
1330 GM_Split (Date, Y, Mo, D, H, Mn, S);
1338 function GM_Second (Date : OS_Time) return Second_Type is
1346 pragma Unreferenced (Y, Mo, D, H, Mn);
1349 GM_Split (Date, Y, Mo, D, H, Mn, S);
1359 Year : out Year_Type;
1360 Month : out Month_Type;
1362 Hour : out Hour_Type;
1363 Minute : out Minute_Type;
1364 Second : out Second_Type)
1366 procedure To_GM_Time
1367 (P_Time_T : Address;
1374 pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
1376 T : OS_Time := Date;
1385 -- Use the global lock because To_GM_Time is not thread safe
1387 Locked_Processing : begin
1390 (P_Time_T => T'Address,
1391 P_Year => Y'Address,
1392 P_Month => Mo'Address,
1394 P_Hours => H'Address,
1395 P_Mins => Mn'Address,
1396 P_Secs => S'Address);
1397 SSL.Unlock_Task.all;
1401 SSL.Unlock_Task.all;
1403 end Locked_Processing;
1422 Minute : Minute_Type;
1423 Second : Second_Type) return OS_Time
1425 procedure To_OS_Time
1426 (P_Time_T : Address;
1433 pragma Import (C, To_OS_Time, "__gnat_to_os_time");
1439 (P_Time_T => Result'Address,
1440 P_Year => Year - 1900,
1441 P_Month => Month - 1,
1453 function GM_Year (Date : OS_Time) return Year_Type is
1461 pragma Unreferenced (Mo, D, H, Mn, S);
1464 GM_Split (Date, Y, Mo, D, H, Mn, S);
1468 ----------------------
1469 -- Is_Absolute_Path --
1470 ----------------------
1472 function Is_Absolute_Path (Name : String) return Boolean is
1473 function Is_Absolute_Path
1475 Length : Integer) return Integer;
1476 pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
1478 return Is_Absolute_Path (Name'Address, Name'Length) /= 0;
1479 end Is_Absolute_Path;
1485 function Is_Directory (Name : C_File_Name) return Boolean is
1486 function Is_Directory (Name : Address) return Integer;
1487 pragma Import (C, Is_Directory, "__gnat_is_directory");
1489 return Is_Directory (Name) /= 0;
1492 function Is_Directory (Name : String) return Boolean is
1493 F_Name : String (1 .. Name'Length + 1);
1495 F_Name (1 .. Name'Length) := Name;
1496 F_Name (F_Name'Last) := ASCII.NUL;
1497 return Is_Directory (F_Name'Address);
1500 -----------------------------
1501 -- Is_Read_Accessible_File --
1502 -----------------------------
1504 function Is_Read_Accessible_File (Name : String) return Boolean is
1505 function Is_Read_Accessible_File (Name : Address) return Integer;
1507 (C, Is_Read_Accessible_File, "__gnat_is_read_accessible_file");
1508 F_Name : String (1 .. Name'Length + 1);
1511 F_Name (1 .. Name'Length) := Name;
1512 F_Name (F_Name'Last) := ASCII.NUL;
1513 return Is_Read_Accessible_File (F_Name'Address) /= 0;
1514 end Is_Read_Accessible_File;
1516 ----------------------------
1517 -- Is_Owner_Readable_File --
1518 ----------------------------
1520 function Is_Owner_Readable_File (Name : C_File_Name) return Boolean is
1521 function Is_Readable_File (Name : Address) return Integer;
1522 pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
1524 return Is_Readable_File (Name) /= 0;
1525 end Is_Owner_Readable_File;
1527 function Is_Owner_Readable_File (Name : String) return Boolean is
1528 F_Name : String (1 .. Name'Length + 1);
1530 F_Name (1 .. Name'Length) := Name;
1531 F_Name (F_Name'Last) := ASCII.NUL;
1532 return Is_Owner_Readable_File (F_Name'Address);
1533 end Is_Owner_Readable_File;
1535 ------------------------
1536 -- Is_Executable_File --
1537 ------------------------
1539 function Is_Executable_File (Name : C_File_Name) return Boolean is
1540 function Is_Executable_File (Name : Address) return Integer;
1541 pragma Import (C, Is_Executable_File, "__gnat_is_executable_file");
1543 return Is_Executable_File (Name) /= 0;
1544 end Is_Executable_File;
1546 function Is_Executable_File (Name : String) return Boolean is
1547 F_Name : String (1 .. Name'Length + 1);
1549 F_Name (1 .. Name'Length) := Name;
1550 F_Name (F_Name'Last) := ASCII.NUL;
1551 return Is_Executable_File (F_Name'Address);
1552 end Is_Executable_File;
1554 ---------------------
1555 -- Is_Regular_File --
1556 ---------------------
1558 function Is_Regular_File (Name : C_File_Name) return Boolean is
1559 function Is_Regular_File (Name : Address) return Integer;
1560 pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
1562 return Is_Regular_File (Name) /= 0;
1563 end Is_Regular_File;
1565 function Is_Regular_File (Name : String) return Boolean is
1566 F_Name : String (1 .. Name'Length + 1);
1568 F_Name (1 .. Name'Length) := Name;
1569 F_Name (F_Name'Last) := ASCII.NUL;
1570 return Is_Regular_File (F_Name'Address);
1571 end Is_Regular_File;
1573 ----------------------
1574 -- Is_Symbolic_Link --
1575 ----------------------
1577 function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
1578 function Is_Symbolic_Link (Name : Address) return Integer;
1579 pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
1581 return Is_Symbolic_Link (Name) /= 0;
1582 end Is_Symbolic_Link;
1584 function Is_Symbolic_Link (Name : String) return Boolean is
1585 F_Name : String (1 .. Name'Length + 1);
1587 F_Name (1 .. Name'Length) := Name;
1588 F_Name (F_Name'Last) := ASCII.NUL;
1589 return Is_Symbolic_Link (F_Name'Address);
1590 end Is_Symbolic_Link;
1592 ------------------------------
1593 -- Is_Write_Accessible_File --
1594 ------------------------------
1596 function Is_Write_Accessible_File (Name : String) return Boolean is
1597 function Is_Write_Accessible_File (Name : Address) return Integer;
1599 (C, Is_Write_Accessible_File, "__gnat_is_write_accessible_file");
1600 F_Name : String (1 .. Name'Length + 1);
1603 F_Name (1 .. Name'Length) := Name;
1604 F_Name (F_Name'Last) := ASCII.NUL;
1605 return Is_Write_Accessible_File (F_Name'Address) /= 0;
1606 end Is_Write_Accessible_File;
1608 ----------------------------
1609 -- Is_Owner_Writable_File --
1610 ----------------------------
1612 function Is_Owner_Writable_File (Name : C_File_Name) return Boolean is
1613 function Is_Writable_File (Name : Address) return Integer;
1614 pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
1616 return Is_Writable_File (Name) /= 0;
1617 end Is_Owner_Writable_File;
1619 function Is_Owner_Writable_File (Name : String) return Boolean is
1620 F_Name : String (1 .. Name'Length + 1);
1622 F_Name (1 .. Name'Length) := Name;
1623 F_Name (F_Name'Last) := ASCII.NUL;
1624 return Is_Owner_Writable_File (F_Name'Address);
1625 end Is_Owner_Writable_File;
1631 procedure Kill (Pid : Process_Id; Hard_Kill : Boolean := True) is
1632 SIGKILL : constant := 9;
1633 SIGINT : constant := 2;
1635 procedure C_Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer);
1636 pragma Import (C, C_Kill, "__gnat_kill");
1640 C_Kill (Pid, SIGKILL, 1);
1642 C_Kill (Pid, SIGINT, 1);
1646 -----------------------
1647 -- Kill_Process_Tree --
1648 -----------------------
1650 procedure Kill_Process_Tree
1651 (Pid : Process_Id; Hard_Kill : Boolean := True)
1653 SIGKILL : constant := 9;
1654 SIGINT : constant := 2;
1656 procedure C_Kill_PT (Pid : Process_Id; Sig_Num : Integer);
1657 pragma Import (C, C_Kill_PT, "__gnat_killprocesstree");
1661 C_Kill_PT (Pid, SIGKILL);
1663 C_Kill_PT (Pid, SIGINT);
1665 end Kill_Process_Tree;
1667 -------------------------
1668 -- Locate_Exec_On_Path --
1669 -------------------------
1671 function Locate_Exec_On_Path
1672 (Exec_Name : String) return String_Access
1674 function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
1675 pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
1677 C_Exec_Name : String (1 .. Exec_Name'Length + 1);
1678 Path_Addr : Address;
1680 Result : String_Access;
1683 C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name;
1684 C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL;
1686 Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
1687 Path_Len := C_String_Length (Path_Addr);
1689 if Path_Len = 0 then
1693 Result := To_Path_String_Access (Path_Addr, Path_Len);
1694 CRTL.free (Path_Addr);
1696 -- Always return an absolute path name
1698 if not Is_Absolute_Path (Result.all) then
1700 Absolute_Path : constant String :=
1701 Normalize_Pathname (Result.all, Resolve_Links => False);
1704 Result := new String'(Absolute_Path
);
1710 end Locate_Exec_On_Path
;
1712 -------------------------
1713 -- Locate_Regular_File --
1714 -------------------------
1716 function Locate_Regular_File
1717 (File_Name
: C_File_Name
;
1718 Path
: C_File_Name
) return String_Access
1720 function Locate_Regular_File
1721 (C_File_Name
, Path_Val
: Address
) return Address
;
1722 pragma Import
(C
, Locate_Regular_File
, "__gnat_locate_regular_file");
1724 Path_Addr
: Address
;
1726 Result
: String_Access
;
1729 Path_Addr
:= Locate_Regular_File
(File_Name
, Path
);
1730 Path_Len
:= C_String_Length
(Path_Addr
);
1732 if Path_Len
= 0 then
1736 Result
:= To_Path_String_Access
(Path_Addr
, Path_Len
);
1737 CRTL
.free
(Path_Addr
);
1740 end Locate_Regular_File
;
1742 function Locate_Regular_File
1743 (File_Name
: String;
1744 Path
: String) return String_Access
1746 C_File_Name
: String (1 .. File_Name
'Length + 1);
1747 C_Path
: String (1 .. Path
'Length + 1);
1748 Result
: String_Access
;
1751 C_File_Name
(1 .. File_Name
'Length) := File_Name
;
1752 C_File_Name
(C_File_Name
'Last) := ASCII
.NUL
;
1754 C_Path
(1 .. Path
'Length) := Path
;
1755 C_Path
(C_Path
'Last) := ASCII
.NUL
;
1757 Result
:= Locate_Regular_File
(C_File_Name
'Address, C_Path
'Address);
1759 -- Always return an absolute path name
1761 if Result
/= null and then not Is_Absolute_Path
(Result
.all) then
1763 Absolute_Path
: constant String := Normalize_Pathname
(Result
.all);
1766 Result
:= new String'(Absolute_Path);
1771 end Locate_Regular_File;
1773 ------------------------
1774 -- Non_Blocking_Spawn --
1775 ------------------------
1777 function Non_Blocking_Spawn
1778 (Program_Name : String;
1779 Args : Argument_List) return Process_Id
1782 pragma Warnings (Off, Junk);
1786 Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
1788 end Non_Blocking_Spawn;
1790 function Non_Blocking_Spawn
1791 (Program_Name : String;
1792 Args : Argument_List;
1793 Output_File_Descriptor : File_Descriptor;
1794 Err_To_Out : Boolean := True) return Process_Id
1797 Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning
1798 Saved_Output : File_Descriptor;
1801 if Output_File_Descriptor = Invalid_FD then
1805 -- Set standard output and, if specified, error to the temporary file
1807 Saved_Output := Dup (Standout);
1808 Dup2 (Output_File_Descriptor, Standout);
1811 Saved_Error := Dup (Standerr);
1812 Dup2 (Output_File_Descriptor, Standerr);
1815 -- Spawn the program
1817 Pid := Non_Blocking_Spawn (Program_Name, Args);
1819 -- Restore the standard output and error
1821 Dup2 (Saved_Output, Standout);
1824 Dup2 (Saved_Error, Standerr);
1827 -- And close the saved standard output and error file descriptors
1829 Close (Saved_Output);
1832 Close (Saved_Error);
1836 end Non_Blocking_Spawn;
1838 function Non_Blocking_Spawn
1839 (Program_Name : String;
1840 Args : Argument_List;
1841 Output_File : String;
1842 Err_To_Out : Boolean := True) return Process_Id
1844 Output_File_Descriptor : constant File_Descriptor :=
1845 Create_Output_Text_File (Output_File);
1846 Result : Process_Id;
1849 -- Do not attempt to spawn if the output file could not be created
1851 if Output_File_Descriptor = Invalid_FD then
1857 (Program_Name, Args, Output_File_Descriptor, Err_To_Out);
1859 -- Close the file just created for the output, as the file descriptor
1860 -- cannot be used anywhere, being a local value. It is safe to do
1861 -- that, as the file descriptor has been duplicated to form
1862 -- standard output and error of the spawned process.
1864 Close (Output_File_Descriptor);
1868 end Non_Blocking_Spawn;
1870 function Non_Blocking_Spawn
1871 (Program_Name : String;
1872 Args : Argument_List;
1873 Stdout_File : String;
1874 Stderr_File : String) return Process_Id
1876 Stderr_FD : constant File_Descriptor :=
1877 Create_Output_Text_File (Stderr_File);
1878 Stdout_FD : constant File_Descriptor :=
1879 Create_Output_Text_File (Stdout_File);
1881 Result : Process_Id;
1882 Saved_Error : File_Descriptor;
1883 Saved_Output : File_Descriptor;
1885 Dummy_Status : Boolean;
1888 -- Do not attempt to spawn if the output files could not be created
1890 if Stdout_FD = Invalid_FD or else Stderr_FD = Invalid_FD then
1894 -- Set standard output and error to the specified files
1896 Saved_Output := Dup (Standout);
1897 Dup2 (Stdout_FD, Standout);
1899 Saved_Error := Dup (Standerr);
1900 Dup2 (Stderr_FD, Standerr);
1902 Set_Close_On_Exec (Saved_Output, True, Dummy_Status);
1903 Set_Close_On_Exec (Saved_Error, True, Dummy_Status);
1905 -- Close the files just created for the output, as the file descriptors
1906 -- cannot be used anywhere, being local values. It is safe to do that,
1907 -- as the file descriptors have been duplicated to form standard output
1908 -- and standard error of the spawned process.
1913 -- Spawn the program
1915 Result := Non_Blocking_Spawn (Program_Name, Args);
1917 -- Restore the standard output and error
1919 Dup2 (Saved_Output, Standout);
1920 Dup2 (Saved_Error, Standerr);
1922 -- And close the saved standard output and error file descriptors
1924 Close (Saved_Output);
1925 Close (Saved_Error);
1928 end Non_Blocking_Spawn;
1930 -------------------------------
1931 -- Non_Blocking_Wait_Process --
1932 -------------------------------
1934 procedure Non_Blocking_Wait_Process
1935 (Pid : out Process_Id; Success : out Boolean)
1939 function Portable_No_Block_Wait (S : Address) return Process_Id;
1941 (C, Portable_No_Block_Wait, "__gnat_portable_no_block_wait");
1944 Pid := Portable_No_Block_Wait (Status'Address);
1945 Success := (Status = 0);
1950 end Non_Blocking_Wait_Process;
1952 -------------------------
1953 -- Normalize_Arguments --
1954 -------------------------
1956 procedure Normalize_Arguments (Args : in out Argument_List) is
1957 procedure Quote_Argument (Arg : in out String_Access);
1958 -- Add quote around argument if it contains spaces (or HT characters)
1960 C_Argument_Needs_Quote : Integer;
1961 pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
1962 Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
1964 --------------------
1965 -- Quote_Argument --
1966 --------------------
1968 procedure Quote_Argument (Arg : in out String_Access) is
1970 Quote_Needed : Boolean := False;
1971 Res : String (1 .. Arg'Length * 2);
1974 if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
1980 for K in Arg'Range loop
1984 if Arg (K) = '"' then
1988 Quote_Needed := True;
1990 elsif Arg (K) = ' ' or else Arg (K) = ASCII.HT then
1992 Quote_Needed := True;
1999 if Quote_Needed then
2001 -- Case of null terminated string
2003 if Res (J) = ASCII.NUL then
2005 -- If the string ends with \, double it
2007 if Res (J - 1) = '\' then
2012 -- Put a quote just before the null at the end
2016 Res (J) := ASCII.NUL;
2018 -- If argument is terminated by '\
', then double it. Otherwise
2019 -- the ending quote will be taken as-is. This is quite strange
2020 -- spawn behavior from Windows, but this is what we see.
2023 if Res (J) = '\
' then
2035 Old : String_Access := Arg;
2038 Arg := new String'(Res (1 .. J));
2046 -- Start of processing for Normalize_Arguments
2049 if Argument_Needs_Quote then
2050 for K in Args'Range loop
2051 if Args (K) /= null and then Args (K)'Length /= 0 then
2052 Quote_Argument (Args (K));
2056 end Normalize_Arguments;
2058 ------------------------
2059 -- Normalize_Pathname --
2060 ------------------------
2062 function Normalize_Pathname
2064 Directory : String := "";
2065 Resolve_Links : Boolean := True;
2066 Case_Sensitive : Boolean := True) return String
2068 procedure Get_Current_Dir
2069 (Dir : System.Address;
2070 Length : System.Address);
2071 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir
");
2073 function Get_File_Names_Case_Sensitive return Integer;
2075 (C, Get_File_Names_Case_Sensitive,
2076 "__gnat_get_file_names_case_sensitive
");
2079 pragma Import (C, Max_Path, "__gnat_max_path_len
");
2080 -- Maximum length of a path name
2083 (Path : System.Address;
2084 Buf : System.Address;
2085 Bufsiz : size_t) return Integer;
2086 pragma Import (C, Readlink, "__gnat_readlink
");
2088 Fold_To_Lower_Case : constant Boolean :=
2090 and then Get_File_Names_Case_Sensitive = 0;
2092 function Final_Value (S : String) return String;
2093 -- Make final adjustment to the returned string. This function strips
2094 -- trailing directory separators, and folds returned string to lower
2095 -- case if required.
2097 function Get_Directory (Dir : String) return String;
2098 -- If Dir is not empty, return it, adding a directory separator
2099 -- if not already present, otherwise return current working directory
2100 -- with terminating directory separator.
2106 function Final_Value (S : String) return String is
2108 -- We may need to fold S to lower case, so we need a variable
2113 if Fold_To_Lower_Case then
2114 System.Case_Util.To_Lower (S1);
2117 -- Remove trailing directory separator, if any
2122 and then (S1 (Last) = '/'
2124 S1 (Last) = Directory_Separator)
2126 -- Special case for Windows: C:\
2129 and then S1 (1) /= Directory_Separator
2130 and then S1 (2) = ':'
2139 -- And ensure that there is a trailing directory separator if the
2140 -- path contains only a drive letter.
2144 and then S1 (1) /= Directory_Separator
2145 and then S1 (2) = ':'
2147 return S1 (1 .. Last) & Directory_Separator;
2149 return S1 (1 .. Last);
2157 function Get_Directory (Dir : String) return String is
2159 -- Directory given, add directory separator if needed
2161 if Dir'Length > 0 then
2165 (Dir, "", Resolve_Links, Case_Sensitive)
2166 & Directory_Separator;
2167 Last : Positive := Result'Last - 1;
2170 -- On Windows, change all '/' to '\'
2173 for J in Result'First .. Last - 1 loop
2174 if Result (J) = '/' then
2175 Result (J) := Directory_Separator;
2180 -- Include additional directory separator, if needed
2182 if Result (Last) /= Directory_Separator then
2186 return Result (Result'First .. Last);
2189 -- Directory name not given, get current directory
2193 Buffer : String (1 .. Max_Path + 2);
2194 Path_Len : Natural := Max_Path;
2197 Get_Current_Dir (Buffer'Address, Path_Len'Address);
2199 if Path_Len = 0 then
2200 raise Program_Error;
2203 if Buffer (Path_Len) /= Directory_Separator then
2204 Path_Len := Path_Len + 1;
2205 Buffer (Path_Len) := Directory_Separator;
2208 -- By default, the drive letter on Windows is in upper case
2211 and then Path_Len >= 2
2212 and then Buffer (2) = ':'
2214 System.Case_Util.To_Upper (Buffer (1 .. 1));
2217 return Buffer (1 .. Path_Len);
2224 Max_Iterations : constant := 500;
2226 Cur_Dir : constant String := Get_Directory (Directory);
2227 Cur_Dir_Len : constant Natural := Cur_Dir'Length;
2229 End_Path : Natural := Name'Length;
2230 Last : Positive := 1;
2231 Link_Buffer : String (1 .. Max_Path + 2);
2232 Path_Buffer : String (1 .. End_Path + Cur_Dir_Len + Max_Path + 2);
2233 -- We need to potentially store in this buffer the following elements:
2234 -- the path itself, the current directory if the path is relative,
2235 -- and additional fragments up to Max_Path in length in case
2236 -- there are any symlinks.
2237 Start, Finish : Positive;
2240 -- Start of processing for Normalize_Pathname
2243 -- Special case, return null if name is null
2245 if End_Path = 0 then
2249 if Is_Absolute_Path (Name) then
2250 Path_Buffer (1 .. End_Path) := Name;
2253 -- If this is a relative pathname, prepend current directory
2254 Path_Buffer (1 .. Cur_Dir_Len) := Cur_Dir;
2255 Path_Buffer (Cur_Dir_Len + 1 .. Cur_Dir_Len + End_Path) := Name;
2256 End_Path := Cur_Dir_Len + End_Path;
2257 Last := Cur_Dir_Len;
2260 -- Special handling for Windows:
2261 -- * Replace all '/' by '\'
2262 -- * Check the drive letter
2263 -- * Remove all double-quotes
2267 -- Replace all '/' by '\'
2269 for Index in 1 .. End_Path loop
2270 if Path_Buffer (Index) = '/' then
2271 Path_Buffer (Index) := Directory_Separator;
2275 -- If we have an absolute path starting with a directory
2276 -- separator (but not a UNC path), we need to have the drive letter
2277 -- in front of the path. Get_Current_Dir returns a path starting
2278 -- with a drive letter. So we take this drive letter and prepend it
2279 -- to the current path.
2281 if Path_Buffer (1) = Directory_Separator
2282 and then Path_Buffer (2) /= Directory_Separator
2284 if Cur_Dir'Length > 2
2285 and then Cur_Dir (Cur_Dir'First + 1) = ':'
2287 Path_Buffer (3 .. End_Path + 2) :=
2288 Path_Buffer (1 .. End_Path);
2289 Path_Buffer (1 .. 2) :=
2290 Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1);
2291 End_Path := End_Path + 2;
2294 -- We have a drive letter already, ensure it is upper-case
2296 elsif Path_Buffer (1) in 'a' .. 'z'
2297 and then Path_Buffer (2) = ':'
2299 System.Case_Util.To_Upper (Path_Buffer (1 .. 1));
2302 -- Remove all double-quotes that are possibly part of the
2303 -- path but can cause problems with other methods.
2309 Index := Path_Buffer'First;
2310 for Current in Path_Buffer'First .. End_Path loop
2311 if Path_Buffer (Current) /= '"' then
2312 Path_Buffer (Index) := Path_Buffer (Current);
2317 End_Path := Index - 1;
2321 -- Start the conversions
2323 -- If this is not finished after Max_Iterations, give up and return an
2326 for J in 1 .. Max_Iterations loop
2331 -- Ensure that Windows UNC path is preserved, e.g: \\server\drive-c
2334 and then Directory_Separator = '\
'
2335 and then Path_Buffer (1 .. 2) = "\\"
2340 -- If we have traversed the full pathname, return it
2342 if Start > End_Path then
2343 return Final_Value (Path_Buffer (1 .. End_Path));
2346 -- Remove duplicate directory separators
2348 while Path_Buffer (Start) = Directory_Separator loop
2349 if Start = End_Path then
2350 return Final_Value (Path_Buffer (1 .. End_Path - 1));
2353 Path_Buffer (Start .. End_Path - 1) :=
2354 Path_Buffer (Start + 1 .. End_Path);
2355 End_Path := End_Path - 1;
2359 -- Find the end of the current field: last character or the one
2360 -- preceding the next directory separator.
2362 while Finish < End_Path
2363 and then Path_Buffer (Finish + 1) /= Directory_Separator
2365 Finish := Finish + 1;
2370 if Start = Finish and then Path_Buffer (Start) = '.' then
2371 if Start = End_Path then
2373 return (1 => Directory_Separator);
2375 if Fold_To_Lower_Case then
2376 System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
2379 return Path_Buffer (1 .. Last - 1);
2382 Path_Buffer (Last + 1 .. End_Path - 2) :=
2383 Path_Buffer (Last + 3 .. End_Path);
2384 End_Path := End_Path - 2;
2387 -- Remove ".." fields
2389 elsif Finish = Start + 1
2390 and then Path_Buffer (Start .. Finish) = ".."
2396 or else Path_Buffer (Start) = Directory_Separator;
2400 if Finish = End_Path then
2401 return (1 => Directory_Separator);
2404 Path_Buffer (1 .. End_Path - Finish) :=
2405 Path_Buffer (Finish + 1 .. End_Path);
2406 End_Path := End_Path - Finish;
2411 if Finish = End_Path then
2412 return Final_Value (Path_Buffer (1 .. Start - 1));
2415 Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
2416 Path_Buffer (Finish + 2 .. End_Path);
2417 End_Path := Start + End_Path - Finish - 1;
2422 -- Check if current field is a symbolic link
2424 elsif Resolve_Links then
2426 Saved : constant Character := Path_Buffer (Finish + 1);
2429 Path_Buffer (Finish + 1) := ASCII.NUL;
2432 (Path => Path_Buffer'Address,
2433 Buf => Link_Buffer'Address,
2434 Bufsiz => Link_Buffer'Length);
2435 Path_Buffer (Finish + 1) := Saved;
2438 -- Not a symbolic link, move to the next field, if any
2443 -- Replace symbolic link with its value
2446 if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
2447 Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
2448 Path_Buffer (Finish + 1 .. End_Path);
2449 End_Path := End_Path - (Finish - Status);
2450 Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
2455 (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
2456 Path_Buffer (Finish + 1 .. End_Path);
2457 End_Path := End_Path - Finish + Last + Status;
2458 Path_Buffer (Last + 1 .. Last + Status) :=
2459 Link_Buffer (1 .. Status);
2468 -- Too many iterations: give up
2470 -- This can happen when there is a circularity in the symbolic links: A
2471 -- is a symbolic link for B, which itself is a symbolic link, and the
2472 -- target of B or of another symbolic link target of B is A. In this
2473 -- case, we return an empty string to indicate failure to resolve.
2476 end Normalize_Pathname;
2482 function Open_Append
2483 (Name : C_File_Name;
2484 Fmode : Mode) return File_Descriptor
2486 function C_Open_Append
2487 (Name : C_File_Name;
2488 Fmode : Mode) return File_Descriptor;
2489 pragma Import (C, C_Open_Append, "__gnat_open_append");
2491 return C_Open_Append (Name, Fmode);
2494 function Open_Append
2496 Fmode : Mode) return File_Descriptor
2498 C_Name : String (1 .. Name'Length + 1);
2500 C_Name (1 .. Name'Length) := Name;
2501 C_Name (C_Name'Last) := ASCII.NUL;
2502 return Open_Append (C_Name (C_Name'First)'Address, Fmode);
2510 (Name : C_File_Name;
2511 Fmode : Mode) return File_Descriptor
2513 function C_Open_Read
2514 (Name : C_File_Name;
2515 Fmode : Mode) return File_Descriptor;
2516 pragma Import (C, C_Open_Read, "__gnat_open_read");
2518 return C_Open_Read (Name, Fmode);
2523 Fmode : Mode) return File_Descriptor
2525 C_Name : String (1 .. Name'Length + 1);
2527 C_Name (1 .. Name'Length) := Name;
2528 C_Name (C_Name'Last) := ASCII.NUL;
2529 return Open_Read (C_Name (C_Name'First)'Address, Fmode);
2532 ---------------------
2533 -- Open_Read_Write --
2534 ---------------------
2536 function Open_Read_Write
2537 (Name : C_File_Name;
2538 Fmode : Mode) return File_Descriptor
2540 function C_Open_Read_Write
2541 (Name : C_File_Name;
2542 Fmode : Mode) return File_Descriptor;
2543 pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
2545 return C_Open_Read_Write (Name, Fmode);
2546 end Open_Read_Write;
2548 function Open_Read_Write
2550 Fmode : Mode) return File_Descriptor
2552 C_Name : String (1 .. Name'Length + 1);
2554 C_Name (1 .. Name'Length) := Name;
2555 C_Name (C_Name'Last) := ASCII.NUL;
2556 return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
2557 end Open_Read_Write;
2563 procedure OS_Exit (Status : Integer) is
2565 OS_Exit_Ptr (Status);
2566 raise Program_Error;
2569 ---------------------
2570 -- OS_Exit_Default --
2571 ---------------------
2573 procedure OS_Exit_Default (Status : Integer) is
2574 procedure GNAT_OS_Exit (Status : Integer);
2575 pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit");
2576 pragma No_Return (GNAT_OS_Exit);
2578 GNAT_OS_Exit (Status);
2579 end OS_Exit_Default;
2581 --------------------
2582 -- Pid_To_Integer --
2583 --------------------
2585 function Pid_To_Integer (Pid : Process_Id) return Integer is
2587 return Integer (Pid);
2595 (FD : File_Descriptor;
2597 N : Integer) return Integer
2601 Integer (System.CRTL.read
2602 (System.CRTL.int (FD),
2603 System.CRTL.chars (A),
2604 System.CRTL.size_t (N)));
2611 procedure Rename_File
2612 (Old_Name : C_File_Name;
2613 New_Name : C_File_Name;
2614 Success : out Boolean)
2616 function rename (From, To : Address) return Integer;
2617 pragma Import (C, rename, "__gnat_rename");
2621 R := rename (Old_Name, New_Name);
2625 procedure Rename_File
2628 Success : out Boolean)
2630 C_Old_Name : String (1 .. Old_Name'Length + 1);
2631 C_New_Name : String (1 .. New_Name'Length + 1);
2634 C_Old_Name (1 .. Old_Name'Length) := Old_Name;
2635 C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
2636 C_New_Name (1 .. New_Name'Length) := New_Name;
2637 C_New_Name (C_New_Name'Last) := ASCII.NUL;
2638 Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
2641 -----------------------
2642 -- Set_Close_On_Exec --
2643 -----------------------
2645 procedure Set_Close_On_Exec
2646 (FD : File_Descriptor;
2647 Close_On_Exec : Boolean;
2648 Status : out Boolean)
2650 function C_Set_Close_On_Exec
2651 (FD : File_Descriptor; Close_On_Exec : System.CRTL.int)
2652 return System.CRTL.int;
2653 pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
2655 Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0;
2656 end Set_Close_On_Exec;
2658 --------------------
2659 -- Set_Executable --
2660 --------------------
2662 procedure Set_Executable (Name : String; Mode : Positive := S_Owner) is
2663 procedure C_Set_Executable (Name : C_File_Name; Mode : Integer);
2664 pragma Import (C, C_Set_Executable, "__gnat_set_executable");
2665 C_Name : aliased String (Name'First .. Name'Last + 1);
2668 C_Name (Name'Range) := Name;
2669 C_Name (C_Name'Last) := ASCII.NUL;
2670 C_Set_Executable (C_Name (C_Name'First)'Address, Mode);
2673 -------------------------------------
2674 -- Set_File_Last_Modify_Time_Stamp --
2675 -------------------------------------
2677 procedure Set_File_Last_Modify_Time_Stamp (Name : String; Time : OS_Time) is
2678 procedure C_Set_File_Time (Name : C_File_Name; Time : OS_Time);
2679 pragma Import (C, C_Set_File_Time, "__gnat_set_file_time_name");
2680 C_Name : aliased String (Name'First .. Name'Last + 1);
2683 C_Name (Name'Range) := Name;
2684 C_Name (C_Name'Last) := ASCII.NUL;
2685 C_Set_File_Time (C_Name'Address, Time);
2686 end Set_File_Last_Modify_Time_Stamp;
2688 ----------------------
2689 -- Set_Non_Readable --
2690 ----------------------
2692 procedure Set_Non_Readable (Name : String) is
2693 procedure C_Set_Non_Readable (Name : C_File_Name);
2694 pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable");
2695 C_Name : aliased String (Name'First .. Name'Last + 1);
2698 C_Name (Name'Range) := Name;
2699 C_Name (C_Name'Last) := ASCII.NUL;
2700 C_Set_Non_Readable (C_Name (C_Name'First)'Address);
2701 end Set_Non_Readable;
2703 ----------------------
2704 -- Set_Non_Writable --
2705 ----------------------
2707 procedure Set_Non_Writable (Name : String) is
2708 procedure C_Set_Non_Writable (Name : C_File_Name);
2709 pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable");
2710 C_Name : aliased String (Name'First .. Name'Last + 1);
2713 C_Name (Name'Range) := Name;
2714 C_Name (C_Name'Last) := ASCII.NUL;
2715 C_Set_Non_Writable (C_Name (C_Name'First)'Address);
2716 end Set_Non_Writable;
2722 procedure Set_Readable (Name : String) is
2723 procedure C_Set_Readable (Name : C_File_Name);
2724 pragma Import (C, C_Set_Readable, "__gnat_set_readable");
2725 C_Name : aliased String (Name'First .. Name'Last + 1);
2728 C_Name (Name'Range) := Name;
2729 C_Name (C_Name'Last) := ASCII.NUL;
2730 C_Set_Readable (C_Name (C_Name'First)'Address);
2733 --------------------
2735 --------------------
2737 procedure Set_Writable (Name : String) is
2738 procedure C_Set_Writable (Name : C_File_Name);
2739 pragma Import (C, C_Set_Writable, "__gnat_set_writable");
2740 C_Name : aliased String (Name'First .. Name'Last + 1);
2743 C_Name (Name'Range) := Name;
2744 C_Name (C_Name'Last) := ASCII.NUL;
2745 C_Set_Writable (C_Name (C_Name'First)'Address);
2752 procedure Setenv (Name : String; Value : String) is
2753 F_Name : String (1 .. Name'Length + 1);
2754 F_Value : String (1 .. Value'Length + 1);
2756 procedure Set_Env_Value (Name, Value : System.Address);
2757 pragma Import (C, Set_Env_Value, "__gnat_setenv");
2760 F_Name (1 .. Name'Length) := Name;
2761 F_Name (F_Name'Last) := ASCII.NUL;
2763 F_Value (1 .. Value'Length) := Value;
2764 F_Value (F_Value'Last) := ASCII.NUL;
2766 Set_Env_Value (F_Name'Address, F_Value'Address);
2774 (Program_Name : String;
2775 Args : Argument_List) return Integer
2778 pragma Warnings (Off, Junk);
2782 Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
2787 (Program_Name : String;
2788 Args : Argument_List;
2789 Success : out Boolean)
2792 Success := (Spawn (Program_Name, Args) = 0);
2796 (Program_Name : String;
2797 Args : Argument_List;
2798 Output_File_Descriptor : File_Descriptor;
2799 Return_Code : out Integer;
2800 Err_To_Out : Boolean := True)
2802 Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning
2803 Saved_Output : File_Descriptor;
2806 -- Set standard output and error to the temporary file
2808 Saved_Output := Dup (Standout);
2809 Dup2 (Output_File_Descriptor, Standout);
2812 Saved_Error := Dup (Standerr);
2813 Dup2 (Output_File_Descriptor, Standerr);
2816 -- Spawn the program
2818 Return_Code := Spawn (Program_Name, Args);
2820 -- Restore the standard output and error
2822 Dup2 (Saved_Output, Standout);
2825 Dup2 (Saved_Error, Standerr);
2828 -- And close the saved standard output and error file descriptors
2830 Close (Saved_Output);
2833 Close (Saved_Error);
2838 (Program_Name : String;
2839 Args : Argument_List;
2840 Output_File : String;
2841 Success : out Boolean;
2842 Return_Code : out Integer;
2843 Err_To_Out : Boolean := True)
2845 FD : File_Descriptor;
2851 FD := Create_Output_Text_File (Output_File);
2853 if FD = Invalid_FD then
2858 Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out);
2860 Close (FD, Success);
2863 --------------------
2864 -- Spawn_Internal --
2865 --------------------
2867 procedure Spawn_Internal
2868 (Program_Name : String;
2869 Args : Argument_List;
2870 Result : out Integer;
2871 Pid : out Process_Id;
2874 procedure Spawn (Args : Argument_List);
2875 -- Call Spawn with given argument list
2877 N_Args : Argument_List (Args'Range);
2878 -- Normalized arguments
2884 procedure Spawn (Args : Argument_List) is
2885 type Chars is array (Positive range <>) of aliased Character;
2886 type Char_Ptr is access constant Character;
2888 Command_Len : constant Positive :=
2889 Program_Name'Length + 1 + Args_Length (Args);
2890 Command_Last : Natural := 0;
2891 Command : aliased Chars (1 .. Command_Len);
2892 -- Command contains all characters of the Program_Name and Args, all
2893 -- terminated by ASCII.NUL characters.
2895 Arg_List_Len : constant Positive := Args'Length + 2;
2896 Arg_List_Last : Natural := 0;
2897 Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
2898 -- List with pointers to NUL-terminated strings of the Program_Name
2899 -- and the Args and terminated with a null pointer. We rely on the
2900 -- default initialization for the last null pointer.
2902 procedure Add_To_Command (S : String);
2903 -- Add S and a NUL character to Command, updating Last
2905 function Portable_Spawn (Args : Address) return Integer;
2906 pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
2908 function Portable_No_Block_Spawn (Args : Address) return Process_Id;
2910 (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
2912 --------------------
2913 -- Add_To_Command --
2914 --------------------
2916 procedure Add_To_Command (S : String) is
2917 First : constant Natural := Command_Last + 1;
2920 Command_Last := Command_Last + S'Length;
2922 -- Move characters one at a time, because Command has aliased
2925 -- But not volatile, so why is this necessary ???
2927 for J in S'Range loop
2928 Command (First + J - S'First) := S (J);
2931 Command_Last := Command_Last + 1;
2932 Command (Command_Last) := ASCII.NUL;
2934 Arg_List_Last := Arg_List_Last + 1;
2935 Arg_List (Arg_List_Last) := Command (First)'Access;
2938 -- Start of processing for Spawn
2941 Add_To_Command (Program_Name);
2943 for J in Args'Range loop
2944 Add_To_Command (Args (J).all);
2949 Result := Portable_Spawn (Arg_List'Address);
2951 Pid := Portable_No_Block_Spawn (Arg_List'Address);
2952 Result := Boolean'Pos (Pid /= Invalid_Pid);
2956 -- Start of processing for Spawn_Internal
2959 -- Copy arguments into a local structure
2961 for K in N_Args'Range loop
2962 N_Args (K) := new String'(Args
(K
).all);
2965 -- Normalize those arguments
2967 Normalize_Arguments
(N_Args
);
2969 -- Call spawn using the normalized arguments
2973 -- Free arguments list
2975 for K
in N_Args
'Range loop
2980 ---------------------------
2981 -- To_Path_String_Access --
2982 ---------------------------
2984 function To_Path_String_Access
2985 (Path_Addr
: Address
;
2986 Path_Len
: Integer) return String_Access
2988 subtype Path_String
is String (1 .. Path_Len
);
2989 type Path_String_Access
is access Path_String
;
2991 function Address_To_Access
is new Ada
.Unchecked_Conversion
2992 (Source
=> Address
, Target
=> Path_String_Access
);
2994 Path_Access
: constant Path_String_Access
:=
2995 Address_To_Access
(Path_Addr
);
2997 Return_Val
: String_Access
;
3000 Return_Val
:= new String (1 .. Path_Len
);
3002 for J
in 1 .. Path_Len
loop
3003 Return_Val
(J
) := Path_Access
(J
);
3007 end To_Path_String_Access
;
3013 procedure Wait_Process
(Pid
: out Process_Id
; Success
: out Boolean) is
3016 function Portable_Wait
(S
: Address
) return Process_Id
;
3017 pragma Import
(C
, Portable_Wait
, "__gnat_portable_wait");
3020 Pid
:= Portable_Wait
(Status
'Address);
3021 Success
:= (Status
= 0);
3029 (FD
: File_Descriptor
;
3031 N
: Integer) return Integer
3035 Integer (System
.CRTL
.write
3036 (System
.CRTL
.int
(FD
),
3037 System
.CRTL
.chars
(A
),
3038 System
.CRTL
.size_t
(N
)));