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)
73 /* Header files and definitions for __gnat_set_file_time_name. */
85 /* use native 64-bit arithmetic */
86 #define unix_time_to_vms(X,Y) \
87 { unsigned long long reftime, tmptime = (X); \
88 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
89 SYS$BINTIM (&unixtime, &reftime); \
90 Y = tmptime * 10000000 + reftime; }
92 /* descrip.h doesn't have everything ... */
93 struct dsc$descriptor_fib
95 unsigned long fib$l_len;
96 struct fibdef *fib$l_addr;
99 /* I/O Status Block. */
102 unsigned short status, count;
103 unsigned long devdep;
106 static char *tryfile;
108 /* Variable length string. */
112 char string [NAM$C_MAXRSS+1];
120 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
131 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
132 defined in the current system. On DOS-like systems these flags control
133 whether the file is opened/created in text-translation mode (CR/LF in
134 external file mapped to LF in internal file), but in Unix-like systems,
135 no text translation is required, so these flags have no effect. */
137 #if defined (__EMX__)
153 #ifndef HOST_EXECUTABLE_SUFFIX
154 #define HOST_EXECUTABLE_SUFFIX ""
157 #ifndef HOST_OBJECT_SUFFIX
158 #define HOST_OBJECT_SUFFIX ".o"
161 #ifndef PATH_SEPARATOR
162 #define PATH_SEPARATOR ':'
165 #ifndef DIR_SEPARATOR
166 #define DIR_SEPARATOR '/'
169 char __gnat_dir_separator = DIR_SEPARATOR;
171 char __gnat_path_separator = PATH_SEPARATOR;
173 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
174 the base filenames that libraries specified with -lsomelib options
175 may have. This is used by GNATMAKE to check whether an executable
176 is up-to-date or not. The syntax is
178 library_template ::= { pattern ; } pattern NUL
179 pattern ::= [ prefix ] * [ postfix ]
181 These should only specify names of static libraries as it makes
182 no sense to determine at link time if dynamic-link libraries are
183 up to date or not. Any libraries that are not found are supposed
186 * if they are needed but not present, the link
189 * otherwise they are libraries in the system paths and so
190 they are considered part of the system and not checked
193 ??? This should be part of a GNAT host-specific compiler
194 file instead of being included in all user applications
195 as well. This is only a temporary work-around for 3.11b. */
197 #ifndef GNAT_LIBRARY_TEMPLATE
199 #define GNAT_LIBRARY_TEMPLATE "*.a"
201 #define GNAT_LIBRARY_TEMPLATE "*.olb"
203 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
207 const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE;
209 /* The following macro HAVE_READDIR_R should be defined if the
210 system provides the routine readdir_r */
211 #undef HAVE_READDIR_R
214 __gnat_to_gm_time (p_time, p_year, p_month, p_day, p_hours, p_mins, p_secs)
216 int *p_year, *p_month, *p_day, *p_hours, *p_mins, *p_secs;
219 time_t time = *p_time;
222 /* On Windows systems, the time is sometimes rounded up to the nearest
223 even second, so if the number of seconds is odd, increment it. */
228 res = gmtime (&time);
232 *p_year = res->tm_year;
233 *p_month = res->tm_mon;
234 *p_day = res->tm_mday;
235 *p_hours = res->tm_hour;
236 *p_mins = res->tm_min;
237 *p_secs = res->tm_sec;
240 *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0;
243 /* Place the contents of the symbolic link named PATH in the buffer BUF,
244 which has size BUFSIZ. If PATH is a symbolic link, then return the number
245 of characters of its content in BUF. Otherwise, return -1. For Windows,
246 OS/2 and vxworks, always return -1. */
249 __gnat_readlink (path, buf, bufsiz)
254 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
256 #elif defined (__INTERIX) || defined (VMS)
258 #elif defined (__vxworks)
261 return readlink (path, buf, bufsiz);
265 /* Creates a symbolic link named newpath
266 which contains the string oldpath.
267 If newpath exists it will NOT be overwritten.
268 For Windows, OS/2, vxworks, Interix and VMS, always retur -1. */
271 __gnat_symlink (oldpath, newpath)
275 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
277 #elif defined (__INTERIX) || defined (VMS)
279 #elif defined (__vxworks)
282 return symlink (oldpath, newpath);
286 /* Try to lock a file, return 1 if success */
288 #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32)
290 /* Version that does not use link. */
293 __gnat_try_lock (dir, file)
297 char full_path [256];
300 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
301 fd = open (full_path, O_CREAT | O_EXCL, 0600);
309 #elif defined (__EMX__) || defined (VMS)
311 /* More cases that do not use link; identical code, to solve too long
315 __gnat_try_lock (dir, file)
319 char full_path [256];
322 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
323 fd = open (full_path, O_CREAT | O_EXCL, 0600);
332 /* Version using link(), more secure over NFS. */
335 __gnat_try_lock (dir, file)
339 char full_path [256];
340 char temp_file [256];
341 struct stat stat_result;
344 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
345 sprintf (temp_file, "%s-%d-%d", dir, getpid(), getppid ());
347 /* Create the temporary file and write the process number */
348 fd = open (temp_file, O_CREAT | O_WRONLY, 0600);
354 /* Link it with the new file */
355 link (temp_file, full_path);
357 /* Count the references on the old one. If we have a count of two, then
358 the link did succeed. Remove the temporary file before returning. */
359 __gnat_stat (temp_file, &stat_result);
361 return stat_result.st_nlink == 2;
365 /* Return the maximum file name length. */
368 __gnat_get_maximum_file_name_length ()
373 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
382 /* Return the default switch character. */
385 __gnat_get_switch_character ()
387 /* Under MSDOS, the switch character is not normally a hyphen, but this is
388 the convention DJGPP uses. Similarly under OS2, the switch character is
389 not normally a hypen, but this is the convention EMX uses. */
394 /* Return nonzero if file names are case sensitive. */
397 __gnat_get_file_names_case_sensitive ()
399 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined(WINNT)
407 __gnat_get_default_identifier_character_set ()
409 #if defined (__EMX__) || defined (MSDOS)
416 /* Return the current working directory */
419 __gnat_get_current_dir (dir, length)
424 /* Force Unix style, which is what GNAT uses internally. */
425 getcwd (dir, *length, 0);
427 getcwd (dir, *length);
430 *length = strlen (dir);
432 dir [*length] = DIR_SEPARATOR;
434 dir [*length] = '\0';
437 /* Return the suffix for object files. */
440 __gnat_get_object_suffix_ptr (len, value)
444 *value = HOST_OBJECT_SUFFIX;
449 *len = strlen (*value);
454 /* Return the suffix for executable files */
457 __gnat_get_executable_suffix_ptr (len, value)
461 *value = HOST_EXECUTABLE_SUFFIX;
465 *len = strlen (*value);
470 /* Return the suffix for debuggable files. Usually this is the same as the
471 executable extension. */
474 __gnat_get_debuggable_suffix_ptr (len, value)
479 *value = HOST_EXECUTABLE_SUFFIX;
481 /* On DOS, the extensionless COFF file is what gdb likes. */
488 *len = strlen (*value);
494 __gnat_open_read (path, fmode)
499 int o_fmode = O_BINARY;
505 /* Optional arguments mbc,deq,fop increase read performance */
506 fd = open (path, O_RDONLY | o_fmode, 0444,
507 "mbc=16", "deq=64", "fop=tef");
508 #elif defined(__vxworks)
509 fd = open (path, O_RDONLY | o_fmode, 0444);
511 fd = open (path, O_RDONLY | o_fmode);
513 return fd < 0 ? -1 : fd;
516 #if defined (__EMX__)
517 #define PERM (S_IREAD | S_IWRITE)
519 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
523 __gnat_open_rw (path, fmode)
528 int o_fmode = O_BINARY;
534 fd = open (path, O_RDWR | o_fmode, PERM,
535 "mbc=16", "deq=64", "fop=tef");
537 fd = open (path, O_RDWR | o_fmode, PERM);
540 return fd < 0 ? -1 : fd;
544 __gnat_open_create (path, fmode)
549 int o_fmode = O_BINARY;
555 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM,
556 "mbc=16", "deq=64", "fop=tef");
558 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
561 return fd < 0 ? -1 : fd;
565 __gnat_open_append (path, fmode)
570 int o_fmode = O_BINARY;
576 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM,
577 "mbc=16", "deq=64", "fop=tef");
579 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
582 return fd < 0 ? -1 : fd;
585 /* Open a new file. Return error (-1) if the file already exists. */
588 __gnat_open_new (path, fmode)
593 int o_fmode = O_BINARY;
599 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
600 "mbc=16", "deq=64", "fop=tef");
602 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
605 return fd < 0 ? -1 : fd;
608 /* Open a new temp file. Return error (-1) if the file already exists.
609 Special options for VMS allow the file to be shared between parent and
610 child processes, however they really slow down output. Used in
614 __gnat_open_new_temp (path, fmode)
619 int o_fmode = O_BINARY;
621 strcpy (path, "GNAT-XXXXXX");
623 #if defined (linux) && !defined (__vxworks)
624 return mkstemp (path);
627 if (mktemp (path) == NULL)
635 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
636 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
637 "mbc=16", "deq=64", "fop=tef");
639 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
642 return fd < 0 ? -1 : fd;
646 __gnat_mkdir (dir_name)
649 /* On some systems, mkdir has two args and on some it has one. If we
650 are being built as part of the compiler, autoconf has figured that out
651 for us. Otherwise, we have to do it ourselves. */
653 return mkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO);
655 #if defined (_WIN32) || defined (__vxworks)
656 return mkdir (dir_name);
658 return mkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO);
663 /* Return the number of bytes in the specified file. */
666 __gnat_file_length (fd)
672 ret = fstat (fd, &statbuf);
673 if (ret || !S_ISREG (statbuf.st_mode))
676 return (statbuf.st_size);
679 /* Create a temporary filename and put it in string pointed to by
683 __gnat_tmp_name (tmp_filename)
690 /* tempnam tries to create a temporary file in directory pointed to by
691 TMP environment variable, in c:\temp if TMP is not set, and in
692 directory specified by P_tmpdir in stdio.h if c:\temp does not
693 exist. The filename will be created with the prefix "gnat-". */
695 pname = (char *) tempnam ("c:\\temp", "gnat-");
697 /* if pname start with a back slash and not path information it means that
698 the filename is valid for the current working directory */
700 if (pname[0] == '\\')
702 strcpy (tmp_filename, ".\\");
703 strcat (tmp_filename, pname+1);
706 strcpy (tmp_filename, pname);
710 #elif defined (linux)
711 char *tmpdir = getenv ("TMPDIR");
714 strcpy (tmp_filename, "/tmp/gnat-XXXXXX");
716 sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
718 close (mkstemp(tmp_filename));
720 tmpnam (tmp_filename);
724 /* Read the next entry in a directory. The returned string points somewhere
728 __gnat_readdir (dirp, buffer)
732 /* If possible, try to use the thread-safe version. */
733 #ifdef HAVE_READDIR_R
734 if (readdir_r (dirp, buffer) != NULL)
735 return ((struct dirent*) buffer)->d_name;
740 struct dirent *dirent = readdir (dirp);
744 strcpy (buffer, dirent->d_name);
753 /* Returns 1 if readdir is thread safe, 0 otherwise. */
756 __gnat_readdir_is_thread_safe ()
758 #ifdef HAVE_READDIR_R
767 /* Returns the file modification timestamp using Win32 routines which are
768 immune against daylight saving time change. It is in fact not possible to
769 use fstat for this purpose as the DST modify the st_mtime field of the
780 unsigned long long timestamp;
782 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
783 unsigned long long offset = 11644473600;
785 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
786 since <Jan 1st 1601>. This function must return the number of seconds
787 since <Jan 1st 1970>. */
789 res = GetFileTime (h, &t_create, &t_access, &t_write);
791 timestamp = (((long long) t_write.dwHighDateTime << 32)
792 + t_write.dwLowDateTime);
794 timestamp = timestamp / 10000000 - offset;
796 return (time_t) timestamp;
800 /* Return a GNAT time stamp given a file name. */
803 __gnat_file_time_name (name)
808 #if defined (__EMX__) || defined (MSDOS)
809 int fd = open (name, O_RDONLY | O_BINARY);
810 time_t ret = __gnat_file_time_fd (fd);
814 #elif defined (_WIN32)
815 HANDLE h = CreateFile (name, GENERIC_READ, FILE_SHARE_READ, 0,
816 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
817 time_t ret = win32_filetime (h);
822 (void) __gnat_stat (name, &statbuf);
824 /* VMS has file versioning */
825 return statbuf.st_ctime;
827 return statbuf.st_mtime;
832 /* Return a GNAT time stamp given a file descriptor. */
835 __gnat_file_time_fd (fd)
838 /* The following workaround code is due to the fact that under EMX and
839 DJGPP fstat attempts to convert time values to GMT rather than keep the
840 actual OS timestamp of the file. By using the OS2/DOS functions directly
841 the GNAT timestamp are independent of this behavior, which is desired to
842 facilitate the distribution of GNAT compiled libraries. */
844 #if defined (__EMX__) || defined (MSDOS)
848 int ret = DosQueryFileInfo (fd, 1, (unsigned char *) &fs,
849 sizeof (FILESTATUS));
851 unsigned file_year = fs.fdateLastWrite.year;
852 unsigned file_month = fs.fdateLastWrite.month;
853 unsigned file_day = fs.fdateLastWrite.day;
854 unsigned file_hour = fs.ftimeLastWrite.hours;
855 unsigned file_min = fs.ftimeLastWrite.minutes;
856 unsigned file_tsec = fs.ftimeLastWrite.twosecs;
860 int ret = getftime (fd, &fs);
862 unsigned file_year = fs.ft_year;
863 unsigned file_month = fs.ft_month;
864 unsigned file_day = fs.ft_day;
865 unsigned file_hour = fs.ft_hour;
866 unsigned file_min = fs.ft_min;
867 unsigned file_tsec = fs.ft_tsec;
870 /* Calculate the seconds since epoch from the time components. First count
871 the whole days passed. The value for years returned by the DOS and OS2
872 functions count years from 1980, so to compensate for the UNIX epoch which
873 begins in 1970 start with 10 years worth of days and add days for each
874 four year period since then. */
877 int cum_days [12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
878 int days_passed = 3652 + (file_year / 4) * 1461;
879 int years_since_leap = file_year % 4;
881 if (years_since_leap == 1)
883 else if (years_since_leap == 2)
885 else if (years_since_leap == 3)
891 days_passed += cum_days [file_month - 1];
892 if (years_since_leap == 0 && file_year != 20 && file_month > 2)
895 days_passed += file_day - 1;
897 /* OK - have whole days. Multiply -- then add in other parts. */
899 tot_secs = days_passed * 86400;
900 tot_secs += file_hour * 3600;
901 tot_secs += file_min * 60;
902 tot_secs += file_tsec * 2;
905 #elif defined (_WIN32)
906 HANDLE h = (HANDLE) _get_osfhandle (fd);
907 time_t ret = win32_filetime (h);
914 (void) fstat (fd, &statbuf);
917 /* VMS has file versioning */
918 return statbuf.st_ctime;
920 return statbuf.st_mtime;
925 /* Set the file time stamp */
928 __gnat_set_file_time_name (name, time_stamp)
932 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32) \
933 || defined (__vxworks)
935 /* Code to implement __gnat_set_file_time_name for these systems. */
943 unsigned long long backup, create, expire, revise;
947 unsigned short value;
960 { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create },
961 { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise },
962 { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire },
963 { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup },
964 n{ ATR$S_FPRO, ATR$C_FPRO, &Fat.prot },
965 { ATR$S_UIC, ATR$C_UIC, &Fat.uic },
970 struct dsc$descriptor_fib fibdsc = {sizeof (fib), (void *) &fib};
974 unsigned long long newtime;
975 unsigned long long revtime;
980 struct dsc$descriptor_s filedsc
981 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) file.string};
982 struct vstring device;
983 struct dsc$descriptor_s devicedsc
984 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) device.string};
985 struct vstring timev;
986 struct dsc$descriptor_s timedsc
987 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) timev.string};
988 struct vstring result;
989 struct dsc$descriptor_s resultdsc
990 = {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string};
992 tryfile = (char *) __gnat_to_host_dir_spec (name, 0);
994 /* Allocate and initialize a fab and nam structures. */
998 nam.nam$l_esa = file.string;
999 nam.nam$b_ess = NAM$C_MAXRSS;
1000 nam.nam$l_rsa = result.string;
1001 nam.nam$b_rss = NAM$C_MAXRSS;
1002 fab.fab$l_fna = tryfile;
1003 fab.fab$b_fns = strlen (tryfile);
1004 fab.fab$l_nam = &nam;
1006 /*Validate filespec syntax and device existence. */
1007 status = SYS$PARSE (&fab, 0, 0);
1008 if ((status & 1) != 1)
1009 LIB$SIGNAL (status);
1011 file.string [nam.nam$b_esl] = 0;
1013 /* Find matching filespec. */
1014 status = SYS$SEARCH (&fab, 0, 0);
1015 if ((status & 1) != 1)
1016 LIB$SIGNAL (status);
1018 file.string [nam.nam$b_esl] = 0;
1019 result.string [result.length=nam.nam$b_rsl] = 0;
1021 /* Get the device name and assign an IO channel. */
1022 strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev);
1023 devicedsc.dsc$w_length = nam.nam$b_dev;
1025 status = SYS$ASSIGN (&devicedsc, &chan, 0, 0, 0);
1026 if ((status & 1) != 1)
1027 LIB$SIGNAL (status);
1029 /* Initialize the FIB and fill in the directory id field. */
1030 bzero (&fib, sizeof (fib));
1031 fib.fib$w_did [0] = nam.nam$w_did [0];
1032 fib.fib$w_did [1] = nam.nam$w_did [1];
1033 fib.fib$w_did [2] = nam.nam$w_did [2];
1034 fib.fib$l_acctl = 0;
1036 strcpy (file.string, (strrchr (result.string, ']') + 1));
1037 filedsc.dsc$w_length = strlen (file.string);
1038 result.string [result.length = 0] = 0;
1040 /* Open and close the file to fill in the attributes. */
1042 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1043 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1044 if ((status & 1) != 1)
1045 LIB$SIGNAL (status);
1046 if ((iosb.status & 1) != 1)
1047 LIB$SIGNAL (iosb.status);
1049 result.string [result.length] = 0;
1050 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0,
1051 &fibdsc, 0, 0, 0, &atrlst, 0);
1052 if ((status & 1) != 1)
1053 LIB$SIGNAL (status);
1054 if ((iosb.status & 1) != 1)
1055 LIB$SIGNAL (iosb.status);
1057 /* Set creation time to requested time */
1058 unix_time_to_vms (time_stamp, newtime);
1064 t = time ((time_t) 0);
1065 ts = localtime (&t);
1067 /* Set revision time to now in local time. */
1068 unix_time_to_vms (t + ts->tm_gmtoff, revtime);
1071 /* Reopen the file, modify the times and then close. */
1072 fib.fib$l_acctl = FIB$M_WRITE;
1074 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1075 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1076 if ((status & 1) != 1)
1077 LIB$SIGNAL (status);
1078 if ((iosb.status & 1) != 1)
1079 LIB$SIGNAL (iosb.status);
1081 Fat.create = newtime;
1082 Fat.revise = revtime;
1084 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0,
1085 &fibdsc, 0, 0, 0, &atrlst, 0);
1086 if ((status & 1) != 1)
1087 LIB$SIGNAL (status);
1088 if ((iosb.status & 1) != 1)
1089 LIB$SIGNAL (iosb.status);
1091 /* Deassign the channel and exit. */
1092 status = SYS$DASSGN (chan);
1093 if ((status & 1) != 1)
1094 LIB$SIGNAL (status);
1096 struct utimbuf utimbuf;
1099 /* Set modification time to requested time */
1100 utimbuf.modtime = time_stamp;
1102 /* Set access time to now in local time */
1103 t = time ((time_t) 0);
1104 utimbuf.actime = mktime (localtime (&t));
1106 utime (name, &utimbuf);
1111 __gnat_get_env_value_ptr (name, len, value)
1116 *value = getenv (name);
1120 *len = strlen (*value);
1125 /* VMS specific declarations for set_env_value. */
1129 static char *to_host_path_spec PROTO ((char *));
1133 unsigned short len, mbz;
1137 typedef struct _ile3
1139 unsigned short len, code;
1141 unsigned short *retlen_adr;
1147 __gnat_set_env_value (name, value)
1154 struct descriptor_s name_desc;
1155 /* Put in JOB table for now, so that the project stuff at least works */
1156 struct descriptor_s table_desc = {7, 0, "LNM$JOB"};
1157 char *host_pathspec = to_host_path_spec (value);
1158 char *copy_pathspec;
1159 int num_dirs_in_pathspec = 1;
1162 if (*host_pathspec == 0)
1165 name_desc.len = strlen (name);
1167 name_desc.adr = name;
1169 ptr = host_pathspec;
1172 num_dirs_in_pathspec++;
1176 ile_s *ile_array = alloca (sizeof (ile_s) * (num_dirs_in_pathspec + 1));
1177 char *copy_pathspec = alloca (strlen (host_pathspec) + 1);
1180 strcpy (copy_pathspec, host_pathspec);
1181 curr = copy_pathspec;
1182 for (i = 0; i < num_dirs_in_pathspec; i++)
1184 next = strchr (curr, ',');
1186 next = strchr (curr, 0);
1189 ile_array [i].len = strlen (curr);
1191 /* Code 2 from lnmdef.h means its a string */
1192 ile_array [i].code = 2;
1193 ile_array [i].adr = curr;
1195 /* retlen_adr is ignored */
1196 ile_array [i].retlen_adr = 0;
1200 /* Terminating item must be zero */
1201 ile_array [i].len = 0;
1202 ile_array [i].code = 0;
1203 ile_array [i].adr = 0;
1204 ile_array [i].retlen_adr = 0;
1206 status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array);
1207 if ((status & 1) != 1)
1208 LIB$SIGNAL (status);
1212 int size = strlen (name) + strlen (value) + 2;
1215 expression = (char *) xmalloc (size * sizeof (char));
1217 sprintf (expression, "%s=%s", name, value);
1218 putenv (expression);
1223 #include <windows.h>
1226 /* Get the list of installed standard libraries from the
1227 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1231 __gnat_get_libraries_from_registry ()
1233 char *result = (char *) "";
1235 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_COMPILE)
1238 DWORD name_size, value_size;
1245 /* First open the key. */
1246 res = RegOpenKeyExA (HKEY_LOCAL_MACHINE, "SOFTWARE", 0, KEY_READ, ®_key);
1248 if (res == ERROR_SUCCESS)
1249 res = RegOpenKeyExA (reg_key, "Ada Core Technologies", 0,
1250 KEY_READ, ®_key);
1252 if (res == ERROR_SUCCESS)
1253 res = RegOpenKeyExA (reg_key, "GNAT", 0, KEY_READ, ®_key);
1255 if (res == ERROR_SUCCESS)
1256 res = RegOpenKeyExA (reg_key, "Standard Libraries", 0, KEY_READ, ®_key);
1258 /* If the key exists, read out all the values in it and concatenate them
1260 for (index = 0; res == ERROR_SUCCESS; index++)
1262 value_size = name_size = 256;
1263 res = RegEnumValue (reg_key, index, name, &name_size, 0,
1264 &type, value, &value_size);
1266 if (res == ERROR_SUCCESS && type == REG_SZ)
1268 char *old_result = result;
1270 result = (char *) xmalloc (strlen (old_result) + value_size + 2);
1271 strcpy (result, old_result);
1272 strcat (result, value);
1273 strcat (result, ";");
1277 /* Remove the trailing ";". */
1279 result[strlen (result) - 1] = 0;
1286 __gnat_stat (name, statbuf)
1288 struct stat *statbuf;
1291 /* Under Windows the directory name for the stat function must not be
1292 terminated by a directory separator except if just after a drive name. */
1293 int name_len = strlen (name);
1294 char last_char = name [name_len - 1];
1295 char win32_name [4096];
1297 strcpy (win32_name, name);
1299 while (name_len > 1 && (last_char == '\\' || last_char == '/'))
1301 win32_name [name_len - 1] = '\0';
1303 last_char = win32_name[name_len - 1];
1306 if (name_len == 2 && win32_name [1] == ':')
1307 strcat (win32_name, "\\");
1309 return stat (win32_name, statbuf);
1312 return stat (name, statbuf);
1317 __gnat_file_exists (name)
1320 struct stat statbuf;
1322 return !__gnat_stat (name, &statbuf);
1326 __gnat_is_absolute_path (name)
1329 return (*name == '/' || *name == DIR_SEPARATOR
1330 #if defined(__EMX__) || defined(MSDOS) || defined(WINNT)
1331 || strlen (name) > 1 && isalpha (name [0]) && name [1] == ':'
1337 __gnat_is_regular_file (name)
1341 struct stat statbuf;
1343 ret = __gnat_stat (name, &statbuf);
1344 return (!ret && S_ISREG (statbuf.st_mode));
1348 __gnat_is_directory (name)
1352 struct stat statbuf;
1354 ret = __gnat_stat (name, &statbuf);
1355 return (!ret && S_ISDIR (statbuf.st_mode));
1359 __gnat_is_writable_file (name)
1364 struct stat statbuf;
1366 ret = __gnat_stat (name, &statbuf);
1367 mode = statbuf.st_mode & S_IWUSR;
1368 return (!ret && mode);
1372 /* Defined in VMS header files */
1373 #define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
1374 LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1)
1377 #if defined (sun) && defined (__SVR4)
1378 /* Using fork on Solaris will duplicate all the threads. fork1, which
1379 duplicates only the active thread, must be used instead, or spawning
1380 subprocess from a program with tasking will lead into numerous problems. */
1385 __gnat_portable_spawn (args)
1392 #if defined (MSDOS) || defined (_WIN32)
1393 status = spawnvp (P_WAIT, args [0], args);
1399 #elif defined(__vxworks) /* Mods for VxWorks */
1400 pid = sp (args[0], args); /* Spawn process and save pid */
1404 while (taskIdVerify(pid) >= 0)
1405 /* Wait until spawned task is complete then continue. */
1410 pid = spawnvp (P_NOWAIT, args [0], args);
1418 if (pid == 0 && execv (args [0], args) != 0)
1423 finished = waitpid (pid, &status, 0);
1425 if (finished != pid || WIFEXITED (status) == 0)
1428 return WEXITSTATUS (status);
1433 /* WIN32 code to implement a wait call that wait for any child process */
1436 /* Synchronization code, to be thread safe. */
1438 static CRITICAL_SECTION plist_cs;
1441 __gnat_plist_init ()
1443 InitializeCriticalSection (&plist_cs);
1449 EnterCriticalSection (&plist_cs);
1455 LeaveCriticalSection (&plist_cs);
1458 typedef struct _process_list
1461 struct _process_list *next;
1464 static Process_List *PLIST = NULL;
1466 static int plist_length = 0;
1474 pl = (Process_List *) xmalloc (sizeof (Process_List));
1478 /* -------------------- critical section -------------------- */
1483 /* -------------------- critical section -------------------- */
1488 void remove_handle (h)
1491 Process_List *pl, *prev;
1495 /* -------------------- critical section -------------------- */
1504 prev->next = pl->next;
1516 /* -------------------- critical section -------------------- */
1522 win32_no_block_spawn (command, args)
1528 PROCESS_INFORMATION PI;
1529 SECURITY_ATTRIBUTES SA;
1531 char full_command [2000];
1535 SI.cb = sizeof (STARTUPINFO);
1536 SI.lpReserved = NULL;
1537 SI.lpReserved2 = NULL;
1538 SI.lpDesktop = NULL;
1542 SI.wShowWindow = SW_HIDE;
1544 /* Security attributes. */
1545 SA.nLength = sizeof (SECURITY_ATTRIBUTES);
1546 SA.bInheritHandle = TRUE;
1547 SA.lpSecurityDescriptor = NULL;
1549 /* Prepare the command string. */
1550 strcpy (full_command, command);
1551 strcat (full_command, " ");
1556 strcat (full_command, args[k]);
1557 strcat (full_command, " ");
1561 result = CreateProcess (NULL, (char *) full_command, &SA, NULL, TRUE,
1562 NORMAL_PRIORITY_CLASS, NULL, NULL, &SI, &PI);
1566 add_handle (PI.hProcess);
1567 CloseHandle (PI.hThread);
1568 return (int) PI.hProcess;
1585 if (plist_length == 0)
1591 hl = (HANDLE *) xmalloc (sizeof (HANDLE) * plist_length);
1596 /* -------------------- critical section -------------------- */
1603 /* -------------------- critical section -------------------- */
1607 res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE);
1608 h = hl [res - WAIT_OBJECT_0];
1613 GetExitCodeProcess (h, &exitcode);
1616 *status = (int) exitcode;
1623 __gnat_portable_no_block_spawn (args)
1628 #if defined (__EMX__) || defined (MSDOS)
1630 /* ??? For PC machines I (Franco) don't know the system calls to implement
1631 this routine. So I'll fake it as follows. This routine will behave
1632 exactly like the blocking portable_spawn and will systematically return
1633 a pid of 0 unless the spawned task did not complete successfully, in
1634 which case we return a pid of -1. To synchronize with this the
1635 portable_wait below systematically returns a pid of 0 and reports that
1636 the subprocess terminated successfully. */
1638 if (spawnvp (P_WAIT, args [0], args) != 0)
1641 #elif defined (_WIN32)
1643 pid = win32_no_block_spawn (args[0], args);
1646 #elif defined (__vxworks) /* Mods for VxWorks */
1647 pid = sp (args[0], args); /* Spawn task and then return (no waiting) */
1656 if (pid == 0 && execv (args [0], args) != 0)
1664 __gnat_portable_wait (process_status)
1665 int *process_status;
1670 #if defined (_WIN32)
1672 pid = win32_wait (&status);
1674 #elif defined (__EMX__) || defined (MSDOS)
1675 /* ??? See corresponding comment in portable_no_block_spawn. */
1677 #elif defined (__vxworks)
1678 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
1683 /* Wait doesn't do the right thing on VMS */
1684 pid = waitpid (-1, &status, 0);
1686 pid = wait (&status);
1688 status = status & 0xffff;
1691 *process_status = status;
1696 __gnat_os_exit (status)
1700 /* Exit without changing 0 to 1 */
1701 __posix_exit (status);
1707 /* Locate a regular file, give a Path value */
1710 __gnat_locate_regular_file (file_name, path_val)
1716 /* Handle absolute pathnames. */
1717 for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
1721 #if defined(__EMX__) || defined(MSDOS) || defined(WINNT)
1722 || isalpha (file_name [0]) && file_name [1] == ':'
1726 if (__gnat_is_regular_file (file_name))
1727 return xstrdup (file_name);
1736 /* The result has to be smaller than path_val + file_name. */
1737 char *file_path = alloca (strlen (path_val) + strlen (file_name) + 2);
1741 for (; *path_val == PATH_SEPARATOR; path_val++)
1747 for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
1748 *ptr++ = *path_val++;
1751 if (*ptr != '/' && *ptr != DIR_SEPARATOR)
1752 *++ptr = DIR_SEPARATOR;
1754 strcpy (++ptr, file_name);
1756 if (__gnat_is_regular_file (file_path))
1757 return xstrdup (file_path);
1765 /* Locate an executable given a Path argument. This routine is only used by
1766 gnatbl and should not be used otherwise. Use locate_exec_on_path
1770 __gnat_locate_exec (exec_name, path_val)
1774 if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
1776 char *full_exec_name
1777 = alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
1779 strcpy (full_exec_name, exec_name);
1780 strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
1781 return __gnat_locate_regular_file (full_exec_name, path_val);
1784 return __gnat_locate_regular_file (exec_name, path_val);
1787 /* Locate an executable using the Systems default PATH */
1790 __gnat_locate_exec_on_path (exec_name)
1794 char *path_val = "/VAXC$PATH";
1796 char *path_val = getenv ("PATH");
1798 char *apath_val = alloca (strlen (path_val) + 1);
1800 strcpy (apath_val, path_val);
1801 return __gnat_locate_exec (exec_name, apath_val);
1806 /* These functions are used to translate to and from VMS and Unix syntax
1807 file, directory and path specifications. */
1809 #define MAXNAMES 256
1810 #define NEW_CANONICAL_FILELIST_INCREMENT 64
1812 static char new_canonical_dirspec [255];
1813 static char new_canonical_filespec [255];
1814 static char new_canonical_pathspec [MAXNAMES*255];
1815 static unsigned new_canonical_filelist_index;
1816 static unsigned new_canonical_filelist_in_use;
1817 static unsigned new_canonical_filelist_allocated;
1818 static char **new_canonical_filelist;
1819 static char new_host_pathspec [MAXNAMES*255];
1820 static char new_host_dirspec [255];
1821 static char new_host_filespec [255];
1823 /* Routine is called repeatedly by decc$from_vms via
1824 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
1828 wildcard_translate_unix (name)
1834 strcpy (buff, name);
1835 ver = strrchr (buff, '.');
1837 /* Chop off the version */
1841 /* Dynamically extend the allocation by the increment */
1842 if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
1844 new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
1845 new_canonical_filelist = (char **) realloc
1846 (new_canonical_filelist,
1847 new_canonical_filelist_allocated * sizeof (char *));
1850 new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
1855 /* Translate a wildcard VMS file spec into a list of Unix file
1856 specs. First do full translation and copy the results into a list (_init),
1857 then return them one at a time (_next). If onlydirs set, only expand
1861 __gnat_to_canonical_file_list_init (filespec, onlydirs)
1868 len = strlen (filespec);
1869 strcpy (buff, filespec);
1871 /* Only look for directories */
1872 if (onlydirs && !strstr (&buff [len-5], "*.dir"))
1873 strcat (buff, "*.dir");
1875 decc$from_vms (buff, wildcard_translate_unix, 1);
1877 /* Remove the .dir extension */
1883 for (i = 0; i < new_canonical_filelist_in_use; i++)
1885 ext = strstr (new_canonical_filelist [i], ".dir");
1891 return new_canonical_filelist_in_use;
1894 /* Return the next filespec in the list */
1897 __gnat_to_canonical_file_list_next ()
1899 return new_canonical_filelist [new_canonical_filelist_index++];
1902 /* Free up storage used in the wildcard expansion */
1905 __gnat_to_canonical_file_list_free ()
1909 for (i = 0; i < new_canonical_filelist_in_use; i++)
1910 free (new_canonical_filelist [i]);
1912 free (new_canonical_filelist);
1914 new_canonical_filelist_in_use = 0;
1915 new_canonical_filelist_allocated = 0;
1916 new_canonical_filelist_index = 0;
1917 new_canonical_filelist = 0;
1920 /* Translate a VMS syntax directory specification in to Unix syntax.
1921 If prefixflag is set, append an underscore "/". If no indicators
1922 of VMS syntax found, return input string. Also translate a dirname
1923 that contains no slashes, in case it's a logical name. */
1926 __gnat_to_canonical_dir_spec (dirspec,prefixflag)
1932 strcpy (new_canonical_dirspec, "");
1933 if (strlen (dirspec))
1937 if (strchr (dirspec, ']') || strchr (dirspec, ':'))
1938 strcpy (new_canonical_dirspec, (char *) decc$translate_vms (dirspec));
1939 else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
1940 strcpy (new_canonical_dirspec, (char *) decc$translate_vms (dirspec1));
1942 strcpy (new_canonical_dirspec, dirspec);
1945 len = strlen (new_canonical_dirspec);
1946 if (prefixflag && new_canonical_dirspec [len-1] != '/')
1947 strcat (new_canonical_dirspec, "/");
1949 return new_canonical_dirspec;
1953 /* Translate a VMS syntax file specification into Unix syntax.
1954 If no indicators of VMS syntax found, return input string. */
1957 __gnat_to_canonical_file_spec (filespec)
1960 strcpy (new_canonical_filespec, "");
1961 if (strchr (filespec, ']') || strchr (filespec, ':'))
1962 strcpy (new_canonical_filespec, (char *) decc$translate_vms (filespec));
1964 strcpy (new_canonical_filespec, filespec);
1966 return new_canonical_filespec;
1969 /* Translate a VMS syntax path specification into Unix syntax.
1970 If no indicators of VMS syntax found, return input string. */
1973 __gnat_to_canonical_path_spec (pathspec)
1976 char *curr, *next, buff [256];
1981 /* If there are /'s, assume it's a Unix path spec and return */
1982 if (strchr (pathspec, '/'))
1985 new_canonical_pathspec [0] = 0;
1990 next = strchr (curr, ',');
1992 next = strchr (curr, 0);
1994 strncpy (buff, curr, next - curr);
1995 buff [next - curr] = 0;
1997 /* Check for wildcards and expand if present */
1998 if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
2002 dirs = __gnat_to_canonical_file_list_init (buff, 1);
2003 for (i = 0; i < dirs; i++)
2007 next_dir = __gnat_to_canonical_file_list_next ();
2008 strcat (new_canonical_pathspec, next_dir);
2010 /* Don't append the separator after the last expansion */
2012 strcat (new_canonical_pathspec, ":");
2015 __gnat_to_canonical_file_list_free ();
2018 strcat (new_canonical_pathspec,
2019 __gnat_to_canonical_dir_spec (buff, 0));
2024 strcat (new_canonical_pathspec, ":");
2028 return new_canonical_pathspec;
2031 static char filename_buff [256];
2034 translate_unix (name, type)
2038 strcpy (filename_buff, name);
2042 /* Translate a Unix syntax path spec into a VMS style (comma separated
2043 list of directories. Only used in this file so make it static */
2046 to_host_path_spec (pathspec)
2049 char *curr, *next, buff [256];
2054 /* Can't very well test for colons, since that's the Unix separator! */
2055 if (strchr (pathspec, ']') || strchr (pathspec, ','))
2058 new_host_pathspec [0] = 0;
2063 next = strchr (curr, ':');
2065 next = strchr (curr, 0);
2067 strncpy (buff, curr, next - curr);
2068 buff [next - curr] = 0;
2070 strcat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0));
2073 strcat (new_host_pathspec, ",");
2077 return new_host_pathspec;
2080 /* Translate a Unix syntax directory specification into VMS syntax.
2081 The prefixflag has no effect, but is kept for symmetry with
2082 to_canonical_dir_spec.
2083 If indicators of VMS syntax found, return input string. */
2086 __gnat_to_host_dir_spec (dirspec, prefixflag)
2090 int len = strlen (dirspec);
2092 strcpy (new_host_dirspec, dirspec);
2094 if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
2095 return new_host_dirspec;
2097 while (len > 1 && new_host_dirspec [len-1] == '/')
2099 new_host_dirspec [len-1] = 0;
2103 decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
2104 strcpy (new_host_dirspec, filename_buff);
2106 return new_host_dirspec;
2110 /* Translate a Unix syntax file specification into VMS syntax.
2111 If indicators of VMS syntax found, return input string. */
2114 __gnat_to_host_file_spec (filespec)
2117 strcpy (new_host_filespec, "");
2118 if (strchr (filespec, ']') || strchr (filespec, ':'))
2119 strcpy (new_host_filespec, filespec);
2122 decc$to_vms (filespec, translate_unix, 1, 1);
2123 strcpy (new_host_filespec, filename_buff);
2126 return new_host_filespec;
2130 __gnat_adjust_os_resource_limits ()
2132 SYS$ADJWSL (131072, 0);
2137 /* Dummy functions for Osint import for non-VMS systems */
2140 __gnat_to_canonical_file_list_init (dirspec, onlydirs)
2141 char *dirspec ATTRIBUTE_UNUSED;
2142 int onlydirs ATTRIBUTE_UNUSED;
2148 __gnat_to_canonical_file_list_next ()
2154 __gnat_to_canonical_file_list_free ()
2159 __gnat_to_canonical_dir_spec (dirspec, prefixflag)
2161 int prefixflag ATTRIBUTE_UNUSED;
2167 __gnat_to_canonical_file_spec (filespec)
2174 __gnat_to_canonical_path_spec (pathspec)
2181 __gnat_to_host_dir_spec (dirspec, prefixflag)
2183 int prefixflag ATTRIBUTE_UNUSED;
2189 __gnat_to_host_file_spec (filespec)
2196 __gnat_adjust_os_resource_limits ()
2202 /* for EMX, we cannot include dummy in libgcc, since it is too difficult
2203 to coordinate this with the EMX distribution. Consequently, we put the
2204 definition of dummy() which is used for exception handling, here */
2206 #if defined (__EMX__)
2210 #if defined (__mips_vxworks)
2213 CACHE_USER_FLUSH (0, ENTIRE_CACHE);
2217 #if defined (CROSS_COMPILE) \
2218 || (! (defined (sparc) && defined (sun) && defined (__SVR4)) \
2219 && ! defined (linux) \
2220 && ! defined (sgi) \
2221 && ! defined (hpux) \
2222 && ! (defined (__alpha__) && defined (__osf__)) \
2223 && ! defined (__MINGW32__))
2224 /* Dummy function to satisfy g-trasym.o.
2225 Currently Solaris sparc, HP/UX, IRIX, GNU/Linux, Tru64 & Windows provide a
2226 non-dummy version of this procedure in libaddr2line.a */
2229 convert_addresses (addrs, n_addr, buf, len)
2230 void *addrs ATTRIBUTE_UNUSED;
2231 int n_addr ATTRIBUTE_UNUSED;
2232 void *buf ATTRIBUTE_UNUSED;