?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* arm.md (reload_mulsi3, reload_mulsi_compare0, reload_muladdsi)
[official-gcc.git] / gcc / ada / g-os_lib.adb
blob590b061a8ad0f94634ca525cb9382ad61fda4125
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 -- --
10 -- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
11 -- --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
22 -- --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
29 -- --
30 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
31 -- --
32 ------------------------------------------------------------------------------
33
34 with System.Soft_Links;
35 with Unchecked_Conversion;
36 with System; use System;
37
38 package body GNAT.OS_Lib is
39
40 package SSL renames System.Soft_Links;
41
42 -----------------------
43 -- Local Subprograms --
44 -----------------------
45
46 function Args_Length (Args : Argument_List) return Natural;
47 -- Returns total number of characters needed to create a string
48 -- of all Args terminated by ASCII.NUL characters
49
50 function C_String_Length (S : Address) return Integer;
51 -- Returns the length of a C string. Does check for null address
52 -- (returns 0).
53
54 procedure Spawn_Internal
55 (Program_Name : String;
56 Args : Argument_List;
57 Result : out Integer;
58 Pid : out Process_Id;
59 Blocking : Boolean);
60 -- Internal routine to implement the two Spawn (blocking/non blocking)
61 -- routines. If Blocking is set to True then the spawn is blocking
62 -- otherwise it is non blocking. In this latter case the Pid contains
63 -- the process id number. The first three parameters are as in Spawn.
64 -- Note that Spawn_Internal normalizes the argument list before calling
65 -- the low level system spawn routines (see Normalize_Arguments). Note
66 -- that Normalize_Arguments is designed to do nothing if it is called
67 -- more than once, so calling Normalize_Arguments before calling one
68 -- of the spawn routines is fine.
69
70 function To_Path_String_Access
71 (Path_Addr : Address;
72 Path_Len : Integer)
73 return String_Access;
74 -- Converts a C String to an Ada String. We could do this making use of
75 -- Interfaces.C.Strings but we prefer not to import that entire package
76
77 -----------------
78 -- Args_Length --
79 -----------------
80
81 function Args_Length (Args : Argument_List) return Natural is
82 Len : Natural := 0;
83
84 begin
85 for J in Args'Range loop
86 Len := Len + Args (J)'Length + 1; -- One extra for ASCII.NUL
87 end loop;
88
89 return Len;
90 end Args_Length;
91
92 -----------------------------
93 -- Argument_String_To_List --
94 -----------------------------
95
96 function Argument_String_To_List
97 (Arg_String : String)
98 return Argument_List_Access
99 is
100 Max_Args : Integer := Arg_String'Length;
101 New_Argv : Argument_List (1 .. Max_Args);
102 New_Argc : Natural := 0;
103 Idx : Integer;
104
105 begin
106 Idx := Arg_String'First;
107
108 loop
109 declare
110 Quoted : Boolean := False;
111 Backqd : Boolean := False;
112 Old_Idx : Integer;
113
114 begin
115 Old_Idx := Idx;
116
117 loop
118 -- An unquoted space is the end of an argument
119
120 if not (Backqd or Quoted)
121 and then Arg_String (Idx) = ' '
122 then
123 exit;
124
125 -- Start of a quoted string
126
127 elsif not (Backqd or Quoted)
128 and then Arg_String (Idx) = '"'
129 then
130 Quoted := True;
131
132 -- End of a quoted string and end of an argument
133
134 elsif (Quoted and not Backqd)
135 and then Arg_String (Idx) = '"'
136 then
137 Idx := Idx + 1;
138 exit;
139
140 -- Following character is backquoted
141
142 elsif Arg_String (Idx) = '\' then
143 Backqd := True;
144
145 -- Turn off backquoting after advancing one character
146
147 elsif Backqd then
148 Backqd := False;
149
150 end if;
151
152 Idx := Idx + 1;
153 exit when Idx > Arg_String'Last;
154 end loop;
155
156 -- Found an argument
157
158 New_Argc := New_Argc + 1;
159 New_Argv (New_Argc) :=
160 new String'(Arg_String (Old_Idx .. Idx - 1));
161
162 -- Skip extraneous spaces
163
164 while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop
165 Idx := Idx + 1;
166 end loop;
167 end;
168
169 exit when Idx > Arg_String'Last;
170 end loop;
171
172 return new Argument_List'(New_Argv (1 .. New_Argc));
173 end Argument_String_To_List;
174
175 ---------------------
176 -- C_String_Length --
177 ---------------------
178
179 function C_String_Length (S : Address) return Integer is
180 function Strlen (S : Address) return Integer;
181 pragma Import (C, Strlen, "strlen");
182
183 begin
184 if S = Null_Address then
185 return 0;
186 else
187 return Strlen (S);
188 end if;
189 end C_String_Length;
190
191 -----------------
192 -- Create_File --
193 -----------------
194
195 function Create_File
196 (Name : C_File_Name;
197 Fmode : Mode)
198 return File_Descriptor
199 is
200 function C_Create_File
201 (Name : C_File_Name;
202 Fmode : Mode)
203 return File_Descriptor;
204 pragma Import (C, C_Create_File, "__gnat_open_create");
205
206 begin
207 return C_Create_File (Name, Fmode);
208 end Create_File;
209
210 function Create_File
211 (Name : String;
212 Fmode : Mode)
213 return File_Descriptor
214 is
215 C_Name : String (1 .. Name'Length + 1);
216
217 begin
218 C_Name (1 .. Name'Length) := Name;
219 C_Name (C_Name'Last) := ASCII.NUL;
220 return Create_File (C_Name (C_Name'First)'Address, Fmode);
221 end Create_File;
222
223 ---------------------
224 -- Create_New_File --
225 ---------------------
226
227 function Create_New_File
228 (Name : C_File_Name;
229 Fmode : Mode)
230 return File_Descriptor
231 is
232 function C_Create_New_File
233 (Name : C_File_Name;
234 Fmode : Mode)
235 return File_Descriptor;
236 pragma Import (C, C_Create_New_File, "__gnat_open_new");
237
238 begin
239 return C_Create_New_File (Name, Fmode);
240 end Create_New_File;
241
242 function Create_New_File
243 (Name : String;
244 Fmode : Mode)
245 return File_Descriptor
246 is
247 C_Name : String (1 .. Name'Length + 1);
248
249 begin
250 C_Name (1 .. Name'Length) := Name;
251 C_Name (C_Name'Last) := ASCII.NUL;
252 return Create_New_File (C_Name (C_Name'First)'Address, Fmode);
253 end Create_New_File;
254
255 ----------------------
256 -- Create_Temp_File --
257 ----------------------
258
259 procedure Create_Temp_File
260 (FD : out File_Descriptor;
261 Name : out Temp_File_Name)
262 is
263 function Open_New_Temp
264 (Name : System.Address;
265 Fmode : Mode)
266 return File_Descriptor;
267 pragma Import (C, Open_New_Temp, "__gnat_open_new_temp");
268
269 begin
270 FD := Open_New_Temp (Name'Address, Binary);
271 end Create_Temp_File;
272
273 -----------------
274 -- Delete_File --
275 -----------------
276
277 procedure Delete_File (Name : Address; Success : out Boolean) is
278 R : Integer;
279
280 function unlink (A : Address) return Integer;
281 pragma Import (C, unlink, "unlink");
282
283 begin
284 R := unlink (Name);
285 Success := (R = 0);
286 end Delete_File;
287
288 procedure Delete_File (Name : String; Success : out Boolean) is
289 C_Name : String (1 .. Name'Length + 1);
290
291 begin
292 C_Name (1 .. Name'Length) := Name;
293 C_Name (C_Name'Last) := ASCII.NUL;
294
295 Delete_File (C_Name'Address, Success);
296 end Delete_File;
297
298 ---------------------
299 -- File_Time_Stamp --
300 ---------------------
301
302 function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
303 function File_Time (FD : File_Descriptor) return OS_Time;
304 pragma Import (C, File_Time, "__gnat_file_time_fd");
305
306 begin
307 return File_Time (FD);
308 end File_Time_Stamp;
309
310 function File_Time_Stamp (Name : C_File_Name) return OS_Time is
311 function File_Time (Name : Address) return OS_Time;
312 pragma Import (C, File_Time, "__gnat_file_time_name");
313
314 begin
315 return File_Time (Name);
316 end File_Time_Stamp;
317
318 function File_Time_Stamp (Name : String) return OS_Time is
319 F_Name : String (1 .. Name'Length + 1);
320
321 begin
322 F_Name (1 .. Name'Length) := Name;
323 F_Name (F_Name'Last) := ASCII.NUL;
324 return File_Time_Stamp (F_Name'Address);
325 end File_Time_Stamp;
326
327 ----------
328 -- Free --
329 ----------
330
331 procedure Free (Arg : in out String_List_Access) is
332 X : String_Access;
333
334 procedure Free_Array is new Unchecked_Deallocation
335 (Object => String_List, Name => String_List_Access);
336
337 begin
338 for J in Arg'Range loop
339 X := Arg (J);
340 Free (X);
341 end loop;
342
343 Free_Array (Arg);
344 end Free;
345
346 ---------------------------
347 -- Get_Debuggable_Suffix --
348 ---------------------------
349
350 function Get_Debuggable_Suffix return String_Access is
351 procedure Get_Suffix_Ptr (Length, Ptr : Address);
352 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
353
354 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
355 pragma Import (C, Strncpy, "strncpy");
356
357 Suffix_Ptr : Address;
358 Suffix_Length : Integer;
359 Result : String_Access;
360
361 begin
362 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
363
364 Result := new String (1 .. Suffix_Length);
365
366 if Suffix_Length > 0 then
367 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
368 end if;
369
370 return Result;
371 end Get_Debuggable_Suffix;
372
373 ---------------------------
374 -- Get_Executable_Suffix --
375 ---------------------------
376
377 function Get_Executable_Suffix return String_Access is
378 procedure Get_Suffix_Ptr (Length, Ptr : Address);
379 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
380
381 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
382 pragma Import (C, Strncpy, "strncpy");
383
384 Suffix_Ptr : Address;
385 Suffix_Length : Integer;
386 Result : String_Access;
387
388 begin
389 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
390
391 Result := new String (1 .. Suffix_Length);
392
393 if Suffix_Length > 0 then
394 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
395 end if;
396
397 return Result;
398 end Get_Executable_Suffix;
399
400 -----------------------
401 -- Get_Object_Suffix --
402 -----------------------
403
404 function Get_Object_Suffix return String_Access is
405 procedure Get_Suffix_Ptr (Length, Ptr : Address);
406 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
407
408 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
409 pragma Import (C, Strncpy, "strncpy");
410
411 Suffix_Ptr : Address;
412 Suffix_Length : Integer;
413 Result : String_Access;
414
415 begin
416 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
417
418 Result := new String (1 .. Suffix_Length);
419
420 if Suffix_Length > 0 then
421 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
422 end if;
423
424 return Result;
425 end Get_Object_Suffix;
426
427 ------------
428 -- Getenv --
429 ------------
430
431 function Getenv (Name : String) return String_Access is
432 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
433 pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr");
434
435 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
436 pragma Import (C, Strncpy, "strncpy");
437
438 Env_Value_Ptr : Address;
439 Env_Value_Length : Integer;
440 F_Name : String (1 .. Name'Length + 1);
441 Result : String_Access;
442
443 begin
444 F_Name (1 .. Name'Length) := Name;
445 F_Name (F_Name'Last) := ASCII.NUL;
446
447 Get_Env_Value_Ptr
448 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
449
450 Result := new String (1 .. Env_Value_Length);
451
452 if Env_Value_Length > 0 then
453 Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
454 end if;
455
456 return Result;
457 end Getenv;
458
459 ------------
460 -- GM_Day --
461 ------------
462
463 function GM_Day (Date : OS_Time) return Day_Type is
464 Y : Year_Type;
465 Mo : Month_Type;
466 D : Day_Type;
467 H : Hour_Type;
468 Mn : Minute_Type;
469 S : Second_Type;
470
471 begin
472 GM_Split (Date, Y, Mo, D, H, Mn, S);
473 return D;
474 end GM_Day;
475
476 -------------
477 -- GM_Hour --
478 -------------
479
480 function GM_Hour (Date : OS_Time) return Hour_Type is
481 Y : Year_Type;
482 Mo : Month_Type;
483 D : Day_Type;
484 H : Hour_Type;
485 Mn : Minute_Type;
486 S : Second_Type;
487
488 begin
489 GM_Split (Date, Y, Mo, D, H, Mn, S);
490 return H;
491 end GM_Hour;
492
493 ---------------
494 -- GM_Minute --
495 ---------------
496
497 function GM_Minute (Date : OS_Time) return Minute_Type is
498 Y : Year_Type;
499 Mo : Month_Type;
500 D : Day_Type;
501 H : Hour_Type;
502 Mn : Minute_Type;
503 S : Second_Type;
504
505 begin
506 GM_Split (Date, Y, Mo, D, H, Mn, S);
507 return Mn;
508 end GM_Minute;
509
510 --------------
511 -- GM_Month --
512 --------------
513
514 function GM_Month (Date : OS_Time) return Month_Type is
515 Y : Year_Type;
516 Mo : Month_Type;
517 D : Day_Type;
518 H : Hour_Type;
519 Mn : Minute_Type;
520 S : Second_Type;
521
522 begin
523 GM_Split (Date, Y, Mo, D, H, Mn, S);
524 return Mo;
525 end GM_Month;
526
527 ---------------
528 -- GM_Second --
529 ---------------
530
531 function GM_Second (Date : OS_Time) return Second_Type is
532 Y : Year_Type;
533 Mo : Month_Type;
534 D : Day_Type;
535 H : Hour_Type;
536 Mn : Minute_Type;
537 S : Second_Type;
538
539 begin
540 GM_Split (Date, Y, Mo, D, H, Mn, S);
541 return S;
542 end GM_Second;
543
544 --------------
545 -- GM_Split --
546 --------------
547
548 procedure GM_Split
549 (Date : OS_Time;
550 Year : out Year_Type;
551 Month : out Month_Type;
552 Day : out Day_Type;
553 Hour : out Hour_Type;
554 Minute : out Minute_Type;
555 Second : out Second_Type)
556 is
557 procedure To_GM_Time
558 (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
559 pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
560
561 T : OS_Time := Date;
562 Y : Integer;
563 Mo : Integer;
564 D : Integer;
565 H : Integer;
566 Mn : Integer;
567 S : Integer;
568
569 begin
570 -- Use the global lock because To_GM_Time is not thread safe.
571
572 Locked_Processing : begin
573 SSL.Lock_Task.all;
574 To_GM_Time
575 (T'Address, Y'Address, Mo'Address, D'Address,
576 H'Address, Mn'Address, S'Address);
577 SSL.Unlock_Task.all;
578
579 exception
580 when others =>
581 SSL.Unlock_Task.all;
582 raise;
583 end Locked_Processing;
584
585 Year := Y + 1900;
586 Month := Mo + 1;
587 Day := D;
588 Hour := H;
589 Minute := Mn;
590 Second := S;
591 end GM_Split;
592
593 -------------
594 -- GM_Year --
595 -------------
596
597 function GM_Year (Date : OS_Time) return Year_Type is
598 Y : Year_Type;
599 Mo : Month_Type;
600 D : Day_Type;
601 H : Hour_Type;
602 Mn : Minute_Type;
603 S : Second_Type;
604
605 begin
606 GM_Split (Date, Y, Mo, D, H, Mn, S);
607 return Y;
608 end GM_Year;
609
610 ----------------------
611 -- Is_Absolute_Path --
612 ----------------------
613
614 function Is_Absolute_Path (Name : String) return Boolean is
615 function Is_Absolute_Path (Name : Address) return Integer;
616 pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
617
618 F_Name : String (1 .. Name'Length + 1);
619
620 begin
621 F_Name (1 .. Name'Length) := Name;
622 F_Name (F_Name'Last) := ASCII.NUL;
623
624 return Is_Absolute_Path (F_Name'Address) /= 0;
625 end Is_Absolute_Path;
626
627 ------------------
628 -- Is_Directory --
629 ------------------
630
631 function Is_Directory (Name : C_File_Name) return Boolean is
632 function Is_Directory (Name : Address) return Integer;
633 pragma Import (C, Is_Directory, "__gnat_is_directory");
634
635 begin
636 return Is_Directory (Name) /= 0;
637 end Is_Directory;
638
639 function Is_Directory (Name : String) return Boolean is
640 F_Name : String (1 .. Name'Length + 1);
641
642 begin
643 F_Name (1 .. Name'Length) := Name;
644 F_Name (F_Name'Last) := ASCII.NUL;
645 return Is_Directory (F_Name'Address);
646 end Is_Directory;
647
648 ---------------------
649 -- Is_Regular_File --
650 ---------------------
651
652 function Is_Regular_File (Name : C_File_Name) return Boolean is
653 function Is_Regular_File (Name : Address) return Integer;
654 pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
655
656 begin
657 return Is_Regular_File (Name) /= 0;
658 end Is_Regular_File;
659
660 function Is_Regular_File (Name : String) return Boolean is
661 F_Name : String (1 .. Name'Length + 1);
662
663 begin
664 F_Name (1 .. Name'Length) := Name;
665 F_Name (F_Name'Last) := ASCII.NUL;
666 return Is_Regular_File (F_Name'Address);
667 end Is_Regular_File;
668
669 ----------------------
670 -- Is_Writable_File --
671 ----------------------
672
673 function Is_Writable_File (Name : C_File_Name) return Boolean is
674 function Is_Writable_File (Name : Address) return Integer;
675 pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
676
677 begin
678 return Is_Writable_File (Name) /= 0;
679 end Is_Writable_File;
680
681 function Is_Writable_File (Name : String) return Boolean is
682 F_Name : String (1 .. Name'Length + 1);
683
684 begin
685 F_Name (1 .. Name'Length) := Name;
686 F_Name (F_Name'Last) := ASCII.NUL;
687 return Is_Writable_File (F_Name'Address);
688 end Is_Writable_File;
689
690 -------------------------
691 -- Locate_Exec_On_Path --
692 -------------------------
693
694 function Locate_Exec_On_Path
695 (Exec_Name : String)
696 return String_Access
697 is
698 function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
699 pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
700
701 procedure Free (Ptr : System.Address);
702 pragma Import (C, Free, "free");
703
704 C_Exec_Name : String (1 .. Exec_Name'Length + 1);
705 Path_Addr : Address;
706 Path_Len : Integer;
707 Result : String_Access;
708
709 begin
710 C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name;
711 C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL;
712
713 Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
714 Path_Len := C_String_Length (Path_Addr);
715
716 if Path_Len = 0 then
717 return null;
718
719 else
720 Result := To_Path_String_Access (Path_Addr, Path_Len);
721 Free (Path_Addr);
722 return Result;
723 end if;
724 end Locate_Exec_On_Path;
725
726 -------------------------
727 -- Locate_Regular_File --
728 -------------------------
729
730 function Locate_Regular_File
731 (File_Name : C_File_Name;
732 Path : C_File_Name)
733 return String_Access
734 is
735 function Locate_Regular_File
736 (C_File_Name, Path_Val : Address) return Address;
737 pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file");
738
739 procedure Free (Ptr : System.Address);
740 pragma Import (C, Free, "free");
741
742 Path_Addr : Address;
743 Path_Len : Integer;
744 Result : String_Access;
745
746 begin
747 Path_Addr := Locate_Regular_File (File_Name, Path);
748 Path_Len := C_String_Length (Path_Addr);
749
750 if Path_Len = 0 then
751 return null;
752 else
753 Result := To_Path_String_Access (Path_Addr, Path_Len);
754 Free (Path_Addr);
755 return Result;
756 end if;
757 end Locate_Regular_File;
758
759 function Locate_Regular_File
760 (File_Name : String;
761 Path : String)
762 return String_Access
763 is
764 C_File_Name : String (1 .. File_Name'Length + 1);
765 C_Path : String (1 .. Path'Length + 1);
766
767 begin
768 C_File_Name (1 .. File_Name'Length) := File_Name;
769 C_File_Name (C_File_Name'Last) := ASCII.NUL;
770
771 C_Path (1 .. Path'Length) := Path;
772 C_Path (C_Path'Last) := ASCII.NUL;
773
774 return Locate_Regular_File (C_File_Name'Address, C_Path'Address);
775 end Locate_Regular_File;
776
777 ------------------------
778 -- Non_Blocking_Spawn --
779 ------------------------
780
781 function Non_Blocking_Spawn
782 (Program_Name : String;
783 Args : Argument_List)
784 return Process_Id
785 is
786 Junk : Integer;
787 Pid : Process_Id;
788
789 begin
790 Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
791 return Pid;
792 end Non_Blocking_Spawn;
793
794 -------------------------
795 -- Normalize_Arguments --
796 -------------------------
797
798 procedure Normalize_Arguments (Args : in out Argument_List) is
799
800 procedure Quote_Argument (Arg : in out String_Access);
801 -- Add quote around argument if it contains spaces.
802
803 Argument_Needs_Quote : Boolean;
804 pragma Import (C, Argument_Needs_Quote, "__gnat_argument_needs_quote");
805
806 --------------------
807 -- Quote_Argument --
808 --------------------
809
810 procedure Quote_Argument (Arg : in out String_Access) is
811 Res : String (1 .. Arg'Length * 2);
812 J : Positive := 1;
813 Quote_Needed : Boolean := False;
814
815 begin
816 if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
817
818 -- Starting quote
819
820 Res (J) := '"';
821
822 for K in Arg'Range loop
823
824 J := J + 1;
825
826 if Arg (K) = '"' then
827 Res (J) := '\';
828 J := J + 1;
829 Res (J) := '"';
830
831 elsif Arg (K) = ' ' then
832 Res (J) := Arg (K);
833 Quote_Needed := True;
834
835 else
836 Res (J) := Arg (K);
837 end if;
838
839 end loop;
840
841 if Quote_Needed then
842
843 -- Ending quote
844
845 J := J + 1;
846 Res (J) := '"';
847
848 declare
849 Old : String_Access := Arg;
850
851 begin
852 Arg := new String'(Res (1 .. J));
853 Free (Old);
854 end;
855 end if;
856
857 end if;
858 end Quote_Argument;
859
860 begin
861 if Argument_Needs_Quote then
862 for K in Args'Range loop
863 if Args (K) /= null then
864 Quote_Argument (Args (K));
865 end if;
866 end loop;
867 end if;
868 end Normalize_Arguments;
869
870 ------------------------
871 -- Normalize_Pathname --
872 ------------------------
873
874 function Normalize_Pathname
875 (Name : String;
876 Directory : String := "")
877 return String
878 is
879 Max_Path : Integer;
880 pragma Import (C, Max_Path, "max_path_len");
881 -- Maximum length of a path name
882
883 procedure Get_Current_Dir
884 (Dir : System.Address;
885 Length : System.Address);
886 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
887
888 Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
889 End_Path : Natural := 0;
890 Link_Buffer : String (1 .. Max_Path + 2);
891 Status : Integer;
892 Last : Positive;
893 Start : Natural;
894 Finish : Positive;
895
896 Max_Iterations : constant := 500;
897
898 function Readlink
899 (Path : System.Address;
900 Buf : System.Address;
901 Bufsiz : Integer)
902 return Integer;
903 pragma Import (C, Readlink, "__gnat_readlink");
904
905 function To_Canonical_File_Spec
906 (Host_File : System.Address)
907 return System.Address;
908 pragma Import
909 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
910
911 The_Name : String (1 .. Name'Length + 1);
912 Canonical_File_Addr : System.Address;
913 Canonical_File_Len : Integer;
914
915 Need_To_Check_Drive_Letter : Boolean := False;
916 -- Set to true if Name is an absolute path that starts with "//"
917
918 function Strlen (S : System.Address) return Integer;
919 pragma Import (C, Strlen, "strlen");
920
921 function Get_Directory return String;
922 -- If Directory is not empty, return it, adding a directory separator
923 -- if not already present, otherwise return current working directory
924 -- with terminating directory separator.
925
926 function Final_Value (S : String) return String;
927 -- Make final adjustment to the returned string.
928 -- To compensate for non standard path name in Interix,
929 -- if S is "/x" or starts with "/x", where x is a capital
930 -- letter 'A' to 'Z', add an additional '/' at the beginning
931 -- so that the returned value starts with "//x".
932
933 -------------------
934 -- Get_Directory --
935 -------------------
936
937 function Get_Directory return String is
938 begin
939 -- Directory given, add directory separator if needed
940
941 if Directory'Length > 0 then
942 if Directory (Directory'Length) = Directory_Separator then
943 return Directory;
944 else
945 declare
946 Result : String (1 .. Directory'Length + 1);
947
948 begin
949 Result (1 .. Directory'Length) := Directory;
950 Result (Result'Length) := Directory_Separator;
951 return Result;
952 end;
953 end if;
954
955 -- Directory name not given, get current directory
956
957 else
958 declare
959 Buffer : String (1 .. Max_Path + 2);
960 Path_Len : Natural := Max_Path;
961
962 begin
963 Get_Current_Dir (Buffer'Address, Path_Len'Address);
964
965 if Buffer (Path_Len) /= Directory_Separator then
966 Path_Len := Path_Len + 1;
967 Buffer (Path_Len) := Directory_Separator;
968 end if;
969
970 return Buffer (1 .. Path_Len);
971 end;
972 end if;
973 end Get_Directory;
974
975 Reference_Dir : constant String := Get_Directory;
976 -- Current directory name specified
977
978 -----------------
979 -- Final_Value --
980 -----------------
981
982 function Final_Value (S : String) return String is
983 begin
984 -- Interix has the non standard notion of disk drive
985 -- indicated by two '/' followed by a capital letter
986 -- 'A' .. 'Z'. One of the two '/' may have been removed
987 -- by Normalize_Pathname. It has to be added again.
988 -- For other OSes, this should not make no difference.
989
990 if Need_To_Check_Drive_Letter
991 and then S'Length >= 2
992 and then S (S'First) = '/'
993 and then S (S'First + 1) in 'A' .. 'Z'
994 and then (S'Length = 2 or else S (S'First + 2) = '/')
995 then
996 declare
997 Result : String (1 .. S'Length + 1);
998
999 begin
1000 Result (1) := '/';
1001 Result (2 .. Result'Last) := S;
1002 return Result;
1003 end;
1004
1005 else
1006 return S;
1007 end if;
1008
1009 end Final_Value;
1010
1011 -- Start of processing for Normalize_Pathname
1012
1013 begin
1014 -- Special case, if name is null, then return null
1015
1016 if Name'Length = 0 then
1017 return "";
1018 end if;
1019
1020 -- First, convert VMS file spec to Unix file spec.
1021 -- If Name is not in VMS syntax, then this is equivalent
1022 -- to put Name at the begining of Path_Buffer.
1023
1024 VMS_Conversion : begin
1025 The_Name (1 .. Name'Length) := Name;
1026 The_Name (The_Name'Last) := ASCII.NUL;
1027
1028 Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1029 Canonical_File_Len := Strlen (Canonical_File_Addr);
1030
1031 -- If VMS syntax conversion has failed, return an empty string
1032 -- to indicate the failure.
1033
1034 if Canonical_File_Len = 0 then
1035 return "";
1036 end if;
1037
1038 declare
1039 subtype Path_String is String (1 .. Canonical_File_Len);
1040 type Path_String_Access is access Path_String;
1041
1042 function Address_To_Access is new
1043 Unchecked_Conversion (Source => Address,
1044 Target => Path_String_Access);
1045
1046 Path_Access : Path_String_Access :=
1047 Address_To_Access (Canonical_File_Addr);
1048
1049 begin
1050 Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
1051 End_Path := Canonical_File_Len;
1052 Last := 1;
1053 end;
1054 end VMS_Conversion;
1055
1056 -- Replace all '/' by Directory Separators (this is for Windows)
1057
1058 if Directory_Separator /= '/' then
1059 for Index in 1 .. End_Path loop
1060 if Path_Buffer (Index) = '/' then
1061 Path_Buffer (Index) := Directory_Separator;
1062 end if;
1063 end loop;
1064 end if;
1065
1066 -- Start the conversions
1067
1068 -- If this is not finished after Max_Iterations, give up and
1069 -- return an empty string.
1070
1071 for J in 1 .. Max_Iterations loop
1072
1073 -- If we don't have an absolute pathname, prepend
1074 -- the directory Reference_Dir.
1075
1076 if Last = 1
1077 and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
1078 then
1079 Path_Buffer
1080 (Reference_Dir'Last + 1 .. Reference_Dir'Length + End_Path) :=
1081 Path_Buffer (1 .. End_Path);
1082 End_Path := Reference_Dir'Length + End_Path;
1083 Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir;
1084 Last := Reference_Dir'Length;
1085 end if;
1086
1087 -- If name starts with "//", we may have a drive letter on Interix
1088
1089 if Last = 1 and then End_Path >= 3 then
1090 Need_To_Check_Drive_Letter := (Path_Buffer (1 .. 2)) = "//";
1091 end if;
1092
1093 Start := Last + 1;
1094 Finish := Last;
1095
1096 -- If we have traversed the full pathname, return it
1097
1098 if Start > End_Path then
1099 return Final_Value (Path_Buffer (1 .. End_Path));
1100 end if;
1101
1102 -- Remove duplicate directory separators
1103
1104 while Path_Buffer (Start) = Directory_Separator loop
1105 if Start = End_Path then
1106 return Final_Value (Path_Buffer (1 .. End_Path - 1));
1107
1108 else
1109 Path_Buffer (Start .. End_Path - 1) :=
1110 Path_Buffer (Start + 1 .. End_Path);
1111 End_Path := End_Path - 1;
1112 end if;
1113 end loop;
1114
1115 -- Find the end of the current field: last character
1116 -- or the one preceding the next directory separator.
1117
1118 while Finish < End_Path
1119 and then Path_Buffer (Finish + 1) /= Directory_Separator
1120 loop
1121 Finish := Finish + 1;
1122 end loop;
1123
1124 -- Remove "." field
1125
1126 if Start = Finish and then Path_Buffer (Start) = '.' then
1127 if Start = End_Path then
1128 if Last = 1 then
1129 return (1 => Directory_Separator);
1130 else
1131 return Path_Buffer (1 .. Last - 1);
1132 end if;
1133
1134 else
1135 Path_Buffer (Last + 1 .. End_Path - 2) :=
1136 Path_Buffer (Last + 3 .. End_Path);
1137 End_Path := End_Path - 2;
1138 end if;
1139
1140 -- Remove ".." fields
1141
1142 elsif Finish = Start + 1
1143 and then Path_Buffer (Start .. Finish) = ".."
1144 then
1145 Start := Last;
1146 loop
1147 Start := Start - 1;
1148 exit when Start < 1 or else
1149 Path_Buffer (Start) = Directory_Separator;
1150 end loop;
1151
1152 if Start <= 1 then
1153 if Finish = End_Path then
1154 return (1 => Directory_Separator);
1155
1156 else
1157 Path_Buffer (1 .. End_Path - Finish) :=
1158 Path_Buffer (Finish + 1 .. End_Path);
1159 End_Path := End_Path - Finish;
1160 Last := 1;
1161 end if;
1162
1163 else
1164 if Finish = End_Path then
1165 return Final_Value (Path_Buffer (1 .. Start - 1));
1166
1167 else
1168 Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
1169 Path_Buffer (Finish + 2 .. End_Path);
1170 End_Path := Start + End_Path - Finish - 1;
1171 Last := Start;
1172 end if;
1173 end if;
1174
1175 -- Check if current field is a symbolic link
1176
1177 else
1178 declare
1179 Saved : Character := Path_Buffer (Finish + 1);
1180
1181 begin
1182 Path_Buffer (Finish + 1) := ASCII.NUL;
1183 Status := Readlink (Path_Buffer'Address,
1184 Link_Buffer'Address,
1185 Link_Buffer'Length);
1186 Path_Buffer (Finish + 1) := Saved;
1187 end;
1188
1189 -- Not a symbolic link, move to the next field, if any
1190
1191 if Status <= 0 then
1192 Last := Finish + 1;
1193
1194 -- Replace symbolic link with its value.
1195
1196 else
1197 if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
1198 Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
1199 Path_Buffer (Finish + 1 .. End_Path);
1200 End_Path := End_Path - (Finish - Status);
1201 Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
1202 Last := 1;
1203
1204 else
1205 Path_Buffer
1206 (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
1207 Path_Buffer (Finish + 1 .. End_Path);
1208 End_Path := End_Path - Finish + Last + Status;
1209 Path_Buffer (Last + 1 .. Last + Status) :=
1210 Link_Buffer (1 .. Status);
1211 end if;
1212 end if;
1213 end if;
1214 end loop;
1215
1216 -- Too many iterations: give up
1217
1218 -- This can happen when there is a circularity in the symbolic links:
1219 -- A is a symbolic link for B, which itself is a symbolic link, and
1220 -- the target of B or of another symbolic link target of B is A.
1221 -- In this case, we return an empty string to indicate failure to
1222 -- resolve.
1223
1224 return "";
1225 end Normalize_Pathname;
1226
1227 ---------------
1228 -- Open_Read --
1229 ---------------
1230
1231 function Open_Read
1232 (Name : C_File_Name;
1233 Fmode : Mode)
1234 return File_Descriptor
1235 is
1236 function C_Open_Read
1237 (Name : C_File_Name;
1238 Fmode : Mode)
1239 return File_Descriptor;
1240 pragma Import (C, C_Open_Read, "__gnat_open_read");
1241
1242 begin
1243 return C_Open_Read (Name, Fmode);
1244 end Open_Read;
1245
1246 function Open_Read
1247 (Name : String;
1248 Fmode : Mode)
1249 return File_Descriptor
1250 is
1251 C_Name : String (1 .. Name'Length + 1);
1252
1253 begin
1254 C_Name (1 .. Name'Length) := Name;
1255 C_Name (C_Name'Last) := ASCII.NUL;
1256 return Open_Read (C_Name (C_Name'First)'Address, Fmode);
1257 end Open_Read;
1258
1259 ---------------------
1260 -- Open_Read_Write --
1261 ---------------------
1262
1263 function Open_Read_Write
1264 (Name : C_File_Name;
1265 Fmode : Mode)
1266 return File_Descriptor
1267 is
1268 function C_Open_Read_Write
1269 (Name : C_File_Name;
1270 Fmode : Mode)
1271 return File_Descriptor;
1272 pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
1273
1274 begin
1275 return C_Open_Read_Write (Name, Fmode);
1276 end Open_Read_Write;
1277
1278 function Open_Read_Write
1279 (Name : String;
1280 Fmode : Mode)
1281 return File_Descriptor
1282 is
1283 C_Name : String (1 .. Name'Length + 1);
1284
1285 begin
1286 C_Name (1 .. Name'Length) := Name;
1287 C_Name (C_Name'Last) := ASCII.NUL;
1288 return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
1289 end Open_Read_Write;
1290
1291 -----------------
1292 -- Rename_File --
1293 -----------------
1294
1295 procedure Rename_File
1296 (Old_Name : C_File_Name;
1297 New_Name : C_File_Name;
1298 Success : out Boolean)
1299 is
1300 function rename (From, To : Address) return Integer;
1301 pragma Import (C, rename, "rename");
1302
1303 R : Integer;
1304
1305 begin
1306 R := rename (Old_Name, New_Name);
1307 Success := (R = 0);
1308 end Rename_File;
1309
1310 procedure Rename_File
1311 (Old_Name : String;
1312 New_Name : String;
1313 Success : out Boolean)
1314 is
1315 C_Old_Name : String (1 .. Old_Name'Length + 1);
1316 C_New_Name : String (1 .. New_Name'Length + 1);
1317
1318 begin
1319 C_Old_Name (1 .. Old_Name'Length) := Old_Name;
1320 C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
1321
1322 C_New_Name (1 .. New_Name'Length) := New_Name;
1323 C_New_Name (C_New_Name'Last) := ASCII.NUL;
1324
1325 Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
1326 end Rename_File;
1327
1328 ------------
1329 -- Setenv --
1330 ------------
1331
1332 procedure Setenv (Name : String; Value : String) is
1333 F_Name : String (1 .. Name'Length + 1);
1334 F_Value : String (1 .. Value'Length + 1);
1335
1336 procedure Set_Env_Value (Name, Value : System.Address);
1337 pragma Import (C, Set_Env_Value, "__gnat_set_env_value");
1338
1339 begin
1340 F_Name (1 .. Name'Length) := Name;
1341 F_Name (F_Name'Last) := ASCII.NUL;
1342
1343 F_Value (1 .. Value'Length) := Value;
1344 F_Value (F_Value'Last) := ASCII.NUL;
1345
1346 Set_Env_Value (F_Name'Address, F_Value'Address);
1347 end Setenv;
1348
1349 -----------
1350 -- Spawn --
1351 -----------
1352
1353 function Spawn
1354 (Program_Name : String;
1355 Args : Argument_List)
1356 return Integer
1357 is
1358 Junk : Process_Id;
1359 Result : Integer;
1360
1361 begin
1362 Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
1363 return Result;
1364 end Spawn;
1365
1366 procedure Spawn
1367 (Program_Name : String;
1368 Args : Argument_List;
1369 Success : out Boolean)
1370 is
1371 begin
1372 Success := (Spawn (Program_Name, Args) = 0);
1373 end Spawn;
1374
1375 --------------------
1376 -- Spawn_Internal --
1377 --------------------
1378
1379 procedure Spawn_Internal
1380 (Program_Name : String;
1381 Args : Argument_List;
1382 Result : out Integer;
1383 Pid : out Process_Id;
1384 Blocking : Boolean)
1385 is
1386
1387 procedure Spawn (Args : Argument_List);
1388 -- Call Spawn.
1389
1390 N_Args : Argument_List (Args'Range);
1391 -- Normalized arguments
1392
1393 -----------
1394 -- Spawn --
1395 -----------
1396
1397 procedure Spawn (Args : Argument_List) is
1398 type Chars is array (Positive range <>) of aliased Character;
1399 type Char_Ptr is access constant Character;
1400
1401 Command_Len : constant Positive := Program_Name'Length + 1
1402 + Args_Length (Args);
1403 Command_Last : Natural := 0;
1404 Command : aliased Chars (1 .. Command_Len);
1405 -- Command contains all characters of the Program_Name and Args,
1406 -- all terminated by ASCII.NUL characters
1407
1408 Arg_List_Len : constant Positive := Args'Length + 2;
1409 Arg_List_Last : Natural := 0;
1410 Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
1411 -- List with pointers to NUL-terminated strings of the
1412 -- Program_Name and the Args and terminated with a null pointer.
1413 -- We rely on the default initialization for the last null pointer.
1414
1415 procedure Add_To_Command (S : String);
1416 -- Add S and a NUL character to Command, updating Last
1417
1418 function Portable_Spawn (Args : Address) return Integer;
1419 pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
1420
1421 function Portable_No_Block_Spawn (Args : Address) return Process_Id;
1422 pragma Import
1423 (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
1424
1425 --------------------
1426 -- Add_To_Command --
1427 --------------------
1428
1429 procedure Add_To_Command (S : String) is
1430 First : constant Natural := Command_Last + 1;
1431
1432 begin
1433 Command_Last := Command_Last + S'Length;
1434
1435 -- Move characters one at a time, because Command has
1436 -- aliased components.
1437
1438 for J in S'Range loop
1439 Command (First + J - S'First) := S (J);
1440 end loop;
1441
1442 Command_Last := Command_Last + 1;
1443 Command (Command_Last) := ASCII.NUL;
1444
1445 Arg_List_Last := Arg_List_Last + 1;
1446 Arg_List (Arg_List_Last) := Command (First)'Access;
1447 end Add_To_Command;
1448
1449 -- Start of processing for Spawn
1450
1451 begin
1452 Add_To_Command (Program_Name);
1453
1454 for J in Args'Range loop
1455 Add_To_Command (Args (J).all);
1456 end loop;
1457
1458 if Blocking then
1459 Pid := Invalid_Pid;
1460 Result := Portable_Spawn (Arg_List'Address);
1461 else
1462 Pid := Portable_No_Block_Spawn (Arg_List'Address);
1463 Result := Boolean'Pos (Pid /= Invalid_Pid);
1464 end if;
1465 end Spawn;
1466
1467 -- Start of processing for Spawn_Internal
1468
1469 begin
1470 -- Copy arguments into a local structure
1471
1472 for K in N_Args'Range loop
1473 N_Args (K) := new String'(Args (K).all);
1474 end loop;
1475
1476 -- Normalize those arguments
1477
1478 Normalize_Arguments (N_Args);
1479
1480 -- Call spawn using the normalized arguments
1481
1482 Spawn (N_Args);
1483
1484 -- Free arguments list
1485
1486 for K in N_Args'Range loop
1487 Free (N_Args (K));
1488 end loop;
1489 end Spawn_Internal;
1490
1491 ---------------------------
1492 -- To_Path_String_Access --
1493 ---------------------------
1494
1495 function To_Path_String_Access
1496 (Path_Addr : Address;
1497 Path_Len : Integer)
1498 return String_Access
1499 is
1500 subtype Path_String is String (1 .. Path_Len);
1501 type Path_String_Access is access Path_String;
1502
1503 function Address_To_Access is new
1504 Unchecked_Conversion (Source => Address,
1505 Target => Path_String_Access);
1506
1507 Path_Access : Path_String_Access := Address_To_Access (Path_Addr);
1508
1509 Return_Val : String_Access;
1510
1511 begin
1512 Return_Val := new String (1 .. Path_Len);
1513
1514 for J in 1 .. Path_Len loop
1515 Return_Val (J) := Path_Access (J);
1516 end loop;
1517
1518 return Return_Val;
1519 end To_Path_String_Access;
1520
1521 ------------------
1522 -- Wait_Process --
1523 ------------------
1524
1525 procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
1526 Status : Integer;
1527
1528 function Portable_Wait (S : Address) return Process_Id;
1529 pragma Import (C, Portable_Wait, "__gnat_portable_wait");
1530
1531 begin
1532 Pid := Portable_Wait (Status'Address);
1533 Success := (Status = 0);
1534 end Wait_Process;
1535
1536 end GNAT.OS_Lib;
Mirror of the offical gcc git repository hosted at gcc.gnu.org