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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [s-os_lib.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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