1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
9 * C Implementation File *
11 * Copyright (C) 1992-2001, Free Software Foundation, Inc. *
13 * GNAT is free software; you can redistribute it and/or modify it under *
14 * terms of the GNU General Public License as published by the Free Soft- *
15 * ware Foundation; either version 2, or (at your option) any later ver- *
16 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
17 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
18 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
19 * for more details. You should have received a copy of the GNU General *
20 * Public License distributed with GNAT; see file COPYING. If not, write *
21 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
22 * MA 02111-1307, USA. *
24 * As a special exception, if you link this file with other files to *
25 * produce an executable, this file does not by itself cause the resulting *
26 * executable to be covered by the GNU General Public License. This except- *
27 * ion does not however invalidate any other reasons why the executable *
28 * file might be covered by the GNU Public License. *
30 * GNAT was originally developed by the GNAT team at New York University. *
31 * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
33 ****************************************************************************/
35 /* This file contains those routines named by Import pragmas in packages */
36 /* in the GNAT hierarchy (especially GNAT.OS_Lib) and in package Osint. */
37 /* Many of the subprograms in OS_Lib import standard library calls */
38 /* directly. This file contains all other routines. */
41 /* No need to redefine exit here */
45 /* We want to use the POSIX variants of include files. */
49 #if defined (__mips_vxworks)
51 #endif /* __mips_vxworks */
62 /* We don't have libiberty, so us malloc. */
63 #define xmalloc(S) malloc (S)
70 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
90 #define NOEXECUTE 0x04
93 /* use native 64-bit arithmetic */
94 #define unix_time_to_vms(X,Y) \
95 { unsigned long long reftime, tmptime = (X); \
96 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
97 SYS$BINTIM (&unixtime, &reftime); \
98 Y = tmptime * 10000000 + reftime; }
100 /* descrip.h doesn't have everything ... */
101 struct dsc$descriptor_fib
103 unsigned long fib$l_len;
104 struct fibdef *fib$l_addr;
109 unsigned short status, count;
110 unsigned long devdep;
113 static char *tryfile;
118 char string [NAM$C_MAXRSS+1];
126 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
137 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
138 defined in the current system. On DOS-like systems these flags control
139 whether the file is opened/created in text-translation mode (CR/LF in
140 external file mapped to LF in internal file), but in Unix-like systems,
141 no text translation is required, so these flags have no effect. */
143 #if defined (__EMX__)
159 #ifndef HOST_EXECUTABLE_SUFFIX
160 #define HOST_EXECUTABLE_SUFFIX ""
163 #ifndef HOST_OBJECT_SUFFIX
164 #define HOST_OBJECT_SUFFIX ".o"
167 #ifndef PATH_SEPARATOR
168 #define PATH_SEPARATOR ':'
171 #ifndef DIR_SEPARATOR
172 #define DIR_SEPARATOR '/'
175 char __gnat_dir_separator = DIR_SEPARATOR;
177 char __gnat_path_separator = PATH_SEPARATOR;
179 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
180 the base filenames that libraries specified with -lsomelib options
181 may have. This is used by GNATMAKE to check whether an executable
182 is up-to-date or not. The syntax is
184 library_template ::= { pattern ; } pattern NUL
185 pattern ::= [ prefix ] * [ postfix ]
187 These should only specify names of static libraries as it makes
188 no sense to determine at link time if dynamic-link libraries are
189 up to date or not. Any libraries that are not found are supposed
192 * if they are needed but not present, the link
195 * otherwise they are libraries in the system paths and so
196 they are considered part of the system and not checked
199 ??? This should be part of a GNAT host-specific compiler
200 file instead of being included in all user applications
201 as well. This is only a temporary work-around for 3.11b. */
203 #ifndef GNAT_LIBRARY_TEMPLATE
205 #define GNAT_LIBRARY_TEMPLATE "*.a"
207 #define GNAT_LIBRARY_TEMPLATE "*.olb"
209 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
213 const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE;
215 /* The following macro HAVE_READDIR_R should be defined if the
216 system provides the routine readdir_r */
217 #undef HAVE_READDIR_R
220 __gnat_to_gm_time (p_time, p_year, p_month, p_day, p_hours, p_mins, p_secs)
222 int *p_year, *p_month, *p_day, *p_hours, *p_mins, *p_secs;
225 time_t time = *p_time;
228 /* On Windows systems, the time is sometimes rounded up to the nearest
229 even second, so if the number of seconds is odd, increment it. */
234 res = gmtime (&time);
238 *p_year = res->tm_year;
239 *p_month = res->tm_mon;
240 *p_day = res->tm_mday;
241 *p_hours = res->tm_hour;
242 *p_mins = res->tm_min;
243 *p_secs = res->tm_sec;
246 *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0;
249 /* Place the contents of the symbolic link named PATH in the buffer BUF,
250 which has size BUFSIZ. If PATH is a symbolic link, then return the number
251 of characters of its content in BUF. Otherwise, return -1. For Windows,
252 OS/2 and vxworks, always return -1. */
255 __gnat_readlink (path, buf, bufsiz)
260 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
262 #elif defined (__INTERIX) || defined (VMS)
264 #elif defined (__vxworks)
267 return readlink (path, buf, bufsiz);
271 /* Creates a symbolic link named newpath
272 which contains the string oldpath.
273 If newpath exists it will NOT be overwritten.
274 For Windows, OS/2, vxworks, Interix and VMS, always retur -1. */
277 __gnat_symlink (oldpath, newpath)
281 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
283 #elif defined (__INTERIX) || defined (VMS)
285 #elif defined (__vxworks)
288 return symlink (oldpath, newpath);
292 /* Try to lock a file, return 1 if success */
294 #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32)
296 /* Version that does not use link. */
299 __gnat_try_lock (dir, file)
303 char full_path [256];
306 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
307 fd = open (full_path, O_CREAT | O_EXCL, 0600);
315 #elif defined (__EMX__) || defined (VMS)
317 /* More cases that do not use link; identical code, to solve too long
321 __gnat_try_lock (dir, file)
325 char full_path [256];
328 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
329 fd = open (full_path, O_CREAT | O_EXCL, 0600);
338 /* Version using link(), more secure over NFS. */
341 __gnat_try_lock (dir, file)
345 char full_path [256];
346 char temp_file [256];
347 struct stat stat_result;
350 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
351 sprintf (temp_file, "%s-%d-%d", dir, getpid(), getppid ());
353 /* Create the temporary file and write the process number */
354 fd = open (temp_file, O_CREAT | O_WRONLY, 0600);
360 /* Link it with the new file */
361 link (temp_file, full_path);
363 /* Count the references on the old one. If we have a count of two, then
364 the link did succeed. Remove the temporary file before returning. */
365 __gnat_stat (temp_file, &stat_result);
367 return stat_result.st_nlink == 2;
371 /* Return the maximum file name length. */
374 __gnat_get_maximum_file_name_length ()
379 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
388 /* Return the default switch character. */
391 __gnat_get_switch_character ()
393 /* Under MSDOS, the switch character is not normally a hyphen, but this is
394 the convention DJGPP uses. Similarly under OS2, the switch character is
395 not normally a hypen, but this is the convention EMX uses. */
400 /* Return nonzero if file names are case sensitive. */
403 __gnat_get_file_names_case_sensitive ()
405 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined(WINNT)
413 __gnat_get_default_identifier_character_set ()
415 #if defined (__EMX__) || defined (MSDOS)
422 /* Return the current working directory */
425 __gnat_get_current_dir (dir, length)
430 /* Force Unix style, which is what GNAT uses internally. */
431 getcwd (dir, *length, 0);
433 getcwd (dir, *length);
436 *length = strlen (dir);
438 dir [*length] = DIR_SEPARATOR;
440 dir [*length] = '\0';
443 /* Return the suffix for object files. */
446 __gnat_get_object_suffix_ptr (len, value)
450 *value = HOST_OBJECT_SUFFIX;
455 *len = strlen (*value);
460 /* Return the suffix for executable files */
463 __gnat_get_executable_suffix_ptr (len, value)
467 *value = HOST_EXECUTABLE_SUFFIX;
471 *len = strlen (*value);
476 /* Return the suffix for debuggable files. Usually this is the same as the
477 executable extension. */
480 __gnat_get_debuggable_suffix_ptr (len, value)
485 *value = HOST_EXECUTABLE_SUFFIX;
487 /* On DOS, the extensionless COFF file is what gdb likes. */
494 *len = strlen (*value);
500 __gnat_open_read (path, fmode)
505 int o_fmode = O_BINARY;
511 /* Optional arguments mbc,deq,fop increase read performance */
512 fd = open (path, O_RDONLY | o_fmode, 0444,
513 "mbc=16", "deq=64", "fop=tef");
514 #elif defined(__vxworks)
515 fd = open (path, O_RDONLY | o_fmode, 0444);
517 fd = open (path, O_RDONLY | o_fmode);
519 return fd < 0 ? -1 : fd;
522 #if defined (__EMX__)
523 #define PERM (S_IREAD | S_IWRITE)
525 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
529 __gnat_open_rw (path, fmode)
534 int o_fmode = O_BINARY;
540 fd = open (path, O_RDWR | o_fmode, PERM,
541 "mbc=16", "deq=64", "fop=tef");
543 fd = open (path, O_RDWR | o_fmode, PERM);
546 return fd < 0 ? -1 : fd;
550 __gnat_open_create (path, fmode)
555 int o_fmode = O_BINARY;
561 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM,
562 "mbc=16", "deq=64", "fop=tef");
564 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
567 return fd < 0 ? -1 : fd;
571 __gnat_open_append (path, fmode)
576 int o_fmode = O_BINARY;
582 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM,
583 "mbc=16", "deq=64", "fop=tef");
585 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
588 return fd < 0 ? -1 : fd;
591 /* Open a new file. Return error (-1) if the file already exists. */
594 __gnat_open_new (path, fmode)
599 int o_fmode = O_BINARY;
605 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
606 "mbc=16", "deq=64", "fop=tef");
608 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
611 return fd < 0 ? -1 : fd;
614 /* Open a new temp file. Return error (-1) if the file already exists.
615 Special options for VMS allow the file to be shared between parent and
616 child processes, however they really slow down output. Used in
620 __gnat_open_new_temp (path, fmode)
625 int o_fmode = O_BINARY;
627 strcpy (path, "GNAT-XXXXXX");
629 #if defined (linux) && !defined (__vxworks)
630 return mkstemp (path);
633 if (mktemp (path) == NULL)
641 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
642 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
643 "mbc=16", "deq=64", "fop=tef");
645 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
648 return fd < 0 ? -1 : fd;
652 __gnat_mkdir (dir_name)
655 /* On some systems, mkdir has two args and on some it has one. If we
656 are being built as part of the compiler, autoconf has figured that out
657 for us. Otherwise, we have to do it ourselves. */
659 return mkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO);
661 #if defined (_WIN32) || defined (__vxworks)
662 return mkdir (dir_name);
664 return mkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO);
669 /* Return the number of bytes in the specified file. */
672 __gnat_file_length (fd)
678 ret = fstat (fd, &statbuf);
679 if (ret || !S_ISREG (statbuf.st_mode))
682 return (statbuf.st_size);
685 /* Create a temporary filename and put it in string pointed to by
689 __gnat_tmp_name (tmp_filename)
696 /* tempnam tries to create a temporary file in directory pointed to by
697 TMP environment variable, in c:\temp if TMP is not set, and in
698 directory specified by P_tmpdir in stdio.h if c:\temp does not
699 exist. The filename will be created with the prefix "gnat-". */
701 pname = (char *) tempnam ("c:\\temp", "gnat-");
703 /* if pname start with a back slash and not path information it means that
704 the filename is valid for the current working directory */
706 if (pname[0] == '\\')
708 strcpy (tmp_filename, ".\\");
709 strcat (tmp_filename, pname+1);
712 strcpy (tmp_filename, pname);
716 #elif defined (linux)
717 char *tmpdir = getenv ("TMPDIR");
720 strcpy (tmp_filename, "/tmp/gnat-XXXXXX");
722 sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
724 close (mkstemp(tmp_filename));
726 tmpnam (tmp_filename);
730 /* Read the next entry in a directory. The returned string points somewhere
734 __gnat_readdir (dirp, buffer)
738 /* If possible, try to use the thread-safe version. */
739 #ifdef HAVE_READDIR_R
740 if (readdir_r (dirp, buffer) != NULL)
741 return ((struct dirent*) buffer)->d_name;
746 struct dirent *dirent = readdir (dirp);
750 strcpy (buffer, dirent->d_name);
759 /* Returns 1 if readdir is thread safe, 0 otherwise. */
762 __gnat_readdir_is_thread_safe ()
764 #ifdef HAVE_READDIR_R
773 /* Returns the file modification timestamp using Win32 routines which are
774 immune against daylight saving time change. It is in fact not possible to
775 use fstat for this purpose as the DST modify the st_mtime field of the
786 unsigned long long timestamp;
788 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
789 unsigned long long offset = 11644473600;
791 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
792 since <Jan 1st 1601>. This function must return the number of seconds
793 since <Jan 1st 1970>. */
795 res = GetFileTime (h, &t_create, &t_access, &t_write);
797 timestamp = (((long long) t_write.dwHighDateTime << 32)
798 + t_write.dwLowDateTime);
800 timestamp = timestamp / 10000000 - offset;
802 return (time_t) timestamp;
806 /* Return a GNAT time stamp given a file name. */
809 __gnat_file_time_name (name)
814 #if defined (__EMX__) || defined (MSDOS)
815 int fd = open (name, O_RDONLY | O_BINARY);
816 time_t ret = __gnat_file_time_fd (fd);
820 #elif defined (_WIN32)
821 HANDLE h = CreateFile (name, GENERIC_READ, FILE_SHARE_READ, 0,
822 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
823 time_t ret = win32_filetime (h);
828 (void) __gnat_stat (name, &statbuf);
830 /* VMS has file versioning */
831 return statbuf.st_ctime;
833 return statbuf.st_mtime;
838 /* Return a GNAT time stamp given a file descriptor. */
841 __gnat_file_time_fd (fd)
844 /* The following workaround code is due to the fact that under EMX and
845 DJGPP fstat attempts to convert time values to GMT rather than keep the
846 actual OS timestamp of the file. By using the OS2/DOS functions directly
847 the GNAT timestamp are independent of this behavior, which is desired to
848 facilitate the distribution of GNAT compiled libraries. */
850 #if defined (__EMX__) || defined (MSDOS)
854 int ret = DosQueryFileInfo (fd, 1, (unsigned char *) &fs,
855 sizeof (FILESTATUS));
857 unsigned file_year = fs.fdateLastWrite.year;
858 unsigned file_month = fs.fdateLastWrite.month;
859 unsigned file_day = fs.fdateLastWrite.day;
860 unsigned file_hour = fs.ftimeLastWrite.hours;
861 unsigned file_min = fs.ftimeLastWrite.minutes;
862 unsigned file_tsec = fs.ftimeLastWrite.twosecs;
866 int ret = getftime (fd, &fs);
868 unsigned file_year = fs.ft_year;
869 unsigned file_month = fs.ft_month;
870 unsigned file_day = fs.ft_day;
871 unsigned file_hour = fs.ft_hour;
872 unsigned file_min = fs.ft_min;
873 unsigned file_tsec = fs.ft_tsec;
876 /* Calculate the seconds since epoch from the time components. First count
877 the whole days passed. The value for years returned by the DOS and OS2
878 functions count years from 1980, so to compensate for the UNIX epoch which
879 begins in 1970 start with 10 years worth of days and add days for each
880 four year period since then. */
883 int cum_days [12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
884 int days_passed = 3652 + (file_year / 4) * 1461;
885 int years_since_leap = file_year % 4;
887 if (years_since_leap == 1)
889 else if (years_since_leap == 2)
891 else if (years_since_leap == 3)
897 days_passed += cum_days [file_month - 1];
898 if (years_since_leap == 0 && file_year != 20 && file_month > 2)
901 days_passed += file_day - 1;
903 /* OK - have whole days. Multiply -- then add in other parts. */
905 tot_secs = days_passed * 86400;
906 tot_secs += file_hour * 3600;
907 tot_secs += file_min * 60;
908 tot_secs += file_tsec * 2;
911 #elif defined (_WIN32)
912 HANDLE h = (HANDLE) _get_osfhandle (fd);
913 time_t ret = win32_filetime (h);
920 (void) fstat (fd, &statbuf);
923 /* VMS has file versioning */
924 return statbuf.st_ctime;
926 return statbuf.st_mtime;
931 /* Set the file time stamp */
934 __gnat_set_file_time_name (name, time_stamp)
938 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32) \
939 || defined (__vxworks)
946 unsigned long long backup, create, expire, revise;
950 unsigned short value;
963 { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create },
964 { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise },
965 { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire },
966 { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup },
967 n{ ATR$S_FPRO, ATR$C_FPRO, &Fat.prot },
968 { ATR$S_UIC, ATR$C_UIC, &Fat.uic },
973 struct dsc$descriptor_fib fibdsc = {sizeof (fib), (void *) &fib};
977 unsigned long long newtime;
978 unsigned long long revtime;
983 struct dsc$descriptor_s filedsc
984 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) file.string};
985 struct vstring device;
986 struct dsc$descriptor_s devicedsc
987 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) device.string};
988 struct vstring timev;
989 struct dsc$descriptor_s timedsc
990 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) timev.string};
991 struct vstring result;
992 struct dsc$descriptor_s resultdsc
993 = {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string};
995 tryfile = (char *) __gnat_to_host_dir_spec (name, 0);
997 /* Allocate and initialize a fab and nam structures. */
1001 nam.nam$l_esa = file.string;
1002 nam.nam$b_ess = NAM$C_MAXRSS;
1003 nam.nam$l_rsa = result.string;
1004 nam.nam$b_rss = NAM$C_MAXRSS;
1005 fab.fab$l_fna = tryfile;
1006 fab.fab$b_fns = strlen (tryfile);
1007 fab.fab$l_nam = &nam;
1009 /*Validate filespec syntax and device existence. */
1010 status = SYS$PARSE (&fab, 0, 0);
1011 if ((status & 1) != 1)
1012 LIB$SIGNAL (status);
1014 file.string [nam.nam$b_esl] = 0;
1016 /* Find matching filespec. */
1017 status = SYS$SEARCH (&fab, 0, 0);
1018 if ((status & 1) != 1)
1019 LIB$SIGNAL (status);
1021 file.string [nam.nam$b_esl] = 0;
1022 result.string [result.length=nam.nam$b_rsl] = 0;
1024 /* Get the device name and assign an IO channel. */
1025 strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev);
1026 devicedsc.dsc$w_length = nam.nam$b_dev;
1028 status = SYS$ASSIGN (&devicedsc, &chan, 0, 0, 0);
1029 if ((status & 1) != 1)
1030 LIB$SIGNAL (status);
1032 /* Initialize the FIB and fill in the directory id field. */
1033 bzero (&fib, sizeof (fib));
1034 fib.fib$w_did [0] = nam.nam$w_did [0];
1035 fib.fib$w_did [1] = nam.nam$w_did [1];
1036 fib.fib$w_did [2] = nam.nam$w_did [2];
1037 fib.fib$l_acctl = 0;
1039 strcpy (file.string, (strrchr (result.string, ']') + 1));
1040 filedsc.dsc$w_length = strlen (file.string);
1041 result.string [result.length = 0] = 0;
1043 /* Open and close the file to fill in the attributes. */
1045 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1046 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1047 if ((status & 1) != 1)
1048 LIB$SIGNAL (status);
1049 if ((iosb.status & 1) != 1)
1050 LIB$SIGNAL (iosb.status);
1052 result.string [result.length] = 0;
1053 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0,
1054 &fibdsc, 0, 0, 0, &atrlst, 0);
1055 if ((status & 1) != 1)
1056 LIB$SIGNAL (status);
1057 if ((iosb.status & 1) != 1)
1058 LIB$SIGNAL (iosb.status);
1060 /* Set creation time to requested time */
1061 unix_time_to_vms (time_stamp, newtime);
1067 t = time ((time_t) 0);
1068 ts = localtime (&t);
1070 /* Set revision time to now in local time. */
1071 unix_time_to_vms (t + ts->tm_gmtoff, revtime);
1074 /* Reopen the file, modify the times and then close. */
1075 fib.fib$l_acctl = FIB$M_WRITE;
1077 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1078 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1079 if ((status & 1) != 1)
1080 LIB$SIGNAL (status);
1081 if ((iosb.status & 1) != 1)
1082 LIB$SIGNAL (iosb.status);
1084 Fat.create = newtime;
1085 Fat.revise = revtime;
1087 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0,
1088 &fibdsc, 0, 0, 0, &atrlst, 0);
1089 if ((status & 1) != 1)
1090 LIB$SIGNAL (status);
1091 if ((iosb.status & 1) != 1)
1092 LIB$SIGNAL (iosb.status);
1094 /* Deassign the channel and exit. */
1095 status = SYS$DASSGN (chan);
1096 if ((status & 1) != 1)
1097 LIB$SIGNAL (status);
1099 struct utimbuf utimbuf;
1102 /* Set modification time to requested time */
1103 utimbuf.modtime = time_stamp;
1105 /* Set access time to now in local time */
1106 t = time ((time_t) 0);
1107 utimbuf.actime = mktime (localtime (&t));
1109 utime (name, &utimbuf);
1114 __gnat_get_env_value_ptr (name, len, value)
1119 *value = getenv (name);
1123 *len = strlen (*value);
1128 /* VMS specific declarations for set_env_value. */
1132 static char *to_host_path_spec PROTO ((char *));
1136 unsigned short len, mbz;
1140 typedef struct _ile3
1142 unsigned short len, code;
1144 unsigned short *retlen_adr;
1150 __gnat_set_env_value (name, value)
1157 struct descriptor_s name_desc;
1158 /* Put in JOB table for now, so that the project stuff at least works */
1159 struct descriptor_s table_desc = {7, 0, "LNM$JOB"};
1160 char *host_pathspec = to_host_path_spec (value);
1161 char *copy_pathspec;
1162 int num_dirs_in_pathspec = 1;
1165 if (*host_pathspec == 0)
1168 name_desc.len = strlen (name);
1170 name_desc.adr = name;
1172 ptr = host_pathspec;
1175 num_dirs_in_pathspec++;
1179 ile_s *ile_array = alloca (sizeof (ile_s) * (num_dirs_in_pathspec + 1));
1180 char *copy_pathspec = alloca (strlen (host_pathspec) + 1);
1183 strcpy (copy_pathspec, host_pathspec);
1184 curr = copy_pathspec;
1185 for (i = 0; i < num_dirs_in_pathspec; i++)
1187 next = strchr (curr, ',');
1189 next = strchr (curr, 0);
1192 ile_array [i].len = strlen (curr);
1194 /* Code 2 from lnmdef.h means its a string */
1195 ile_array [i].code = 2;
1196 ile_array [i].adr = curr;
1198 /* retlen_adr is ignored */
1199 ile_array [i].retlen_adr = 0;
1203 /* Terminating item must be zero */
1204 ile_array [i].len = 0;
1205 ile_array [i].code = 0;
1206 ile_array [i].adr = 0;
1207 ile_array [i].retlen_adr = 0;
1209 status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array);
1210 if ((status & 1) != 1)
1211 LIB$SIGNAL (status);
1215 int size = strlen (name) + strlen (value) + 2;
1218 expression = (char *) xmalloc (size * sizeof (char));
1220 sprintf (expression, "%s=%s", name, value);
1221 putenv (expression);
1226 #include <windows.h>
1229 /* Get the list of installed standard libraries from the
1230 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1234 __gnat_get_libraries_from_registry ()
1236 char *result = (char *) "";
1238 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_COMPILE)
1241 DWORD name_size, value_size;
1248 /* First open the key. */
1249 res = RegOpenKeyExA (HKEY_LOCAL_MACHINE, "SOFTWARE", 0, KEY_READ, ®_key);
1251 if (res == ERROR_SUCCESS)
1252 res = RegOpenKeyExA (reg_key, "Ada Core Technologies", 0,
1253 KEY_READ, ®_key);
1255 if (res == ERROR_SUCCESS)
1256 res = RegOpenKeyExA (reg_key, "GNAT", 0, KEY_READ, ®_key);
1258 if (res == ERROR_SUCCESS)
1259 res = RegOpenKeyExA (reg_key, "Standard Libraries", 0, KEY_READ, ®_key);
1261 /* If the key exists, read out all the values in it and concatenate them
1263 for (index = 0; res == ERROR_SUCCESS; index++)
1265 value_size = name_size = 256;
1266 res = RegEnumValue (reg_key, index, name, &name_size, 0,
1267 &type, value, &value_size);
1269 if (res == ERROR_SUCCESS && type == REG_SZ)
1271 char *old_result = result;
1273 result = (char *) xmalloc (strlen (old_result) + value_size + 2);
1274 strcpy (result, old_result);
1275 strcat (result, value);
1276 strcat (result, ";");
1280 /* Remove the trailing ";". */
1282 result[strlen (result) - 1] = 0;
1289 __gnat_stat (name, statbuf)
1291 struct stat *statbuf;
1294 /* Under Windows the directory name for the stat function must not be
1295 terminated by a directory separator except if just after a drive name. */
1296 int name_len = strlen (name);
1297 char last_char = name [name_len - 1];
1298 char win32_name [4096];
1300 strcpy (win32_name, name);
1302 while (name_len > 1 && (last_char == '\\' || last_char == '/'))
1304 win32_name [name_len - 1] = '\0';
1306 last_char = win32_name[name_len - 1];
1309 if (name_len == 2 && win32_name [1] == ':')
1310 strcat (win32_name, "\\");
1312 return stat (win32_name, statbuf);
1315 return stat (name, statbuf);
1320 __gnat_file_exists (name)
1323 struct stat statbuf;
1325 return !__gnat_stat (name, &statbuf);
1329 __gnat_is_absolute_path (name)
1332 return (*name == '/' || *name == DIR_SEPARATOR
1333 #if defined(__EMX__) || defined(MSDOS) || defined(WINNT)
1334 || strlen (name) > 1 && isalpha (name [0]) && name [1] == ':'
1340 __gnat_is_regular_file (name)
1344 struct stat statbuf;
1346 ret = __gnat_stat (name, &statbuf);
1347 return (!ret && S_ISREG (statbuf.st_mode));
1351 __gnat_is_directory (name)
1355 struct stat statbuf;
1357 ret = __gnat_stat (name, &statbuf);
1358 return (!ret && S_ISDIR (statbuf.st_mode));
1362 __gnat_is_writable_file (name)
1367 struct stat statbuf;
1369 ret = __gnat_stat (name, &statbuf);
1370 mode = statbuf.st_mode & S_IWUSR;
1371 return (!ret && mode);
1375 /* Defined in VMS header files */
1376 #define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
1377 LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1)
1380 #if defined (sun) && defined (__SVR4)
1381 /* Using fork on Solaris will duplicate all the threads. fork1, which
1382 duplicates only the active thread, must be used instead, or spawning
1383 subprocess from a program with tasking will lead into numerous problems. */
1388 __gnat_portable_spawn (args)
1395 #if defined (MSDOS) || defined (_WIN32)
1396 status = spawnvp (P_WAIT, args [0], args);
1402 #elif defined(__vxworks) /* Mods for VxWorks */
1403 pid = sp (args[0], args); /* Spawn process and save pid */
1407 while (taskIdVerify(pid) >= 0)
1408 /* Wait until spawned task is complete then continue. */
1413 pid = spawnvp (P_NOWAIT, args [0], args);
1421 if (pid == 0 && execv (args [0], args) != 0)
1426 finished = waitpid (pid, &status, 0);
1428 if (finished != pid || WIFEXITED (status) == 0)
1431 return WEXITSTATUS (status);
1436 /* WIN32 code to implement a wait call that wait for any child process */
1439 /* Synchronization code, to be thread safe. */
1441 static CRITICAL_SECTION plist_cs;
1444 __gnat_plist_init ()
1446 InitializeCriticalSection (&plist_cs);
1452 EnterCriticalSection (&plist_cs);
1458 LeaveCriticalSection (&plist_cs);
1461 typedef struct _process_list
1464 struct _process_list *next;
1467 static Process_List *PLIST = NULL;
1469 static int plist_length = 0;
1477 pl = (Process_List *) xmalloc (sizeof (Process_List));
1481 /* -------------------- critical section -------------------- */
1486 /* -------------------- critical section -------------------- */
1491 void remove_handle (h)
1494 Process_List *pl, *prev;
1498 /* -------------------- critical section -------------------- */
1507 prev->next = pl->next;
1519 /* -------------------- critical section -------------------- */
1525 win32_no_block_spawn (command, args)
1531 PROCESS_INFORMATION PI;
1532 SECURITY_ATTRIBUTES SA;
1534 char full_command [2000];
1538 SI.cb = sizeof (STARTUPINFO);
1539 SI.lpReserved = NULL;
1540 SI.lpReserved2 = NULL;
1541 SI.lpDesktop = NULL;
1545 SI.wShowWindow = SW_HIDE;
1547 /* Security attributes. */
1548 SA.nLength = sizeof (SECURITY_ATTRIBUTES);
1549 SA.bInheritHandle = TRUE;
1550 SA.lpSecurityDescriptor = NULL;
1552 /* Prepare the command string. */
1553 strcpy (full_command, command);
1554 strcat (full_command, " ");
1559 strcat (full_command, args[k]);
1560 strcat (full_command, " ");
1564 result = CreateProcess (NULL, (char *) full_command, &SA, NULL, TRUE,
1565 NORMAL_PRIORITY_CLASS, NULL, NULL, &SI, &PI);
1569 add_handle (PI.hProcess);
1570 CloseHandle (PI.hThread);
1571 return (int) PI.hProcess;
1588 if (plist_length == 0)
1594 hl = (HANDLE *) xmalloc (sizeof (HANDLE) * plist_length);
1599 /* -------------------- critical section -------------------- */
1606 /* -------------------- critical section -------------------- */
1610 res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE);
1611 h = hl [res - WAIT_OBJECT_0];
1616 GetExitCodeProcess (h, &exitcode);
1619 *status = (int) exitcode;
1626 __gnat_portable_no_block_spawn (args)
1631 #if defined (__EMX__) || defined (MSDOS)
1633 /* ??? For PC machines I (Franco) don't know the system calls to implement
1634 this routine. So I'll fake it as follows. This routine will behave
1635 exactly like the blocking portable_spawn and will systematically return
1636 a pid of 0 unless the spawned task did not complete successfully, in
1637 which case we return a pid of -1. To synchronize with this the
1638 portable_wait below systematically returns a pid of 0 and reports that
1639 the subprocess terminated successfully. */
1641 if (spawnvp (P_WAIT, args [0], args) != 0)
1644 #elif defined (_WIN32)
1646 pid = win32_no_block_spawn (args[0], args);
1649 #elif defined (__vxworks) /* Mods for VxWorks */
1650 pid = sp (args[0], args); /* Spawn task and then return (no waiting) */
1659 if (pid == 0 && execv (args [0], args) != 0)
1667 __gnat_portable_wait (process_status)
1668 int *process_status;
1673 #if defined (_WIN32)
1675 pid = win32_wait (&status);
1677 #elif defined (__EMX__) || defined (MSDOS)
1678 /* ??? See corresponding comment in portable_no_block_spawn. */
1680 #elif defined (__vxworks)
1681 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
1686 /* Wait doesn't do the right thing on VMS */
1687 pid = waitpid (-1, &status, 0);
1689 pid = wait (&status);
1691 status = status & 0xffff;
1694 *process_status = status;
1699 __gnat_os_exit (status)
1703 /* Exit without changing 0 to 1 */
1704 __posix_exit (status);
1710 /* Locate a regular file, give a Path value */
1713 __gnat_locate_regular_file (file_name, path_val)
1719 /* Handle absolute pathnames. */
1720 for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
1724 #if defined(__EMX__) || defined(MSDOS) || defined(WINNT)
1725 || isalpha (file_name [0]) && file_name [1] == ':'
1729 if (__gnat_is_regular_file (file_name))
1730 return xstrdup (file_name);
1739 /* The result has to be smaller than path_val + file_name. */
1740 char *file_path = alloca (strlen (path_val) + strlen (file_name) + 2);
1744 for (; *path_val == PATH_SEPARATOR; path_val++)
1750 for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
1751 *ptr++ = *path_val++;
1754 if (*ptr != '/' && *ptr != DIR_SEPARATOR)
1755 *++ptr = DIR_SEPARATOR;
1757 strcpy (++ptr, file_name);
1759 if (__gnat_is_regular_file (file_path))
1760 return xstrdup (file_path);
1768 /* Locate an executable given a Path argument. This routine is only used by
1769 gnatbl and should not be used otherwise. Use locate_exec_on_path
1773 __gnat_locate_exec (exec_name, path_val)
1777 if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
1779 char *full_exec_name
1780 = alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
1782 strcpy (full_exec_name, exec_name);
1783 strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
1784 return __gnat_locate_regular_file (full_exec_name, path_val);
1787 return __gnat_locate_regular_file (exec_name, path_val);
1790 /* Locate an executable using the Systems default PATH */
1793 __gnat_locate_exec_on_path (exec_name)
1797 char *path_val = "/VAXC$PATH";
1799 char *path_val = getenv ("PATH");
1801 char *apath_val = alloca (strlen (path_val) + 1);
1803 strcpy (apath_val, path_val);
1804 return __gnat_locate_exec (exec_name, apath_val);
1809 /* These functions are used to translate to and from VMS and Unix syntax
1810 file, directory and path specifications. */
1812 #define MAXNAMES 256
1813 #define NEW_CANONICAL_FILELIST_INCREMENT 64
1815 static char new_canonical_dirspec [255];
1816 static char new_canonical_filespec [255];
1817 static char new_canonical_pathspec [MAXNAMES*255];
1818 static unsigned new_canonical_filelist_index;
1819 static unsigned new_canonical_filelist_in_use;
1820 static unsigned new_canonical_filelist_allocated;
1821 static char **new_canonical_filelist;
1822 static char new_host_pathspec [MAXNAMES*255];
1823 static char new_host_dirspec [255];
1824 static char new_host_filespec [255];
1826 /* Routine is called repeatedly by decc$from_vms via
1827 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
1831 wildcard_translate_unix (name)
1837 strcpy (buff, name);
1838 ver = strrchr (buff, '.');
1840 /* Chop off the version */
1844 /* Dynamically extend the allocation by the increment */
1845 if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
1847 new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
1848 new_canonical_filelist = (char **) realloc
1849 (new_canonical_filelist,
1850 new_canonical_filelist_allocated * sizeof (char *));
1853 new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
1858 /* Translate a wildcard VMS file spec into a list of Unix file
1859 specs. First do full translation and copy the results into a list (_init),
1860 then return them one at a time (_next). If onlydirs set, only expand
1864 __gnat_to_canonical_file_list_init (filespec, onlydirs)
1871 len = strlen (filespec);
1872 strcpy (buff, filespec);
1874 /* Only look for directories */
1875 if (onlydirs && !strstr (&buff [len-5], "*.dir"))
1876 strcat (buff, "*.dir");
1878 decc$from_vms (buff, wildcard_translate_unix, 1);
1880 /* Remove the .dir extension */
1886 for (i = 0; i < new_canonical_filelist_in_use; i++)
1888 ext = strstr (new_canonical_filelist [i], ".dir");
1894 return new_canonical_filelist_in_use;
1897 /* Return the next filespec in the list */
1900 __gnat_to_canonical_file_list_next ()
1902 return new_canonical_filelist [new_canonical_filelist_index++];
1905 /* Free up storage used in the wildcard expansion */
1908 __gnat_to_canonical_file_list_free ()
1912 for (i = 0; i < new_canonical_filelist_in_use; i++)
1913 free (new_canonical_filelist [i]);
1915 free (new_canonical_filelist);
1917 new_canonical_filelist_in_use = 0;
1918 new_canonical_filelist_allocated = 0;
1919 new_canonical_filelist_index = 0;
1920 new_canonical_filelist = 0;
1923 /* Translate a VMS syntax directory specification in to Unix syntax.
1924 If prefixflag is set, append an underscore "/". If no indicators
1925 of VMS syntax found, return input string. Also translate a dirname
1926 that contains no slashes, in case it's a logical name. */
1929 __gnat_to_canonical_dir_spec (dirspec,prefixflag)
1935 strcpy (new_canonical_dirspec, "");
1936 if (strlen (dirspec))
1940 if (strchr (dirspec, ']') || strchr (dirspec, ':'))
1941 strcpy (new_canonical_dirspec, (char *) decc$translate_vms (dirspec));
1942 else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
1943 strcpy (new_canonical_dirspec, (char *) decc$translate_vms (dirspec1));
1945 strcpy (new_canonical_dirspec, dirspec);
1948 len = strlen (new_canonical_dirspec);
1949 if (prefixflag && new_canonical_dirspec [len-1] != '/')
1950 strcat (new_canonical_dirspec, "/");
1952 return new_canonical_dirspec;
1956 /* Translate a VMS syntax file specification into Unix syntax.
1957 If no indicators of VMS syntax found, return input string. */
1960 __gnat_to_canonical_file_spec (filespec)
1963 strcpy (new_canonical_filespec, "");
1964 if (strchr (filespec, ']') || strchr (filespec, ':'))
1965 strcpy (new_canonical_filespec, (char *) decc$translate_vms (filespec));
1967 strcpy (new_canonical_filespec, filespec);
1969 return new_canonical_filespec;
1972 /* Translate a VMS syntax path specification into Unix syntax.
1973 If no indicators of VMS syntax found, return input string. */
1976 __gnat_to_canonical_path_spec (pathspec)
1979 char *curr, *next, buff [256];
1984 /* If there are /'s, assume it's a Unix path spec and return */
1985 if (strchr (pathspec, '/'))
1988 new_canonical_pathspec [0] = 0;
1993 next = strchr (curr, ',');
1995 next = strchr (curr, 0);
1997 strncpy (buff, curr, next - curr);
1998 buff [next - curr] = 0;
2000 /* Check for wildcards and expand if present */
2001 if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
2005 dirs = __gnat_to_canonical_file_list_init (buff, 1);
2006 for (i = 0; i < dirs; i++)
2010 next_dir = __gnat_to_canonical_file_list_next ();
2011 strcat (new_canonical_pathspec, next_dir);
2013 /* Don't append the separator after the last expansion */
2015 strcat (new_canonical_pathspec, ":");
2018 __gnat_to_canonical_file_list_free ();
2021 strcat (new_canonical_pathspec,
2022 __gnat_to_canonical_dir_spec (buff, 0));
2027 strcat (new_canonical_pathspec, ":");
2031 return new_canonical_pathspec;
2034 static char filename_buff [256];
2037 translate_unix (name, type)
2041 strcpy (filename_buff, name);
2045 /* Translate a Unix syntax path spec into a VMS style (comma separated
2046 list of directories. Only used in this file so make it static */
2049 to_host_path_spec (pathspec)
2052 char *curr, *next, buff [256];
2057 /* Can't very well test for colons, since that's the Unix separator! */
2058 if (strchr (pathspec, ']') || strchr (pathspec, ','))
2061 new_host_pathspec [0] = 0;
2066 next = strchr (curr, ':');
2068 next = strchr (curr, 0);
2070 strncpy (buff, curr, next - curr);
2071 buff [next - curr] = 0;
2073 strcat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0));
2076 strcat (new_host_pathspec, ",");
2080 return new_host_pathspec;
2083 /* Translate a Unix syntax directory specification into VMS syntax.
2084 The prefixflag has no effect, but is kept for symmetry with
2085 to_canonical_dir_spec.
2086 If indicators of VMS syntax found, return input string. */
2089 __gnat_to_host_dir_spec (dirspec, prefixflag)
2093 int len = strlen (dirspec);
2095 strcpy (new_host_dirspec, dirspec);
2097 if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
2098 return new_host_dirspec;
2100 while (len > 1 && new_host_dirspec [len-1] == '/')
2102 new_host_dirspec [len-1] = 0;
2106 decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
2107 strcpy (new_host_dirspec, filename_buff);
2109 return new_host_dirspec;
2113 /* Translate a Unix syntax file specification into VMS syntax.
2114 If indicators of VMS syntax found, return input string. */
2117 __gnat_to_host_file_spec (filespec)
2120 strcpy (new_host_filespec, "");
2121 if (strchr (filespec, ']') || strchr (filespec, ':'))
2122 strcpy (new_host_filespec, filespec);
2125 decc$to_vms (filespec, translate_unix, 1, 1);
2126 strcpy (new_host_filespec, filename_buff);
2129 return new_host_filespec;
2133 __gnat_adjust_os_resource_limits ()
2135 SYS$ADJWSL (131072, 0);
2140 /* Dummy functions for Osint import for non-VMS systems */
2143 __gnat_to_canonical_file_list_init (dirspec, onlydirs)
2144 char *dirspec ATTRIBUTE_UNUSED;
2145 int onlydirs ATTRIBUTE_UNUSED;
2151 __gnat_to_canonical_file_list_next ()
2157 __gnat_to_canonical_file_list_free ()
2162 __gnat_to_canonical_dir_spec (dirspec, prefixflag)
2164 int prefixflag ATTRIBUTE_UNUSED;
2170 __gnat_to_canonical_file_spec (filespec)
2177 __gnat_to_canonical_path_spec (pathspec)
2184 __gnat_to_host_dir_spec (dirspec, prefixflag)
2186 int prefixflag ATTRIBUTE_UNUSED;
2192 __gnat_to_host_file_spec (filespec)
2199 __gnat_adjust_os_resource_limits ()
2205 /* for EMX, we cannot include dummy in libgcc, since it is too difficult
2206 to coordinate this with the EMX distribution. Consequently, we put the
2207 definition of dummy() which is used for exception handling, here */
2209 #if defined (__EMX__)
2213 #if defined (__mips_vxworks)
2216 CACHE_USER_FLUSH (0, ENTIRE_CACHE);
2220 #if defined (CROSS_COMPILE) \
2221 || (! (defined (sparc) && defined (sun) && defined (__SVR4)) \
2222 && ! defined (linux) \
2223 && ! defined (sgi) \
2224 && ! defined (hpux) \
2225 && ! (defined (__alpha__) && defined (__osf__)) \
2226 && ! defined (__MINGW32__))
2227 /* Dummy function to satisfy g-trasym.o.
2228 Currently Solaris sparc, HP/UX, IRIX, GNU/Linux, Tru64 & Windows provide a
2229 non-dummy version of this procedure in libaddr2line.a */
2232 convert_addresses (addrs, n_addr, buf, len)
2233 void *addrs ATTRIBUTE_UNUSED;
2234 int n_addr ATTRIBUTE_UNUSED;
2235 void *buf ATTRIBUTE_UNUSED;