1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2007, Free Software Foundation, Inc. *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 2, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License distributed with GNAT; see file COPYING. If not, write *
19 * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
20 * Boston, MA 02110-1301, USA. *
22 * As a special exception, if you link this file with other files to *
23 * produce an executable, this file does not by itself cause the resulting *
24 * executable to be covered by the GNU General Public License. This except- *
25 * ion does not however invalidate any other reasons why the executable *
26 * file might be covered by the GNU Public License. *
28 * GNAT was originally developed by the GNAT team at New York University. *
29 * Extensive contributions were provided by Ada Core Technologies Inc. *
31 ****************************************************************************/
33 /* This file contains those routines named by Import pragmas in
34 packages in the GNAT hierarchy (especially GNAT.OS_Lib) and in
35 package Osint. Many of the subprograms in OS_Lib import standard
36 library calls directly. This file contains all other routines. */
40 /* No need to redefine exit here. */
43 /* We want to use the POSIX variants of include files. */
47 #if defined (__mips_vxworks)
49 #endif /* __mips_vxworks */
55 #define HOST_EXECUTABLE_SUFFIX ".exe"
56 #define HOST_OBJECT_SUFFIX ".obj"
70 /* We don't have libiberty, so use malloc. */
71 #define xmalloc(S) malloc (S)
72 #define xrealloc(V,S) realloc (V,S)
81 #include <sys/utime.h>
93 #elif defined (__vxworks) && defined (__RTP__)
99 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
102 /* Header files and definitions for __gnat_set_file_time_name. */
105 #include <vms/atrdef.h>
106 #include <vms/fibdef.h>
107 #include <vms/stsdef.h>
108 #include <vms/iodef.h>
110 #include <vms/descrip.h>
114 /* Use native 64-bit arithmetic. */
115 #define unix_time_to_vms(X,Y) \
116 { unsigned long long reftime, tmptime = (X); \
117 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
118 SYS$BINTIM (&unixtime, &reftime); \
119 Y = tmptime * 10000000 + reftime; }
121 /* descrip.h doesn't have everything ... */
122 struct dsc$descriptor_fib
124 unsigned long fib$l_len;
125 struct fibdef *fib$l_addr;
128 /* I/O Status Block. */
131 unsigned short status, count;
132 unsigned long devdep;
135 static char *tryfile;
137 /* Variable length string. */
141 char string[NAM$C_MAXRSS+1];
148 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
156 #define DIR_SEPARATOR '\\'
161 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
162 defined in the current system. On DOS-like systems these flags control
163 whether the file is opened/created in text-translation mode (CR/LF in
164 external file mapped to LF in internal file), but in Unix-like systems,
165 no text translation is required, so these flags have no effect. */
167 #if defined (__EMX__)
183 #ifndef HOST_EXECUTABLE_SUFFIX
184 #define HOST_EXECUTABLE_SUFFIX ""
187 #ifndef HOST_OBJECT_SUFFIX
188 #define HOST_OBJECT_SUFFIX ".o"
191 #ifndef PATH_SEPARATOR
192 #define PATH_SEPARATOR ':'
195 #ifndef DIR_SEPARATOR
196 #define DIR_SEPARATOR '/'
199 /* Check for cross-compilation */
200 #ifdef CROSS_DIRECTORY_STRUCTURE
201 int __gnat_is_cross_compiler = 1;
203 int __gnat_is_cross_compiler = 0;
206 char __gnat_dir_separator = DIR_SEPARATOR;
208 char __gnat_path_separator = PATH_SEPARATOR;
210 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
211 the base filenames that libraries specified with -lsomelib options
212 may have. This is used by GNATMAKE to check whether an executable
213 is up-to-date or not. The syntax is
215 library_template ::= { pattern ; } pattern NUL
216 pattern ::= [ prefix ] * [ postfix ]
218 These should only specify names of static libraries as it makes
219 no sense to determine at link time if dynamic-link libraries are
220 up to date or not. Any libraries that are not found are supposed
223 * if they are needed but not present, the link
226 * otherwise they are libraries in the system paths and so
227 they are considered part of the system and not checked
230 ??? This should be part of a GNAT host-specific compiler
231 file instead of being included in all user applications
232 as well. This is only a temporary work-around for 3.11b. */
234 #ifndef GNAT_LIBRARY_TEMPLATE
235 #if defined (__EMX__)
236 #define GNAT_LIBRARY_TEMPLATE "*.a"
238 #define GNAT_LIBRARY_TEMPLATE "*.olb"
240 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
244 const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE;
246 /* This variable is used in hostparm.ads to say whether the host is a VMS
249 const int __gnat_vmsp = 1;
251 const int __gnat_vmsp = 0;
255 #define GNAT_MAX_PATH_LEN MAX_PATH
258 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
260 #elif defined (__vxworks) || defined (__OPENNT)
261 #define GNAT_MAX_PATH_LEN PATH_MAX
265 #if defined (__MINGW32__)
269 #include <sys/param.h>
273 #include <sys/param.h>
277 #define GNAT_MAX_PATH_LEN MAXPATHLEN
279 #define GNAT_MAX_PATH_LEN 256
284 /* The __gnat_max_path_len variable is used to export the maximum
285 length of a path name to Ada code. max_path_len is also provided
286 for compatibility with older GNAT versions, please do not use
289 int __gnat_max_path_len = GNAT_MAX_PATH_LEN;
290 int max_path_len = GNAT_MAX_PATH_LEN;
292 /* The following macro HAVE_READDIR_R should be defined if the
293 system provides the routine readdir_r. */
294 #undef HAVE_READDIR_R
296 #if defined(VMS) && defined (__LONG_POINTERS)
298 /* Return a 32 bit pointer to an array of 32 bit pointers
299 given a 64 bit pointer to an array of 64 bit pointers */
301 typedef __char_ptr32 *__char_ptr_char_ptr32 __attribute__ ((mode (SI)));
303 static __char_ptr_char_ptr32
304 to_ptr32 (char **ptr64)
307 __char_ptr_char_ptr32 short_argv;
309 for (argc=0; ptr64[argc]; argc++);
311 /* Reallocate argv with 32 bit pointers. */
312 short_argv = (__char_ptr_char_ptr32) decc$malloc
313 (sizeof (__char_ptr32) * (argc + 1));
315 for (argc=0; ptr64[argc]; argc++)
316 short_argv[argc] = (__char_ptr32) decc$strdup (ptr64[argc]);
318 short_argv[argc] = (__char_ptr32) 0;
322 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
324 #define MAYBE_TO_PTR32(argv) argv
331 time_t res = time (NULL);
332 return (OS_Time) res;
346 time_t time = (time_t) *p_time;
349 /* On Windows systems, the time is sometimes rounded up to the nearest
350 even second, so if the number of seconds is odd, increment it. */
356 res = localtime (&time);
358 res = gmtime (&time);
363 *p_year = res->tm_year;
364 *p_month = res->tm_mon;
365 *p_day = res->tm_mday;
366 *p_hours = res->tm_hour;
367 *p_mins = res->tm_min;
368 *p_secs = res->tm_sec;
371 *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0;
374 /* Place the contents of the symbolic link named PATH in the buffer BUF,
375 which has size BUFSIZ. If PATH is a symbolic link, then return the number
376 of characters of its content in BUF. Otherwise, return -1. For Windows,
377 OS/2 and vxworks, always return -1. */
380 __gnat_readlink (char *path ATTRIBUTE_UNUSED,
381 char *buf ATTRIBUTE_UNUSED,
382 size_t bufsiz ATTRIBUTE_UNUSED)
384 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
386 #elif defined (__INTERIX) || defined (VMS)
388 #elif defined (__vxworks)
391 return readlink (path, buf, bufsiz);
395 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH. If
396 NEWPATH exists it will NOT be overwritten. For Windows, OS/2, VxWorks,
397 Interix and VMS, always return -1. */
400 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED,
401 char *newpath ATTRIBUTE_UNUSED)
403 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
405 #elif defined (__INTERIX) || defined (VMS)
407 #elif defined (__vxworks)
410 return symlink (oldpath, newpath);
414 /* Try to lock a file, return 1 if success. */
416 #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32)
418 /* Version that does not use link. */
421 __gnat_try_lock (char *dir, char *file)
425 TCHAR wfull_path[GNAT_MAX_PATH_LEN];
426 TCHAR wfile[GNAT_MAX_PATH_LEN];
427 TCHAR wdir[GNAT_MAX_PATH_LEN];
429 S2WSU (wdir, dir, GNAT_MAX_PATH_LEN);
430 S2WSU (wfile, file, GNAT_MAX_PATH_LEN);
432 _stprintf (wfull_path, _T("%s%c%s"), wdir, _T(DIR_SEPARATOR), wfile);
433 fd = _topen (wfull_path, O_CREAT | O_EXCL, 0600);
437 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
438 fd = open (full_path, O_CREAT | O_EXCL, 0600);
448 #elif defined (__EMX__) || defined (VMS)
450 /* More cases that do not use link; identical code, to solve too long
454 __gnat_try_lock (char *dir, char *file)
459 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
460 fd = open (full_path, O_CREAT | O_EXCL, 0600);
471 /* Version using link(), more secure over NFS. */
472 /* See TN 6913-016 for discussion ??? */
475 __gnat_try_lock (char *dir, char *file)
479 struct stat stat_result;
482 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
483 sprintf (temp_file, "%s%cTMP-%ld-%ld",
484 dir, DIR_SEPARATOR, (long)getpid(), (long)getppid ());
486 /* Create the temporary file and write the process number. */
487 fd = open (temp_file, O_CREAT | O_WRONLY, 0600);
493 /* Link it with the new file. */
494 link (temp_file, full_path);
496 /* Count the references on the old one. If we have a count of two, then
497 the link did succeed. Remove the temporary file before returning. */
498 __gnat_stat (temp_file, &stat_result);
500 return stat_result.st_nlink == 2;
504 /* Return the maximum file name length. */
507 __gnat_get_maximum_file_name_length (void)
512 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
521 /* Return nonzero if file names are case sensitive. */
524 __gnat_get_file_names_case_sensitive (void)
526 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT)
534 __gnat_get_default_identifier_character_set (void)
536 #if defined (__EMX__) || defined (MSDOS)
543 /* Return the current working directory. */
546 __gnat_get_current_dir (char *dir, int *length)
548 #if defined (__MINGW32__)
549 TCHAR wdir[GNAT_MAX_PATH_LEN];
551 _tgetcwd (wdir, *length);
553 WS2SU (dir, wdir, GNAT_MAX_PATH_LEN);
556 /* Force Unix style, which is what GNAT uses internally. */
557 getcwd (dir, *length, 0);
559 getcwd (dir, *length);
562 *length = strlen (dir);
564 if (dir [*length - 1] != DIR_SEPARATOR)
566 dir [*length] = DIR_SEPARATOR;
572 /* Return the suffix for object files. */
575 __gnat_get_object_suffix_ptr (int *len, const char **value)
577 *value = HOST_OBJECT_SUFFIX;
582 *len = strlen (*value);
587 /* Return the suffix for executable files. */
590 __gnat_get_executable_suffix_ptr (int *len, const char **value)
592 *value = HOST_EXECUTABLE_SUFFIX;
596 *len = strlen (*value);
601 /* Return the suffix for debuggable files. Usually this is the same as the
602 executable extension. */
605 __gnat_get_debuggable_suffix_ptr (int *len, const char **value)
608 *value = HOST_EXECUTABLE_SUFFIX;
610 /* On DOS, the extensionless COFF file is what gdb likes. */
617 *len = strlen (*value);
622 /* Returns the OS filename and corresponding encoding. */
625 __gnat_os_filename (char *filename, char *w_filename,
626 char *os_name, int *o_length,
627 char *encoding, int *e_length)
629 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE)
630 WS2SU (os_name, (TCHAR *)w_filename, o_length);
631 *o_length = strlen (os_name);
632 strcpy (encoding, "encoding=utf8");
633 *e_length = strlen (encoding);
635 strcpy (os_name, filename);
636 *o_length = strlen (filename);
642 __gnat_fopen (char *path, char *mode, int encoding)
644 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE)
645 TCHAR wpath[GNAT_MAX_PATH_LEN];
648 S2WS (wmode, mode, 10);
650 if (encoding == Encoding_UTF8)
651 S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
653 S2WS (wpath, path, GNAT_MAX_PATH_LEN);
655 return _tfopen (wpath, wmode);
657 return decc$fopen (path, mode);
659 return fopen (path, mode);
664 __gnat_freopen (char *path, char *mode, FILE *stream, int encoding)
666 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE)
667 TCHAR wpath[GNAT_MAX_PATH_LEN];
670 S2WS (wmode, mode, 10);
672 if (encoding == Encoding_UTF8)
673 S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
675 S2WS (wpath, path, GNAT_MAX_PATH_LEN);
677 return _tfreopen (wpath, wmode, stream);
679 return decc$freopen (path, mode, stream);
681 return freopen (path, mode, stream);
686 __gnat_open_read (char *path, int fmode)
689 int o_fmode = O_BINARY;
695 /* Optional arguments mbc,deq,fop increase read performance. */
696 fd = open (path, O_RDONLY | o_fmode, 0444,
697 "mbc=16", "deq=64", "fop=tef");
698 #elif defined (__vxworks)
699 fd = open (path, O_RDONLY | o_fmode, 0444);
700 #elif defined (__MINGW32__)
702 TCHAR wpath[GNAT_MAX_PATH_LEN];
704 S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
705 fd = _topen (wpath, O_RDONLY | o_fmode, 0444);
708 fd = open (path, O_RDONLY | o_fmode);
711 return fd < 0 ? -1 : fd;
714 #if defined (__EMX__) || defined (__MINGW32__)
715 #define PERM (S_IREAD | S_IWRITE)
717 /* Excerpt from DECC C RTL Reference Manual:
718 To create files with OpenVMS RMS default protections using the UNIX
719 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
720 and open with a file-protection mode argument of 0777 in a program
721 that never specifically calls umask. These default protections include
722 correctly establishing protections based on ACLs, previous versions of
726 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
730 __gnat_open_rw (char *path, int fmode)
733 int o_fmode = O_BINARY;
739 fd = open (path, O_RDWR | o_fmode, PERM,
740 "mbc=16", "deq=64", "fop=tef");
741 #elif defined (__MINGW32__)
743 TCHAR wpath[GNAT_MAX_PATH_LEN];
745 S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
746 fd = _topen (wpath, O_RDWR | o_fmode, PERM);
749 fd = open (path, O_RDWR | o_fmode, PERM);
752 return fd < 0 ? -1 : fd;
756 __gnat_open_create (char *path, int fmode)
759 int o_fmode = O_BINARY;
765 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM,
766 "mbc=16", "deq=64", "fop=tef");
767 #elif defined (__MINGW32__)
769 TCHAR wpath[GNAT_MAX_PATH_LEN];
771 S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
772 fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
775 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
778 return fd < 0 ? -1 : fd;
782 __gnat_create_output_file (char *path)
786 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM,
787 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
788 "shr=del,get,put,upd");
789 #elif defined (__MINGW32__)
791 TCHAR wpath[GNAT_MAX_PATH_LEN];
793 S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
794 fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
797 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
800 return fd < 0 ? -1 : fd;
804 __gnat_open_append (char *path, int fmode)
807 int o_fmode = O_BINARY;
813 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM,
814 "mbc=16", "deq=64", "fop=tef");
815 #elif defined (__MINGW32__)
817 TCHAR wpath[GNAT_MAX_PATH_LEN];
819 S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
820 fd = _topen (wpath, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
823 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
826 return fd < 0 ? -1 : fd;
829 /* Open a new file. Return error (-1) if the file already exists. */
832 __gnat_open_new (char *path, int fmode)
835 int o_fmode = O_BINARY;
841 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
842 "mbc=16", "deq=64", "fop=tef");
843 #elif defined (__MINGW32__)
845 TCHAR wpath[GNAT_MAX_PATH_LEN];
847 S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
848 fd = _topen (wpath, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
851 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
854 return fd < 0 ? -1 : fd;
857 /* Open a new temp file. Return error (-1) if the file already exists.
858 Special options for VMS allow the file to be shared between parent and child
859 processes, however they really slow down output. Used in gnatchop. */
862 __gnat_open_new_temp (char *path, int fmode)
865 int o_fmode = O_BINARY;
867 strcpy (path, "GNAT-XXXXXX");
869 #if (defined (__FreeBSD__) || defined (linux)) && !defined (__vxworks)
870 return mkstemp (path);
871 #elif defined (__Lynx__)
874 if (mktemp (path) == NULL)
882 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
883 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
884 "mbc=16", "deq=64", "fop=tef");
886 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
889 return fd < 0 ? -1 : fd;
892 /* Return the number of bytes in the specified file. */
895 __gnat_file_length (int fd)
900 ret = fstat (fd, &statbuf);
901 if (ret || !S_ISREG (statbuf.st_mode))
904 return (statbuf.st_size);
907 /* Return the number of bytes in the specified named file. */
910 __gnat_named_file_length (char *name)
915 ret = __gnat_stat (name, &statbuf);
916 if (ret || !S_ISREG (statbuf.st_mode))
919 return (statbuf.st_size);
922 /* Create a temporary filename and put it in string pointed to by
926 __gnat_tmp_name (char *tmp_filename)
932 /* tempnam tries to create a temporary file in directory pointed to by
933 TMP environment variable, in c:\temp if TMP is not set, and in
934 directory specified by P_tmpdir in stdio.h if c:\temp does not
935 exist. The filename will be created with the prefix "gnat-". */
937 pname = (char *) tempnam ("c:\\temp", "gnat-");
939 /* if pname is NULL, the file was not created properly, the disk is full
940 or there is no more free temporary files */
943 *tmp_filename = '\0';
945 /* If pname start with a back slash and not path information it means that
946 the filename is valid for the current working directory. */
948 else if (pname[0] == '\\')
950 strcpy (tmp_filename, ".\\");
951 strcat (tmp_filename, pname+1);
954 strcpy (tmp_filename, pname);
959 #elif defined (linux) || defined (__FreeBSD__)
960 #define MAX_SAFE_PATH 1000
961 char *tmpdir = getenv ("TMPDIR");
963 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
964 a buffer overflow. */
965 if (tmpdir == NULL || strlen (tmpdir) > MAX_SAFE_PATH)
966 strcpy (tmp_filename, "/tmp/gnat-XXXXXX");
968 sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
970 close (mkstemp(tmp_filename));
972 tmpnam (tmp_filename);
976 /* Open directory and returns a DIR pointer. */
978 DIR* __gnat_opendir (char *name)
981 TCHAR wname[GNAT_MAX_PATH_LEN];
983 S2WSU (wname, name, GNAT_MAX_PATH_LEN);
984 return (DIR*)_topendir (wname);
987 return opendir (name);
991 /* Read the next entry in a directory. The returned string points somewhere
995 __gnat_readdir (DIR *dirp, char *buffer, int *len)
997 #if defined (__MINGW32__)
998 struct _tdirent *dirent = _treaddir ((_TDIR*)dirp);
1002 WS2SU (buffer, dirent->d_name, GNAT_MAX_PATH_LEN);
1003 *len = strlen (buffer);
1010 #elif defined (HAVE_READDIR_R)
1011 /* If possible, try to use the thread-safe version. */
1012 if (readdir_r (dirp, buffer) != NULL)
1014 *len = strlen (((struct dirent*) buffer)->d_name);
1015 return ((struct dirent*) buffer)->d_name;
1021 struct dirent *dirent = (struct dirent *) readdir (dirp);
1025 strcpy (buffer, dirent->d_name);
1026 *len = strlen (buffer);
1035 /* Close a directory entry. */
1037 int __gnat_closedir (DIR *dirp)
1040 return _tclosedir ((_TDIR*)dirp);
1043 return closedir (dirp);
1047 /* Returns 1 if readdir is thread safe, 0 otherwise. */
1050 __gnat_readdir_is_thread_safe (void)
1052 #ifdef HAVE_READDIR_R
1060 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
1061 static const unsigned long long w32_epoch_offset = 11644473600ULL;
1063 /* Returns the file modification timestamp using Win32 routines which are
1064 immune against daylight saving time change. It is in fact not possible to
1065 use fstat for this purpose as the DST modify the st_mtime field of the
1069 win32_filetime (HANDLE h)
1074 unsigned long long ull_time;
1077 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1078 since <Jan 1st 1601>. This function must return the number of seconds
1079 since <Jan 1st 1970>. */
1081 if (GetFileTime (h, NULL, NULL, &t_write.ft_time))
1082 return (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset);
1087 /* Return a GNAT time stamp given a file name. */
1090 __gnat_file_time_name (char *name)
1093 #if defined (__EMX__) || defined (MSDOS)
1094 int fd = open (name, O_RDONLY | O_BINARY);
1095 time_t ret = __gnat_file_time_fd (fd);
1097 return (OS_Time)ret;
1099 #elif defined (_WIN32)
1101 TCHAR wname[GNAT_MAX_PATH_LEN];
1103 S2WSU (wname, name, GNAT_MAX_PATH_LEN);
1105 HANDLE h = CreateFile
1106 (wname, GENERIC_READ, FILE_SHARE_READ, 0,
1107 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
1109 if (h != INVALID_HANDLE_VALUE)
1111 ret = win32_filetime (h);
1114 return (OS_Time) ret;
1116 struct stat statbuf;
1117 if (__gnat_stat (name, &statbuf) != 0) {
1121 /* VMS has file versioning. */
1122 return (OS_Time)statbuf.st_ctime;
1124 return (OS_Time)statbuf.st_mtime;
1130 /* Return a GNAT time stamp given a file descriptor. */
1133 __gnat_file_time_fd (int fd)
1135 /* The following workaround code is due to the fact that under EMX and
1136 DJGPP fstat attempts to convert time values to GMT rather than keep the
1137 actual OS timestamp of the file. By using the OS2/DOS functions directly
1138 the GNAT timestamp are independent of this behavior, which is desired to
1139 facilitate the distribution of GNAT compiled libraries. */
1141 #if defined (__EMX__) || defined (MSDOS)
1145 int ret = DosQueryFileInfo (fd, 1, (unsigned char *) &fs,
1146 sizeof (FILESTATUS));
1148 unsigned file_year = fs.fdateLastWrite.year;
1149 unsigned file_month = fs.fdateLastWrite.month;
1150 unsigned file_day = fs.fdateLastWrite.day;
1151 unsigned file_hour = fs.ftimeLastWrite.hours;
1152 unsigned file_min = fs.ftimeLastWrite.minutes;
1153 unsigned file_tsec = fs.ftimeLastWrite.twosecs;
1157 int ret = getftime (fd, &fs);
1159 unsigned file_year = fs.ft_year;
1160 unsigned file_month = fs.ft_month;
1161 unsigned file_day = fs.ft_day;
1162 unsigned file_hour = fs.ft_hour;
1163 unsigned file_min = fs.ft_min;
1164 unsigned file_tsec = fs.ft_tsec;
1167 /* Calculate the seconds since epoch from the time components. First count
1168 the whole days passed. The value for years returned by the DOS and OS2
1169 functions count years from 1980, so to compensate for the UNIX epoch which
1170 begins in 1970 start with 10 years worth of days and add days for each
1171 four year period since then. */
1174 int cum_days[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
1175 int days_passed = 3652 + (file_year / 4) * 1461;
1176 int years_since_leap = file_year % 4;
1178 if (years_since_leap == 1)
1180 else if (years_since_leap == 2)
1182 else if (years_since_leap == 3)
1183 days_passed += 1096;
1188 days_passed += cum_days[file_month - 1];
1189 if (years_since_leap == 0 && file_year != 20 && file_month > 2)
1192 days_passed += file_day - 1;
1194 /* OK - have whole days. Multiply -- then add in other parts. */
1196 tot_secs = days_passed * 86400;
1197 tot_secs += file_hour * 3600;
1198 tot_secs += file_min * 60;
1199 tot_secs += file_tsec * 2;
1200 return (OS_Time) tot_secs;
1202 #elif defined (_WIN32)
1203 HANDLE h = (HANDLE) _get_osfhandle (fd);
1204 time_t ret = win32_filetime (h);
1205 return (OS_Time) ret;
1208 struct stat statbuf;
1210 if (fstat (fd, &statbuf) != 0) {
1211 return (OS_Time) -1;
1214 /* VMS has file versioning. */
1215 return (OS_Time) statbuf.st_ctime;
1217 return (OS_Time) statbuf.st_mtime;
1223 /* Set the file time stamp. */
1226 __gnat_set_file_time_name (char *name, time_t time_stamp)
1228 #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1230 /* Code to implement __gnat_set_file_time_name for these systems. */
1232 #elif defined (_WIN32)
1236 unsigned long long ull_time;
1238 TCHAR wname[GNAT_MAX_PATH_LEN];
1240 S2WSU (wname, name, GNAT_MAX_PATH_LEN);
1242 HANDLE h = CreateFile
1243 (wname, GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
1244 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS,
1246 if (h == INVALID_HANDLE_VALUE)
1248 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1249 t_write.ull_time = ((unsigned long long)time_stamp + w32_epoch_offset);
1250 /* Convert to 100 nanosecond units */
1251 t_write.ull_time *= 10000000ULL;
1253 SetFileTime(h, NULL, NULL, &t_write.ft_time);
1263 unsigned long long backup, create, expire, revise;
1267 unsigned short value;
1270 unsigned system : 4;
1276 } Fat = { 0, 0, 0, 0, 0, { 0 }};
1280 { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create },
1281 { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise },
1282 { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire },
1283 { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup },
1284 { ATR$S_FPRO, ATR$C_FPRO, &Fat.prot },
1285 { ATR$S_UIC, ATR$C_UIC, &Fat.uic },
1290 struct dsc$descriptor_fib fibdsc = {sizeof (fib), (void *) &fib};
1294 unsigned long long newtime;
1295 unsigned long long revtime;
1299 struct vstring file;
1300 struct dsc$descriptor_s filedsc
1301 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) file.string};
1302 struct vstring device;
1303 struct dsc$descriptor_s devicedsc
1304 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) device.string};
1305 struct vstring timev;
1306 struct dsc$descriptor_s timedsc
1307 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) timev.string};
1308 struct vstring result;
1309 struct dsc$descriptor_s resultdsc
1310 = {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string};
1312 /* Convert parameter name (a file spec) to host file form. Note that this
1313 is needed on VMS to prepare for subsequent calls to VMS RMS library
1314 routines. Note that it would not work to call __gnat_to_host_dir_spec
1315 as was done in a previous version, since this fails silently unless
1316 the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1317 (directory not found) condition is signalled. */
1318 tryfile = (char *) __gnat_to_host_file_spec (name);
1320 /* Allocate and initialize a FAB and NAM structures. */
1324 nam.nam$l_esa = file.string;
1325 nam.nam$b_ess = NAM$C_MAXRSS;
1326 nam.nam$l_rsa = result.string;
1327 nam.nam$b_rss = NAM$C_MAXRSS;
1328 fab.fab$l_fna = tryfile;
1329 fab.fab$b_fns = strlen (tryfile);
1330 fab.fab$l_nam = &nam;
1332 /* Validate filespec syntax and device existence. */
1333 status = SYS$PARSE (&fab, 0, 0);
1334 if ((status & 1) != 1)
1335 LIB$SIGNAL (status);
1337 file.string[nam.nam$b_esl] = 0;
1339 /* Find matching filespec. */
1340 status = SYS$SEARCH (&fab, 0, 0);
1341 if ((status & 1) != 1)
1342 LIB$SIGNAL (status);
1344 file.string[nam.nam$b_esl] = 0;
1345 result.string[result.length=nam.nam$b_rsl] = 0;
1347 /* Get the device name and assign an IO channel. */
1348 strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev);
1349 devicedsc.dsc$w_length = nam.nam$b_dev;
1351 status = SYS$ASSIGN (&devicedsc, &chan, 0, 0, 0);
1352 if ((status & 1) != 1)
1353 LIB$SIGNAL (status);
1355 /* Initialize the FIB and fill in the directory id field. */
1356 memset (&fib, 0, sizeof (fib));
1357 fib.fib$w_did[0] = nam.nam$w_did[0];
1358 fib.fib$w_did[1] = nam.nam$w_did[1];
1359 fib.fib$w_did[2] = nam.nam$w_did[2];
1360 fib.fib$l_acctl = 0;
1362 strcpy (file.string, (strrchr (result.string, ']') + 1));
1363 filedsc.dsc$w_length = strlen (file.string);
1364 result.string[result.length = 0] = 0;
1366 /* Open and close the file to fill in the attributes. */
1368 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1369 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1370 if ((status & 1) != 1)
1371 LIB$SIGNAL (status);
1372 if ((iosb.status & 1) != 1)
1373 LIB$SIGNAL (iosb.status);
1375 result.string[result.length] = 0;
1376 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, &fibdsc, 0, 0, 0,
1378 if ((status & 1) != 1)
1379 LIB$SIGNAL (status);
1380 if ((iosb.status & 1) != 1)
1381 LIB$SIGNAL (iosb.status);
1386 /* Set creation time to requested time. */
1387 unix_time_to_vms (time_stamp, newtime);
1389 t = time ((time_t) 0);
1391 /* Set revision time to now in local time. */
1392 unix_time_to_vms (t, revtime);
1395 /* Reopen the file, modify the times and then close. */
1396 fib.fib$l_acctl = FIB$M_WRITE;
1398 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1399 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1400 if ((status & 1) != 1)
1401 LIB$SIGNAL (status);
1402 if ((iosb.status & 1) != 1)
1403 LIB$SIGNAL (iosb.status);
1405 Fat.create = newtime;
1406 Fat.revise = revtime;
1408 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0,
1409 &fibdsc, 0, 0, 0, &atrlst, 0);
1410 if ((status & 1) != 1)
1411 LIB$SIGNAL (status);
1412 if ((iosb.status & 1) != 1)
1413 LIB$SIGNAL (iosb.status);
1415 /* Deassign the channel and exit. */
1416 status = SYS$DASSGN (chan);
1417 if ((status & 1) != 1)
1418 LIB$SIGNAL (status);
1420 struct utimbuf utimbuf;
1423 /* Set modification time to requested time. */
1424 utimbuf.modtime = time_stamp;
1426 /* Set access time to now in local time. */
1427 t = time ((time_t) 0);
1428 utimbuf.actime = mktime (localtime (&t));
1430 utime (name, &utimbuf);
1435 #include <windows.h>
1438 /* Get the list of installed standard libraries from the
1439 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1443 __gnat_get_libraries_from_registry (void)
1445 char *result = (char *) "";
1447 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE)
1450 DWORD name_size, value_size;
1457 /* First open the key. */
1458 res = RegOpenKeyExA (HKEY_LOCAL_MACHINE, "SOFTWARE", 0, KEY_READ, ®_key);
1460 if (res == ERROR_SUCCESS)
1461 res = RegOpenKeyExA (reg_key, "Ada Core Technologies", 0,
1462 KEY_READ, ®_key);
1464 if (res == ERROR_SUCCESS)
1465 res = RegOpenKeyExA (reg_key, "GNAT", 0, KEY_READ, ®_key);
1467 if (res == ERROR_SUCCESS)
1468 res = RegOpenKeyExA (reg_key, "Standard Libraries", 0, KEY_READ, ®_key);
1470 /* If the key exists, read out all the values in it and concatenate them
1472 for (index = 0; res == ERROR_SUCCESS; index++)
1474 value_size = name_size = 256;
1475 res = RegEnumValueA (reg_key, index, (TCHAR*)name, &name_size, 0,
1476 &type, (LPBYTE)value, &value_size);
1478 if (res == ERROR_SUCCESS && type == REG_SZ)
1480 char *old_result = result;
1482 result = (char *) xmalloc (strlen (old_result) + value_size + 2);
1483 strcpy (result, old_result);
1484 strcat (result, value);
1485 strcat (result, ";");
1489 /* Remove the trailing ";". */
1491 result[strlen (result) - 1] = 0;
1498 __gnat_stat (char *name, struct stat *statbuf)
1501 /* Under Windows the directory name for the stat function must not be
1502 terminated by a directory separator except if just after a drive name. */
1503 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1507 S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
1508 name_len = _tcslen (wname);
1510 if (name_len > GNAT_MAX_PATH_LEN)
1513 last_char = wname[name_len - 1];
1515 while (name_len > 1 && (last_char == _T('\\') || last_char == _T('/')))
1517 wname[name_len - 1] = _T('\0');
1519 last_char = wname[name_len - 1];
1522 /* Only a drive letter followed by ':', we must add a directory separator
1523 for the stat routine to work properly. */
1524 if (name_len == 2 && wname[1] == _T(':'))
1525 _tcscat (wname, _T("\\"));
1527 return _tstat (wname, statbuf);
1530 return stat (name, statbuf);
1535 __gnat_file_exists (char *name)
1538 /* On Windows do not use __gnat_stat() because a bug in Microsoft
1539 _stat() routine. When the system time-zone is set with a negative
1540 offset the _stat() routine fails on specific files like CON: */
1541 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1543 S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
1544 return GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES;
1546 struct stat statbuf;
1548 return !__gnat_stat (name, &statbuf);
1553 __gnat_is_absolute_path (char *name, int length)
1555 return (length != 0) &&
1556 (*name == '/' || *name == DIR_SEPARATOR
1557 #if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
1558 || (length > 1 && isalpha (name[0]) && name[1] == ':')
1564 __gnat_is_regular_file (char *name)
1567 struct stat statbuf;
1569 ret = __gnat_stat (name, &statbuf);
1570 return (!ret && S_ISREG (statbuf.st_mode));
1574 __gnat_is_directory (char *name)
1577 struct stat statbuf;
1579 ret = __gnat_stat (name, &statbuf);
1580 return (!ret && S_ISDIR (statbuf.st_mode));
1584 __gnat_is_readable_file (char *name)
1588 struct stat statbuf;
1590 ret = __gnat_stat (name, &statbuf);
1591 mode = statbuf.st_mode & S_IRUSR;
1592 return (!ret && mode);
1596 __gnat_is_writable_file (char *name)
1600 struct stat statbuf;
1602 ret = __gnat_stat (name, &statbuf);
1603 mode = statbuf.st_mode & S_IWUSR;
1604 return (!ret && mode);
1608 __gnat_set_writable (char *name)
1611 struct stat statbuf;
1613 if (stat (name, &statbuf) == 0)
1615 statbuf.st_mode = statbuf.st_mode | S_IWUSR;
1616 chmod (name, statbuf.st_mode);
1622 __gnat_set_executable (char *name)
1625 struct stat statbuf;
1627 if (stat (name, &statbuf) == 0)
1629 statbuf.st_mode = statbuf.st_mode | S_IXUSR;
1630 chmod (name, statbuf.st_mode);
1636 __gnat_set_readonly (char *name)
1639 struct stat statbuf;
1641 if (stat (name, &statbuf) == 0)
1643 statbuf.st_mode = statbuf.st_mode & 07577;
1644 chmod (name, statbuf.st_mode);
1650 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED)
1652 #if defined (__vxworks)
1655 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
1657 struct stat statbuf;
1659 ret = lstat (name, &statbuf);
1660 return (!ret && S_ISLNK (statbuf.st_mode));
1667 #if defined (sun) && defined (__SVR4)
1668 /* Using fork on Solaris will duplicate all the threads. fork1, which
1669 duplicates only the active thread, must be used instead, or spawning
1670 subprocess from a program with tasking will lead into numerous problems. */
1675 __gnat_portable_spawn (char *args[])
1678 int finished ATTRIBUTE_UNUSED;
1679 int pid ATTRIBUTE_UNUSED;
1681 #if defined (MSDOS) || defined (_WIN32)
1682 /* args[0] must be quotes as it could contain a full pathname with spaces */
1683 char *args_0 = args[0];
1684 args[0] = (char *)xmalloc (strlen (args_0) + 3);
1685 strcpy (args[0], "\"");
1686 strcat (args[0], args_0);
1687 strcat (args[0], "\"");
1689 status = spawnvp (P_WAIT, args_0, (const char* const*)args);
1691 /* restore previous value */
1693 args[0] = (char *)args_0;
1700 #elif defined (__vxworks)
1705 pid = spawnvp (P_NOWAIT, args[0], args);
1717 if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
1719 return -1; /* execv is in parent context on VMS. */
1727 finished = waitpid (pid, &status, 0);
1729 if (finished != pid || WIFEXITED (status) == 0)
1732 return WEXITSTATUS (status);
1738 /* Create a copy of the given file descriptor.
1739 Return -1 if an error occurred. */
1742 __gnat_dup (int oldfd)
1744 #if defined (__vxworks) && !defined (__RTP__)
1745 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
1753 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
1754 Return -1 if an error occurred. */
1757 __gnat_dup2 (int oldfd, int newfd)
1759 #if defined (__vxworks) && !defined (__RTP__)
1760 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
1764 return dup2 (oldfd, newfd);
1768 /* WIN32 code to implement a wait call that wait for any child process. */
1772 /* Synchronization code, to be thread safe. */
1774 static CRITICAL_SECTION plist_cs;
1777 __gnat_plist_init (void)
1779 InitializeCriticalSection (&plist_cs);
1785 EnterCriticalSection (&plist_cs);
1791 LeaveCriticalSection (&plist_cs);
1794 typedef struct _process_list
1797 struct _process_list *next;
1800 static Process_List *PLIST = NULL;
1802 static int plist_length = 0;
1805 add_handle (HANDLE h)
1809 pl = (Process_List *) xmalloc (sizeof (Process_List));
1813 /* -------------------- critical section -------------------- */
1818 /* -------------------- critical section -------------------- */
1824 remove_handle (HANDLE h)
1827 Process_List *prev = NULL;
1831 /* -------------------- critical section -------------------- */
1840 prev->next = pl->next;
1852 /* -------------------- critical section -------------------- */
1858 win32_no_block_spawn (char *command, char *args[])
1862 PROCESS_INFORMATION PI;
1863 SECURITY_ATTRIBUTES SA;
1868 /* compute the total command line length */
1872 csize += strlen (args[k]) + 1;
1876 full_command = (char *) xmalloc (csize);
1879 SI.cb = sizeof (STARTUPINFO);
1880 SI.lpReserved = NULL;
1881 SI.lpReserved2 = NULL;
1882 SI.lpDesktop = NULL;
1886 SI.wShowWindow = SW_HIDE;
1888 /* Security attributes. */
1889 SA.nLength = sizeof (SECURITY_ATTRIBUTES);
1890 SA.bInheritHandle = TRUE;
1891 SA.lpSecurityDescriptor = NULL;
1893 /* Prepare the command string. */
1894 strcpy (full_command, command);
1895 strcat (full_command, " ");
1900 strcat (full_command, args[k]);
1901 strcat (full_command, " ");
1906 int wsize = csize * 2;
1907 TCHAR *wcommand = (TCHAR *) xmalloc (wsize);
1909 S2WSU (wcommand, full_command, wsize);
1911 free (full_command);
1913 result = CreateProcess
1914 (NULL, wcommand, &SA, NULL, TRUE,
1915 GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
1922 add_handle (PI.hProcess);
1923 CloseHandle (PI.hThread);
1924 return (int) PI.hProcess;
1931 win32_wait (int *status)
1940 if (plist_length == 0)
1946 hl = (HANDLE *) xmalloc (sizeof (HANDLE) * plist_length);
1951 /* -------------------- critical section -------------------- */
1958 /* -------------------- critical section -------------------- */
1962 res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE);
1963 h = hl[res - WAIT_OBJECT_0];
1968 GetExitCodeProcess (h, &exitcode);
1971 *status = (int) exitcode;
1978 __gnat_portable_no_block_spawn (char *args[])
1982 #if defined (__EMX__) || defined (MSDOS)
1984 /* ??? For PC machines I (Franco) don't know the system calls to implement
1985 this routine. So I'll fake it as follows. This routine will behave
1986 exactly like the blocking portable_spawn and will systematically return
1987 a pid of 0 unless the spawned task did not complete successfully, in
1988 which case we return a pid of -1. To synchronize with this the
1989 portable_wait below systematically returns a pid of 0 and reports that
1990 the subprocess terminated successfully. */
1992 if (spawnvp (P_WAIT, args[0], args) != 0)
1995 #elif defined (_WIN32)
1997 pid = win32_no_block_spawn (args[0], args);
2000 #elif defined (__vxworks)
2009 if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
2011 return -1; /* execv is in parent context on VMS. */
2023 __gnat_portable_wait (int *process_status)
2028 #if defined (_WIN32)
2030 pid = win32_wait (&status);
2032 #elif defined (__EMX__) || defined (MSDOS)
2033 /* ??? See corresponding comment in portable_no_block_spawn. */
2035 #elif defined (__vxworks)
2036 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
2040 pid = waitpid (-1, &status, 0);
2041 status = status & 0xffff;
2044 *process_status = status;
2049 __gnat_os_exit (int status)
2054 /* Locate a regular file, give a Path value. */
2057 __gnat_locate_regular_file (char *file_name, char *path_val)
2060 char *file_path = alloca (strlen (file_name) + 1);
2063 /* Return immediately if file_name is empty */
2065 if (*file_name == '\0')
2068 /* Remove quotes around file_name if present */
2074 strcpy (file_path, ptr);
2076 ptr = file_path + strlen (file_path) - 1;
2081 /* Handle absolute pathnames. */
2083 absolute = __gnat_is_absolute_path (file_path, strlen (file_name));
2087 if (__gnat_is_regular_file (file_path))
2088 return xstrdup (file_path);
2093 /* If file_name include directory separator(s), try it first as
2094 a path name relative to the current directory */
2095 for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
2100 if (__gnat_is_regular_file (file_name))
2101 return xstrdup (file_name);
2108 /* The result has to be smaller than path_val + file_name. */
2109 char *file_path = alloca (strlen (path_val) + strlen (file_name) + 2);
2113 for (; *path_val == PATH_SEPARATOR; path_val++)
2119 /* Skip the starting quote */
2121 if (*path_val == '"')
2124 for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
2125 *ptr++ = *path_val++;
2129 /* Skip the ending quote */
2134 if (*ptr != '/' && *ptr != DIR_SEPARATOR)
2135 *++ptr = DIR_SEPARATOR;
2137 strcpy (++ptr, file_name);
2139 if (__gnat_is_regular_file (file_path))
2140 return xstrdup (file_path);
2147 /* Locate an executable given a Path argument. This routine is only used by
2148 gnatbl and should not be used otherwise. Use locate_exec_on_path
2152 __gnat_locate_exec (char *exec_name, char *path_val)
2155 if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
2157 char *full_exec_name
2158 = alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
2160 strcpy (full_exec_name, exec_name);
2161 strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
2162 ptr = __gnat_locate_regular_file (full_exec_name, path_val);
2165 return __gnat_locate_regular_file (exec_name, path_val);
2169 return __gnat_locate_regular_file (exec_name, path_val);
2172 /* Locate an executable using the Systems default PATH. */
2175 __gnat_locate_exec_on_path (char *exec_name)
2180 TCHAR *wpath_val = _tgetenv (_T("PATH"));
2182 /* In Win32 systems we expand the PATH as for XP environment
2183 variables are not automatically expanded. We also prepend the
2184 ".;" to the path to match normal NT path search semantics */
2186 #define EXPAND_BUFFER_SIZE 32767
2188 wapath_val = alloca (EXPAND_BUFFER_SIZE);
2190 wapath_val [0] = '.';
2191 wapath_val [1] = ';';
2193 DWORD res = ExpandEnvironmentStrings
2194 (wpath_val, &wapath_val[2], EXPAND_BUFFER_SIZE - 2);
2196 if (!res) wapath_val [0] = _T('\0');
2198 apath_val = alloca (EXPAND_BUFFER_SIZE);
2200 WS2SU (apath_val, wapath_val, EXPAND_BUFFER_SIZE);
2201 return __gnat_locate_exec (exec_name, apath_val);
2206 char *path_val = "/VAXC$PATH";
2208 char *path_val = getenv ("PATH");
2210 if (path_val == NULL) return NULL;
2211 apath_val = alloca (strlen (path_val) + 1);
2212 strcpy (apath_val, path_val);
2213 return __gnat_locate_exec (exec_name, apath_val);
2219 /* These functions are used to translate to and from VMS and Unix syntax
2220 file, directory and path specifications. */
2223 #define MAXNAMES 256
2224 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2226 static char new_canonical_dirspec [MAXPATH];
2227 static char new_canonical_filespec [MAXPATH];
2228 static char new_canonical_pathspec [MAXNAMES*MAXPATH];
2229 static unsigned new_canonical_filelist_index;
2230 static unsigned new_canonical_filelist_in_use;
2231 static unsigned new_canonical_filelist_allocated;
2232 static char **new_canonical_filelist;
2233 static char new_host_pathspec [MAXNAMES*MAXPATH];
2234 static char new_host_dirspec [MAXPATH];
2235 static char new_host_filespec [MAXPATH];
2237 /* Routine is called repeatedly by decc$from_vms via
2238 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2242 wildcard_translate_unix (char *name)
2245 char buff [MAXPATH];
2247 strncpy (buff, name, MAXPATH);
2248 buff [MAXPATH - 1] = (char) 0;
2249 ver = strrchr (buff, '.');
2251 /* Chop off the version. */
2255 /* Dynamically extend the allocation by the increment. */
2256 if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
2258 new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
2259 new_canonical_filelist = (char **) xrealloc
2260 (new_canonical_filelist,
2261 new_canonical_filelist_allocated * sizeof (char *));
2264 new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
2269 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2270 full translation and copy the results into a list (_init), then return them
2271 one at a time (_next). If onlydirs set, only expand directory files. */
2274 __gnat_to_canonical_file_list_init (char *filespec, int onlydirs)
2277 char buff [MAXPATH];
2279 len = strlen (filespec);
2280 strncpy (buff, filespec, MAXPATH);
2282 /* Only look for directories */
2283 if (onlydirs && !strstr (&buff [len-5], "*.dir"))
2284 strncat (buff, "*.dir", MAXPATH);
2286 buff [MAXPATH - 1] = (char) 0;
2288 decc$from_vms (buff, wildcard_translate_unix, 1);
2290 /* Remove the .dir extension. */
2296 for (i = 0; i < new_canonical_filelist_in_use; i++)
2298 ext = strstr (new_canonical_filelist[i], ".dir");
2304 return new_canonical_filelist_in_use;
2307 /* Return the next filespec in the list. */
2310 __gnat_to_canonical_file_list_next ()
2312 return new_canonical_filelist[new_canonical_filelist_index++];
2315 /* Free storage used in the wildcard expansion. */
2318 __gnat_to_canonical_file_list_free ()
2322 for (i = 0; i < new_canonical_filelist_in_use; i++)
2323 free (new_canonical_filelist[i]);
2325 free (new_canonical_filelist);
2327 new_canonical_filelist_in_use = 0;
2328 new_canonical_filelist_allocated = 0;
2329 new_canonical_filelist_index = 0;
2330 new_canonical_filelist = 0;
2333 /* Translate a VMS syntax directory specification in to Unix syntax. If
2334 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2335 found, return input string. Also translate a dirname that contains no
2336 slashes, in case it's a logical name. */
2339 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag)
2343 strcpy (new_canonical_dirspec, "");
2344 if (strlen (dirspec))
2348 if (strchr (dirspec, ']') || strchr (dirspec, ':'))
2350 strncpy (new_canonical_dirspec,
2351 (char *) decc$translate_vms (dirspec),
2354 else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
2356 strncpy (new_canonical_dirspec,
2357 (char *) decc$translate_vms (dirspec1),
2362 strncpy (new_canonical_dirspec, dirspec, MAXPATH);
2366 len = strlen (new_canonical_dirspec);
2367 if (prefixflag && new_canonical_dirspec [len-1] != '/')
2368 strncat (new_canonical_dirspec, "/", MAXPATH);
2370 new_canonical_dirspec [MAXPATH - 1] = (char) 0;
2372 return new_canonical_dirspec;
2376 /* Translate a VMS syntax file specification into Unix syntax.
2377 If no indicators of VMS syntax found, check if it's an uppercase
2378 alphanumeric_ name and if so try it out as an environment
2379 variable (logical name). If all else fails return the
2383 __gnat_to_canonical_file_spec (char *filespec)
2387 strncpy (new_canonical_filespec, "", MAXPATH);
2389 if (strchr (filespec, ']') || strchr (filespec, ':'))
2391 char *tspec = (char *) decc$translate_vms (filespec);
2393 if (tspec != (char *) -1)
2394 strncpy (new_canonical_filespec, tspec, MAXPATH);
2396 else if ((strlen (filespec) == strspn (filespec,
2397 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
2398 && (filespec1 = getenv (filespec)))
2400 char *tspec = (char *) decc$translate_vms (filespec1);
2402 if (tspec != (char *) -1)
2403 strncpy (new_canonical_filespec, tspec, MAXPATH);
2407 strncpy (new_canonical_filespec, filespec, MAXPATH);
2410 new_canonical_filespec [MAXPATH - 1] = (char) 0;
2412 return new_canonical_filespec;
2415 /* Translate a VMS syntax path specification into Unix syntax.
2416 If no indicators of VMS syntax found, return input string. */
2419 __gnat_to_canonical_path_spec (char *pathspec)
2421 char *curr, *next, buff [MAXPATH];
2426 /* If there are /'s, assume it's a Unix path spec and return. */
2427 if (strchr (pathspec, '/'))
2430 new_canonical_pathspec[0] = 0;
2435 next = strchr (curr, ',');
2437 next = strchr (curr, 0);
2439 strncpy (buff, curr, next - curr);
2440 buff[next - curr] = 0;
2442 /* Check for wildcards and expand if present. */
2443 if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
2447 dirs = __gnat_to_canonical_file_list_init (buff, 1);
2448 for (i = 0; i < dirs; i++)
2452 next_dir = __gnat_to_canonical_file_list_next ();
2453 strncat (new_canonical_pathspec, next_dir, MAXPATH);
2455 /* Don't append the separator after the last expansion. */
2457 strncat (new_canonical_pathspec, ":", MAXPATH);
2460 __gnat_to_canonical_file_list_free ();
2463 strncat (new_canonical_pathspec,
2464 __gnat_to_canonical_dir_spec (buff, 0), MAXPATH);
2469 strncat (new_canonical_pathspec, ":", MAXPATH);
2473 new_canonical_pathspec [MAXPATH - 1] = (char) 0;
2475 return new_canonical_pathspec;
2478 static char filename_buff [MAXPATH];
2481 translate_unix (char *name, int type)
2483 strncpy (filename_buff, name, MAXPATH);
2484 filename_buff [MAXPATH - 1] = (char) 0;
2488 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
2492 to_host_path_spec (char *pathspec)
2494 char *curr, *next, buff [MAXPATH];
2499 /* Can't very well test for colons, since that's the Unix separator! */
2500 if (strchr (pathspec, ']') || strchr (pathspec, ','))
2503 new_host_pathspec[0] = 0;
2508 next = strchr (curr, ':');
2510 next = strchr (curr, 0);
2512 strncpy (buff, curr, next - curr);
2513 buff[next - curr] = 0;
2515 strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH);
2518 strncat (new_host_pathspec, ",", MAXPATH);
2522 new_host_pathspec [MAXPATH - 1] = (char) 0;
2524 return new_host_pathspec;
2527 /* Translate a Unix syntax directory specification into VMS syntax. The
2528 PREFIXFLAG has no effect, but is kept for symmetry with
2529 to_canonical_dir_spec. If indicators of VMS syntax found, return input
2533 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2535 int len = strlen (dirspec);
2537 strncpy (new_host_dirspec, dirspec, MAXPATH);
2538 new_host_dirspec [MAXPATH - 1] = (char) 0;
2540 if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
2541 return new_host_dirspec;
2543 while (len > 1 && new_host_dirspec[len - 1] == '/')
2545 new_host_dirspec[len - 1] = 0;
2549 decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
2550 strncpy (new_host_dirspec, filename_buff, MAXPATH);
2551 new_host_dirspec [MAXPATH - 1] = (char) 0;
2553 return new_host_dirspec;
2556 /* Translate a Unix syntax file specification into VMS syntax.
2557 If indicators of VMS syntax found, return input string. */
2560 __gnat_to_host_file_spec (char *filespec)
2562 strncpy (new_host_filespec, "", MAXPATH);
2563 if (strchr (filespec, ']') || strchr (filespec, ':'))
2565 strncpy (new_host_filespec, filespec, MAXPATH);
2569 decc$to_vms (filespec, translate_unix, 1, 1);
2570 strncpy (new_host_filespec, filename_buff, MAXPATH);
2573 new_host_filespec [MAXPATH - 1] = (char) 0;
2575 return new_host_filespec;
2579 __gnat_adjust_os_resource_limits ()
2581 SYS$ADJWSL (131072, 0);
2586 /* Dummy functions for Osint import for non-VMS systems. */
2589 __gnat_to_canonical_file_list_init
2590 (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED)
2596 __gnat_to_canonical_file_list_next (void)
2602 __gnat_to_canonical_file_list_free (void)
2607 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2613 __gnat_to_canonical_file_spec (char *filespec)
2619 __gnat_to_canonical_path_spec (char *pathspec)
2625 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2631 __gnat_to_host_file_spec (char *filespec)
2637 __gnat_adjust_os_resource_limits (void)
2643 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
2644 to coordinate this with the EMX distribution. Consequently, we put the
2645 definition of dummy which is used for exception handling, here. */
2647 #if defined (__EMX__)
2651 #if defined (__mips_vxworks)
2655 CACHE_USER_FLUSH (0, ENTIRE_CACHE);
2659 #if defined (CROSS_DIRECTORY_STRUCTURE) \
2660 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
2661 && defined (__SVR4)) \
2662 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
2663 && ! (defined (linux) && defined (__ia64__)) \
2664 && ! defined (__FreeBSD__) \
2665 && ! defined (__hpux__) \
2666 && ! defined (__APPLE__) \
2667 && ! defined (_AIX) \
2668 && ! (defined (__alpha__) && defined (__osf__)) \
2669 && ! defined (VMS) \
2670 && ! defined (__MINGW32__) \
2671 && ! (defined (__mips) && defined (__sgi)))
2673 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
2674 just above for a list of native platforms that provide a non-dummy
2675 version of this procedure in libaddr2line.a. */
2678 convert_addresses (const char *file_name ATTRIBUTE_UNUSED,
2679 void *addrs ATTRIBUTE_UNUSED,
2680 int n_addr ATTRIBUTE_UNUSED,
2681 void *buf ATTRIBUTE_UNUSED,
2682 int *len ATTRIBUTE_UNUSED)
2688 #if defined (_WIN32)
2689 int __gnat_argument_needs_quote = 1;
2691 int __gnat_argument_needs_quote = 0;
2694 /* This option is used to enable/disable object files handling from the
2695 binder file by the GNAT Project module. For example, this is disabled on
2696 Windows (prior to GCC 3.4) as it is already done by the mdll module.
2697 Stating with GCC 3.4 the shared libraries are not based on mdll
2698 anymore as it uses the GCC's -shared option */
2699 #if defined (_WIN32) \
2700 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
2701 int __gnat_prj_add_obj_files = 0;
2703 int __gnat_prj_add_obj_files = 1;
2706 /* char used as prefix/suffix for environment variables */
2707 #if defined (_WIN32)
2708 char __gnat_environment_char = '%';
2710 char __gnat_environment_char = '$';
2713 /* This functions copy the file attributes from a source file to a
2716 mode = 0 : In this mode copy only the file time stamps (last access and
2717 last modification time stamps).
2719 mode = 1 : In this mode, time stamps and read/write/execute attributes are
2722 Returns 0 if operation was successful and -1 in case of error. */
2725 __gnat_copy_attribs (char *from, char *to, int mode)
2727 #if defined (VMS) || defined (__vxworks)
2731 struct utimbuf tbuf;
2733 if (stat (from, &fbuf) == -1)
2738 tbuf.actime = fbuf.st_atime;
2739 tbuf.modtime = fbuf.st_mtime;
2741 if (utime (to, &tbuf) == -1)
2748 if (chmod (to, fbuf.st_mode) == -1)
2759 __gnat_lseek (int fd, long offset, int whence)
2761 return (int) lseek (fd, offset, whence);
2764 /* This function returns the major version number of GCC being used. */
2766 get_gcc_version (void)
2771 return (int) (version_string[0] - '0');
2776 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED,
2777 int close_on_exec_p ATTRIBUTE_UNUSED)
2779 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
2780 int flags = fcntl (fd, F_GETFD, 0);
2783 if (close_on_exec_p)
2784 flags |= FD_CLOEXEC;
2786 flags &= ~FD_CLOEXEC;
2787 return fcntl (fd, F_SETFD, flags | FD_CLOEXEC);
2790 /* For the Windows case, we should use SetHandleInformation to remove
2791 the HANDLE_INHERIT property from fd. This is not implemented yet,
2792 but for our purposes (support of GNAT.Expect) this does not matter,
2793 as by default handles are *not* inherited. */
2797 /* Indicates if platforms supports automatic initialization through the
2798 constructor mechanism */
2800 __gnat_binder_supports_auto_init ()
2809 /* Indicates that Stand-Alone Libraries are automatically initialized through
2810 the constructor mechanism */
2812 __gnat_sals_init_using_constructors ()
2814 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)