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>
92 #elif defined (__vxworks) && defined (__RTP__)
98 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
101 /* Header files and definitions for __gnat_set_file_time_name. */
104 #include <vms/atrdef.h>
105 #include <vms/fibdef.h>
106 #include <vms/stsdef.h>
107 #include <vms/iodef.h>
109 #include <vms/descrip.h>
113 /* Use native 64-bit arithmetic. */
114 #define unix_time_to_vms(X,Y) \
115 { unsigned long long reftime, tmptime = (X); \
116 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
117 SYS$BINTIM (&unixtime, &reftime); \
118 Y = tmptime * 10000000 + reftime; }
120 /* descrip.h doesn't have everything ... */
121 struct dsc$descriptor_fib
123 unsigned long fib$l_len
;
124 struct fibdef
*fib$l_addr
;
127 /* I/O Status Block. */
130 unsigned short status
, count
;
131 unsigned long devdep
;
134 static char *tryfile
;
136 /* Variable length string. */
140 char string
[NAM$C_MAXRSS
+1];
147 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
155 #define DIR_SEPARATOR '\\'
160 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
161 defined in the current system. On DOS-like systems these flags control
162 whether the file is opened/created in text-translation mode (CR/LF in
163 external file mapped to LF in internal file), but in Unix-like systems,
164 no text translation is required, so these flags have no effect. */
166 #if defined (__EMX__)
182 #ifndef HOST_EXECUTABLE_SUFFIX
183 #define HOST_EXECUTABLE_SUFFIX ""
186 #ifndef HOST_OBJECT_SUFFIX
187 #define HOST_OBJECT_SUFFIX ".o"
190 #ifndef PATH_SEPARATOR
191 #define PATH_SEPARATOR ':'
194 #ifndef DIR_SEPARATOR
195 #define DIR_SEPARATOR '/'
198 /* Check for cross-compilation */
200 int __gnat_is_cross_compiler
= 1;
202 int __gnat_is_cross_compiler
= 0;
205 char __gnat_dir_separator
= DIR_SEPARATOR
;
207 char __gnat_path_separator
= PATH_SEPARATOR
;
209 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
210 the base filenames that libraries specified with -lsomelib options
211 may have. This is used by GNATMAKE to check whether an executable
212 is up-to-date or not. The syntax is
214 library_template ::= { pattern ; } pattern NUL
215 pattern ::= [ prefix ] * [ postfix ]
217 These should only specify names of static libraries as it makes
218 no sense to determine at link time if dynamic-link libraries are
219 up to date or not. Any libraries that are not found are supposed
222 * if they are needed but not present, the link
225 * otherwise they are libraries in the system paths and so
226 they are considered part of the system and not checked
229 ??? This should be part of a GNAT host-specific compiler
230 file instead of being included in all user applications
231 as well. This is only a temporary work-around for 3.11b. */
233 #ifndef GNAT_LIBRARY_TEMPLATE
234 #if defined (__EMX__)
235 #define GNAT_LIBRARY_TEMPLATE "*.a"
237 #define GNAT_LIBRARY_TEMPLATE "*.olb"
239 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
243 const char *__gnat_library_template
= GNAT_LIBRARY_TEMPLATE
;
245 /* This variable is used in hostparm.ads to say whether the host is a VMS
248 const int __gnat_vmsp
= 1;
250 const int __gnat_vmsp
= 0;
254 #define GNAT_MAX_PATH_LEN MAX_PATH
257 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
259 #elif defined (__vxworks) || defined (__OPENNT)
260 #define GNAT_MAX_PATH_LEN PATH_MAX
264 #if defined (__MINGW32__)
268 #include <sys/param.h>
272 #include <sys/param.h>
276 #define GNAT_MAX_PATH_LEN MAXPATHLEN
278 #define GNAT_MAX_PATH_LEN 256
283 /* The __gnat_max_path_len variable is used to export the maximum
284 length of a path name to Ada code. max_path_len is also provided
285 for compatibility with older GNAT versions, please do not use
288 int __gnat_max_path_len
= GNAT_MAX_PATH_LEN
;
289 int max_path_len
= GNAT_MAX_PATH_LEN
;
291 /* The following macro HAVE_READDIR_R should be defined if the
292 system provides the routine readdir_r. */
293 #undef HAVE_READDIR_R
295 #if defined(VMS) && defined (__LONG_POINTERS)
297 /* Return a 32 bit pointer to an array of 32 bit pointers
298 given a 64 bit pointer to an array of 64 bit pointers */
300 typedef __char_ptr32
*__char_ptr_char_ptr32
__attribute__ ((mode (SI
)));
302 static __char_ptr_char_ptr32
303 to_ptr32 (char **ptr64
)
306 __char_ptr_char_ptr32 short_argv
;
308 for (argc
=0; ptr64
[argc
]; argc
++);
310 /* Reallocate argv with 32 bit pointers. */
311 short_argv
= (__char_ptr_char_ptr32
) decc$malloc
312 (sizeof (__char_ptr32
) * (argc
+ 1));
314 for (argc
=0; ptr64
[argc
]; argc
++)
315 short_argv
[argc
] = (__char_ptr32
) decc$
strdup (ptr64
[argc
]);
317 short_argv
[argc
] = (__char_ptr32
) 0;
321 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
323 #define MAYBE_TO_PTR32(argv) argv
337 time_t time
= (time_t) *p_time
;
340 /* On Windows systems, the time is sometimes rounded up to the nearest
341 even second, so if the number of seconds is odd, increment it. */
347 res
= localtime (&time
);
349 res
= gmtime (&time
);
354 *p_year
= res
->tm_year
;
355 *p_month
= res
->tm_mon
;
356 *p_day
= res
->tm_mday
;
357 *p_hours
= res
->tm_hour
;
358 *p_mins
= res
->tm_min
;
359 *p_secs
= res
->tm_sec
;
362 *p_year
= *p_month
= *p_day
= *p_hours
= *p_mins
= *p_secs
= 0;
365 /* Place the contents of the symbolic link named PATH in the buffer BUF,
366 which has size BUFSIZ. If PATH is a symbolic link, then return the number
367 of characters of its content in BUF. Otherwise, return -1. For Windows,
368 OS/2 and vxworks, always return -1. */
371 __gnat_readlink (char *path ATTRIBUTE_UNUSED
,
372 char *buf ATTRIBUTE_UNUSED
,
373 size_t bufsiz ATTRIBUTE_UNUSED
)
375 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
377 #elif defined (__INTERIX) || defined (VMS)
379 #elif defined (__vxworks)
382 return readlink (path
, buf
, bufsiz
);
386 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH. If
387 NEWPATH exists it will NOT be overwritten. For Windows, OS/2, VxWorks,
388 Interix and VMS, always return -1. */
391 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED
,
392 char *newpath ATTRIBUTE_UNUSED
)
394 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
396 #elif defined (__INTERIX) || defined (VMS)
398 #elif defined (__vxworks)
401 return symlink (oldpath
, newpath
);
405 /* Try to lock a file, return 1 if success. */
407 #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32)
409 /* Version that does not use link. */
412 __gnat_try_lock (char *dir
, char *file
)
417 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
418 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
426 #elif defined (__EMX__) || defined (VMS)
428 /* More cases that do not use link; identical code, to solve too long
432 __gnat_try_lock (char *dir
, char *file
)
437 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
438 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
448 /* Version using link(), more secure over NFS. */
449 /* See TN 6913-016 for discussion ??? */
452 __gnat_try_lock (char *dir
, char *file
)
456 struct stat stat_result
;
459 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
460 sprintf (temp_file
, "%s%cTMP-%ld-%ld",
461 dir
, DIR_SEPARATOR
, (long)getpid(), (long)getppid ());
463 /* Create the temporary file and write the process number. */
464 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
470 /* Link it with the new file. */
471 link (temp_file
, full_path
);
473 /* Count the references on the old one. If we have a count of two, then
474 the link did succeed. Remove the temporary file before returning. */
475 __gnat_stat (temp_file
, &stat_result
);
477 return stat_result
.st_nlink
== 2;
481 /* Return the maximum file name length. */
484 __gnat_get_maximum_file_name_length (void)
489 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
498 /* Return nonzero if file names are case sensitive. */
501 __gnat_get_file_names_case_sensitive (void)
503 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT)
511 __gnat_get_default_identifier_character_set (void)
513 #if defined (__EMX__) || defined (MSDOS)
520 /* Return the current working directory. */
523 __gnat_get_current_dir (char *dir
, int *length
)
526 /* Force Unix style, which is what GNAT uses internally. */
527 getcwd (dir
, *length
, 0);
529 getcwd (dir
, *length
);
532 *length
= strlen (dir
);
534 if (dir
[*length
- 1] != DIR_SEPARATOR
)
536 dir
[*length
] = DIR_SEPARATOR
;
542 /* Return the suffix for object files. */
545 __gnat_get_object_suffix_ptr (int *len
, const char **value
)
547 *value
= HOST_OBJECT_SUFFIX
;
552 *len
= strlen (*value
);
557 /* Return the suffix for executable files. */
560 __gnat_get_executable_suffix_ptr (int *len
, const char **value
)
562 *value
= HOST_EXECUTABLE_SUFFIX
;
566 *len
= strlen (*value
);
571 /* Return the suffix for debuggable files. Usually this is the same as the
572 executable extension. */
575 __gnat_get_debuggable_suffix_ptr (int *len
, const char **value
)
578 *value
= HOST_EXECUTABLE_SUFFIX
;
580 /* On DOS, the extensionless COFF file is what gdb likes. */
587 *len
= strlen (*value
);
593 __gnat_open_read (char *path
, int fmode
)
596 int o_fmode
= O_BINARY
;
602 /* Optional arguments mbc,deq,fop increase read performance. */
603 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
604 "mbc=16", "deq=64", "fop=tef");
605 #elif defined (__vxworks)
606 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
608 fd
= open (path
, O_RDONLY
| o_fmode
);
611 return fd
< 0 ? -1 : fd
;
614 #if defined (__EMX__) || defined (__MINGW32__)
615 #define PERM (S_IREAD | S_IWRITE)
617 /* Excerpt from DECC C RTL Reference Manual:
618 To create files with OpenVMS RMS default protections using the UNIX
619 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
620 and open with a file-protection mode argument of 0777 in a program
621 that never specifically calls umask. These default protections include
622 correctly establishing protections based on ACLs, previous versions of
626 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
630 __gnat_open_rw (char *path
, int fmode
)
633 int o_fmode
= O_BINARY
;
639 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
640 "mbc=16", "deq=64", "fop=tef");
642 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
645 return fd
< 0 ? -1 : fd
;
649 __gnat_open_create (char *path
, int fmode
)
652 int o_fmode
= O_BINARY
;
658 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
659 "mbc=16", "deq=64", "fop=tef");
661 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
664 return fd
< 0 ? -1 : fd
;
668 __gnat_create_output_file (char *path
)
672 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
,
673 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
674 "shr=del,get,put,upd");
676 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
679 return fd
< 0 ? -1 : fd
;
683 __gnat_open_append (char *path
, int fmode
)
686 int o_fmode
= O_BINARY
;
692 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
693 "mbc=16", "deq=64", "fop=tef");
695 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
698 return fd
< 0 ? -1 : fd
;
701 /* Open a new file. Return error (-1) if the file already exists. */
704 __gnat_open_new (char *path
, int fmode
)
707 int o_fmode
= O_BINARY
;
713 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
714 "mbc=16", "deq=64", "fop=tef");
716 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
719 return fd
< 0 ? -1 : fd
;
722 /* Open a new temp file. Return error (-1) if the file already exists.
723 Special options for VMS allow the file to be shared between parent and child
724 processes, however they really slow down output. Used in gnatchop. */
727 __gnat_open_new_temp (char *path
, int fmode
)
730 int o_fmode
= O_BINARY
;
732 strcpy (path
, "GNAT-XXXXXX");
734 #if (defined (__FreeBSD__) || defined (linux)) && !defined (__vxworks)
735 return mkstemp (path
);
736 #elif defined (__Lynx__)
739 if (mktemp (path
) == NULL
)
747 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
748 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
749 "mbc=16", "deq=64", "fop=tef");
751 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
754 return fd
< 0 ? -1 : fd
;
757 /* Return the number of bytes in the specified file. */
760 __gnat_file_length (int fd
)
765 ret
= fstat (fd
, &statbuf
);
766 if (ret
|| !S_ISREG (statbuf
.st_mode
))
769 return (statbuf
.st_size
);
772 /* Return the number of bytes in the specified named file. */
775 __gnat_named_file_length (char *name
)
780 ret
= __gnat_stat (name
, &statbuf
);
781 if (ret
|| !S_ISREG (statbuf
.st_mode
))
784 return (statbuf
.st_size
);
787 /* Create a temporary filename and put it in string pointed to by
791 __gnat_tmp_name (char *tmp_filename
)
797 /* tempnam tries to create a temporary file in directory pointed to by
798 TMP environment variable, in c:\temp if TMP is not set, and in
799 directory specified by P_tmpdir in stdio.h if c:\temp does not
800 exist. The filename will be created with the prefix "gnat-". */
802 pname
= (char *) tempnam ("c:\\temp", "gnat-");
804 /* if pname is NULL, the file was not created properly, the disk is full
805 or there is no more free temporary files */
808 *tmp_filename
= '\0';
810 /* If pname start with a back slash and not path information it means that
811 the filename is valid for the current working directory. */
813 else if (pname
[0] == '\\')
815 strcpy (tmp_filename
, ".\\");
816 strcat (tmp_filename
, pname
+1);
819 strcpy (tmp_filename
, pname
);
824 #elif defined (linux) || defined (__FreeBSD__)
825 #define MAX_SAFE_PATH 1000
826 char *tmpdir
= getenv ("TMPDIR");
828 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
829 a buffer overflow. */
830 if (tmpdir
== NULL
|| strlen (tmpdir
) > MAX_SAFE_PATH
)
831 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
833 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
835 close (mkstemp(tmp_filename
));
837 tmpnam (tmp_filename
);
841 /* Read the next entry in a directory. The returned string points somewhere
845 __gnat_readdir (DIR *dirp
, char *buffer
)
847 /* If possible, try to use the thread-safe version. */
848 #ifdef HAVE_READDIR_R
849 if (readdir_r (dirp
, buffer
) != NULL
)
850 return ((struct dirent
*) buffer
)->d_name
;
855 struct dirent
*dirent
= (struct dirent
*) readdir (dirp
);
859 strcpy (buffer
, dirent
->d_name
);
868 /* Returns 1 if readdir is thread safe, 0 otherwise. */
871 __gnat_readdir_is_thread_safe (void)
873 #ifdef HAVE_READDIR_R
881 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
882 static const unsigned long long w32_epoch_offset
= 11644473600ULL;
884 /* Returns the file modification timestamp using Win32 routines which are
885 immune against daylight saving time change. It is in fact not possible to
886 use fstat for this purpose as the DST modify the st_mtime field of the
890 win32_filetime (HANDLE h
)
895 unsigned long long ull_time
;
898 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
899 since <Jan 1st 1601>. This function must return the number of seconds
900 since <Jan 1st 1970>. */
902 if (GetFileTime (h
, NULL
, NULL
, &t_write
.ft_time
))
903 return (time_t) (t_write
.ull_time
/ 10000000ULL
909 /* Return a GNAT time stamp given a file name. */
912 __gnat_file_time_name (char *name
)
915 #if defined (__EMX__) || defined (MSDOS)
916 int fd
= open (name
, O_RDONLY
| O_BINARY
);
917 time_t ret
= __gnat_file_time_fd (fd
);
921 #elif defined (_WIN32)
923 HANDLE h
= CreateFile (name
, GENERIC_READ
, FILE_SHARE_READ
, 0,
924 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
, 0);
926 if (h
!= INVALID_HANDLE_VALUE
)
928 ret
= win32_filetime (h
);
931 return (OS_Time
) ret
;
934 if (__gnat_stat (name
, &statbuf
) != 0) {
938 /* VMS has file versioning. */
939 return (OS_Time
)statbuf
.st_ctime
;
941 return (OS_Time
)statbuf
.st_mtime
;
947 /* Return a GNAT time stamp given a file descriptor. */
950 __gnat_file_time_fd (int fd
)
952 /* The following workaround code is due to the fact that under EMX and
953 DJGPP fstat attempts to convert time values to GMT rather than keep the
954 actual OS timestamp of the file. By using the OS2/DOS functions directly
955 the GNAT timestamp are independent of this behavior, which is desired to
956 facilitate the distribution of GNAT compiled libraries. */
958 #if defined (__EMX__) || defined (MSDOS)
962 int ret
= DosQueryFileInfo (fd
, 1, (unsigned char *) &fs
,
963 sizeof (FILESTATUS
));
965 unsigned file_year
= fs
.fdateLastWrite
.year
;
966 unsigned file_month
= fs
.fdateLastWrite
.month
;
967 unsigned file_day
= fs
.fdateLastWrite
.day
;
968 unsigned file_hour
= fs
.ftimeLastWrite
.hours
;
969 unsigned file_min
= fs
.ftimeLastWrite
.minutes
;
970 unsigned file_tsec
= fs
.ftimeLastWrite
.twosecs
;
974 int ret
= getftime (fd
, &fs
);
976 unsigned file_year
= fs
.ft_year
;
977 unsigned file_month
= fs
.ft_month
;
978 unsigned file_day
= fs
.ft_day
;
979 unsigned file_hour
= fs
.ft_hour
;
980 unsigned file_min
= fs
.ft_min
;
981 unsigned file_tsec
= fs
.ft_tsec
;
984 /* Calculate the seconds since epoch from the time components. First count
985 the whole days passed. The value for years returned by the DOS and OS2
986 functions count years from 1980, so to compensate for the UNIX epoch which
987 begins in 1970 start with 10 years worth of days and add days for each
988 four year period since then. */
991 int cum_days
[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
992 int days_passed
= 3652 + (file_year
/ 4) * 1461;
993 int years_since_leap
= file_year
% 4;
995 if (years_since_leap
== 1)
997 else if (years_since_leap
== 2)
999 else if (years_since_leap
== 3)
1000 days_passed
+= 1096;
1005 days_passed
+= cum_days
[file_month
- 1];
1006 if (years_since_leap
== 0 && file_year
!= 20 && file_month
> 2)
1009 days_passed
+= file_day
- 1;
1011 /* OK - have whole days. Multiply -- then add in other parts. */
1013 tot_secs
= days_passed
* 86400;
1014 tot_secs
+= file_hour
* 3600;
1015 tot_secs
+= file_min
* 60;
1016 tot_secs
+= file_tsec
* 2;
1017 return (OS_Time
) tot_secs
;
1019 #elif defined (_WIN32)
1020 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
1021 time_t ret
= win32_filetime (h
);
1022 return (OS_Time
) ret
;
1025 struct stat statbuf
;
1027 if (fstat (fd
, &statbuf
) != 0) {
1028 return (OS_Time
) -1;
1031 /* VMS has file versioning. */
1032 return (OS_Time
) statbuf
.st_ctime
;
1034 return (OS_Time
) statbuf
.st_mtime
;
1040 /* Set the file time stamp. */
1043 __gnat_set_file_time_name (char *name
, time_t time_stamp
)
1045 #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1047 /* Code to implement __gnat_set_file_time_name for these systems. */
1049 #elif defined (_WIN32)
1053 unsigned long long ull_time
;
1056 HANDLE h
= CreateFile (name
, GENERIC_WRITE
, FILE_SHARE_WRITE
, NULL
,
1057 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
,
1059 if (h
== INVALID_HANDLE_VALUE
)
1061 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1062 t_write
.ull_time
= ((unsigned long long)time_stamp
+ w32_epoch_offset
);
1063 /* Convert to 100 nanosecond units */
1064 t_write
.ull_time
*= 10000000ULL;
1066 SetFileTime(h
, NULL
, NULL
, &t_write
.ft_time
);
1076 unsigned long long backup
, create
, expire
, revise
;
1080 unsigned short value
;
1083 unsigned system
: 4;
1089 } Fat
= { 0, 0, 0, 0, 0, { 0 }};
1093 { ATR$S_CREDATE
, ATR$C_CREDATE
, &Fat
.create
},
1094 { ATR$S_REVDATE
, ATR$C_REVDATE
, &Fat
.revise
},
1095 { ATR$S_EXPDATE
, ATR$C_EXPDATE
, &Fat
.expire
},
1096 { ATR$S_BAKDATE
, ATR$C_BAKDATE
, &Fat
.backup
},
1097 { ATR$S_FPRO
, ATR$C_FPRO
, &Fat
.prot
},
1098 { ATR$S_UIC
, ATR$C_UIC
, &Fat
.uic
},
1103 struct dsc$descriptor_fib fibdsc
= {sizeof (fib
), (void *) &fib
};
1107 unsigned long long newtime
;
1108 unsigned long long revtime
;
1112 struct vstring file
;
1113 struct dsc$descriptor_s filedsc
1114 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) file
.string
};
1115 struct vstring device
;
1116 struct dsc$descriptor_s devicedsc
1117 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) device
.string
};
1118 struct vstring timev
;
1119 struct dsc$descriptor_s timedsc
1120 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) timev
.string
};
1121 struct vstring result
;
1122 struct dsc$descriptor_s resultdsc
1123 = {NAM$C_MAXRSS
, DSC$K_DTYPE_VT
, DSC$K_CLASS_VS
, (void *) result
.string
};
1125 tryfile
= (char *) __gnat_to_host_dir_spec (name
, 0);
1127 /* Allocate and initialize a FAB and NAM structures. */
1131 nam
.nam$l_esa
= file
.string
;
1132 nam
.nam$b_ess
= NAM$C_MAXRSS
;
1133 nam
.nam$l_rsa
= result
.string
;
1134 nam
.nam$b_rss
= NAM$C_MAXRSS
;
1135 fab
.fab$l_fna
= tryfile
;
1136 fab
.fab$b_fns
= strlen (tryfile
);
1137 fab
.fab$l_nam
= &nam
;
1139 /* Validate filespec syntax and device existence. */
1140 status
= SYS$
PARSE (&fab
, 0, 0);
1141 if ((status
& 1) != 1)
1142 LIB$
SIGNAL (status
);
1144 file
.string
[nam
.nam$b_esl
] = 0;
1146 /* Find matching filespec. */
1147 status
= SYS$
SEARCH (&fab
, 0, 0);
1148 if ((status
& 1) != 1)
1149 LIB$
SIGNAL (status
);
1151 file
.string
[nam
.nam$b_esl
] = 0;
1152 result
.string
[result
.length
=nam
.nam$b_rsl
] = 0;
1154 /* Get the device name and assign an IO channel. */
1155 strncpy (device
.string
, nam
.nam$l_dev
, nam
.nam$b_dev
);
1156 devicedsc
.dsc$w_length
= nam
.nam$b_dev
;
1158 status
= SYS$
ASSIGN (&devicedsc
, &chan
, 0, 0, 0);
1159 if ((status
& 1) != 1)
1160 LIB$
SIGNAL (status
);
1162 /* Initialize the FIB and fill in the directory id field. */
1163 memset (&fib
, 0, sizeof (fib
));
1164 fib
.fib$w_did
[0] = nam
.nam$w_did
[0];
1165 fib
.fib$w_did
[1] = nam
.nam$w_did
[1];
1166 fib
.fib$w_did
[2] = nam
.nam$w_did
[2];
1167 fib
.fib$l_acctl
= 0;
1169 strcpy (file
.string
, (strrchr (result
.string
, ']') + 1));
1170 filedsc
.dsc$w_length
= strlen (file
.string
);
1171 result
.string
[result
.length
= 0] = 0;
1173 /* Open and close the file to fill in the attributes. */
1175 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1176 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1177 if ((status
& 1) != 1)
1178 LIB$
SIGNAL (status
);
1179 if ((iosb
.status
& 1) != 1)
1180 LIB$
SIGNAL (iosb
.status
);
1182 result
.string
[result
.length
] = 0;
1183 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0, &fibdsc
, 0, 0, 0,
1185 if ((status
& 1) != 1)
1186 LIB$
SIGNAL (status
);
1187 if ((iosb
.status
& 1) != 1)
1188 LIB$
SIGNAL (iosb
.status
);
1193 /* Set creation time to requested time. */
1194 unix_time_to_vms (time_stamp
, newtime
);
1196 t
= time ((time_t) 0);
1198 /* Set revision time to now in local time. */
1199 unix_time_to_vms (t
, revtime
);
1202 /* Reopen the file, modify the times and then close. */
1203 fib
.fib$l_acctl
= FIB$M_WRITE
;
1205 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1206 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1207 if ((status
& 1) != 1)
1208 LIB$
SIGNAL (status
);
1209 if ((iosb
.status
& 1) != 1)
1210 LIB$
SIGNAL (iosb
.status
);
1212 Fat
.create
= newtime
;
1213 Fat
.revise
= revtime
;
1215 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0,
1216 &fibdsc
, 0, 0, 0, &atrlst
, 0);
1217 if ((status
& 1) != 1)
1218 LIB$
SIGNAL (status
);
1219 if ((iosb
.status
& 1) != 1)
1220 LIB$
SIGNAL (iosb
.status
);
1222 /* Deassign the channel and exit. */
1223 status
= SYS$
DASSGN (chan
);
1224 if ((status
& 1) != 1)
1225 LIB$
SIGNAL (status
);
1227 struct utimbuf utimbuf
;
1230 /* Set modification time to requested time. */
1231 utimbuf
.modtime
= time_stamp
;
1233 /* Set access time to now in local time. */
1234 t
= time ((time_t) 0);
1235 utimbuf
.actime
= mktime (localtime (&t
));
1237 utime (name
, &utimbuf
);
1242 __gnat_get_env_value_ptr (char *name
, int *len
, char **value
)
1244 *value
= getenv (name
);
1248 *len
= strlen (*value
);
1253 /* VMS specific declarations for set_env_value. */
1257 static char *to_host_path_spec (char *);
1261 unsigned short len
, mbz
;
1265 typedef struct _ile3
1267 unsigned short len
, code
;
1269 unsigned short *retlen_adr
;
1275 __gnat_set_env_value (char *name
, char *value
)
1280 struct descriptor_s name_desc
;
1281 /* Put in JOB table for now, so that the project stuff at least works. */
1282 struct descriptor_s table_desc
= {7, 0, "LNM$JOB"};
1283 char *host_pathspec
= value
;
1284 char *copy_pathspec
;
1285 int num_dirs_in_pathspec
= 1;
1289 name_desc
.len
= strlen (name
);
1291 name_desc
.adr
= name
;
1293 if (*host_pathspec
== 0)
1296 status
= LIB$
DELETE_LOGICAL (&name_desc
, &table_desc
);
1297 /* no need to check status; if the logical name is not
1298 defined, that's fine. */
1302 ptr
= host_pathspec
;
1305 num_dirs_in_pathspec
++;
1309 ile_s
*ile_array
= alloca (sizeof (ile_s
) * (num_dirs_in_pathspec
+ 1));
1310 char *copy_pathspec
= alloca (strlen (host_pathspec
) + 1);
1313 strcpy (copy_pathspec
, host_pathspec
);
1314 curr
= copy_pathspec
;
1315 for (i
= 0; i
< num_dirs_in_pathspec
; i
++)
1317 next
= strchr (curr
, ',');
1319 next
= strchr (curr
, 0);
1322 ile_array
[i
].len
= strlen (curr
);
1324 /* Code 2 from lnmdef.h means it's a string. */
1325 ile_array
[i
].code
= 2;
1326 ile_array
[i
].adr
= curr
;
1328 /* retlen_adr is ignored. */
1329 ile_array
[i
].retlen_adr
= 0;
1333 /* Terminating item must be zero. */
1334 ile_array
[i
].len
= 0;
1335 ile_array
[i
].code
= 0;
1336 ile_array
[i
].adr
= 0;
1337 ile_array
[i
].retlen_adr
= 0;
1339 status
= LIB$
SET_LOGICAL (&name_desc
, 0, &table_desc
, 0, ile_array
);
1340 if ((status
& 1) != 1)
1341 LIB$
SIGNAL (status
);
1344 #elif defined (__vxworks) && defined (__RTP__)
1345 setenv (name
, value
, 1);
1348 int size
= strlen (name
) + strlen (value
) + 2;
1351 expression
= (char *) xmalloc (size
* sizeof (char));
1353 sprintf (expression
, "%s=%s", name
, value
);
1354 putenv (expression
);
1359 #include <windows.h>
1362 /* Get the list of installed standard libraries from the
1363 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1367 __gnat_get_libraries_from_registry (void)
1369 char *result
= (char *) "";
1371 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_COMPILE)
1374 DWORD name_size
, value_size
;
1381 /* First open the key. */
1382 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1384 if (res
== ERROR_SUCCESS
)
1385 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1386 KEY_READ
, ®_key
);
1388 if (res
== ERROR_SUCCESS
)
1389 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1391 if (res
== ERROR_SUCCESS
)
1392 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1394 /* If the key exists, read out all the values in it and concatenate them
1396 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1398 value_size
= name_size
= 256;
1399 res
= RegEnumValue (reg_key
, index
, name
, &name_size
, 0,
1400 &type
, (LPBYTE
)value
, &value_size
);
1402 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1404 char *old_result
= result
;
1406 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1407 strcpy (result
, old_result
);
1408 strcat (result
, value
);
1409 strcat (result
, ";");
1413 /* Remove the trailing ";". */
1415 result
[strlen (result
) - 1] = 0;
1422 __gnat_stat (char *name
, struct stat
*statbuf
)
1425 /* Under Windows the directory name for the stat function must not be
1426 terminated by a directory separator except if just after a drive name. */
1427 int name_len
= strlen (name
);
1428 char last_char
= name
[name_len
- 1];
1429 char win32_name
[GNAT_MAX_PATH_LEN
+ 2];
1431 if (name_len
> GNAT_MAX_PATH_LEN
)
1434 strcpy (win32_name
, name
);
1436 while (name_len
> 1 && (last_char
== '\\' || last_char
== '/'))
1438 win32_name
[name_len
- 1] = '\0';
1440 last_char
= win32_name
[name_len
- 1];
1443 if (name_len
== 2 && win32_name
[1] == ':')
1444 strcat (win32_name
, "\\");
1446 return stat (win32_name
, statbuf
);
1449 return stat (name
, statbuf
);
1454 __gnat_file_exists (char *name
)
1456 struct stat statbuf
;
1458 return !__gnat_stat (name
, &statbuf
);
1462 __gnat_is_absolute_path (char *name
, int length
)
1464 return (length
!= 0) &&
1465 (*name
== '/' || *name
== DIR_SEPARATOR
1466 #if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
1467 || (length
> 1 && isalpha (name
[0]) && name
[1] == ':')
1473 __gnat_is_regular_file (char *name
)
1476 struct stat statbuf
;
1478 ret
= __gnat_stat (name
, &statbuf
);
1479 return (!ret
&& S_ISREG (statbuf
.st_mode
));
1483 __gnat_is_directory (char *name
)
1486 struct stat statbuf
;
1488 ret
= __gnat_stat (name
, &statbuf
);
1489 return (!ret
&& S_ISDIR (statbuf
.st_mode
));
1493 __gnat_is_readable_file (char *name
)
1497 struct stat statbuf
;
1499 ret
= __gnat_stat (name
, &statbuf
);
1500 mode
= statbuf
.st_mode
& S_IRUSR
;
1501 return (!ret
&& mode
);
1505 __gnat_is_writable_file (char *name
)
1509 struct stat statbuf
;
1511 ret
= __gnat_stat (name
, &statbuf
);
1512 mode
= statbuf
.st_mode
& S_IWUSR
;
1513 return (!ret
&& mode
);
1517 __gnat_set_writable (char *name
)
1520 struct stat statbuf
;
1522 if (stat (name
, &statbuf
) == 0)
1524 statbuf
.st_mode
= statbuf
.st_mode
| S_IWUSR
;
1525 chmod (name
, statbuf
.st_mode
);
1531 __gnat_set_executable (char *name
)
1534 struct stat statbuf
;
1536 if (stat (name
, &statbuf
) == 0)
1538 statbuf
.st_mode
= statbuf
.st_mode
| S_IXUSR
;
1539 chmod (name
, statbuf
.st_mode
);
1545 __gnat_set_readonly (char *name
)
1548 struct stat statbuf
;
1550 if (stat (name
, &statbuf
) == 0)
1552 statbuf
.st_mode
= statbuf
.st_mode
& 07577;
1553 chmod (name
, statbuf
.st_mode
);
1559 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED
)
1561 #if defined (__vxworks)
1564 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
1566 struct stat statbuf
;
1568 ret
= lstat (name
, &statbuf
);
1569 return (!ret
&& S_ISLNK (statbuf
.st_mode
));
1576 #if defined (sun) && defined (__SVR4)
1577 /* Using fork on Solaris will duplicate all the threads. fork1, which
1578 duplicates only the active thread, must be used instead, or spawning
1579 subprocess from a program with tasking will lead into numerous problems. */
1584 __gnat_portable_spawn (char *args
[])
1587 int finished ATTRIBUTE_UNUSED
;
1588 int pid ATTRIBUTE_UNUSED
;
1590 #if defined (MSDOS) || defined (_WIN32)
1591 /* args[0] must be quotes as it could contain a full pathname with spaces */
1592 char *args_0
= args
[0];
1593 args
[0] = (char *)xmalloc (strlen (args_0
) + 3);
1594 strcpy (args
[0], "\"");
1595 strcat (args
[0], args_0
);
1596 strcat (args
[0], "\"");
1598 status
= spawnvp (P_WAIT
, args_0
, (const char* const*)args
);
1600 /* restore previous value */
1602 args
[0] = (char *)args_0
;
1609 #elif defined (__vxworks)
1614 pid
= spawnvp (P_NOWAIT
, args
[0], args
);
1626 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
1628 return -1; /* execv is in parent context on VMS. */
1636 finished
= waitpid (pid
, &status
, 0);
1638 if (finished
!= pid
|| WIFEXITED (status
) == 0)
1641 return WEXITSTATUS (status
);
1647 /* Create a copy of the given file descriptor.
1648 Return -1 if an error occurred. */
1651 __gnat_dup (int oldfd
)
1653 #if defined (__vxworks) && !defined (__RTP__)
1654 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
1662 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
1663 Return -1 if an error occurred. */
1666 __gnat_dup2 (int oldfd
, int newfd
)
1668 #if defined (__vxworks) && !defined (__RTP__)
1669 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
1673 return dup2 (oldfd
, newfd
);
1677 /* WIN32 code to implement a wait call that wait for any child process. */
1681 /* Synchronization code, to be thread safe. */
1683 static CRITICAL_SECTION plist_cs
;
1686 __gnat_plist_init (void)
1688 InitializeCriticalSection (&plist_cs
);
1694 EnterCriticalSection (&plist_cs
);
1700 LeaveCriticalSection (&plist_cs
);
1703 typedef struct _process_list
1706 struct _process_list
*next
;
1709 static Process_List
*PLIST
= NULL
;
1711 static int plist_length
= 0;
1714 add_handle (HANDLE h
)
1718 pl
= (Process_List
*) xmalloc (sizeof (Process_List
));
1722 /* -------------------- critical section -------------------- */
1727 /* -------------------- critical section -------------------- */
1733 remove_handle (HANDLE h
)
1736 Process_List
*prev
= NULL
;
1740 /* -------------------- critical section -------------------- */
1749 prev
->next
= pl
->next
;
1761 /* -------------------- critical section -------------------- */
1767 win32_no_block_spawn (char *command
, char *args
[])
1771 PROCESS_INFORMATION PI
;
1772 SECURITY_ATTRIBUTES SA
;
1777 /* compute the total command line length */
1781 csize
+= strlen (args
[k
]) + 1;
1785 full_command
= (char *) xmalloc (csize
);
1788 SI
.cb
= sizeof (STARTUPINFO
);
1789 SI
.lpReserved
= NULL
;
1790 SI
.lpReserved2
= NULL
;
1791 SI
.lpDesktop
= NULL
;
1795 SI
.wShowWindow
= SW_HIDE
;
1797 /* Security attributes. */
1798 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
1799 SA
.bInheritHandle
= TRUE
;
1800 SA
.lpSecurityDescriptor
= NULL
;
1802 /* Prepare the command string. */
1803 strcpy (full_command
, command
);
1804 strcat (full_command
, " ");
1809 strcat (full_command
, args
[k
]);
1810 strcat (full_command
, " ");
1814 result
= CreateProcess
1815 (NULL
, (char *) full_command
, &SA
, NULL
, TRUE
,
1816 GetPriorityClass (GetCurrentProcess()), NULL
, NULL
, &SI
, &PI
);
1818 free (full_command
);
1822 add_handle (PI
.hProcess
);
1823 CloseHandle (PI
.hThread
);
1824 return (int) PI
.hProcess
;
1831 win32_wait (int *status
)
1840 if (plist_length
== 0)
1846 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * plist_length
);
1851 /* -------------------- critical section -------------------- */
1858 /* -------------------- critical section -------------------- */
1862 res
= WaitForMultipleObjects (plist_length
, hl
, FALSE
, INFINITE
);
1863 h
= hl
[res
- WAIT_OBJECT_0
];
1868 GetExitCodeProcess (h
, &exitcode
);
1871 *status
= (int) exitcode
;
1878 __gnat_portable_no_block_spawn (char *args
[])
1882 #if defined (__EMX__) || defined (MSDOS)
1884 /* ??? For PC machines I (Franco) don't know the system calls to implement
1885 this routine. So I'll fake it as follows. This routine will behave
1886 exactly like the blocking portable_spawn and will systematically return
1887 a pid of 0 unless the spawned task did not complete successfully, in
1888 which case we return a pid of -1. To synchronize with this the
1889 portable_wait below systematically returns a pid of 0 and reports that
1890 the subprocess terminated successfully. */
1892 if (spawnvp (P_WAIT
, args
[0], args
) != 0)
1895 #elif defined (_WIN32)
1897 pid
= win32_no_block_spawn (args
[0], args
);
1900 #elif defined (__vxworks)
1909 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
1911 return -1; /* execv is in parent context on VMS. */
1923 __gnat_portable_wait (int *process_status
)
1928 #if defined (_WIN32)
1930 pid
= win32_wait (&status
);
1932 #elif defined (__EMX__) || defined (MSDOS)
1933 /* ??? See corresponding comment in portable_no_block_spawn. */
1935 #elif defined (__vxworks)
1936 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
1940 pid
= waitpid (-1, &status
, 0);
1941 status
= status
& 0xffff;
1944 *process_status
= status
;
1949 __gnat_os_exit (int status
)
1954 /* Locate a regular file, give a Path value. */
1957 __gnat_locate_regular_file (char *file_name
, char *path_val
)
1960 char *file_path
= alloca (strlen (file_name
) + 1);
1963 /* Return immediately if file_name is empty */
1965 if (*file_name
== '\0')
1968 /* Remove quotes around file_name if present */
1974 strcpy (file_path
, ptr
);
1976 ptr
= file_path
+ strlen (file_path
) - 1;
1981 /* Handle absolute pathnames. */
1983 absolute
= __gnat_is_absolute_path (file_path
, strlen (file_name
));
1987 if (__gnat_is_regular_file (file_path
))
1988 return xstrdup (file_path
);
1993 /* If file_name include directory separator(s), try it first as
1994 a path name relative to the current directory */
1995 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
2000 if (__gnat_is_regular_file (file_name
))
2001 return xstrdup (file_name
);
2008 /* The result has to be smaller than path_val + file_name. */
2009 char *file_path
= alloca (strlen (path_val
) + strlen (file_name
) + 2);
2013 for (; *path_val
== PATH_SEPARATOR
; path_val
++)
2019 /* Skip the starting quote */
2021 if (*path_val
== '"')
2024 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
2025 *ptr
++ = *path_val
++;
2029 /* Skip the ending quote */
2034 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
2035 *++ptr
= DIR_SEPARATOR
;
2037 strcpy (++ptr
, file_name
);
2039 if (__gnat_is_regular_file (file_path
))
2040 return xstrdup (file_path
);
2047 /* Locate an executable given a Path argument. This routine is only used by
2048 gnatbl and should not be used otherwise. Use locate_exec_on_path
2052 __gnat_locate_exec (char *exec_name
, char *path_val
)
2055 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
2057 char *full_exec_name
2058 = alloca (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
2060 strcpy (full_exec_name
, exec_name
);
2061 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
2062 ptr
= __gnat_locate_regular_file (full_exec_name
, path_val
);
2065 return __gnat_locate_regular_file (exec_name
, path_val
);
2069 return __gnat_locate_regular_file (exec_name
, path_val
);
2072 /* Locate an executable using the Systems default PATH. */
2075 __gnat_locate_exec_on_path (char *exec_name
)
2079 char *path_val
= "/VAXC$PATH";
2081 char *path_val
= getenv ("PATH");
2084 /* In Win32 systems we expand the PATH as for XP environment
2085 variables are not automatically expanded. We also prepend the
2086 ".;" to the path to match normal NT path search semantics */
2088 #define EXPAND_BUFFER_SIZE 32767
2090 apath_val
= alloca (EXPAND_BUFFER_SIZE
);
2092 apath_val
[0] = '.';
2093 apath_val
[1] = ';';
2095 DWORD res
= ExpandEnvironmentStrings
2096 (path_val
, apath_val
+ 2, EXPAND_BUFFER_SIZE
- 2);
2098 if (!res
) apath_val
[0] = '\0';
2100 apath_val
= alloca (strlen (path_val
) + 1);
2101 strcpy (apath_val
, path_val
);
2104 return __gnat_locate_exec (exec_name
, apath_val
);
2109 /* These functions are used to translate to and from VMS and Unix syntax
2110 file, directory and path specifications. */
2113 #define MAXNAMES 256
2114 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2116 static char new_canonical_dirspec
[MAXPATH
];
2117 static char new_canonical_filespec
[MAXPATH
];
2118 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
2119 static unsigned new_canonical_filelist_index
;
2120 static unsigned new_canonical_filelist_in_use
;
2121 static unsigned new_canonical_filelist_allocated
;
2122 static char **new_canonical_filelist
;
2123 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
2124 static char new_host_dirspec
[MAXPATH
];
2125 static char new_host_filespec
[MAXPATH
];
2127 /* Routine is called repeatedly by decc$from_vms via
2128 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2132 wildcard_translate_unix (char *name
)
2135 char buff
[MAXPATH
];
2137 strncpy (buff
, name
, MAXPATH
);
2138 buff
[MAXPATH
- 1] = (char) 0;
2139 ver
= strrchr (buff
, '.');
2141 /* Chop off the version. */
2145 /* Dynamically extend the allocation by the increment. */
2146 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
2148 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
2149 new_canonical_filelist
= (char **) xrealloc
2150 (new_canonical_filelist
,
2151 new_canonical_filelist_allocated
* sizeof (char *));
2154 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
2159 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2160 full translation and copy the results into a list (_init), then return them
2161 one at a time (_next). If onlydirs set, only expand directory files. */
2164 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
2167 char buff
[MAXPATH
];
2169 len
= strlen (filespec
);
2170 strncpy (buff
, filespec
, MAXPATH
);
2172 /* Only look for directories */
2173 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
2174 strncat (buff
, "*.dir", MAXPATH
);
2176 buff
[MAXPATH
- 1] = (char) 0;
2178 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
2180 /* Remove the .dir extension. */
2186 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
2188 ext
= strstr (new_canonical_filelist
[i
], ".dir");
2194 return new_canonical_filelist_in_use
;
2197 /* Return the next filespec in the list. */
2200 __gnat_to_canonical_file_list_next ()
2202 return new_canonical_filelist
[new_canonical_filelist_index
++];
2205 /* Free storage used in the wildcard expansion. */
2208 __gnat_to_canonical_file_list_free ()
2212 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
2213 free (new_canonical_filelist
[i
]);
2215 free (new_canonical_filelist
);
2217 new_canonical_filelist_in_use
= 0;
2218 new_canonical_filelist_allocated
= 0;
2219 new_canonical_filelist_index
= 0;
2220 new_canonical_filelist
= 0;
2223 /* Translate a VMS syntax directory specification in to Unix syntax. If
2224 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2225 found, return input string. Also translate a dirname that contains no
2226 slashes, in case it's a logical name. */
2229 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
2233 strcpy (new_canonical_dirspec
, "");
2234 if (strlen (dirspec
))
2238 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
2240 strncpy (new_canonical_dirspec
,
2241 (char *) decc$
translate_vms (dirspec
),
2244 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
2246 strncpy (new_canonical_dirspec
,
2247 (char *) decc$
translate_vms (dirspec1
),
2252 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
2256 len
= strlen (new_canonical_dirspec
);
2257 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
2258 strncat (new_canonical_dirspec
, "/", MAXPATH
);
2260 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
2262 return new_canonical_dirspec
;
2266 /* Translate a VMS syntax file specification into Unix syntax.
2267 If no indicators of VMS syntax found, check if it's an uppercase
2268 alphanumeric_ name and if so try it out as an environment
2269 variable (logical name). If all else fails return the
2273 __gnat_to_canonical_file_spec (char *filespec
)
2277 strncpy (new_canonical_filespec
, "", MAXPATH
);
2279 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
2281 char *tspec
= (char *) decc$
translate_vms (filespec
);
2283 if (tspec
!= (char *) -1)
2284 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
2286 else if ((strlen (filespec
) == strspn (filespec
,
2287 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
2288 && (filespec1
= getenv (filespec
)))
2290 char *tspec
= (char *) decc$
translate_vms (filespec1
);
2292 if (tspec
!= (char *) -1)
2293 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
2297 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
2300 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
2302 return new_canonical_filespec
;
2305 /* Translate a VMS syntax path specification into Unix syntax.
2306 If no indicators of VMS syntax found, return input string. */
2309 __gnat_to_canonical_path_spec (char *pathspec
)
2311 char *curr
, *next
, buff
[MAXPATH
];
2316 /* If there are /'s, assume it's a Unix path spec and return. */
2317 if (strchr (pathspec
, '/'))
2320 new_canonical_pathspec
[0] = 0;
2325 next
= strchr (curr
, ',');
2327 next
= strchr (curr
, 0);
2329 strncpy (buff
, curr
, next
- curr
);
2330 buff
[next
- curr
] = 0;
2332 /* Check for wildcards and expand if present. */
2333 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
2337 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
2338 for (i
= 0; i
< dirs
; i
++)
2342 next_dir
= __gnat_to_canonical_file_list_next ();
2343 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
2345 /* Don't append the separator after the last expansion. */
2347 strncat (new_canonical_pathspec
, ":", MAXPATH
);
2350 __gnat_to_canonical_file_list_free ();
2353 strncat (new_canonical_pathspec
,
2354 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
2359 strncat (new_canonical_pathspec
, ":", MAXPATH
);
2363 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
2365 return new_canonical_pathspec
;
2368 static char filename_buff
[MAXPATH
];
2371 translate_unix (char *name
, int type
)
2373 strncpy (filename_buff
, name
, MAXPATH
);
2374 filename_buff
[MAXPATH
- 1] = (char) 0;
2378 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
2382 to_host_path_spec (char *pathspec
)
2384 char *curr
, *next
, buff
[MAXPATH
];
2389 /* Can't very well test for colons, since that's the Unix separator! */
2390 if (strchr (pathspec
, ']') || strchr (pathspec
, ','))
2393 new_host_pathspec
[0] = 0;
2398 next
= strchr (curr
, ':');
2400 next
= strchr (curr
, 0);
2402 strncpy (buff
, curr
, next
- curr
);
2403 buff
[next
- curr
] = 0;
2405 strncat (new_host_pathspec
, __gnat_to_host_dir_spec (buff
, 0), MAXPATH
);
2408 strncat (new_host_pathspec
, ",", MAXPATH
);
2412 new_host_pathspec
[MAXPATH
- 1] = (char) 0;
2414 return new_host_pathspec
;
2417 /* Translate a Unix syntax directory specification into VMS syntax. The
2418 PREFIXFLAG has no effect, but is kept for symmetry with
2419 to_canonical_dir_spec. If indicators of VMS syntax found, return input
2423 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2425 int len
= strlen (dirspec
);
2427 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
2428 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
2430 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
2431 return new_host_dirspec
;
2433 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
2435 new_host_dirspec
[len
- 1] = 0;
2439 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
2440 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
2441 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
2443 return new_host_dirspec
;
2446 /* Translate a Unix syntax file specification into VMS syntax.
2447 If indicators of VMS syntax found, return input string. */
2450 __gnat_to_host_file_spec (char *filespec
)
2452 strncpy (new_host_filespec
, "", MAXPATH
);
2453 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
2455 strncpy (new_host_filespec
, filespec
, MAXPATH
);
2459 decc$
to_vms (filespec
, translate_unix
, 1, 1);
2460 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
2463 new_host_filespec
[MAXPATH
- 1] = (char) 0;
2465 return new_host_filespec
;
2469 __gnat_adjust_os_resource_limits ()
2471 SYS$
ADJWSL (131072, 0);
2476 /* Dummy functions for Osint import for non-VMS systems. */
2479 __gnat_to_canonical_file_list_init
2480 (char *dirspec ATTRIBUTE_UNUSED
, int onlydirs ATTRIBUTE_UNUSED
)
2486 __gnat_to_canonical_file_list_next (void)
2492 __gnat_to_canonical_file_list_free (void)
2497 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2503 __gnat_to_canonical_file_spec (char *filespec
)
2509 __gnat_to_canonical_path_spec (char *pathspec
)
2515 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2521 __gnat_to_host_file_spec (char *filespec
)
2527 __gnat_adjust_os_resource_limits (void)
2533 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
2534 to coordinate this with the EMX distribution. Consequently, we put the
2535 definition of dummy which is used for exception handling, here. */
2537 #if defined (__EMX__)
2541 #if defined (__mips_vxworks)
2545 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
2549 #if defined (CROSS_COMPILE) \
2550 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
2551 && defined (__SVR4)) \
2552 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
2553 && ! (defined (linux) && defined (__ia64__)) \
2554 && ! defined (__FreeBSD__) \
2555 && ! defined (__hpux__) \
2556 && ! defined (__APPLE__) \
2557 && ! defined (_AIX) \
2558 && ! (defined (__alpha__) && defined (__osf__)) \
2559 && ! defined (__MINGW32__) \
2560 && ! (defined (__mips) && defined (__sgi)))
2562 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
2563 just above for a list of native platforms that provide a non-dummy
2564 version of this procedure in libaddr2line.a. */
2567 convert_addresses (void *addrs ATTRIBUTE_UNUSED
,
2568 int n_addr ATTRIBUTE_UNUSED
,
2569 void *buf ATTRIBUTE_UNUSED
,
2570 int *len ATTRIBUTE_UNUSED
)
2576 #if defined (_WIN32)
2577 int __gnat_argument_needs_quote
= 1;
2579 int __gnat_argument_needs_quote
= 0;
2582 /* This option is used to enable/disable object files handling from the
2583 binder file by the GNAT Project module. For example, this is disabled on
2584 Windows (prior to GCC 3.4) as it is already done by the mdll module.
2585 Stating with GCC 3.4 the shared libraries are not based on mdll
2586 anymore as it uses the GCC's -shared option */
2587 #if defined (_WIN32) \
2588 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
2589 int __gnat_prj_add_obj_files
= 0;
2591 int __gnat_prj_add_obj_files
= 1;
2594 /* char used as prefix/suffix for environment variables */
2595 #if defined (_WIN32)
2596 char __gnat_environment_char
= '%';
2598 char __gnat_environment_char
= '$';
2601 /* This functions copy the file attributes from a source file to a
2604 mode = 0 : In this mode copy only the file time stamps (last access and
2605 last modification time stamps).
2607 mode = 1 : In this mode, time stamps and read/write/execute attributes are
2610 Returns 0 if operation was successful and -1 in case of error. */
2613 __gnat_copy_attribs (char *from
, char *to
, int mode
)
2615 #if defined (VMS) || defined (__vxworks)
2619 struct utimbuf tbuf
;
2621 if (stat (from
, &fbuf
) == -1)
2626 tbuf
.actime
= fbuf
.st_atime
;
2627 tbuf
.modtime
= fbuf
.st_mtime
;
2629 if (utime (to
, &tbuf
) == -1)
2636 if (chmod (to
, fbuf
.st_mode
) == -1)
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)