1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2005, 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, 59 Temple Place - Suite 330, Boston, *
20 * MA 02111-1307, 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)
80 #include <sys/utime.h>
96 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
99 /* Header files and definitions for __gnat_set_file_time_name. */
102 #include <vms/atrdef.h>
103 #include <vms/fibdef.h>
104 #include <vms/stsdef.h>
105 #include <vms/iodef.h>
107 #include <vms/descrip.h>
111 /* Use native 64-bit arithmetic. */
112 #define unix_time_to_vms(X,Y) \
113 { unsigned long long reftime, tmptime = (X); \
114 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
115 SYS$BINTIM (&unixtime, &reftime); \
116 Y = tmptime * 10000000 + reftime; }
118 /* descrip.h doesn't have everything ... */
119 struct dsc$descriptor_fib
121 unsigned long fib$l_len;
122 struct fibdef *fib$l_addr;
125 /* I/O Status Block. */
128 unsigned short status, count;
129 unsigned long devdep;
132 static char *tryfile;
134 /* Variable length string. */
138 char string[NAM$C_MAXRSS+1];
145 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
153 #define DIR_SEPARATOR '\\'
158 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
159 defined in the current system. On DOS-like systems these flags control
160 whether the file is opened/created in text-translation mode (CR/LF in
161 external file mapped to LF in internal file), but in Unix-like systems,
162 no text translation is required, so these flags have no effect. */
164 #if defined (__EMX__)
180 #ifndef HOST_EXECUTABLE_SUFFIX
181 #define HOST_EXECUTABLE_SUFFIX ""
184 #ifndef HOST_OBJECT_SUFFIX
185 #define HOST_OBJECT_SUFFIX ".o"
188 #ifndef PATH_SEPARATOR
189 #define PATH_SEPARATOR ':'
192 #ifndef DIR_SEPARATOR
193 #define DIR_SEPARATOR '/'
196 char __gnat_dir_separator = DIR_SEPARATOR;
198 char __gnat_path_separator = PATH_SEPARATOR;
200 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
201 the base filenames that libraries specified with -lsomelib options
202 may have. This is used by GNATMAKE to check whether an executable
203 is up-to-date or not. The syntax is
205 library_template ::= { pattern ; } pattern NUL
206 pattern ::= [ prefix ] * [ postfix ]
208 These should only specify names of static libraries as it makes
209 no sense to determine at link time if dynamic-link libraries are
210 up to date or not. Any libraries that are not found are supposed
213 * if they are needed but not present, the link
216 * otherwise they are libraries in the system paths and so
217 they are considered part of the system and not checked
220 ??? This should be part of a GNAT host-specific compiler
221 file instead of being included in all user applications
222 as well. This is only a temporary work-around for 3.11b. */
224 #ifndef GNAT_LIBRARY_TEMPLATE
225 #if defined (__EMX__)
226 #define GNAT_LIBRARY_TEMPLATE "*.a"
228 #define GNAT_LIBRARY_TEMPLATE "*.olb"
230 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
234 const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE;
236 /* This variable is used in hostparm.ads to say whether the host is a VMS
239 const int __gnat_vmsp = 1;
241 const int __gnat_vmsp = 0;
245 #define GNAT_MAX_PATH_LEN MAX_PATH
248 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
250 #elif defined (__vxworks) || defined (__OPENNT)
251 #define GNAT_MAX_PATH_LEN PATH_MAX
255 #if defined (__MINGW32__)
259 #include <sys/param.h>
263 #include <sys/param.h>
266 #define GNAT_MAX_PATH_LEN MAXPATHLEN
270 /* The __gnat_max_path_len variable is used to export the maximum
271 length of a path name to Ada code. max_path_len is also provided
272 for compatibility with older GNAT versions, please do not use
275 int __gnat_max_path_len = GNAT_MAX_PATH_LEN;
276 int max_path_len = GNAT_MAX_PATH_LEN;
278 /* The following macro HAVE_READDIR_R should be defined if the
279 system provides the routine readdir_r. */
280 #undef HAVE_READDIR_R
282 #if defined(VMS) && defined (__LONG_POINTERS)
284 /* Return a 32 bit pointer to an array of 32 bit pointers
285 given a 64 bit pointer to an array of 64 bit pointers */
287 typedef __char_ptr32 *__char_ptr_char_ptr32 __attribute__ ((mode (SI)));
289 static __char_ptr_char_ptr32
290 to_ptr32 (char **ptr64)
293 __char_ptr_char_ptr32 short_argv;
295 for (argc=0; ptr64[argc]; argc++);
297 /* Reallocate argv with 32 bit pointers. */
298 short_argv = (__char_ptr_char_ptr32) decc$malloc
299 (sizeof (__char_ptr32) * (argc + 1));
301 for (argc=0; ptr64[argc]; argc++)
302 short_argv[argc] = (__char_ptr32) decc$strdup (ptr64[argc]);
304 short_argv[argc] = (__char_ptr32) 0;
308 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
310 #define MAYBE_TO_PTR32(argv) argv
324 time_t time = (time_t) *p_time;
327 /* On Windows systems, the time is sometimes rounded up to the nearest
328 even second, so if the number of seconds is odd, increment it. */
334 res = localtime (&time);
336 res = gmtime (&time);
341 *p_year = res->tm_year;
342 *p_month = res->tm_mon;
343 *p_day = res->tm_mday;
344 *p_hours = res->tm_hour;
345 *p_mins = res->tm_min;
346 *p_secs = res->tm_sec;
349 *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0;
352 /* Place the contents of the symbolic link named PATH in the buffer BUF,
353 which has size BUFSIZ. If PATH is a symbolic link, then return the number
354 of characters of its content in BUF. Otherwise, return -1. For Windows,
355 OS/2 and vxworks, always return -1. */
358 __gnat_readlink (char *path ATTRIBUTE_UNUSED,
359 char *buf ATTRIBUTE_UNUSED,
360 size_t bufsiz ATTRIBUTE_UNUSED)
362 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
364 #elif defined (__INTERIX) || defined (VMS)
366 #elif defined (__vxworks)
369 return readlink (path, buf, bufsiz);
373 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH. If
374 NEWPATH exists it will NOT be overwritten. For Windows, OS/2, VxWorks,
375 Interix and VMS, always return -1. */
378 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED,
379 char *newpath ATTRIBUTE_UNUSED)
381 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
383 #elif defined (__INTERIX) || defined (VMS)
385 #elif defined (__vxworks)
388 return symlink (oldpath, newpath);
392 /* Try to lock a file, return 1 if success. */
394 #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32)
396 /* Version that does not use link. */
399 __gnat_try_lock (char *dir, char *file)
404 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
405 fd = open (full_path, O_CREAT | O_EXCL, 0600);
413 #elif defined (__EMX__) || defined (VMS)
415 /* More cases that do not use link; identical code, to solve too long
419 __gnat_try_lock (char *dir, char *file)
424 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
425 fd = open (full_path, O_CREAT | O_EXCL, 0600);
435 /* Version using link(), more secure over NFS. */
436 /* See TN 6913-016 for discussion ??? */
439 __gnat_try_lock (char *dir, char *file)
443 struct stat stat_result;
446 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
447 sprintf (temp_file, "%s%cTMP-%ld-%ld",
448 dir, DIR_SEPARATOR, (long)getpid(), (long)getppid ());
450 /* Create the temporary file and write the process number. */
451 fd = open (temp_file, O_CREAT | O_WRONLY, 0600);
457 /* Link it with the new file. */
458 link (temp_file, full_path);
460 /* Count the references on the old one. If we have a count of two, then
461 the link did succeed. Remove the temporary file before returning. */
462 __gnat_stat (temp_file, &stat_result);
464 return stat_result.st_nlink == 2;
468 /* Return the maximum file name length. */
471 __gnat_get_maximum_file_name_length (void)
476 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
485 /* Return nonzero if file names are case sensitive. */
488 __gnat_get_file_names_case_sensitive (void)
490 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT)
498 __gnat_get_default_identifier_character_set (void)
500 #if defined (__EMX__) || defined (MSDOS)
507 /* Return the current working directory. */
510 __gnat_get_current_dir (char *dir, int *length)
513 /* Force Unix style, which is what GNAT uses internally. */
514 getcwd (dir, *length, 0);
516 getcwd (dir, *length);
519 *length = strlen (dir);
521 if (dir [*length - 1] != DIR_SEPARATOR)
523 dir [*length] = DIR_SEPARATOR;
529 /* Return the suffix for object files. */
532 __gnat_get_object_suffix_ptr (int *len, const char **value)
534 *value = HOST_OBJECT_SUFFIX;
539 *len = strlen (*value);
544 /* Return the suffix for executable files. */
547 __gnat_get_executable_suffix_ptr (int *len, const char **value)
549 *value = HOST_EXECUTABLE_SUFFIX;
553 *len = strlen (*value);
558 /* Return the suffix for debuggable files. Usually this is the same as the
559 executable extension. */
562 __gnat_get_debuggable_suffix_ptr (int *len, const char **value)
565 *value = HOST_EXECUTABLE_SUFFIX;
567 /* On DOS, the extensionless COFF file is what gdb likes. */
574 *len = strlen (*value);
580 __gnat_open_read (char *path, int fmode)
583 int o_fmode = O_BINARY;
589 /* Optional arguments mbc,deq,fop increase read performance. */
590 fd = open (path, O_RDONLY | o_fmode, 0444,
591 "mbc=16", "deq=64", "fop=tef");
592 #elif defined (__vxworks)
593 fd = open (path, O_RDONLY | o_fmode, 0444);
595 fd = open (path, O_RDONLY | o_fmode);
598 return fd < 0 ? -1 : fd;
601 #if defined (__EMX__) || defined (__MINGW32__)
602 #define PERM (S_IREAD | S_IWRITE)
604 /* Excerpt from DECC C RTL Reference Manual:
605 To create files with OpenVMS RMS default protections using the UNIX
606 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
607 and open with a file-protection mode argument of 0777 in a program
608 that never specifically calls umask. These default protections include
609 correctly establishing protections based on ACLs, previous versions of
613 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
617 __gnat_open_rw (char *path, int fmode)
620 int o_fmode = O_BINARY;
626 fd = open (path, O_RDWR | o_fmode, PERM,
627 "mbc=16", "deq=64", "fop=tef");
629 fd = open (path, O_RDWR | o_fmode, PERM);
632 return fd < 0 ? -1 : fd;
636 __gnat_open_create (char *path, int fmode)
639 int o_fmode = O_BINARY;
645 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM,
646 "mbc=16", "deq=64", "fop=tef");
648 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
651 return fd < 0 ? -1 : fd;
655 __gnat_create_output_file (char *path)
659 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM,
660 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
661 "shr=del,get,put,upd");
663 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
666 return fd < 0 ? -1 : fd;
670 __gnat_open_append (char *path, int fmode)
673 int o_fmode = O_BINARY;
679 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM,
680 "mbc=16", "deq=64", "fop=tef");
682 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
685 return fd < 0 ? -1 : fd;
688 /* Open a new file. Return error (-1) if the file already exists. */
691 __gnat_open_new (char *path, int fmode)
694 int o_fmode = O_BINARY;
700 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
701 "mbc=16", "deq=64", "fop=tef");
703 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
706 return fd < 0 ? -1 : fd;
709 /* Open a new temp file. Return error (-1) if the file already exists.
710 Special options for VMS allow the file to be shared between parent and child
711 processes, however they really slow down output. Used in gnatchop. */
714 __gnat_open_new_temp (char *path, int fmode)
717 int o_fmode = O_BINARY;
719 strcpy (path, "GNAT-XXXXXX");
721 #if (defined (__FreeBSD__) || defined (linux)) && !defined (__vxworks)
722 return mkstemp (path);
723 #elif defined (__Lynx__)
726 if (mktemp (path) == NULL)
734 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
735 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
736 "mbc=16", "deq=64", "fop=tef");
738 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
741 return fd < 0 ? -1 : fd;
744 /* Return the number of bytes in the specified file. */
747 __gnat_file_length (int fd)
752 ret = fstat (fd, &statbuf);
753 if (ret || !S_ISREG (statbuf.st_mode))
756 return (statbuf.st_size);
759 /* Return the number of bytes in the specified named file. */
762 __gnat_named_file_length (char *name)
767 ret = __gnat_stat (name, &statbuf);
768 if (ret || !S_ISREG (statbuf.st_mode))
771 return (statbuf.st_size);
774 /* Create a temporary filename and put it in string pointed to by
778 __gnat_tmp_name (char *tmp_filename)
784 /* tempnam tries to create a temporary file in directory pointed to by
785 TMP environment variable, in c:\temp if TMP is not set, and in
786 directory specified by P_tmpdir in stdio.h if c:\temp does not
787 exist. The filename will be created with the prefix "gnat-". */
789 pname = (char *) tempnam ("c:\\temp", "gnat-");
791 /* if pname is NULL, the file was not created properly, the disk is full
792 or there is no more free temporary files */
795 *tmp_filename = '\0';
797 /* If pname start with a back slash and not path information it means that
798 the filename is valid for the current working directory. */
800 else if (pname[0] == '\\')
802 strcpy (tmp_filename, ".\\");
803 strcat (tmp_filename, pname+1);
806 strcpy (tmp_filename, pname);
811 #elif defined (linux) || defined (__FreeBSD__)
812 #define MAX_SAFE_PATH 1000
813 char *tmpdir = getenv ("TMPDIR");
815 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
816 a buffer overflow. */
817 if (tmpdir == NULL || strlen (tmpdir) > MAX_SAFE_PATH)
818 strcpy (tmp_filename, "/tmp/gnat-XXXXXX");
820 sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
822 close (mkstemp(tmp_filename));
824 tmpnam (tmp_filename);
828 /* Read the next entry in a directory. The returned string points somewhere
832 __gnat_readdir (DIR *dirp, char *buffer)
834 /* If possible, try to use the thread-safe version. */
835 #ifdef HAVE_READDIR_R
836 if (readdir_r (dirp, buffer) != NULL)
837 return ((struct dirent*) buffer)->d_name;
842 struct dirent *dirent = (struct dirent *) readdir (dirp);
846 strcpy (buffer, dirent->d_name);
855 /* Returns 1 if readdir is thread safe, 0 otherwise. */
858 __gnat_readdir_is_thread_safe (void)
860 #ifdef HAVE_READDIR_R
868 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
869 static const unsigned long long w32_epoch_offset = 11644473600ULL;
871 /* Returns the file modification timestamp using Win32 routines which are
872 immune against daylight saving time change. It is in fact not possible to
873 use fstat for this purpose as the DST modify the st_mtime field of the
877 win32_filetime (HANDLE h)
882 unsigned long long ull_time;
885 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
886 since <Jan 1st 1601>. This function must return the number of seconds
887 since <Jan 1st 1970>. */
889 if (GetFileTime (h, NULL, NULL, &t_write.ft_time))
890 return (time_t) (t_write.ull_time / 10000000ULL
896 /* Return a GNAT time stamp given a file name. */
899 __gnat_file_time_name (char *name)
902 #if defined (__EMX__) || defined (MSDOS)
903 int fd = open (name, O_RDONLY | O_BINARY);
904 time_t ret = __gnat_file_time_fd (fd);
908 #elif defined (_WIN32)
910 HANDLE h = CreateFile (name, GENERIC_READ, FILE_SHARE_READ, 0,
911 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
913 if (h != INVALID_HANDLE_VALUE)
915 ret = win32_filetime (h);
918 return (OS_Time) ret;
921 if (__gnat_stat (name, &statbuf) != 0) {
925 /* VMS has file versioning. */
926 return (OS_Time)statbuf.st_ctime;
928 return (OS_Time)statbuf.st_mtime;
934 /* Return a GNAT time stamp given a file descriptor. */
937 __gnat_file_time_fd (int fd)
939 /* The following workaround code is due to the fact that under EMX and
940 DJGPP fstat attempts to convert time values to GMT rather than keep the
941 actual OS timestamp of the file. By using the OS2/DOS functions directly
942 the GNAT timestamp are independent of this behavior, which is desired to
943 facilitate the distribution of GNAT compiled libraries. */
945 #if defined (__EMX__) || defined (MSDOS)
949 int ret = DosQueryFileInfo (fd, 1, (unsigned char *) &fs,
950 sizeof (FILESTATUS));
952 unsigned file_year = fs.fdateLastWrite.year;
953 unsigned file_month = fs.fdateLastWrite.month;
954 unsigned file_day = fs.fdateLastWrite.day;
955 unsigned file_hour = fs.ftimeLastWrite.hours;
956 unsigned file_min = fs.ftimeLastWrite.minutes;
957 unsigned file_tsec = fs.ftimeLastWrite.twosecs;
961 int ret = getftime (fd, &fs);
963 unsigned file_year = fs.ft_year;
964 unsigned file_month = fs.ft_month;
965 unsigned file_day = fs.ft_day;
966 unsigned file_hour = fs.ft_hour;
967 unsigned file_min = fs.ft_min;
968 unsigned file_tsec = fs.ft_tsec;
971 /* Calculate the seconds since epoch from the time components. First count
972 the whole days passed. The value for years returned by the DOS and OS2
973 functions count years from 1980, so to compensate for the UNIX epoch which
974 begins in 1970 start with 10 years worth of days and add days for each
975 four year period since then. */
978 int cum_days[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
979 int days_passed = 3652 + (file_year / 4) * 1461;
980 int years_since_leap = file_year % 4;
982 if (years_since_leap == 1)
984 else if (years_since_leap == 2)
986 else if (years_since_leap == 3)
992 days_passed += cum_days[file_month - 1];
993 if (years_since_leap == 0 && file_year != 20 && file_month > 2)
996 days_passed += file_day - 1;
998 /* OK - have whole days. Multiply -- then add in other parts. */
1000 tot_secs = days_passed * 86400;
1001 tot_secs += file_hour * 3600;
1002 tot_secs += file_min * 60;
1003 tot_secs += file_tsec * 2;
1004 return (OS_Time) tot_secs;
1006 #elif defined (_WIN32)
1007 HANDLE h = (HANDLE) _get_osfhandle (fd);
1008 time_t ret = win32_filetime (h);
1009 return (OS_Time) ret;
1012 struct stat statbuf;
1014 if (fstat (fd, &statbuf) != 0) {
1015 return (OS_Time) -1;
1018 /* VMS has file versioning. */
1019 return (OS_Time) statbuf.st_ctime;
1021 return (OS_Time) statbuf.st_mtime;
1027 /* Set the file time stamp. */
1030 __gnat_set_file_time_name (char *name, time_t time_stamp)
1032 #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1034 /* Code to implement __gnat_set_file_time_name for these systems. */
1036 #elif defined (_WIN32)
1040 unsigned long long ull_time;
1043 HANDLE h = CreateFile (name, GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
1044 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS,
1046 if (h == INVALID_HANDLE_VALUE)
1048 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1049 t_write.ull_time = ((unsigned long long)time_stamp + w32_epoch_offset);
1050 /* Convert to 100 nanosecond units */
1051 t_write.ull_time *= 10000000ULL;
1053 SetFileTime(h, NULL, NULL, &t_write.ft_time);
1063 unsigned long long backup, create, expire, revise;
1067 unsigned short value;
1070 unsigned system : 4;
1076 } Fat = { 0, 0, 0, 0, 0, { 0 }};
1080 { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create },
1081 { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise },
1082 { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire },
1083 { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup },
1084 { ATR$S_FPRO, ATR$C_FPRO, &Fat.prot },
1085 { ATR$S_UIC, ATR$C_UIC, &Fat.uic },
1090 struct dsc$descriptor_fib fibdsc = {sizeof (fib), (void *) &fib};
1094 unsigned long long newtime;
1095 unsigned long long revtime;
1099 struct vstring file;
1100 struct dsc$descriptor_s filedsc
1101 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) file.string};
1102 struct vstring device;
1103 struct dsc$descriptor_s devicedsc
1104 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) device.string};
1105 struct vstring timev;
1106 struct dsc$descriptor_s timedsc
1107 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) timev.string};
1108 struct vstring result;
1109 struct dsc$descriptor_s resultdsc
1110 = {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string};
1112 tryfile = (char *) __gnat_to_host_dir_spec (name, 0);
1114 /* Allocate and initialize a FAB and NAM structures. */
1118 nam.nam$l_esa = file.string;
1119 nam.nam$b_ess = NAM$C_MAXRSS;
1120 nam.nam$l_rsa = result.string;
1121 nam.nam$b_rss = NAM$C_MAXRSS;
1122 fab.fab$l_fna = tryfile;
1123 fab.fab$b_fns = strlen (tryfile);
1124 fab.fab$l_nam = &nam;
1126 /* Validate filespec syntax and device existence. */
1127 status = SYS$PARSE (&fab, 0, 0);
1128 if ((status & 1) != 1)
1129 LIB$SIGNAL (status);
1131 file.string[nam.nam$b_esl] = 0;
1133 /* Find matching filespec. */
1134 status = SYS$SEARCH (&fab, 0, 0);
1135 if ((status & 1) != 1)
1136 LIB$SIGNAL (status);
1138 file.string[nam.nam$b_esl] = 0;
1139 result.string[result.length=nam.nam$b_rsl] = 0;
1141 /* Get the device name and assign an IO channel. */
1142 strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev);
1143 devicedsc.dsc$w_length = nam.nam$b_dev;
1145 status = SYS$ASSIGN (&devicedsc, &chan, 0, 0, 0);
1146 if ((status & 1) != 1)
1147 LIB$SIGNAL (status);
1149 /* Initialize the FIB and fill in the directory id field. */
1150 memset (&fib, 0, sizeof (fib));
1151 fib.fib$w_did[0] = nam.nam$w_did[0];
1152 fib.fib$w_did[1] = nam.nam$w_did[1];
1153 fib.fib$w_did[2] = nam.nam$w_did[2];
1154 fib.fib$l_acctl = 0;
1156 strcpy (file.string, (strrchr (result.string, ']') + 1));
1157 filedsc.dsc$w_length = strlen (file.string);
1158 result.string[result.length = 0] = 0;
1160 /* Open and close the file to fill in the attributes. */
1162 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1163 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1164 if ((status & 1) != 1)
1165 LIB$SIGNAL (status);
1166 if ((iosb.status & 1) != 1)
1167 LIB$SIGNAL (iosb.status);
1169 result.string[result.length] = 0;
1170 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, &fibdsc, 0, 0, 0,
1172 if ((status & 1) != 1)
1173 LIB$SIGNAL (status);
1174 if ((iosb.status & 1) != 1)
1175 LIB$SIGNAL (iosb.status);
1180 /* Set creation time to requested time. */
1181 unix_time_to_vms (time_stamp, newtime);
1183 t = time ((time_t) 0);
1185 /* Set revision time to now in local time. */
1186 unix_time_to_vms (t, revtime);
1189 /* Reopen the file, modify the times and then close. */
1190 fib.fib$l_acctl = FIB$M_WRITE;
1192 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1193 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1194 if ((status & 1) != 1)
1195 LIB$SIGNAL (status);
1196 if ((iosb.status & 1) != 1)
1197 LIB$SIGNAL (iosb.status);
1199 Fat.create = newtime;
1200 Fat.revise = revtime;
1202 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0,
1203 &fibdsc, 0, 0, 0, &atrlst, 0);
1204 if ((status & 1) != 1)
1205 LIB$SIGNAL (status);
1206 if ((iosb.status & 1) != 1)
1207 LIB$SIGNAL (iosb.status);
1209 /* Deassign the channel and exit. */
1210 status = SYS$DASSGN (chan);
1211 if ((status & 1) != 1)
1212 LIB$SIGNAL (status);
1214 struct utimbuf utimbuf;
1217 /* Set modification time to requested time. */
1218 utimbuf.modtime = time_stamp;
1220 /* Set access time to now in local time. */
1221 t = time ((time_t) 0);
1222 utimbuf.actime = mktime (localtime (&t));
1224 utime (name, &utimbuf);
1229 __gnat_get_env_value_ptr (char *name, int *len, char **value)
1231 *value = getenv (name);
1235 *len = strlen (*value);
1240 /* VMS specific declarations for set_env_value. */
1244 static char *to_host_path_spec (char *);
1248 unsigned short len, mbz;
1252 typedef struct _ile3
1254 unsigned short len, code;
1256 unsigned short *retlen_adr;
1262 __gnat_set_env_value (char *name, char *value)
1267 struct descriptor_s name_desc;
1268 /* Put in JOB table for now, so that the project stuff at least works. */
1269 struct descriptor_s table_desc = {7, 0, "LNM$JOB"};
1270 char *host_pathspec = value;
1271 char *copy_pathspec;
1272 int num_dirs_in_pathspec = 1;
1276 name_desc.len = strlen (name);
1278 name_desc.adr = name;
1280 if (*host_pathspec == 0)
1283 status = LIB$DELETE_LOGICAL (&name_desc, &table_desc);
1284 /* no need to check status; if the logical name is not
1285 defined, that's fine. */
1289 ptr = host_pathspec;
1292 num_dirs_in_pathspec++;
1296 ile_s *ile_array = alloca (sizeof (ile_s) * (num_dirs_in_pathspec + 1));
1297 char *copy_pathspec = alloca (strlen (host_pathspec) + 1);
1300 strcpy (copy_pathspec, host_pathspec);
1301 curr = copy_pathspec;
1302 for (i = 0; i < num_dirs_in_pathspec; i++)
1304 next = strchr (curr, ',');
1306 next = strchr (curr, 0);
1309 ile_array[i].len = strlen (curr);
1311 /* Code 2 from lnmdef.h means its a string. */
1312 ile_array[i].code = 2;
1313 ile_array[i].adr = curr;
1315 /* retlen_adr is ignored. */
1316 ile_array[i].retlen_adr = 0;
1320 /* Terminating item must be zero. */
1321 ile_array[i].len = 0;
1322 ile_array[i].code = 0;
1323 ile_array[i].adr = 0;
1324 ile_array[i].retlen_adr = 0;
1326 status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array);
1327 if ((status & 1) != 1)
1328 LIB$SIGNAL (status);
1332 int size = strlen (name) + strlen (value) + 2;
1335 expression = (char *) xmalloc (size * sizeof (char));
1337 sprintf (expression, "%s=%s", name, value);
1338 putenv (expression);
1343 #include <windows.h>
1346 /* Get the list of installed standard libraries from the
1347 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1351 __gnat_get_libraries_from_registry (void)
1353 char *result = (char *) "";
1355 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_COMPILE)
1358 DWORD name_size, value_size;
1365 /* First open the key. */
1366 res = RegOpenKeyExA (HKEY_LOCAL_MACHINE, "SOFTWARE", 0, KEY_READ, ®_key);
1368 if (res == ERROR_SUCCESS)
1369 res = RegOpenKeyExA (reg_key, "Ada Core Technologies", 0,
1370 KEY_READ, ®_key);
1372 if (res == ERROR_SUCCESS)
1373 res = RegOpenKeyExA (reg_key, "GNAT", 0, KEY_READ, ®_key);
1375 if (res == ERROR_SUCCESS)
1376 res = RegOpenKeyExA (reg_key, "Standard Libraries", 0, KEY_READ, ®_key);
1378 /* If the key exists, read out all the values in it and concatenate them
1380 for (index = 0; res == ERROR_SUCCESS; index++)
1382 value_size = name_size = 256;
1383 res = RegEnumValue (reg_key, index, name, &name_size, 0,
1384 &type, (LPBYTE)value, &value_size);
1386 if (res == ERROR_SUCCESS && type == REG_SZ)
1388 char *old_result = result;
1390 result = (char *) xmalloc (strlen (old_result) + value_size + 2);
1391 strcpy (result, old_result);
1392 strcat (result, value);
1393 strcat (result, ";");
1397 /* Remove the trailing ";". */
1399 result[strlen (result) - 1] = 0;
1406 __gnat_stat (char *name, struct stat *statbuf)
1409 /* Under Windows the directory name for the stat function must not be
1410 terminated by a directory separator except if just after a drive name. */
1411 int name_len = strlen (name);
1412 char last_char = name[name_len - 1];
1413 char win32_name[GNAT_MAX_PATH_LEN + 2];
1415 if (name_len > GNAT_MAX_PATH_LEN)
1418 strcpy (win32_name, name);
1420 while (name_len > 1 && (last_char == '\\' || last_char == '/'))
1422 win32_name[name_len - 1] = '\0';
1424 last_char = win32_name[name_len - 1];
1427 if (name_len == 2 && win32_name[1] == ':')
1428 strcat (win32_name, "\\");
1430 return stat (win32_name, statbuf);
1433 return stat (name, statbuf);
1438 __gnat_file_exists (char *name)
1440 struct stat statbuf;
1442 return !__gnat_stat (name, &statbuf);
1446 __gnat_is_absolute_path (char *name, int length)
1448 return (length != 0) &&
1449 (*name == '/' || *name == DIR_SEPARATOR
1450 #if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
1451 || (length > 1 && isalpha (name[0]) && name[1] == ':')
1457 __gnat_is_regular_file (char *name)
1460 struct stat statbuf;
1462 ret = __gnat_stat (name, &statbuf);
1463 return (!ret && S_ISREG (statbuf.st_mode));
1467 __gnat_is_directory (char *name)
1470 struct stat statbuf;
1472 ret = __gnat_stat (name, &statbuf);
1473 return (!ret && S_ISDIR (statbuf.st_mode));
1477 __gnat_is_readable_file (char *name)
1481 struct stat statbuf;
1483 ret = __gnat_stat (name, &statbuf);
1484 mode = statbuf.st_mode & S_IRUSR;
1485 return (!ret && mode);
1489 __gnat_is_writable_file (char *name)
1493 struct stat statbuf;
1495 ret = __gnat_stat (name, &statbuf);
1496 mode = statbuf.st_mode & S_IWUSR;
1497 return (!ret && mode);
1501 __gnat_set_writable (char *name)
1504 struct stat statbuf;
1506 if (stat (name, &statbuf) == 0)
1508 statbuf.st_mode = statbuf.st_mode | S_IWUSR;
1509 chmod (name, statbuf.st_mode);
1515 __gnat_set_executable (char *name)
1518 struct stat statbuf;
1520 if (stat (name, &statbuf) == 0)
1522 statbuf.st_mode = statbuf.st_mode | S_IXUSR;
1523 chmod (name, statbuf.st_mode);
1529 __gnat_set_readonly (char *name)
1532 struct stat statbuf;
1534 if (stat (name, &statbuf) == 0)
1536 statbuf.st_mode = statbuf.st_mode & 07577;
1537 chmod (name, statbuf.st_mode);
1543 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED)
1545 #if defined (__vxworks)
1548 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
1550 struct stat statbuf;
1552 ret = lstat (name, &statbuf);
1553 return (!ret && S_ISLNK (statbuf.st_mode));
1560 #if defined (sun) && defined (__SVR4)
1561 /* Using fork on Solaris will duplicate all the threads. fork1, which
1562 duplicates only the active thread, must be used instead, or spawning
1563 subprocess from a program with tasking will lead into numerous problems. */
1568 __gnat_portable_spawn (char *args[])
1571 int finished ATTRIBUTE_UNUSED;
1572 int pid ATTRIBUTE_UNUSED;
1574 #if defined (MSDOS) || defined (_WIN32)
1575 /* args[0] must be quotes as it could contain a full pathname with spaces */
1576 char *args_0 = args[0];
1577 args[0] = (char *)xmalloc (strlen (args_0) + 3);
1578 strcpy (args[0], "\"");
1579 strcat (args[0], args_0);
1580 strcat (args[0], "\"");
1582 status = spawnvp (P_WAIT, args_0, (const char* const*)args);
1584 /* restore previous value */
1586 args[0] = (char *)args_0;
1593 #elif defined (__vxworks)
1598 pid = spawnvp (P_NOWAIT, args[0], args);
1610 if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
1612 return -1; /* execv is in parent context on VMS. */
1620 finished = waitpid (pid, &status, 0);
1622 if (finished != pid || WIFEXITED (status) == 0)
1625 return WEXITSTATUS (status);
1631 /* Create a copy of the given file descriptor.
1632 Return -1 if an error occurred. */
1635 __gnat_dup (int oldfd)
1637 #if defined (__vxworks)
1638 /* Not supported on VxWorks. */
1645 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
1646 Return -1 if an error occurred. */
1649 __gnat_dup2 (int oldfd, int newfd)
1651 #if defined (__vxworks)
1652 /* Not supported on VxWorks. */
1655 return dup2 (oldfd, newfd);
1659 /* WIN32 code to implement a wait call that wait for any child process. */
1663 /* Synchronization code, to be thread safe. */
1665 static CRITICAL_SECTION plist_cs;
1668 __gnat_plist_init (void)
1670 InitializeCriticalSection (&plist_cs);
1676 EnterCriticalSection (&plist_cs);
1682 LeaveCriticalSection (&plist_cs);
1685 typedef struct _process_list
1688 struct _process_list *next;
1691 static Process_List *PLIST = NULL;
1693 static int plist_length = 0;
1696 add_handle (HANDLE h)
1700 pl = (Process_List *) xmalloc (sizeof (Process_List));
1704 /* -------------------- critical section -------------------- */
1709 /* -------------------- critical section -------------------- */
1715 remove_handle (HANDLE h)
1718 Process_List *prev = NULL;
1722 /* -------------------- critical section -------------------- */
1731 prev->next = pl->next;
1743 /* -------------------- critical section -------------------- */
1749 win32_no_block_spawn (char *command, char *args[])
1753 PROCESS_INFORMATION PI;
1754 SECURITY_ATTRIBUTES SA;
1759 /* compute the total command line length */
1763 csize += strlen (args[k]) + 1;
1767 full_command = (char *) xmalloc (csize);
1770 SI.cb = sizeof (STARTUPINFO);
1771 SI.lpReserved = NULL;
1772 SI.lpReserved2 = NULL;
1773 SI.lpDesktop = NULL;
1777 SI.wShowWindow = SW_HIDE;
1779 /* Security attributes. */
1780 SA.nLength = sizeof (SECURITY_ATTRIBUTES);
1781 SA.bInheritHandle = TRUE;
1782 SA.lpSecurityDescriptor = NULL;
1784 /* Prepare the command string. */
1785 strcpy (full_command, command);
1786 strcat (full_command, " ");
1791 strcat (full_command, args[k]);
1792 strcat (full_command, " ");
1796 result = CreateProcess
1797 (NULL, (char *) full_command, &SA, NULL, TRUE,
1798 GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
1800 free (full_command);
1804 add_handle (PI.hProcess);
1805 CloseHandle (PI.hThread);
1806 return (int) PI.hProcess;
1813 win32_wait (int *status)
1822 if (plist_length == 0)
1828 hl = (HANDLE *) xmalloc (sizeof (HANDLE) * plist_length);
1833 /* -------------------- critical section -------------------- */
1840 /* -------------------- critical section -------------------- */
1844 res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE);
1845 h = hl[res - WAIT_OBJECT_0];
1850 GetExitCodeProcess (h, &exitcode);
1853 *status = (int) exitcode;
1860 __gnat_portable_no_block_spawn (char *args[])
1864 #if defined (__EMX__) || defined (MSDOS)
1866 /* ??? For PC machines I (Franco) don't know the system calls to implement
1867 this routine. So I'll fake it as follows. This routine will behave
1868 exactly like the blocking portable_spawn and will systematically return
1869 a pid of 0 unless the spawned task did not complete successfully, in
1870 which case we return a pid of -1. To synchronize with this the
1871 portable_wait below systematically returns a pid of 0 and reports that
1872 the subprocess terminated successfully. */
1874 if (spawnvp (P_WAIT, args[0], args) != 0)
1877 #elif defined (_WIN32)
1879 pid = win32_no_block_spawn (args[0], args);
1882 #elif defined (__vxworks)
1891 if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
1893 return -1; /* execv is in parent context on VMS. */
1905 __gnat_portable_wait (int *process_status)
1910 #if defined (_WIN32)
1912 pid = win32_wait (&status);
1914 #elif defined (__EMX__) || defined (MSDOS)
1915 /* ??? See corresponding comment in portable_no_block_spawn. */
1917 #elif defined (__vxworks)
1918 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
1922 pid = waitpid (-1, &status, 0);
1923 status = status & 0xffff;
1926 *process_status = status;
1931 __gnat_os_exit (int status)
1936 /* Locate a regular file, give a Path value. */
1939 __gnat_locate_regular_file (char *file_name, char *path_val)
1942 int absolute = __gnat_is_absolute_path (file_name, strlen (file_name));
1944 /* Handle absolute pathnames. */
1947 if (__gnat_is_regular_file (file_name))
1948 return xstrdup (file_name);
1953 /* If file_name include directory separator(s), try it first as
1954 a path name relative to the current directory */
1955 for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
1960 if (__gnat_is_regular_file (file_name))
1961 return xstrdup (file_name);
1968 /* The result has to be smaller than path_val + file_name. */
1969 char *file_path = alloca (strlen (path_val) + strlen (file_name) + 2);
1973 for (; *path_val == PATH_SEPARATOR; path_val++)
1979 for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
1980 *ptr++ = *path_val++;
1983 if (*ptr != '/' && *ptr != DIR_SEPARATOR)
1984 *++ptr = DIR_SEPARATOR;
1986 strcpy (++ptr, file_name);
1988 if (__gnat_is_regular_file (file_path))
1989 return xstrdup (file_path);
1996 /* Locate an executable given a Path argument. This routine is only used by
1997 gnatbl and should not be used otherwise. Use locate_exec_on_path
2001 __gnat_locate_exec (char *exec_name, char *path_val)
2003 if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
2005 char *full_exec_name
2006 = alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
2008 strcpy (full_exec_name, exec_name);
2009 strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
2010 return __gnat_locate_regular_file (full_exec_name, path_val);
2013 return __gnat_locate_regular_file (exec_name, path_val);
2016 /* Locate an executable using the Systems default PATH. */
2019 __gnat_locate_exec_on_path (char *exec_name)
2023 char *path_val = "/VAXC$PATH";
2025 char *path_val = getenv ("PATH");
2028 /* In Win32 systems we expand the PATH as for XP environment
2029 variables are not automatically expanded. */
2030 int len = strlen (path_val) * 3;
2031 char *expanded_path_val = alloca (len + 1);
2033 DWORD res = ExpandEnvironmentStrings (path_val, expanded_path_val, len);
2037 path_val = expanded_path_val;
2041 apath_val = alloca (strlen (path_val) + 1);
2042 strcpy (apath_val, path_val);
2044 return __gnat_locate_exec (exec_name, apath_val);
2049 /* These functions are used to translate to and from VMS and Unix syntax
2050 file, directory and path specifications. */
2053 #define MAXNAMES 256
2054 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2056 static char new_canonical_dirspec [MAXPATH];
2057 static char new_canonical_filespec [MAXPATH];
2058 static char new_canonical_pathspec [MAXNAMES*MAXPATH];
2059 static unsigned new_canonical_filelist_index;
2060 static unsigned new_canonical_filelist_in_use;
2061 static unsigned new_canonical_filelist_allocated;
2062 static char **new_canonical_filelist;
2063 static char new_host_pathspec [MAXNAMES*MAXPATH];
2064 static char new_host_dirspec [MAXPATH];
2065 static char new_host_filespec [MAXPATH];
2067 /* Routine is called repeatedly by decc$from_vms via
2068 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2072 wildcard_translate_unix (char *name)
2075 char buff [MAXPATH];
2077 strncpy (buff, name, MAXPATH);
2078 buff [MAXPATH - 1] = (char) 0;
2079 ver = strrchr (buff, '.');
2081 /* Chop off the version. */
2085 /* Dynamically extend the allocation by the increment. */
2086 if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
2088 new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
2089 new_canonical_filelist = (char **) xrealloc
2090 (new_canonical_filelist,
2091 new_canonical_filelist_allocated * sizeof (char *));
2094 new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
2099 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2100 full translation and copy the results into a list (_init), then return them
2101 one at a time (_next). If onlydirs set, only expand directory files. */
2104 __gnat_to_canonical_file_list_init (char *filespec, int onlydirs)
2107 char buff [MAXPATH];
2109 len = strlen (filespec);
2110 strncpy (buff, filespec, MAXPATH);
2112 /* Only look for directories */
2113 if (onlydirs && !strstr (&buff [len-5], "*.dir"))
2114 strncat (buff, "*.dir", MAXPATH);
2116 buff [MAXPATH - 1] = (char) 0;
2118 decc$from_vms (buff, wildcard_translate_unix, 1);
2120 /* Remove the .dir extension. */
2126 for (i = 0; i < new_canonical_filelist_in_use; i++)
2128 ext = strstr (new_canonical_filelist[i], ".dir");
2134 return new_canonical_filelist_in_use;
2137 /* Return the next filespec in the list. */
2140 __gnat_to_canonical_file_list_next ()
2142 return new_canonical_filelist[new_canonical_filelist_index++];
2145 /* Free storage used in the wildcard expansion. */
2148 __gnat_to_canonical_file_list_free ()
2152 for (i = 0; i < new_canonical_filelist_in_use; i++)
2153 free (new_canonical_filelist[i]);
2155 free (new_canonical_filelist);
2157 new_canonical_filelist_in_use = 0;
2158 new_canonical_filelist_allocated = 0;
2159 new_canonical_filelist_index = 0;
2160 new_canonical_filelist = 0;
2163 /* Translate a VMS syntax directory specification in to Unix syntax. If
2164 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2165 found, return input string. Also translate a dirname that contains no
2166 slashes, in case it's a logical name. */
2169 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag)
2173 strcpy (new_canonical_dirspec, "");
2174 if (strlen (dirspec))
2178 if (strchr (dirspec, ']') || strchr (dirspec, ':'))
2180 strncpy (new_canonical_dirspec,
2181 (char *) decc$translate_vms (dirspec),
2184 else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
2186 strncpy (new_canonical_dirspec,
2187 (char *) decc$translate_vms (dirspec1),
2192 strncpy (new_canonical_dirspec, dirspec, MAXPATH);
2196 len = strlen (new_canonical_dirspec);
2197 if (prefixflag && new_canonical_dirspec [len-1] != '/')
2198 strncat (new_canonical_dirspec, "/", MAXPATH);
2200 new_canonical_dirspec [MAXPATH - 1] = (char) 0;
2202 return new_canonical_dirspec;
2206 /* Translate a VMS syntax file specification into Unix syntax.
2207 If no indicators of VMS syntax found, check if its an uppercase
2208 alphanumeric_ name and if so try it out as an environment
2209 variable (logical name). If all else fails return the
2213 __gnat_to_canonical_file_spec (char *filespec)
2217 strncpy (new_canonical_filespec, "", MAXPATH);
2219 if (strchr (filespec, ']') || strchr (filespec, ':'))
2221 strncpy (new_canonical_filespec,
2222 (char *) decc$translate_vms (filespec), MAXPATH);
2224 else if ((strlen (filespec) == strspn (filespec,
2225 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
2226 && (filespec1 = getenv (filespec)))
2228 strncpy (new_canonical_filespec,
2229 (char *) decc$translate_vms (filespec1), MAXPATH);
2233 strncpy (new_canonical_filespec, filespec, MAXPATH);
2236 new_canonical_filespec [MAXPATH - 1] = (char) 0;
2238 return new_canonical_filespec;
2241 /* Translate a VMS syntax path specification into Unix syntax.
2242 If no indicators of VMS syntax found, return input string. */
2245 __gnat_to_canonical_path_spec (char *pathspec)
2247 char *curr, *next, buff [MAXPATH];
2252 /* If there are /'s, assume it's a Unix path spec and return. */
2253 if (strchr (pathspec, '/'))
2256 new_canonical_pathspec[0] = 0;
2261 next = strchr (curr, ',');
2263 next = strchr (curr, 0);
2265 strncpy (buff, curr, next - curr);
2266 buff[next - curr] = 0;
2268 /* Check for wildcards and expand if present. */
2269 if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
2273 dirs = __gnat_to_canonical_file_list_init (buff, 1);
2274 for (i = 0; i < dirs; i++)
2278 next_dir = __gnat_to_canonical_file_list_next ();
2279 strncat (new_canonical_pathspec, next_dir, MAXPATH);
2281 /* Don't append the separator after the last expansion. */
2283 strncat (new_canonical_pathspec, ":", MAXPATH);
2286 __gnat_to_canonical_file_list_free ();
2289 strncat (new_canonical_pathspec,
2290 __gnat_to_canonical_dir_spec (buff, 0), MAXPATH);
2295 strncat (new_canonical_pathspec, ":", MAXPATH);
2299 new_canonical_pathspec [MAXPATH - 1] = (char) 0;
2301 return new_canonical_pathspec;
2304 static char filename_buff [MAXPATH];
2307 translate_unix (char *name, int type)
2309 strncpy (filename_buff, name, MAXPATH);
2310 filename_buff [MAXPATH - 1] = (char) 0;
2314 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
2318 to_host_path_spec (char *pathspec)
2320 char *curr, *next, buff [MAXPATH];
2325 /* Can't very well test for colons, since that's the Unix separator! */
2326 if (strchr (pathspec, ']') || strchr (pathspec, ','))
2329 new_host_pathspec[0] = 0;
2334 next = strchr (curr, ':');
2336 next = strchr (curr, 0);
2338 strncpy (buff, curr, next - curr);
2339 buff[next - curr] = 0;
2341 strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH);
2344 strncat (new_host_pathspec, ",", MAXPATH);
2348 new_host_pathspec [MAXPATH - 1] = (char) 0;
2350 return new_host_pathspec;
2353 /* Translate a Unix syntax directory specification into VMS syntax. The
2354 PREFIXFLAG has no effect, but is kept for symmetry with
2355 to_canonical_dir_spec. If indicators of VMS syntax found, return input
2359 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2361 int len = strlen (dirspec);
2363 strncpy (new_host_dirspec, dirspec, MAXPATH);
2364 new_host_dirspec [MAXPATH - 1] = (char) 0;
2366 if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
2367 return new_host_dirspec;
2369 while (len > 1 && new_host_dirspec[len - 1] == '/')
2371 new_host_dirspec[len - 1] = 0;
2375 decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
2376 strncpy (new_host_dirspec, filename_buff, MAXPATH);
2377 new_host_dirspec [MAXPATH - 1] = (char) 0;
2379 return new_host_dirspec;
2382 /* Translate a Unix syntax file specification into VMS syntax.
2383 If indicators of VMS syntax found, return input string. */
2386 __gnat_to_host_file_spec (char *filespec)
2388 strncpy (new_host_filespec, "", MAXPATH);
2389 if (strchr (filespec, ']') || strchr (filespec, ':'))
2391 strncpy (new_host_filespec, filespec, MAXPATH);
2395 decc$to_vms (filespec, translate_unix, 1, 1);
2396 strncpy (new_host_filespec, filename_buff, MAXPATH);
2399 new_host_filespec [MAXPATH - 1] = (char) 0;
2401 return new_host_filespec;
2405 __gnat_adjust_os_resource_limits ()
2407 SYS$ADJWSL (131072, 0);
2412 /* Dummy functions for Osint import for non-VMS systems. */
2415 __gnat_to_canonical_file_list_init
2416 (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED)
2422 __gnat_to_canonical_file_list_next (void)
2428 __gnat_to_canonical_file_list_free (void)
2433 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2439 __gnat_to_canonical_file_spec (char *filespec)
2445 __gnat_to_canonical_path_spec (char *pathspec)
2451 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2457 __gnat_to_host_file_spec (char *filespec)
2463 __gnat_adjust_os_resource_limits (void)
2469 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
2470 to coordinate this with the EMX distribution. Consequently, we put the
2471 definition of dummy which is used for exception handling, here. */
2473 #if defined (__EMX__)
2477 #if defined (__mips_vxworks)
2481 CACHE_USER_FLUSH (0, ENTIRE_CACHE);
2485 #if defined (CROSS_COMPILE) \
2486 || (! (defined (sparc) && defined (sun) && defined (__SVR4)) \
2487 && ! (defined (linux) && defined (i386)) \
2488 && ! defined (__FreeBSD__) \
2489 && ! defined (__hpux__) \
2490 && ! defined (__APPLE__) \
2491 && ! defined (_AIX) \
2492 && ! (defined (__alpha__) && defined (__osf__)) \
2493 && ! defined (__MINGW32__) \
2494 && ! (defined (__mips) && defined (__sgi)))
2496 /* Dummy function to satisfy g-trasym.o. Currently Solaris sparc, HP/UX,
2497 GNU/Linux x86, Tru64 & Windows provide a non-dummy version of this
2498 procedure in libaddr2line.a. */
2501 convert_addresses (void *addrs ATTRIBUTE_UNUSED,
2502 int n_addr ATTRIBUTE_UNUSED,
2503 void *buf ATTRIBUTE_UNUSED,
2504 int *len ATTRIBUTE_UNUSED)
2510 #if defined (_WIN32)
2511 int __gnat_argument_needs_quote = 1;
2513 int __gnat_argument_needs_quote = 0;
2516 /* This option is used to enable/disable object files handling from the
2517 binder file by the GNAT Project module. For example, this is disabled on
2518 Windows (prior to GCC 3.4) as it is already done by the mdll module.
2519 Stating with GCC 3.4 the shared libraries are not based on mdll
2520 anymore as it uses the GCC's -shared option */
2521 #if defined (_WIN32) \
2522 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
2523 int __gnat_prj_add_obj_files = 0;
2525 int __gnat_prj_add_obj_files = 1;
2528 /* char used as prefix/suffix for environment variables */
2529 #if defined (_WIN32)
2530 char __gnat_environment_char = '%';
2532 char __gnat_environment_char = '$';
2535 /* This functions copy the file attributes from a source file to a
2538 mode = 0 : In this mode copy only the file time stamps (last access and
2539 last modification time stamps).
2541 mode = 1 : In this mode, time stamps and read/write/execute attributes are
2544 Returns 0 if operation was successful and -1 in case of error. */
2547 __gnat_copy_attribs (char *from, char *to, int mode)
2549 #if defined (VMS) || defined (__vxworks)
2553 struct utimbuf tbuf;
2555 if (stat (from, &fbuf) == -1)
2560 tbuf.actime = fbuf.st_atime;
2561 tbuf.modtime = fbuf.st_mtime;
2563 if (utime (to, &tbuf) == -1)
2570 if (chmod (to, fbuf.st_mode) == -1)
2580 /* This function is installed in libgcc.a. */
2581 extern void __gnat_install_locks (void (*) (void), void (*) (void));
2583 /* This function offers a hook for libgnarl to set the
2584 locking subprograms for libgcc_eh.
2585 This is only needed on OpenVMS, since other platforms use standard
2586 --enable-threads=posix option, or similar. */
2589 __gnatlib_install_locks (void (*lock) (void) ATTRIBUTE_UNUSED,
2590 void (*unlock) (void) ATTRIBUTE_UNUSED)
2592 #if defined (IN_RTS) && defined (VMS)
2593 __gnat_install_locks (lock, unlock);
2594 /* There is a bootstrap path issue if adaint is build with this
2595 symbol unresolved for the stage1 compiler. Since the compiler
2596 does not use tasking, we simply make __gnatlib_install_locks
2597 a no-op in this case. */
2602 __gnat_lseek (int fd, long offset, int whence)
2604 return (int) lseek (fd, offset, whence);
2607 /* This function returns the version of GCC being used. Here it's GCC 3. */
2609 get_gcc_version (void)
2615 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED,
2616 int close_on_exec_p ATTRIBUTE_UNUSED)
2618 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
2619 int flags = fcntl (fd, F_GETFD, 0);
2622 if (close_on_exec_p)
2623 flags |= FD_CLOEXEC;
2625 flags &= ~FD_CLOEXEC;
2626 return fcntl (fd, F_SETFD, flags | FD_CLOEXEC);
2629 /* For the Windows case, we should use SetHandleInformation to remove
2630 the HANDLE_INHERIT property from fd. This is not implemented yet,
2631 but for our purposes (support of GNAT.Expect) this does not matter,
2632 as by default handles are *not* inherited. */