hppa: Revise REG+D address support to allow long displacements before reload
[official-gcc.git] / gcc / ada / adaint.c
blobbb4ed2607e50c382185540321de1f1578b617bc7
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * A D A I N T *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2023, 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 ****************************************************************************/
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. */
37 /* Ensure access to errno is thread safe. */
39 #ifndef _REENTRANT
40 #define _REENTRANT
41 #endif
43 #ifndef _THREAD_SAFE
44 #define _THREAD_SAFE
45 #endif
47 /* Use 64 bit Large File API */
48 #if defined (__QNX__)
49 #define _LARGEFILE64_SOURCE 1
50 #elif !defined(_LARGEFILE_SOURCE)
51 #define _LARGEFILE_SOURCE
52 #endif
53 #define _FILE_OFFSET_BITS 64
55 #ifdef __vxworks
57 /* No need to redefine exit here. */
58 #undef exit
60 /* We want to use the POSIX variants of include files. */
61 #define POSIX
62 #include "vxWorks.h"
63 #include <sys/time.h>
65 #if defined (__mips_vxworks)
66 #include "cacheLib.h"
67 #endif /* __mips_vxworks */
69 /* If SMP, access vxCpuConfiguredGet */
70 #ifdef _WRS_CONFIG_SMP
71 #include <vxCpuLib.h>
72 #endif /* _WRS_CONFIG_SMP */
74 /* We need to know the VxWorks version because some file operations
75 (such as chmod) are only available on VxWorks 6. */
76 #include "version.h"
78 /* vwModNum.h and dosFsLib.h are needed for the VxWorks 6 rename workaround.
79 See below. */
80 #if (_WRS_VXWORKS_MAJOR == 6)
81 #include <vwModNum.h>
82 #include <dosFsLib.h>
83 #endif /* 6.x */
84 #endif /* VxWorks */
86 #if defined (__APPLE__)
87 #include <unistd.h>
88 #endif
90 #if defined (__hpux__)
91 #include <sys/param.h>
92 #include <sys/pstat.h>
93 #endif
95 #ifdef __PikeOS__
96 #define __BSD_VISIBLE 1
97 #endif
99 #ifdef __QNX__
100 #include <sys/syspage.h>
101 #include <sys/time.h>
102 #endif
104 #ifdef IN_RTS
106 #ifdef STANDALONE
107 #include <errno.h>
108 #include <sys/types.h>
109 #include <sys/stat.h>
110 #include <unistd.h>
111 #include <stdlib.h>
112 #include <string.h>
114 /* for CPU_SET/CPU_ZERO */
115 #define _GNU_SOURCE
116 #define __USE_GNU
118 #include "runtime.h"
120 #else
121 #include "tconfig.h"
122 #include "tsystem.h"
123 #endif
125 #include <sys/stat.h>
126 #include <fcntl.h>
127 #include <time.h>
129 #if defined (__vxworks) || defined (__ANDROID__)
130 /* S_IREAD and S_IWRITE are not defined in VxWorks or Android */
131 #ifndef S_IREAD
132 #define S_IREAD (S_IRUSR | S_IRGRP | S_IROTH)
133 #endif
135 #ifndef S_IWRITE
136 #define S_IWRITE (S_IWUSR)
137 #endif
138 #endif
140 /* We don't have libiberty, so use malloc. */
141 #define xmalloc(S) malloc (S)
142 #define xrealloc(V,S) realloc (V,S)
143 #else
144 #include "config.h"
145 #include "system.h"
146 #include "version.h"
147 #endif
149 /* limits.h is needed for LLONG_MIN. */
150 #ifdef __cplusplus
151 #include <climits>
152 #else
153 #include <limits.h>
154 #endif
156 #ifdef __cplusplus
157 extern "C" {
158 #endif
160 #if defined (__DJGPP__)
162 /* For isalpha-like tests in the compiler, we're expected to resort to
163 safe-ctype.h/ISALPHA. This isn't available for the runtime library
164 build, so we fallback on ctype.h/isalpha there. */
166 #ifdef IN_RTS
167 #include <ctype.h>
168 #define ISALPHA isalpha
169 #endif
171 #elif defined (__MINGW32__) || defined (__CYGWIN__)
173 #include "mingw32.h"
175 /* Current code page and CCS encoding to use, set in initialize.c. */
176 UINT __gnat_current_codepage;
177 UINT __gnat_current_ccs_encoding;
179 #include <sys/utime.h>
181 /* For isalpha-like tests in the compiler, we're expected to resort to
182 safe-ctype.h/ISALPHA. This isn't available for the runtime library
183 build, so we fallback on ctype.h/isalpha there. */
185 #ifdef IN_RTS
186 #include <ctype.h>
187 #define ISALPHA isalpha
188 #endif
190 #elif defined (__Lynx__)
192 /* Lynx utime.h only defines the entities of interest to us if
193 defined (VMOS_DEV), so ... */
194 #define VMOS_DEV
195 #include <utime.h>
196 #undef VMOS_DEV
198 #else
199 #include <utime.h>
200 #endif
202 /* wait.h processing */
203 #if defined (__vxworks) && defined (__RTP__)
204 # include <wait.h>
205 #elif defined (__Lynx__)
206 /* ??? We really need wait.h and it includes resource.h on Lynx. GCC
207 has a resource.h header as well, included instead of the lynx
208 version in our setup, causing lots of errors. We don't really need
209 the lynx contents of this file, so just workaround the issue by
210 preventing the inclusion of the GCC header from doing anything. */
211 # define GCC_RESOURCE_H
212 # include <sys/wait.h>
213 #elif defined (__PikeOS__) || defined (__MINGW32__)
214 /* No wait() or waitpid() calls available. */
215 #else
216 /* Default case. */
217 #include <sys/wait.h>
218 #endif
220 #if defined (__DJGPP__)
221 #include <process.h>
222 #include <signal.h>
223 #include <dir.h>
224 #include <utime.h>
225 #undef DIR_SEPARATOR
226 #define DIR_SEPARATOR '\\'
228 #elif defined (_WIN32)
230 /* Cannot redefine abort here. */
231 #undef abort
233 #define WIN32_LEAN_AND_MEAN
234 #include <windows.h>
235 #include <accctrl.h>
236 #include <aclapi.h>
237 #include <tlhelp32.h>
238 #include <signal.h>
239 #undef DIR_SEPARATOR
240 #define DIR_SEPARATOR '\\'
242 #else
243 #include <utime.h>
244 #endif
246 #include "adaint.h"
248 int __gnat_in_child_after_fork = 0;
250 #if defined (__APPLE__) && defined (st_mtime)
251 #define st_atim st_atimespec
252 #define st_mtim st_mtimespec
253 #endif
255 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
256 defined in the current system. On DOS-like systems these flags control
257 whether the file is opened/created in text-translation mode (CR/LF in
258 external file mapped to LF in internal file), but in Unix-like systems,
259 no text translation is required, so these flags have no effect. */
261 #ifndef O_BINARY
262 #define O_BINARY 0
263 #endif
265 #ifndef O_TEXT
266 #define O_TEXT 0
267 #endif
269 #ifndef HOST_EXECUTABLE_SUFFIX
270 #define HOST_EXECUTABLE_SUFFIX ""
271 #endif
273 #ifndef HOST_OBJECT_SUFFIX
274 #define HOST_OBJECT_SUFFIX ".o"
275 #endif
277 #ifndef PATH_SEPARATOR
278 #define PATH_SEPARATOR ':'
279 #endif
281 #ifndef DIR_SEPARATOR
282 #define DIR_SEPARATOR '/'
283 #define IS_DIRECTORY_SEPARATOR(c) ((c) == DIR_SEPARATOR)
284 #else
285 #define IS_DIRECTORY_SEPARATOR(c) ((c) == '/' || (c) == DIR_SEPARATOR)
286 #endif
288 /* Check for cross-compilation. */
289 #if defined (CROSS_COMPILE) || defined (CROSS_DIRECTORY_STRUCTURE)
290 #define IS_CROSS 1
291 int __gnat_is_cross_compiler = 1;
292 #else
293 #undef IS_CROSS
294 int __gnat_is_cross_compiler = 0;
295 #endif
297 char __gnat_dir_separator = DIR_SEPARATOR;
299 char __gnat_path_separator = PATH_SEPARATOR;
301 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
302 the base filenames that libraries specified with -lsomelib options
303 may have. This is used by GNATMAKE to check whether an executable
304 is up-to-date or not. The syntax is
306 library_template ::= { pattern ; } pattern NUL
307 pattern ::= [ prefix ] * [ postfix ]
309 These should only specify names of static libraries as it makes
310 no sense to determine at link time if dynamic-link libraries are
311 up to date or not. Any libraries that are not found are supposed
312 to be up-to-date:
314 * if they are needed but not present, the link
315 will fail,
317 * otherwise they are libraries in the system paths and so
318 they are considered part of the system and not checked
319 for that reason.
321 ??? This should be part of a GNAT host-specific compiler
322 file instead of being included in all user applications
323 as well. This is only a temporary work-around for 3.11b. */
325 #ifndef GNAT_LIBRARY_TEMPLATE
326 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
327 #endif
329 const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE;
331 #if defined (__vxworks)
332 #define GNAT_MAX_PATH_LEN PATH_MAX
334 #else
336 #if defined (__MINGW32__)
337 #include "mingw32.h"
338 #else
339 #include <sys/param.h>
340 #endif
342 #ifdef MAXPATHLEN
343 #define GNAT_MAX_PATH_LEN MAXPATHLEN
344 #else
345 #define GNAT_MAX_PATH_LEN 256
346 #endif
348 #endif
350 /* Used for runtime check that Ada constant File_Attributes_Size is no
351 less than the actual size of struct file_attributes (see Osint
352 initialization). */
353 int __gnat_size_of_file_attributes = sizeof (struct file_attributes);
355 void __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr);
357 /* The __gnat_max_path_len variable is used to export the maximum
358 length of a path name to Ada code. max_path_len is also provided
359 for compatibility with older GNAT versions, please do not use
360 it. */
362 int __gnat_max_path_len = GNAT_MAX_PATH_LEN;
363 int max_path_len = GNAT_MAX_PATH_LEN;
365 /* Control whether we can use ACL on Windows. */
367 int __gnat_use_acl = 1;
369 /* The following macro HAVE_READDIR_R should be defined if the
370 system provides the routine readdir_r.
371 ... but we never define it anywhere??? */
372 #undef HAVE_READDIR_R
374 #define MAYBE_TO_PTR32(argv) argv
376 static const char ATTR_UNSET = 127;
378 /* Reset the file attributes as if no system call had been performed */
380 void
381 __gnat_reset_attributes (struct file_attributes* attr)
383 attr->exists = ATTR_UNSET;
384 attr->error = EINVAL;
386 attr->writable = ATTR_UNSET;
387 attr->readable = ATTR_UNSET;
388 attr->executable = ATTR_UNSET;
390 attr->regular = ATTR_UNSET;
391 attr->symbolic_link = ATTR_UNSET;
392 attr->directory = ATTR_UNSET;
394 attr->timestamp = (OS_Time)-2;
395 attr->file_length = -1;
399 __gnat_error_attributes (struct file_attributes *attr) {
400 return attr->error;
403 OS_Time
404 __gnat_current_time (void)
406 time_t res = time (NULL);
407 return (OS_Time) res;
410 /* Return the current local time as a string in the ISO 8601 format of
411 "YYYY-MM-DD HH:MM:SS.SS". The returned string is 22 + 1 (NULL) characters
412 long. */
414 void
415 __gnat_current_time_string (char *result)
417 const char *format = "%Y-%m-%d %H:%M:%S";
418 /* Format string necessary to describe the ISO 8601 format */
420 const time_t t_val = time (NULL);
422 strftime (result, 22, format, localtime (&t_val));
423 /* Convert the local time into a string following the ISO format, copying
424 at most 22 characters into the result string. */
426 result [19] = '.';
427 result [20] = '0';
428 result [21] = '0';
429 /* The sub-seconds are manually set to zero since type time_t lacks the
430 precision necessary for nanoseconds. */
433 void
434 __gnat_to_gm_time (OS_Time *p_time, int *p_year, int *p_month, int *p_day,
435 int *p_hours, int *p_mins, int *p_secs)
437 struct tm *res;
438 time_t time = (time_t) *p_time;
440 res = gmtime (&time);
441 if (res)
443 *p_year = res->tm_year;
444 *p_month = res->tm_mon;
445 *p_day = res->tm_mday;
446 *p_hours = res->tm_hour;
447 *p_mins = res->tm_min;
448 *p_secs = res->tm_sec;
450 else
451 *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0;
454 void
455 __gnat_to_os_time (OS_Time *p_time, int year, int month, int day,
456 int hours, int mins, int secs)
458 struct tm v;
460 v.tm_year = year;
461 v.tm_mon = month;
462 v.tm_mday = day;
463 v.tm_hour = hours;
464 v.tm_min = mins;
465 v.tm_sec = secs;
466 v.tm_isdst = -1;
468 /* returns -1 of failing, this is s-os_lib Invalid_Time */
470 *p_time = (OS_Time) mktime (&v);
473 /* Place the contents of the symbolic link named PATH in the buffer BUF,
474 which has size BUFSIZ. If PATH is a symbolic link, then return the number
475 of characters of its content in BUF. Otherwise, return -1.
476 For systems not supporting symbolic links, always return -1. */
479 __gnat_readlink (char *path ATTRIBUTE_UNUSED,
480 char *buf ATTRIBUTE_UNUSED,
481 size_t bufsiz ATTRIBUTE_UNUSED)
483 #if defined (_WIN32) \
484 || defined(__vxworks) || defined (__PikeOS__)
485 return -1;
486 #else
487 return readlink (path, buf, bufsiz);
488 #endif
491 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH.
492 If NEWPATH exists it will NOT be overwritten.
493 For systems not supporting symbolic links, always return -1. */
496 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED,
497 char *newpath ATTRIBUTE_UNUSED)
499 #if defined (_WIN32) \
500 || defined(__vxworks) || defined (__PikeOS__)
501 return -1;
502 #else
503 return symlink (oldpath, newpath);
504 #endif
507 /* Try to lock a file, return 1 if success. */
509 #if defined (__vxworks) \
510 || defined (_WIN32) || defined (__PikeOS__)
512 /* Version that does not use link. */
515 __gnat_try_lock (char *dir, char *file)
517 int fd;
518 #ifdef __MINGW32__
519 TCHAR wfull_path[GNAT_MAX_PATH_LEN];
520 TCHAR wfile[GNAT_MAX_PATH_LEN];
521 TCHAR wdir[GNAT_MAX_PATH_LEN];
523 S2WSC (wdir, dir, GNAT_MAX_PATH_LEN);
524 S2WSC (wfile, file, GNAT_MAX_PATH_LEN);
526 /* ??? the code below crash on MingW64 for obscure reasons, a ticket
527 has been opened here:
529 https://sourceforge.net/p/mingw-w64/bugs/414/
531 As a workaround an equivalent set of code has been put in place below.
533 _stprintf (wfull_path, _T("%s%c%s"), wdir, _T(DIR_SEPARATOR), wfile);
536 _tcscpy (wfull_path, wdir);
537 _tcscat (wfull_path, L"\\");
538 _tcscat (wfull_path, wfile);
540 fd = _topen (wfull_path, O_CREAT | O_EXCL, 0600);
541 #else
542 char full_path[256];
544 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
545 fd = open (full_path, O_CREAT | O_EXCL, 0600);
546 #endif
548 if (fd < 0)
549 return 0;
551 close (fd);
552 return 1;
555 #else
557 /* Version using link(), more secure over NFS. */
558 /* See TN 6913-016 for discussion ??? */
561 __gnat_try_lock (char *dir, char *file)
563 char full_path[256];
564 char temp_file[256];
565 GNAT_STRUCT_STAT stat_result;
566 int fd;
568 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
569 sprintf (temp_file, "%s%cTMP-%ld-%ld",
570 dir, DIR_SEPARATOR, (long)getpid(), (long)getppid ());
572 /* Create the temporary file and write the process number. */
573 fd = open (temp_file, O_CREAT | O_WRONLY, 0600);
574 if (fd < 0)
575 return 0;
577 close (fd);
579 /* Link it with the new file. */
580 link (temp_file, full_path);
582 /* Count the references on the old one. If we have a count of two, then
583 the link did succeed. Remove the temporary file before returning. */
584 __gnat_stat (temp_file, &stat_result);
585 unlink (temp_file);
586 return stat_result.st_nlink == 2;
588 #endif
590 /* Return the maximum file name length. */
593 __gnat_get_maximum_file_name_length (void)
595 return -1;
598 /* Return nonzero if file names are case sensitive. */
600 static int file_names_case_sensitive_cache = -1;
603 __gnat_get_file_names_case_sensitive (void)
605 if (file_names_case_sensitive_cache == -1)
607 const char *sensitive = getenv ("GNAT_FILE_NAME_CASE_SENSITIVE");
609 if (sensitive != NULL
610 && (sensitive[0] == '0' || sensitive[0] == '1')
611 && sensitive[1] == '\0')
612 file_names_case_sensitive_cache = sensitive[0] - '0';
613 else
615 /* By default, we suppose filesystems aren't case sensitive on
616 Windows and Darwin (but they are on arm-darwin). */
617 #if defined (WINNT) || defined (__DJGPP__) \
618 || (defined (__APPLE__) && !(defined (__arm__) || defined (__arm64__)))
619 file_names_case_sensitive_cache = 0;
620 #else
621 file_names_case_sensitive_cache = 1;
622 #endif
625 return file_names_case_sensitive_cache;
628 /* Return nonzero if environment variables are case sensitive. */
631 __gnat_get_env_vars_case_sensitive (void)
633 #if defined (WINNT) || defined (__DJGPP__)
634 return 0;
635 #else
636 return 1;
637 #endif
640 char
641 __gnat_get_default_identifier_character_set (void)
643 return '1';
646 /* Return the current working directory. */
648 void
649 __gnat_get_current_dir (char *dir, int *length)
651 #if defined (__MINGW32__)
652 TCHAR wdir[GNAT_MAX_PATH_LEN];
654 _tgetcwd (wdir, *length);
656 WS2SC (dir, wdir, GNAT_MAX_PATH_LEN);
658 #else
659 char* result = getcwd (dir, *length);
660 /* If the current directory does not exist, set length = 0
661 to indicate error. That can't happen on windows, where
662 you can't delete a directory if it is the current
663 directory of some process. */
664 if (!result)
666 *length = 0;
667 return;
669 #endif
671 *length = strlen (dir);
673 if (dir [*length - 1] != DIR_SEPARATOR)
675 dir [*length] = DIR_SEPARATOR;
676 ++(*length);
678 dir[*length] = '\0';
681 /* Return the suffix for object files. */
683 void
684 __gnat_get_object_suffix_ptr (int *len, const char **value)
686 *value = HOST_OBJECT_SUFFIX;
688 if (*value == 0)
689 *len = 0;
690 else
691 *len = strlen (*value);
693 return;
696 /* Return the suffix for executable files. */
698 void
699 __gnat_get_executable_suffix_ptr (int *len, const char **value)
701 *value = HOST_EXECUTABLE_SUFFIX;
703 if (!*value)
704 *len = 0;
705 else
706 *len = strlen (*value);
708 return;
711 /* Return the suffix for debuggable files. Usually this is the same as the
712 executable extension. */
714 void
715 __gnat_get_debuggable_suffix_ptr (int *len, const char **value)
717 *value = HOST_EXECUTABLE_SUFFIX;
719 if (*value == 0)
720 *len = 0;
721 else
722 *len = strlen (*value);
724 return;
727 /* Returns the OS filename and corresponding encoding. */
729 void
730 __gnat_os_filename (char *filename ATTRIBUTE_UNUSED,
731 char *w_filename ATTRIBUTE_UNUSED,
732 char *os_name, int *o_length,
733 char *encoding ATTRIBUTE_UNUSED, int *e_length)
735 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
736 WS2SC (os_name, (TCHAR *)w_filename, (DWORD)*o_length);
737 *o_length = strlen (os_name);
738 strcpy (encoding, "encoding=utf8");
739 *e_length = strlen (encoding);
740 #else
741 strcpy (os_name, filename);
742 *o_length = strlen (filename);
743 *e_length = 0;
744 #endif
747 /* Delete a file. */
750 __gnat_unlink (char *path)
752 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
754 TCHAR wpath[GNAT_MAX_PATH_LEN];
756 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
757 return _tunlink (wpath);
759 #else
760 return unlink (path);
761 #endif
764 /* Rename a file. */
767 __gnat_rename (char *from, char *to)
769 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
771 TCHAR wfrom[GNAT_MAX_PATH_LEN], wto[GNAT_MAX_PATH_LEN];
773 S2WSC (wfrom, from, GNAT_MAX_PATH_LEN);
774 S2WSC (wto, to, GNAT_MAX_PATH_LEN);
775 return _trename (wfrom, wto);
777 #elif defined (__vxworks) && (_WRS_VXWORKS_MAJOR == 6)
779 /* When used on a dos filesystem under VxWorks 6.9 rename will trigger a
780 S_dosFsLib_FILE_NOT_FOUND errno when the file is not found. Let's map
781 that to ENOENT so Ada.Directory.Rename can detect that and raise the
782 Name_Error exception. */
783 int ret = rename (from, to);
785 if (ret && (errno == S_dosFsLib_FILE_NOT_FOUND))
787 errno = ENOENT;
789 return ret;
791 #else
792 return rename (from, to);
793 #endif
796 /* Changing directory. */
799 __gnat_chdir (char *path)
801 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
803 TCHAR wpath[GNAT_MAX_PATH_LEN];
805 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
806 return _tchdir (wpath);
808 #else
809 return chdir (path);
810 #endif
813 /* Removing a directory. */
816 __gnat_rmdir (char *path)
818 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
820 TCHAR wpath[GNAT_MAX_PATH_LEN];
822 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
823 return _trmdir (wpath);
825 #elif defined (VTHREADS)
826 /* rmdir not available */
827 return -1;
828 #else
829 return rmdir (path);
830 #endif
833 #if defined (_WIN32) || defined (__linux__) || defined (__sun__) \
834 || defined (__FreeBSD__) || defined(__DragonFly__) || defined (__QNX__)
835 #define HAS_TARGET_WCHAR_T
836 #endif
838 #ifdef HAS_TARGET_WCHAR_T
839 #include <wchar.h>
840 #endif
843 __gnat_fputwc(int c, FILE *stream)
845 #ifdef HAS_TARGET_WCHAR_T
846 return fputwc ((wchar_t)c, stream);
847 #else
848 return fputc (c, stream);
849 #endif
852 FILE *
853 __gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED)
855 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
856 TCHAR wpath[GNAT_MAX_PATH_LEN];
857 TCHAR wmode[10];
859 S2WS (wmode, mode, 10);
861 if (encoding == Encoding_Unspecified)
862 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
863 else if (encoding == Encoding_UTF8)
864 S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
865 else
866 S2WS (wpath, path, GNAT_MAX_PATH_LEN);
868 return _tfopen (wpath, wmode);
870 #else
871 return GNAT_FOPEN (path, mode);
872 #endif
875 FILE *
876 __gnat_freopen (char *path,
877 char *mode,
878 FILE *stream,
879 int encoding ATTRIBUTE_UNUSED)
881 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
882 TCHAR wpath[GNAT_MAX_PATH_LEN];
883 TCHAR wmode[10];
885 S2WS (wmode, mode, 10);
887 if (encoding == Encoding_Unspecified)
888 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
889 else if (encoding == Encoding_UTF8)
890 S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
891 else
892 S2WS (wpath, path, GNAT_MAX_PATH_LEN);
894 return _tfreopen (wpath, wmode, stream);
895 #else
896 return freopen (path, mode, stream);
897 #endif
901 __gnat_open_read (char *path, int fmode)
903 int fd;
904 int o_fmode = O_BINARY;
906 if (fmode)
907 o_fmode = O_TEXT;
909 #if defined (__vxworks)
910 fd = open (path, O_RDONLY | o_fmode, 0444);
911 #elif defined (__MINGW32__)
913 TCHAR wpath[GNAT_MAX_PATH_LEN];
915 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
916 fd = _topen (wpath, O_RDONLY | o_fmode, 0444);
918 #else
919 fd = GNAT_OPEN (path, O_RDONLY | o_fmode);
920 #endif
922 return fd < 0 ? -1 : fd;
925 #if defined (__MINGW32__)
926 #define PERM (S_IREAD | S_IWRITE)
927 #else
928 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
929 #endif
932 __gnat_open_rw (char *path, int fmode)
934 int fd;
935 int o_fmode = O_BINARY;
937 if (fmode)
938 o_fmode = O_TEXT;
940 #if defined (__MINGW32__)
942 TCHAR wpath[GNAT_MAX_PATH_LEN];
944 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
945 fd = _topen (wpath, O_RDWR | o_fmode, PERM);
947 #else
948 fd = GNAT_OPEN (path, O_RDWR | o_fmode, PERM);
949 #endif
951 return fd < 0 ? -1 : fd;
955 __gnat_open_create (char *path, int fmode)
957 int fd;
958 int o_fmode = O_BINARY;
960 if (fmode)
961 o_fmode = O_TEXT;
963 #if defined (__MINGW32__)
965 TCHAR wpath[GNAT_MAX_PATH_LEN];
967 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
968 fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
970 #else
971 fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
972 #endif
974 return fd < 0 ? -1 : fd;
978 __gnat_create_output_file (char *path)
980 int fd;
981 #if defined (__MINGW32__)
983 TCHAR wpath[GNAT_MAX_PATH_LEN];
985 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
986 fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
988 #else
989 fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
990 #endif
992 return fd < 0 ? -1 : fd;
996 __gnat_create_output_file_new (char *path)
998 int fd;
999 #if defined (__MINGW32__)
1001 TCHAR wpath[GNAT_MAX_PATH_LEN];
1003 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
1004 fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM);
1006 #else
1007 fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM);
1008 #endif
1010 return fd < 0 ? -1 : fd;
1014 __gnat_open_append (char *path, int fmode)
1016 int fd;
1017 int o_fmode = O_BINARY;
1019 if (fmode)
1020 o_fmode = O_TEXT;
1022 #if defined (__MINGW32__)
1024 TCHAR wpath[GNAT_MAX_PATH_LEN];
1026 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
1027 fd = _topen (wpath, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
1029 #else
1030 fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
1031 #endif
1033 return fd < 0 ? -1 : fd;
1036 /* Open a new file. Return error (-1) if the file already exists. */
1039 __gnat_open_new (char *path, int fmode)
1041 int fd;
1042 int o_fmode = O_BINARY;
1044 if (fmode)
1045 o_fmode = O_TEXT;
1047 #if defined (__MINGW32__)
1049 TCHAR wpath[GNAT_MAX_PATH_LEN];
1051 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
1052 fd = _topen (wpath, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
1054 #else
1055 fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
1056 #endif
1058 return fd < 0 ? -1 : fd;
1061 /* Open a new temp file. Return error (-1) if the file already exists. */
1064 __gnat_open_new_temp (char *path, int fmode)
1066 int fd;
1067 int o_fmode = O_BINARY;
1069 strcpy (path, "GNAT-XXXXXX");
1071 #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \
1072 || defined (__linux__) || defined (__GLIBC__) || defined (__ANDROID__) \
1073 || defined (__DragonFly__) || defined (__QNX__)) && !defined (__vxworks)
1074 return mkstemp (path);
1075 #elif defined (__Lynx__)
1076 mktemp (path);
1077 #else
1078 if (mktemp (path) == NULL)
1079 return -1;
1080 #endif
1082 if (fmode)
1083 o_fmode = O_TEXT;
1085 fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
1086 return fd < 0 ? -1 : fd;
1090 __gnat_open (char *path, int fmode)
1092 int fd;
1094 #if defined (__MINGW32__)
1096 TCHAR wpath[GNAT_MAX_PATH_LEN];
1098 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
1099 fd = _topen (wpath, fmode, PERM);
1101 #else
1102 fd = GNAT_OPEN (path, fmode, PERM);
1103 #endif
1105 return fd < 0 ? -1 : fd;
1108 /****************************************************************
1109 ** Perform a call to GNAT_STAT or GNAT_FSTAT, and extract as much information
1110 ** as possible from it, storing the result in a cache for later reuse
1111 ****************************************************************/
1113 void
1114 __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr)
1116 GNAT_STRUCT_STAT statbuf;
1117 int ret, error;
1119 if (fd != -1) {
1120 /* GNAT_FSTAT returns -1 and sets errno for failure */
1121 ret = GNAT_FSTAT (fd, &statbuf);
1122 error = ret ? errno : 0;
1124 } else {
1125 /* __gnat_stat returns errno value directly */
1126 error = __gnat_stat (name, &statbuf);
1127 ret = error ? -1 : 0;
1131 * A missing file is reported as an attr structure with error == 0 and
1132 * exists == 0.
1135 if (error == 0 || error == ENOENT)
1136 attr->error = 0;
1137 else
1138 attr->error = error;
1140 attr->regular = (!ret && S_ISREG (statbuf.st_mode));
1141 attr->directory = (!ret && S_ISDIR (statbuf.st_mode));
1143 if (!attr->regular)
1144 attr->file_length = 0;
1145 else
1146 /* st_size may be 32 bits, or 64 bits which is converted to long. We
1147 don't return a useful value for files larger than 2 gigabytes in
1148 either case. */
1149 attr->file_length = statbuf.st_size; /* all systems */
1151 attr->exists = !ret;
1153 #if !defined (_WIN32)
1154 /* on Windows requires extra system call, see __gnat_is_readable_file_attr */
1155 attr->readable = (!ret && (statbuf.st_mode & S_IRUSR));
1156 attr->writable = (!ret && (statbuf.st_mode & S_IWUSR));
1157 attr->executable = (!ret && (statbuf.st_mode & S_IXUSR));
1158 #endif
1160 if (ret != 0) {
1161 attr->timestamp = (OS_Time)-1;
1162 } else {
1163 attr->timestamp = (OS_Time)statbuf.st_mtime;
1167 /****************************************************************
1168 ** Return the number of bytes in the specified file
1169 ****************************************************************/
1171 __int64
1172 __gnat_file_length_attr (int fd, char* name, struct file_attributes* attr)
1174 if (attr->file_length == -1) {
1175 __gnat_stat_to_attr (fd, name, attr);
1178 return attr->file_length;
1181 __int64
1182 __gnat_file_length (int fd)
1184 struct file_attributes attr;
1185 __gnat_reset_attributes (&attr);
1186 return __gnat_file_length_attr (fd, NULL, &attr);
1189 long
1190 __gnat_file_length_long (int fd)
1192 struct file_attributes attr;
1193 __gnat_reset_attributes (&attr);
1194 return (long)__gnat_file_length_attr (fd, NULL, &attr);
1197 __int64
1198 __gnat_named_file_length (char *name)
1200 struct file_attributes attr;
1201 __gnat_reset_attributes (&attr);
1202 return __gnat_file_length_attr (-1, name, &attr);
1205 /* Create a temporary filename and put it in string pointed to by
1206 TMP_FILENAME. */
1208 void
1209 __gnat_tmp_name (char *tmp_filename)
1211 #if defined (__MINGW32__)
1213 char *pname;
1214 char prefix[25];
1216 /* tempnam tries to create a temporary file in directory pointed to by
1217 TMP environment variable, in c:\temp if TMP is not set, and in
1218 directory specified by P_tmpdir in stdio.h if c:\temp does not
1219 exist. The filename will be created with the prefix "gnat-". */
1221 sprintf (prefix, "gnat-%d-", (int)getpid());
1222 pname = (char *) _tempnam ("c:\\temp", prefix);
1224 /* if pname is NULL, the file was not created properly, the disk is full
1225 or there is no more free temporary files */
1227 if (pname == NULL)
1228 *tmp_filename = '\0';
1230 /* If pname start with a back slash and not path information it means that
1231 the filename is valid for the current working directory. */
1233 else if (pname[0] == '\\')
1235 strcpy (tmp_filename, ".\\");
1236 strcat (tmp_filename, pname+1);
1238 else
1239 strcpy (tmp_filename, pname);
1241 free (pname);
1244 #elif defined (__linux__) || defined (__FreeBSD__) || defined (__NetBSD__) \
1245 || defined (__OpenBSD__) || defined (__GLIBC__) || defined (__ANDROID__) \
1246 || defined (__DragonFly__) || defined (__QNX__)
1247 #define MAX_SAFE_PATH 1000
1248 char *tmpdir = getenv ("TMPDIR");
1250 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
1251 a buffer overflow. */
1252 if (tmpdir == NULL || strlen (tmpdir) > MAX_SAFE_PATH)
1253 #ifdef __ANDROID__
1254 strcpy (tmp_filename, "/cache/gnat-XXXXXX");
1255 #else
1256 strcpy (tmp_filename, "/tmp/gnat-XXXXXX");
1257 #endif
1258 else
1259 sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
1261 close (mkstemp(tmp_filename));
1262 #elif defined (__vxworks) && !defined (VTHREADS)
1263 int index;
1264 char *pos;
1265 char *savepos;
1266 static ushort_t seed = 0; /* used to generate unique name */
1268 /* Generate a unique name. */
1269 strcpy (tmp_filename, "tmp");
1271 index = 5;
1272 savepos = pos = tmp_filename + strlen (tmp_filename) + index;
1273 *pos = '\0';
1275 while (1)
1277 FILE *f;
1278 ushort_t t;
1280 /* Fill up the name buffer from the last position. */
1281 seed++;
1282 for (t = seed; --index >= 0; t >>= 3)
1283 *--pos = '0' + (t & 07);
1285 /* Check to see if its unique, if not bump the seed and try again. */
1286 f = fopen (tmp_filename, "r");
1287 if (f == NULL)
1288 break;
1289 fclose (f);
1290 pos = savepos;
1291 index = 5;
1293 #else
1294 tmpnam (tmp_filename);
1295 #endif
1298 /* Open directory and returns a DIR pointer. */
1300 DIR* __gnat_opendir (char *name)
1302 #if defined (__MINGW32__)
1303 TCHAR wname[GNAT_MAX_PATH_LEN];
1305 S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1306 return (DIR*)_topendir (wname);
1308 #else
1309 return opendir (name);
1310 #endif
1313 /* Read the next entry in a directory. The returned string points somewhere
1314 in the buffer. */
1316 #if defined (__sun__)
1317 /* For Solaris, be sure to use the 64-bit version, otherwise NFS reads may
1318 fail with EOVERFLOW if the server uses 64-bit cookies. */
1319 #define dirent dirent64
1320 #define readdir readdir64
1321 #endif
1323 char *
1324 __gnat_readdir (DIR *dirp, char *buffer, int *len)
1326 #if defined (__MINGW32__)
1327 struct _tdirent *dirent = _treaddir ((_TDIR*)dirp);
1329 if (dirent != NULL)
1331 WS2SC (buffer, dirent->d_name, GNAT_MAX_PATH_LEN);
1332 *len = strlen (buffer);
1334 return buffer;
1336 else
1337 return NULL;
1339 #elif defined (HAVE_READDIR_R)
1340 /* If possible, try to use the thread-safe version. */
1341 if (readdir_r (dirp, buffer) != NULL)
1343 *len = strlen (((struct dirent*) buffer)->d_name);
1344 return ((struct dirent*) buffer)->d_name;
1346 else
1347 return NULL;
1349 #else
1350 struct dirent *dirent = (struct dirent *) readdir (dirp);
1352 if (dirent != NULL)
1354 strcpy (buffer, dirent->d_name);
1355 *len = strlen (buffer);
1356 return buffer;
1358 else
1359 return NULL;
1361 #endif
1364 /* Close a directory entry. */
1366 int __gnat_closedir (DIR *dirp)
1368 #if defined (__MINGW32__)
1369 return _tclosedir ((_TDIR*)dirp);
1371 #else
1372 return closedir (dirp);
1373 #endif
1376 /* Returns 1 if readdir is thread safe, 0 otherwise. */
1379 __gnat_readdir_is_thread_safe (void)
1381 #ifdef HAVE_READDIR_R
1382 return 1;
1383 #else
1384 return 0;
1385 #endif
1388 #if defined (_WIN32)
1389 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
1390 static const unsigned long long w32_epoch_offset = 11644473600ULL;
1392 /* Returns the file modification timestamp using Win32 routines which are
1393 immune against daylight saving time change. It is in fact not possible to
1394 use fstat for this purpose as the DST modify the st_mtime field of the
1395 stat structure. */
1397 static time_t
1398 win32_filetime (HANDLE h)
1400 union
1402 FILETIME ft_time;
1403 unsigned long long ull_time;
1404 } t_write;
1406 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1407 since <Jan 1st 1601>. This function must return the number of seconds
1408 since <Jan 1st 1970>. */
1410 if (GetFileTime (h, NULL, NULL, &t_write.ft_time))
1411 return (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset);
1412 return (time_t) 0;
1415 /* As above but starting from a FILETIME. */
1416 static void
1417 f2t (const FILETIME *ft, __time64_t *t)
1419 union
1421 FILETIME ft_time;
1422 unsigned long long ull_time;
1423 } t_write;
1425 t_write.ft_time = *ft;
1426 *t = (__time64_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset);
1428 #endif
1430 /* Return a GNAT time stamp given a file name. */
1432 OS_Time
1433 __gnat_file_time_name_attr (char* name, struct file_attributes* attr)
1435 if (attr->timestamp == (OS_Time)-2) {
1436 #if defined (_WIN32)
1437 BOOL res;
1438 WIN32_FILE_ATTRIBUTE_DATA fad;
1439 __time64_t ret = -1;
1440 TCHAR wname[GNAT_MAX_PATH_LEN];
1441 S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1443 if ((res = GetFileAttributesEx (wname, GetFileExInfoStandard, &fad)))
1444 f2t (&fad.ftLastWriteTime, &ret);
1445 attr->timestamp = (OS_Time) ret;
1446 #else
1447 __gnat_stat_to_attr (-1, name, attr);
1448 #endif
1450 return attr->timestamp;
1453 OS_Time
1454 __gnat_file_time_name (char *name)
1456 struct file_attributes attr;
1457 __gnat_reset_attributes (&attr);
1458 return __gnat_file_time_name_attr (name, &attr);
1461 /* Return a GNAT time stamp given a file descriptor. */
1463 OS_Time
1464 __gnat_file_time_fd_attr (int fd, struct file_attributes* attr)
1466 if (attr->timestamp == (OS_Time)-2) {
1467 #if defined (_WIN32)
1468 HANDLE h = (HANDLE) _get_osfhandle (fd);
1469 time_t ret = win32_filetime (h);
1470 attr->timestamp = (OS_Time) ret;
1472 #else
1473 __gnat_stat_to_attr (fd, NULL, attr);
1474 #endif
1477 return attr->timestamp;
1480 OS_Time
1481 __gnat_file_time_fd (int fd)
1483 struct file_attributes attr;
1484 __gnat_reset_attributes (&attr);
1485 return __gnat_file_time_fd_attr (fd, &attr);
1488 extern long long __gnat_file_time(char* name)
1490 long long result;
1492 if (name == NULL) {
1493 return LLONG_MIN;
1495 /* Number of seconds between <Jan 1st 1970> and <Jan 1st 2150>. */
1496 static const long long ada_epoch_offset = (136 * 365 + 44 * 366) * 86400LL;
1497 #if defined(_WIN32)
1499 /* Number of 100 nanoseconds between <Jan 1st 1601> and <Jan 1st 2150>. */
1500 static const long long w32_epoch_offset =
1501 (11644473600LL + ada_epoch_offset) * 1E7;
1503 WIN32_FILE_ATTRIBUTE_DATA fad;
1504 union
1506 FILETIME ft_time;
1507 long long ll_time;
1508 } t_write;
1510 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1511 int name_len;
1513 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
1514 name_len = _tcslen (wname);
1516 if (name_len > GNAT_MAX_PATH_LEN)
1517 return LLONG_MIN;
1519 if (!GetFileAttributesEx(wname, GetFileExInfoStandard, &fad)) {
1520 return LLONG_MIN;
1523 t_write.ft_time = fad.ftLastWriteTime;
1525 #if defined(__GNUG__) && __GNUG__ <= 4
1526 result = (t_write.ll_time - w32_epoch_offset) * 100;
1527 #else
1528 /* Next code similar to (t_write.ll_time - w32_epoch_offset) * 100
1529 but on overflow returns LLONG_MIN value. */
1531 if (__builtin_ssubll_overflow(t_write.ll_time, w32_epoch_offset, &result)) {
1532 return LLONG_MIN;
1535 if (__builtin_smulll_overflow(result, 100, &result)) {
1536 return LLONG_MIN;
1538 #endif
1540 #else
1542 struct stat sb;
1543 if (stat(name, &sb) != 0) {
1544 return LLONG_MIN;
1547 #if defined(__GNUG__) && __GNUG__ <= 4
1548 result = (sb.st_mtime - ada_epoch_offset) * 1E9;
1549 #if defined(st_mtime)
1550 result += sb.st_mtim.tv_nsec;
1551 #endif
1552 #else
1553 /* Next code similar to
1554 (sb.st_mtime - ada_epoch_offset) * 1E9 + sb.st_mtim.tv_nsec
1555 but on overflow returns LLONG_MIN value. */
1557 if (__builtin_ssubll_overflow(sb.st_mtime, ada_epoch_offset, &result)) {
1558 return LLONG_MIN;
1561 if (__builtin_smulll_overflow(result, 1E9, &result)) {
1562 return LLONG_MIN;
1565 #if defined(st_mtime)
1566 if (__builtin_saddll_overflow(result, sb.st_mtim.tv_nsec, &result)) {
1567 return LLONG_MIN;
1569 #endif
1570 #endif
1571 #endif
1572 return result;
1575 /* Set the file time stamp. */
1577 void
1578 __gnat_set_file_time_name (char *name, OS_Time time_stamp)
1580 #if defined (__vxworks)
1582 /* Code to implement __gnat_set_file_time_name for these systems. */
1584 #elif defined (_WIN32)
1585 union
1587 FILETIME ft_time;
1588 unsigned long long ull_time;
1589 } t_write;
1590 TCHAR wname[GNAT_MAX_PATH_LEN];
1592 S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1594 HANDLE h = CreateFile
1595 (wname, GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
1596 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS,
1597 NULL);
1598 if (h == INVALID_HANDLE_VALUE)
1599 return;
1600 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1601 t_write.ull_time = ((unsigned long long)time_stamp + w32_epoch_offset);
1602 /* Convert to 100 nanosecond units */
1603 t_write.ull_time *= 10000000ULL;
1605 SetFileTime(h, NULL, NULL, &t_write.ft_time);
1606 CloseHandle (h);
1607 return;
1609 #else
1610 struct utimbuf utimbuf;
1611 time_t t;
1613 /* Set modification time to requested time. */
1614 utimbuf.modtime = (time_t) time_stamp;
1616 /* Set access time to now in local time. */
1617 t = time (NULL);
1618 utimbuf.actime = mktime (localtime (&t));
1620 utime (name, &utimbuf);
1621 #endif
1624 /* Get the list of installed standard libraries from the
1625 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1626 key. */
1628 char *
1629 __gnat_get_libraries_from_registry (void)
1631 char *result = (char *) xmalloc (1);
1633 result[0] = '\0';
1635 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
1637 HKEY reg_key;
1638 DWORD name_size, value_size;
1639 char name[256];
1640 char value[256];
1641 DWORD type;
1642 DWORD index;
1643 LONG res;
1645 /* First open the key. */
1646 res = RegOpenKeyExA (HKEY_LOCAL_MACHINE, "SOFTWARE", 0, KEY_READ, &reg_key);
1648 if (res == ERROR_SUCCESS)
1649 res = RegOpenKeyExA (reg_key, "Ada Core Technologies", 0,
1650 KEY_READ, &reg_key);
1652 if (res == ERROR_SUCCESS)
1653 res = RegOpenKeyExA (reg_key, "GNAT", 0, KEY_READ, &reg_key);
1655 if (res == ERROR_SUCCESS)
1656 res = RegOpenKeyExA (reg_key, "Standard Libraries", 0, KEY_READ, &reg_key);
1658 /* If the key exists, read out all the values in it and concatenate them
1659 into a path. */
1660 for (index = 0; res == ERROR_SUCCESS; index++)
1662 value_size = name_size = 256;
1663 res = RegEnumValueA (reg_key, index, name, &name_size, 0,
1664 &type, (LPBYTE)value, &value_size);
1666 if (res == ERROR_SUCCESS && type == REG_SZ)
1668 char *old_result = result;
1670 result = (char *) xmalloc (strlen (old_result) + value_size + 2);
1671 strcpy (result, old_result);
1672 strcat (result, value);
1673 strcat (result, ";");
1674 free (old_result);
1678 /* Remove the trailing ";". */
1679 if (result[0] != 0)
1680 result[strlen (result) - 1] = 0;
1682 #endif
1683 return result;
1686 /* Query information for the given file NAME and return it in STATBUF.
1687 * Returns 0 for success, or errno value for failure.
1690 __gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf)
1692 #ifdef __MINGW32__
1693 WIN32_FILE_ATTRIBUTE_DATA fad;
1694 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1695 int name_len;
1696 BOOL res;
1697 DWORD error;
1699 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
1700 name_len = _tcslen (wname);
1702 if (name_len > GNAT_MAX_PATH_LEN)
1703 return EINVAL;
1705 ZeroMemory (statbuf, sizeof(GNAT_STRUCT_STAT));
1707 res = GetFileAttributesEx (wname, GetFileExInfoStandard, &fad);
1709 if (res == FALSE) {
1710 error = GetLastError();
1712 /* Check file existence using GetFileAttributes() which does not fail on
1713 special Windows files like con:, aux:, nul: etc... */
1715 if (GetFileAttributes(wname) != INVALID_FILE_ATTRIBUTES) {
1716 /* Just pretend that it is a regular and readable file */
1717 statbuf->st_mode = S_IFREG | S_IREAD | S_IWRITE;
1718 return 0;
1721 switch (error) {
1722 case ERROR_ACCESS_DENIED:
1723 case ERROR_SHARING_VIOLATION:
1724 case ERROR_LOCK_VIOLATION:
1725 case ERROR_SHARING_BUFFER_EXCEEDED:
1726 return EACCES;
1727 case ERROR_BUFFER_OVERFLOW:
1728 return ENAMETOOLONG;
1729 case ERROR_NOT_ENOUGH_MEMORY:
1730 return ENOMEM;
1731 default:
1732 return ENOENT;
1736 f2t (&fad.ftCreationTime, &statbuf->st_ctime);
1737 f2t (&fad.ftLastWriteTime, &statbuf->st_mtime);
1738 f2t (&fad.ftLastAccessTime, &statbuf->st_atime);
1740 statbuf->st_size =
1741 (__int64)fad.nFileSizeLow | (__int64)fad.nFileSizeHigh << 32;
1743 /* We do not have the S_IEXEC attribute, but this is not used on GNAT. */
1744 statbuf->st_mode = S_IREAD;
1746 if (fad.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY)
1747 statbuf->st_mode |= S_IFDIR;
1748 else
1749 statbuf->st_mode |= S_IFREG;
1751 if (!(fad.dwFileAttributes & FILE_ATTRIBUTE_READONLY))
1752 statbuf->st_mode |= S_IWRITE;
1754 return 0;
1756 #else
1757 return GNAT_STAT (name, statbuf) == 0 ? 0 : errno;
1758 #endif
1761 /*************************************************************************
1762 ** Check whether a file exists
1763 *************************************************************************/
1766 __gnat_file_exists_attr (char* name, struct file_attributes* attr)
1768 if (attr->exists == ATTR_UNSET)
1769 __gnat_stat_to_attr (-1, name, attr);
1771 return attr->exists;
1775 __gnat_file_exists (char *name)
1777 struct file_attributes attr;
1778 __gnat_reset_attributes (&attr);
1779 return __gnat_file_exists_attr (name, &attr);
1782 /**********************************************************************
1783 ** Whether name is an absolute path
1784 **********************************************************************/
1787 __gnat_is_absolute_path (char *name, int length)
1789 #ifdef __vxworks
1790 /* On VxWorks systems, an absolute path can be represented (depending on
1791 the host platform) as either /dir/file, or device:/dir/file, or
1792 device:drive_letter:/dir/file. */
1794 int index;
1796 if (name[0] == '/')
1797 return 1;
1799 for (index = 0; index < length; index++)
1801 if (name[index] == ':' &&
1802 ((name[index + 1] == '/') ||
1803 (isalpha (name[index + 1]) && index + 2 <= length &&
1804 name[index + 2] == '/')))
1805 return 1;
1807 else if (name[index] == '/')
1808 return 0;
1810 return 0;
1811 #else
1812 return (length != 0) &&
1813 (IS_DIRECTORY_SEPARATOR(*name)
1814 #if defined (WINNT) || defined(__DJGPP__)
1815 || (length > 2 && ISALPHA (name[0]) && name[1] == ':'
1816 && IS_DIRECTORY_SEPARATOR(name[2]))
1817 #endif
1819 #endif
1823 __gnat_is_regular_file_attr (char* name, struct file_attributes* attr)
1825 if (attr->regular == ATTR_UNSET)
1826 __gnat_stat_to_attr (-1, name, attr);
1828 return attr->regular;
1832 __gnat_is_regular_file (char *name)
1834 struct file_attributes attr;
1836 __gnat_reset_attributes (&attr);
1837 return __gnat_is_regular_file_attr (name, &attr);
1841 __gnat_is_regular_file_fd (int fd)
1843 int ret;
1844 GNAT_STRUCT_STAT statbuf;
1846 ret = GNAT_FSTAT (fd, &statbuf);
1847 return (!ret && S_ISREG (statbuf.st_mode));
1851 __gnat_is_directory_attr (char* name, struct file_attributes* attr)
1853 if (attr->directory == ATTR_UNSET)
1854 __gnat_stat_to_attr (-1, name, attr);
1856 return attr->directory;
1860 __gnat_is_directory (char *name)
1862 struct file_attributes attr;
1864 __gnat_reset_attributes (&attr);
1865 return __gnat_is_directory_attr (name, &attr);
1868 #if defined (_WIN32)
1870 /* Returns the same constant as GetDriveType but takes a pathname as
1871 argument. */
1873 static UINT
1874 GetDriveTypeFromPath (TCHAR *wfullpath)
1876 TCHAR wdrv[MAX_PATH];
1877 TCHAR wpath[MAX_PATH];
1878 TCHAR wfilename[MAX_PATH];
1879 TCHAR wext[MAX_PATH];
1881 _tsplitpath (wfullpath, wdrv, wpath, wfilename, wext);
1883 if (_tcslen (wdrv) != 0)
1885 /* we have a drive specified. */
1886 _tcscat (wdrv, _T("\\"));
1887 return GetDriveType (wdrv);
1889 else
1891 /* No drive specified. */
1893 /* Is this a relative path, if so get current drive type. */
1894 if (wpath[0] != _T('\\') ||
1895 (_tcslen (wpath) > 2 && wpath[0] == _T('\\')
1896 && wpath[1] != _T('\\')))
1897 return GetDriveType (NULL);
1899 UINT result = GetDriveType (wpath);
1901 /* Cannot guess the drive type, is this \\.\ ? */
1903 if (result == DRIVE_NO_ROOT_DIR &&
1904 _tcslen (wpath) >= 4 && wpath[0] == _T('\\') && wpath[1] == _T('\\')
1905 && wpath[2] == _T('.') && wpath[3] == _T('\\'))
1907 if (_tcslen (wpath) == 4)
1908 _tcscat (wpath, wfilename);
1910 LPTSTR p = &wpath[4];
1911 LPTSTR b = _tcschr (p, _T('\\'));
1913 if (b != NULL)
1915 /* logical drive \\.\c\dir\file */
1916 *b++ = _T(':');
1917 *b++ = _T('\\');
1918 *b = _T('\0');
1920 else
1921 _tcscat (p, _T(":\\"));
1923 return GetDriveType (p);
1926 return result;
1930 /* This MingW section contains code to work with ACL. */
1931 static int
1932 __gnat_check_OWNER_ACL (TCHAR *wname,
1933 DWORD CheckAccessDesired,
1934 GENERIC_MAPPING CheckGenericMapping)
1936 DWORD dwAccessDesired, dwAccessAllowed;
1937 PRIVILEGE_SET PrivilegeSet;
1938 DWORD dwPrivSetSize = sizeof (PRIVILEGE_SET);
1939 BOOL fAccessGranted = FALSE;
1940 HANDLE hToken = NULL;
1941 DWORD nLength = 0;
1942 PSECURITY_DESCRIPTOR pSD = NULL;
1944 GetFileSecurity
1945 (wname, OWNER_SECURITY_INFORMATION |
1946 GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION,
1947 NULL, 0, &nLength);
1949 if ((pSD = (SECURITY_DESCRIPTOR *) HeapAlloc
1950 (GetProcessHeap (), HEAP_ZERO_MEMORY, nLength)) == NULL)
1951 return 0;
1953 /* Obtain the security descriptor. */
1955 if (!GetFileSecurity
1956 (wname, OWNER_SECURITY_INFORMATION |
1957 GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION,
1958 pSD, nLength, &nLength))
1959 goto error;
1961 if (!ImpersonateSelf (SecurityImpersonation))
1962 goto error;
1964 if (!OpenThreadToken
1965 (GetCurrentThread(), TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken))
1966 goto error;
1968 /* Undoes the effect of ImpersonateSelf. */
1970 RevertToSelf ();
1972 /* We want to test for write permissions. */
1974 dwAccessDesired = CheckAccessDesired;
1976 MapGenericMask (&dwAccessDesired, &CheckGenericMapping);
1978 if (!AccessCheck
1979 (pSD , /* security descriptor to check */
1980 hToken, /* impersonation token */
1981 dwAccessDesired, /* requested access rights */
1982 &CheckGenericMapping, /* pointer to GENERIC_MAPPING */
1983 &PrivilegeSet, /* receives privileges used in check */
1984 &dwPrivSetSize, /* size of PrivilegeSet buffer */
1985 &dwAccessAllowed, /* receives mask of allowed access rights */
1986 &fAccessGranted))
1987 goto error;
1989 CloseHandle (hToken);
1990 HeapFree (GetProcessHeap (), 0, pSD);
1991 return fAccessGranted;
1993 error:
1994 if (hToken)
1995 CloseHandle (hToken);
1996 HeapFree (GetProcessHeap (), 0, pSD);
1997 return 0;
2000 static void
2001 __gnat_set_OWNER_ACL (TCHAR *wname,
2002 ACCESS_MODE AccessMode,
2003 DWORD AccessPermissions)
2005 PACL pOldDACL = NULL;
2006 PACL pNewDACL = NULL;
2007 PSECURITY_DESCRIPTOR pSD = NULL;
2008 EXPLICIT_ACCESS ea;
2009 TCHAR username [100];
2010 DWORD unsize = 100;
2012 /* Get current user, he will act as the owner */
2014 if (!GetUserName (username, &unsize))
2015 return;
2017 if (GetNamedSecurityInfo
2018 (wname,
2019 SE_FILE_OBJECT,
2020 DACL_SECURITY_INFORMATION,
2021 NULL, NULL, &pOldDACL, NULL, &pSD) != ERROR_SUCCESS)
2022 return;
2024 BuildExplicitAccessWithName
2025 (&ea, username, AccessPermissions, (ACCESS_MODE) AccessMode, NO_INHERITANCE);
2027 if (AccessMode == SET_ACCESS)
2029 /* SET_ACCESS, we want to set an explicte set of permissions, do not
2030 merge with current DACL. */
2031 if (SetEntriesInAcl (1, &ea, NULL, &pNewDACL) != ERROR_SUCCESS)
2032 return;
2034 else
2035 if (SetEntriesInAcl (1, &ea, pOldDACL, &pNewDACL) != ERROR_SUCCESS)
2036 return;
2038 if (SetNamedSecurityInfo
2039 (wname, SE_FILE_OBJECT,
2040 DACL_SECURITY_INFORMATION, NULL, NULL, pNewDACL, NULL) != ERROR_SUCCESS)
2041 return;
2043 LocalFree (pSD);
2044 LocalFree (pNewDACL);
2047 /* Check if it is possible to use ACL for wname, the file must not be on a
2048 network drive. */
2050 static int
2051 __gnat_can_use_acl (TCHAR *wname)
2053 return __gnat_use_acl && GetDriveTypeFromPath (wname) != DRIVE_REMOTE;
2056 #endif /* defined (_WIN32) */
2059 __gnat_is_readable_file_attr (char* name, struct file_attributes* attr)
2061 if (attr->readable == ATTR_UNSET)
2063 #if defined (_WIN32)
2064 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2065 GENERIC_MAPPING GenericMapping;
2067 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2069 if (__gnat_can_use_acl (wname))
2071 ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
2072 GenericMapping.GenericRead = GENERIC_READ;
2073 attr->readable =
2074 __gnat_check_OWNER_ACL (wname, FILE_READ_DATA, GenericMapping);
2076 else
2077 attr->readable = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES;
2078 #else
2079 __gnat_stat_to_attr (-1, name, attr);
2080 #endif
2083 return attr->readable;
2087 __gnat_is_read_accessible_file (char *name)
2089 #if defined (_WIN32)
2090 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2092 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2094 return !_waccess (wname, 4);
2096 #elif defined (__vxworks)
2097 int fd;
2099 if ((fd = open (name, O_RDONLY, 0)) < 0)
2100 return 0;
2101 close (fd);
2102 return 1;
2104 #else
2105 return !access (name, R_OK);
2106 #endif
2110 __gnat_is_readable_file (char *name)
2112 struct file_attributes attr;
2114 __gnat_reset_attributes (&attr);
2115 return __gnat_is_readable_file_attr (name, &attr);
2119 __gnat_is_writable_file_attr (char* name, struct file_attributes* attr)
2121 if (attr->writable == ATTR_UNSET)
2123 #if defined (_WIN32)
2124 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2125 GENERIC_MAPPING GenericMapping;
2127 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2129 if (__gnat_can_use_acl (wname))
2131 ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
2132 GenericMapping.GenericWrite = GENERIC_WRITE;
2134 attr->writable = __gnat_check_OWNER_ACL
2135 (wname, FILE_WRITE_DATA | FILE_APPEND_DATA, GenericMapping)
2136 && !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY);
2138 else
2139 attr->writable =
2140 !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY);
2142 #else
2143 __gnat_stat_to_attr (-1, name, attr);
2144 #endif
2147 return attr->writable;
2151 __gnat_is_writable_file (char *name)
2153 struct file_attributes attr;
2155 __gnat_reset_attributes (&attr);
2156 return __gnat_is_writable_file_attr (name, &attr);
2160 __gnat_is_write_accessible_file (char *name)
2162 #if defined (_WIN32)
2163 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2165 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2167 return !_waccess (wname, 2);
2169 #elif defined (__vxworks)
2170 int fd;
2172 if ((fd = open (name, O_WRONLY, 0)) < 0)
2173 return 0;
2174 close (fd);
2175 return 1;
2177 #else
2178 return !access (name, W_OK);
2179 #endif
2183 __gnat_is_executable_file_attr (char* name, struct file_attributes* attr)
2185 if (attr->executable == ATTR_UNSET)
2187 #if defined (_WIN32)
2188 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2189 GENERIC_MAPPING GenericMapping;
2191 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2193 if (__gnat_can_use_acl (wname))
2195 ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
2196 GenericMapping.GenericExecute = GENERIC_EXECUTE;
2198 attr->executable =
2199 __gnat_check_OWNER_ACL (wname, FILE_EXECUTE, GenericMapping);
2201 else
2203 TCHAR *l, *last = _tcsstr(wname, _T(".exe"));
2205 /* look for last .exe */
2206 if (last)
2207 while ((l = _tcsstr(last+1, _T(".exe"))))
2208 last = l;
2210 attr->executable =
2211 GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES
2212 && (last - wname) == (int) (_tcslen (wname) - 4);
2214 #else
2215 __gnat_stat_to_attr (-1, name, attr);
2216 #endif
2219 return attr->regular && attr->executable;
2223 __gnat_is_executable_file (char *name)
2225 struct file_attributes attr;
2227 __gnat_reset_attributes (&attr);
2228 return __gnat_is_executable_file_attr (name, &attr);
2231 void
2232 __gnat_set_writable (char *name)
2234 #if defined (_WIN32)
2235 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2237 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2239 if (__gnat_can_use_acl (wname))
2240 __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_WRITE);
2242 SetFileAttributes
2243 (wname, GetFileAttributes (wname) & ~FILE_ATTRIBUTE_READONLY);
2244 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6)
2245 GNAT_STRUCT_STAT statbuf;
2247 if (GNAT_STAT (name, &statbuf) == 0)
2249 statbuf.st_mode = statbuf.st_mode | S_IWUSR;
2250 chmod (name, statbuf.st_mode);
2252 #endif
2255 /* must match definition in s-os_lib.ads */
2256 #define S_OWNER 1
2257 #define S_GROUP 2
2258 #define S_OTHERS 4
2260 void
2261 __gnat_set_executable (char *name, int mode ATTRIBUTE_UNUSED)
2263 #if defined (_WIN32)
2264 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2266 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2268 if (__gnat_can_use_acl (wname))
2269 __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_EXECUTE);
2271 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6)
2272 GNAT_STRUCT_STAT statbuf;
2274 if (GNAT_STAT (name, &statbuf) == 0)
2276 if (mode & S_OWNER)
2277 statbuf.st_mode = statbuf.st_mode | S_IXUSR;
2278 if (mode & S_GROUP)
2279 statbuf.st_mode = statbuf.st_mode | S_IXGRP;
2280 if (mode & S_OTHERS)
2281 statbuf.st_mode = statbuf.st_mode | S_IXOTH;
2282 chmod (name, statbuf.st_mode);
2284 #endif
2287 void
2288 __gnat_set_non_writable (char *name)
2290 #if defined (_WIN32)
2291 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2293 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2295 if (__gnat_can_use_acl (wname))
2296 __gnat_set_OWNER_ACL
2297 (wname, DENY_ACCESS,
2298 FILE_WRITE_DATA | FILE_APPEND_DATA |
2299 FILE_WRITE_EA | FILE_WRITE_ATTRIBUTES);
2301 SetFileAttributes
2302 (wname, GetFileAttributes (wname) | FILE_ATTRIBUTE_READONLY);
2303 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6)
2304 GNAT_STRUCT_STAT statbuf;
2306 if (GNAT_STAT (name, &statbuf) == 0)
2308 statbuf.st_mode = statbuf.st_mode & 07577;
2309 chmod (name, statbuf.st_mode);
2311 #endif
2314 void
2315 __gnat_set_readable (char *name)
2317 #if defined (_WIN32)
2318 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2320 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2322 if (__gnat_can_use_acl (wname))
2323 __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_READ);
2325 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6)
2326 GNAT_STRUCT_STAT statbuf;
2328 if (GNAT_STAT (name, &statbuf) == 0)
2330 chmod (name, statbuf.st_mode | S_IREAD);
2332 #endif
2335 void
2336 __gnat_set_non_readable (char *name)
2338 #if defined (_WIN32)
2339 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2341 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2343 if (__gnat_can_use_acl (wname))
2344 __gnat_set_OWNER_ACL (wname, DENY_ACCESS, FILE_GENERIC_READ);
2346 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6)
2347 GNAT_STRUCT_STAT statbuf;
2349 if (GNAT_STAT (name, &statbuf) == 0)
2351 chmod (name, statbuf.st_mode & (~S_IREAD));
2353 #endif
2357 __gnat_is_symbolic_link_attr (char* name ATTRIBUTE_UNUSED,
2358 struct file_attributes* attr)
2360 if (attr->symbolic_link == ATTR_UNSET)
2362 #if defined (__vxworks)
2363 attr->symbolic_link = 0;
2365 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
2366 int ret;
2367 GNAT_STRUCT_STAT statbuf;
2368 ret = GNAT_LSTAT (name, &statbuf);
2369 attr->symbolic_link = (!ret && S_ISLNK (statbuf.st_mode));
2370 #else
2371 attr->symbolic_link = 0;
2372 #endif
2374 return attr->symbolic_link;
2378 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED)
2380 struct file_attributes attr;
2382 __gnat_reset_attributes (&attr);
2383 return __gnat_is_symbolic_link_attr (name, &attr);
2386 #if defined (__sun__)
2387 /* Using fork on Solaris will duplicate all the threads. fork1, which
2388 duplicates only the active thread, must be used instead, or spawning
2389 subprocess from a program with tasking will lead into numerous problems. */
2390 #define fork fork1
2391 #endif
2394 __gnat_portable_spawn (char *args[] ATTRIBUTE_UNUSED)
2396 int status ATTRIBUTE_UNUSED = 0;
2397 int finished ATTRIBUTE_UNUSED;
2398 int pid ATTRIBUTE_UNUSED;
2400 #if defined (__vxworks) || defined(__PikeOS__)
2401 return -1;
2403 #elif defined (__DJGPP__) || defined (_WIN32)
2404 /* args[0] must be quotes as it could contain a full pathname with spaces */
2405 char *args_0 = args[0];
2406 args[0] = (char *)xmalloc (strlen (args_0) + 3);
2407 strcpy (args[0], "\"");
2408 strcat (args[0], args_0);
2409 strcat (args[0], "\"");
2411 status = spawnvp (P_WAIT, args_0, (char ** const)args);
2413 /* restore previous value */
2414 free (args[0]);
2415 args[0] = (char *)args_0;
2417 if (status < 0)
2418 return -1;
2419 else
2420 return status;
2422 #else
2424 pid = fork ();
2425 if (pid < 0)
2426 return -1;
2428 if (pid == 0)
2430 /* The child. */
2431 execv (args[0], MAYBE_TO_PTR32 (args));
2433 /* execv() returns only on error */
2434 _exit (1);
2437 /* The parent. */
2438 finished = waitpid (pid, &status, 0);
2440 if (finished != pid || WIFEXITED (status) == 0)
2441 return -1;
2443 return WEXITSTATUS (status);
2444 #endif
2446 return 0;
2449 /* Create a copy of the given file descriptor.
2450 Return -1 if an error occurred. */
2453 __gnat_dup (int oldfd)
2455 #if defined (__vxworks) && !defined (__RTP__)
2456 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2457 RTPs. */
2458 return -1;
2459 #else
2460 return dup (oldfd);
2461 #endif
2464 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
2465 Return -1 if an error occurred. */
2468 __gnat_dup2 (int oldfd ATTRIBUTE_UNUSED, int newfd ATTRIBUTE_UNUSED)
2470 #if defined (__vxworks) && !defined (__RTP__)
2471 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2472 RTPs. */
2473 return -1;
2474 #elif defined (__PikeOS__)
2475 /* Not supported. */
2476 return -1;
2477 #elif defined (_WIN32)
2478 /* Special case when oldfd and newfd are identical and are the standard
2479 input, output or error as this makes Windows XP hangs. Note that we
2480 do that only for standard file descriptors that are known to be valid. */
2481 if (oldfd == newfd && newfd >= 0 && newfd <= 2)
2482 return newfd;
2483 else
2484 return dup2 (oldfd, newfd);
2485 #else
2486 return dup2 (oldfd, newfd);
2487 #endif
2491 __gnat_number_of_cpus (void)
2493 int cores = 1;
2495 #if defined (_SC_NPROCESSORS_ONLN)
2496 cores = (int) sysconf (_SC_NPROCESSORS_ONLN);
2498 #elif defined (__QNX__)
2499 cores = (int) _syspage_ptr->num_cpu;
2501 #elif defined (__hpux__)
2502 struct pst_dynamic psd;
2503 if (pstat_getdynamic (&psd, sizeof (psd), 1, 0) != -1)
2504 cores = (int) psd.psd_proc_cnt;
2506 #elif defined (_WIN32)
2507 SYSTEM_INFO sysinfo;
2508 GetSystemInfo (&sysinfo);
2509 cores = (int) sysinfo.dwNumberOfProcessors;
2511 #elif defined (_WRS_CONFIG_SMP)
2512 unsigned int vxCpuConfiguredGet (void);
2514 cores = vxCpuConfiguredGet ();
2516 #endif
2518 return cores;
2521 /* WIN32 code to implement a wait call that wait for any child process. */
2523 #if defined (_WIN32)
2525 /* Synchronization code, to be thread safe. */
2527 #ifdef CERT
2529 /* For the Cert run times on native Windows we use dummy functions
2530 for locking and unlocking tasks since we do not support multiple
2531 threads on this configuration (Cert run time on native Windows). */
2533 static void EnterCS (void) {}
2534 static void LeaveCS (void) {}
2535 static void SignalListChanged (void) {}
2537 #else
2539 CRITICAL_SECTION ProcListCS;
2540 HANDLE ProcListEvt = NULL;
2542 static void EnterCS (void)
2544 EnterCriticalSection(&ProcListCS);
2547 static void LeaveCS (void)
2549 LeaveCriticalSection(&ProcListCS);
2552 static void SignalListChanged (void)
2554 SetEvent (ProcListEvt);
2557 #endif
2559 static HANDLE *HANDLES_LIST = NULL;
2560 static int *PID_LIST = NULL, plist_length = 0, plist_max_length = 0;
2562 static void
2563 add_handle (HANDLE h, int pid)
2565 /* -------------------- critical section -------------------- */
2566 EnterCS();
2568 if (plist_length == plist_max_length)
2570 plist_max_length += 100;
2571 HANDLES_LIST =
2572 (HANDLE *) xrealloc (HANDLES_LIST, sizeof (HANDLE) * plist_max_length);
2573 PID_LIST =
2574 (int *) xrealloc (PID_LIST, sizeof (int) * plist_max_length);
2577 HANDLES_LIST[plist_length] = h;
2578 PID_LIST[plist_length] = pid;
2579 ++plist_length;
2581 SignalListChanged();
2582 LeaveCS();
2583 /* -------------------- critical section -------------------- */
2587 __gnat_win32_remove_handle (HANDLE h, int pid)
2589 int j;
2590 int found = 0;
2592 /* -------------------- critical section -------------------- */
2593 EnterCS();
2595 for (j = 0; j < plist_length; j++)
2597 if ((HANDLES_LIST[j] == h) || (PID_LIST[j] == pid))
2599 CloseHandle (h);
2600 --plist_length;
2601 HANDLES_LIST[j] = HANDLES_LIST[plist_length];
2602 PID_LIST[j] = PID_LIST[plist_length];
2603 found = 1;
2604 break;
2608 LeaveCS();
2609 /* -------------------- critical section -------------------- */
2611 if (found)
2612 SignalListChanged();
2614 return found;
2617 static void
2618 win32_no_block_spawn (char *command, char *args[], HANDLE *h, int *pid)
2620 BOOL result;
2621 STARTUPINFO SI;
2622 PROCESS_INFORMATION PI;
2623 SECURITY_ATTRIBUTES SA;
2624 int csize = 1;
2625 char *full_command;
2626 int k;
2628 /* compute the total command line length */
2629 k = 0;
2630 while (args[k])
2632 csize += strlen (args[k]) + 1;
2633 k++;
2636 full_command = (char *) xmalloc (csize);
2638 /* Startup info. */
2639 SI.cb = sizeof (STARTUPINFO);
2640 SI.lpReserved = NULL;
2641 SI.lpReserved2 = NULL;
2642 SI.lpDesktop = NULL;
2643 SI.cbReserved2 = 0;
2644 SI.lpTitle = NULL;
2645 SI.dwFlags = 0;
2646 SI.wShowWindow = SW_HIDE;
2648 /* Security attributes. */
2649 SA.nLength = sizeof (SECURITY_ATTRIBUTES);
2650 SA.bInheritHandle = TRUE;
2651 SA.lpSecurityDescriptor = NULL;
2653 /* Prepare the command string. */
2654 strcpy (full_command, command);
2655 strcat (full_command, " ");
2657 k = 1;
2658 while (args[k])
2660 strcat (full_command, args[k]);
2661 strcat (full_command, " ");
2662 k++;
2666 int wsize = csize * 2;
2667 TCHAR *wcommand = (TCHAR *) xmalloc (wsize);
2669 S2WSC (wcommand, full_command, wsize);
2671 free (full_command);
2673 result = CreateProcess
2674 (NULL, wcommand, &SA, NULL, TRUE,
2675 GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
2677 free (wcommand);
2680 if (result == TRUE)
2682 CloseHandle (PI.hThread);
2683 *h = PI.hProcess;
2684 *pid = PI.dwProcessId;
2686 else
2688 *h = NULL;
2689 *pid = 0;
2693 static int
2694 win32_wait (int *status)
2696 DWORD exitcode, pid;
2697 HANDLE *hl;
2698 HANDLE h;
2699 int *pidl;
2700 DWORD res;
2701 int hl_len;
2702 int found;
2703 int pos;
2705 START_WAIT:
2707 if (plist_length == 0)
2709 errno = ECHILD;
2710 return -1;
2713 /* -------------------- critical section -------------------- */
2714 EnterCS();
2716 /* ??? We can't wait for more than MAXIMUM_WAIT_OBJECTS due to a Win32
2717 limitation */
2718 if (plist_length < MAXIMUM_WAIT_OBJECTS)
2719 hl_len = plist_length;
2720 else
2722 errno = EINVAL;
2723 return -1;
2726 #ifdef CERT
2727 hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len);
2728 memmove (hl, HANDLES_LIST, sizeof (HANDLE) * hl_len);
2729 pidl = (int *) xmalloc (sizeof (int) * hl_len);
2730 memmove (pidl, PID_LIST, sizeof (int) * hl_len);
2731 #else
2732 /* Note that index 0 contains the event handle that is signaled when the
2733 process list has changed */
2734 hl = (HANDLE *) xmalloc (sizeof (HANDLE) * (hl_len + 1));
2735 hl[0] = ProcListEvt;
2736 memmove (&hl[1], HANDLES_LIST, sizeof (HANDLE) * hl_len);
2737 pidl = (int *) xmalloc (sizeof (int) * (hl_len + 1));
2738 memmove (&pidl[1], PID_LIST, sizeof (int) * hl_len);
2739 hl_len++;
2740 #endif
2742 LeaveCS();
2743 /* -------------------- critical section -------------------- */
2745 res = WaitForMultipleObjects (hl_len, hl, FALSE, INFINITE);
2747 /* If there was an error, exit now */
2748 if (res == WAIT_FAILED)
2750 free (hl);
2751 free (pidl);
2752 errno = EINVAL;
2753 return -1;
2756 /* if the ProcListEvt has been signaled then the list of processes has been
2757 updated to add or remove a handle, just loop over */
2759 if (res - WAIT_OBJECT_0 == 0)
2761 free (hl);
2762 free (pidl);
2763 goto START_WAIT;
2766 /* Handle two distinct groups of return codes: finished waits and abandoned
2767 waits */
2769 if (res < WAIT_ABANDONED_0)
2770 pos = res - WAIT_OBJECT_0;
2771 else
2772 pos = res - WAIT_ABANDONED_0;
2774 h = hl[pos];
2775 GetExitCodeProcess (h, &exitcode);
2776 pid = pidl [pos];
2778 found = __gnat_win32_remove_handle (h, -1);
2780 free (hl);
2781 free (pidl);
2783 /* if not found another process waiting has already handled this process */
2785 if (!found)
2787 goto START_WAIT;
2790 *status = (int) exitcode;
2791 return (int) pid;
2794 #endif
2797 __gnat_portable_no_block_spawn (char *args[] ATTRIBUTE_UNUSED)
2800 #if defined (__vxworks) || defined (__PikeOS__)
2801 /* Not supported. */
2802 return -1;
2804 #elif defined(__DJGPP__)
2805 if (spawnvp (P_WAIT, args[0], args) != 0)
2806 return -1;
2807 else
2808 return 0;
2810 #elif defined (_WIN32)
2812 HANDLE h = NULL;
2813 int pid;
2815 win32_no_block_spawn (args[0], args, &h, &pid);
2816 if (h != NULL)
2818 add_handle (h, pid);
2819 return pid;
2821 else
2822 return -1;
2824 #else
2826 int pid = fork ();
2828 if (pid == 0)
2830 /* The child. */
2831 execv (args[0], MAYBE_TO_PTR32 (args));
2833 /* execv() returns only on error */
2834 _exit (1);
2837 return pid;
2839 #endif
2843 __gnat_portable_wait (int *process_status)
2845 int status = 0;
2846 int pid = 0;
2848 #if defined (__vxworks) || defined (__PikeOS__)
2849 /* Not sure what to do here, so do nothing but return zero. */
2851 #elif defined (_WIN32)
2853 pid = win32_wait (&status);
2855 #elif defined (__DJGPP__)
2856 /* Child process has already ended in case of DJGPP.
2857 No need to do anything. Just return success. */
2858 #else
2860 pid = waitpid (-1, &status, 0);
2861 status = status & 0xffff;
2862 #endif
2864 *process_status = status;
2865 return pid;
2869 __gnat_portable_no_block_wait (int *process_status)
2871 int status = 0;
2872 int pid = 0;
2874 #if defined (__vxworks) || defined (__PikeOS__) || defined (_WIN32)
2875 /* Not supported. */
2876 status = -1;
2878 #else
2880 pid = waitpid (-1, &status, WNOHANG);
2881 status = status & 0xffff;
2882 #endif
2884 *process_status = status;
2885 return pid;
2888 void
2889 __gnat_os_exit (int status)
2891 exit (status);
2895 __gnat_current_process_id (void)
2897 #if defined (__vxworks) || defined (__PikeOS__)
2898 return -1;
2900 #elif defined (_WIN32)
2902 return (int)GetCurrentProcessId();
2904 #else
2906 return (int)getpid();
2907 #endif
2910 /* Locate file on path, that matches a predicate */
2912 char *
2913 __gnat_locate_file_with_predicate (char *file_name, char *path_val,
2914 int (*predicate)(char *))
2916 char *ptr;
2917 char *file_path = (char *) alloca (strlen (file_name) + 1);
2918 int absolute;
2920 /* Return immediately if file_name is empty */
2922 if (*file_name == '\0')
2923 return 0;
2925 /* Remove quotes around file_name if present */
2927 ptr = file_name;
2928 if (*ptr == '"')
2929 ptr++;
2931 strcpy (file_path, ptr);
2933 ptr = file_path + strlen (file_path) - 1;
2935 if (*ptr == '"')
2936 *ptr = '\0';
2938 /* Handle absolute pathnames. */
2940 absolute = __gnat_is_absolute_path (file_path, strlen (file_name));
2942 if (absolute)
2944 if (predicate (file_path))
2945 return xstrdup (file_path);
2947 return 0;
2950 /* If file_name include directory separator(s), try it first as
2951 a path name relative to the current directory */
2952 for (ptr = file_name; *ptr && !IS_DIRECTORY_SEPARATOR(*ptr); ptr++)
2955 if (*ptr != 0)
2957 if (predicate (file_name))
2958 return xstrdup (file_name);
2961 if (path_val == 0)
2962 return 0;
2965 /* The result has to be smaller than path_val + file_name. */
2966 char *file_path =
2967 (char *) alloca (strlen (path_val) + strlen (file_name) + 2);
2969 for (;;)
2971 /* Skip the starting quote */
2973 if (*path_val == '"')
2974 path_val++;
2976 for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
2977 *ptr++ = *path_val++;
2979 /* If directory is empty, it is the current directory*/
2981 if (ptr == file_path)
2983 *ptr = '.';
2985 else
2986 ptr--;
2988 /* Skip the ending quote */
2990 if (*ptr == '"')
2991 ptr--;
2993 if (!IS_DIRECTORY_SEPARATOR(*ptr))
2994 *++ptr = DIR_SEPARATOR;
2996 strcpy (++ptr, file_name);
2998 if (predicate (file_path))
2999 return xstrdup (file_path);
3001 if (*path_val == 0)
3002 return 0;
3004 /* Skip path separator */
3006 path_val++;
3010 return 0;
3013 /* Locate an executable file, give a Path value. */
3015 char *
3016 __gnat_locate_executable_file (char *file_name, char *path_val)
3018 return __gnat_locate_file_with_predicate
3019 (file_name, path_val, &__gnat_is_executable_file);
3022 /* Locate a regular file, give a Path value. */
3024 char *
3025 __gnat_locate_regular_file (char *file_name, char *path_val)
3027 return __gnat_locate_file_with_predicate
3028 (file_name, path_val, &__gnat_is_regular_file);
3031 /* Locate an executable given a Path argument. This routine is only used by
3032 gnatbl and should not be used otherwise. Use locate_exec_on_path
3033 instead. */
3035 char *
3036 __gnat_locate_exec (char *exec_name, char *path_val)
3038 const unsigned int len = strlen (HOST_EXECUTABLE_SUFFIX);
3039 char *ptr;
3041 if (len > 0 && !strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
3043 char *full_exec_name = (char *) alloca (strlen (exec_name) + len + 1);
3045 strcpy (full_exec_name, exec_name);
3046 strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
3047 ptr = __gnat_locate_executable_file (full_exec_name, path_val);
3049 if (ptr == 0)
3050 return __gnat_locate_executable_file (exec_name, path_val);
3051 return ptr;
3053 else
3054 return __gnat_locate_executable_file (exec_name, path_val);
3057 /* Locate an executable using the Systems default PATH. */
3059 char *
3060 __gnat_locate_exec_on_path (char *exec_name)
3062 char *apath_val;
3064 #if defined (_WIN32)
3065 TCHAR *wpath_val = _tgetenv (_T("PATH"));
3066 TCHAR *wapath_val;
3067 /* In Win32 systems we expand the PATH as for XP environment
3068 variables are not automatically expanded. We also prepend the
3069 ".;" to the path to match normal NT path search semantics */
3071 #define EXPAND_BUFFER_SIZE 32767
3073 wapath_val = (TCHAR *) alloca (EXPAND_BUFFER_SIZE);
3075 wapath_val [0] = '.';
3076 wapath_val [1] = ';';
3078 DWORD res = ExpandEnvironmentStrings
3079 (wpath_val, &wapath_val[2], EXPAND_BUFFER_SIZE - 2);
3081 if (!res) wapath_val [0] = _T('\0');
3083 apath_val = (char *) alloca (EXPAND_BUFFER_SIZE);
3085 WS2SC (apath_val, wapath_val, EXPAND_BUFFER_SIZE);
3087 #else
3088 const char *path_val = getenv ("PATH");
3090 /* If PATH is not defined, proceed with __gnat_locate_exec anyway, so we can
3091 find files that contain directory names. */
3093 if (path_val == NULL) path_val = "";
3094 apath_val = (char *) alloca (strlen (path_val) + 1);
3095 strcpy (apath_val, path_val);
3096 #endif
3098 return __gnat_locate_exec (exec_name, apath_val);
3101 /* Dummy functions for Osint import for non-VMS systems.
3102 ??? To be removed. */
3105 __gnat_to_canonical_file_list_init (char *dirspec ATTRIBUTE_UNUSED,
3106 int onlydirs ATTRIBUTE_UNUSED)
3108 return 0;
3111 char *
3112 __gnat_to_canonical_file_list_next (void)
3114 static char empty[] = "";
3115 return empty;
3118 void
3119 __gnat_to_canonical_file_list_free (void)
3123 char *
3124 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3126 return dirspec;
3129 char *
3130 __gnat_to_canonical_file_spec (char *filespec)
3132 return filespec;
3135 char *
3136 __gnat_to_canonical_path_spec (char *pathspec)
3138 return pathspec;
3141 char *
3142 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3144 return dirspec;
3147 char *
3148 __gnat_to_host_file_spec (char *filespec)
3150 return filespec;
3153 void
3154 __gnat_adjust_os_resource_limits (void)
3158 #if defined (__mips_vxworks)
3160 _flush_cache (void)
3162 CACHE_USER_FLUSH (0, ENTIRE_CACHE);
3164 #endif
3166 #if defined (_WIN32)
3167 int __gnat_argument_needs_quote = 1;
3168 #else
3169 int __gnat_argument_needs_quote = 0;
3170 #endif
3172 /* This option is used to enable/disable object files handling from the
3173 binder file by the GNAT Project module. For example, this is disabled on
3174 Windows (prior to GCC 3.4) as it is already done by the mdll module.
3175 Stating with GCC 3.4 the shared libraries are not based on mdll
3176 anymore as it uses the GCC's -shared option */
3177 #if defined (_WIN32) \
3178 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3179 int __gnat_prj_add_obj_files = 0;
3180 #else
3181 int __gnat_prj_add_obj_files = 1;
3182 #endif
3184 /* char used as prefix/suffix for environment variables */
3185 #if defined (_WIN32)
3186 char __gnat_environment_char = '%';
3187 #else
3188 char __gnat_environment_char = '$';
3189 #endif
3191 /* This functions copy the file attributes from a source file to a
3192 destination file.
3194 mode = 0 : In this mode copy only the file time stamps (last access and
3195 last modification time stamps).
3197 mode = 1 : In this mode, time stamps and read/write/execute attributes are
3198 copied.
3200 mode = 2 : In this mode, only read/write/execute attributes are copied
3202 Returns 0 if operation was successful and -1 in case of error. */
3205 __gnat_copy_attribs (char *from ATTRIBUTE_UNUSED, char *to ATTRIBUTE_UNUSED,
3206 int mode ATTRIBUTE_UNUSED)
3208 #if (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6)
3209 return -1;
3211 #elif defined (_WIN32)
3212 TCHAR wfrom [GNAT_MAX_PATH_LEN + 2];
3213 TCHAR wto [GNAT_MAX_PATH_LEN + 2];
3214 BOOL res;
3215 FILETIME fct, flat, flwt;
3216 HANDLE hfrom, hto;
3218 S2WSC (wfrom, from, GNAT_MAX_PATH_LEN + 2);
3219 S2WSC (wto, to, GNAT_MAX_PATH_LEN + 2);
3221 /* Do we need to copy the timestamp ? */
3223 if (mode != 2) {
3224 /* retrieve from times */
3226 hfrom = CreateFile
3227 (wfrom, GENERIC_READ, 0, NULL, OPEN_EXISTING,
3228 FILE_ATTRIBUTE_NORMAL, NULL);
3230 if (hfrom == INVALID_HANDLE_VALUE)
3231 return -1;
3233 res = GetFileTime (hfrom, &fct, &flat, &flwt);
3235 CloseHandle (hfrom);
3237 if (res == 0)
3238 return -1;
3240 /* retrieve from times */
3242 hto = CreateFile
3243 (wto, GENERIC_WRITE, 0, NULL, OPEN_EXISTING,
3244 FILE_ATTRIBUTE_NORMAL, NULL);
3246 if (hto == INVALID_HANDLE_VALUE)
3247 return -1;
3249 res = SetFileTime (hto, NULL, &flat, &flwt);
3251 CloseHandle (hto);
3253 if (res == 0)
3254 return -1;
3257 /* Do we need to copy the permissions ? */
3258 /* Set file attributes in full mode. */
3260 if (mode != 0)
3262 DWORD attribs = GetFileAttributes (wfrom);
3264 if (attribs == INVALID_FILE_ATTRIBUTES)
3265 return -1;
3267 res = SetFileAttributes (wto, attribs);
3268 if (res == 0)
3269 return -1;
3272 return 0;
3274 #else
3275 GNAT_STRUCT_STAT fbuf;
3277 if (GNAT_STAT (from, &fbuf) == -1) {
3278 return -1;
3281 #if (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 7)
3283 /* VxWorks prior to 7 only has utime. */
3285 /* Do we need to copy the timestamp ? */
3286 if (mode != 2) {
3287 struct utimbuf tbuf;
3289 tbuf.actime = fbuf.st_atime;
3290 tbuf.modtime = fbuf.st_mtime;
3292 if (utime (to, &tbuf) == -1)
3293 return -1;
3296 #elif _POSIX_C_SOURCE >= 200809L
3297 struct timespec tbuf[2];
3299 if (mode != 2) {
3300 tbuf[0] = fbuf.st_atim;
3301 tbuf[1] = fbuf.st_mtim;
3303 if (utimensat (AT_FDCWD, to, tbuf, 0) == -1) {
3304 return -1;
3308 #else
3309 struct timeval tbuf[2];
3310 /* Do we need to copy timestamp ? */
3312 if (mode != 2) {
3313 tbuf[0].tv_sec = fbuf.st_atime;
3314 tbuf[1].tv_sec = fbuf.st_mtime;
3316 #if defined(st_mtime)
3317 tbuf[0].tv_usec = fbuf.st_atim.tv_nsec / 1000;
3318 tbuf[1].tv_usec = fbuf.st_mtim.tv_nsec / 1000;
3319 #else
3320 tbuf[0].tv_usec = 0;
3321 tbuf[1].tv_usec = 0;
3322 #endif
3324 if (utimes (to, tbuf) == -1) {
3325 return -1;
3328 #endif
3330 /* Do we need to copy file permissions ? */
3331 if (mode != 0 && (chmod (to, fbuf.st_mode) == -1)) {
3332 return -1;
3335 return 0;
3336 #endif
3340 __gnat_lseek (int fd, long offset, int whence)
3342 return (int) lseek (fd, offset, whence);
3345 /* This function returns the major version number of GCC being used. */
3347 get_gcc_version (void)
3349 #ifdef IN_RTS
3350 return __GNUC__;
3351 #else
3352 return (int) (version_string[0] - '0');
3353 #endif
3357 * Set Close_On_Exec as indicated.
3358 * Note: this is used for both GNAT.OS_Lib and GNAT.Sockets.
3362 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED,
3363 int close_on_exec_p ATTRIBUTE_UNUSED)
3365 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3366 int flags = fcntl (fd, F_GETFD, 0);
3367 if (flags < 0)
3368 return flags;
3369 if (close_on_exec_p)
3370 flags |= FD_CLOEXEC;
3371 else
3372 flags &= ~FD_CLOEXEC;
3373 return fcntl (fd, F_SETFD, flags);
3374 #elif defined(_WIN32)
3375 HANDLE h = (HANDLE) _get_osfhandle (fd);
3376 if (h == (HANDLE) -1)
3377 return -1;
3378 if (close_on_exec_p)
3379 return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT, 0);
3380 return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT,
3381 HANDLE_FLAG_INHERIT);
3382 #else
3383 /* TODO: Unimplemented. */
3384 return -1;
3385 #endif
3388 /* Indicates if platforms supports automatic initialization through the
3389 constructor mechanism */
3391 __gnat_binder_supports_auto_init (void)
3393 return 1;
3396 /* Indicates that Stand-Alone Libraries are automatically initialized through
3397 the constructor mechanism */
3399 __gnat_sals_init_using_constructors (void)
3401 #if defined (__vxworks) || defined (__Lynx__)
3402 return 0;
3403 #else
3404 return 1;
3405 #endif
3408 #if defined (__linux__) || defined (__ANDROID__)
3409 /* There is no function in the glibc to retrieve the LWP of the current
3410 thread. We need to do a system call in order to retrieve this
3411 information. */
3412 #include <sys/syscall.h>
3413 void *
3414 __gnat_lwp_self (void)
3416 return (void *) syscall (__NR_gettid);
3418 #endif
3420 #if defined (__APPLE__)
3421 # if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ >= 1060
3422 # include <mach/thread_info.h>
3423 # include <mach/mach_init.h>
3424 # include <mach/thread_act.h>
3425 # else
3426 # include <pthread.h>
3427 # endif
3429 /* System-wide thread identifier. Note it could be truncated on 32 bit
3430 hosts.
3431 Previously was: pthread_mach_thread_np (pthread_self ()). */
3432 void *
3433 __gnat_lwp_self (void)
3435 #if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ >= 1060
3436 thread_identifier_info_data_t data;
3437 mach_msg_type_number_t count = THREAD_IDENTIFIER_INFO_COUNT;
3438 kern_return_t kret;
3440 kret = thread_info (mach_thread_self (), THREAD_IDENTIFIER_INFO,
3441 (thread_info_t) &data, &count);
3442 if (kret == KERN_SUCCESS)
3443 return (void *)(uintptr_t)data.thread_id;
3444 else
3445 return 0;
3446 #else
3447 return (void *)pthread_mach_thread_np (pthread_self ());
3448 #endif
3450 #endif
3452 #if defined (__linux__)
3453 #include <sched.h>
3455 /* glibc versions earlier than 2.7 do not define the routines to handle
3456 dynamically allocated CPU sets. For these targets, we use the static
3457 versions. */
3459 #ifdef CPU_ALLOC
3461 /* Dynamic cpu sets */
3463 cpu_set_t *
3464 __gnat_cpu_alloc (size_t count)
3466 return CPU_ALLOC (count);
3469 size_t
3470 __gnat_cpu_alloc_size (size_t count)
3472 return CPU_ALLOC_SIZE (count);
3475 void
3476 __gnat_cpu_free (cpu_set_t *set)
3478 CPU_FREE (set);
3481 void
3482 __gnat_cpu_zero (size_t count, cpu_set_t *set)
3484 CPU_ZERO_S (count, set);
3487 void
3488 __gnat_cpu_set (int cpu, size_t count, cpu_set_t *set)
3490 /* Ada handles CPU numbers starting from 1, while C identifies the first
3491 CPU by a 0, so we need to adjust. */
3492 CPU_SET_S (cpu - 1, count, set);
3495 #else /* !CPU_ALLOC */
3497 /* Static cpu sets */
3499 cpu_set_t *
3500 __gnat_cpu_alloc (size_t count ATTRIBUTE_UNUSED)
3502 return (cpu_set_t *) xmalloc (sizeof (cpu_set_t));
3505 size_t
3506 __gnat_cpu_alloc_size (size_t count ATTRIBUTE_UNUSED)
3508 return sizeof (cpu_set_t);
3511 void
3512 __gnat_cpu_free (cpu_set_t *set)
3514 free (set);
3517 void
3518 __gnat_cpu_zero (size_t count ATTRIBUTE_UNUSED, cpu_set_t *set)
3520 CPU_ZERO (set);
3523 void
3524 __gnat_cpu_set (int cpu, size_t count ATTRIBUTE_UNUSED, cpu_set_t *set)
3526 /* Ada handles CPU numbers starting from 1, while C identifies the first
3527 CPU by a 0, so we need to adjust. */
3528 CPU_SET (cpu - 1, set);
3530 #endif /* !CPU_ALLOC */
3531 #endif /* __linux__ */
3533 /* Return the load address of the executable, or 0 if not known. In the
3534 specific case of error, (void *)-1 can be returned. Beware: this unit may
3535 be in a shared library. As low-level units are needed, we allow #include
3536 here. */
3538 #if defined (__APPLE__)
3539 #include <mach-o/dyld.h>
3540 #elif defined (__linux__)
3541 #include <features.h>
3542 #include <link.h>
3543 #endif
3545 const void *
3546 __gnat_get_executable_load_address (void)
3548 #if defined (__APPLE__)
3549 return _dyld_get_image_header (0);
3551 #elif defined (__linux__) && (defined (__GLIBC__) || defined (__UCLIBC__))
3552 struct link_map *map = _r_debug.r_map;
3553 return (const void *)map->l_addr;
3555 #elif defined (_WIN32)
3556 return GetModuleHandle (NULL);
3558 #else
3559 return NULL;
3560 #endif
3563 void
3564 __gnat_kill (int pid, int sig)
3566 #if defined(_WIN32)
3567 HANDLE h;
3569 switch (sig) {
3570 case 9: // SIGKILL is not declared in Windows headers
3571 case SIGINT:
3572 case SIGBREAK:
3573 case SIGTERM:
3574 case SIGABRT:
3575 h = OpenProcess (PROCESS_ALL_ACCESS, FALSE, pid);
3576 if (h != NULL) {
3577 TerminateProcess (h, sig);
3578 CloseHandle (h);
3582 #elif defined (__vxworks)
3583 /* Not implemented */
3584 #else
3585 kill (pid, sig);
3586 #endif
3589 void __gnat_killprocesstree (int pid, int sig_num)
3591 #if defined(_WIN32)
3592 PROCESSENTRY32 pe;
3594 memset(&pe, 0, sizeof(PROCESSENTRY32));
3595 pe.dwSize = sizeof(PROCESSENTRY32);
3597 HANDLE hSnap = CreateToolhelp32Snapshot (TH32CS_SNAPPROCESS, 0);
3599 /* cannot take snapshot, just kill the parent process */
3601 if (hSnap == INVALID_HANDLE_VALUE)
3603 __gnat_kill (pid, sig_num);
3604 return;
3607 if (Process32First(hSnap, &pe))
3609 BOOL bContinue = TRUE;
3611 /* kill child processes first */
3613 while (bContinue)
3615 if (pe.th32ParentProcessID == (DWORD)pid)
3616 __gnat_killprocesstree (pe.th32ProcessID, sig_num);
3618 bContinue = Process32Next (hSnap, &pe);
3622 CloseHandle (hSnap);
3624 /* kill process */
3626 __gnat_kill (pid, sig_num);
3628 #elif defined (__vxworks)
3629 /* not implemented */
3631 #elif defined (__linux__)
3632 DIR *dir;
3633 struct dirent *d;
3635 /* read all processes' pid and ppid */
3637 dir = opendir ("/proc");
3639 /* cannot open proc, just kill the parent process */
3641 if (!dir)
3643 __gnat_kill (pid, sig_num);
3644 return;
3647 /* kill child processes first */
3649 while ((d = readdir (dir)) != NULL)
3651 if ((d->d_type & DT_DIR) == DT_DIR)
3653 char statfile[64];
3654 int _pid, _ppid;
3656 /* read /proc/<PID>/stat */
3658 if (strlen (d->d_name) >= sizeof (statfile) - strlen ("/proc//stat"))
3659 continue;
3660 strcpy (statfile, "/proc/");
3661 strcat (statfile, d->d_name);
3662 strcat (statfile, "/stat");
3664 FILE *fd = fopen (statfile, "r");
3666 if (fd)
3668 const int match = fscanf (fd, "%d %*s %*s %d", &_pid, &_ppid);
3669 fclose (fd);
3671 if (match == 2 && _ppid == pid)
3672 __gnat_killprocesstree (_pid, sig_num);
3677 closedir (dir);
3679 /* kill process */
3681 __gnat_kill (pid, sig_num);
3682 #else
3683 __gnat_kill (pid, sig_num);
3684 #endif
3685 /* Note on Solaris it is possible to read /proc/<PID>/status.
3686 The 5th and 6th words are the pid and the 7th and 8th the ppid.
3687 See: /usr/include/sys/procfs.h (struct pstatus).
3691 #ifdef __cplusplus
3693 #endif