1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2004, 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 */
68 /* We don't have libiberty, so use malloc. */
69 #define xmalloc(S) malloc (S)
70 #define xrealloc(V,S) realloc (V,S)
78 #include <sys/utime.h>
94 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
97 /* Header files and definitions for __gnat_set_file_time_name. */
109 /* Use native 64-bit arithmetic. */
110 #define unix_time_to_vms(X,Y) \
111 { unsigned long long reftime, tmptime = (X); \
112 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
113 SYS$BINTIM (&unixtime, &reftime); \
114 Y = tmptime * 10000000 + reftime; }
116 /* descrip.h doesn't have everything ... */
117 struct dsc$descriptor_fib
119 unsigned long fib$l_len;
120 struct fibdef *fib$l_addr;
123 /* I/O Status Block. */
126 unsigned short status, count;
127 unsigned long devdep;
130 static char *tryfile;
132 /* Variable length string. */
136 char string[NAM$C_MAXRSS+1];
143 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
151 #define DIR_SEPARATOR '\\'
156 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
157 defined in the current system. On DOS-like systems these flags control
158 whether the file is opened/created in text-translation mode (CR/LF in
159 external file mapped to LF in internal file), but in Unix-like systems,
160 no text translation is required, so these flags have no effect. */
162 #if defined (__EMX__)
178 #ifndef HOST_EXECUTABLE_SUFFIX
179 #define HOST_EXECUTABLE_SUFFIX ""
182 #ifndef HOST_OBJECT_SUFFIX
183 #define HOST_OBJECT_SUFFIX ".o"
186 #ifndef PATH_SEPARATOR
187 #define PATH_SEPARATOR ':'
190 #ifndef DIR_SEPARATOR
191 #define DIR_SEPARATOR '/'
194 char __gnat_dir_separator = DIR_SEPARATOR;
196 char __gnat_path_separator = PATH_SEPARATOR;
198 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
199 the base filenames that libraries specified with -lsomelib options
200 may have. This is used by GNATMAKE to check whether an executable
201 is up-to-date or not. The syntax is
203 library_template ::= { pattern ; } pattern NUL
204 pattern ::= [ prefix ] * [ postfix ]
206 These should only specify names of static libraries as it makes
207 no sense to determine at link time if dynamic-link libraries are
208 up to date or not. Any libraries that are not found are supposed
211 * if they are needed but not present, the link
214 * otherwise they are libraries in the system paths and so
215 they are considered part of the system and not checked
218 ??? This should be part of a GNAT host-specific compiler
219 file instead of being included in all user applications
220 as well. This is only a temporary work-around for 3.11b. */
222 #ifndef GNAT_LIBRARY_TEMPLATE
223 #if defined (__EMX__)
224 #define GNAT_LIBRARY_TEMPLATE "*.a"
226 #define GNAT_LIBRARY_TEMPLATE "*.olb"
228 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
232 const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE;
234 /* This variable is used in hostparm.ads to say whether the host is a VMS
237 const int __gnat_vmsp = 1;
239 const int __gnat_vmsp = 0;
243 #define GNAT_MAX_PATH_LEN MAX_PATH
246 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
248 #elif defined (__vxworks) || defined (__OPENNT)
249 #define GNAT_MAX_PATH_LEN PATH_MAX
253 #if defined (__MINGW32__)
257 #include <sys/param.h>
261 #include <sys/param.h>
264 #define GNAT_MAX_PATH_LEN MAXPATHLEN
268 /* The __gnat_max_path_len variable is used to export the maximum
269 length of a path name to Ada code. max_path_len is also provided
270 for compatibility with older GNAT versions, please do not use
273 int __gnat_max_path_len = GNAT_MAX_PATH_LEN;
274 int max_path_len = GNAT_MAX_PATH_LEN;
276 /* The following macro HAVE_READDIR_R should be defined if the
277 system provides the routine readdir_r. */
278 #undef HAVE_READDIR_R
291 time_t time = (time_t) *p_time;
294 /* On Windows systems, the time is sometimes rounded up to the nearest
295 even second, so if the number of seconds is odd, increment it. */
301 res = localtime (&time);
303 res = gmtime (&time);
308 *p_year = res->tm_year;
309 *p_month = res->tm_mon;
310 *p_day = res->tm_mday;
311 *p_hours = res->tm_hour;
312 *p_mins = res->tm_min;
313 *p_secs = res->tm_sec;
316 *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0;
319 /* Place the contents of the symbolic link named PATH in the buffer BUF,
320 which has size BUFSIZ. If PATH is a symbolic link, then return the number
321 of characters of its content in BUF. Otherwise, return -1. For Windows,
322 OS/2 and vxworks, always return -1. */
325 __gnat_readlink (char *path ATTRIBUTE_UNUSED,
326 char *buf ATTRIBUTE_UNUSED,
327 size_t bufsiz ATTRIBUTE_UNUSED)
329 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
331 #elif defined (__INTERIX) || defined (VMS)
333 #elif defined (__vxworks)
336 return readlink (path, buf, bufsiz);
340 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH. If
341 NEWPATH exists it will NOT be overwritten. For Windows, OS/2, VxWorks,
342 Interix and VMS, always return -1. */
345 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED,
346 char *newpath ATTRIBUTE_UNUSED)
348 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
350 #elif defined (__INTERIX) || defined (VMS)
352 #elif defined (__vxworks)
355 return symlink (oldpath, newpath);
359 /* Try to lock a file, return 1 if success. */
361 #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32)
363 /* Version that does not use link. */
366 __gnat_try_lock (char *dir, char *file)
371 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
372 fd = open (full_path, O_CREAT | O_EXCL, 0600);
380 #elif defined (__EMX__) || defined (VMS)
382 /* More cases that do not use link; identical code, to solve too long
386 __gnat_try_lock (char *dir, char *file)
391 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
392 fd = open (full_path, O_CREAT | O_EXCL, 0600);
402 /* Version using link(), more secure over NFS. */
403 /* See TN 6913-016 for discussion ??? */
406 __gnat_try_lock (char *dir, char *file)
410 struct stat stat_result;
413 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
414 sprintf (temp_file, "%s-%ld-%ld", dir, (long) getpid(), (long) getppid ());
416 /* Create the temporary file and write the process number. */
417 fd = open (temp_file, O_CREAT | O_WRONLY, 0600);
423 /* Link it with the new file. */
424 link (temp_file, full_path);
426 /* Count the references on the old one. If we have a count of two, then
427 the link did succeed. Remove the temporary file before returning. */
428 __gnat_stat (temp_file, &stat_result);
430 return stat_result.st_nlink == 2;
434 /* Return the maximum file name length. */
437 __gnat_get_maximum_file_name_length (void)
442 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
451 /* Return nonzero if file names are case sensitive. */
454 __gnat_get_file_names_case_sensitive (void)
456 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT)
464 __gnat_get_default_identifier_character_set (void)
466 #if defined (__EMX__) || defined (MSDOS)
473 /* Return the current working directory. */
476 __gnat_get_current_dir (char *dir, int *length)
479 /* Force Unix style, which is what GNAT uses internally. */
480 getcwd (dir, *length, 0);
482 getcwd (dir, *length);
485 *length = strlen (dir);
487 if (dir [*length - 1] != DIR_SEPARATOR)
489 dir [*length] = DIR_SEPARATOR;
495 /* Return the suffix for object files. */
498 __gnat_get_object_suffix_ptr (int *len, const char **value)
500 *value = HOST_OBJECT_SUFFIX;
505 *len = strlen (*value);
510 /* Return the suffix for executable files. */
513 __gnat_get_executable_suffix_ptr (int *len, const char **value)
515 *value = HOST_EXECUTABLE_SUFFIX;
519 *len = strlen (*value);
524 /* Return the suffix for debuggable files. Usually this is the same as the
525 executable extension. */
528 __gnat_get_debuggable_suffix_ptr (int *len, const char **value)
531 *value = HOST_EXECUTABLE_SUFFIX;
533 /* On DOS, the extensionless COFF file is what gdb likes. */
540 *len = strlen (*value);
546 __gnat_open_read (char *path, int fmode)
549 int o_fmode = O_BINARY;
555 /* Optional arguments mbc,deq,fop increase read performance. */
556 fd = open (path, O_RDONLY | o_fmode, 0444,
557 "mbc=16", "deq=64", "fop=tef");
558 #elif defined (__vxworks)
559 fd = open (path, O_RDONLY | o_fmode, 0444);
561 fd = open (path, O_RDONLY | o_fmode);
564 return fd < 0 ? -1 : fd;
567 #if defined (__EMX__) || defined (__MINGW32__)
568 #define PERM (S_IREAD | S_IWRITE)
570 /* Excerpt from DECC C RTL Reference Manual:
571 To create files with OpenVMS RMS default protections using the UNIX
572 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
573 and open with a file-protection mode argument of 0777 in a program
574 that never specifically calls umask. These default protections include
575 correctly establishing protections based on ACLs, previous versions of
579 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
583 __gnat_open_rw (char *path, int fmode)
586 int o_fmode = O_BINARY;
592 fd = open (path, O_RDWR | o_fmode, PERM,
593 "mbc=16", "deq=64", "fop=tef");
595 fd = open (path, O_RDWR | o_fmode, PERM);
598 return fd < 0 ? -1 : fd;
602 __gnat_open_create (char *path, int fmode)
605 int o_fmode = O_BINARY;
611 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM,
612 "mbc=16", "deq=64", "fop=tef");
614 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
617 return fd < 0 ? -1 : fd;
621 __gnat_create_output_file (char *path)
625 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM,
626 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
627 "shr=del,get,put,upd");
629 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
632 return fd < 0 ? -1 : fd;
636 __gnat_open_append (char *path, int fmode)
639 int o_fmode = O_BINARY;
645 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM,
646 "mbc=16", "deq=64", "fop=tef");
648 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
651 return fd < 0 ? -1 : fd;
654 /* Open a new file. Return error (-1) if the file already exists. */
657 __gnat_open_new (char *path, int fmode)
660 int o_fmode = O_BINARY;
666 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
667 "mbc=16", "deq=64", "fop=tef");
669 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
672 return fd < 0 ? -1 : fd;
675 /* Open a new temp file. Return error (-1) if the file already exists.
676 Special options for VMS allow the file to be shared between parent and child
677 processes, however they really slow down output. Used in gnatchop. */
680 __gnat_open_new_temp (char *path, int fmode)
683 int o_fmode = O_BINARY;
685 strcpy (path, "GNAT-XXXXXX");
687 #if (defined (__FreeBSD__) || defined (linux)) && !defined (__vxworks)
688 return mkstemp (path);
689 #elif defined (__Lynx__)
692 if (mktemp (path) == NULL)
700 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
701 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
702 "mbc=16", "deq=64", "fop=tef");
704 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
707 return fd < 0 ? -1 : fd;
710 /* Return the number of bytes in the specified file. */
713 __gnat_file_length (int fd)
718 ret = fstat (fd, &statbuf);
719 if (ret || !S_ISREG (statbuf.st_mode))
722 return (statbuf.st_size);
725 /* Return the number of bytes in the specified named file. */
728 __gnat_named_file_length (char *name)
733 ret = __gnat_stat (name, &statbuf);
734 if (ret || !S_ISREG (statbuf.st_mode))
737 return (statbuf.st_size);
740 /* Create a temporary filename and put it in string pointed to by
744 __gnat_tmp_name (char *tmp_filename)
750 /* tempnam tries to create a temporary file in directory pointed to by
751 TMP environment variable, in c:\temp if TMP is not set, and in
752 directory specified by P_tmpdir in stdio.h if c:\temp does not
753 exist. The filename will be created with the prefix "gnat-". */
755 pname = (char *) tempnam ("c:\\temp", "gnat-");
757 /* if pname is NULL, the file was not created properly, the disk is full
758 or there is no more free temporary files */
761 *tmp_filename = '\0';
763 /* If pname start with a back slash and not path information it means that
764 the filename is valid for the current working directory. */
766 else if (pname[0] == '\\')
768 strcpy (tmp_filename, ".\\");
769 strcat (tmp_filename, pname+1);
772 strcpy (tmp_filename, pname);
777 #elif defined (linux) || defined (__FreeBSD__)
778 #define MAX_SAFE_PATH 1000
779 char *tmpdir = getenv ("TMPDIR");
781 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
782 a buffer overflow. */
783 if (tmpdir == NULL || strlen (tmpdir) > MAX_SAFE_PATH)
784 strcpy (tmp_filename, "/tmp/gnat-XXXXXX");
786 sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
788 close (mkstemp(tmp_filename));
790 tmpnam (tmp_filename);
794 /* Read the next entry in a directory. The returned string points somewhere
798 __gnat_readdir (DIR *dirp, char *buffer)
800 /* If possible, try to use the thread-safe version. */
801 #ifdef HAVE_READDIR_R
802 if (readdir_r (dirp, buffer) != NULL)
803 return ((struct dirent*) buffer)->d_name;
808 struct dirent *dirent = readdir (dirp);
812 strcpy (buffer, dirent->d_name);
821 /* Returns 1 if readdir is thread safe, 0 otherwise. */
824 __gnat_readdir_is_thread_safe (void)
826 #ifdef HAVE_READDIR_R
834 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
835 static const unsigned long long w32_epoch_offset = 11644473600ULL;
837 /* Returns the file modification timestamp using Win32 routines which are
838 immune against daylight saving time change. It is in fact not possible to
839 use fstat for this purpose as the DST modify the st_mtime field of the
843 win32_filetime (HANDLE h)
848 unsigned long long ull_time;
851 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
852 since <Jan 1st 1601>. This function must return the number of seconds
853 since <Jan 1st 1970>. */
855 if (GetFileTime (h, NULL, NULL, &t_write.ft_time))
856 return (time_t) (t_write.ull_time / 10000000ULL
862 /* Return a GNAT time stamp given a file name. */
865 __gnat_file_time_name (char *name)
868 #if defined (__EMX__) || defined (MSDOS)
869 int fd = open (name, O_RDONLY | O_BINARY);
870 time_t ret = __gnat_file_time_fd (fd);
874 #elif defined (_WIN32)
876 HANDLE h = CreateFile (name, GENERIC_READ, FILE_SHARE_READ, 0,
877 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
879 if (h != INVALID_HANDLE_VALUE)
881 ret = win32_filetime (h);
887 (void) __gnat_stat (name, &statbuf);
889 /* VMS has file versioning. */
890 return statbuf.st_ctime;
892 return statbuf.st_mtime;
897 /* Return a GNAT time stamp given a file descriptor. */
900 __gnat_file_time_fd (int fd)
902 /* The following workaround code is due to the fact that under EMX and
903 DJGPP fstat attempts to convert time values to GMT rather than keep the
904 actual OS timestamp of the file. By using the OS2/DOS functions directly
905 the GNAT timestamp are independent of this behavior, which is desired to
906 facilitate the distribution of GNAT compiled libraries. */
908 #if defined (__EMX__) || defined (MSDOS)
912 int ret = DosQueryFileInfo (fd, 1, (unsigned char *) &fs,
913 sizeof (FILESTATUS));
915 unsigned file_year = fs.fdateLastWrite.year;
916 unsigned file_month = fs.fdateLastWrite.month;
917 unsigned file_day = fs.fdateLastWrite.day;
918 unsigned file_hour = fs.ftimeLastWrite.hours;
919 unsigned file_min = fs.ftimeLastWrite.minutes;
920 unsigned file_tsec = fs.ftimeLastWrite.twosecs;
924 int ret = getftime (fd, &fs);
926 unsigned file_year = fs.ft_year;
927 unsigned file_month = fs.ft_month;
928 unsigned file_day = fs.ft_day;
929 unsigned file_hour = fs.ft_hour;
930 unsigned file_min = fs.ft_min;
931 unsigned file_tsec = fs.ft_tsec;
934 /* Calculate the seconds since epoch from the time components. First count
935 the whole days passed. The value for years returned by the DOS and OS2
936 functions count years from 1980, so to compensate for the UNIX epoch which
937 begins in 1970 start with 10 years worth of days and add days for each
938 four year period since then. */
941 int cum_days[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
942 int days_passed = 3652 + (file_year / 4) * 1461;
943 int years_since_leap = file_year % 4;
945 if (years_since_leap == 1)
947 else if (years_since_leap == 2)
949 else if (years_since_leap == 3)
955 days_passed += cum_days[file_month - 1];
956 if (years_since_leap == 0 && file_year != 20 && file_month > 2)
959 days_passed += file_day - 1;
961 /* OK - have whole days. Multiply -- then add in other parts. */
963 tot_secs = days_passed * 86400;
964 tot_secs += file_hour * 3600;
965 tot_secs += file_min * 60;
966 tot_secs += file_tsec * 2;
969 #elif defined (_WIN32)
970 HANDLE h = (HANDLE) _get_osfhandle (fd);
971 time_t ret = win32_filetime (h);
977 (void) fstat (fd, &statbuf);
980 /* VMS has file versioning. */
981 return statbuf.st_ctime;
983 return statbuf.st_mtime;
988 /* Set the file time stamp. */
991 __gnat_set_file_time_name (char *name, time_t time_stamp)
993 #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
995 /* Code to implement __gnat_set_file_time_name for these systems. */
997 #elif defined (_WIN32)
1001 unsigned long long ull_time;
1004 HANDLE h = CreateFile (name, GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
1005 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS,
1007 if (h == INVALID_HANDLE_VALUE)
1009 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1010 t_write.ull_time = ((unsigned long long)time_stamp + w32_epoch_offset);
1011 /* Convert to 100 nanosecond units */
1012 t_write.ull_time *= 10000000ULL;
1014 SetFileTime(h, NULL, NULL, &t_write.ft_time);
1024 unsigned long long backup, create, expire, revise;
1028 unsigned short value;
1031 unsigned system : 4;
1037 } Fat = { 0, 0, 0, 0, 0, { 0 }};
1041 { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create },
1042 { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise },
1043 { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire },
1044 { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup },
1045 { ATR$S_FPRO, ATR$C_FPRO, &Fat.prot },
1046 { ATR$S_UIC, ATR$C_UIC, &Fat.uic },
1051 struct dsc$descriptor_fib fibdsc = {sizeof (fib), (void *) &fib};
1055 unsigned long long newtime;
1056 unsigned long long revtime;
1060 struct vstring file;
1061 struct dsc$descriptor_s filedsc
1062 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) file.string};
1063 struct vstring device;
1064 struct dsc$descriptor_s devicedsc
1065 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) device.string};
1066 struct vstring timev;
1067 struct dsc$descriptor_s timedsc
1068 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) timev.string};
1069 struct vstring result;
1070 struct dsc$descriptor_s resultdsc
1071 = {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string};
1073 tryfile = (char *) __gnat_to_host_dir_spec (name, 0);
1075 /* Allocate and initialize a FAB and NAM structures. */
1079 nam.nam$l_esa = file.string;
1080 nam.nam$b_ess = NAM$C_MAXRSS;
1081 nam.nam$l_rsa = result.string;
1082 nam.nam$b_rss = NAM$C_MAXRSS;
1083 fab.fab$l_fna = tryfile;
1084 fab.fab$b_fns = strlen (tryfile);
1085 fab.fab$l_nam = &nam;
1087 /* Validate filespec syntax and device existence. */
1088 status = SYS$PARSE (&fab, 0, 0);
1089 if ((status & 1) != 1)
1090 LIB$SIGNAL (status);
1092 file.string[nam.nam$b_esl] = 0;
1094 /* Find matching filespec. */
1095 status = SYS$SEARCH (&fab, 0, 0);
1096 if ((status & 1) != 1)
1097 LIB$SIGNAL (status);
1099 file.string[nam.nam$b_esl] = 0;
1100 result.string[result.length=nam.nam$b_rsl] = 0;
1102 /* Get the device name and assign an IO channel. */
1103 strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev);
1104 devicedsc.dsc$w_length = nam.nam$b_dev;
1106 status = SYS$ASSIGN (&devicedsc, &chan, 0, 0, 0);
1107 if ((status & 1) != 1)
1108 LIB$SIGNAL (status);
1110 /* Initialize the FIB and fill in the directory id field. */
1111 memset (&fib, 0, sizeof (fib));
1112 fib.fib$w_did[0] = nam.nam$w_did[0];
1113 fib.fib$w_did[1] = nam.nam$w_did[1];
1114 fib.fib$w_did[2] = nam.nam$w_did[2];
1115 fib.fib$l_acctl = 0;
1117 strcpy (file.string, (strrchr (result.string, ']') + 1));
1118 filedsc.dsc$w_length = strlen (file.string);
1119 result.string[result.length = 0] = 0;
1121 /* Open and close the file to fill in the attributes. */
1123 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1124 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1125 if ((status & 1) != 1)
1126 LIB$SIGNAL (status);
1127 if ((iosb.status & 1) != 1)
1128 LIB$SIGNAL (iosb.status);
1130 result.string[result.length] = 0;
1131 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, &fibdsc, 0, 0, 0,
1133 if ((status & 1) != 1)
1134 LIB$SIGNAL (status);
1135 if ((iosb.status & 1) != 1)
1136 LIB$SIGNAL (iosb.status);
1141 /* Set creation time to requested time. */
1142 unix_time_to_vms (time_stamp, newtime);
1144 t = time ((time_t) 0);
1146 /* Set revision time to now in local time. */
1147 unix_time_to_vms (t, revtime);
1150 /* Reopen the file, modify the times and then close. */
1151 fib.fib$l_acctl = FIB$M_WRITE;
1153 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1154 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1155 if ((status & 1) != 1)
1156 LIB$SIGNAL (status);
1157 if ((iosb.status & 1) != 1)
1158 LIB$SIGNAL (iosb.status);
1160 Fat.create = newtime;
1161 Fat.revise = revtime;
1163 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0,
1164 &fibdsc, 0, 0, 0, &atrlst, 0);
1165 if ((status & 1) != 1)
1166 LIB$SIGNAL (status);
1167 if ((iosb.status & 1) != 1)
1168 LIB$SIGNAL (iosb.status);
1170 /* Deassign the channel and exit. */
1171 status = SYS$DASSGN (chan);
1172 if ((status & 1) != 1)
1173 LIB$SIGNAL (status);
1175 struct utimbuf utimbuf;
1178 /* Set modification time to requested time. */
1179 utimbuf.modtime = time_stamp;
1181 /* Set access time to now in local time. */
1182 t = time ((time_t) 0);
1183 utimbuf.actime = mktime (localtime (&t));
1185 utime (name, &utimbuf);
1190 __gnat_get_env_value_ptr (char *name, int *len, char **value)
1192 *value = getenv (name);
1196 *len = strlen (*value);
1201 /* VMS specific declarations for set_env_value. */
1205 static char *to_host_path_spec (char *);
1209 unsigned short len, mbz;
1213 typedef struct _ile3
1215 unsigned short len, code;
1217 unsigned short *retlen_adr;
1223 __gnat_set_env_value (char *name, char *value)
1228 struct descriptor_s name_desc;
1229 /* Put in JOB table for now, so that the project stuff at least works. */
1230 struct descriptor_s table_desc = {7, 0, "LNM$JOB"};
1231 char *host_pathspec = value;
1232 char *copy_pathspec;
1233 int num_dirs_in_pathspec = 1;
1237 name_desc.len = strlen (name);
1239 name_desc.adr = name;
1241 if (*host_pathspec == 0)
1244 status = LIB$DELETE_LOGICAL (&name_desc, &table_desc);
1245 /* no need to check status; if the logical name is not
1246 defined, that's fine. */
1250 ptr = host_pathspec;
1253 num_dirs_in_pathspec++;
1257 ile_s *ile_array = alloca (sizeof (ile_s) * (num_dirs_in_pathspec + 1));
1258 char *copy_pathspec = alloca (strlen (host_pathspec) + 1);
1261 strcpy (copy_pathspec, host_pathspec);
1262 curr = copy_pathspec;
1263 for (i = 0; i < num_dirs_in_pathspec; i++)
1265 next = strchr (curr, ',');
1267 next = strchr (curr, 0);
1270 ile_array[i].len = strlen (curr);
1272 /* Code 2 from lnmdef.h means its a string. */
1273 ile_array[i].code = 2;
1274 ile_array[i].adr = curr;
1276 /* retlen_adr is ignored. */
1277 ile_array[i].retlen_adr = 0;
1281 /* Terminating item must be zero. */
1282 ile_array[i].len = 0;
1283 ile_array[i].code = 0;
1284 ile_array[i].adr = 0;
1285 ile_array[i].retlen_adr = 0;
1287 status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array);
1288 if ((status & 1) != 1)
1289 LIB$SIGNAL (status);
1293 int size = strlen (name) + strlen (value) + 2;
1296 expression = (char *) xmalloc (size * sizeof (char));
1298 sprintf (expression, "%s=%s", name, value);
1299 putenv (expression);
1304 #include <windows.h>
1307 /* Get the list of installed standard libraries from the
1308 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1312 __gnat_get_libraries_from_registry (void)
1314 char *result = (char *) "";
1316 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_COMPILE)
1319 DWORD name_size, value_size;
1326 /* First open the key. */
1327 res = RegOpenKeyExA (HKEY_LOCAL_MACHINE, "SOFTWARE", 0, KEY_READ, ®_key);
1329 if (res == ERROR_SUCCESS)
1330 res = RegOpenKeyExA (reg_key, "Ada Core Technologies", 0,
1331 KEY_READ, ®_key);
1333 if (res == ERROR_SUCCESS)
1334 res = RegOpenKeyExA (reg_key, "GNAT", 0, KEY_READ, ®_key);
1336 if (res == ERROR_SUCCESS)
1337 res = RegOpenKeyExA (reg_key, "Standard Libraries", 0, KEY_READ, ®_key);
1339 /* If the key exists, read out all the values in it and concatenate them
1341 for (index = 0; res == ERROR_SUCCESS; index++)
1343 value_size = name_size = 256;
1344 res = RegEnumValue (reg_key, index, name, &name_size, 0,
1345 &type, value, &value_size);
1347 if (res == ERROR_SUCCESS && type == REG_SZ)
1349 char *old_result = result;
1351 result = (char *) xmalloc (strlen (old_result) + value_size + 2);
1352 strcpy (result, old_result);
1353 strcat (result, value);
1354 strcat (result, ";");
1358 /* Remove the trailing ";". */
1360 result[strlen (result) - 1] = 0;
1367 __gnat_stat (char *name, struct stat *statbuf)
1370 /* Under Windows the directory name for the stat function must not be
1371 terminated by a directory separator except if just after a drive name. */
1372 int name_len = strlen (name);
1373 char last_char = name[name_len - 1];
1374 char win32_name[GNAT_MAX_PATH_LEN + 2];
1376 if (name_len > GNAT_MAX_PATH_LEN)
1379 strcpy (win32_name, name);
1381 while (name_len > 1 && (last_char == '\\' || last_char == '/'))
1383 win32_name[name_len - 1] = '\0';
1385 last_char = win32_name[name_len - 1];
1388 if (name_len == 2 && win32_name[1] == ':')
1389 strcat (win32_name, "\\");
1391 return stat (win32_name, statbuf);
1394 return stat (name, statbuf);
1399 __gnat_file_exists (char *name)
1401 struct stat statbuf;
1403 return !__gnat_stat (name, &statbuf);
1407 __gnat_is_absolute_path (char *name)
1409 return (*name == '/' || *name == DIR_SEPARATOR
1410 #if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
1411 || (strlen (name) > 1 && isalpha (name[0]) && name[1] == ':')
1417 __gnat_is_regular_file (char *name)
1420 struct stat statbuf;
1422 ret = __gnat_stat (name, &statbuf);
1423 return (!ret && S_ISREG (statbuf.st_mode));
1427 __gnat_is_directory (char *name)
1430 struct stat statbuf;
1432 ret = __gnat_stat (name, &statbuf);
1433 return (!ret && S_ISDIR (statbuf.st_mode));
1437 __gnat_is_readable_file (char *name)
1441 struct stat statbuf;
1443 ret = __gnat_stat (name, &statbuf);
1444 mode = statbuf.st_mode & S_IRUSR;
1445 return (!ret && mode);
1449 __gnat_is_writable_file (char *name)
1453 struct stat statbuf;
1455 ret = __gnat_stat (name, &statbuf);
1456 mode = statbuf.st_mode & S_IWUSR;
1457 return (!ret && mode);
1461 __gnat_set_writable (char *name)
1464 struct stat statbuf;
1466 if (stat (name, &statbuf) == 0)
1468 statbuf.st_mode = statbuf.st_mode | S_IWUSR;
1469 chmod (name, statbuf.st_mode);
1475 __gnat_set_executable (char *name)
1478 struct stat statbuf;
1480 if (stat (name, &statbuf) == 0)
1482 statbuf.st_mode = statbuf.st_mode | S_IXUSR;
1483 chmod (name, statbuf.st_mode);
1489 __gnat_set_readonly (char *name)
1492 struct stat statbuf;
1494 if (stat (name, &statbuf) == 0)
1496 statbuf.st_mode = statbuf.st_mode & 07577;
1497 chmod (name, statbuf.st_mode);
1503 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED)
1505 #if defined (__vxworks)
1508 #elif defined (_AIX) || defined (unix)
1510 struct stat statbuf;
1512 ret = lstat (name, &statbuf);
1513 return (!ret && S_ISLNK (statbuf.st_mode));
1521 /* Defined in VMS header files. */
1522 #if defined (__ALPHA)
1523 #define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
1524 LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1)
1525 #elif defined (__IA64)
1526 #define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
1527 LIB$I64_GET_CURR_INVO_CONTEXT(decc$$get_vfork_jmpbuf()) : -1)
1531 #if defined (sun) && defined (__SVR4)
1532 /* Using fork on Solaris will duplicate all the threads. fork1, which
1533 duplicates only the active thread, must be used instead, or spawning
1534 subprocess from a program with tasking will lead into numerous problems. */
1539 __gnat_portable_spawn (char *args[])
1542 int finished ATTRIBUTE_UNUSED;
1543 int pid ATTRIBUTE_UNUSED;
1545 #if defined (MSDOS) || defined (_WIN32)
1546 status = spawnvp (P_WAIT, args[0],(const char* const*)args);
1552 #elif defined (__vxworks)
1557 pid = spawnvp (P_NOWAIT, args[0], args);
1569 if (execv (args[0], args) != 0)
1571 return -1; /* execv is in parent context on VMS. */
1579 finished = waitpid (pid, &status, 0);
1581 if (finished != pid || WIFEXITED (status) == 0)
1584 return WEXITSTATUS (status);
1590 /* WIN32 code to implement a wait call that wait for any child process. */
1594 /* Synchronization code, to be thread safe. */
1596 static CRITICAL_SECTION plist_cs;
1599 __gnat_plist_init (void)
1601 InitializeCriticalSection (&plist_cs);
1607 EnterCriticalSection (&plist_cs);
1613 LeaveCriticalSection (&plist_cs);
1616 typedef struct _process_list
1619 struct _process_list *next;
1622 static Process_List *PLIST = NULL;
1624 static int plist_length = 0;
1627 add_handle (HANDLE h)
1631 pl = (Process_List *) xmalloc (sizeof (Process_List));
1635 /* -------------------- critical section -------------------- */
1640 /* -------------------- critical section -------------------- */
1646 remove_handle (HANDLE h)
1649 Process_List *prev = NULL;
1653 /* -------------------- critical section -------------------- */
1662 prev->next = pl->next;
1674 /* -------------------- critical section -------------------- */
1680 win32_no_block_spawn (char *command, char *args[])
1684 PROCESS_INFORMATION PI;
1685 SECURITY_ATTRIBUTES SA;
1690 /* compute the total command line length */
1694 csize += strlen (args[k]) + 1;
1698 full_command = (char *) xmalloc (csize);
1701 SI.cb = sizeof (STARTUPINFO);
1702 SI.lpReserved = NULL;
1703 SI.lpReserved2 = NULL;
1704 SI.lpDesktop = NULL;
1708 SI.wShowWindow = SW_HIDE;
1710 /* Security attributes. */
1711 SA.nLength = sizeof (SECURITY_ATTRIBUTES);
1712 SA.bInheritHandle = TRUE;
1713 SA.lpSecurityDescriptor = NULL;
1715 /* Prepare the command string. */
1716 strcpy (full_command, command);
1717 strcat (full_command, " ");
1722 strcat (full_command, args[k]);
1723 strcat (full_command, " ");
1727 result = CreateProcess (NULL, (char *) full_command, &SA, NULL, TRUE,
1728 NORMAL_PRIORITY_CLASS, NULL, NULL, &SI, &PI);
1730 free (full_command);
1734 add_handle (PI.hProcess);
1735 CloseHandle (PI.hThread);
1736 return (int) PI.hProcess;
1743 win32_wait (int *status)
1752 if (plist_length == 0)
1758 hl = (HANDLE *) xmalloc (sizeof (HANDLE) * plist_length);
1763 /* -------------------- critical section -------------------- */
1770 /* -------------------- critical section -------------------- */
1774 res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE);
1775 h = hl[res - WAIT_OBJECT_0];
1780 GetExitCodeProcess (h, &exitcode);
1783 *status = (int) exitcode;
1790 __gnat_portable_no_block_spawn (char *args[])
1794 #if defined (__EMX__) || defined (MSDOS)
1796 /* ??? For PC machines I (Franco) don't know the system calls to implement
1797 this routine. So I'll fake it as follows. This routine will behave
1798 exactly like the blocking portable_spawn and will systematically return
1799 a pid of 0 unless the spawned task did not complete successfully, in
1800 which case we return a pid of -1. To synchronize with this the
1801 portable_wait below systematically returns a pid of 0 and reports that
1802 the subprocess terminated successfully. */
1804 if (spawnvp (P_WAIT, args[0], args) != 0)
1807 #elif defined (_WIN32)
1809 pid = win32_no_block_spawn (args[0], args);
1812 #elif defined (__vxworks)
1821 if (execv (args[0], args) != 0)
1823 return -1; /* execv is in parent context on VMS. */
1835 __gnat_portable_wait (int *process_status)
1840 #if defined (_WIN32)
1842 pid = win32_wait (&status);
1844 #elif defined (__EMX__) || defined (MSDOS)
1845 /* ??? See corresponding comment in portable_no_block_spawn. */
1847 #elif defined (__vxworks)
1848 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
1852 pid = waitpid (-1, &status, 0);
1853 status = status & 0xffff;
1856 *process_status = status;
1861 __gnat_waitpid (int pid)
1865 #if defined (_WIN32)
1866 cwait (&status, pid, _WAIT_CHILD);
1867 #elif defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1868 /* Status is already zero, so nothing to do. */
1870 waitpid (pid, &status, 0);
1871 status = WEXITSTATUS (status);
1878 __gnat_os_exit (int status)
1883 /* Locate a regular file, give a Path value. */
1886 __gnat_locate_regular_file (char *file_name, char *path_val)
1889 int absolute = __gnat_is_absolute_path (file_name);
1891 /* Handle absolute pathnames. */
1894 if (__gnat_is_regular_file (file_name))
1895 return xstrdup (file_name);
1900 /* If file_name include directory separator(s), try it first as
1901 a path name relative to the current directory */
1902 for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
1907 if (__gnat_is_regular_file (file_name))
1908 return xstrdup (file_name);
1915 /* The result has to be smaller than path_val + file_name. */
1916 char *file_path = alloca (strlen (path_val) + strlen (file_name) + 2);
1920 for (; *path_val == PATH_SEPARATOR; path_val++)
1926 for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
1927 *ptr++ = *path_val++;
1930 if (*ptr != '/' && *ptr != DIR_SEPARATOR)
1931 *++ptr = DIR_SEPARATOR;
1933 strcpy (++ptr, file_name);
1935 if (__gnat_is_regular_file (file_path))
1936 return xstrdup (file_path);
1943 /* Locate an executable given a Path argument. This routine is only used by
1944 gnatbl and should not be used otherwise. Use locate_exec_on_path
1948 __gnat_locate_exec (char *exec_name, char *path_val)
1950 if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
1952 char *full_exec_name
1953 = alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
1955 strcpy (full_exec_name, exec_name);
1956 strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
1957 return __gnat_locate_regular_file (full_exec_name, path_val);
1960 return __gnat_locate_regular_file (exec_name, path_val);
1963 /* Locate an executable using the Systems default PATH. */
1966 __gnat_locate_exec_on_path (char *exec_name)
1970 char *path_val = "/VAXC$PATH";
1972 char *path_val = getenv ("PATH");
1975 /* In Win32 systems we expand the PATH as for XP environment
1976 variables are not automatically expanded. */
1977 int len = strlen (path_val) * 3;
1978 char *expanded_path_val = alloca (len + 1);
1980 DWORD res = ExpandEnvironmentStrings (path_val, expanded_path_val, len);
1984 path_val = expanded_path_val;
1988 apath_val = alloca (strlen (path_val) + 1);
1989 strcpy (apath_val, path_val);
1991 return __gnat_locate_exec (exec_name, apath_val);
1996 /* These functions are used to translate to and from VMS and Unix syntax
1997 file, directory and path specifications. */
2000 #define MAXNAMES 256
2001 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2003 static char new_canonical_dirspec [MAXPATH];
2004 static char new_canonical_filespec [MAXPATH];
2005 static char new_canonical_pathspec [MAXNAMES*MAXPATH];
2006 static unsigned new_canonical_filelist_index;
2007 static unsigned new_canonical_filelist_in_use;
2008 static unsigned new_canonical_filelist_allocated;
2009 static char **new_canonical_filelist;
2010 static char new_host_pathspec [MAXNAMES*MAXPATH];
2011 static char new_host_dirspec [MAXPATH];
2012 static char new_host_filespec [MAXPATH];
2014 /* Routine is called repeatedly by decc$from_vms via
2015 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2019 wildcard_translate_unix (char *name)
2022 char buff [MAXPATH];
2024 strncpy (buff, name, MAXPATH);
2025 buff [MAXPATH - 1] = (char) 0;
2026 ver = strrchr (buff, '.');
2028 /* Chop off the version. */
2032 /* Dynamically extend the allocation by the increment. */
2033 if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
2035 new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
2036 new_canonical_filelist = (char **) xrealloc
2037 (new_canonical_filelist,
2038 new_canonical_filelist_allocated * sizeof (char *));
2041 new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
2046 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2047 full translation and copy the results into a list (_init), then return them
2048 one at a time (_next). If onlydirs set, only expand directory files. */
2051 __gnat_to_canonical_file_list_init (char *filespec, int onlydirs)
2054 char buff [MAXPATH];
2056 len = strlen (filespec);
2057 strncpy (buff, filespec, MAXPATH);
2059 /* Only look for directories */
2060 if (onlydirs && !strstr (&buff [len-5], "*.dir"))
2061 strncat (buff, "*.dir", MAXPATH);
2063 buff [MAXPATH - 1] = (char) 0;
2065 decc$from_vms (buff, wildcard_translate_unix, 1);
2067 /* Remove the .dir extension. */
2073 for (i = 0; i < new_canonical_filelist_in_use; i++)
2075 ext = strstr (new_canonical_filelist[i], ".dir");
2081 return new_canonical_filelist_in_use;
2084 /* Return the next filespec in the list. */
2087 __gnat_to_canonical_file_list_next ()
2089 return new_canonical_filelist[new_canonical_filelist_index++];
2092 /* Free storage used in the wildcard expansion. */
2095 __gnat_to_canonical_file_list_free ()
2099 for (i = 0; i < new_canonical_filelist_in_use; i++)
2100 free (new_canonical_filelist[i]);
2102 free (new_canonical_filelist);
2104 new_canonical_filelist_in_use = 0;
2105 new_canonical_filelist_allocated = 0;
2106 new_canonical_filelist_index = 0;
2107 new_canonical_filelist = 0;
2110 /* Translate a VMS syntax directory specification in to Unix syntax. If
2111 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2112 found, return input string. Also translate a dirname that contains no
2113 slashes, in case it's a logical name. */
2116 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag)
2120 strcpy (new_canonical_dirspec, "");
2121 if (strlen (dirspec))
2125 if (strchr (dirspec, ']') || strchr (dirspec, ':'))
2127 strncpy (new_canonical_dirspec,
2128 (char *) decc$translate_vms (dirspec),
2131 else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
2133 strncpy (new_canonical_dirspec,
2134 (char *) decc$translate_vms (dirspec1),
2139 strncpy (new_canonical_dirspec, dirspec, MAXPATH);
2143 len = strlen (new_canonical_dirspec);
2144 if (prefixflag && new_canonical_dirspec [len-1] != '/')
2145 strncat (new_canonical_dirspec, "/", MAXPATH);
2147 new_canonical_dirspec [MAXPATH - 1] = (char) 0;
2149 return new_canonical_dirspec;
2153 /* Translate a VMS syntax file specification into Unix syntax.
2154 If no indicators of VMS syntax found, return input string. */
2157 __gnat_to_canonical_file_spec (char *filespec)
2159 strncpy (new_canonical_filespec, "", MAXPATH);
2161 if (strchr (filespec, ']') || strchr (filespec, ':'))
2163 strncpy (new_canonical_filespec,
2164 (char *) decc$translate_vms (filespec),
2169 strncpy (new_canonical_filespec, filespec, MAXPATH);
2172 new_canonical_filespec [MAXPATH - 1] = (char) 0;
2174 return new_canonical_filespec;
2177 /* Translate a VMS syntax path specification into Unix syntax.
2178 If no indicators of VMS syntax found, return input string. */
2181 __gnat_to_canonical_path_spec (char *pathspec)
2183 char *curr, *next, buff [MAXPATH];
2188 /* If there are /'s, assume it's a Unix path spec and return. */
2189 if (strchr (pathspec, '/'))
2192 new_canonical_pathspec[0] = 0;
2197 next = strchr (curr, ',');
2199 next = strchr (curr, 0);
2201 strncpy (buff, curr, next - curr);
2202 buff[next - curr] = 0;
2204 /* Check for wildcards and expand if present. */
2205 if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
2209 dirs = __gnat_to_canonical_file_list_init (buff, 1);
2210 for (i = 0; i < dirs; i++)
2214 next_dir = __gnat_to_canonical_file_list_next ();
2215 strncat (new_canonical_pathspec, next_dir, MAXPATH);
2217 /* Don't append the separator after the last expansion. */
2219 strncat (new_canonical_pathspec, ":", MAXPATH);
2222 __gnat_to_canonical_file_list_free ();
2225 strncat (new_canonical_pathspec,
2226 __gnat_to_canonical_dir_spec (buff, 0), MAXPATH);
2231 strncat (new_canonical_pathspec, ":", MAXPATH);
2235 new_canonical_pathspec [MAXPATH - 1] = (char) 0;
2237 return new_canonical_pathspec;
2240 static char filename_buff [MAXPATH];
2243 translate_unix (char *name, int type)
2245 strncpy (filename_buff, name, MAXPATH);
2246 filename_buff [MAXPATH - 1] = (char) 0;
2250 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
2254 to_host_path_spec (char *pathspec)
2256 char *curr, *next, buff [MAXPATH];
2261 /* Can't very well test for colons, since that's the Unix separator! */
2262 if (strchr (pathspec, ']') || strchr (pathspec, ','))
2265 new_host_pathspec[0] = 0;
2270 next = strchr (curr, ':');
2272 next = strchr (curr, 0);
2274 strncpy (buff, curr, next - curr);
2275 buff[next - curr] = 0;
2277 strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH);
2280 strncat (new_host_pathspec, ",", MAXPATH);
2284 new_host_pathspec [MAXPATH - 1] = (char) 0;
2286 return new_host_pathspec;
2289 /* Translate a Unix syntax directory specification into VMS syntax. The
2290 PREFIXFLAG has no effect, but is kept for symmetry with
2291 to_canonical_dir_spec. If indicators of VMS syntax found, return input
2295 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2297 int len = strlen (dirspec);
2299 strncpy (new_host_dirspec, dirspec, MAXPATH);
2300 new_host_dirspec [MAXPATH - 1] = (char) 0;
2302 if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
2303 return new_host_dirspec;
2305 while (len > 1 && new_host_dirspec[len - 1] == '/')
2307 new_host_dirspec[len - 1] = 0;
2311 decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
2312 strncpy (new_host_dirspec, filename_buff, MAXPATH);
2313 new_host_dirspec [MAXPATH - 1] = (char) 0;
2315 return new_host_dirspec;
2318 /* Translate a Unix syntax file specification into VMS syntax.
2319 If indicators of VMS syntax found, return input string. */
2322 __gnat_to_host_file_spec (char *filespec)
2324 strncpy (new_host_filespec, "", MAXPATH);
2325 if (strchr (filespec, ']') || strchr (filespec, ':'))
2327 strncpy (new_host_filespec, filespec, MAXPATH);
2331 decc$to_vms (filespec, translate_unix, 1, 1);
2332 strncpy (new_host_filespec, filename_buff, MAXPATH);
2335 new_host_filespec [MAXPATH - 1] = (char) 0;
2337 return new_host_filespec;
2341 __gnat_adjust_os_resource_limits ()
2343 SYS$ADJWSL (131072, 0);
2348 /* Dummy functions for Osint import for non-VMS systems. */
2351 __gnat_to_canonical_file_list_init
2352 (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED)
2358 __gnat_to_canonical_file_list_next (void)
2364 __gnat_to_canonical_file_list_free (void)
2369 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2375 __gnat_to_canonical_file_spec (char *filespec)
2381 __gnat_to_canonical_path_spec (char *pathspec)
2387 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2393 __gnat_to_host_file_spec (char *filespec)
2399 __gnat_adjust_os_resource_limits (void)
2405 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
2406 to coordinate this with the EMX distribution. Consequently, we put the
2407 definition of dummy which is used for exception handling, here. */
2409 #if defined (__EMX__)
2413 #if defined (__mips_vxworks)
2417 CACHE_USER_FLUSH (0, ENTIRE_CACHE);
2421 #if defined (CROSS_COMPILE) \
2422 || (! (defined (sparc) && defined (sun) && defined (__SVR4)) \
2423 && ! (defined (linux) && defined (i386)) \
2424 && ! defined (__FreeBSD__) \
2425 && ! defined (hpux) \
2426 && ! defined (_AIX) \
2427 && ! (defined (__alpha__) && defined (__osf__)) \
2428 && ! defined (__MINGW32__))
2430 /* Dummy function to satisfy g-trasym.o. Currently Solaris sparc, HP/UX,
2431 GNU/Linux x86, Tru64 & Windows provide a non-dummy version of this
2432 procedure in libaddr2line.a. */
2435 convert_addresses (void *addrs ATTRIBUTE_UNUSED,
2436 int n_addr ATTRIBUTE_UNUSED,
2437 void *buf ATTRIBUTE_UNUSED,
2438 int *len ATTRIBUTE_UNUSED)
2444 #if defined (_WIN32)
2445 int __gnat_argument_needs_quote = 1;
2447 int __gnat_argument_needs_quote = 0;
2450 /* This option is used to enable/disable object files handling from the
2451 binder file by the GNAT Project module. For example, this is disabled on
2452 Windows as it is already done by the mdll module. */
2453 #if defined (_WIN32)
2454 int __gnat_prj_add_obj_files = 0;
2456 int __gnat_prj_add_obj_files = 1;
2459 /* char used as prefix/suffix for environment variables */
2460 #if defined (_WIN32)
2461 char __gnat_environment_char = '%';
2463 char __gnat_environment_char = '$';
2466 /* This functions copy the file attributes from a source file to a
2469 mode = 0 : In this mode copy only the file time stamps (last access and
2470 last modification time stamps).
2472 mode = 1 : In this mode, time stamps and read/write/execute attributes are
2475 Returns 0 if operation was successful and -1 in case of error. */
2478 __gnat_copy_attribs (char *from, char *to, int mode)
2480 #if defined (VMS) || defined (__vxworks)
2484 struct utimbuf tbuf;
2486 if (stat (from, &fbuf) == -1)
2491 tbuf.actime = fbuf.st_atime;
2492 tbuf.modtime = fbuf.st_mtime;
2494 if (utime (to, &tbuf) == -1)
2501 if (chmod (to, fbuf.st_mode) == -1)
2511 /* This function is installed in libgcc.a. */
2512 extern void __gnat_install_locks (void (*) (void), void (*) (void));
2514 /* This function offers a hook for libgnarl to set the
2515 locking subprograms for libgcc_eh.
2516 This is only needed on OpenVMS, since other platforms use standard
2517 --enable-threads=posix option, or similar. */
2520 __gnatlib_install_locks (void (*lock) (void) ATTRIBUTE_UNUSED,
2521 void (*unlock) (void) ATTRIBUTE_UNUSED)
2523 #if defined (IN_RTS) && defined (VMS)
2524 __gnat_install_locks (lock, unlock);
2525 /* There is a bootstrap path issue if adaint is build with this
2526 symbol unresolved for the stage1 compiler. Since the compiler
2527 does not use tasking, we simply make __gnatlib_install_locks
2528 a no-op in this case. */
2533 __gnat_lseek (int fd, long offset, int whence)
2535 return (int) lseek (fd, offset, whence);
2538 /* This function returns the version of GCC being used. Here it's GCC 3. */
2540 get_gcc_version (void)