1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2010, 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 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. *
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. *
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/>. *
27 * GNAT was originally developed by the GNAT team at New York University. *
28 * Extensive contributions were provided by Ada Core Technologies Inc. *
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. */
39 /* No need to redefine exit here. */
42 /* We want to use the POSIX variants of include files. */
46 #if defined (__mips_vxworks)
48 #endif /* __mips_vxworks */
54 #define HOST_EXECUTABLE_SUFFIX ".exe"
55 #define HOST_OBJECT_SUFFIX ".obj"
69 /* We don't have libiberty, so use malloc. */
70 #define xmalloc(S) malloc (S)
71 #define xrealloc(V,S) realloc (V,S)
78 #if defined (__MINGW32__)
86 /* Current code page to use, set in initialize.c. */
90 #include <sys/utime.h>
92 /* For isalpha-like tests in the compiler, we're expected to resort to
93 safe-ctype.h/ISALPHA. This isn't available for the runtime library
94 build, so we fallback on ctype.h/isalpha there. */
98 #define ISALPHA isalpha
101 #elif defined (__Lynx__)
103 /* Lynx utime.h only defines the entities of interest to us if
104 defined (VMOS_DEV), so ... */
113 /* wait.h processing */
116 #include <sys/wait.h>
118 #elif defined (__vxworks) && defined (__RTP__)
120 #elif defined (__Lynx__)
121 /* ??? We really need wait.h and it includes resource.h on Lynx. GCC
122 has a resource.h header as well, included instead of the lynx
123 version in our setup, causing lots of errors. We don't really need
124 the lynx contents of this file, so just workaround the issue by
125 preventing the inclusion of the GCC header from doing anything. */
126 #define GCC_RESOURCE_H
127 #include <sys/wait.h>
128 #elif defined (__nucleus__)
129 /* No wait() or waitpid() calls available */
132 #include <sys/wait.h>
138 /* Header files and definitions for __gnat_set_file_time_name. */
140 #define __NEW_STARLET 1
142 #include <vms/atrdef.h>
143 #include <vms/fibdef.h>
144 #include <vms/stsdef.h>
145 #include <vms/iodef.h>
147 #include <vms/descrip.h>
151 /* Use native 64-bit arithmetic. */
152 #define unix_time_to_vms(X,Y) \
153 { unsigned long long reftime, tmptime = (X); \
154 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
155 SYS$BINTIM (&unixtime, &reftime); \
156 Y = tmptime * 10000000 + reftime; }
158 /* descrip.h doesn't have everything ... */
159 typedef struct fibdef* __fibdef_ptr32 __attribute__ (( mode (SI) ));
160 struct dsc$descriptor_fib
162 unsigned int fib$l_len;
163 __fibdef_ptr32 fib$l_addr;
166 /* I/O Status Block. */
169 unsigned short status, count;
173 static char *tryfile;
175 /* Variable length string. */
179 char string[NAM$C_MAXRSS+1];
197 #define DIR_SEPARATOR '\\'
202 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
203 defined in the current system. On DOS-like systems these flags control
204 whether the file is opened/created in text-translation mode (CR/LF in
205 external file mapped to LF in internal file), but in Unix-like systems,
206 no text translation is required, so these flags have no effect. */
216 #ifndef HOST_EXECUTABLE_SUFFIX
217 #define HOST_EXECUTABLE_SUFFIX ""
220 #ifndef HOST_OBJECT_SUFFIX
221 #define HOST_OBJECT_SUFFIX ".o"
224 #ifndef PATH_SEPARATOR
225 #define PATH_SEPARATOR ':'
228 #ifndef DIR_SEPARATOR
229 #define DIR_SEPARATOR '/'
232 /* Check for cross-compilation */
233 #if defined (CROSS_COMPILE) || defined (CROSS_DIRECTORY_STRUCTURE)
235 int __gnat_is_cross_compiler = 1;
238 int __gnat_is_cross_compiler = 0;
241 char __gnat_dir_separator = DIR_SEPARATOR;
243 char __gnat_path_separator = PATH_SEPARATOR;
245 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
246 the base filenames that libraries specified with -lsomelib options
247 may have. This is used by GNATMAKE to check whether an executable
248 is up-to-date or not. The syntax is
250 library_template ::= { pattern ; } pattern NUL
251 pattern ::= [ prefix ] * [ postfix ]
253 These should only specify names of static libraries as it makes
254 no sense to determine at link time if dynamic-link libraries are
255 up to date or not. Any libraries that are not found are supposed
258 * if they are needed but not present, the link
261 * otherwise they are libraries in the system paths and so
262 they are considered part of the system and not checked
265 ??? This should be part of a GNAT host-specific compiler
266 file instead of being included in all user applications
267 as well. This is only a temporary work-around for 3.11b. */
269 #ifndef GNAT_LIBRARY_TEMPLATE
271 #define GNAT_LIBRARY_TEMPLATE "*.olb"
273 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
277 const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE;
279 /* This variable is used in hostparm.ads to say whether the host is a VMS
282 const int __gnat_vmsp = 1;
284 const int __gnat_vmsp = 0;
288 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
290 #elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__)
291 #define GNAT_MAX_PATH_LEN PATH_MAX
295 #if defined (__MINGW32__)
299 #include <sys/param.h>
303 #include <sys/param.h>
307 #define GNAT_MAX_PATH_LEN MAXPATHLEN
309 #define GNAT_MAX_PATH_LEN 256
314 /* Used for Ada bindings */
315 const int __gnat_size_of_file_attributes = sizeof (struct file_attributes);
317 /* Reset the file attributes as if no system call had been performed */
318 void __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr);
320 /* The __gnat_max_path_len variable is used to export the maximum
321 length of a path name to Ada code. max_path_len is also provided
322 for compatibility with older GNAT versions, please do not use
325 int __gnat_max_path_len = GNAT_MAX_PATH_LEN;
326 int max_path_len = GNAT_MAX_PATH_LEN;
328 /* Control whether we can use ACL on Windows. */
330 int __gnat_use_acl = 1;
332 /* The following macro HAVE_READDIR_R should be defined if the
333 system provides the routine readdir_r. */
334 #undef HAVE_READDIR_R
336 #if defined(VMS) && defined (__LONG_POINTERS)
338 /* Return a 32 bit pointer to an array of 32 bit pointers
339 given a 64 bit pointer to an array of 64 bit pointers */
341 typedef __char_ptr32 *__char_ptr_char_ptr32 __attribute__ ((mode (SI)));
343 static __char_ptr_char_ptr32
344 to_ptr32 (char **ptr64)
347 __char_ptr_char_ptr32 short_argv;
349 for (argc=0; ptr64[argc]; argc++);
351 /* Reallocate argv with 32 bit pointers. */
352 short_argv = (__char_ptr_char_ptr32) decc$malloc
353 (sizeof (__char_ptr32) * (argc + 1));
355 for (argc=0; ptr64[argc]; argc++)
356 short_argv[argc] = (__char_ptr32) decc$strdup (ptr64[argc]);
358 short_argv[argc] = (__char_ptr32) 0;
362 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
364 #define MAYBE_TO_PTR32(argv) argv
367 static const char ATTR_UNSET = 127;
370 __gnat_reset_attributes
371 (struct file_attributes* attr)
373 attr->exists = ATTR_UNSET;
375 attr->writable = ATTR_UNSET;
376 attr->readable = ATTR_UNSET;
377 attr->executable = ATTR_UNSET;
379 attr->regular = ATTR_UNSET;
380 attr->symbolic_link = ATTR_UNSET;
381 attr->directory = ATTR_UNSET;
383 attr->timestamp = (OS_Time)-2;
384 attr->file_length = -1;
391 time_t res = time (NULL);
392 return (OS_Time) res;
395 /* Return the current local time as a string in the ISO 8601 format of
396 "YYYY-MM-DD HH:MM:SS.SS". The returned string is 22 + 1 (NULL) characters
400 __gnat_current_time_string
403 const char *format = "%Y-%m-%d %H:%M:%S";
404 /* Format string necessary to describe the ISO 8601 format */
406 const time_t t_val = time (NULL);
408 strftime (result, 22, format, localtime (&t_val));
409 /* Convert the local time into a string following the ISO format, copying
410 at most 22 characters into the result string. */
415 /* The sub-seconds are manually set to zero since type time_t lacks the
416 precision necessary for nanoseconds. */
430 time_t time = (time_t) *p_time;
433 /* On Windows systems, the time is sometimes rounded up to the nearest
434 even second, so if the number of seconds is odd, increment it. */
440 res = localtime (&time);
442 res = gmtime (&time);
447 *p_year = res->tm_year;
448 *p_month = res->tm_mon;
449 *p_day = res->tm_mday;
450 *p_hours = res->tm_hour;
451 *p_mins = res->tm_min;
452 *p_secs = res->tm_sec;
455 *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0;
458 /* Place the contents of the symbolic link named PATH in the buffer BUF,
459 which has size BUFSIZ. If PATH is a symbolic link, then return the number
460 of characters of its content in BUF. Otherwise, return -1.
461 For systems not supporting symbolic links, always return -1. */
464 __gnat_readlink (char *path ATTRIBUTE_UNUSED,
465 char *buf ATTRIBUTE_UNUSED,
466 size_t bufsiz ATTRIBUTE_UNUSED)
468 #if defined (_WIN32) || defined (VMS) \
469 || defined(__vxworks) || defined (__nucleus__)
472 return readlink (path, buf, bufsiz);
476 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH.
477 If NEWPATH exists it will NOT be overwritten.
478 For systems not supporting symbolic links, always return -1. */
481 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED,
482 char *newpath ATTRIBUTE_UNUSED)
484 #if defined (_WIN32) || defined (VMS) \
485 || defined(__vxworks) || defined (__nucleus__)
488 return symlink (oldpath, newpath);
492 /* Try to lock a file, return 1 if success. */
494 #if defined (__vxworks) || defined (__nucleus__) \
495 || defined (_WIN32) || defined (VMS)
497 /* Version that does not use link. */
500 __gnat_try_lock (char *dir, char *file)
504 TCHAR wfull_path[GNAT_MAX_PATH_LEN];
505 TCHAR wfile[GNAT_MAX_PATH_LEN];
506 TCHAR wdir[GNAT_MAX_PATH_LEN];
508 S2WSC (wdir, dir, GNAT_MAX_PATH_LEN);
509 S2WSC (wfile, file, GNAT_MAX_PATH_LEN);
511 _stprintf (wfull_path, _T("%s%c%s"), wdir, _T(DIR_SEPARATOR), wfile);
512 fd = _topen (wfull_path, O_CREAT | O_EXCL, 0600);
516 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
517 fd = open (full_path, O_CREAT | O_EXCL, 0600);
529 /* Version using link(), more secure over NFS. */
530 /* See TN 6913-016 for discussion ??? */
533 __gnat_try_lock (char *dir, char *file)
537 GNAT_STRUCT_STAT stat_result;
540 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
541 sprintf (temp_file, "%s%cTMP-%ld-%ld",
542 dir, DIR_SEPARATOR, (long)getpid(), (long)getppid ());
544 /* Create the temporary file and write the process number. */
545 fd = open (temp_file, O_CREAT | O_WRONLY, 0600);
551 /* Link it with the new file. */
552 link (temp_file, full_path);
554 /* Count the references on the old one. If we have a count of two, then
555 the link did succeed. Remove the temporary file before returning. */
556 __gnat_stat (temp_file, &stat_result);
558 return stat_result.st_nlink == 2;
562 /* Return the maximum file name length. */
565 __gnat_get_maximum_file_name_length (void)
568 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
577 /* Return nonzero if file names are case sensitive. */
580 __gnat_get_file_names_case_sensitive (void)
582 #if defined (VMS) || defined (WINNT)
590 __gnat_get_default_identifier_character_set (void)
595 /* Return the current working directory. */
598 __gnat_get_current_dir (char *dir, int *length)
600 #if defined (__MINGW32__)
601 TCHAR wdir[GNAT_MAX_PATH_LEN];
603 _tgetcwd (wdir, *length);
605 WS2SC (dir, wdir, GNAT_MAX_PATH_LEN);
608 /* Force Unix style, which is what GNAT uses internally. */
609 getcwd (dir, *length, 0);
611 getcwd (dir, *length);
614 *length = strlen (dir);
616 if (dir [*length - 1] != DIR_SEPARATOR)
618 dir [*length] = DIR_SEPARATOR;
624 /* Return the suffix for object files. */
627 __gnat_get_object_suffix_ptr (int *len, const char **value)
629 *value = HOST_OBJECT_SUFFIX;
634 *len = strlen (*value);
639 /* Return the suffix for executable files. */
642 __gnat_get_executable_suffix_ptr (int *len, const char **value)
644 *value = HOST_EXECUTABLE_SUFFIX;
648 *len = strlen (*value);
653 /* Return the suffix for debuggable files. Usually this is the same as the
654 executable extension. */
657 __gnat_get_debuggable_suffix_ptr (int *len, const char **value)
659 *value = HOST_EXECUTABLE_SUFFIX;
664 *len = strlen (*value);
669 /* Returns the OS filename and corresponding encoding. */
672 __gnat_os_filename (char *filename ATTRIBUTE_UNUSED,
673 char *w_filename ATTRIBUTE_UNUSED,
674 char *os_name, int *o_length,
675 char *encoding ATTRIBUTE_UNUSED, int *e_length)
677 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
678 WS2SC (os_name, (TCHAR *)w_filename, (DWORD)*o_length);
679 *o_length = strlen (os_name);
680 strcpy (encoding, "encoding=utf8");
681 *e_length = strlen (encoding);
683 strcpy (os_name, filename);
684 *o_length = strlen (filename);
692 __gnat_unlink (char *path)
694 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
696 TCHAR wpath[GNAT_MAX_PATH_LEN];
698 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
699 return _tunlink (wpath);
702 return unlink (path);
709 __gnat_rename (char *from, char *to)
711 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
713 TCHAR wfrom[GNAT_MAX_PATH_LEN], wto[GNAT_MAX_PATH_LEN];
715 S2WSC (wfrom, from, GNAT_MAX_PATH_LEN);
716 S2WSC (wto, to, GNAT_MAX_PATH_LEN);
717 return _trename (wfrom, wto);
720 return rename (from, to);
724 /* Changing directory. */
727 __gnat_chdir (char *path)
729 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
731 TCHAR wpath[GNAT_MAX_PATH_LEN];
733 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
734 return _tchdir (wpath);
741 /* Removing a directory. */
744 __gnat_rmdir (char *path)
746 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
748 TCHAR wpath[GNAT_MAX_PATH_LEN];
750 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
751 return _trmdir (wpath);
753 #elif defined (VTHREADS)
754 /* rmdir not available */
762 __gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED)
764 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
765 TCHAR wpath[GNAT_MAX_PATH_LEN];
768 S2WS (wmode, mode, 10);
770 if (encoding == Encoding_Unspecified)
771 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
772 else if (encoding == Encoding_UTF8)
773 S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
775 S2WS (wpath, path, GNAT_MAX_PATH_LEN);
777 return _tfopen (wpath, wmode);
779 return decc$fopen (path, mode);
781 return GNAT_FOPEN (path, mode);
786 __gnat_freopen (char *path, char *mode, FILE *stream, int encoding ATTRIBUTE_UNUSED)
788 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
789 TCHAR wpath[GNAT_MAX_PATH_LEN];
792 S2WS (wmode, mode, 10);
794 if (encoding == Encoding_Unspecified)
795 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
796 else if (encoding == Encoding_UTF8)
797 S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
799 S2WS (wpath, path, GNAT_MAX_PATH_LEN);
801 return _tfreopen (wpath, wmode, stream);
803 return decc$freopen (path, mode, stream);
805 return freopen (path, mode, stream);
810 __gnat_open_read (char *path, int fmode)
813 int o_fmode = O_BINARY;
819 /* Optional arguments mbc,deq,fop increase read performance. */
820 fd = open (path, O_RDONLY | o_fmode, 0444,
821 "mbc=16", "deq=64", "fop=tef");
822 #elif defined (__vxworks)
823 fd = open (path, O_RDONLY | o_fmode, 0444);
824 #elif defined (__MINGW32__)
826 TCHAR wpath[GNAT_MAX_PATH_LEN];
828 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
829 fd = _topen (wpath, O_RDONLY | o_fmode, 0444);
832 fd = open (path, O_RDONLY | o_fmode);
835 return fd < 0 ? -1 : fd;
838 #if defined (__MINGW32__)
839 #define PERM (S_IREAD | S_IWRITE)
841 /* Excerpt from DECC C RTL Reference Manual:
842 To create files with OpenVMS RMS default protections using the UNIX
843 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
844 and open with a file-protection mode argument of 0777 in a program
845 that never specifically calls umask. These default protections include
846 correctly establishing protections based on ACLs, previous versions of
850 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
854 __gnat_open_rw (char *path, int fmode)
857 int o_fmode = O_BINARY;
863 fd = open (path, O_RDWR | o_fmode, PERM,
864 "mbc=16", "deq=64", "fop=tef");
865 #elif defined (__MINGW32__)
867 TCHAR wpath[GNAT_MAX_PATH_LEN];
869 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
870 fd = _topen (wpath, O_RDWR | o_fmode, PERM);
873 fd = open (path, O_RDWR | o_fmode, PERM);
876 return fd < 0 ? -1 : fd;
880 __gnat_open_create (char *path, int fmode)
883 int o_fmode = O_BINARY;
889 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM,
890 "mbc=16", "deq=64", "fop=tef");
891 #elif defined (__MINGW32__)
893 TCHAR wpath[GNAT_MAX_PATH_LEN];
895 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
896 fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
899 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
902 return fd < 0 ? -1 : fd;
906 __gnat_create_output_file (char *path)
910 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM,
911 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
912 "shr=del,get,put,upd");
913 #elif defined (__MINGW32__)
915 TCHAR wpath[GNAT_MAX_PATH_LEN];
917 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
918 fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
921 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
924 return fd < 0 ? -1 : fd;
928 __gnat_create_output_file_new (char *path)
932 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM,
933 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
934 "shr=del,get,put,upd");
935 #elif defined (__MINGW32__)
937 TCHAR wpath[GNAT_MAX_PATH_LEN];
939 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
940 fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM);
943 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM);
946 return fd < 0 ? -1 : fd;
950 __gnat_open_append (char *path, int fmode)
953 int o_fmode = O_BINARY;
959 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM,
960 "mbc=16", "deq=64", "fop=tef");
961 #elif defined (__MINGW32__)
963 TCHAR wpath[GNAT_MAX_PATH_LEN];
965 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
966 fd = _topen (wpath, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
969 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
972 return fd < 0 ? -1 : fd;
975 /* Open a new file. Return error (-1) if the file already exists. */
978 __gnat_open_new (char *path, int fmode)
981 int o_fmode = O_BINARY;
987 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
988 "mbc=16", "deq=64", "fop=tef");
989 #elif defined (__MINGW32__)
991 TCHAR wpath[GNAT_MAX_PATH_LEN];
993 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
994 fd = _topen (wpath, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
997 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
1000 return fd < 0 ? -1 : fd;
1003 /* Open a new temp file. Return error (-1) if the file already exists.
1004 Special options for VMS allow the file to be shared between parent and child
1005 processes, however they really slow down output. Used in gnatchop. */
1008 __gnat_open_new_temp (char *path, int fmode)
1011 int o_fmode = O_BINARY;
1013 strcpy (path, "GNAT-XXXXXX");
1015 #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \
1016 || defined (linux) || defined(__GLIBC__)) && !defined (__vxworks)
1017 return mkstemp (path);
1018 #elif defined (__Lynx__)
1020 #elif defined (__nucleus__)
1023 if (mktemp (path) == NULL)
1031 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
1032 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
1033 "mbc=16", "deq=64", "fop=tef");
1035 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
1038 return fd < 0 ? -1 : fd;
1041 /****************************************************************
1042 ** Perform a call to GNAT_STAT or GNAT_FSTAT, and extract as much information
1043 ** as possible from it, storing the result in a cache for later reuse
1044 ****************************************************************/
1047 __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr)
1049 GNAT_STRUCT_STAT statbuf;
1053 ret = GNAT_FSTAT (fd, &statbuf);
1055 ret = __gnat_stat (name, &statbuf);
1057 attr->regular = (!ret && S_ISREG (statbuf.st_mode));
1058 attr->directory = (!ret && S_ISDIR (statbuf.st_mode));
1061 attr->file_length = 0;
1063 /* st_size may be 32 bits, or 64 bits which is converted to long. We
1064 don't return a useful value for files larger than 2 gigabytes in
1066 attr->file_length = statbuf.st_size; /* all systems */
1069 /* on Windows requires extra system call, see comment in __gnat_file_exists_attr */
1070 attr->exists = !ret;
1073 #if !defined (_WIN32) || defined (RTX)
1074 /* on Windows requires extra system call, see __gnat_is_readable_file_attr */
1075 attr->readable = (!ret && (statbuf.st_mode & S_IRUSR));
1076 attr->writable = (!ret && (statbuf.st_mode & S_IWUSR));
1077 attr->executable = (!ret && (statbuf.st_mode & S_IXUSR));
1080 #if !defined (_WIN32) || defined (RTX)
1081 /* on Windows requires extra system call, see __gnat_file_time_name_attr */
1083 attr->timestamp = (OS_Time)-1;
1086 /* VMS has file versioning. */
1087 attr->timestamp = (OS_Time)statbuf.st_ctime;
1089 attr->timestamp = (OS_Time)statbuf.st_mtime;
1096 /****************************************************************
1097 ** Return the number of bytes in the specified file
1098 ****************************************************************/
1101 __gnat_file_length_attr (int fd, char* name, struct file_attributes* attr)
1103 if (attr->file_length == -1) {
1104 __gnat_stat_to_attr (fd, name, attr);
1107 return attr->file_length;
1111 __gnat_file_length (int fd)
1113 struct file_attributes attr;
1114 __gnat_reset_attributes (&attr);
1115 return __gnat_file_length_attr (fd, NULL, &attr);
1119 __gnat_named_file_length (char *name)
1121 struct file_attributes attr;
1122 __gnat_reset_attributes (&attr);
1123 return __gnat_file_length_attr (-1, name, &attr);
1126 /* Create a temporary filename and put it in string pointed to by
1130 __gnat_tmp_name (char *tmp_filename)
1133 /* Variable used to create a series of unique names */
1134 static int counter = 0;
1136 /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */
1137 strcpy (tmp_filename, "c:\\WINDOWS\\Temp\\gnat-");
1138 sprintf (&tmp_filename[strlen (tmp_filename)], "%d\0", counter++);
1140 #elif defined (__MINGW32__)
1144 /* tempnam tries to create a temporary file in directory pointed to by
1145 TMP environment variable, in c:\temp if TMP is not set, and in
1146 directory specified by P_tmpdir in stdio.h if c:\temp does not
1147 exist. The filename will be created with the prefix "gnat-". */
1149 pname = (char *) tempnam ("c:\\temp", "gnat-");
1151 /* if pname is NULL, the file was not created properly, the disk is full
1152 or there is no more free temporary files */
1155 *tmp_filename = '\0';
1157 /* If pname start with a back slash and not path information it means that
1158 the filename is valid for the current working directory. */
1160 else if (pname[0] == '\\')
1162 strcpy (tmp_filename, ".\\");
1163 strcat (tmp_filename, pname+1);
1166 strcpy (tmp_filename, pname);
1171 #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \
1172 || defined (__OpenBSD__) || defined(__GLIBC__)
1173 #define MAX_SAFE_PATH 1000
1174 char *tmpdir = getenv ("TMPDIR");
1176 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
1177 a buffer overflow. */
1178 if (tmpdir == NULL || strlen (tmpdir) > MAX_SAFE_PATH)
1179 strcpy (tmp_filename, "/tmp/gnat-XXXXXX");
1181 sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
1183 close (mkstemp(tmp_filename));
1185 tmpnam (tmp_filename);
1189 /* Open directory and returns a DIR pointer. */
1191 DIR* __gnat_opendir (char *name)
1194 /* Not supported in RTX */
1198 #elif defined (__MINGW32__)
1199 TCHAR wname[GNAT_MAX_PATH_LEN];
1201 S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1202 return (DIR*)_topendir (wname);
1205 return opendir (name);
1209 /* Read the next entry in a directory. The returned string points somewhere
1213 __gnat_readdir (DIR *dirp, char *buffer, int *len)
1216 /* Not supported in RTX */
1220 #elif defined (__MINGW32__)
1221 struct _tdirent *dirent = _treaddir ((_TDIR*)dirp);
1225 WS2SC (buffer, dirent->d_name, GNAT_MAX_PATH_LEN);
1226 *len = strlen (buffer);
1233 #elif defined (HAVE_READDIR_R)
1234 /* If possible, try to use the thread-safe version. */
1235 if (readdir_r (dirp, buffer) != NULL)
1237 *len = strlen (((struct dirent*) buffer)->d_name);
1238 return ((struct dirent*) buffer)->d_name;
1244 struct dirent *dirent = (struct dirent *) readdir (dirp);
1248 strcpy (buffer, dirent->d_name);
1249 *len = strlen (buffer);
1258 /* Close a directory entry. */
1260 int __gnat_closedir (DIR *dirp)
1263 /* Not supported in RTX */
1267 #elif defined (__MINGW32__)
1268 return _tclosedir ((_TDIR*)dirp);
1271 return closedir (dirp);
1275 /* Returns 1 if readdir is thread safe, 0 otherwise. */
1278 __gnat_readdir_is_thread_safe (void)
1280 #ifdef HAVE_READDIR_R
1287 #if defined (_WIN32) && !defined (RTX)
1288 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
1289 static const unsigned long long w32_epoch_offset = 11644473600ULL;
1291 /* Returns the file modification timestamp using Win32 routines which are
1292 immune against daylight saving time change. It is in fact not possible to
1293 use fstat for this purpose as the DST modify the st_mtime field of the
1297 win32_filetime (HANDLE h)
1302 unsigned long long ull_time;
1305 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1306 since <Jan 1st 1601>. This function must return the number of seconds
1307 since <Jan 1st 1970>. */
1309 if (GetFileTime (h, NULL, NULL, &t_write.ft_time))
1310 return (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset);
1315 /* Return a GNAT time stamp given a file name. */
1318 __gnat_file_time_name_attr (char* name, struct file_attributes* attr)
1320 if (attr->timestamp == (OS_Time)-2) {
1321 #if defined (_WIN32) && !defined (RTX)
1323 TCHAR wname[GNAT_MAX_PATH_LEN];
1324 S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1326 HANDLE h = CreateFile
1327 (wname, GENERIC_READ, FILE_SHARE_READ, 0,
1328 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
1330 if (h != INVALID_HANDLE_VALUE) {
1331 ret = win32_filetime (h);
1334 attr->timestamp = (OS_Time) ret;
1336 __gnat_stat_to_attr (-1, name, attr);
1339 return attr->timestamp;
1343 __gnat_file_time_name (char *name)
1345 struct file_attributes attr;
1346 __gnat_reset_attributes (&attr);
1347 return __gnat_file_time_name_attr (name, &attr);
1350 /* Return a GNAT time stamp given a file descriptor. */
1353 __gnat_file_time_fd_attr (int fd, struct file_attributes* attr)
1355 if (attr->timestamp == (OS_Time)-2) {
1356 #if defined (_WIN32) && !defined (RTX)
1357 HANDLE h = (HANDLE) _get_osfhandle (fd);
1358 time_t ret = win32_filetime (h);
1359 attr->timestamp = (OS_Time) ret;
1362 __gnat_stat_to_attr (fd, NULL, attr);
1366 return attr->timestamp;
1370 __gnat_file_time_fd (int fd)
1372 struct file_attributes attr;
1373 __gnat_reset_attributes (&attr);
1374 return __gnat_file_time_fd_attr (fd, &attr);
1377 /* Set the file time stamp. */
1380 __gnat_set_file_time_name (char *name, time_t time_stamp)
1382 #if defined (__vxworks)
1384 /* Code to implement __gnat_set_file_time_name for these systems. */
1386 #elif defined (_WIN32) && !defined (RTX)
1390 unsigned long long ull_time;
1392 TCHAR wname[GNAT_MAX_PATH_LEN];
1394 S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1396 HANDLE h = CreateFile
1397 (wname, GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
1398 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS,
1400 if (h == INVALID_HANDLE_VALUE)
1402 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1403 t_write.ull_time = ((unsigned long long)time_stamp + w32_epoch_offset);
1404 /* Convert to 100 nanosecond units */
1405 t_write.ull_time *= 10000000ULL;
1407 SetFileTime(h, NULL, NULL, &t_write.ft_time);
1417 unsigned long long backup, create, expire, revise;
1421 unsigned short value;
1424 unsigned system : 4;
1430 } Fat = { 0, 0, 0, 0, 0, { 0 }};
1434 { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create },
1435 { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise },
1436 { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire },
1437 { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup },
1438 { ATR$S_FPRO, ATR$C_FPRO, &Fat.prot },
1439 { ATR$S_UIC, ATR$C_UIC, &Fat.uic },
1444 struct dsc$descriptor_fib fibdsc = {sizeof (fib), (void *) &fib};
1448 unsigned long long newtime;
1449 unsigned long long revtime;
1453 struct vstring file;
1454 struct dsc$descriptor_s filedsc
1455 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) file.string};
1456 struct vstring device;
1457 struct dsc$descriptor_s devicedsc
1458 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) device.string};
1459 struct vstring timev;
1460 struct dsc$descriptor_s timedsc
1461 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) timev.string};
1462 struct vstring result;
1463 struct dsc$descriptor_s resultdsc
1464 = {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string};
1466 /* Convert parameter name (a file spec) to host file form. Note that this
1467 is needed on VMS to prepare for subsequent calls to VMS RMS library
1468 routines. Note that it would not work to call __gnat_to_host_dir_spec
1469 as was done in a previous version, since this fails silently unless
1470 the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1471 (directory not found) condition is signalled. */
1472 tryfile = (char *) __gnat_to_host_file_spec (name);
1474 /* Allocate and initialize a FAB and NAM structures. */
1478 nam.nam$l_esa = file.string;
1479 nam.nam$b_ess = NAM$C_MAXRSS;
1480 nam.nam$l_rsa = result.string;
1481 nam.nam$b_rss = NAM$C_MAXRSS;
1482 fab.fab$l_fna = tryfile;
1483 fab.fab$b_fns = strlen (tryfile);
1484 fab.fab$l_nam = &nam;
1486 /* Validate filespec syntax and device existence. */
1487 status = SYS$PARSE (&fab, 0, 0);
1488 if ((status & 1) != 1)
1489 LIB$SIGNAL (status);
1491 file.string[nam.nam$b_esl] = 0;
1493 /* Find matching filespec. */
1494 status = SYS$SEARCH (&fab, 0, 0);
1495 if ((status & 1) != 1)
1496 LIB$SIGNAL (status);
1498 file.string[nam.nam$b_esl] = 0;
1499 result.string[result.length=nam.nam$b_rsl] = 0;
1501 /* Get the device name and assign an IO channel. */
1502 strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev);
1503 devicedsc.dsc$w_length = nam.nam$b_dev;
1505 status = SYS$ASSIGN (&devicedsc, &chan, 0, 0, 0);
1506 if ((status & 1) != 1)
1507 LIB$SIGNAL (status);
1509 /* Initialize the FIB and fill in the directory id field. */
1510 memset (&fib, 0, sizeof (fib));
1511 fib.fib$w_did[0] = nam.nam$w_did[0];
1512 fib.fib$w_did[1] = nam.nam$w_did[1];
1513 fib.fib$w_did[2] = nam.nam$w_did[2];
1514 fib.fib$l_acctl = 0;
1516 strcpy (file.string, (strrchr (result.string, ']') + 1));
1517 filedsc.dsc$w_length = strlen (file.string);
1518 result.string[result.length = 0] = 0;
1520 /* Open and close the file to fill in the attributes. */
1522 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1523 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1524 if ((status & 1) != 1)
1525 LIB$SIGNAL (status);
1526 if ((iosb.status & 1) != 1)
1527 LIB$SIGNAL (iosb.status);
1529 result.string[result.length] = 0;
1530 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, &fibdsc, 0, 0, 0,
1532 if ((status & 1) != 1)
1533 LIB$SIGNAL (status);
1534 if ((iosb.status & 1) != 1)
1535 LIB$SIGNAL (iosb.status);
1540 /* Set creation time to requested time. */
1541 unix_time_to_vms (time_stamp, newtime);
1543 t = time ((time_t) 0);
1545 /* Set revision time to now in local time. */
1546 unix_time_to_vms (t, revtime);
1549 /* Reopen the file, modify the times and then close. */
1550 fib.fib$l_acctl = FIB$M_WRITE;
1552 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1553 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1554 if ((status & 1) != 1)
1555 LIB$SIGNAL (status);
1556 if ((iosb.status & 1) != 1)
1557 LIB$SIGNAL (iosb.status);
1559 Fat.create = newtime;
1560 Fat.revise = revtime;
1562 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0,
1563 &fibdsc, 0, 0, 0, &atrlst, 0);
1564 if ((status & 1) != 1)
1565 LIB$SIGNAL (status);
1566 if ((iosb.status & 1) != 1)
1567 LIB$SIGNAL (iosb.status);
1569 /* Deassign the channel and exit. */
1570 status = SYS$DASSGN (chan);
1571 if ((status & 1) != 1)
1572 LIB$SIGNAL (status);
1574 struct utimbuf utimbuf;
1577 /* Set modification time to requested time. */
1578 utimbuf.modtime = time_stamp;
1580 /* Set access time to now in local time. */
1581 t = time ((time_t) 0);
1582 utimbuf.actime = mktime (localtime (&t));
1584 utime (name, &utimbuf);
1588 /* Get the list of installed standard libraries from the
1589 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1593 __gnat_get_libraries_from_registry (void)
1595 char *result = (char *) xmalloc (1);
1599 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) \
1603 DWORD name_size, value_size;
1610 /* First open the key. */
1611 res = RegOpenKeyExA (HKEY_LOCAL_MACHINE, "SOFTWARE", 0, KEY_READ, ®_key);
1613 if (res == ERROR_SUCCESS)
1614 res = RegOpenKeyExA (reg_key, "Ada Core Technologies", 0,
1615 KEY_READ, ®_key);
1617 if (res == ERROR_SUCCESS)
1618 res = RegOpenKeyExA (reg_key, "GNAT", 0, KEY_READ, ®_key);
1620 if (res == ERROR_SUCCESS)
1621 res = RegOpenKeyExA (reg_key, "Standard Libraries", 0, KEY_READ, ®_key);
1623 /* If the key exists, read out all the values in it and concatenate them
1625 for (index = 0; res == ERROR_SUCCESS; index++)
1627 value_size = name_size = 256;
1628 res = RegEnumValueA (reg_key, index, name, &name_size, 0,
1629 &type, (LPBYTE)value, &value_size);
1631 if (res == ERROR_SUCCESS && type == REG_SZ)
1633 char *old_result = result;
1635 result = (char *) xmalloc (strlen (old_result) + value_size + 2);
1636 strcpy (result, old_result);
1637 strcat (result, value);
1638 strcat (result, ";");
1643 /* Remove the trailing ";". */
1645 result[strlen (result) - 1] = 0;
1652 __gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf)
1655 /* Under Windows the directory name for the stat function must not be
1656 terminated by a directory separator except if just after a drive name
1657 or with UNC path without directory (only the name of the shared
1658 resource), for example: \\computer\share\ */
1660 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1663 int dirsep_count = 0;
1665 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
1666 name_len = _tcslen (wname);
1668 if (name_len > GNAT_MAX_PATH_LEN)
1671 last_char = wname[name_len - 1];
1673 while (name_len > 1 && (last_char == _T('\\') || last_char == _T('/')))
1675 wname[name_len - 1] = _T('\0');
1677 last_char = wname[name_len - 1];
1680 /* Count back-slashes. */
1682 for (k=0; k<name_len; k++)
1683 if (wname[k] == _T('\\') || wname[k] == _T('/'))
1686 /* Only a drive letter followed by ':', we must add a directory separator
1687 for the stat routine to work properly. */
1688 if ((name_len == 2 && wname[1] == _T(':'))
1689 || (name_len > 3 && wname[0] == _T('\\') && wname[1] == _T('\\')
1690 && dirsep_count == 3))
1691 _tcscat (wname, _T("\\"));
1693 return _tstat (wname, (struct _stat *)statbuf);
1696 return GNAT_STAT (name, statbuf);
1700 /*************************************************************************
1701 ** Check whether a file exists
1702 *************************************************************************/
1705 __gnat_file_exists_attr (char* name, struct file_attributes* attr)
1707 if (attr->exists == ATTR_UNSET) {
1709 /* On Windows do not use __gnat_stat() because of a bug in Microsoft
1710 _stat() routine. When the system time-zone is set with a negative
1711 offset the _stat() routine fails on specific files like CON: */
1712 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1713 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
1714 attr->exists = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES;
1716 __gnat_stat_to_attr (-1, name, attr);
1720 return attr->exists;
1724 __gnat_file_exists (char *name)
1726 struct file_attributes attr;
1727 __gnat_reset_attributes (&attr);
1728 return __gnat_file_exists_attr (name, &attr);
1731 /**********************************************************************
1732 ** Whether name is an absolute path
1733 **********************************************************************/
1736 __gnat_is_absolute_path (char *name, int length)
1739 /* On VxWorks systems, an absolute path can be represented (depending on
1740 the host platform) as either /dir/file, or device:/dir/file, or
1741 device:drive_letter:/dir/file. */
1748 for (index = 0; index < length; index++)
1750 if (name[index] == ':' &&
1751 ((name[index + 1] == '/') ||
1752 (isalpha (name[index + 1]) && index + 2 <= length &&
1753 name[index + 2] == '/')))
1756 else if (name[index] == '/')
1761 return (length != 0) &&
1762 (*name == '/' || *name == DIR_SEPARATOR
1764 || (length > 1 && ISALPHA (name[0]) && name[1] == ':')
1771 __gnat_is_regular_file_attr (char* name, struct file_attributes* attr)
1773 if (attr->regular == ATTR_UNSET) {
1774 __gnat_stat_to_attr (-1, name, attr);
1777 return attr->regular;
1781 __gnat_is_regular_file (char *name)
1783 struct file_attributes attr;
1784 __gnat_reset_attributes (&attr);
1785 return __gnat_is_regular_file_attr (name, &attr);
1789 __gnat_is_directory_attr (char* name, struct file_attributes* attr)
1791 if (attr->directory == ATTR_UNSET) {
1792 __gnat_stat_to_attr (-1, name, attr);
1795 return attr->directory;
1799 __gnat_is_directory (char *name)
1801 struct file_attributes attr;
1802 __gnat_reset_attributes (&attr);
1803 return __gnat_is_directory_attr (name, &attr);
1806 #if defined (_WIN32) && !defined (RTX)
1808 /* Returns the same constant as GetDriveType but takes a pathname as
1812 GetDriveTypeFromPath (TCHAR *wfullpath)
1814 TCHAR wdrv[MAX_PATH];
1815 TCHAR wpath[MAX_PATH];
1816 TCHAR wfilename[MAX_PATH];
1817 TCHAR wext[MAX_PATH];
1819 _tsplitpath (wfullpath, wdrv, wpath, wfilename, wext);
1821 if (_tcslen (wdrv) != 0)
1823 /* we have a drive specified. */
1824 _tcscat (wdrv, _T("\\"));
1825 return GetDriveType (wdrv);
1829 /* No drive specified. */
1831 /* Is this a relative path, if so get current drive type. */
1832 if (wpath[0] != _T('\\') ||
1833 (_tcslen (wpath) > 2 && wpath[0] == _T('\\') && wpath[1] != _T('\\')))
1834 return GetDriveType (NULL);
1836 UINT result = GetDriveType (wpath);
1838 /* Cannot guess the drive type, is this \\.\ ? */
1840 if (result == DRIVE_NO_ROOT_DIR &&
1841 _tcslen (wpath) >= 4 && wpath[0] == _T('\\') && wpath[1] == _T('\\')
1842 && wpath[2] == _T('.') && wpath[3] == _T('\\'))
1844 if (_tcslen (wpath) == 4)
1845 _tcscat (wpath, wfilename);
1847 LPTSTR p = &wpath[4];
1848 LPTSTR b = _tcschr (p, _T('\\'));
1851 { /* logical drive \\.\c\dir\file */
1857 _tcscat (p, _T(":\\"));
1859 return GetDriveType (p);
1866 /* This MingW section contains code to work with ACL. */
1868 __gnat_check_OWNER_ACL
1870 DWORD CheckAccessDesired,
1871 GENERIC_MAPPING CheckGenericMapping)
1873 DWORD dwAccessDesired, dwAccessAllowed;
1874 PRIVILEGE_SET PrivilegeSet;
1875 DWORD dwPrivSetSize = sizeof (PRIVILEGE_SET);
1876 BOOL fAccessGranted = FALSE;
1877 HANDLE hToken = NULL;
1879 SECURITY_DESCRIPTOR* pSD = NULL;
1882 (wname, OWNER_SECURITY_INFORMATION |
1883 GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION,
1886 if ((pSD = (PSECURITY_DESCRIPTOR) HeapAlloc
1887 (GetProcessHeap (), HEAP_ZERO_MEMORY, nLength)) == NULL)
1890 /* Obtain the security descriptor. */
1892 if (!GetFileSecurity
1893 (wname, OWNER_SECURITY_INFORMATION |
1894 GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION,
1895 pSD, nLength, &nLength))
1898 if (!ImpersonateSelf (SecurityImpersonation))
1901 if (!OpenThreadToken
1902 (GetCurrentThread(), TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken))
1905 /* Undoes the effect of ImpersonateSelf. */
1909 /* We want to test for write permissions. */
1911 dwAccessDesired = CheckAccessDesired;
1913 MapGenericMask (&dwAccessDesired, &CheckGenericMapping);
1916 (pSD , /* security descriptor to check */
1917 hToken, /* impersonation token */
1918 dwAccessDesired, /* requested access rights */
1919 &CheckGenericMapping, /* pointer to GENERIC_MAPPING */
1920 &PrivilegeSet, /* receives privileges used in check */
1921 &dwPrivSetSize, /* size of PrivilegeSet buffer */
1922 &dwAccessAllowed, /* receives mask of allowed access rights */
1926 CloseHandle (hToken);
1927 HeapFree (GetProcessHeap (), 0, pSD);
1928 return fAccessGranted;
1932 CloseHandle (hToken);
1933 HeapFree (GetProcessHeap (), 0, pSD);
1938 __gnat_set_OWNER_ACL
1941 DWORD AccessPermissions)
1943 PACL pOldDACL = NULL;
1944 PACL pNewDACL = NULL;
1945 PSECURITY_DESCRIPTOR pSD = NULL;
1947 TCHAR username [100];
1950 /* Get current user, he will act as the owner */
1952 if (!GetUserName (username, &unsize))
1955 if (GetNamedSecurityInfo
1958 DACL_SECURITY_INFORMATION,
1959 NULL, NULL, &pOldDACL, NULL, &pSD) != ERROR_SUCCESS)
1962 BuildExplicitAccessWithName
1963 (&ea, username, AccessPermissions, AccessMode, NO_INHERITANCE);
1965 if (AccessMode == SET_ACCESS)
1967 /* SET_ACCESS, we want to set an explicte set of permissions, do not
1968 merge with current DACL. */
1969 if (SetEntriesInAcl (1, &ea, NULL, &pNewDACL) != ERROR_SUCCESS)
1973 if (SetEntriesInAcl (1, &ea, pOldDACL, &pNewDACL) != ERROR_SUCCESS)
1976 if (SetNamedSecurityInfo
1977 (wname, SE_FILE_OBJECT,
1978 DACL_SECURITY_INFORMATION, NULL, NULL, pNewDACL, NULL) != ERROR_SUCCESS)
1982 LocalFree (pNewDACL);
1985 /* Check if it is possible to use ACL for wname, the file must not be on a
1989 __gnat_can_use_acl (TCHAR *wname)
1991 return __gnat_use_acl && GetDriveTypeFromPath (wname) != DRIVE_REMOTE;
1994 #endif /* defined (_WIN32) && !defined (RTX) */
1997 __gnat_is_readable_file_attr (char* name, struct file_attributes* attr)
1999 if (attr->readable == ATTR_UNSET) {
2000 #if defined (_WIN32) && !defined (RTX)
2001 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2002 GENERIC_MAPPING GenericMapping;
2004 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2006 if (__gnat_can_use_acl (wname))
2008 ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
2009 GenericMapping.GenericRead = GENERIC_READ;
2010 attr->readable = __gnat_check_OWNER_ACL (wname, FILE_READ_DATA, GenericMapping);
2013 attr->readable = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES;
2015 __gnat_stat_to_attr (-1, name, attr);
2019 return attr->readable;
2023 __gnat_is_readable_file (char *name)
2025 struct file_attributes attr;
2026 __gnat_reset_attributes (&attr);
2027 return __gnat_is_readable_file_attr (name, &attr);
2031 __gnat_is_writable_file_attr (char* name, struct file_attributes* attr)
2033 if (attr->writable == ATTR_UNSET) {
2034 #if defined (_WIN32) && !defined (RTX)
2035 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2036 GENERIC_MAPPING GenericMapping;
2038 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2040 if (__gnat_can_use_acl (wname))
2042 ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
2043 GenericMapping.GenericWrite = GENERIC_WRITE;
2045 attr->writable = __gnat_check_OWNER_ACL
2046 (wname, FILE_WRITE_DATA | FILE_APPEND_DATA, GenericMapping)
2047 && !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY);
2050 attr->writable = !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY);
2053 __gnat_stat_to_attr (-1, name, attr);
2057 return attr->writable;
2061 __gnat_is_writable_file (char *name)
2063 struct file_attributes attr;
2064 __gnat_reset_attributes (&attr);
2065 return __gnat_is_writable_file_attr (name, &attr);
2069 __gnat_is_executable_file_attr (char* name, struct file_attributes* attr)
2071 if (attr->executable == ATTR_UNSET) {
2072 #if defined (_WIN32) && !defined (RTX)
2073 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2074 GENERIC_MAPPING GenericMapping;
2076 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2078 if (__gnat_can_use_acl (wname))
2080 ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
2081 GenericMapping.GenericExecute = GENERIC_EXECUTE;
2083 attr->executable = __gnat_check_OWNER_ACL (wname, FILE_EXECUTE, GenericMapping);
2086 attr->executable = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES
2087 && _tcsstr (wname, _T(".exe")) - wname == (int) (_tcslen (wname) - 4);
2089 __gnat_stat_to_attr (-1, name, attr);
2093 return attr->executable;
2097 __gnat_is_executable_file (char *name)
2099 struct file_attributes attr;
2100 __gnat_reset_attributes (&attr);
2101 return __gnat_is_executable_file_attr (name, &attr);
2105 __gnat_set_writable (char *name)
2107 #if defined (_WIN32) && !defined (RTX)
2108 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2110 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2112 if (__gnat_can_use_acl (wname))
2113 __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_WRITE);
2116 (wname, GetFileAttributes (wname) & ~FILE_ATTRIBUTE_READONLY);
2117 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2118 GNAT_STRUCT_STAT statbuf;
2120 if (GNAT_STAT (name, &statbuf) == 0)
2122 statbuf.st_mode = statbuf.st_mode | S_IWUSR;
2123 chmod (name, statbuf.st_mode);
2129 __gnat_set_executable (char *name)
2131 #if defined (_WIN32) && !defined (RTX)
2132 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2134 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2136 if (__gnat_can_use_acl (wname))
2137 __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_EXECUTE);
2139 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2140 GNAT_STRUCT_STAT statbuf;
2142 if (GNAT_STAT (name, &statbuf) == 0)
2144 statbuf.st_mode = statbuf.st_mode | S_IXUSR;
2145 chmod (name, statbuf.st_mode);
2151 __gnat_set_non_writable (char *name)
2153 #if defined (_WIN32) && !defined (RTX)
2154 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2156 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2158 if (__gnat_can_use_acl (wname))
2159 __gnat_set_OWNER_ACL
2160 (wname, DENY_ACCESS,
2161 FILE_WRITE_DATA | FILE_APPEND_DATA |
2162 FILE_WRITE_EA | FILE_WRITE_ATTRIBUTES);
2165 (wname, GetFileAttributes (wname) | FILE_ATTRIBUTE_READONLY);
2166 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2167 GNAT_STRUCT_STAT statbuf;
2169 if (GNAT_STAT (name, &statbuf) == 0)
2171 statbuf.st_mode = statbuf.st_mode & 07577;
2172 chmod (name, statbuf.st_mode);
2178 __gnat_set_readable (char *name)
2180 #if defined (_WIN32) && !defined (RTX)
2181 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2183 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2185 if (__gnat_can_use_acl (wname))
2186 __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_READ);
2188 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2189 GNAT_STRUCT_STAT statbuf;
2191 if (GNAT_STAT (name, &statbuf) == 0)
2193 chmod (name, statbuf.st_mode | S_IREAD);
2199 __gnat_set_non_readable (char *name)
2201 #if defined (_WIN32) && !defined (RTX)
2202 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2204 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2206 if (__gnat_can_use_acl (wname))
2207 __gnat_set_OWNER_ACL (wname, DENY_ACCESS, FILE_GENERIC_READ);
2209 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2210 GNAT_STRUCT_STAT statbuf;
2212 if (GNAT_STAT (name, &statbuf) == 0)
2214 chmod (name, statbuf.st_mode & (~S_IREAD));
2220 __gnat_is_symbolic_link_attr (char* name, struct file_attributes* attr)
2222 if (attr->symbolic_link == ATTR_UNSET) {
2223 #if defined (__vxworks) || defined (__nucleus__)
2224 attr->symbolic_link = 0;
2226 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
2228 GNAT_STRUCT_STAT statbuf;
2229 ret = GNAT_LSTAT (name, &statbuf);
2230 attr->symbolic_link = (!ret && S_ISLNK (statbuf.st_mode));
2232 attr->symbolic_link = 0;
2235 return attr->symbolic_link;
2239 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED)
2241 struct file_attributes attr;
2242 __gnat_reset_attributes (&attr);
2243 return __gnat_is_symbolic_link_attr (name, &attr);
2247 #if defined (sun) && defined (__SVR4)
2248 /* Using fork on Solaris will duplicate all the threads. fork1, which
2249 duplicates only the active thread, must be used instead, or spawning
2250 subprocess from a program with tasking will lead into numerous problems. */
2255 __gnat_portable_spawn (char *args[])
2258 int finished ATTRIBUTE_UNUSED;
2259 int pid ATTRIBUTE_UNUSED;
2261 #if defined (__vxworks) || defined(__nucleus__) || defined(RTX)
2264 #elif defined (_WIN32)
2265 /* args[0] must be quotes as it could contain a full pathname with spaces */
2266 char *args_0 = args[0];
2267 args[0] = (char *)xmalloc (strlen (args_0) + 3);
2268 strcpy (args[0], "\"");
2269 strcat (args[0], args_0);
2270 strcat (args[0], "\"");
2272 status = spawnvp (P_WAIT, args_0, (const char* const*)args);
2274 /* restore previous value */
2276 args[0] = (char *)args_0;
2292 if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
2294 return -1; /* execv is in parent context on VMS. */
2301 finished = waitpid (pid, &status, 0);
2303 if (finished != pid || WIFEXITED (status) == 0)
2306 return WEXITSTATUS (status);
2312 /* Create a copy of the given file descriptor.
2313 Return -1 if an error occurred. */
2316 __gnat_dup (int oldfd)
2318 #if defined (__vxworks) && !defined (__RTP__)
2319 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2327 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
2328 Return -1 if an error occurred. */
2331 __gnat_dup2 (int oldfd, int newfd)
2333 #if defined (__vxworks) && !defined (__RTP__)
2334 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2338 return dup2 (oldfd, newfd);
2342 /* WIN32 code to implement a wait call that wait for any child process. */
2344 #if defined (_WIN32) && !defined (RTX)
2346 /* Synchronization code, to be thread safe. */
2350 /* For the Cert run times on native Windows we use dummy functions
2351 for locking and unlocking tasks since we do not support multiple
2352 threads on this configuration (Cert run time on native Windows). */
2354 void dummy (void) {}
2356 void (*Lock_Task) () = &dummy;
2357 void (*Unlock_Task) () = &dummy;
2361 #define Lock_Task system__soft_links__lock_task
2362 extern void (*Lock_Task) (void);
2364 #define Unlock_Task system__soft_links__unlock_task
2365 extern void (*Unlock_Task) (void);
2369 static HANDLE *HANDLES_LIST = NULL;
2370 static int *PID_LIST = NULL, plist_length = 0, plist_max_length = 0;
2373 add_handle (HANDLE h, int pid)
2376 /* -------------------- critical section -------------------- */
2379 if (plist_length == plist_max_length)
2381 plist_max_length += 1000;
2383 xrealloc (HANDLES_LIST, sizeof (HANDLE) * plist_max_length);
2385 xrealloc (PID_LIST, sizeof (int) * plist_max_length);
2388 HANDLES_LIST[plist_length] = h;
2389 PID_LIST[plist_length] = pid;
2393 /* -------------------- critical section -------------------- */
2397 __gnat_win32_remove_handle (HANDLE h, int pid)
2401 /* -------------------- critical section -------------------- */
2404 for (j = 0; j < plist_length; j++)
2406 if ((HANDLES_LIST[j] == h) || (PID_LIST[j] == pid))
2410 HANDLES_LIST[j] = HANDLES_LIST[plist_length];
2411 PID_LIST[j] = PID_LIST[plist_length];
2417 /* -------------------- critical section -------------------- */
2421 win32_no_block_spawn (char *command, char *args[], HANDLE *h, int *pid)
2425 PROCESS_INFORMATION PI;
2426 SECURITY_ATTRIBUTES SA;
2431 /* compute the total command line length */
2435 csize += strlen (args[k]) + 1;
2439 full_command = (char *) xmalloc (csize);
2442 SI.cb = sizeof (STARTUPINFO);
2443 SI.lpReserved = NULL;
2444 SI.lpReserved2 = NULL;
2445 SI.lpDesktop = NULL;
2449 SI.wShowWindow = SW_HIDE;
2451 /* Security attributes. */
2452 SA.nLength = sizeof (SECURITY_ATTRIBUTES);
2453 SA.bInheritHandle = TRUE;
2454 SA.lpSecurityDescriptor = NULL;
2456 /* Prepare the command string. */
2457 strcpy (full_command, command);
2458 strcat (full_command, " ");
2463 strcat (full_command, args[k]);
2464 strcat (full_command, " ");
2469 int wsize = csize * 2;
2470 TCHAR *wcommand = (TCHAR *) xmalloc (wsize);
2472 S2WSC (wcommand, full_command, wsize);
2474 free (full_command);
2476 result = CreateProcess
2477 (NULL, wcommand, &SA, NULL, TRUE,
2478 GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
2485 CloseHandle (PI.hThread);
2487 *pid = PI.dwProcessId;
2497 win32_wait (int *status)
2499 DWORD exitcode, pid;
2506 if (plist_length == 0)
2514 /* -------------------- critical section -------------------- */
2517 hl_len = plist_length;
2519 hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len);
2521 memmove (hl, HANDLES_LIST, sizeof (HANDLE) * hl_len);
2524 /* -------------------- critical section -------------------- */
2526 res = WaitForMultipleObjects (hl_len, hl, FALSE, INFINITE);
2527 h = hl[res - WAIT_OBJECT_0];
2529 GetExitCodeProcess (h, &exitcode);
2530 pid = PID_LIST [res - WAIT_OBJECT_0];
2531 __gnat_win32_remove_handle (h, -1);
2535 *status = (int) exitcode;
2542 __gnat_portable_no_block_spawn (char *args[])
2545 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2548 #elif defined (_WIN32)
2553 win32_no_block_spawn (args[0], args, &h, &pid);
2556 add_handle (h, pid);
2569 if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
2571 return -1; /* execv is in parent context on VMS. */
2583 __gnat_portable_wait (int *process_status)
2588 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2589 /* Not sure what to do here, so do nothing but return zero. */
2591 #elif defined (_WIN32)
2593 pid = win32_wait (&status);
2597 pid = waitpid (-1, &status, 0);
2598 status = status & 0xffff;
2601 *process_status = status;
2606 __gnat_os_exit (int status)
2611 /* Locate a regular file, give a Path value. */
2614 __gnat_locate_regular_file (char *file_name, char *path_val)
2617 char *file_path = (char *) alloca (strlen (file_name) + 1);
2620 /* Return immediately if file_name is empty */
2622 if (*file_name == '\0')
2625 /* Remove quotes around file_name if present */
2631 strcpy (file_path, ptr);
2633 ptr = file_path + strlen (file_path) - 1;
2638 /* Handle absolute pathnames. */
2640 absolute = __gnat_is_absolute_path (file_path, strlen (file_name));
2644 if (__gnat_is_regular_file (file_path))
2645 return xstrdup (file_path);
2650 /* If file_name include directory separator(s), try it first as
2651 a path name relative to the current directory */
2652 for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
2657 if (__gnat_is_regular_file (file_name))
2658 return xstrdup (file_name);
2665 /* The result has to be smaller than path_val + file_name. */
2666 char *file_path = (char *) alloca (strlen (path_val) + strlen (file_name) + 2);
2670 /* Skip the starting quote */
2672 if (*path_val == '"')
2675 for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
2676 *ptr++ = *path_val++;
2678 /* If directory is empty, it is the current directory*/
2680 if (ptr == file_path)
2687 /* Skip the ending quote */
2692 if (*ptr != '/' && *ptr != DIR_SEPARATOR)
2693 *++ptr = DIR_SEPARATOR;
2695 strcpy (++ptr, file_name);
2697 if (__gnat_is_regular_file (file_path))
2698 return xstrdup (file_path);
2703 /* Skip path separator */
2712 /* Locate an executable given a Path argument. This routine is only used by
2713 gnatbl and should not be used otherwise. Use locate_exec_on_path
2717 __gnat_locate_exec (char *exec_name, char *path_val)
2720 if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
2722 char *full_exec_name
2723 = (char *) alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
2725 strcpy (full_exec_name, exec_name);
2726 strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
2727 ptr = __gnat_locate_regular_file (full_exec_name, path_val);
2730 return __gnat_locate_regular_file (exec_name, path_val);
2734 return __gnat_locate_regular_file (exec_name, path_val);
2737 /* Locate an executable using the Systems default PATH. */
2740 __gnat_locate_exec_on_path (char *exec_name)
2744 #if defined (_WIN32) && !defined (RTX)
2745 TCHAR *wpath_val = _tgetenv (_T("PATH"));
2747 /* In Win32 systems we expand the PATH as for XP environment
2748 variables are not automatically expanded. We also prepend the
2749 ".;" to the path to match normal NT path search semantics */
2751 #define EXPAND_BUFFER_SIZE 32767
2753 wapath_val = alloca (EXPAND_BUFFER_SIZE);
2755 wapath_val [0] = '.';
2756 wapath_val [1] = ';';
2758 DWORD res = ExpandEnvironmentStrings
2759 (wpath_val, &wapath_val[2], EXPAND_BUFFER_SIZE - 2);
2761 if (!res) wapath_val [0] = _T('\0');
2763 apath_val = alloca (EXPAND_BUFFER_SIZE);
2765 WS2SC (apath_val, wapath_val, EXPAND_BUFFER_SIZE);
2766 return __gnat_locate_exec (exec_name, apath_val);
2771 char *path_val = "/VAXC$PATH";
2773 char *path_val = getenv ("PATH");
2775 if (path_val == NULL) return NULL;
2776 apath_val = (char *) alloca (strlen (path_val) + 1);
2777 strcpy (apath_val, path_val);
2778 return __gnat_locate_exec (exec_name, apath_val);
2784 /* These functions are used to translate to and from VMS and Unix syntax
2785 file, directory and path specifications. */
2788 #define MAXNAMES 256
2789 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2791 static char new_canonical_dirspec [MAXPATH];
2792 static char new_canonical_filespec [MAXPATH];
2793 static char new_canonical_pathspec [MAXNAMES*MAXPATH];
2794 static unsigned new_canonical_filelist_index;
2795 static unsigned new_canonical_filelist_in_use;
2796 static unsigned new_canonical_filelist_allocated;
2797 static char **new_canonical_filelist;
2798 static char new_host_pathspec [MAXNAMES*MAXPATH];
2799 static char new_host_dirspec [MAXPATH];
2800 static char new_host_filespec [MAXPATH];
2802 /* Routine is called repeatedly by decc$from_vms via
2803 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2807 wildcard_translate_unix (char *name)
2810 char buff [MAXPATH];
2812 strncpy (buff, name, MAXPATH);
2813 buff [MAXPATH - 1] = (char) 0;
2814 ver = strrchr (buff, '.');
2816 /* Chop off the version. */
2820 /* Dynamically extend the allocation by the increment. */
2821 if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
2823 new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
2824 new_canonical_filelist = (char **) xrealloc
2825 (new_canonical_filelist,
2826 new_canonical_filelist_allocated * sizeof (char *));
2829 new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
2834 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2835 full translation and copy the results into a list (_init), then return them
2836 one at a time (_next). If onlydirs set, only expand directory files. */
2839 __gnat_to_canonical_file_list_init (char *filespec, int onlydirs)
2842 char buff [MAXPATH];
2844 len = strlen (filespec);
2845 strncpy (buff, filespec, MAXPATH);
2847 /* Only look for directories */
2848 if (onlydirs && !strstr (&buff [len-5], "*.dir"))
2849 strncat (buff, "*.dir", MAXPATH);
2851 buff [MAXPATH - 1] = (char) 0;
2853 decc$from_vms (buff, wildcard_translate_unix, 1);
2855 /* Remove the .dir extension. */
2861 for (i = 0; i < new_canonical_filelist_in_use; i++)
2863 ext = strstr (new_canonical_filelist[i], ".dir");
2869 return new_canonical_filelist_in_use;
2872 /* Return the next filespec in the list. */
2875 __gnat_to_canonical_file_list_next ()
2877 return new_canonical_filelist[new_canonical_filelist_index++];
2880 /* Free storage used in the wildcard expansion. */
2883 __gnat_to_canonical_file_list_free ()
2887 for (i = 0; i < new_canonical_filelist_in_use; i++)
2888 free (new_canonical_filelist[i]);
2890 free (new_canonical_filelist);
2892 new_canonical_filelist_in_use = 0;
2893 new_canonical_filelist_allocated = 0;
2894 new_canonical_filelist_index = 0;
2895 new_canonical_filelist = 0;
2898 /* The functional equivalent of decc$translate_vms routine.
2899 Designed to produce the same output, but is protected against
2900 malformed paths (original version ACCVIOs in this case) and
2901 does not require VMS-specific DECC RTL */
2903 #define NAM$C_MAXRSS 1024
2906 __gnat_translate_vms (char *src)
2908 static char retbuf [NAM$C_MAXRSS+1];
2909 char *srcendpos, *pos1, *pos2, *retpos;
2910 int disp, path_present = 0;
2912 if (!src) return NULL;
2914 srcendpos = strchr (src, '\0');
2917 /* Look for the node and/or device in front of the path */
2919 pos2 = strchr (pos1, ':');
2921 if (pos2 && (pos2 < srcendpos) && (*(pos2 + 1) == ':')) {
2922 /* There is a node name. "node_name::" becomes "node_name!" */
2924 strncpy (retbuf, pos1, disp);
2925 retpos [disp] = '!';
2926 retpos = retpos + disp + 1;
2928 pos2 = strchr (pos1, ':');
2932 /* There is a device name. "dev_name:" becomes "/dev_name/" */
2935 strncpy (retpos, pos1, disp);
2936 retpos = retpos + disp;
2941 /* No explicit device; we must look ahead and prepend /sys$disk/ if
2942 the path is absolute */
2943 if ((*pos1 == '[' || *pos1 == '<') && (pos1 < srcendpos)
2944 && !strchr (".-]>", *(pos1 + 1))) {
2945 strncpy (retpos, "/sys$disk/", 10);
2949 /* Process the path part */
2950 while (*pos1 == '[' || *pos1 == '<') {
2953 if (*pos1 == ']' || *pos1 == '>') {
2954 /* Special case, [] translates to '.' */
2959 /* '[000000' means root dir. It can be present in the middle of
2960 the path due to expansion of logical devices, in which case
2962 if (!strncmp (pos1, "000000", 6) && path_present > 1 &&
2963 (*(pos1 + 6) == ']' || *(pos1 + 6) == '>' || *(pos1 + 6) == '.')) {
2965 if (*pos1 == '.') pos1++;
2967 else if (*pos1 == '.') {
2972 /* There is a qualified path */
2973 while (*pos1 && *pos1 != ']' && *pos1 != '>') {
2976 /* '.' is used to separate directories. Replace it with '/' but
2977 only if there isn't already '/' just before */
2978 if (*(retpos - 1) != '/') *(retpos++) = '/';
2980 if (pos1 + 1 < srcendpos && *pos1 == '.' && *(pos1 + 1) == '.') {
2981 /* ellipsis refers to entire subtree; replace with '**' */
2982 *(retpos++) = '*'; *(retpos++) = '*'; *(retpos++) = '/';
2987 /* When after '.' '[' '<' is equivalent to Unix ".." but there
2988 may be several in a row */
2989 if (*(pos1 - 1) == '.' || *(pos1 - 1) == '[' ||
2990 *(pos1 - 1) == '<') {
2991 while (*pos1 == '-') {
2993 *(retpos++) = '.'; *(retpos++) = '.'; *(retpos++) = '/';
2998 /* otherwise fall through to default */
3000 *(retpos++) = *(pos1++);
3007 if (pos1 < srcendpos) {
3008 /* Now add the actual file name, until the version suffix if any */
3009 if (path_present) *(retpos++) = '/';
3010 pos2 = strchr (pos1, ';');
3011 disp = pos2? (pos2 - pos1) : (srcendpos - pos1);
3012 strncpy (retpos, pos1, disp);
3014 if (pos2 && pos2 < srcendpos) {
3015 /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
3017 disp = srcendpos - pos2 - 1;
3018 strncpy (retpos, pos2 + 1, disp);
3029 /* Translate a VMS syntax directory specification in to Unix syntax. If
3030 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
3031 found, return input string. Also translate a dirname that contains no
3032 slashes, in case it's a logical name. */
3035 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag)
3039 strcpy (new_canonical_dirspec, "");
3040 if (strlen (dirspec))
3044 if (strchr (dirspec, ']') || strchr (dirspec, ':'))
3046 strncpy (new_canonical_dirspec,
3047 __gnat_translate_vms (dirspec),
3050 else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
3052 strncpy (new_canonical_dirspec,
3053 __gnat_translate_vms (dirspec1),
3058 strncpy (new_canonical_dirspec, dirspec, MAXPATH);
3062 len = strlen (new_canonical_dirspec);
3063 if (prefixflag && new_canonical_dirspec [len-1] != '/')
3064 strncat (new_canonical_dirspec, "/", MAXPATH);
3066 new_canonical_dirspec [MAXPATH - 1] = (char) 0;
3068 return new_canonical_dirspec;
3072 /* Translate a VMS syntax file specification into Unix syntax.
3073 If no indicators of VMS syntax found, check if it's an uppercase
3074 alphanumeric_ name and if so try it out as an environment
3075 variable (logical name). If all else fails return the
3079 __gnat_to_canonical_file_spec (char *filespec)
3083 strncpy (new_canonical_filespec, "", MAXPATH);
3085 if (strchr (filespec, ']') || strchr (filespec, ':'))
3087 char *tspec = (char *) __gnat_translate_vms (filespec);
3089 if (tspec != (char *) -1)
3090 strncpy (new_canonical_filespec, tspec, MAXPATH);
3092 else if ((strlen (filespec) == strspn (filespec,
3093 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
3094 && (filespec1 = getenv (filespec)))
3096 char *tspec = (char *) __gnat_translate_vms (filespec1);
3098 if (tspec != (char *) -1)
3099 strncpy (new_canonical_filespec, tspec, MAXPATH);
3103 strncpy (new_canonical_filespec, filespec, MAXPATH);
3106 new_canonical_filespec [MAXPATH - 1] = (char) 0;
3108 return new_canonical_filespec;
3111 /* Translate a VMS syntax path specification into Unix syntax.
3112 If no indicators of VMS syntax found, return input string. */
3115 __gnat_to_canonical_path_spec (char *pathspec)
3117 char *curr, *next, buff [MAXPATH];
3122 /* If there are /'s, assume it's a Unix path spec and return. */
3123 if (strchr (pathspec, '/'))
3126 new_canonical_pathspec[0] = 0;
3131 next = strchr (curr, ',');
3133 next = strchr (curr, 0);
3135 strncpy (buff, curr, next - curr);
3136 buff[next - curr] = 0;
3138 /* Check for wildcards and expand if present. */
3139 if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
3143 dirs = __gnat_to_canonical_file_list_init (buff, 1);
3144 for (i = 0; i < dirs; i++)
3148 next_dir = __gnat_to_canonical_file_list_next ();
3149 strncat (new_canonical_pathspec, next_dir, MAXPATH);
3151 /* Don't append the separator after the last expansion. */
3153 strncat (new_canonical_pathspec, ":", MAXPATH);
3156 __gnat_to_canonical_file_list_free ();
3159 strncat (new_canonical_pathspec,
3160 __gnat_to_canonical_dir_spec (buff, 0), MAXPATH);
3165 strncat (new_canonical_pathspec, ":", MAXPATH);
3169 new_canonical_pathspec [MAXPATH - 1] = (char) 0;
3171 return new_canonical_pathspec;
3174 static char filename_buff [MAXPATH];
3177 translate_unix (char *name, int type)
3179 strncpy (filename_buff, name, MAXPATH);
3180 filename_buff [MAXPATH - 1] = (char) 0;
3184 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
3188 to_host_path_spec (char *pathspec)
3190 char *curr, *next, buff [MAXPATH];
3195 /* Can't very well test for colons, since that's the Unix separator! */
3196 if (strchr (pathspec, ']') || strchr (pathspec, ','))
3199 new_host_pathspec[0] = 0;
3204 next = strchr (curr, ':');
3206 next = strchr (curr, 0);
3208 strncpy (buff, curr, next - curr);
3209 buff[next - curr] = 0;
3211 strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH);
3214 strncat (new_host_pathspec, ",", MAXPATH);
3218 new_host_pathspec [MAXPATH - 1] = (char) 0;
3220 return new_host_pathspec;
3223 /* Translate a Unix syntax directory specification into VMS syntax. The
3224 PREFIXFLAG has no effect, but is kept for symmetry with
3225 to_canonical_dir_spec. If indicators of VMS syntax found, return input
3229 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3231 int len = strlen (dirspec);
3233 strncpy (new_host_dirspec, dirspec, MAXPATH);
3234 new_host_dirspec [MAXPATH - 1] = (char) 0;
3236 if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
3237 return new_host_dirspec;
3239 while (len > 1 && new_host_dirspec[len - 1] == '/')
3241 new_host_dirspec[len - 1] = 0;
3245 decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
3246 strncpy (new_host_dirspec, filename_buff, MAXPATH);
3247 new_host_dirspec [MAXPATH - 1] = (char) 0;
3249 return new_host_dirspec;
3252 /* Translate a Unix syntax file specification into VMS syntax.
3253 If indicators of VMS syntax found, return input string. */
3256 __gnat_to_host_file_spec (char *filespec)
3258 strncpy (new_host_filespec, "", MAXPATH);
3259 if (strchr (filespec, ']') || strchr (filespec, ':'))
3261 strncpy (new_host_filespec, filespec, MAXPATH);
3265 decc$to_vms (filespec, translate_unix, 1, 1);
3266 strncpy (new_host_filespec, filename_buff, MAXPATH);
3269 new_host_filespec [MAXPATH - 1] = (char) 0;
3271 return new_host_filespec;
3275 __gnat_adjust_os_resource_limits ()
3277 SYS$ADJWSL (131072, 0);
3282 /* Dummy functions for Osint import for non-VMS systems. */
3285 __gnat_to_canonical_file_list_init
3286 (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED)
3292 __gnat_to_canonical_file_list_next (void)
3294 static char *empty = "";
3299 __gnat_to_canonical_file_list_free (void)
3304 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3310 __gnat_to_canonical_file_spec (char *filespec)
3316 __gnat_to_canonical_path_spec (char *pathspec)
3322 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3328 __gnat_to_host_file_spec (char *filespec)
3334 __gnat_adjust_os_resource_limits (void)
3340 #if defined (__mips_vxworks)
3344 CACHE_USER_FLUSH (0, ENTIRE_CACHE);
3348 #if defined (IS_CROSS) \
3349 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3350 && defined (__SVR4)) \
3351 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3352 && ! (defined (linux) && defined (__ia64__)) \
3353 && ! (defined (linux) && defined (powerpc)) \
3354 && ! defined (__FreeBSD__) \
3355 && ! defined (__Lynx__) \
3356 && ! defined (__hpux__) \
3357 && ! defined (__APPLE__) \
3358 && ! defined (_AIX) \
3359 && ! (defined (__alpha__) && defined (__osf__)) \
3360 && ! defined (VMS) \
3361 && ! defined (__MINGW32__) \
3362 && ! (defined (__mips) && defined (__sgi)))
3364 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3365 just above for a list of native platforms that provide a non-dummy
3366 version of this procedure in libaddr2line.a. */
3369 convert_addresses (const char *file_name ATTRIBUTE_UNUSED,
3370 void *addrs ATTRIBUTE_UNUSED,
3371 int n_addr ATTRIBUTE_UNUSED,
3372 void *buf ATTRIBUTE_UNUSED,
3373 int *len ATTRIBUTE_UNUSED)
3379 #if defined (_WIN32)
3380 int __gnat_argument_needs_quote = 1;
3382 int __gnat_argument_needs_quote = 0;
3385 /* This option is used to enable/disable object files handling from the
3386 binder file by the GNAT Project module. For example, this is disabled on
3387 Windows (prior to GCC 3.4) as it is already done by the mdll module.
3388 Stating with GCC 3.4 the shared libraries are not based on mdll
3389 anymore as it uses the GCC's -shared option */
3390 #if defined (_WIN32) \
3391 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3392 int __gnat_prj_add_obj_files = 0;
3394 int __gnat_prj_add_obj_files = 1;
3397 /* char used as prefix/suffix for environment variables */
3398 #if defined (_WIN32)
3399 char __gnat_environment_char = '%';
3401 char __gnat_environment_char = '$';
3404 /* This functions copy the file attributes from a source file to a
3407 mode = 0 : In this mode copy only the file time stamps (last access and
3408 last modification time stamps).
3410 mode = 1 : In this mode, time stamps and read/write/execute attributes are
3413 Returns 0 if operation was successful and -1 in case of error. */
3416 __gnat_copy_attribs (char *from, char *to, int mode)
3418 #if defined (VMS) || defined (__vxworks) || defined (__nucleus__)
3421 #elif defined (_WIN32) && !defined (RTX)
3422 TCHAR wfrom [GNAT_MAX_PATH_LEN + 2];
3423 TCHAR wto [GNAT_MAX_PATH_LEN + 2];
3425 FILETIME fct, flat, flwt;
3428 S2WSC (wfrom, from, GNAT_MAX_PATH_LEN + 2);
3429 S2WSC (wto, to, GNAT_MAX_PATH_LEN + 2);
3431 /* retrieve from times */
3434 (wfrom, GENERIC_READ, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
3436 if (hfrom == INVALID_HANDLE_VALUE)
3439 res = GetFileTime (hfrom, &fct, &flat, &flwt);
3441 CloseHandle (hfrom);
3446 /* retrieve from times */
3449 (wto, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
3451 if (hto == INVALID_HANDLE_VALUE)
3454 res = SetFileTime (hto, NULL, &flat, &flwt);
3461 /* Set file attributes in full mode. */
3465 DWORD attribs = GetFileAttributes (wfrom);
3467 if (attribs == INVALID_FILE_ATTRIBUTES)
3470 res = SetFileAttributes (wto, attribs);
3478 GNAT_STRUCT_STAT fbuf;
3479 struct utimbuf tbuf;
3481 if (GNAT_STAT (from, &fbuf) == -1)
3486 tbuf.actime = fbuf.st_atime;
3487 tbuf.modtime = fbuf.st_mtime;
3489 if (utime (to, &tbuf) == -1)
3496 if (chmod (to, fbuf.st_mode) == -1)
3507 __gnat_lseek (int fd, long offset, int whence)
3509 return (int) lseek (fd, offset, whence);
3512 /* This function returns the major version number of GCC being used. */
3514 get_gcc_version (void)
3519 return (int) (version_string[0] - '0');
3524 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED,
3525 int close_on_exec_p ATTRIBUTE_UNUSED)
3527 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3528 int flags = fcntl (fd, F_GETFD, 0);
3531 if (close_on_exec_p)
3532 flags |= FD_CLOEXEC;
3534 flags &= ~FD_CLOEXEC;
3535 return fcntl (fd, F_SETFD, flags | FD_CLOEXEC);
3536 #elif defined(_WIN32)
3537 HANDLE h = (HANDLE) _get_osfhandle (fd);
3538 if (h == (HANDLE) -1)
3540 if (close_on_exec_p)
3541 return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT, 0);
3542 return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT,
3543 HANDLE_FLAG_INHERIT);
3545 /* TODO: Unimplemented. */
3550 /* Indicates if platforms supports automatic initialization through the
3551 constructor mechanism */
3553 __gnat_binder_supports_auto_init (void)
3562 /* Indicates that Stand-Alone Libraries are automatically initialized through
3563 the constructor mechanism */
3565 __gnat_sals_init_using_constructors (void)
3567 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3576 /* In RTX mode, the procedure to get the time (as file time) is different
3577 in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3578 we introduce an intermediate procedure to link against the corresponding
3579 one in each situation. */
3581 extern void GetTimeAsFileTime(LPFILETIME pTime);
3583 void GetTimeAsFileTime(LPFILETIME pTime)
3586 RtGetRtssTimeAsFileTime (pTime); /* RTSS interface */
3588 GetSystemTimeAsFileTime (pTime); /* w32 interface */
3593 /* Add symbol that is required to link. It would otherwise be taken from
3594 libgcc.a and it would try to use the gcc constructors that are not
3595 supported by Microsoft linker. */
3597 extern void __main (void);
3599 void __main (void) {}
3603 #if defined (linux) || defined(__GLIBC__)
3604 /* pthread affinity support */
3606 int __gnat_pthread_setaffinity_np (pthread_t th,
3608 const void *cpuset);
3611 #include <pthread.h>
3613 __gnat_pthread_setaffinity_np (pthread_t th,
3615 const cpu_set_t *cpuset)
3617 return pthread_setaffinity_np (th, cpusetsize, cpuset);
3621 __gnat_pthread_setaffinity_np (pthread_t th ATTRIBUTE_UNUSED,
3622 size_t cpusetsize ATTRIBUTE_UNUSED,
3623 const void *cpuset ATTRIBUTE_UNUSED)
3631 /* There is no function in the glibc to retrieve the LWP of the current
3632 thread. We need to do a system call in order to retrieve this
3634 #include <sys/syscall.h>
3635 void *__gnat_lwp_self (void)
3637 return (void *) syscall (__NR_gettid);