projects / gcc.git / blob
? search:


59d615bfc3be291e3add532fe4a4a2e2ab275afa
[gcc.git] / gcc / ada / adaint.c
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * A D A I N T *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2009, Free Software Foundation, Inc. *
10 * *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 3, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. *
17 * *
18 * As a special exception under Section 7 of GPL version 3, you are granted *
19 * additional permissions described in the GCC Runtime Library Exception, *
20 * version 3.1, as published by the Free Software Foundation. *
21 * *
22 * You should have received a copy of the GNU General Public License and *
23 * a copy of the GCC Runtime Library Exception along with this program; *
24 * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see *
25 * <http://www.gnu.org/licenses/>. *
26 * *
27 * GNAT was originally developed by the GNAT team at New York University. *
28 * Extensive contributions were provided by Ada Core Technologies Inc. *
29 * *
30 ****************************************************************************/
31
32 /* This file contains those routines named by Import pragmas in
33 packages in the GNAT hierarchy (especially GNAT.OS_Lib) and in
34 package Osint. Many of the subprograms in OS_Lib import standard
35 library calls directly. This file contains all other routines. */
36
37 #ifdef __vxworks
38
39 /* No need to redefine exit here. */
40 #undef exit
41
42 /* We want to use the POSIX variants of include files. */
43 #define POSIX
44 #include "vxWorks.h"
45
46 #if defined (__mips_vxworks)
47 #include "cacheLib.h"
48 #endif /* __mips_vxworks */
49
50 #endif /* VxWorks */
51
52 #ifdef VMS
53 #define _POSIX_EXIT 1
54 #define HOST_EXECUTABLE_SUFFIX ".exe"
55 #define HOST_OBJECT_SUFFIX ".obj"
56 #endif
57
58 #ifdef IN_RTS
59 #include "tconfig.h"
60 #include "tsystem.h"
61
62 #include <sys/stat.h>
63 #include <fcntl.h>
64 #include <time.h>
65 #ifdef VMS
66 #include <unixio.h>
67 #endif
68
69 /* We don't have libiberty, so use malloc. */
70 #define xmalloc(S) malloc (S)
71 #define xrealloc(V,S) realloc (V,S)
72 #else
73 #include "config.h"
74 #include "system.h"
75 #include "version.h"
76 #endif
77
78 #if defined (__MINGW32__)
79
80 #if defined (RTX)
81 #include <windows.h>
82 #include <Rtapi.h>
83 #else
84 #include "mingw32.h"
85
86 /* Current code page to use, set in initialize.c. */
87 UINT CurrentCodePage;
88 #endif
89
90 #include <sys/utime.h>
91
92 /* For isalpha-like tests in the compiler, we're expected to resort to
93 safe-ctype.h/ISALPHA. This isn't available for the runtime library
94 build, so we fallback on ctype.h/isalpha there. */
95
96 #ifdef IN_RTS
97 #include <ctype.h>
98 #define ISALPHA isalpha
99 #endif
100
101 #elif defined (__Lynx__)
102
103 /* Lynx utime.h only defines the entities of interest to us if
104 defined (VMOS_DEV), so ... */
105 #define VMOS_DEV
106 #include <utime.h>
107 #undef VMOS_DEV
108
109 #elif !defined (VMS)
110 #include <utime.h>
111 #endif
112
113 /* wait.h processing */
114 #ifdef __MINGW32__
115 #if OLD_MINGW
116 #include <sys/wait.h>
117 #endif
118 #elif defined (__vxworks) && defined (__RTP__)
119 #include <wait.h>
120 #elif defined (__Lynx__)
121 /* ??? We really need wait.h and it includes resource.h on Lynx. GCC
122 has a resource.h header as well, included instead of the lynx
123 version in our setup, causing lots of errors. We don't really need
124 the lynx contents of this file, so just workaround the issue by
125 preventing the inclusion of the GCC header from doing anything. */
126 #define GCC_RESOURCE_H
127 #include <sys/wait.h>
128 #elif defined (__nucleus__)
129 /* No wait() or waitpid() calls available */
130 #else
131 /* Default case */
132 #include <sys/wait.h>
133 #endif
134
135 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
136 #elif defined (VMS)
137
138 /* Header files and definitions for __gnat_set_file_time_name. */
139
140 #define __NEW_STARLET 1
141 #include <vms/rms.h>
142 #include <vms/atrdef.h>
143 #include <vms/fibdef.h>
144 #include <vms/stsdef.h>
145 #include <vms/iodef.h>
146 #include <errno.h>
147 #include <vms/descrip.h>
148 #include <string.h>
149 #include <unixlib.h>
150
151 /* Use native 64-bit arithmetic. */
152 #define unix_time_to_vms(X,Y) \
153 { unsigned long long reftime, tmptime = (X); \
154 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
155 SYS$BINTIM (&unixtime, &reftime); \
156 Y = tmptime * 10000000 + reftime; }
157
158 /* descrip.h doesn't have everything ... */
159 typedef struct fibdef* __fibdef_ptr32 __attribute__ (( mode (SI) ));
160 struct dsc$descriptor_fib
161 {
162 unsigned int fib$l_len;
163 __fibdef_ptr32 fib$l_addr;
164 };
165
166 /* I/O Status Block. */
167 struct IOSB
168 {
169 unsigned short status, count;
170 unsigned int devdep;
171 };
172
173 static char *tryfile;
174
175 /* Variable length string. */
176 struct vstring
177 {
178 short length;
179 char string[NAM$C_MAXRSS+1];
180 };
181
182 #else
183 #include <utime.h>
184 #endif
185
186 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
187 #include <process.h>
188 #endif
189
190 #if defined (_WIN32)
191 #include <dir.h>
192 #include <windows.h>
193 #include <accctrl.h>
194 #include <aclapi.h>
195 #undef DIR_SEPARATOR
196 #define DIR_SEPARATOR '\\'
197 #endif
198
199 #include "adaint.h"
200
201 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
202 defined in the current system. On DOS-like systems these flags control
203 whether the file is opened/created in text-translation mode (CR/LF in
204 external file mapped to LF in internal file), but in Unix-like systems,
205 no text translation is required, so these flags have no effect. */
206
207 #if defined (__EMX__)
208 #include <os2.h>
209 #endif
210
211 #if defined (MSDOS)
212 #include <dos.h>
213 #endif
214
215 #ifndef O_BINARY
216 #define O_BINARY 0
217 #endif
218
219 #ifndef O_TEXT
220 #define O_TEXT 0
221 #endif
222
223 #ifndef HOST_EXECUTABLE_SUFFIX
224 #define HOST_EXECUTABLE_SUFFIX ""
225 #endif
226
227 #ifndef HOST_OBJECT_SUFFIX
228 #define HOST_OBJECT_SUFFIX ".o"
229 #endif
230
231 #ifndef PATH_SEPARATOR
232 #define PATH_SEPARATOR ':'
233 #endif
234
235 #ifndef DIR_SEPARATOR
236 #define DIR_SEPARATOR '/'
237 #endif
238
239 /* Check for cross-compilation */
240 #if defined (CROSS_COMPILE) || defined (CROSS_DIRECTORY_STRUCTURE)
241 #define IS_CROSS 1
242 int __gnat_is_cross_compiler = 1;
243 #else
244 #undef IS_CROSS
245 int __gnat_is_cross_compiler = 0;
246 #endif
247
248 char __gnat_dir_separator = DIR_SEPARATOR;
249
250 char __gnat_path_separator = PATH_SEPARATOR;
251
252 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
253 the base filenames that libraries specified with -lsomelib options
254 may have. This is used by GNATMAKE to check whether an executable
255 is up-to-date or not. The syntax is
256
257 library_template ::= { pattern ; } pattern NUL
258 pattern ::= [ prefix ] * [ postfix ]
259
260 These should only specify names of static libraries as it makes
261 no sense to determine at link time if dynamic-link libraries are
262 up to date or not. Any libraries that are not found are supposed
263 to be up-to-date:
264
265 * if they are needed but not present, the link
266 will fail,
267
268 * otherwise they are libraries in the system paths and so
269 they are considered part of the system and not checked
270 for that reason.
271
272 ??? This should be part of a GNAT host-specific compiler
273 file instead of being included in all user applications
274 as well. This is only a temporary work-around for 3.11b. */
275
276 #ifndef GNAT_LIBRARY_TEMPLATE
277 #if defined (__EMX__)
278 #define GNAT_LIBRARY_TEMPLATE "*.a"
279 #elif defined (VMS)
280 #define GNAT_LIBRARY_TEMPLATE "*.olb"
281 #else
282 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
283 #endif
284 #endif
285
286 const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE;
287
288 /* This variable is used in hostparm.ads to say whether the host is a VMS
289 system. */
290 #ifdef VMS
291 const int __gnat_vmsp = 1;
292 #else
293 const int __gnat_vmsp = 0;
294 #endif
295
296 #ifdef __EMX__
297 #define GNAT_MAX_PATH_LEN MAX_PATH
298
299 #elif defined (VMS)
300 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
301
302 #elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__)
303 #define GNAT_MAX_PATH_LEN PATH_MAX
304
305 #else
306
307 #if defined (__MINGW32__)
308 #include "mingw32.h"
309
310 #if OLD_MINGW
311 #include <sys/param.h>
312 #endif
313
314 #else
315 #include <sys/param.h>
316 #endif
317
318 #ifdef MAXPATHLEN
319 #define GNAT_MAX_PATH_LEN MAXPATHLEN
320 #else
321 #define GNAT_MAX_PATH_LEN 256
322 #endif
323
324 #endif
325
326 /* The __gnat_max_path_len variable is used to export the maximum
327 length of a path name to Ada code. max_path_len is also provided
328 for compatibility with older GNAT versions, please do not use
329 it. */
330
331 int __gnat_max_path_len = GNAT_MAX_PATH_LEN;
332 int max_path_len = GNAT_MAX_PATH_LEN;
333
334 /* Control whether we can use ACL on Windows. */
335
336 int __gnat_use_acl = 1;
337
338 /* The following macro HAVE_READDIR_R should be defined if the
339 system provides the routine readdir_r. */
340 #undef HAVE_READDIR_R
341 \f
342 #if defined(VMS) && defined (__LONG_POINTERS)
343
344 /* Return a 32 bit pointer to an array of 32 bit pointers
345 given a 64 bit pointer to an array of 64 bit pointers */
346
347 typedef __char_ptr32 *__char_ptr_char_ptr32 __attribute__ ((mode (SI)));
348
349 static __char_ptr_char_ptr32
350 to_ptr32 (char **ptr64)
351 {
352 int argc;
353 __char_ptr_char_ptr32 short_argv;
354
355 for (argc=0; ptr64[argc]; argc++);
356
357 /* Reallocate argv with 32 bit pointers. */
358 short_argv = (__char_ptr_char_ptr32) decc$malloc
359 (sizeof (__char_ptr32) * (argc + 1));
360
361 for (argc=0; ptr64[argc]; argc++)
362 short_argv[argc] = (__char_ptr32) decc$strdup (ptr64[argc]);
363
364 short_argv[argc] = (__char_ptr32) 0;
365 return short_argv;
366
367 }
368 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
369 #else
370 #define MAYBE_TO_PTR32(argv) argv
371 #endif
372
373 OS_Time
374 __gnat_current_time
375 (void)
376 {
377 time_t res = time (NULL);
378 return (OS_Time) res;
379 }
380
381 /* Return the current local time as a string in the ISO 8601 format of
382 "YYYY-MM-DD HH:MM:SS.SS". The returned string is 22 + 1 (NULL) characters
383 long. */
384
385 void
386 __gnat_current_time_string
387 (char *result)
388 {
389 const char *format = "%Y-%m-%d %H:%M:%S";
390 /* Format string necessary to describe the ISO 8601 format */
391
392 const time_t t_val = time (NULL);
393
394 strftime (result, 22, format, localtime (&t_val));
395 /* Convert the local time into a string following the ISO format, copying
396 at most 22 characters into the result string. */
397
398 result [19] = '.';
399 result [20] = '0';
400 result [21] = '0';
401 /* The sub-seconds are manually set to zero since type time_t lacks the
402 precision necessary for nanoseconds. */
403 }
404
405 void
406 __gnat_to_gm_time
407 (OS_Time *p_time,
408 int *p_year,
409 int *p_month,
410 int *p_day,
411 int *p_hours,
412 int *p_mins,
413 int *p_secs)
414 {
415 struct tm *res;
416 time_t time = (time_t) *p_time;
417
418 #ifdef _WIN32
419 /* On Windows systems, the time is sometimes rounded up to the nearest
420 even second, so if the number of seconds is odd, increment it. */
421 if (time & 1)
422 time++;
423 #endif
424
425 #ifdef VMS
426 res = localtime (&time);
427 #else
428 res = gmtime (&time);
429 #endif
430
431 if (res)
432 {
433 *p_year = res->tm_year;
434 *p_month = res->tm_mon;
435 *p_day = res->tm_mday;
436 *p_hours = res->tm_hour;
437 *p_mins = res->tm_min;
438 *p_secs = res->tm_sec;
439 }
440 else
441 *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0;
442 }
443
444 /* Place the contents of the symbolic link named PATH in the buffer BUF,
445 which has size BUFSIZ. If PATH is a symbolic link, then return the number
446 of characters of its content in BUF. Otherwise, return -1.
447 For systems not supporting symbolic links, always return -1. */
448
449 int
450 __gnat_readlink (char *path ATTRIBUTE_UNUSED,
451 char *buf ATTRIBUTE_UNUSED,
452 size_t bufsiz ATTRIBUTE_UNUSED)
453 {
454 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__) \
455 || defined (VMS) || defined(__vxworks) || defined (__nucleus__)
456 return -1;
457 #else
458 return readlink (path, buf, bufsiz);
459 #endif
460 }
461
462 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH.
463 If NEWPATH exists it will NOT be overwritten.
464 For systems not supporting symbolic links, always return -1. */
465
466 int
467 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED,
468 char *newpath ATTRIBUTE_UNUSED)
469 {
470 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__) \
471 || defined (VMS) || defined(__vxworks) || defined (__nucleus__)
472 return -1;
473 #else
474 return symlink (oldpath, newpath);
475 #endif
476 }
477
478 /* Try to lock a file, return 1 if success. */
479
480 #if defined (__vxworks) || defined (__nucleus__) || defined (MSDOS) \
481 || defined (_WIN32) || defined (__EMX__) || defined (VMS)
482
483 /* Version that does not use link. */
484
485 int
486 __gnat_try_lock (char *dir, char *file)
487 {
488 int fd;
489 #ifdef __MINGW32__
490 TCHAR wfull_path[GNAT_MAX_PATH_LEN];
491 TCHAR wfile[GNAT_MAX_PATH_LEN];
492 TCHAR wdir[GNAT_MAX_PATH_LEN];
493
494 S2WSC (wdir, dir, GNAT_MAX_PATH_LEN);
495 S2WSC (wfile, file, GNAT_MAX_PATH_LEN);
496
497 _stprintf (wfull_path, _T("%s%c%s"), wdir, _T(DIR_SEPARATOR), wfile);
498 fd = _topen (wfull_path, O_CREAT | O_EXCL, 0600);
499 #else
500 char full_path[256];
501
502 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
503 fd = open (full_path, O_CREAT | O_EXCL, 0600);
504 #endif
505
506 if (fd < 0)
507 return 0;
508
509 close (fd);
510 return 1;
511 }
512
513 #else
514
515 /* Version using link(), more secure over NFS. */
516 /* See TN 6913-016 for discussion ??? */
517
518 int
519 __gnat_try_lock (char *dir, char *file)
520 {
521 char full_path[256];
522 char temp_file[256];
523 STRUCT_STAT stat_result;
524 int fd;
525
526 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
527 sprintf (temp_file, "%s%cTMP-%ld-%ld",
528 dir, DIR_SEPARATOR, (long)getpid(), (long)getppid ());
529
530 /* Create the temporary file and write the process number. */
531 fd = open (temp_file, O_CREAT | O_WRONLY, 0600);
532 if (fd < 0)
533 return 0;
534
535 close (fd);
536
537 /* Link it with the new file. */
538 link (temp_file, full_path);
539
540 /* Count the references on the old one. If we have a count of two, then
541 the link did succeed. Remove the temporary file before returning. */
542 __gnat_stat (temp_file, &stat_result);
543 unlink (temp_file);
544 return stat_result.st_nlink == 2;
545 }
546 #endif
547
548 /* Return the maximum file name length. */
549
550 int
551 __gnat_get_maximum_file_name_length (void)
552 {
553 #if defined (MSDOS)
554 return 8;
555 #elif defined (VMS)
556 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
557 return -1;
558 else
559 return 39;
560 #else
561 return -1;
562 #endif
563 }
564
565 /* Return nonzero if file names are case sensitive. */
566
567 int
568 __gnat_get_file_names_case_sensitive (void)
569 {
570 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT)
571 return 0;
572 #else
573 return 1;
574 #endif
575 }
576
577 char
578 __gnat_get_default_identifier_character_set (void)
579 {
580 #if defined (__EMX__) || defined (MSDOS)
581 return 'p';
582 #else
583 return '1';
584 #endif
585 }
586
587 /* Return the current working directory. */
588
589 void
590 __gnat_get_current_dir (char *dir, int *length)
591 {
592 #if defined (__MINGW32__)
593 TCHAR wdir[GNAT_MAX_PATH_LEN];
594
595 _tgetcwd (wdir, *length);
596
597 WS2SC (dir, wdir, GNAT_MAX_PATH_LEN);
598
599 #elif defined (VMS)
600 /* Force Unix style, which is what GNAT uses internally. */
601 getcwd (dir, *length, 0);
602 #else
603 getcwd (dir, *length);
604 #endif
605
606 *length = strlen (dir);
607
608 if (dir [*length - 1] != DIR_SEPARATOR)
609 {
610 dir [*length] = DIR_SEPARATOR;
611 ++(*length);
612 }
613 dir[*length] = '\0';
614 }
615
616 /* Return the suffix for object files. */
617
618 void
619 __gnat_get_object_suffix_ptr (int *len, const char **value)
620 {
621 *value = HOST_OBJECT_SUFFIX;
622
623 if (*value == 0)
624 *len = 0;
625 else
626 *len = strlen (*value);
627
628 return;
629 }
630
631 /* Return the suffix for executable files. */
632
633 void
634 __gnat_get_executable_suffix_ptr (int *len, const char **value)
635 {
636 *value = HOST_EXECUTABLE_SUFFIX;
637 if (!*value)
638 *len = 0;
639 else
640 *len = strlen (*value);
641
642 return;
643 }
644
645 /* Return the suffix for debuggable files. Usually this is the same as the
646 executable extension. */
647
648 void
649 __gnat_get_debuggable_suffix_ptr (int *len, const char **value)
650 {
651 #ifndef MSDOS
652 *value = HOST_EXECUTABLE_SUFFIX;
653 #else
654 /* On DOS, the extensionless COFF file is what gdb likes. */
655 *value = "";
656 #endif
657
658 if (*value == 0)
659 *len = 0;
660 else
661 *len = strlen (*value);
662
663 return;
664 }
665
666 /* Returns the OS filename and corresponding encoding. */
667
668 void
669 __gnat_os_filename (char *filename ATTRIBUTE_UNUSED,
670 char *w_filename ATTRIBUTE_UNUSED,
671 char *os_name, int *o_length,
672 char *encoding ATTRIBUTE_UNUSED, int *e_length)
673 {
674 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
675 WS2SC (os_name, (TCHAR *)w_filename, (DWORD)o_length);
676 *o_length = strlen (os_name);
677 strcpy (encoding, "encoding=utf8");
678 *e_length = strlen (encoding);
679 #else
680 strcpy (os_name, filename);
681 *o_length = strlen (filename);
682 *e_length = 0;
683 #endif
684 }
685
686 /* Delete a file. */
687
688 int
689 __gnat_unlink (char *path)
690 {
691 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
692 {
693 TCHAR wpath[GNAT_MAX_PATH_LEN];
694
695 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
696 return _tunlink (wpath);
697 }
698 #else
699 return unlink (path);
700 #endif
701 }
702
703 /* Rename a file. */
704
705 int
706 __gnat_rename (char *from, char *to)
707 {
708 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
709 {
710 TCHAR wfrom[GNAT_MAX_PATH_LEN], wto[GNAT_MAX_PATH_LEN];
711
712 S2WSC (wfrom, from, GNAT_MAX_PATH_LEN);
713 S2WSC (wto, to, GNAT_MAX_PATH_LEN);
714 return _trename (wfrom, wto);
715 }
716 #else
717 return rename (from, to);
718 #endif
719 }
720
721 /* Changing directory. */
722
723 int
724 __gnat_chdir (char *path)
725 {
726 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
727 {
728 TCHAR wpath[GNAT_MAX_PATH_LEN];
729
730 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
731 return _tchdir (wpath);
732 }
733 #else
734 return chdir (path);
735 #endif
736 }
737
738 /* Removing a directory. */
739
740 int
741 __gnat_rmdir (char *path)
742 {
743 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
744 {
745 TCHAR wpath[GNAT_MAX_PATH_LEN];
746
747 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
748 return _trmdir (wpath);
749 }
750 #elif defined (VTHREADS)
751 /* rmdir not available */
752 return -1;
753 #else
754 return rmdir (path);
755 #endif
756 }
757
758 FILE *
759 __gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED)
760 {
761 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
762 TCHAR wpath[GNAT_MAX_PATH_LEN];
763 TCHAR wmode[10];
764
765 S2WS (wmode, mode, 10);
766
767 if (encoding == Encoding_Unspecified)
768 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
769 else if (encoding == Encoding_UTF8)
770 S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
771 else
772 S2WS (wpath, path, GNAT_MAX_PATH_LEN);
773
774 return _tfopen (wpath, wmode);
775 #elif defined (VMS)
776 return decc$fopen (path, mode);
777 #else
778 return FOPEN (path, mode);
779 #endif
780 }
781
782 FILE *
783 __gnat_freopen (char *path, char *mode, FILE *stream, int encoding ATTRIBUTE_UNUSED)
784 {
785 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
786 TCHAR wpath[GNAT_MAX_PATH_LEN];
787 TCHAR wmode[10];
788
789 S2WS (wmode, mode, 10);
790
791 if (encoding == Encoding_Unspecified)
792 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
793 else if (encoding == Encoding_UTF8)
794 S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
795 else
796 S2WS (wpath, path, GNAT_MAX_PATH_LEN);
797
798 return _tfreopen (wpath, wmode, stream);
799 #elif defined (VMS)
800 return decc$freopen (path, mode, stream);
801 #else
802 return freopen (path, mode, stream);
803 #endif
804 }
805
806 int
807 __gnat_open_read (char *path, int fmode)
808 {
809 int fd;
810 int o_fmode = O_BINARY;
811
812 if (fmode)
813 o_fmode = O_TEXT;
814
815 #if defined (VMS)
816 /* Optional arguments mbc,deq,fop increase read performance. */
817 fd = open (path, O_RDONLY | o_fmode, 0444,
818 "mbc=16", "deq=64", "fop=tef");
819 #elif defined (__vxworks)
820 fd = open (path, O_RDONLY | o_fmode, 0444);
821 #elif defined (__MINGW32__)
822 {
823 TCHAR wpath[GNAT_MAX_PATH_LEN];
824
825 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
826 fd = _topen (wpath, O_RDONLY | o_fmode, 0444);
827 }
828 #else
829 fd = open (path, O_RDONLY | o_fmode);
830 #endif
831
832 return fd < 0 ? -1 : fd;
833 }
834
835 #if defined (__EMX__) || defined (__MINGW32__)
836 #define PERM (S_IREAD | S_IWRITE)
837 #elif defined (VMS)
838 /* Excerpt from DECC C RTL Reference Manual:
839 To create files with OpenVMS RMS default protections using the UNIX
840 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
841 and open with a file-protection mode argument of 0777 in a program
842 that never specifically calls umask. These default protections include
843 correctly establishing protections based on ACLs, previous versions of
844 files, and so on. */
845 #define PERM 0777
846 #else
847 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
848 #endif
849
850 int
851 __gnat_open_rw (char *path, int fmode)
852 {
853 int fd;
854 int o_fmode = O_BINARY;
855
856 if (fmode)
857 o_fmode = O_TEXT;
858
859 #if defined (VMS)
860 fd = open (path, O_RDWR | o_fmode, PERM,
861 "mbc=16", "deq=64", "fop=tef");
862 #elif defined (__MINGW32__)
863 {
864 TCHAR wpath[GNAT_MAX_PATH_LEN];
865
866 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
867 fd = _topen (wpath, O_RDWR | o_fmode, PERM);
868 }
869 #else
870 fd = open (path, O_RDWR | o_fmode, PERM);
871 #endif
872
873 return fd < 0 ? -1 : fd;
874 }
875
876 int
877 __gnat_open_create (char *path, int fmode)
878 {
879 int fd;
880 int o_fmode = O_BINARY;
881
882 if (fmode)
883 o_fmode = O_TEXT;
884
885 #if defined (VMS)
886 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM,
887 "mbc=16", "deq=64", "fop=tef");
888 #elif defined (__MINGW32__)
889 {
890 TCHAR wpath[GNAT_MAX_PATH_LEN];
891
892 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
893 fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
894 }
895 #else
896 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
897 #endif
898
899 return fd < 0 ? -1 : fd;
900 }
901
902 int
903 __gnat_create_output_file (char *path)
904 {
905 int fd;
906 #if defined (VMS)
907 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM,
908 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
909 "shr=del,get,put,upd");
910 #elif defined (__MINGW32__)
911 {
912 TCHAR wpath[GNAT_MAX_PATH_LEN];
913
914 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
915 fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
916 }
917 #else
918 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
919 #endif
920
921 return fd < 0 ? -1 : fd;
922 }
923
924 int
925 __gnat_open_append (char *path, int fmode)
926 {
927 int fd;
928 int o_fmode = O_BINARY;
929
930 if (fmode)
931 o_fmode = O_TEXT;
932
933 #if defined (VMS)
934 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM,
935 "mbc=16", "deq=64", "fop=tef");
936 #elif defined (__MINGW32__)
937 {
938 TCHAR wpath[GNAT_MAX_PATH_LEN];
939
940 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
941 fd = _topen (wpath, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
942 }
943 #else
944 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
945 #endif
946
947 return fd < 0 ? -1 : fd;
948 }
949
950 /* Open a new file. Return error (-1) if the file already exists. */
951
952 int
953 __gnat_open_new (char *path, int fmode)
954 {
955 int fd;
956 int o_fmode = O_BINARY;
957
958 if (fmode)
959 o_fmode = O_TEXT;
960
961 #if defined (VMS)
962 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
963 "mbc=16", "deq=64", "fop=tef");
964 #elif defined (__MINGW32__)
965 {
966 TCHAR wpath[GNAT_MAX_PATH_LEN];
967
968 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
969 fd = _topen (wpath, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
970 }
971 #else
972 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
973 #endif
974
975 return fd < 0 ? -1 : fd;
976 }
977
978 /* Open a new temp file. Return error (-1) if the file already exists.
979 Special options for VMS allow the file to be shared between parent and child
980 processes, however they really slow down output. Used in gnatchop. */
981
982 int
983 __gnat_open_new_temp (char *path, int fmode)
984 {
985 int fd;
986 int o_fmode = O_BINARY;
987
988 strcpy (path, "GNAT-XXXXXX");
989
990 #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \
991 || defined (linux) || defined(__GLIBC__)) && !defined (__vxworks)
992 return mkstemp (path);
993 #elif defined (__Lynx__)
994 mktemp (path);
995 #elif defined (__nucleus__)
996 return -1;
997 #else
998 if (mktemp (path) == NULL)
999 return -1;
1000 #endif
1001
1002 if (fmode)
1003 o_fmode = O_TEXT;
1004
1005 #if defined (VMS)
1006 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
1007 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
1008 "mbc=16", "deq=64", "fop=tef");
1009 #else
1010 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
1011 #endif
1012
1013 return fd < 0 ? -1 : fd;
1014 }
1015
1016 /* Return the number of bytes in the specified file. */
1017
1018 long
1019 __gnat_file_length (int fd)
1020 {
1021 int ret;
1022 STRUCT_STAT statbuf;
1023
1024 ret = FSTAT (fd, &statbuf);
1025 if (ret || !S_ISREG (statbuf.st_mode))
1026 return 0;
1027
1028 /* st_size may be 32 bits, or 64 bits which is converted to long. We
1029 don't return a useful value for files larger than 2 gigabytes in
1030 either case. */
1031
1032 return (statbuf.st_size);
1033 }
1034
1035 /* Return the number of bytes in the specified named file. */
1036
1037 long
1038 __gnat_named_file_length (char *name)
1039 {
1040 int ret;
1041 STRUCT_STAT statbuf;
1042
1043 ret = __gnat_stat (name, &statbuf);
1044 if (ret || !S_ISREG (statbuf.st_mode))
1045 return 0;
1046
1047 /* st_size may be 32 bits, or 64 bits which is converted to long. We
1048 don't return a useful value for files larger than 2 gigabytes in
1049 either case. */
1050
1051 return (statbuf.st_size);
1052 }
1053
1054 /* Create a temporary filename and put it in string pointed to by
1055 TMP_FILENAME. */
1056
1057 void
1058 __gnat_tmp_name (char *tmp_filename)
1059 {
1060 #ifdef RTX
1061 /* Variable used to create a series of unique names */
1062 static int counter = 0;
1063
1064 /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */
1065 strcpy (tmp_filename, "c:\\WINDOWS\\Temp\\gnat-");
1066 sprintf (&tmp_filename[strlen (tmp_filename)], "%d\0", counter++);
1067
1068 #elif defined (__MINGW32__)
1069 {
1070 char *pname;
1071
1072 /* tempnam tries to create a temporary file in directory pointed to by
1073 TMP environment variable, in c:\temp if TMP is not set, and in
1074 directory specified by P_tmpdir in stdio.h if c:\temp does not
1075 exist. The filename will be created with the prefix "gnat-". */
1076
1077 pname = (char *) tempnam ("c:\\temp", "gnat-");
1078
1079 /* if pname is NULL, the file was not created properly, the disk is full
1080 or there is no more free temporary files */
1081
1082 if (pname == NULL)
1083 *tmp_filename = '\0';
1084
1085 /* If pname start with a back slash and not path information it means that
1086 the filename is valid for the current working directory. */
1087
1088 else if (pname[0] == '\\')
1089 {
1090 strcpy (tmp_filename, ".\\");
1091 strcat (tmp_filename, pname+1);
1092 }
1093 else
1094 strcpy (tmp_filename, pname);
1095
1096 free (pname);
1097 }
1098
1099 #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \
1100 || defined (__OpenBSD__) || defined(__GLIBC__)
1101 #define MAX_SAFE_PATH 1000
1102 char *tmpdir = getenv ("TMPDIR");
1103
1104 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
1105 a buffer overflow. */
1106 if (tmpdir == NULL || strlen (tmpdir) > MAX_SAFE_PATH)
1107 strcpy (tmp_filename, "/tmp/gnat-XXXXXX");
1108 else
1109 sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
1110
1111 close (mkstemp(tmp_filename));
1112 #else
1113 tmpnam (tmp_filename);
1114 #endif
1115 }
1116
1117 /* Open directory and returns a DIR pointer. */
1118
1119 DIR* __gnat_opendir (char *name)
1120 {
1121 #if defined (RTX)
1122 /* Not supported in RTX */
1123
1124 return NULL;
1125
1126 #elif defined (__MINGW32__)
1127 TCHAR wname[GNAT_MAX_PATH_LEN];
1128
1129 S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1130 return (DIR*)_topendir (wname);
1131
1132 #else
1133 return opendir (name);
1134 #endif
1135 }
1136
1137 /* Read the next entry in a directory. The returned string points somewhere
1138 in the buffer. */
1139
1140 char *
1141 __gnat_readdir (DIR *dirp, char *buffer, int *len)
1142 {
1143 #if defined (RTX)
1144 /* Not supported in RTX */
1145
1146 return NULL;
1147
1148 #elif defined (__MINGW32__)
1149 struct _tdirent *dirent = _treaddir ((_TDIR*)dirp);
1150
1151 if (dirent != NULL)
1152 {
1153 WS2SC (buffer, dirent->d_name, GNAT_MAX_PATH_LEN);
1154 *len = strlen (buffer);
1155
1156 return buffer;
1157 }
1158 else
1159 return NULL;
1160
1161 #elif defined (HAVE_READDIR_R)
1162 /* If possible, try to use the thread-safe version. */
1163 if (readdir_r (dirp, buffer) != NULL)
1164 {
1165 *len = strlen (((struct dirent*) buffer)->d_name);
1166 return ((struct dirent*) buffer)->d_name;
1167 }
1168 else
1169 return NULL;
1170
1171 #else
1172 struct dirent *dirent = (struct dirent *) readdir (dirp);
1173
1174 if (dirent != NULL)
1175 {
1176 strcpy (buffer, dirent->d_name);
1177 *len = strlen (buffer);
1178 return buffer;
1179 }
1180 else
1181 return NULL;
1182
1183 #endif
1184 }
1185
1186 /* Close a directory entry. */
1187
1188 int __gnat_closedir (DIR *dirp)
1189 {
1190 #if defined (RTX)
1191 /* Not supported in RTX */
1192
1193 return 0;
1194
1195 #elif defined (__MINGW32__)
1196 return _tclosedir ((_TDIR*)dirp);
1197
1198 #else
1199 return closedir (dirp);
1200 #endif
1201 }
1202
1203 /* Returns 1 if readdir is thread safe, 0 otherwise. */
1204
1205 int
1206 __gnat_readdir_is_thread_safe (void)
1207 {
1208 #ifdef HAVE_READDIR_R
1209 return 1;
1210 #else
1211 return 0;
1212 #endif
1213 }
1214
1215 #if defined (_WIN32) && !defined (RTX)
1216 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
1217 static const unsigned long long w32_epoch_offset = 11644473600ULL;
1218
1219 /* Returns the file modification timestamp using Win32 routines which are
1220 immune against daylight saving time change. It is in fact not possible to
1221 use fstat for this purpose as the DST modify the st_mtime field of the
1222 stat structure. */
1223
1224 static time_t
1225 win32_filetime (HANDLE h)
1226 {
1227 union
1228 {
1229 FILETIME ft_time;
1230 unsigned long long ull_time;
1231 } t_write;
1232
1233 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1234 since <Jan 1st 1601>. This function must return the number of seconds
1235 since <Jan 1st 1970>. */
1236
1237 if (GetFileTime (h, NULL, NULL, &t_write.ft_time))
1238 return (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset);
1239 return (time_t) 0;
1240 }
1241 #endif
1242
1243 /* Return a GNAT time stamp given a file name. */
1244
1245 OS_Time
1246 __gnat_file_time_name (char *name)
1247 {
1248
1249 #if defined (__EMX__) || defined (MSDOS)
1250 int fd = open (name, O_RDONLY | O_BINARY);
1251 time_t ret = __gnat_file_time_fd (fd);
1252 close (fd);
1253 return (OS_Time)ret;
1254
1255 #elif defined (_WIN32) && !defined (RTX)
1256 time_t ret = -1;
1257 TCHAR wname[GNAT_MAX_PATH_LEN];
1258
1259 S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1260
1261 HANDLE h = CreateFile
1262 (wname, GENERIC_READ, FILE_SHARE_READ, 0,
1263 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
1264
1265 if (h != INVALID_HANDLE_VALUE)
1266 {
1267 ret = win32_filetime (h);
1268 CloseHandle (h);
1269 }
1270 return (OS_Time) ret;
1271 #else
1272 STRUCT_STAT statbuf;
1273 if (__gnat_stat (name, &statbuf) != 0) {
1274 return (OS_Time)-1;
1275 } else {
1276 #ifdef VMS
1277 /* VMS has file versioning. */
1278 return (OS_Time)statbuf.st_ctime;
1279 #else
1280 return (OS_Time)statbuf.st_mtime;
1281 #endif
1282 }
1283 #endif
1284 }
1285
1286 /* Return a GNAT time stamp given a file descriptor. */
1287
1288 OS_Time
1289 __gnat_file_time_fd (int fd)
1290 {
1291 /* The following workaround code is due to the fact that under EMX and
1292 DJGPP fstat attempts to convert time values to GMT rather than keep the
1293 actual OS timestamp of the file. By using the OS2/DOS functions directly
1294 the GNAT timestamp are independent of this behavior, which is desired to
1295 facilitate the distribution of GNAT compiled libraries. */
1296
1297 #if defined (__EMX__) || defined (MSDOS)
1298 #ifdef __EMX__
1299
1300 FILESTATUS fs;
1301 int ret = DosQueryFileInfo (fd, 1, (unsigned char *) &fs,
1302 sizeof (FILESTATUS));
1303
1304 unsigned file_year = fs.fdateLastWrite.year;
1305 unsigned file_month = fs.fdateLastWrite.month;
1306 unsigned file_day = fs.fdateLastWrite.day;
1307 unsigned file_hour = fs.ftimeLastWrite.hours;
1308 unsigned file_min = fs.ftimeLastWrite.minutes;
1309 unsigned file_tsec = fs.ftimeLastWrite.twosecs;
1310
1311 #else
1312 struct ftime fs;
1313 int ret = getftime (fd, &fs);
1314
1315 unsigned file_year = fs.ft_year;
1316 unsigned file_month = fs.ft_month;
1317 unsigned file_day = fs.ft_day;
1318 unsigned file_hour = fs.ft_hour;
1319 unsigned file_min = fs.ft_min;
1320 unsigned file_tsec = fs.ft_tsec;
1321 #endif
1322
1323 /* Calculate the seconds since epoch from the time components. First count
1324 the whole days passed. The value for years returned by the DOS and OS2
1325 functions count years from 1980, so to compensate for the UNIX epoch which
1326 begins in 1970 start with 10 years worth of days and add days for each
1327 four year period since then. */
1328
1329 time_t tot_secs;
1330 int cum_days[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
1331 int days_passed = 3652 + (file_year / 4) * 1461;
1332 int years_since_leap = file_year % 4;
1333
1334 if (years_since_leap == 1)
1335 days_passed += 366;
1336 else if (years_since_leap == 2)
1337 days_passed += 731;
1338 else if (years_since_leap == 3)
1339 days_passed += 1096;
1340
1341 if (file_year > 20)
1342 days_passed -= 1;
1343
1344 days_passed += cum_days[file_month - 1];
1345 if (years_since_leap == 0 && file_year != 20 && file_month > 2)
1346 days_passed++;
1347
1348 days_passed += file_day - 1;
1349
1350 /* OK - have whole days. Multiply -- then add in other parts. */
1351
1352 tot_secs = days_passed * 86400;
1353 tot_secs += file_hour * 3600;
1354 tot_secs += file_min * 60;
1355 tot_secs += file_tsec * 2;
1356 return (OS_Time) tot_secs;
1357
1358 #elif defined (_WIN32) && !defined (RTX)
1359 HANDLE h = (HANDLE) _get_osfhandle (fd);
1360 time_t ret = win32_filetime (h);
1361 return (OS_Time) ret;
1362
1363 #else
1364 STRUCT_STAT statbuf;
1365
1366 if (FSTAT (fd, &statbuf) != 0) {
1367 return (OS_Time) -1;
1368 } else {
1369 #ifdef VMS
1370 /* VMS has file versioning. */
1371 return (OS_Time) statbuf.st_ctime;
1372 #else
1373 return (OS_Time) statbuf.st_mtime;
1374 #endif
1375 }
1376 #endif
1377 }
1378
1379 /* Set the file time stamp. */
1380
1381 void
1382 __gnat_set_file_time_name (char *name, time_t time_stamp)
1383 {
1384 #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1385
1386 /* Code to implement __gnat_set_file_time_name for these systems. */
1387
1388 #elif defined (_WIN32) && !defined (RTX)
1389 union
1390 {
1391 FILETIME ft_time;
1392 unsigned long long ull_time;
1393 } t_write;
1394 TCHAR wname[GNAT_MAX_PATH_LEN];
1395
1396 S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1397
1398 HANDLE h = CreateFile
1399 (wname, GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
1400 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS,
1401 NULL);
1402 if (h == INVALID_HANDLE_VALUE)
1403 return;
1404 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1405 t_write.ull_time = ((unsigned long long)time_stamp + w32_epoch_offset);
1406 /* Convert to 100 nanosecond units */
1407 t_write.ull_time *= 10000000ULL;
1408
1409 SetFileTime(h, NULL, NULL, &t_write.ft_time);
1410 CloseHandle (h);
1411 return;
1412
1413 #elif defined (VMS)
1414 struct FAB fab;
1415 struct NAM nam;
1416
1417 struct
1418 {
1419 unsigned long long backup, create, expire, revise;
1420 unsigned int uic;
1421 union
1422 {
1423 unsigned short value;
1424 struct
1425 {
1426 unsigned system : 4;
1427 unsigned owner : 4;
1428 unsigned group : 4;
1429 unsigned world : 4;
1430 } bits;
1431 } prot;
1432 } Fat = { 0, 0, 0, 0, 0, { 0 }};
1433
1434 ATRDEF atrlst[]
1435 = {
1436 { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create },
1437 { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise },
1438 { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire },
1439 { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup },
1440 { ATR$S_FPRO, ATR$C_FPRO, &Fat.prot },
1441 { ATR$S_UIC, ATR$C_UIC, &Fat.uic },
1442 { 0, 0, 0}
1443 };
1444
1445 FIBDEF fib;
1446 struct dsc$descriptor_fib fibdsc = {sizeof (fib), (void *) &fib};
1447
1448 struct IOSB iosb;
1449
1450 unsigned long long newtime;
1451 unsigned long long revtime;
1452 long status;
1453 short chan;
1454
1455 struct vstring file;
1456 struct dsc$descriptor_s filedsc
1457 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) file.string};
1458 struct vstring device;
1459 struct dsc$descriptor_s devicedsc
1460 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) device.string};
1461 struct vstring timev;
1462 struct dsc$descriptor_s timedsc
1463 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) timev.string};
1464 struct vstring result;
1465 struct dsc$descriptor_s resultdsc
1466 = {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string};
1467
1468 /* Convert parameter name (a file spec) to host file form. Note that this
1469 is needed on VMS to prepare for subsequent calls to VMS RMS library
1470 routines. Note that it would not work to call __gnat_to_host_dir_spec
1471 as was done in a previous version, since this fails silently unless
1472 the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1473 (directory not found) condition is signalled. */
1474 tryfile = (char *) __gnat_to_host_file_spec (name);
1475
1476 /* Allocate and initialize a FAB and NAM structures. */
1477 fab = cc$rms_fab;
1478 nam = cc$rms_nam;
1479
1480 nam.nam$l_esa = file.string;
1481 nam.nam$b_ess = NAM$C_MAXRSS;
1482 nam.nam$l_rsa = result.string;
1483 nam.nam$b_rss = NAM$C_MAXRSS;
1484 fab.fab$l_fna = tryfile;
1485 fab.fab$b_fns = strlen (tryfile);
1486 fab.fab$l_nam = &nam;
1487
1488 /* Validate filespec syntax and device existence. */
1489 status = SYS$PARSE (&fab, 0, 0);
1490 if ((status & 1) != 1)
1491 LIB$SIGNAL (status);
1492
1493 file.string[nam.nam$b_esl] = 0;
1494
1495 /* Find matching filespec. */
1496 status = SYS$SEARCH (&fab, 0, 0);
1497 if ((status & 1) != 1)
1498 LIB$SIGNAL (status);
1499
1500 file.string[nam.nam$b_esl] = 0;
1501 result.string[result.length=nam.nam$b_rsl] = 0;
1502
1503 /* Get the device name and assign an IO channel. */
1504 strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev);
1505 devicedsc.dsc$w_length = nam.nam$b_dev;
1506 chan = 0;
1507 status = SYS$ASSIGN (&devicedsc, &chan, 0, 0, 0);
1508 if ((status & 1) != 1)
1509 LIB$SIGNAL (status);
1510
1511 /* Initialize the FIB and fill in the directory id field. */
1512 memset (&fib, 0, sizeof (fib));
1513 fib.fib$w_did[0] = nam.nam$w_did[0];
1514 fib.fib$w_did[1] = nam.nam$w_did[1];
1515 fib.fib$w_did[2] = nam.nam$w_did[2];
1516 fib.fib$l_acctl = 0;
1517 fib.fib$l_wcc = 0;
1518 strcpy (file.string, (strrchr (result.string, ']') + 1));
1519 filedsc.dsc$w_length = strlen (file.string);
1520 result.string[result.length = 0] = 0;
1521
1522 /* Open and close the file to fill in the attributes. */
1523 status
1524 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1525 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1526 if ((status & 1) != 1)
1527 LIB$SIGNAL (status);
1528 if ((iosb.status & 1) != 1)
1529 LIB$SIGNAL (iosb.status);
1530
1531 result.string[result.length] = 0;
1532 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, &fibdsc, 0, 0, 0,
1533 &atrlst, 0);
1534 if ((status & 1) != 1)
1535 LIB$SIGNAL (status);
1536 if ((iosb.status & 1) != 1)
1537 LIB$SIGNAL (iosb.status);
1538
1539 {
1540 time_t t;
1541
1542 /* Set creation time to requested time. */
1543 unix_time_to_vms (time_stamp, newtime);
1544
1545 t = time ((time_t) 0);
1546
1547 /* Set revision time to now in local time. */
1548 unix_time_to_vms (t, revtime);
1549 }
1550
1551 /* Reopen the file, modify the times and then close. */
1552 fib.fib$l_acctl = FIB$M_WRITE;
1553 status
1554 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1555 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1556 if ((status & 1) != 1)
1557 LIB$SIGNAL (status);
1558 if ((iosb.status & 1) != 1)
1559 LIB$SIGNAL (iosb.status);
1560
1561 Fat.create = newtime;
1562 Fat.revise = revtime;
1563
1564 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0,
1565 &fibdsc, 0, 0, 0, &atrlst, 0);
1566 if ((status & 1) != 1)
1567 LIB$SIGNAL (status);
1568 if ((iosb.status & 1) != 1)
1569 LIB$SIGNAL (iosb.status);
1570
1571 /* Deassign the channel and exit. */
1572 status = SYS$DASSGN (chan);
1573 if ((status & 1) != 1)
1574 LIB$SIGNAL (status);
1575 #else
1576 struct utimbuf utimbuf;
1577 time_t t;
1578
1579 /* Set modification time to requested time. */
1580 utimbuf.modtime = time_stamp;
1581
1582 /* Set access time to now in local time. */
1583 t = time ((time_t) 0);
1584 utimbuf.actime = mktime (localtime (&t));
1585
1586 utime (name, &utimbuf);
1587 #endif
1588 }
1589
1590 /* Get the list of installed standard libraries from the
1591 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1592 key. */
1593
1594 char *
1595 __gnat_get_libraries_from_registry (void)
1596 {
1597 char *result = (char *) xmalloc (1);
1598
1599 result[0] = '\0';
1600
1601 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) \
1602 && ! defined (RTX)
1603
1604 HKEY reg_key;
1605 DWORD name_size, value_size;
1606 char name[256];
1607 char value[256];
1608 DWORD type;
1609 DWORD index;
1610 LONG res;
1611
1612 /* First open the key. */
1613 res = RegOpenKeyExA (HKEY_LOCAL_MACHINE, "SOFTWARE", 0, KEY_READ, &reg_key);
1614
1615 if (res == ERROR_SUCCESS)
1616 res = RegOpenKeyExA (reg_key, "Ada Core Technologies", 0,
1617 KEY_READ, &reg_key);
1618
1619 if (res == ERROR_SUCCESS)
1620 res = RegOpenKeyExA (reg_key, "GNAT", 0, KEY_READ, &reg_key);
1621
1622 if (res == ERROR_SUCCESS)
1623 res = RegOpenKeyExA (reg_key, "Standard Libraries", 0, KEY_READ, &reg_key);
1624
1625 /* If the key exists, read out all the values in it and concatenate them
1626 into a path. */
1627 for (index = 0; res == ERROR_SUCCESS; index++)
1628 {
1629 value_size = name_size = 256;
1630 res = RegEnumValueA (reg_key, index, name, &name_size, 0,
1631 &type, (LPBYTE)value, &value_size);
1632
1633 if (res == ERROR_SUCCESS && type == REG_SZ)
1634 {
1635 char *old_result = result;
1636
1637 result = (char *) xmalloc (strlen (old_result) + value_size + 2);
1638 strcpy (result, old_result);
1639 strcat (result, value);
1640 strcat (result, ";");
1641 free (old_result);
1642 }
1643 }
1644
1645 /* Remove the trailing ";". */
1646 if (result[0] != 0)
1647 result[strlen (result) - 1] = 0;
1648
1649 #endif
1650 return result;
1651 }
1652
1653 int
1654 __gnat_stat (char *name, STRUCT_STAT *statbuf)
1655 {
1656 #ifdef __MINGW32__
1657 /* Under Windows the directory name for the stat function must not be
1658 terminated by a directory separator except if just after a drive name. */
1659 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1660 int name_len;
1661 TCHAR last_char;
1662
1663 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
1664 name_len = _tcslen (wname);
1665
1666 if (name_len > GNAT_MAX_PATH_LEN)
1667 return -1;
1668
1669 last_char = wname[name_len - 1];
1670
1671 while (name_len > 1 && (last_char == _T('\\') || last_char == _T('/')))
1672 {
1673 wname[name_len - 1] = _T('\0');
1674 name_len--;
1675 last_char = wname[name_len - 1];
1676 }
1677
1678 /* Only a drive letter followed by ':', we must add a directory separator
1679 for the stat routine to work properly. */
1680 if (name_len == 2 && wname[1] == _T(':'))
1681 _tcscat (wname, _T("\\"));
1682
1683 return _tstat (wname, (struct _stat *)statbuf);
1684
1685 #else
1686 return STAT (name, statbuf);
1687 #endif
1688 }
1689
1690 int
1691 __gnat_file_exists (char *name)
1692 {
1693 #ifdef __MINGW32__
1694 /* On Windows do not use __gnat_stat() because a bug in Microsoft
1695 _stat() routine. When the system time-zone is set with a negative
1696 offset the _stat() routine fails on specific files like CON: */
1697 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1698
1699 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
1700 return GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES;
1701 #else
1702 STRUCT_STAT statbuf;
1703
1704 return !__gnat_stat (name, &statbuf);
1705 #endif
1706 }
1707
1708 int
1709 __gnat_is_absolute_path (char *name, int length)
1710 {
1711 #ifdef __vxworks
1712 /* On VxWorks systems, an absolute path can be represented (depending on
1713 the host platform) as either /dir/file, or device:/dir/file, or
1714 device:drive_letter:/dir/file. */
1715
1716 int index;
1717
1718 if (name[0] == '/')
1719 return 1;
1720
1721 for (index = 0; index < length; index++)
1722 {
1723 if (name[index] == ':' &&
1724 ((name[index + 1] == '/') ||
1725 (isalpha (name[index + 1]) && index + 2 <= length &&
1726 name[index + 2] == '/')))
1727 return 1;
1728
1729 else if (name[index] == '/')
1730 return 0;
1731 }
1732 return 0;
1733 #else
1734 return (length != 0) &&
1735 (*name == '/' || *name == DIR_SEPARATOR
1736 #if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
1737 || (length > 1 && ISALPHA (name[0]) && name[1] == ':')
1738 #endif
1739 );
1740 #endif
1741 }
1742
1743 int
1744 __gnat_is_regular_file (char *name)
1745 {
1746 int ret;
1747 STRUCT_STAT statbuf;
1748
1749 ret = __gnat_stat (name, &statbuf);
1750 return (!ret && S_ISREG (statbuf.st_mode));
1751 }
1752
1753 int
1754 __gnat_is_directory (char *name)
1755 {
1756 int ret;
1757 STRUCT_STAT statbuf;
1758
1759 ret = __gnat_stat (name, &statbuf);
1760 return (!ret && S_ISDIR (statbuf.st_mode));
1761 }
1762
1763 #if defined (_WIN32) && !defined (RTX)
1764
1765 /* Returns the same constant as GetDriveType but takes a pathname as
1766 argument. */
1767
1768 static UINT
1769 GetDriveTypeFromPath (TCHAR *wfullpath)
1770 {
1771 TCHAR wdrv[MAX_PATH];
1772 TCHAR wpath[MAX_PATH];
1773 TCHAR wfilename[MAX_PATH];
1774 TCHAR wext[MAX_PATH];
1775
1776 _tsplitpath (wfullpath, wdrv, wpath, wfilename, wext);
1777
1778 if (_tcslen (wdrv) != 0)
1779 {
1780 /* we have a drive specified. */
1781 _tcscat (wdrv, _T("\\"));
1782 return GetDriveType (wdrv);
1783 }
1784 else
1785 {
1786 /* No drive specified. */
1787
1788 /* Is this a relative path, if so get current drive type. */
1789 if (wpath[0] != _T('\\') ||
1790 (_tcslen (wpath) > 2 && wpath[0] == _T('\\') && wpath[1] != _T('\\')))
1791 return GetDriveType (NULL);
1792
1793 UINT result = GetDriveType (wpath);
1794
1795 /* Cannot guess the drive type, is this \\.\ ? */
1796
1797 if (result == DRIVE_NO_ROOT_DIR &&
1798 _tcslen (wpath) >= 4 && wpath[0] == _T('\\') && wpath[1] == _T('\\')
1799 && wpath[2] == _T('.') && wpath[3] == _T('\\'))
1800 {
1801 if (_tcslen (wpath) == 4)
1802 _tcscat (wpath, wfilename);
1803
1804 LPTSTR p = &wpath[4];
1805 LPTSTR b = _tcschr (p, _T('\\'));
1806
1807 if (b != NULL)
1808 { /* logical drive \\.\c\dir\file */
1809 *b++ = _T(':');
1810 *b++ = _T('\\');
1811 *b = _T('\0');
1812 }
1813 else
1814 _tcscat (p, _T(":\\"));
1815
1816 return GetDriveType (p);
1817 }
1818
1819 return result;
1820 }
1821 }
1822
1823 /* This MingW section contains code to work with ACL. */
1824 static int
1825 __gnat_check_OWNER_ACL
1826 (TCHAR *wname,
1827 DWORD CheckAccessDesired,
1828 GENERIC_MAPPING CheckGenericMapping)
1829 {
1830 DWORD dwAccessDesired, dwAccessAllowed;
1831 PRIVILEGE_SET PrivilegeSet;
1832 DWORD dwPrivSetSize = sizeof (PRIVILEGE_SET);
1833 BOOL fAccessGranted = FALSE;
1834 HANDLE hToken = NULL;
1835 DWORD nLength = 0;
1836 SECURITY_DESCRIPTOR* pSD = NULL;
1837
1838 GetFileSecurity
1839 (wname, OWNER_SECURITY_INFORMATION |
1840 GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION,
1841 NULL, 0, &nLength);
1842
1843 if ((pSD = (PSECURITY_DESCRIPTOR) HeapAlloc
1844 (GetProcessHeap (), HEAP_ZERO_MEMORY, nLength)) == NULL)
1845 return 0;
1846
1847 /* Obtain the security descriptor. */
1848
1849 if (!GetFileSecurity
1850 (wname, OWNER_SECURITY_INFORMATION |
1851 GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION,
1852 pSD, nLength, &nLength))
1853 goto error;
1854
1855 if (!ImpersonateSelf (SecurityImpersonation))
1856 goto error;
1857
1858 if (!OpenThreadToken
1859 (GetCurrentThread(), TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken))
1860 goto error;
1861
1862 /* Undoes the effect of ImpersonateSelf. */
1863
1864 RevertToSelf ();
1865
1866 /* We want to test for write permissions. */
1867
1868 dwAccessDesired = CheckAccessDesired;
1869
1870 MapGenericMask (&dwAccessDesired, &CheckGenericMapping);
1871
1872 if (!AccessCheck
1873 (pSD , /* security descriptor to check */
1874 hToken, /* impersonation token */
1875 dwAccessDesired, /* requested access rights */
1876 &CheckGenericMapping, /* pointer to GENERIC_MAPPING */
1877 &PrivilegeSet, /* receives privileges used in check */
1878 &dwPrivSetSize, /* size of PrivilegeSet buffer */
1879 &dwAccessAllowed, /* receives mask of allowed access rights */
1880 &fAccessGranted))
1881 goto error;
1882
1883 CloseHandle (hToken);
1884 HeapFree (GetProcessHeap (), 0, pSD);
1885 return fAccessGranted;
1886
1887 error:
1888 if (hToken)
1889 CloseHandle (hToken);
1890 HeapFree (GetProcessHeap (), 0, pSD);
1891 return 0;
1892 }
1893
1894 static void
1895 __gnat_set_OWNER_ACL
1896 (TCHAR *wname,
1897 DWORD AccessMode,
1898 DWORD AccessPermissions)
1899 {
1900 ACL* pOldDACL = NULL;
1901 ACL* pNewDACL = NULL;
1902 SECURITY_DESCRIPTOR* pSD = NULL;
1903 EXPLICIT_ACCESS ea;
1904 TCHAR username [100];
1905 DWORD unsize = 100;
1906
1907 /* Get current user, he will act as the owner */
1908
1909 if (!GetUserName (username, &unsize))
1910 return;
1911
1912 if (GetNamedSecurityInfo
1913 (wname,
1914 SE_FILE_OBJECT,
1915 DACL_SECURITY_INFORMATION,
1916 NULL, NULL, &pOldDACL, NULL, &pSD) != ERROR_SUCCESS)
1917 return;
1918
1919 BuildExplicitAccessWithName
1920 (&ea, username, AccessPermissions, AccessMode, NO_INHERITANCE);
1921
1922 if (AccessMode == SET_ACCESS)
1923 {
1924 /* SET_ACCESS, we want to set an explicte set of permissions, do not
1925 merge with current DACL. */
1926 if (SetEntriesInAcl (1, &ea, NULL, &pNewDACL) != ERROR_SUCCESS)
1927 return;
1928 }
1929 else
1930 if (SetEntriesInAcl (1, &ea, pOldDACL, &pNewDACL) != ERROR_SUCCESS)
1931 return;
1932
1933 if (SetNamedSecurityInfo
1934 (wname, SE_FILE_OBJECT,
1935 DACL_SECURITY_INFORMATION, NULL, NULL, pNewDACL, NULL) != ERROR_SUCCESS)
1936 return;
1937
1938 LocalFree (pSD);
1939 LocalFree (pNewDACL);
1940 }
1941
1942 /* Check if it is possible to use ACL for wname, the file must not be on a
1943 network drive. */
1944
1945 static int
1946 __gnat_can_use_acl (TCHAR *wname)
1947 {
1948 return __gnat_use_acl && GetDriveTypeFromPath (wname) != DRIVE_REMOTE;
1949 }
1950
1951 #endif /* defined (_WIN32) && !defined (RTX) */
1952
1953 int
1954 __gnat_is_readable_file (char *name)
1955 {
1956 #if defined (_WIN32) && !defined (RTX)
1957 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1958 GENERIC_MAPPING GenericMapping;
1959
1960 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
1961
1962 if (__gnat_can_use_acl (wname))
1963 {
1964 ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
1965 GenericMapping.GenericRead = GENERIC_READ;
1966
1967 return __gnat_check_OWNER_ACL (wname, FILE_READ_DATA, GenericMapping);
1968 }
1969 else
1970 return GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES;
1971
1972 #else
1973 int ret;
1974 int mode;
1975 STRUCT_STAT statbuf;
1976
1977 ret = STAT (name, &statbuf);
1978 mode = statbuf.st_mode & S_IRUSR;
1979 return (!ret && mode);
1980 #endif
1981 }
1982
1983 int
1984 __gnat_is_writable_file (char *name)
1985 {
1986 #if defined (_WIN32) && !defined (RTX)
1987 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1988 GENERIC_MAPPING GenericMapping;
1989
1990 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
1991
1992 if (__gnat_can_use_acl (wname))
1993 {
1994 ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
1995 GenericMapping.GenericWrite = GENERIC_WRITE;
1996
1997 return __gnat_check_OWNER_ACL
1998 (wname, FILE_WRITE_DATA | FILE_APPEND_DATA, GenericMapping)
1999 && !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY);
2000 }
2001 else
2002 return !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY);
2003
2004 #else
2005 int ret;
2006 int mode;
2007 STRUCT_STAT statbuf;
2008
2009 ret = STAT (name, &statbuf);
2010 mode = statbuf.st_mode & S_IWUSR;
2011 return (!ret && mode);
2012 #endif
2013 }
2014
2015 int
2016 __gnat_is_executable_file (char *name)
2017 {
2018 #if defined (_WIN32) && !defined (RTX)
2019 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2020 GENERIC_MAPPING GenericMapping;
2021
2022 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2023
2024 if (__gnat_can_use_acl (wname))
2025 {
2026 ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
2027 GenericMapping.GenericExecute = GENERIC_EXECUTE;
2028
2029 return __gnat_check_OWNER_ACL (wname, FILE_EXECUTE, GenericMapping);
2030 }
2031 else
2032 return GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES
2033 && _tcsstr (wname, _T(".exe")) - wname == (int) (_tcslen (wname) - 4);
2034 #else
2035 int ret;
2036 int mode;
2037 STRUCT_STAT statbuf;
2038
2039 ret = STAT (name, &statbuf);
2040 mode = statbuf.st_mode & S_IXUSR;
2041 return (!ret && mode);
2042 #endif
2043 }
2044
2045 void
2046 __gnat_set_writable (char *name)
2047 {
2048 #if defined (_WIN32) && !defined (RTX)
2049 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2050
2051 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2052
2053 if (__gnat_can_use_acl (wname))
2054 __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_WRITE);
2055
2056 SetFileAttributes
2057 (wname, GetFileAttributes (wname) & ~FILE_ATTRIBUTE_READONLY);
2058 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2059 STRUCT_STAT statbuf;
2060
2061 if (STAT (name, &statbuf) == 0)
2062 {
2063 statbuf.st_mode = statbuf.st_mode | S_IWUSR;
2064 chmod (name, statbuf.st_mode);
2065 }
2066 #endif
2067 }
2068
2069 void
2070 __gnat_set_executable (char *name)
2071 {
2072 #if defined (_WIN32) && !defined (RTX)
2073 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2074
2075 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2076
2077 if (__gnat_can_use_acl (wname))
2078 __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_EXECUTE);
2079
2080 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2081 STRUCT_STAT statbuf;
2082
2083 if (STAT (name, &statbuf) == 0)
2084 {
2085 statbuf.st_mode = statbuf.st_mode | S_IXUSR;
2086 chmod (name, statbuf.st_mode);
2087 }
2088 #endif
2089 }
2090
2091 void
2092 __gnat_set_non_writable (char *name)
2093 {
2094 #if defined (_WIN32) && !defined (RTX)
2095 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2096
2097 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2098
2099 if (__gnat_can_use_acl (wname))
2100 __gnat_set_OWNER_ACL
2101 (wname, DENY_ACCESS,
2102 FILE_WRITE_DATA | FILE_APPEND_DATA |
2103 FILE_WRITE_EA | FILE_WRITE_ATTRIBUTES);
2104
2105 SetFileAttributes
2106 (wname, GetFileAttributes (wname) | FILE_ATTRIBUTE_READONLY);
2107 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2108 STRUCT_STAT statbuf;
2109
2110 if (STAT (name, &statbuf) == 0)
2111 {
2112 statbuf.st_mode = statbuf.st_mode & 07577;
2113 chmod (name, statbuf.st_mode);
2114 }
2115 #endif
2116 }
2117
2118 void
2119 __gnat_set_readable (char *name)
2120 {
2121 #if defined (_WIN32) && !defined (RTX)
2122 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2123
2124 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2125
2126 if (__gnat_can_use_acl (wname))
2127 __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_READ);
2128
2129 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2130 STRUCT_STAT statbuf;
2131
2132 if (STAT (name, &statbuf) == 0)
2133 {
2134 chmod (name, statbuf.st_mode | S_IREAD);
2135 }
2136 #endif
2137 }
2138
2139 void
2140 __gnat_set_non_readable (char *name)
2141 {
2142 #if defined (_WIN32) && !defined (RTX)
2143 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2144
2145 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2146
2147 if (__gnat_can_use_acl (wname))
2148 __gnat_set_OWNER_ACL (wname, DENY_ACCESS, FILE_GENERIC_READ);
2149
2150 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2151 STRUCT_STAT statbuf;
2152
2153 if (STAT (name, &statbuf) == 0)
2154 {
2155 chmod (name, statbuf.st_mode & (~S_IREAD));
2156 }
2157 #endif
2158 }
2159
2160 int
2161 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED)
2162 {
2163 #if defined (__vxworks) || defined (__nucleus__)
2164 return 0;
2165
2166 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
2167 int ret;
2168 STRUCT_STAT statbuf;
2169
2170 ret = LSTAT (name, &statbuf);
2171 return (!ret && S_ISLNK (statbuf.st_mode));
2172
2173 #else
2174 return 0;
2175 #endif
2176 }
2177
2178 #if defined (sun) && defined (__SVR4)
2179 /* Using fork on Solaris will duplicate all the threads. fork1, which
2180 duplicates only the active thread, must be used instead, or spawning
2181 subprocess from a program with tasking will lead into numerous problems. */
2182 #define fork fork1
2183 #endif
2184
2185 int
2186 __gnat_portable_spawn (char *args[])
2187 {
2188 int status = 0;
2189 int finished ATTRIBUTE_UNUSED;
2190 int pid ATTRIBUTE_UNUSED;
2191
2192 #if defined (__vxworks) || defined(__nucleus__) || defined(RTX)
2193 return -1;
2194
2195 #elif defined (MSDOS) || defined (_WIN32)
2196 /* args[0] must be quotes as it could contain a full pathname with spaces */
2197 char *args_0 = args[0];
2198 args[0] = (char *)xmalloc (strlen (args_0) + 3);
2199 strcpy (args[0], "\"");
2200 strcat (args[0], args_0);
2201 strcat (args[0], "\"");
2202
2203 status = spawnvp (P_WAIT, args_0, (const char* const*)args);
2204
2205 /* restore previous value */
2206 free (args[0]);
2207 args[0] = (char *)args_0;
2208
2209 if (status < 0)
2210 return -1;
2211 else
2212 return status;
2213
2214 #else
2215
2216 #ifdef __EMX__
2217 pid = spawnvp (P_NOWAIT, args[0], args);
2218 if (pid == -1)
2219 return -1;
2220
2221 #else
2222 pid = fork ();
2223 if (pid < 0)
2224 return -1;
2225
2226 if (pid == 0)
2227 {
2228 /* The child. */
2229 if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
2230 #if defined (VMS)
2231 return -1; /* execv is in parent context on VMS. */
2232 #else
2233 _exit (1);
2234 #endif
2235 }
2236 #endif
2237
2238 /* The parent. */
2239 finished = waitpid (pid, &status, 0);
2240
2241 if (finished != pid || WIFEXITED (status) == 0)
2242 return -1;
2243
2244 return WEXITSTATUS (status);
2245 #endif
2246
2247 return 0;
2248 }
2249
2250 /* Create a copy of the given file descriptor.
2251 Return -1 if an error occurred. */
2252
2253 int
2254 __gnat_dup (int oldfd)
2255 {
2256 #if defined (__vxworks) && !defined (__RTP__)
2257 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2258 RTPs. */
2259 return -1;
2260 #else
2261 return dup (oldfd);
2262 #endif
2263 }
2264
2265 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
2266 Return -1 if an error occurred. */
2267
2268 int
2269 __gnat_dup2 (int oldfd, int newfd)
2270 {
2271 #if defined (__vxworks) && !defined (__RTP__)
2272 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2273 RTPs. */
2274 return -1;
2275 #else
2276 return dup2 (oldfd, newfd);
2277 #endif
2278 }
2279
2280 /* WIN32 code to implement a wait call that wait for any child process. */
2281
2282 #if defined (_WIN32) && !defined (RTX)
2283
2284 /* Synchronization code, to be thread safe. */
2285
2286 #ifdef CERT
2287
2288 /* For the Cert run times on native Windows we use dummy functions
2289 for locking and unlocking tasks since we do not support multiple
2290 threads on this configuration (Cert run time on native Windows). */
2291
2292 void dummy (void) {}
2293
2294 void (*Lock_Task) () = &dummy;
2295 void (*Unlock_Task) () = &dummy;
2296
2297 #else
2298
2299 #define Lock_Task system__soft_links__lock_task
2300 extern void (*Lock_Task) (void);
2301
2302 #define Unlock_Task system__soft_links__unlock_task
2303 extern void (*Unlock_Task) (void);
2304
2305 #endif
2306
2307 typedef struct _process_list
2308 {
2309 HANDLE h;
2310 struct _process_list *next;
2311 } Process_List;
2312
2313 static Process_List *PLIST = NULL;
2314
2315 static int plist_length = 0;
2316
2317 static void
2318 add_handle (HANDLE h)
2319 {
2320 Process_List *pl;
2321
2322 pl = (Process_List *) xmalloc (sizeof (Process_List));
2323
2324 /* -------------------- critical section -------------------- */
2325 (*Lock_Task) ();
2326
2327 pl->h = h;
2328 pl->next = PLIST;
2329 PLIST = pl;
2330 ++plist_length;
2331
2332 (*Unlock_Task) ();
2333 /* -------------------- critical section -------------------- */
2334 }
2335
2336 static void
2337 remove_handle (HANDLE h)
2338 {
2339 Process_List *pl;
2340 Process_List *prev = NULL;
2341
2342 /* -------------------- critical section -------------------- */
2343 (*Lock_Task) ();
2344
2345 pl = PLIST;
2346 while (pl)
2347 {
2348 if (pl->h == h)
2349 {
2350 if (pl == PLIST)
2351 PLIST = pl->next;
2352 else
2353 prev->next = pl->next;
2354 free (pl);
2355 break;
2356 }
2357 else
2358 {
2359 prev = pl;
2360 pl = pl->next;
2361 }
2362 }
2363
2364 --plist_length;
2365
2366 (*Unlock_Task) ();
2367 /* -------------------- critical section -------------------- */
2368 }
2369
2370 static int
2371 win32_no_block_spawn (char *command, char *args[])
2372 {
2373 BOOL result;
2374 STARTUPINFO SI;
2375 PROCESS_INFORMATION PI;
2376 SECURITY_ATTRIBUTES SA;
2377 int csize = 1;
2378 char *full_command;
2379 int k;
2380
2381 /* compute the total command line length */
2382 k = 0;
2383 while (args[k])
2384 {
2385 csize += strlen (args[k]) + 1;
2386 k++;
2387 }
2388
2389 full_command = (char *) xmalloc (csize);
2390
2391 /* Startup info. */
2392 SI.cb = sizeof (STARTUPINFO);
2393 SI.lpReserved = NULL;
2394 SI.lpReserved2 = NULL;
2395 SI.lpDesktop = NULL;
2396 SI.cbReserved2 = 0;
2397 SI.lpTitle = NULL;
2398 SI.dwFlags = 0;
2399 SI.wShowWindow = SW_HIDE;
2400
2401 /* Security attributes. */
2402 SA.nLength = sizeof (SECURITY_ATTRIBUTES);
2403 SA.bInheritHandle = TRUE;
2404 SA.lpSecurityDescriptor = NULL;
2405
2406 /* Prepare the command string. */
2407 strcpy (full_command, command);
2408 strcat (full_command, " ");
2409
2410 k = 1;
2411 while (args[k])
2412 {
2413 strcat (full_command, args[k]);
2414 strcat (full_command, " ");
2415 k++;
2416 }
2417
2418 {
2419 int wsize = csize * 2;
2420 TCHAR *wcommand = (TCHAR *) xmalloc (wsize);
2421
2422 S2WSC (wcommand, full_command, wsize);
2423
2424 free (full_command);
2425
2426 result = CreateProcess
2427 (NULL, wcommand, &SA, NULL, TRUE,
2428 GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
2429
2430 free (wcommand);
2431 }
2432
2433 if (result == TRUE)
2434 {
2435 add_handle (PI.hProcess);
2436 CloseHandle (PI.hThread);
2437 return (int) PI.hProcess;
2438 }
2439 else
2440 return -1;
2441 }
2442
2443 static int
2444 win32_wait (int *status)
2445 {
2446 DWORD exitcode;
2447 HANDLE *hl;
2448 HANDLE h;
2449 DWORD res;
2450 int k;
2451 Process_List *pl;
2452 int hl_len;
2453
2454 if (plist_length == 0)
2455 {
2456 errno = ECHILD;
2457 return -1;
2458 }
2459
2460 k = 0;
2461
2462 /* -------------------- critical section -------------------- */
2463 (*Lock_Task) ();
2464
2465 hl_len = plist_length;
2466
2467 hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len);
2468
2469 pl = PLIST;
2470 while (pl)
2471 {
2472 hl[k++] = pl->h;
2473 pl = pl->next;
2474 }
2475
2476 (*Unlock_Task) ();
2477 /* -------------------- critical section -------------------- */
2478
2479 res = WaitForMultipleObjects (hl_len, hl, FALSE, INFINITE);
2480 h = hl[res - WAIT_OBJECT_0];
2481 free (hl);
2482
2483 remove_handle (h);
2484
2485 GetExitCodeProcess (h, &exitcode);
2486 CloseHandle (h);
2487
2488 *status = (int) exitcode;
2489 return (int) h;
2490 }
2491
2492 #endif
2493
2494 int
2495 __gnat_portable_no_block_spawn (char *args[])
2496 {
2497 int pid = 0;
2498
2499 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2500 return -1;
2501
2502 #elif defined (__EMX__) || defined (MSDOS)
2503
2504 /* ??? For PC machines I (Franco) don't know the system calls to implement
2505 this routine. So I'll fake it as follows. This routine will behave
2506 exactly like the blocking portable_spawn and will systematically return
2507 a pid of 0 unless the spawned task did not complete successfully, in
2508 which case we return a pid of -1. To synchronize with this the
2509 portable_wait below systematically returns a pid of 0 and reports that
2510 the subprocess terminated successfully. */
2511
2512 if (spawnvp (P_WAIT, args[0], args) != 0)
2513 return -1;
2514
2515 #elif defined (_WIN32)
2516
2517 pid = win32_no_block_spawn (args[0], args);
2518 return pid;
2519
2520 #else
2521 pid = fork ();
2522
2523 if (pid == 0)
2524 {
2525 /* The child. */
2526 if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
2527 #if defined (VMS)
2528 return -1; /* execv is in parent context on VMS. */
2529 #else
2530 _exit (1);
2531 #endif
2532 }
2533
2534 #endif
2535
2536 return pid;
2537 }
2538
2539 int
2540 __gnat_portable_wait (int *process_status)
2541 {
2542 int status = 0;
2543 int pid = 0;
2544
2545 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2546 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
2547 return zero. */
2548
2549 #elif defined (_WIN32)
2550
2551 pid = win32_wait (&status);
2552
2553 #elif defined (__EMX__) || defined (MSDOS)
2554 /* ??? See corresponding comment in portable_no_block_spawn. */
2555
2556 #else
2557
2558 pid = waitpid (-1, &status, 0);
2559 status = status & 0xffff;
2560 #endif
2561
2562 *process_status = status;
2563 return pid;
2564 }
2565
2566 void
2567 __gnat_os_exit (int status)
2568 {
2569 exit (status);
2570 }
2571
2572 /* Locate a regular file, give a Path value. */
2573
2574 char *
2575 __gnat_locate_regular_file (char *file_name, char *path_val)
2576 {
2577 char *ptr;
2578 char *file_path = (char *) alloca (strlen (file_name) + 1);
2579 int absolute;
2580
2581 /* Return immediately if file_name is empty */
2582
2583 if (*file_name == '\0')
2584 return 0;
2585
2586 /* Remove quotes around file_name if present */
2587
2588 ptr = file_name;
2589 if (*ptr == '"')
2590 ptr++;
2591
2592 strcpy (file_path, ptr);
2593
2594 ptr = file_path + strlen (file_path) - 1;
2595
2596 if (*ptr == '"')
2597 *ptr = '\0';
2598
2599 /* Handle absolute pathnames. */
2600
2601 absolute = __gnat_is_absolute_path (file_path, strlen (file_name));
2602
2603 if (absolute)
2604 {
2605 if (__gnat_is_regular_file (file_path))
2606 return xstrdup (file_path);
2607
2608 return 0;
2609 }
2610
2611 /* If file_name include directory separator(s), try it first as
2612 a path name relative to the current directory */
2613 for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
2614 ;
2615
2616 if (*ptr != 0)
2617 {
2618 if (__gnat_is_regular_file (file_name))
2619 return xstrdup (file_name);
2620 }
2621
2622 if (path_val == 0)
2623 return 0;
2624
2625 {
2626 /* The result has to be smaller than path_val + file_name. */
2627 char *file_path = (char *) alloca (strlen (path_val) + strlen (file_name) + 2);
2628
2629 for (;;)
2630 {
2631 for (; *path_val == PATH_SEPARATOR; path_val++)
2632 ;
2633
2634 if (*path_val == 0)
2635 return 0;
2636
2637 /* Skip the starting quote */
2638
2639 if (*path_val == '"')
2640 path_val++;
2641
2642 for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
2643 *ptr++ = *path_val++;
2644
2645 ptr--;
2646
2647 /* Skip the ending quote */
2648
2649 if (*ptr == '"')
2650 ptr--;
2651
2652 if (*ptr != '/' && *ptr != DIR_SEPARATOR)
2653 *++ptr = DIR_SEPARATOR;
2654
2655 strcpy (++ptr, file_name);
2656
2657 if (__gnat_is_regular_file (file_path))
2658 return xstrdup (file_path);
2659 }
2660 }
2661
2662 return 0;
2663 }
2664
2665 /* Locate an executable given a Path argument. This routine is only used by
2666 gnatbl and should not be used otherwise. Use locate_exec_on_path
2667 instead. */
2668
2669 char *
2670 __gnat_locate_exec (char *exec_name, char *path_val)
2671 {
2672 char *ptr;
2673 if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
2674 {
2675 char *full_exec_name
2676 = (char *) alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
2677
2678 strcpy (full_exec_name, exec_name);
2679 strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
2680 ptr = __gnat_locate_regular_file (full_exec_name, path_val);
2681
2682 if (ptr == 0)
2683 return __gnat_locate_regular_file (exec_name, path_val);
2684 return ptr;
2685 }
2686 else
2687 return __gnat_locate_regular_file (exec_name, path_val);
2688 }
2689
2690 /* Locate an executable using the Systems default PATH. */
2691
2692 char *
2693 __gnat_locate_exec_on_path (char *exec_name)
2694 {
2695 char *apath_val;
2696
2697 #if defined (_WIN32) && !defined (RTX)
2698 TCHAR *wpath_val = _tgetenv (_T("PATH"));
2699 TCHAR *wapath_val;
2700 /* In Win32 systems we expand the PATH as for XP environment
2701 variables are not automatically expanded. We also prepend the
2702 ".;" to the path to match normal NT path search semantics */
2703
2704 #define EXPAND_BUFFER_SIZE 32767
2705
2706 wapath_val = alloca (EXPAND_BUFFER_SIZE);
2707
2708 wapath_val [0] = '.';
2709 wapath_val [1] = ';';
2710
2711 DWORD res = ExpandEnvironmentStrings
2712 (wpath_val, &wapath_val[2], EXPAND_BUFFER_SIZE - 2);
2713
2714 if (!res) wapath_val [0] = _T('\0');
2715
2716 apath_val = alloca (EXPAND_BUFFER_SIZE);
2717
2718 WS2SC (apath_val, wapath_val, EXPAND_BUFFER_SIZE);
2719 return __gnat_locate_exec (exec_name, apath_val);
2720
2721 #else
2722
2723 #ifdef VMS
2724 char *path_val = "/VAXC$PATH";
2725 #else
2726 char *path_val = getenv ("PATH");
2727 #endif
2728 if (path_val == NULL) return NULL;
2729 apath_val = (char *) alloca (strlen (path_val) + 1);
2730 strcpy (apath_val, path_val);
2731 return __gnat_locate_exec (exec_name, apath_val);
2732 #endif
2733 }
2734
2735 #ifdef VMS
2736
2737 /* These functions are used to translate to and from VMS and Unix syntax
2738 file, directory and path specifications. */
2739
2740 #define MAXPATH 256
2741 #define MAXNAMES 256
2742 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2743
2744 static char new_canonical_dirspec [MAXPATH];
2745 static char new_canonical_filespec [MAXPATH];
2746 static char new_canonical_pathspec [MAXNAMES*MAXPATH];
2747 static unsigned new_canonical_filelist_index;
2748 static unsigned new_canonical_filelist_in_use;
2749 static unsigned new_canonical_filelist_allocated;
2750 static char **new_canonical_filelist;
2751 static char new_host_pathspec [MAXNAMES*MAXPATH];
2752 static char new_host_dirspec [MAXPATH];
2753 static char new_host_filespec [MAXPATH];
2754
2755 /* Routine is called repeatedly by decc$from_vms via
2756 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2757 runs out. */
2758
2759 static int
2760 wildcard_translate_unix (char *name)
2761 {
2762 char *ver;
2763 char buff [MAXPATH];
2764
2765 strncpy (buff, name, MAXPATH);
2766 buff [MAXPATH - 1] = (char) 0;
2767 ver = strrchr (buff, '.');
2768
2769 /* Chop off the version. */
2770 if (ver)
2771 *ver = 0;
2772
2773 /* Dynamically extend the allocation by the increment. */
2774 if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
2775 {
2776 new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
2777 new_canonical_filelist = (char **) xrealloc
2778 (new_canonical_filelist,
2779 new_canonical_filelist_allocated * sizeof (char *));
2780 }
2781
2782 new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
2783
2784 return 1;
2785 }
2786
2787 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2788 full translation and copy the results into a list (_init), then return them
2789 one at a time (_next). If onlydirs set, only expand directory files. */
2790
2791 int
2792 __gnat_to_canonical_file_list_init (char *filespec, int onlydirs)
2793 {
2794 int len;
2795 char buff [MAXPATH];
2796
2797 len = strlen (filespec);
2798 strncpy (buff, filespec, MAXPATH);
2799
2800 /* Only look for directories */
2801 if (onlydirs && !strstr (&buff [len-5], "*.dir"))
2802 strncat (buff, "*.dir", MAXPATH);
2803
2804 buff [MAXPATH - 1] = (char) 0;
2805
2806 decc$from_vms (buff, wildcard_translate_unix, 1);
2807
2808 /* Remove the .dir extension. */
2809 if (onlydirs)
2810 {
2811 int i;
2812 char *ext;
2813
2814 for (i = 0; i < new_canonical_filelist_in_use; i++)
2815 {
2816 ext = strstr (new_canonical_filelist[i], ".dir");
2817 if (ext)
2818 *ext = 0;
2819 }
2820 }
2821
2822 return new_canonical_filelist_in_use;
2823 }
2824
2825 /* Return the next filespec in the list. */
2826
2827 char *
2828 __gnat_to_canonical_file_list_next ()
2829 {
2830 return new_canonical_filelist[new_canonical_filelist_index++];
2831 }
2832
2833 /* Free storage used in the wildcard expansion. */
2834
2835 void
2836 __gnat_to_canonical_file_list_free ()
2837 {
2838 int i;
2839
2840 for (i = 0; i < new_canonical_filelist_in_use; i++)
2841 free (new_canonical_filelist[i]);
2842
2843 free (new_canonical_filelist);
2844
2845 new_canonical_filelist_in_use = 0;
2846 new_canonical_filelist_allocated = 0;
2847 new_canonical_filelist_index = 0;
2848 new_canonical_filelist = 0;
2849 }
2850
2851 /* The functional equivalent of decc$translate_vms routine.
2852 Designed to produce the same output, but is protected against
2853 malformed paths (original version ACCVIOs in this case) and
2854 does not require VMS-specific DECC RTL */
2855
2856 #define NAM$C_MAXRSS 1024
2857
2858 char *
2859 __gnat_translate_vms (char *src)
2860 {
2861 static char retbuf [NAM$C_MAXRSS+1];
2862 char *srcendpos, *pos1, *pos2, *retpos;
2863 int disp, path_present = 0;
2864
2865 if (!src) return NULL;
2866
2867 srcendpos = strchr (src, '\0');
2868 retpos = retbuf;
2869
2870 /* Look for the node and/or device in front of the path */
2871 pos1 = src;
2872 pos2 = strchr (pos1, ':');
2873
2874 if (pos2 && (pos2 < srcendpos) && (*(pos2 + 1) == ':')) {
2875 /* There is a node name. "node_name::" becomes "node_name!" */
2876 disp = pos2 - pos1;
2877 strncpy (retbuf, pos1, disp);
2878 retpos [disp] = '!';
2879 retpos = retpos + disp + 1;
2880 pos1 = pos2 + 2;
2881 pos2 = strchr (pos1, ':');
2882 }
2883
2884 if (pos2) {
2885 /* There is a device name. "dev_name:" becomes "/dev_name/" */
2886 *(retpos++) = '/';
2887 disp = pos2 - pos1;
2888 strncpy (retpos, pos1, disp);
2889 retpos = retpos + disp;
2890 pos1 = pos2 + 1;
2891 *(retpos++) = '/';
2892 }
2893 else
2894 /* No explicit device; we must look ahead and prepend /sys$disk/ if
2895 the path is absolute */
2896 if ((*pos1 == '[' || *pos1 == '<') && (pos1 < srcendpos)
2897 && !strchr (".-]>", *(pos1 + 1))) {
2898 strncpy (retpos, "/sys$disk/", 10);
2899 retpos += 10;
2900 }
2901
2902 /* Process the path part */
2903 while (*pos1 == '[' || *pos1 == '<') {
2904 path_present++;
2905 pos1++;
2906 if (*pos1 == ']' || *pos1 == '>') {
2907 /* Special case, [] translates to '.' */
2908 *(retpos++) = '.';
2909 pos1++;
2910 }
2911 else {
2912 /* '[000000' means root dir. It can be present in the middle of
2913 the path due to expansion of logical devices, in which case
2914 we skip it */
2915 if (!strncmp (pos1, "000000", 6) && path_present > 1 &&
2916 (*(pos1 + 6) == ']' || *(pos1 + 6) == '>' || *(pos1 + 6) == '.')) {
2917 pos1 += 6;
2918 if (*pos1 == '.') pos1++;
2919 }
2920 else if (*pos1 == '.') {
2921 /* Relative path */
2922 *(retpos++) = '.';
2923 }
2924
2925 /* There is a qualified path */
2926 while (*pos1 && *pos1 != ']' && *pos1 != '>') {
2927 switch (*pos1) {
2928 case '.':
2929 /* '.' is used to separate directories. Replace it with '/' but
2930 only if there isn't already '/' just before */
2931 if (*(retpos - 1) != '/') *(retpos++) = '/';
2932 pos1++;
2933 if (pos1 + 1 < srcendpos && *pos1 == '.' && *(pos1 + 1) == '.') {
2934 /* ellipsis refers to entire subtree; replace with '**' */
2935 *(retpos++) = '*'; *(retpos++) = '*'; *(retpos++) = '/';
2936 pos1 += 2;
2937 }
2938 break;
2939 case '-' :
2940 /* When after '.' '[' '<' is equivalent to Unix ".." but there
2941 may be several in a row */
2942 if (*(pos1 - 1) == '.' || *(pos1 - 1) == '[' ||
2943 *(pos1 - 1) == '<') {
2944 while (*pos1 == '-') {
2945 pos1++;
2946 *(retpos++) = '.'; *(retpos++) = '.'; *(retpos++) = '/';
2947 }
2948 retpos--;
2949 break;
2950 }
2951 /* otherwise fall through to default */
2952 default:
2953 *(retpos++) = *(pos1++);
2954 }
2955 }
2956 pos1++;
2957 }
2958 }
2959
2960 if (pos1 < srcendpos) {
2961 /* Now add the actual file name, until the version suffix if any */
2962 if (path_present) *(retpos++) = '/';
2963 pos2 = strchr (pos1, ';');
2964 disp = pos2? (pos2 - pos1) : (srcendpos - pos1);
2965 strncpy (retpos, pos1, disp);
2966 retpos += disp;
2967 if (pos2 && pos2 < srcendpos) {
2968 /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
2969 *retpos++ = '.';
2970 disp = srcendpos - pos2 - 1;
2971 strncpy (retpos, pos2 + 1, disp);
2972 retpos += disp;
2973 }
2974 }
2975
2976 *retpos = '\0';
2977
2978 return retbuf;
2979
2980 }
2981
2982 /* Translate a VMS syntax directory specification in to Unix syntax. If
2983 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2984 found, return input string. Also translate a dirname that contains no
2985 slashes, in case it's a logical name. */
2986
2987 char *
2988 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag)
2989 {
2990 int len;
2991
2992 strcpy (new_canonical_dirspec, "");
2993 if (strlen (dirspec))
2994 {
2995 char *dirspec1;
2996
2997 if (strchr (dirspec, ']') || strchr (dirspec, ':'))
2998 {
2999 strncpy (new_canonical_dirspec,
3000 __gnat_translate_vms (dirspec),
3001 MAXPATH);
3002 }
3003 else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
3004 {
3005 strncpy (new_canonical_dirspec,
3006 __gnat_translate_vms (dirspec1),
3007 MAXPATH);
3008 }
3009 else
3010 {
3011 strncpy (new_canonical_dirspec, dirspec, MAXPATH);
3012 }
3013 }
3014
3015 len = strlen (new_canonical_dirspec);
3016 if (prefixflag && new_canonical_dirspec [len-1] != '/')
3017 strncat (new_canonical_dirspec, "/", MAXPATH);
3018
3019 new_canonical_dirspec [MAXPATH - 1] = (char) 0;
3020
3021 return new_canonical_dirspec;
3022
3023 }
3024
3025 /* Translate a VMS syntax file specification into Unix syntax.
3026 If no indicators of VMS syntax found, check if it's an uppercase
3027 alphanumeric_ name and if so try it out as an environment
3028 variable (logical name). If all else fails return the
3029 input string. */
3030
3031 char *
3032 __gnat_to_canonical_file_spec (char *filespec)
3033 {
3034 char *filespec1;
3035
3036 strncpy (new_canonical_filespec, "", MAXPATH);
3037
3038 if (strchr (filespec, ']') || strchr (filespec, ':'))
3039 {
3040 char *tspec = (char *) __gnat_translate_vms (filespec);
3041
3042 if (tspec != (char *) -1)
3043 strncpy (new_canonical_filespec, tspec, MAXPATH);
3044 }
3045 else if ((strlen (filespec) == strspn (filespec,
3046 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
3047 && (filespec1 = getenv (filespec)))
3048 {
3049 char *tspec = (char *) __gnat_translate_vms (filespec1);
3050
3051 if (tspec != (char *) -1)
3052 strncpy (new_canonical_filespec, tspec, MAXPATH);
3053 }
3054 else
3055 {
3056 strncpy (new_canonical_filespec, filespec, MAXPATH);
3057 }
3058
3059 new_canonical_filespec [MAXPATH - 1] = (char) 0;
3060
3061 return new_canonical_filespec;
3062 }
3063
3064 /* Translate a VMS syntax path specification into Unix syntax.
3065 If no indicators of VMS syntax found, return input string. */
3066
3067 char *
3068 __gnat_to_canonical_path_spec (char *pathspec)
3069 {
3070 char *curr, *next, buff [MAXPATH];
3071
3072 if (pathspec == 0)
3073 return pathspec;
3074
3075 /* If there are /'s, assume it's a Unix path spec and return. */
3076 if (strchr (pathspec, '/'))
3077 return pathspec;
3078
3079 new_canonical_pathspec[0] = 0;
3080 curr = pathspec;
3081
3082 for (;;)
3083 {
3084 next = strchr (curr, ',');
3085 if (next == 0)
3086 next = strchr (curr, 0);
3087
3088 strncpy (buff, curr, next - curr);
3089 buff[next - curr] = 0;
3090
3091 /* Check for wildcards and expand if present. */
3092 if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
3093 {
3094 int i, dirs;
3095
3096 dirs = __gnat_to_canonical_file_list_init (buff, 1);
3097 for (i = 0; i < dirs; i++)
3098 {
3099 char *next_dir;
3100
3101 next_dir = __gnat_to_canonical_file_list_next ();
3102 strncat (new_canonical_pathspec, next_dir, MAXPATH);
3103
3104 /* Don't append the separator after the last expansion. */
3105 if (i+1 < dirs)
3106 strncat (new_canonical_pathspec, ":", MAXPATH);
3107 }
3108
3109 __gnat_to_canonical_file_list_free ();
3110 }
3111 else
3112 strncat (new_canonical_pathspec,
3113 __gnat_to_canonical_dir_spec (buff, 0), MAXPATH);
3114
3115 if (*next == 0)
3116 break;
3117
3118 strncat (new_canonical_pathspec, ":", MAXPATH);
3119 curr = next + 1;
3120 }
3121
3122 new_canonical_pathspec [MAXPATH - 1] = (char) 0;
3123
3124 return new_canonical_pathspec;
3125 }
3126
3127 static char filename_buff [MAXPATH];
3128
3129 static int
3130 translate_unix (char *name, int type)
3131 {
3132 strncpy (filename_buff, name, MAXPATH);
3133 filename_buff [MAXPATH - 1] = (char) 0;
3134 return 0;
3135 }
3136
3137 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
3138 directories. */
3139
3140 static char *
3141 to_host_path_spec (char *pathspec)
3142 {
3143 char *curr, *next, buff [MAXPATH];
3144
3145 if (pathspec == 0)
3146 return pathspec;
3147
3148 /* Can't very well test for colons, since that's the Unix separator! */
3149 if (strchr (pathspec, ']') || strchr (pathspec, ','))
3150 return pathspec;
3151
3152 new_host_pathspec[0] = 0;
3153 curr = pathspec;
3154
3155 for (;;)
3156 {
3157 next = strchr (curr, ':');
3158 if (next == 0)
3159 next = strchr (curr, 0);
3160
3161 strncpy (buff, curr, next - curr);
3162 buff[next - curr] = 0;
3163
3164 strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH);
3165 if (*next == 0)
3166 break;
3167 strncat (new_host_pathspec, ",", MAXPATH);
3168 curr = next + 1;
3169 }
3170
3171 new_host_pathspec [MAXPATH - 1] = (char) 0;
3172
3173 return new_host_pathspec;
3174 }
3175
3176 /* Translate a Unix syntax directory specification into VMS syntax. The
3177 PREFIXFLAG has no effect, but is kept for symmetry with
3178 to_canonical_dir_spec. If indicators of VMS syntax found, return input
3179 string. */
3180
3181 char *
3182 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3183 {
3184 int len = strlen (dirspec);
3185
3186 strncpy (new_host_dirspec, dirspec, MAXPATH);
3187 new_host_dirspec [MAXPATH - 1] = (char) 0;
3188
3189 if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
3190 return new_host_dirspec;
3191
3192 while (len > 1 && new_host_dirspec[len - 1] == '/')
3193 {
3194 new_host_dirspec[len - 1] = 0;
3195 len--;
3196 }
3197
3198 decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
3199 strncpy (new_host_dirspec, filename_buff, MAXPATH);
3200 new_host_dirspec [MAXPATH - 1] = (char) 0;
3201
3202 return new_host_dirspec;
3203 }
3204
3205 /* Translate a Unix syntax file specification into VMS syntax.
3206 If indicators of VMS syntax found, return input string. */
3207
3208 char *
3209 __gnat_to_host_file_spec (char *filespec)
3210 {
3211 strncpy (new_host_filespec, "", MAXPATH);
3212 if (strchr (filespec, ']') || strchr (filespec, ':'))
3213 {
3214 strncpy (new_host_filespec, filespec, MAXPATH);
3215 }
3216 else
3217 {
3218 decc$to_vms (filespec, translate_unix, 1, 1);
3219 strncpy (new_host_filespec, filename_buff, MAXPATH);
3220 }
3221
3222 new_host_filespec [MAXPATH - 1] = (char) 0;
3223
3224 return new_host_filespec;
3225 }
3226
3227 void
3228 __gnat_adjust_os_resource_limits ()
3229 {
3230 SYS$ADJWSL (131072, 0);
3231 }
3232
3233 #else /* VMS */
3234
3235 /* Dummy functions for Osint import for non-VMS systems. */
3236
3237 int
3238 __gnat_to_canonical_file_list_init
3239 (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED)
3240 {
3241 return 0;
3242 }
3243
3244 char *
3245 __gnat_to_canonical_file_list_next (void)
3246 {
3247 return (char *) "";
3248 }
3249
3250 void
3251 __gnat_to_canonical_file_list_free (void)
3252 {
3253 }
3254
3255 char *
3256 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3257 {
3258 return dirspec;
3259 }
3260
3261 char *
3262 __gnat_to_canonical_file_spec (char *filespec)
3263 {
3264 return filespec;
3265 }
3266
3267 char *
3268 __gnat_to_canonical_path_spec (char *pathspec)
3269 {
3270 return pathspec;
3271 }
3272
3273 char *
3274 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3275 {
3276 return dirspec;
3277 }
3278
3279 char *
3280 __gnat_to_host_file_spec (char *filespec)
3281 {
3282 return filespec;
3283 }
3284
3285 void
3286 __gnat_adjust_os_resource_limits (void)
3287 {
3288 }
3289
3290 #endif
3291
3292 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
3293 to coordinate this with the EMX distribution. Consequently, we put the
3294 definition of dummy which is used for exception handling, here. */
3295
3296 #if defined (__EMX__)
3297 void __dummy () {}
3298 #endif
3299
3300 #if defined (__mips_vxworks)
3301 int
3302 _flush_cache()
3303 {
3304 CACHE_USER_FLUSH (0, ENTIRE_CACHE);
3305 }
3306 #endif
3307
3308 #if defined (IS_CROSS) \
3309 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3310 && defined (__SVR4)) \
3311 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3312 && ! (defined (linux) && defined (__ia64__)) \
3313 && ! (defined (linux) && defined (powerpc)) \
3314 && ! defined (__FreeBSD__) \
3315 && ! defined (__hpux__) \
3316 && ! defined (__APPLE__) \
3317 && ! defined (_AIX) \
3318 && ! (defined (__alpha__) && defined (__osf__)) \
3319 && ! defined (VMS) \
3320 && ! defined (__MINGW32__) \
3321 && ! (defined (__mips) && defined (__sgi)))
3322
3323 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3324 just above for a list of native platforms that provide a non-dummy
3325 version of this procedure in libaddr2line.a. */
3326
3327 void
3328 convert_addresses (const char *file_name ATTRIBUTE_UNUSED,
3329 void *addrs ATTRIBUTE_UNUSED,
3330 int n_addr ATTRIBUTE_UNUSED,
3331 void *buf ATTRIBUTE_UNUSED,
3332 int *len ATTRIBUTE_UNUSED)
3333 {
3334 *len = 0;
3335 }
3336 #endif
3337
3338 #if defined (_WIN32)
3339 int __gnat_argument_needs_quote = 1;
3340 #else
3341 int __gnat_argument_needs_quote = 0;
3342 #endif
3343
3344 /* This option is used to enable/disable object files handling from the
3345 binder file by the GNAT Project module. For example, this is disabled on
3346 Windows (prior to GCC 3.4) as it is already done by the mdll module.
3347 Stating with GCC 3.4 the shared libraries are not based on mdll
3348 anymore as it uses the GCC's -shared option */
3349 #if defined (_WIN32) \
3350 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3351 int __gnat_prj_add_obj_files = 0;
3352 #else
3353 int __gnat_prj_add_obj_files = 1;
3354 #endif
3355
3356 /* char used as prefix/suffix for environment variables */
3357 #if defined (_WIN32)
3358 char __gnat_environment_char = '%';
3359 #else
3360 char __gnat_environment_char = '$';
3361 #endif
3362
3363 /* This functions copy the file attributes from a source file to a
3364 destination file.
3365
3366 mode = 0 : In this mode copy only the file time stamps (last access and
3367 last modification time stamps).
3368
3369 mode = 1 : In this mode, time stamps and read/write/execute attributes are
3370 copied.
3371
3372 Returns 0 if operation was successful and -1 in case of error. */
3373
3374 int
3375 __gnat_copy_attribs (char *from, char *to, int mode)
3376 {
3377 #if defined (VMS) || defined (__vxworks) || defined (__nucleus__)
3378 return -1;
3379
3380 #elif defined (_WIN32) && !defined (RTX)
3381 TCHAR wfrom [GNAT_MAX_PATH_LEN + 2];
3382 TCHAR wto [GNAT_MAX_PATH_LEN + 2];
3383 BOOL res;
3384 FILETIME fct, flat, flwt;
3385 HANDLE hfrom, hto;
3386
3387 S2WSC (wfrom, from, GNAT_MAX_PATH_LEN + 2);
3388 S2WSC (wto, to, GNAT_MAX_PATH_LEN + 2);
3389
3390 /* retrieve from times */
3391
3392 hfrom = CreateFile
3393 (wfrom, GENERIC_READ, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
3394
3395 if (hfrom == INVALID_HANDLE_VALUE)
3396 return -1;
3397
3398 res = GetFileTime (hfrom, &fct, &flat, &flwt);
3399
3400 CloseHandle (hfrom);
3401
3402 if (res == 0)
3403 return -1;
3404
3405 /* retrieve from times */
3406
3407 hto = CreateFile
3408 (wto, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
3409
3410 if (hto == INVALID_HANDLE_VALUE)
3411 return -1;
3412
3413 res = SetFileTime (hto, NULL, &flat, &flwt);
3414
3415 CloseHandle (hto);
3416
3417 if (res == 0)
3418 return -1;
3419
3420 /* Set file attributes in full mode. */
3421
3422 if (mode == 1)
3423 {
3424 DWORD attribs = GetFileAttributes (wfrom);
3425
3426 if (attribs == INVALID_FILE_ATTRIBUTES)
3427 return -1;
3428
3429 res = SetFileAttributes (wto, attribs);
3430 if (res == 0)
3431 return -1;
3432 }
3433
3434 return 0;
3435
3436 #else
3437 STRUCT_STAT fbuf;
3438 struct utimbuf tbuf;
3439
3440 if (STAT (from, &fbuf) == -1)
3441 {
3442 return -1;
3443 }
3444
3445 tbuf.actime = fbuf.st_atime;
3446 tbuf.modtime = fbuf.st_mtime;
3447
3448 if (utime (to, &tbuf) == -1)
3449 {
3450 return -1;
3451 }
3452
3453 if (mode == 1)
3454 {
3455 if (chmod (to, fbuf.st_mode) == -1)
3456 {
3457 return -1;
3458 }
3459 }
3460
3461 return 0;
3462 #endif
3463 }
3464
3465 int
3466 __gnat_lseek (int fd, long offset, int whence)
3467 {
3468 return (int) lseek (fd, offset, whence);
3469 }
3470
3471 /* This function returns the major version number of GCC being used. */
3472 int
3473 get_gcc_version (void)
3474 {
3475 #ifdef IN_RTS
3476 return __GNUC__;
3477 #else
3478 return (int) (version_string[0] - '0');
3479 #endif
3480 }
3481
3482 int
3483 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED,
3484 int close_on_exec_p ATTRIBUTE_UNUSED)
3485 {
3486 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3487 int flags = fcntl (fd, F_GETFD, 0);
3488 if (flags < 0)
3489 return flags;
3490 if (close_on_exec_p)
3491 flags |= FD_CLOEXEC;
3492 else
3493 flags &= ~FD_CLOEXEC;
3494 return fcntl (fd, F_SETFD, flags | FD_CLOEXEC);
3495 #elif defined(_WIN32)
3496 HANDLE h = (HANDLE) _get_osfhandle (fd);
3497 if (h == (HANDLE) -1)
3498 return -1;
3499 if (close_on_exec_p)
3500 return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT, 0);
3501 return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT,
3502 HANDLE_FLAG_INHERIT);
3503 #else
3504 /* TODO: Unimplemented. */
3505 return -1;
3506 #endif
3507 }
3508
3509 /* Indicates if platforms supports automatic initialization through the
3510 constructor mechanism */
3511 int
3512 __gnat_binder_supports_auto_init ()
3513 {
3514 #ifdef VMS
3515 return 0;
3516 #else
3517 return 1;
3518 #endif
3519 }
3520
3521 /* Indicates that Stand-Alone Libraries are automatically initialized through
3522 the constructor mechanism */
3523 int
3524 __gnat_sals_init_using_constructors ()
3525 {
3526 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3527 return 0;
3528 #else
3529 return 1;
3530 #endif
3531 }
3532
3533 #ifdef RTX
3534
3535 /* In RTX mode, the procedure to get the time (as file time) is different
3536 in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3537 we introduce an intermediate procedure to link against the corresponding
3538 one in each situation. */
3539
3540 extern void GetTimeAsFileTime(LPFILETIME pTime);
3541
3542 void GetTimeAsFileTime(LPFILETIME pTime)
3543 {
3544 #ifdef RTSS
3545 RtGetRtssTimeAsFileTime (pTime); /* RTSS interface */
3546 #else
3547 GetSystemTimeAsFileTime (pTime); /* w32 interface */
3548 #endif
3549 }
3550
3551 #ifdef RTSS
3552 /* Add symbol that is required to link. It would otherwise be taken from
3553 libgcc.a and it would try to use the gcc constructors that are not
3554 supported by Microsoft linker. */
3555
3556 extern void __main (void);
3557
3558 void __main (void) {}
3559 #endif
3560 #endif
3561
3562 #if defined (linux) || defined(__GLIBC__)
3563 /* pthread affinity support */
3564
3565 int __gnat_pthread_setaffinity_np (pthread_t th,
3566 size_t cpusetsize,
3567 const void *cpuset);
3568
3569 #ifdef CPU_SETSIZE
3570 #include <pthread.h>
3571 int
3572 __gnat_pthread_setaffinity_np (pthread_t th,
3573 size_t cpusetsize,
3574 const cpu_set_t *cpuset)
3575 {
3576 return pthread_setaffinity_np (th, cpusetsize, cpuset);
3577 }
3578 #else
3579 int
3580 __gnat_pthread_setaffinity_np (pthread_t th ATTRIBUTE_UNUSED,
3581 size_t cpusetsize ATTRIBUTE_UNUSED,
3582 const void *cpuset ATTRIBUTE_UNUSED)
3583 {
3584 return 0;
3585 }
3586 #endif
3587 #endif
3588
3589 #if defined (linux)
3590 /* There is no function in the glibc to retrieve the LWP of the current
3591 thread. We need to do a system call in order to retrieve this
3592 information. */
3593 #include <sys/syscall.h>
3594 void *__gnat_lwp_self (void)
3595 {
3596 return (void *) syscall (__NR_gettid);
3597 }
3598 #endif