OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-os_lib.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.