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, 51 Franklin Street, Fifth Floor, *
20 * Boston, MA 02110-1301, USA. *
22 * As a special exception, if you link this file with other files to *
23 * produce an executable, this file does not by itself cause the resulting *
24 * executable to be covered by the GNU General Public License. This except- *
25 * ion does not however invalidate any other reasons why the executable *
26 * file might be covered by the GNU Public License. *
28 * GNAT was originally developed by the GNAT team at New York University. *
29 * Extensive contributions were provided by Ada Core Technologies Inc. *
31 ****************************************************************************/
33 /* This file contains those routines named by Import pragmas in
34 packages in the GNAT hierarchy (especially GNAT.OS_Lib) and in
35 package Osint. Many of the subprograms in OS_Lib import standard
36 library calls directly. This file contains all other routines. */
40 /* No need to redefine exit here. */
43 /* We want to use the POSIX variants of include files. */
47 #if defined (__mips_vxworks)
49 #endif /* __mips_vxworks */
55 #define HOST_EXECUTABLE_SUFFIX ".exe"
56 #define HOST_OBJECT_SUFFIX ".obj"
70 /* We don't have libiberty, so use malloc. */
71 #define xmalloc(S) malloc (S)
72 #define xrealloc(V,S) realloc (V,S)
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>
267 #define GNAT_MAX_PATH_LEN MAXPATHLEN
269 #define GNAT_MAX_PATH_LEN 256
274 /* The __gnat_max_path_len variable is used to export the maximum
275 length of a path name to Ada code. max_path_len is also provided
276 for compatibility with older GNAT versions, please do not use
279 int __gnat_max_path_len = GNAT_MAX_PATH_LEN;
280 int max_path_len = GNAT_MAX_PATH_LEN;
282 /* The following macro HAVE_READDIR_R should be defined if the
283 system provides the routine readdir_r. */
284 #undef HAVE_READDIR_R
286 #if defined(VMS) && defined (__LONG_POINTERS)
288 /* Return a 32 bit pointer to an array of 32 bit pointers
289 given a 64 bit pointer to an array of 64 bit pointers */
291 typedef __char_ptr32 *__char_ptr_char_ptr32 __attribute__ ((mode (SI)));
293 static __char_ptr_char_ptr32
294 to_ptr32 (char **ptr64)
297 __char_ptr_char_ptr32 short_argv;
299 for (argc=0; ptr64[argc]; argc++);
301 /* Reallocate argv with 32 bit pointers. */
302 short_argv = (__char_ptr_char_ptr32) decc$malloc
303 (sizeof (__char_ptr32) * (argc + 1));
305 for (argc=0; ptr64[argc]; argc++)
306 short_argv[argc] = (__char_ptr32) decc$strdup (ptr64[argc]);
308 short_argv[argc] = (__char_ptr32) 0;
312 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
314 #define MAYBE_TO_PTR32(argv) argv
328 time_t time = (time_t) *p_time;
331 /* On Windows systems, the time is sometimes rounded up to the nearest
332 even second, so if the number of seconds is odd, increment it. */
338 res = localtime (&time);
340 res = gmtime (&time);
345 *p_year = res->tm_year;
346 *p_month = res->tm_mon;
347 *p_day = res->tm_mday;
348 *p_hours = res->tm_hour;
349 *p_mins = res->tm_min;
350 *p_secs = res->tm_sec;
353 *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0;
356 /* Place the contents of the symbolic link named PATH in the buffer BUF,
357 which has size BUFSIZ. If PATH is a symbolic link, then return the number
358 of characters of its content in BUF. Otherwise, return -1. For Windows,
359 OS/2 and vxworks, always return -1. */
362 __gnat_readlink (char *path ATTRIBUTE_UNUSED,
363 char *buf ATTRIBUTE_UNUSED,
364 size_t bufsiz ATTRIBUTE_UNUSED)
366 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
368 #elif defined (__INTERIX) || defined (VMS)
370 #elif defined (__vxworks)
373 return readlink (path, buf, bufsiz);
377 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH. If
378 NEWPATH exists it will NOT be overwritten. For Windows, OS/2, VxWorks,
379 Interix and VMS, always return -1. */
382 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED,
383 char *newpath ATTRIBUTE_UNUSED)
385 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
387 #elif defined (__INTERIX) || defined (VMS)
389 #elif defined (__vxworks)
392 return symlink (oldpath, newpath);
396 /* Try to lock a file, return 1 if success. */
398 #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32)
400 /* Version that does not use link. */
403 __gnat_try_lock (char *dir, char *file)
408 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
409 fd = open (full_path, O_CREAT | O_EXCL, 0600);
417 #elif defined (__EMX__) || defined (VMS)
419 /* More cases that do not use link; identical code, to solve too long
423 __gnat_try_lock (char *dir, char *file)
428 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
429 fd = open (full_path, O_CREAT | O_EXCL, 0600);
439 /* Version using link(), more secure over NFS. */
440 /* See TN 6913-016 for discussion ??? */
443 __gnat_try_lock (char *dir, char *file)
447 struct stat stat_result;
450 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
451 sprintf (temp_file, "%s%cTMP-%ld-%ld",
452 dir, DIR_SEPARATOR, (long)getpid(), (long)getppid ());
454 /* Create the temporary file and write the process number. */
455 fd = open (temp_file, O_CREAT | O_WRONLY, 0600);
461 /* Link it with the new file. */
462 link (temp_file, full_path);
464 /* Count the references on the old one. If we have a count of two, then
465 the link did succeed. Remove the temporary file before returning. */
466 __gnat_stat (temp_file, &stat_result);
468 return stat_result.st_nlink == 2;
472 /* Return the maximum file name length. */
475 __gnat_get_maximum_file_name_length (void)
480 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
489 /* Return nonzero if file names are case sensitive. */
492 __gnat_get_file_names_case_sensitive (void)
494 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT)
502 __gnat_get_default_identifier_character_set (void)
504 #if defined (__EMX__) || defined (MSDOS)
511 /* Return the current working directory. */
514 __gnat_get_current_dir (char *dir, int *length)
517 /* Force Unix style, which is what GNAT uses internally. */
518 getcwd (dir, *length, 0);
520 getcwd (dir, *length);
523 *length = strlen (dir);
525 if (dir [*length - 1] != DIR_SEPARATOR)
527 dir [*length] = DIR_SEPARATOR;
533 /* Return the suffix for object files. */
536 __gnat_get_object_suffix_ptr (int *len, const char **value)
538 *value = HOST_OBJECT_SUFFIX;
543 *len = strlen (*value);
548 /* Return the suffix for executable files. */
551 __gnat_get_executable_suffix_ptr (int *len, const char **value)
553 *value = HOST_EXECUTABLE_SUFFIX;
557 *len = strlen (*value);
562 /* Return the suffix for debuggable files. Usually this is the same as the
563 executable extension. */
566 __gnat_get_debuggable_suffix_ptr (int *len, const char **value)
569 *value = HOST_EXECUTABLE_SUFFIX;
571 /* On DOS, the extensionless COFF file is what gdb likes. */
578 *len = strlen (*value);
584 __gnat_open_read (char *path, int fmode)
587 int o_fmode = O_BINARY;
593 /* Optional arguments mbc,deq,fop increase read performance. */
594 fd = open (path, O_RDONLY | o_fmode, 0444,
595 "mbc=16", "deq=64", "fop=tef");
596 #elif defined (__vxworks)
597 fd = open (path, O_RDONLY | o_fmode, 0444);
599 fd = open (path, O_RDONLY | o_fmode);
602 return fd < 0 ? -1 : fd;
605 #if defined (__EMX__) || defined (__MINGW32__)
606 #define PERM (S_IREAD | S_IWRITE)
608 /* Excerpt from DECC C RTL Reference Manual:
609 To create files with OpenVMS RMS default protections using the UNIX
610 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
611 and open with a file-protection mode argument of 0777 in a program
612 that never specifically calls umask. These default protections include
613 correctly establishing protections based on ACLs, previous versions of
617 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
621 __gnat_open_rw (char *path, int fmode)
624 int o_fmode = O_BINARY;
630 fd = open (path, O_RDWR | o_fmode, PERM,
631 "mbc=16", "deq=64", "fop=tef");
633 fd = open (path, O_RDWR | o_fmode, PERM);
636 return fd < 0 ? -1 : fd;
640 __gnat_open_create (char *path, int fmode)
643 int o_fmode = O_BINARY;
649 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM,
650 "mbc=16", "deq=64", "fop=tef");
652 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
655 return fd < 0 ? -1 : fd;
659 __gnat_create_output_file (char *path)
663 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM,
664 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
665 "shr=del,get,put,upd");
667 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
670 return fd < 0 ? -1 : fd;
674 __gnat_open_append (char *path, int fmode)
677 int o_fmode = O_BINARY;
683 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM,
684 "mbc=16", "deq=64", "fop=tef");
686 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
689 return fd < 0 ? -1 : fd;
692 /* Open a new file. Return error (-1) if the file already exists. */
695 __gnat_open_new (char *path, int fmode)
698 int o_fmode = O_BINARY;
704 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
705 "mbc=16", "deq=64", "fop=tef");
707 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
710 return fd < 0 ? -1 : fd;
713 /* Open a new temp file. Return error (-1) if the file already exists.
714 Special options for VMS allow the file to be shared between parent and child
715 processes, however they really slow down output. Used in gnatchop. */
718 __gnat_open_new_temp (char *path, int fmode)
721 int o_fmode = O_BINARY;
723 strcpy (path, "GNAT-XXXXXX");
725 #if (defined (__FreeBSD__) || defined (linux)) && !defined (__vxworks)
726 return mkstemp (path);
727 #elif defined (__Lynx__)
730 if (mktemp (path) == NULL)
738 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
739 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
740 "mbc=16", "deq=64", "fop=tef");
742 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
745 return fd < 0 ? -1 : fd;
748 /* Return the number of bytes in the specified file. */
751 __gnat_file_length (int fd)
756 ret = fstat (fd, &statbuf);
757 if (ret || !S_ISREG (statbuf.st_mode))
760 return (statbuf.st_size);
763 /* Return the number of bytes in the specified named file. */
766 __gnat_named_file_length (char *name)
771 ret = __gnat_stat (name, &statbuf);
772 if (ret || !S_ISREG (statbuf.st_mode))
775 return (statbuf.st_size);
778 /* Create a temporary filename and put it in string pointed to by
782 __gnat_tmp_name (char *tmp_filename)
788 /* tempnam tries to create a temporary file in directory pointed to by
789 TMP environment variable, in c:\temp if TMP is not set, and in
790 directory specified by P_tmpdir in stdio.h if c:\temp does not
791 exist. The filename will be created with the prefix "gnat-". */
793 pname = (char *) tempnam ("c:\\temp", "gnat-");
795 /* if pname is NULL, the file was not created properly, the disk is full
796 or there is no more free temporary files */
799 *tmp_filename = '\0';
801 /* If pname start with a back slash and not path information it means that
802 the filename is valid for the current working directory. */
804 else if (pname[0] == '\\')
806 strcpy (tmp_filename, ".\\");
807 strcat (tmp_filename, pname+1);
810 strcpy (tmp_filename, pname);
815 #elif defined (linux) || defined (__FreeBSD__)
816 #define MAX_SAFE_PATH 1000
817 char *tmpdir = getenv ("TMPDIR");
819 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
820 a buffer overflow. */
821 if (tmpdir == NULL || strlen (tmpdir) > MAX_SAFE_PATH)
822 strcpy (tmp_filename, "/tmp/gnat-XXXXXX");
824 sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
826 close (mkstemp(tmp_filename));
828 tmpnam (tmp_filename);
832 /* Read the next entry in a directory. The returned string points somewhere
836 __gnat_readdir (DIR *dirp, char *buffer)
838 /* If possible, try to use the thread-safe version. */
839 #ifdef HAVE_READDIR_R
840 if (readdir_r (dirp, buffer) != NULL)
841 return ((struct dirent*) buffer)->d_name;
846 struct dirent *dirent = (struct dirent *) readdir (dirp);
850 strcpy (buffer, dirent->d_name);
859 /* Returns 1 if readdir is thread safe, 0 otherwise. */
862 __gnat_readdir_is_thread_safe (void)
864 #ifdef HAVE_READDIR_R
872 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
873 static const unsigned long long w32_epoch_offset = 11644473600ULL;
875 /* Returns the file modification timestamp using Win32 routines which are
876 immune against daylight saving time change. It is in fact not possible to
877 use fstat for this purpose as the DST modify the st_mtime field of the
881 win32_filetime (HANDLE h)
886 unsigned long long ull_time;
889 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
890 since <Jan 1st 1601>. This function must return the number of seconds
891 since <Jan 1st 1970>. */
893 if (GetFileTime (h, NULL, NULL, &t_write.ft_time))
894 return (time_t) (t_write.ull_time / 10000000ULL
900 /* Return a GNAT time stamp given a file name. */
903 __gnat_file_time_name (char *name)
906 #if defined (__EMX__) || defined (MSDOS)
907 int fd = open (name, O_RDONLY | O_BINARY);
908 time_t ret = __gnat_file_time_fd (fd);
912 #elif defined (_WIN32)
914 HANDLE h = CreateFile (name, GENERIC_READ, FILE_SHARE_READ, 0,
915 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
917 if (h != INVALID_HANDLE_VALUE)
919 ret = win32_filetime (h);
922 return (OS_Time) ret;
925 if (__gnat_stat (name, &statbuf) != 0) {
929 /* VMS has file versioning. */
930 return (OS_Time)statbuf.st_ctime;
932 return (OS_Time)statbuf.st_mtime;
938 /* Return a GNAT time stamp given a file descriptor. */
941 __gnat_file_time_fd (int fd)
943 /* The following workaround code is due to the fact that under EMX and
944 DJGPP fstat attempts to convert time values to GMT rather than keep the
945 actual OS timestamp of the file. By using the OS2/DOS functions directly
946 the GNAT timestamp are independent of this behavior, which is desired to
947 facilitate the distribution of GNAT compiled libraries. */
949 #if defined (__EMX__) || defined (MSDOS)
953 int ret = DosQueryFileInfo (fd, 1, (unsigned char *) &fs,
954 sizeof (FILESTATUS));
956 unsigned file_year = fs.fdateLastWrite.year;
957 unsigned file_month = fs.fdateLastWrite.month;
958 unsigned file_day = fs.fdateLastWrite.day;
959 unsigned file_hour = fs.ftimeLastWrite.hours;
960 unsigned file_min = fs.ftimeLastWrite.minutes;
961 unsigned file_tsec = fs.ftimeLastWrite.twosecs;
965 int ret = getftime (fd, &fs);
967 unsigned file_year = fs.ft_year;
968 unsigned file_month = fs.ft_month;
969 unsigned file_day = fs.ft_day;
970 unsigned file_hour = fs.ft_hour;
971 unsigned file_min = fs.ft_min;
972 unsigned file_tsec = fs.ft_tsec;
975 /* Calculate the seconds since epoch from the time components. First count
976 the whole days passed. The value for years returned by the DOS and OS2
977 functions count years from 1980, so to compensate for the UNIX epoch which
978 begins in 1970 start with 10 years worth of days and add days for each
979 four year period since then. */
982 int cum_days[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
983 int days_passed = 3652 + (file_year / 4) * 1461;
984 int years_since_leap = file_year % 4;
986 if (years_since_leap == 1)
988 else if (years_since_leap == 2)
990 else if (years_since_leap == 3)
996 days_passed += cum_days[file_month - 1];
997 if (years_since_leap == 0 && file_year != 20 && file_month > 2)
1000 days_passed += file_day - 1;
1002 /* OK - have whole days. Multiply -- then add in other parts. */
1004 tot_secs = days_passed * 86400;
1005 tot_secs += file_hour * 3600;
1006 tot_secs += file_min * 60;
1007 tot_secs += file_tsec * 2;
1008 return (OS_Time) tot_secs;
1010 #elif defined (_WIN32)
1011 HANDLE h = (HANDLE) _get_osfhandle (fd);
1012 time_t ret = win32_filetime (h);
1013 return (OS_Time) ret;
1016 struct stat statbuf;
1018 if (fstat (fd, &statbuf) != 0) {
1019 return (OS_Time) -1;
1022 /* VMS has file versioning. */
1023 return (OS_Time) statbuf.st_ctime;
1025 return (OS_Time) statbuf.st_mtime;
1031 /* Set the file time stamp. */
1034 __gnat_set_file_time_name (char *name, time_t time_stamp)
1036 #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1038 /* Code to implement __gnat_set_file_time_name for these systems. */
1040 #elif defined (_WIN32)
1044 unsigned long long ull_time;
1047 HANDLE h = CreateFile (name, GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
1048 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS,
1050 if (h == INVALID_HANDLE_VALUE)
1052 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1053 t_write.ull_time = ((unsigned long long)time_stamp + w32_epoch_offset);
1054 /* Convert to 100 nanosecond units */
1055 t_write.ull_time *= 10000000ULL;
1057 SetFileTime(h, NULL, NULL, &t_write.ft_time);
1067 unsigned long long backup, create, expire, revise;
1071 unsigned short value;
1074 unsigned system : 4;
1080 } Fat = { 0, 0, 0, 0, 0, { 0 }};
1084 { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create },
1085 { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise },
1086 { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire },
1087 { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup },
1088 { ATR$S_FPRO, ATR$C_FPRO, &Fat.prot },
1089 { ATR$S_UIC, ATR$C_UIC, &Fat.uic },
1094 struct dsc$descriptor_fib fibdsc = {sizeof (fib), (void *) &fib};
1098 unsigned long long newtime;
1099 unsigned long long revtime;
1103 struct vstring file;
1104 struct dsc$descriptor_s filedsc
1105 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) file.string};
1106 struct vstring device;
1107 struct dsc$descriptor_s devicedsc
1108 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) device.string};
1109 struct vstring timev;
1110 struct dsc$descriptor_s timedsc
1111 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) timev.string};
1112 struct vstring result;
1113 struct dsc$descriptor_s resultdsc
1114 = {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string};
1116 tryfile = (char *) __gnat_to_host_dir_spec (name, 0);
1118 /* Allocate and initialize a FAB and NAM structures. */
1122 nam.nam$l_esa = file.string;
1123 nam.nam$b_ess = NAM$C_MAXRSS;
1124 nam.nam$l_rsa = result.string;
1125 nam.nam$b_rss = NAM$C_MAXRSS;
1126 fab.fab$l_fna = tryfile;
1127 fab.fab$b_fns = strlen (tryfile);
1128 fab.fab$l_nam = &nam;
1130 /* Validate filespec syntax and device existence. */
1131 status = SYS$PARSE (&fab, 0, 0);
1132 if ((status & 1) != 1)
1133 LIB$SIGNAL (status);
1135 file.string[nam.nam$b_esl] = 0;
1137 /* Find matching filespec. */
1138 status = SYS$SEARCH (&fab, 0, 0);
1139 if ((status & 1) != 1)
1140 LIB$SIGNAL (status);
1142 file.string[nam.nam$b_esl] = 0;
1143 result.string[result.length=nam.nam$b_rsl] = 0;
1145 /* Get the device name and assign an IO channel. */
1146 strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev);
1147 devicedsc.dsc$w_length = nam.nam$b_dev;
1149 status = SYS$ASSIGN (&devicedsc, &chan, 0, 0, 0);
1150 if ((status & 1) != 1)
1151 LIB$SIGNAL (status);
1153 /* Initialize the FIB and fill in the directory id field. */
1154 memset (&fib, 0, sizeof (fib));
1155 fib.fib$w_did[0] = nam.nam$w_did[0];
1156 fib.fib$w_did[1] = nam.nam$w_did[1];
1157 fib.fib$w_did[2] = nam.nam$w_did[2];
1158 fib.fib$l_acctl = 0;
1160 strcpy (file.string, (strrchr (result.string, ']') + 1));
1161 filedsc.dsc$w_length = strlen (file.string);
1162 result.string[result.length = 0] = 0;
1164 /* Open and close the file to fill in the attributes. */
1166 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1167 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1168 if ((status & 1) != 1)
1169 LIB$SIGNAL (status);
1170 if ((iosb.status & 1) != 1)
1171 LIB$SIGNAL (iosb.status);
1173 result.string[result.length] = 0;
1174 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, &fibdsc, 0, 0, 0,
1176 if ((status & 1) != 1)
1177 LIB$SIGNAL (status);
1178 if ((iosb.status & 1) != 1)
1179 LIB$SIGNAL (iosb.status);
1184 /* Set creation time to requested time. */
1185 unix_time_to_vms (time_stamp, newtime);
1187 t = time ((time_t) 0);
1189 /* Set revision time to now in local time. */
1190 unix_time_to_vms (t, revtime);
1193 /* Reopen the file, modify the times and then close. */
1194 fib.fib$l_acctl = FIB$M_WRITE;
1196 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1197 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1198 if ((status & 1) != 1)
1199 LIB$SIGNAL (status);
1200 if ((iosb.status & 1) != 1)
1201 LIB$SIGNAL (iosb.status);
1203 Fat.create = newtime;
1204 Fat.revise = revtime;
1206 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0,
1207 &fibdsc, 0, 0, 0, &atrlst, 0);
1208 if ((status & 1) != 1)
1209 LIB$SIGNAL (status);
1210 if ((iosb.status & 1) != 1)
1211 LIB$SIGNAL (iosb.status);
1213 /* Deassign the channel and exit. */
1214 status = SYS$DASSGN (chan);
1215 if ((status & 1) != 1)
1216 LIB$SIGNAL (status);
1218 struct utimbuf utimbuf;
1221 /* Set modification time to requested time. */
1222 utimbuf.modtime = time_stamp;
1224 /* Set access time to now in local time. */
1225 t = time ((time_t) 0);
1226 utimbuf.actime = mktime (localtime (&t));
1228 utime (name, &utimbuf);
1233 __gnat_get_env_value_ptr (char *name, int *len, char **value)
1235 *value = getenv (name);
1239 *len = strlen (*value);
1244 /* VMS specific declarations for set_env_value. */
1248 static char *to_host_path_spec (char *);
1252 unsigned short len, mbz;
1256 typedef struct _ile3
1258 unsigned short len, code;
1260 unsigned short *retlen_adr;
1266 __gnat_set_env_value (char *name, char *value)
1271 struct descriptor_s name_desc;
1272 /* Put in JOB table for now, so that the project stuff at least works. */
1273 struct descriptor_s table_desc = {7, 0, "LNM$JOB"};
1274 char *host_pathspec = value;
1275 char *copy_pathspec;
1276 int num_dirs_in_pathspec = 1;
1280 name_desc.len = strlen (name);
1282 name_desc.adr = name;
1284 if (*host_pathspec == 0)
1287 status = LIB$DELETE_LOGICAL (&name_desc, &table_desc);
1288 /* no need to check status; if the logical name is not
1289 defined, that's fine. */
1293 ptr = host_pathspec;
1296 num_dirs_in_pathspec++;
1300 ile_s *ile_array = alloca (sizeof (ile_s) * (num_dirs_in_pathspec + 1));
1301 char *copy_pathspec = alloca (strlen (host_pathspec) + 1);
1304 strcpy (copy_pathspec, host_pathspec);
1305 curr = copy_pathspec;
1306 for (i = 0; i < num_dirs_in_pathspec; i++)
1308 next = strchr (curr, ',');
1310 next = strchr (curr, 0);
1313 ile_array[i].len = strlen (curr);
1315 /* Code 2 from lnmdef.h means it's a string. */
1316 ile_array[i].code = 2;
1317 ile_array[i].adr = curr;
1319 /* retlen_adr is ignored. */
1320 ile_array[i].retlen_adr = 0;
1324 /* Terminating item must be zero. */
1325 ile_array[i].len = 0;
1326 ile_array[i].code = 0;
1327 ile_array[i].adr = 0;
1328 ile_array[i].retlen_adr = 0;
1330 status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array);
1331 if ((status & 1) != 1)
1332 LIB$SIGNAL (status);
1336 int size = strlen (name) + strlen (value) + 2;
1339 expression = (char *) xmalloc (size * sizeof (char));
1341 sprintf (expression, "%s=%s", name, value);
1342 putenv (expression);
1347 #include <windows.h>
1350 /* Get the list of installed standard libraries from the
1351 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1355 __gnat_get_libraries_from_registry (void)
1357 char *result = (char *) "";
1359 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_COMPILE)
1362 DWORD name_size, value_size;
1369 /* First open the key. */
1370 res = RegOpenKeyExA (HKEY_LOCAL_MACHINE, "SOFTWARE", 0, KEY_READ, ®_key);
1372 if (res == ERROR_SUCCESS)
1373 res = RegOpenKeyExA (reg_key, "Ada Core Technologies", 0,
1374 KEY_READ, ®_key);
1376 if (res == ERROR_SUCCESS)
1377 res = RegOpenKeyExA (reg_key, "GNAT", 0, KEY_READ, ®_key);
1379 if (res == ERROR_SUCCESS)
1380 res = RegOpenKeyExA (reg_key, "Standard Libraries", 0, KEY_READ, ®_key);
1382 /* If the key exists, read out all the values in it and concatenate them
1384 for (index = 0; res == ERROR_SUCCESS; index++)
1386 value_size = name_size = 256;
1387 res = RegEnumValue (reg_key, index, name, &name_size, 0,
1388 &type, (LPBYTE)value, &value_size);
1390 if (res == ERROR_SUCCESS && type == REG_SZ)
1392 char *old_result = result;
1394 result = (char *) xmalloc (strlen (old_result) + value_size + 2);
1395 strcpy (result, old_result);
1396 strcat (result, value);
1397 strcat (result, ";");
1401 /* Remove the trailing ";". */
1403 result[strlen (result) - 1] = 0;
1410 __gnat_stat (char *name, struct stat *statbuf)
1413 /* Under Windows the directory name for the stat function must not be
1414 terminated by a directory separator except if just after a drive name. */
1415 int name_len = strlen (name);
1416 char last_char = name[name_len - 1];
1417 char win32_name[GNAT_MAX_PATH_LEN + 2];
1419 if (name_len > GNAT_MAX_PATH_LEN)
1422 strcpy (win32_name, name);
1424 while (name_len > 1 && (last_char == '\\' || last_char == '/'))
1426 win32_name[name_len - 1] = '\0';
1428 last_char = win32_name[name_len - 1];
1431 if (name_len == 2 && win32_name[1] == ':')
1432 strcat (win32_name, "\\");
1434 return stat (win32_name, statbuf);
1437 return stat (name, statbuf);
1442 __gnat_file_exists (char *name)
1444 struct stat statbuf;
1446 return !__gnat_stat (name, &statbuf);
1450 __gnat_is_absolute_path (char *name, int length)
1452 return (length != 0) &&
1453 (*name == '/' || *name == DIR_SEPARATOR
1454 #if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
1455 || (length > 1 && isalpha (name[0]) && name[1] == ':')
1461 __gnat_is_regular_file (char *name)
1464 struct stat statbuf;
1466 ret = __gnat_stat (name, &statbuf);
1467 return (!ret && S_ISREG (statbuf.st_mode));
1471 __gnat_is_directory (char *name)
1474 struct stat statbuf;
1476 ret = __gnat_stat (name, &statbuf);
1477 return (!ret && S_ISDIR (statbuf.st_mode));
1481 __gnat_is_readable_file (char *name)
1485 struct stat statbuf;
1487 ret = __gnat_stat (name, &statbuf);
1488 mode = statbuf.st_mode & S_IRUSR;
1489 return (!ret && mode);
1493 __gnat_is_writable_file (char *name)
1497 struct stat statbuf;
1499 ret = __gnat_stat (name, &statbuf);
1500 mode = statbuf.st_mode & S_IWUSR;
1501 return (!ret && mode);
1505 __gnat_set_writable (char *name)
1508 struct stat statbuf;
1510 if (stat (name, &statbuf) == 0)
1512 statbuf.st_mode = statbuf.st_mode | S_IWUSR;
1513 chmod (name, statbuf.st_mode);
1519 __gnat_set_executable (char *name)
1522 struct stat statbuf;
1524 if (stat (name, &statbuf) == 0)
1526 statbuf.st_mode = statbuf.st_mode | S_IXUSR;
1527 chmod (name, statbuf.st_mode);
1533 __gnat_set_readonly (char *name)
1536 struct stat statbuf;
1538 if (stat (name, &statbuf) == 0)
1540 statbuf.st_mode = statbuf.st_mode & 07577;
1541 chmod (name, statbuf.st_mode);
1547 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED)
1549 #if defined (__vxworks)
1552 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
1554 struct stat statbuf;
1556 ret = lstat (name, &statbuf);
1557 return (!ret && S_ISLNK (statbuf.st_mode));
1564 #if defined (sun) && defined (__SVR4)
1565 /* Using fork on Solaris will duplicate all the threads. fork1, which
1566 duplicates only the active thread, must be used instead, or spawning
1567 subprocess from a program with tasking will lead into numerous problems. */
1572 __gnat_portable_spawn (char *args[])
1575 int finished ATTRIBUTE_UNUSED;
1576 int pid ATTRIBUTE_UNUSED;
1578 #if defined (MSDOS) || defined (_WIN32)
1579 /* args[0] must be quotes as it could contain a full pathname with spaces */
1580 char *args_0 = args[0];
1581 args[0] = (char *)xmalloc (strlen (args_0) + 3);
1582 strcpy (args[0], "\"");
1583 strcat (args[0], args_0);
1584 strcat (args[0], "\"");
1586 status = spawnvp (P_WAIT, args_0, (const char* const*)args);
1588 /* restore previous value */
1590 args[0] = (char *)args_0;
1597 #elif defined (__vxworks)
1602 pid = spawnvp (P_NOWAIT, args[0], args);
1614 if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
1616 return -1; /* execv is in parent context on VMS. */
1624 finished = waitpid (pid, &status, 0);
1626 if (finished != pid || WIFEXITED (status) == 0)
1629 return WEXITSTATUS (status);
1635 /* Create a copy of the given file descriptor.
1636 Return -1 if an error occurred. */
1639 __gnat_dup (int oldfd)
1641 #if defined (__vxworks)
1642 /* Not supported on VxWorks. */
1649 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
1650 Return -1 if an error occurred. */
1653 __gnat_dup2 (int oldfd, int newfd)
1655 #if defined (__vxworks)
1656 /* Not supported on VxWorks. */
1659 return dup2 (oldfd, newfd);
1663 /* WIN32 code to implement a wait call that wait for any child process. */
1667 /* Synchronization code, to be thread safe. */
1669 static CRITICAL_SECTION plist_cs;
1672 __gnat_plist_init (void)
1674 InitializeCriticalSection (&plist_cs);
1680 EnterCriticalSection (&plist_cs);
1686 LeaveCriticalSection (&plist_cs);
1689 typedef struct _process_list
1692 struct _process_list *next;
1695 static Process_List *PLIST = NULL;
1697 static int plist_length = 0;
1700 add_handle (HANDLE h)
1704 pl = (Process_List *) xmalloc (sizeof (Process_List));
1708 /* -------------------- critical section -------------------- */
1713 /* -------------------- critical section -------------------- */
1719 remove_handle (HANDLE h)
1722 Process_List *prev = NULL;
1726 /* -------------------- critical section -------------------- */
1735 prev->next = pl->next;
1747 /* -------------------- critical section -------------------- */
1753 win32_no_block_spawn (char *command, char *args[])
1757 PROCESS_INFORMATION PI;
1758 SECURITY_ATTRIBUTES SA;
1763 /* compute the total command line length */
1767 csize += strlen (args[k]) + 1;
1771 full_command = (char *) xmalloc (csize);
1774 SI.cb = sizeof (STARTUPINFO);
1775 SI.lpReserved = NULL;
1776 SI.lpReserved2 = NULL;
1777 SI.lpDesktop = NULL;
1781 SI.wShowWindow = SW_HIDE;
1783 /* Security attributes. */
1784 SA.nLength = sizeof (SECURITY_ATTRIBUTES);
1785 SA.bInheritHandle = TRUE;
1786 SA.lpSecurityDescriptor = NULL;
1788 /* Prepare the command string. */
1789 strcpy (full_command, command);
1790 strcat (full_command, " ");
1795 strcat (full_command, args[k]);
1796 strcat (full_command, " ");
1800 result = CreateProcess
1801 (NULL, (char *) full_command, &SA, NULL, TRUE,
1802 GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
1804 free (full_command);
1808 add_handle (PI.hProcess);
1809 CloseHandle (PI.hThread);
1810 return (int) PI.hProcess;
1817 win32_wait (int *status)
1826 if (plist_length == 0)
1832 hl = (HANDLE *) xmalloc (sizeof (HANDLE) * plist_length);
1837 /* -------------------- critical section -------------------- */
1844 /* -------------------- critical section -------------------- */
1848 res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE);
1849 h = hl[res - WAIT_OBJECT_0];
1854 GetExitCodeProcess (h, &exitcode);
1857 *status = (int) exitcode;
1864 __gnat_portable_no_block_spawn (char *args[])
1868 #if defined (__EMX__) || defined (MSDOS)
1870 /* ??? For PC machines I (Franco) don't know the system calls to implement
1871 this routine. So I'll fake it as follows. This routine will behave
1872 exactly like the blocking portable_spawn and will systematically return
1873 a pid of 0 unless the spawned task did not complete successfully, in
1874 which case we return a pid of -1. To synchronize with this the
1875 portable_wait below systematically returns a pid of 0 and reports that
1876 the subprocess terminated successfully. */
1878 if (spawnvp (P_WAIT, args[0], args) != 0)
1881 #elif defined (_WIN32)
1883 pid = win32_no_block_spawn (args[0], args);
1886 #elif defined (__vxworks)
1895 if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
1897 return -1; /* execv is in parent context on VMS. */
1909 __gnat_portable_wait (int *process_status)
1914 #if defined (_WIN32)
1916 pid = win32_wait (&status);
1918 #elif defined (__EMX__) || defined (MSDOS)
1919 /* ??? See corresponding comment in portable_no_block_spawn. */
1921 #elif defined (__vxworks)
1922 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
1926 pid = waitpid (-1, &status, 0);
1927 status = status & 0xffff;
1930 *process_status = status;
1935 __gnat_os_exit (int status)
1940 /* Locate a regular file, give a Path value. */
1943 __gnat_locate_regular_file (char *file_name, char *path_val)
1946 char *file_path = alloca (strlen (file_name) + 1);
1949 /* Remove quotes around file_name if present */
1955 strcpy (file_path, ptr);
1957 ptr = file_path + strlen (file_path) - 1;
1962 /* Handle absolute pathnames. */
1964 absolute = __gnat_is_absolute_path (file_path, strlen (file_name));
1968 if (__gnat_is_regular_file (file_path))
1969 return xstrdup (file_path);
1974 /* If file_name include directory separator(s), try it first as
1975 a path name relative to the current directory */
1976 for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
1981 if (__gnat_is_regular_file (file_name))
1982 return xstrdup (file_name);
1989 /* The result has to be smaller than path_val + file_name. */
1990 char *file_path = alloca (strlen (path_val) + strlen (file_name) + 2);
1994 for (; *path_val == PATH_SEPARATOR; path_val++)
2000 /* Skip the starting quote */
2002 if (*path_val == '"')
2005 for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
2006 *ptr++ = *path_val++;
2010 /* Skip the ending quote */
2015 if (*ptr != '/' && *ptr != DIR_SEPARATOR)
2016 *++ptr = DIR_SEPARATOR;
2018 strcpy (++ptr, file_name);
2020 if (__gnat_is_regular_file (file_path))
2021 return xstrdup (file_path);
2028 /* Locate an executable given a Path argument. This routine is only used by
2029 gnatbl and should not be used otherwise. Use locate_exec_on_path
2033 __gnat_locate_exec (char *exec_name, char *path_val)
2036 if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
2038 char *full_exec_name
2039 = alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
2041 strcpy (full_exec_name, exec_name);
2042 strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
2043 ptr = __gnat_locate_regular_file (full_exec_name, path_val);
2046 return __gnat_locate_regular_file (exec_name, path_val);
2050 return __gnat_locate_regular_file (exec_name, path_val);
2053 /* Locate an executable using the Systems default PATH. */
2056 __gnat_locate_exec_on_path (char *exec_name)
2060 char *path_val = "/VAXC$PATH";
2062 char *path_val = getenv ("PATH");
2065 /* In Win32 systems we expand the PATH as for XP environment
2066 variables are not automatically expanded. We also prepend the
2067 ".;" to the path to match normal NT path search semantics */
2069 #define EXPAND_BUFFER_SIZE 32767
2071 apath_val = alloca (EXPAND_BUFFER_SIZE);
2073 apath_val [0] = '.';
2074 apath_val [1] = ';';
2076 DWORD res = ExpandEnvironmentStrings
2077 (path_val, apath_val + 2, EXPAND_BUFFER_SIZE - 2);
2079 if (!res) apath_val [0] = '\0';
2081 apath_val = alloca (strlen (path_val) + 1);
2082 strcpy (apath_val, path_val);
2085 return __gnat_locate_exec (exec_name, apath_val);
2090 /* These functions are used to translate to and from VMS and Unix syntax
2091 file, directory and path specifications. */
2094 #define MAXNAMES 256
2095 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2097 static char new_canonical_dirspec [MAXPATH];
2098 static char new_canonical_filespec [MAXPATH];
2099 static char new_canonical_pathspec [MAXNAMES*MAXPATH];
2100 static unsigned new_canonical_filelist_index;
2101 static unsigned new_canonical_filelist_in_use;
2102 static unsigned new_canonical_filelist_allocated;
2103 static char **new_canonical_filelist;
2104 static char new_host_pathspec [MAXNAMES*MAXPATH];
2105 static char new_host_dirspec [MAXPATH];
2106 static char new_host_filespec [MAXPATH];
2108 /* Routine is called repeatedly by decc$from_vms via
2109 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2113 wildcard_translate_unix (char *name)
2116 char buff [MAXPATH];
2118 strncpy (buff, name, MAXPATH);
2119 buff [MAXPATH - 1] = (char) 0;
2120 ver = strrchr (buff, '.');
2122 /* Chop off the version. */
2126 /* Dynamically extend the allocation by the increment. */
2127 if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
2129 new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
2130 new_canonical_filelist = (char **) xrealloc
2131 (new_canonical_filelist,
2132 new_canonical_filelist_allocated * sizeof (char *));
2135 new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
2140 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2141 full translation and copy the results into a list (_init), then return them
2142 one at a time (_next). If onlydirs set, only expand directory files. */
2145 __gnat_to_canonical_file_list_init (char *filespec, int onlydirs)
2148 char buff [MAXPATH];
2150 len = strlen (filespec);
2151 strncpy (buff, filespec, MAXPATH);
2153 /* Only look for directories */
2154 if (onlydirs && !strstr (&buff [len-5], "*.dir"))
2155 strncat (buff, "*.dir", MAXPATH);
2157 buff [MAXPATH - 1] = (char) 0;
2159 decc$from_vms (buff, wildcard_translate_unix, 1);
2161 /* Remove the .dir extension. */
2167 for (i = 0; i < new_canonical_filelist_in_use; i++)
2169 ext = strstr (new_canonical_filelist[i], ".dir");
2175 return new_canonical_filelist_in_use;
2178 /* Return the next filespec in the list. */
2181 __gnat_to_canonical_file_list_next ()
2183 return new_canonical_filelist[new_canonical_filelist_index++];
2186 /* Free storage used in the wildcard expansion. */
2189 __gnat_to_canonical_file_list_free ()
2193 for (i = 0; i < new_canonical_filelist_in_use; i++)
2194 free (new_canonical_filelist[i]);
2196 free (new_canonical_filelist);
2198 new_canonical_filelist_in_use = 0;
2199 new_canonical_filelist_allocated = 0;
2200 new_canonical_filelist_index = 0;
2201 new_canonical_filelist = 0;
2204 /* Translate a VMS syntax directory specification in to Unix syntax. If
2205 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2206 found, return input string. Also translate a dirname that contains no
2207 slashes, in case it's a logical name. */
2210 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag)
2214 strcpy (new_canonical_dirspec, "");
2215 if (strlen (dirspec))
2219 if (strchr (dirspec, ']') || strchr (dirspec, ':'))
2221 strncpy (new_canonical_dirspec,
2222 (char *) decc$translate_vms (dirspec),
2225 else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
2227 strncpy (new_canonical_dirspec,
2228 (char *) decc$translate_vms (dirspec1),
2233 strncpy (new_canonical_dirspec, dirspec, MAXPATH);
2237 len = strlen (new_canonical_dirspec);
2238 if (prefixflag && new_canonical_dirspec [len-1] != '/')
2239 strncat (new_canonical_dirspec, "/", MAXPATH);
2241 new_canonical_dirspec [MAXPATH - 1] = (char) 0;
2243 return new_canonical_dirspec;
2247 /* Translate a VMS syntax file specification into Unix syntax.
2248 If no indicators of VMS syntax found, check if it's an uppercase
2249 alphanumeric_ name and if so try it out as an environment
2250 variable (logical name). If all else fails return the
2254 __gnat_to_canonical_file_spec (char *filespec)
2258 strncpy (new_canonical_filespec, "", MAXPATH);
2260 if (strchr (filespec, ']') || strchr (filespec, ':'))
2262 char *tspec = (char *) decc$translate_vms (filespec);
2264 if (tspec != (char *) -1)
2265 strncpy (new_canonical_filespec, tspec, MAXPATH);
2267 else if ((strlen (filespec) == strspn (filespec,
2268 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
2269 && (filespec1 = getenv (filespec)))
2271 char *tspec = (char *) decc$translate_vms (filespec1);
2273 if (tspec != (char *) -1)
2274 strncpy (new_canonical_filespec, tspec, MAXPATH);
2278 strncpy (new_canonical_filespec, filespec, MAXPATH);
2281 new_canonical_filespec [MAXPATH - 1] = (char) 0;
2283 return new_canonical_filespec;
2286 /* Translate a VMS syntax path specification into Unix syntax.
2287 If no indicators of VMS syntax found, return input string. */
2290 __gnat_to_canonical_path_spec (char *pathspec)
2292 char *curr, *next, buff [MAXPATH];
2297 /* If there are /'s, assume it's a Unix path spec and return. */
2298 if (strchr (pathspec, '/'))
2301 new_canonical_pathspec[0] = 0;
2306 next = strchr (curr, ',');
2308 next = strchr (curr, 0);
2310 strncpy (buff, curr, next - curr);
2311 buff[next - curr] = 0;
2313 /* Check for wildcards and expand if present. */
2314 if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
2318 dirs = __gnat_to_canonical_file_list_init (buff, 1);
2319 for (i = 0; i < dirs; i++)
2323 next_dir = __gnat_to_canonical_file_list_next ();
2324 strncat (new_canonical_pathspec, next_dir, MAXPATH);
2326 /* Don't append the separator after the last expansion. */
2328 strncat (new_canonical_pathspec, ":", MAXPATH);
2331 __gnat_to_canonical_file_list_free ();
2334 strncat (new_canonical_pathspec,
2335 __gnat_to_canonical_dir_spec (buff, 0), MAXPATH);
2340 strncat (new_canonical_pathspec, ":", MAXPATH);
2344 new_canonical_pathspec [MAXPATH - 1] = (char) 0;
2346 return new_canonical_pathspec;
2349 static char filename_buff [MAXPATH];
2352 translate_unix (char *name, int type)
2354 strncpy (filename_buff, name, MAXPATH);
2355 filename_buff [MAXPATH - 1] = (char) 0;
2359 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
2363 to_host_path_spec (char *pathspec)
2365 char *curr, *next, buff [MAXPATH];
2370 /* Can't very well test for colons, since that's the Unix separator! */
2371 if (strchr (pathspec, ']') || strchr (pathspec, ','))
2374 new_host_pathspec[0] = 0;
2379 next = strchr (curr, ':');
2381 next = strchr (curr, 0);
2383 strncpy (buff, curr, next - curr);
2384 buff[next - curr] = 0;
2386 strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH);
2389 strncat (new_host_pathspec, ",", MAXPATH);
2393 new_host_pathspec [MAXPATH - 1] = (char) 0;
2395 return new_host_pathspec;
2398 /* Translate a Unix syntax directory specification into VMS syntax. The
2399 PREFIXFLAG has no effect, but is kept for symmetry with
2400 to_canonical_dir_spec. If indicators of VMS syntax found, return input
2404 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2406 int len = strlen (dirspec);
2408 strncpy (new_host_dirspec, dirspec, MAXPATH);
2409 new_host_dirspec [MAXPATH - 1] = (char) 0;
2411 if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
2412 return new_host_dirspec;
2414 while (len > 1 && new_host_dirspec[len - 1] == '/')
2416 new_host_dirspec[len - 1] = 0;
2420 decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
2421 strncpy (new_host_dirspec, filename_buff, MAXPATH);
2422 new_host_dirspec [MAXPATH - 1] = (char) 0;
2424 return new_host_dirspec;
2427 /* Translate a Unix syntax file specification into VMS syntax.
2428 If indicators of VMS syntax found, return input string. */
2431 __gnat_to_host_file_spec (char *filespec)
2433 strncpy (new_host_filespec, "", MAXPATH);
2434 if (strchr (filespec, ']') || strchr (filespec, ':'))
2436 strncpy (new_host_filespec, filespec, MAXPATH);
2440 decc$to_vms (filespec, translate_unix, 1, 1);
2441 strncpy (new_host_filespec, filename_buff, MAXPATH);
2444 new_host_filespec [MAXPATH - 1] = (char) 0;
2446 return new_host_filespec;
2450 __gnat_adjust_os_resource_limits ()
2452 SYS$ADJWSL (131072, 0);
2457 /* Dummy functions for Osint import for non-VMS systems. */
2460 __gnat_to_canonical_file_list_init
2461 (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED)
2467 __gnat_to_canonical_file_list_next (void)
2473 __gnat_to_canonical_file_list_free (void)
2478 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2484 __gnat_to_canonical_file_spec (char *filespec)
2490 __gnat_to_canonical_path_spec (char *pathspec)
2496 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2502 __gnat_to_host_file_spec (char *filespec)
2508 __gnat_adjust_os_resource_limits (void)
2514 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
2515 to coordinate this with the EMX distribution. Consequently, we put the
2516 definition of dummy which is used for exception handling, here. */
2518 #if defined (__EMX__)
2522 #if defined (__mips_vxworks)
2526 CACHE_USER_FLUSH (0, ENTIRE_CACHE);
2530 #if defined (CROSS_COMPILE) \
2531 || (! (defined (sparc) && defined (sun) && defined (__SVR4)) \
2532 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
2533 && ! defined (__FreeBSD__) \
2534 && ! defined (__hpux__) \
2535 && ! defined (__APPLE__) \
2536 && ! defined (_AIX) \
2537 && ! (defined (__alpha__) && defined (__osf__)) \
2538 && ! defined (__MINGW32__) \
2539 && ! (defined (__mips) && defined (__sgi)))
2541 /* Dummy function to satisfy g-trasym.o. Currently Solaris sparc, HP/UX,
2542 GNU/Linux x86{_64}, Tru64 & Windows provide a non-dummy version of this
2543 procedure in libaddr2line.a. */
2546 convert_addresses (void *addrs ATTRIBUTE_UNUSED,
2547 int n_addr ATTRIBUTE_UNUSED,
2548 void *buf ATTRIBUTE_UNUSED,
2549 int *len ATTRIBUTE_UNUSED)
2555 #if defined (_WIN32)
2556 int __gnat_argument_needs_quote = 1;
2558 int __gnat_argument_needs_quote = 0;
2561 /* This option is used to enable/disable object files handling from the
2562 binder file by the GNAT Project module. For example, this is disabled on
2563 Windows (prior to GCC 3.4) as it is already done by the mdll module.
2564 Stating with GCC 3.4 the shared libraries are not based on mdll
2565 anymore as it uses the GCC's -shared option */
2566 #if defined (_WIN32) \
2567 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
2568 int __gnat_prj_add_obj_files = 0;
2570 int __gnat_prj_add_obj_files = 1;
2573 /* char used as prefix/suffix for environment variables */
2574 #if defined (_WIN32)
2575 char __gnat_environment_char = '%';
2577 char __gnat_environment_char = '$';
2580 /* This functions copy the file attributes from a source file to a
2583 mode = 0 : In this mode copy only the file time stamps (last access and
2584 last modification time stamps).
2586 mode = 1 : In this mode, time stamps and read/write/execute attributes are
2589 Returns 0 if operation was successful and -1 in case of error. */
2592 __gnat_copy_attribs (char *from, char *to, int mode)
2594 #if defined (VMS) || defined (__vxworks)
2598 struct utimbuf tbuf;
2600 if (stat (from, &fbuf) == -1)
2605 tbuf.actime = fbuf.st_atime;
2606 tbuf.modtime = fbuf.st_mtime;
2608 if (utime (to, &tbuf) == -1)
2615 if (chmod (to, fbuf.st_mode) == -1)
2625 /* This function is installed in libgcc.a. */
2626 extern void __gnat_install_locks (void (*) (void), void (*) (void));
2628 /* This function offers a hook for libgnarl to set the
2629 locking subprograms for libgcc_eh.
2630 This is only needed on OpenVMS, since other platforms use standard
2631 --enable-threads=posix option, or similar. */
2634 __gnatlib_install_locks (void (*lock) (void) ATTRIBUTE_UNUSED,
2635 void (*unlock) (void) ATTRIBUTE_UNUSED)
2637 #if defined (IN_RTS) && defined (VMS)
2638 __gnat_install_locks (lock, unlock);
2639 /* There is a bootstrap path issue if adaint is build with this
2640 symbol unresolved for the stage1 compiler. Since the compiler
2641 does not use tasking, we simply make __gnatlib_install_locks
2642 a no-op in this case. */
2647 __gnat_lseek (int fd, long offset, int whence)
2649 return (int) lseek (fd, offset, whence);
2652 /* This function returns the version of GCC being used. Here it's GCC 3. */
2654 get_gcc_version (void)
2660 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED,
2661 int close_on_exec_p ATTRIBUTE_UNUSED)
2663 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
2664 int flags = fcntl (fd, F_GETFD, 0);
2667 if (close_on_exec_p)
2668 flags |= FD_CLOEXEC;
2670 flags &= ~FD_CLOEXEC;
2671 return fcntl (fd, F_SETFD, flags | FD_CLOEXEC);
2674 /* For the Windows case, we should use SetHandleInformation to remove
2675 the HANDLE_INHERIT property from fd. This is not implemented yet,
2676 but for our purposes (support of GNAT.Expect) this does not matter,
2677 as by default handles are *not* inherited. */
2681 /* Indicates if platforms supports automatic initialization through the
2682 constructor mechanism */
2684 __gnat_binder_supports_auto_init ()
2693 /* Indicates that Stand-Alone Libraries are automatically initialized through
2694 the constructor mechanism */
2696 __gnat_sals_init_using_constructors ()
2698 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)