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