1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2005, Free Software Foundation, Inc. *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 2, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License distributed with GNAT; see file COPYING. If not, write *
19 * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
20 * Boston, MA 02110-1301, USA. *
22 * As a special exception, if you link this file with other files to *
23 * produce an executable, this file does not by itself cause the resulting *
24 * executable to be covered by the GNU General Public License. This except- *
25 * ion does not however invalidate any other reasons why the executable *
26 * file might be covered by the GNU Public License. *
28 * GNAT was originally developed by the GNAT team at New York University. *
29 * Extensive contributions were provided by Ada Core Technologies Inc. *
31 ****************************************************************************/
33 /* This file contains those routines named by Import pragmas in
34 packages in the GNAT hierarchy (especially GNAT.OS_Lib) and in
35 package Osint. Many of the subprograms in OS_Lib import standard
36 library calls directly. This file contains all other routines. */
40 /* No need to redefine exit here. */
43 /* We want to use the POSIX variants of include files. */
47 #if defined (__mips_vxworks)
49 #endif /* __mips_vxworks */
55 #define HOST_EXECUTABLE_SUFFIX ".exe"
56 #define HOST_OBJECT_SUFFIX ".obj"
70 /* We don't have libiberty, so use malloc. */
71 #define xmalloc(S) malloc (S)
72 #define xrealloc(V,S) realloc (V,S)
80 #include <sys/utime.h>
96 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
99 /* Header files and definitions for __gnat_set_file_time_name. */
102 #include <vms/atrdef.h>
103 #include <vms/fibdef.h>
104 #include <vms/stsdef.h>
105 #include <vms/iodef.h>
107 #include <vms/descrip.h>
111 /* Use native 64-bit arithmetic. */
112 #define unix_time_to_vms(X,Y) \
113 { unsigned long long reftime, tmptime = (X); \
114 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
115 SYS$BINTIM (&unixtime, &reftime); \
116 Y = tmptime * 10000000 + reftime; }
118 /* descrip.h doesn't have everything ... */
119 struct dsc$descriptor_fib
121 unsigned long fib$l_len
;
122 struct fibdef
*fib$l_addr
;
125 /* I/O Status Block. */
128 unsigned short status
, count
;
129 unsigned long devdep
;
132 static char *tryfile
;
134 /* Variable length string. */
138 char string
[NAM$C_MAXRSS
+1];
145 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
153 #define DIR_SEPARATOR '\\'
158 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
159 defined in the current system. On DOS-like systems these flags control
160 whether the file is opened/created in text-translation mode (CR/LF in
161 external file mapped to LF in internal file), but in Unix-like systems,
162 no text translation is required, so these flags have no effect. */
164 #if defined (__EMX__)
180 #ifndef HOST_EXECUTABLE_SUFFIX
181 #define HOST_EXECUTABLE_SUFFIX ""
184 #ifndef HOST_OBJECT_SUFFIX
185 #define HOST_OBJECT_SUFFIX ".o"
188 #ifndef PATH_SEPARATOR
189 #define PATH_SEPARATOR ':'
192 #ifndef DIR_SEPARATOR
193 #define DIR_SEPARATOR '/'
196 char __gnat_dir_separator
= DIR_SEPARATOR
;
198 char __gnat_path_separator
= PATH_SEPARATOR
;
200 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
201 the base filenames that libraries specified with -lsomelib options
202 may have. This is used by GNATMAKE to check whether an executable
203 is up-to-date or not. The syntax is
205 library_template ::= { pattern ; } pattern NUL
206 pattern ::= [ prefix ] * [ postfix ]
208 These should only specify names of static libraries as it makes
209 no sense to determine at link time if dynamic-link libraries are
210 up to date or not. Any libraries that are not found are supposed
213 * if they are needed but not present, the link
216 * otherwise they are libraries in the system paths and so
217 they are considered part of the system and not checked
220 ??? This should be part of a GNAT host-specific compiler
221 file instead of being included in all user applications
222 as well. This is only a temporary work-around for 3.11b. */
224 #ifndef GNAT_LIBRARY_TEMPLATE
225 #if defined (__EMX__)
226 #define GNAT_LIBRARY_TEMPLATE "*.a"
228 #define GNAT_LIBRARY_TEMPLATE "*.olb"
230 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
234 const char *__gnat_library_template
= GNAT_LIBRARY_TEMPLATE
;
236 /* This variable is used in hostparm.ads to say whether the host is a VMS
239 const int __gnat_vmsp
= 1;
241 const int __gnat_vmsp
= 0;
245 #define GNAT_MAX_PATH_LEN MAX_PATH
248 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
250 #elif defined (__vxworks) || defined (__OPENNT)
251 #define GNAT_MAX_PATH_LEN PATH_MAX
255 #if defined (__MINGW32__)
259 #include <sys/param.h>
263 #include <sys/param.h>
266 #define GNAT_MAX_PATH_LEN MAXPATHLEN
270 /* The __gnat_max_path_len variable is used to export the maximum
271 length of a path name to Ada code. max_path_len is also provided
272 for compatibility with older GNAT versions, please do not use
275 int __gnat_max_path_len
= GNAT_MAX_PATH_LEN
;
276 int max_path_len
= GNAT_MAX_PATH_LEN
;
278 /* The following macro HAVE_READDIR_R should be defined if the
279 system provides the routine readdir_r. */
280 #undef HAVE_READDIR_R
282 #if defined(VMS) && defined (__LONG_POINTERS)
284 /* Return a 32 bit pointer to an array of 32 bit pointers
285 given a 64 bit pointer to an array of 64 bit pointers */
287 typedef __char_ptr32
*__char_ptr_char_ptr32
__attribute__ ((mode (SI
)));
289 static __char_ptr_char_ptr32
290 to_ptr32 (char **ptr64
)
293 __char_ptr_char_ptr32 short_argv
;
295 for (argc
=0; ptr64
[argc
]; argc
++);
297 /* Reallocate argv with 32 bit pointers. */
298 short_argv
= (__char_ptr_char_ptr32
) decc$malloc
299 (sizeof (__char_ptr32
) * (argc
+ 1));
301 for (argc
=0; ptr64
[argc
]; argc
++)
302 short_argv
[argc
] = (__char_ptr32
) decc$
strdup (ptr64
[argc
]);
304 short_argv
[argc
] = (__char_ptr32
) 0;
308 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
310 #define MAYBE_TO_PTR32(argv) argv
324 time_t time
= (time_t) *p_time
;
327 /* On Windows systems, the time is sometimes rounded up to the nearest
328 even second, so if the number of seconds is odd, increment it. */
334 res
= localtime (&time
);
336 res
= gmtime (&time
);
341 *p_year
= res
->tm_year
;
342 *p_month
= res
->tm_mon
;
343 *p_day
= res
->tm_mday
;
344 *p_hours
= res
->tm_hour
;
345 *p_mins
= res
->tm_min
;
346 *p_secs
= res
->tm_sec
;
349 *p_year
= *p_month
= *p_day
= *p_hours
= *p_mins
= *p_secs
= 0;
352 /* Place the contents of the symbolic link named PATH in the buffer BUF,
353 which has size BUFSIZ. If PATH is a symbolic link, then return the number
354 of characters of its content in BUF. Otherwise, return -1. For Windows,
355 OS/2 and vxworks, always return -1. */
358 __gnat_readlink (char *path ATTRIBUTE_UNUSED
,
359 char *buf ATTRIBUTE_UNUSED
,
360 size_t bufsiz ATTRIBUTE_UNUSED
)
362 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
364 #elif defined (__INTERIX) || defined (VMS)
366 #elif defined (__vxworks)
369 return readlink (path
, buf
, bufsiz
);
373 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH. If
374 NEWPATH exists it will NOT be overwritten. For Windows, OS/2, VxWorks,
375 Interix and VMS, always return -1. */
378 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED
,
379 char *newpath ATTRIBUTE_UNUSED
)
381 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
383 #elif defined (__INTERIX) || defined (VMS)
385 #elif defined (__vxworks)
388 return symlink (oldpath
, newpath
);
392 /* Try to lock a file, return 1 if success. */
394 #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32)
396 /* Version that does not use link. */
399 __gnat_try_lock (char *dir
, char *file
)
404 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
405 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
413 #elif defined (__EMX__) || defined (VMS)
415 /* More cases that do not use link; identical code, to solve too long
419 __gnat_try_lock (char *dir
, char *file
)
424 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
425 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
435 /* Version using link(), more secure over NFS. */
436 /* See TN 6913-016 for discussion ??? */
439 __gnat_try_lock (char *dir
, char *file
)
443 struct stat stat_result
;
446 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
447 sprintf (temp_file
, "%s%cTMP-%ld-%ld",
448 dir
, DIR_SEPARATOR
, (long)getpid(), (long)getppid ());
450 /* Create the temporary file and write the process number. */
451 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
457 /* Link it with the new file. */
458 link (temp_file
, full_path
);
460 /* Count the references on the old one. If we have a count of two, then
461 the link did succeed. Remove the temporary file before returning. */
462 __gnat_stat (temp_file
, &stat_result
);
464 return stat_result
.st_nlink
== 2;
468 /* Return the maximum file name length. */
471 __gnat_get_maximum_file_name_length (void)
476 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
485 /* Return nonzero if file names are case sensitive. */
488 __gnat_get_file_names_case_sensitive (void)
490 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT)
498 __gnat_get_default_identifier_character_set (void)
500 #if defined (__EMX__) || defined (MSDOS)
507 /* Return the current working directory. */
510 __gnat_get_current_dir (char *dir
, int *length
)
513 /* Force Unix style, which is what GNAT uses internally. */
514 getcwd (dir
, *length
, 0);
516 getcwd (dir
, *length
);
519 *length
= strlen (dir
);
521 if (dir
[*length
- 1] != DIR_SEPARATOR
)
523 dir
[*length
] = DIR_SEPARATOR
;
529 /* Return the suffix for object files. */
532 __gnat_get_object_suffix_ptr (int *len
, const char **value
)
534 *value
= HOST_OBJECT_SUFFIX
;
539 *len
= strlen (*value
);
544 /* Return the suffix for executable files. */
547 __gnat_get_executable_suffix_ptr (int *len
, const char **value
)
549 *value
= HOST_EXECUTABLE_SUFFIX
;
553 *len
= strlen (*value
);
558 /* Return the suffix for debuggable files. Usually this is the same as the
559 executable extension. */
562 __gnat_get_debuggable_suffix_ptr (int *len
, const char **value
)
565 *value
= HOST_EXECUTABLE_SUFFIX
;
567 /* On DOS, the extensionless COFF file is what gdb likes. */
574 *len
= strlen (*value
);
580 __gnat_open_read (char *path
, int fmode
)
583 int o_fmode
= O_BINARY
;
589 /* Optional arguments mbc,deq,fop increase read performance. */
590 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
591 "mbc=16", "deq=64", "fop=tef");
592 #elif defined (__vxworks)
593 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
595 fd
= open (path
, O_RDONLY
| o_fmode
);
598 return fd
< 0 ? -1 : fd
;
601 #if defined (__EMX__) || defined (__MINGW32__)
602 #define PERM (S_IREAD | S_IWRITE)
604 /* Excerpt from DECC C RTL Reference Manual:
605 To create files with OpenVMS RMS default protections using the UNIX
606 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
607 and open with a file-protection mode argument of 0777 in a program
608 that never specifically calls umask. These default protections include
609 correctly establishing protections based on ACLs, previous versions of
613 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
617 __gnat_open_rw (char *path
, int fmode
)
620 int o_fmode
= O_BINARY
;
626 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
627 "mbc=16", "deq=64", "fop=tef");
629 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
632 return fd
< 0 ? -1 : fd
;
636 __gnat_open_create (char *path
, int fmode
)
639 int o_fmode
= O_BINARY
;
645 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
646 "mbc=16", "deq=64", "fop=tef");
648 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
651 return fd
< 0 ? -1 : fd
;
655 __gnat_create_output_file (char *path
)
659 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
,
660 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
661 "shr=del,get,put,upd");
663 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
666 return fd
< 0 ? -1 : fd
;
670 __gnat_open_append (char *path
, int fmode
)
673 int o_fmode
= O_BINARY
;
679 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
680 "mbc=16", "deq=64", "fop=tef");
682 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
685 return fd
< 0 ? -1 : fd
;
688 /* Open a new file. Return error (-1) if the file already exists. */
691 __gnat_open_new (char *path
, int fmode
)
694 int o_fmode
= O_BINARY
;
700 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
701 "mbc=16", "deq=64", "fop=tef");
703 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
706 return fd
< 0 ? -1 : fd
;
709 /* Open a new temp file. Return error (-1) if the file already exists.
710 Special options for VMS allow the file to be shared between parent and child
711 processes, however they really slow down output. Used in gnatchop. */
714 __gnat_open_new_temp (char *path
, int fmode
)
717 int o_fmode
= O_BINARY
;
719 strcpy (path
, "GNAT-XXXXXX");
721 #if (defined (__FreeBSD__) || defined (linux)) && !defined (__vxworks)
722 return mkstemp (path
);
723 #elif defined (__Lynx__)
726 if (mktemp (path
) == NULL
)
734 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
735 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
736 "mbc=16", "deq=64", "fop=tef");
738 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
741 return fd
< 0 ? -1 : fd
;
744 /* Return the number of bytes in the specified file. */
747 __gnat_file_length (int fd
)
752 ret
= fstat (fd
, &statbuf
);
753 if (ret
|| !S_ISREG (statbuf
.st_mode
))
756 return (statbuf
.st_size
);
759 /* Return the number of bytes in the specified named file. */
762 __gnat_named_file_length (char *name
)
767 ret
= __gnat_stat (name
, &statbuf
);
768 if (ret
|| !S_ISREG (statbuf
.st_mode
))
771 return (statbuf
.st_size
);
774 /* Create a temporary filename and put it in string pointed to by
778 __gnat_tmp_name (char *tmp_filename
)
784 /* tempnam tries to create a temporary file in directory pointed to by
785 TMP environment variable, in c:\temp if TMP is not set, and in
786 directory specified by P_tmpdir in stdio.h if c:\temp does not
787 exist. The filename will be created with the prefix "gnat-". */
789 pname
= (char *) tempnam ("c:\\temp", "gnat-");
791 /* if pname is NULL, the file was not created properly, the disk is full
792 or there is no more free temporary files */
795 *tmp_filename
= '\0';
797 /* If pname start with a back slash and not path information it means that
798 the filename is valid for the current working directory. */
800 else if (pname
[0] == '\\')
802 strcpy (tmp_filename
, ".\\");
803 strcat (tmp_filename
, pname
+1);
806 strcpy (tmp_filename
, pname
);
811 #elif defined (linux) || defined (__FreeBSD__)
812 #define MAX_SAFE_PATH 1000
813 char *tmpdir
= getenv ("TMPDIR");
815 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
816 a buffer overflow. */
817 if (tmpdir
== NULL
|| strlen (tmpdir
) > MAX_SAFE_PATH
)
818 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
820 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
822 close (mkstemp(tmp_filename
));
824 tmpnam (tmp_filename
);
828 /* Read the next entry in a directory. The returned string points somewhere
832 __gnat_readdir (DIR *dirp
, char *buffer
)
834 /* If possible, try to use the thread-safe version. */
835 #ifdef HAVE_READDIR_R
836 if (readdir_r (dirp
, buffer
) != NULL
)
837 return ((struct dirent
*) buffer
)->d_name
;
842 struct dirent
*dirent
= (struct dirent
*) readdir (dirp
);
846 strcpy (buffer
, dirent
->d_name
);
855 /* Returns 1 if readdir is thread safe, 0 otherwise. */
858 __gnat_readdir_is_thread_safe (void)
860 #ifdef HAVE_READDIR_R
868 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
869 static const unsigned long long w32_epoch_offset
= 11644473600ULL;
871 /* Returns the file modification timestamp using Win32 routines which are
872 immune against daylight saving time change. It is in fact not possible to
873 use fstat for this purpose as the DST modify the st_mtime field of the
877 win32_filetime (HANDLE h
)
882 unsigned long long ull_time
;
885 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
886 since <Jan 1st 1601>. This function must return the number of seconds
887 since <Jan 1st 1970>. */
889 if (GetFileTime (h
, NULL
, NULL
, &t_write
.ft_time
))
890 return (time_t) (t_write
.ull_time
/ 10000000ULL
896 /* Return a GNAT time stamp given a file name. */
899 __gnat_file_time_name (char *name
)
902 #if defined (__EMX__) || defined (MSDOS)
903 int fd
= open (name
, O_RDONLY
| O_BINARY
);
904 time_t ret
= __gnat_file_time_fd (fd
);
908 #elif defined (_WIN32)
910 HANDLE h
= CreateFile (name
, GENERIC_READ
, FILE_SHARE_READ
, 0,
911 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
, 0);
913 if (h
!= INVALID_HANDLE_VALUE
)
915 ret
= win32_filetime (h
);
918 return (OS_Time
) ret
;
921 if (__gnat_stat (name
, &statbuf
) != 0) {
925 /* VMS has file versioning. */
926 return (OS_Time
)statbuf
.st_ctime
;
928 return (OS_Time
)statbuf
.st_mtime
;
934 /* Return a GNAT time stamp given a file descriptor. */
937 __gnat_file_time_fd (int fd
)
939 /* The following workaround code is due to the fact that under EMX and
940 DJGPP fstat attempts to convert time values to GMT rather than keep the
941 actual OS timestamp of the file. By using the OS2/DOS functions directly
942 the GNAT timestamp are independent of this behavior, which is desired to
943 facilitate the distribution of GNAT compiled libraries. */
945 #if defined (__EMX__) || defined (MSDOS)
949 int ret
= DosQueryFileInfo (fd
, 1, (unsigned char *) &fs
,
950 sizeof (FILESTATUS
));
952 unsigned file_year
= fs
.fdateLastWrite
.year
;
953 unsigned file_month
= fs
.fdateLastWrite
.month
;
954 unsigned file_day
= fs
.fdateLastWrite
.day
;
955 unsigned file_hour
= fs
.ftimeLastWrite
.hours
;
956 unsigned file_min
= fs
.ftimeLastWrite
.minutes
;
957 unsigned file_tsec
= fs
.ftimeLastWrite
.twosecs
;
961 int ret
= getftime (fd
, &fs
);
963 unsigned file_year
= fs
.ft_year
;
964 unsigned file_month
= fs
.ft_month
;
965 unsigned file_day
= fs
.ft_day
;
966 unsigned file_hour
= fs
.ft_hour
;
967 unsigned file_min
= fs
.ft_min
;
968 unsigned file_tsec
= fs
.ft_tsec
;
971 /* Calculate the seconds since epoch from the time components. First count
972 the whole days passed. The value for years returned by the DOS and OS2
973 functions count years from 1980, so to compensate for the UNIX epoch which
974 begins in 1970 start with 10 years worth of days and add days for each
975 four year period since then. */
978 int cum_days
[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
979 int days_passed
= 3652 + (file_year
/ 4) * 1461;
980 int years_since_leap
= file_year
% 4;
982 if (years_since_leap
== 1)
984 else if (years_since_leap
== 2)
986 else if (years_since_leap
== 3)
992 days_passed
+= cum_days
[file_month
- 1];
993 if (years_since_leap
== 0 && file_year
!= 20 && file_month
> 2)
996 days_passed
+= file_day
- 1;
998 /* OK - have whole days. Multiply -- then add in other parts. */
1000 tot_secs
= days_passed
* 86400;
1001 tot_secs
+= file_hour
* 3600;
1002 tot_secs
+= file_min
* 60;
1003 tot_secs
+= file_tsec
* 2;
1004 return (OS_Time
) tot_secs
;
1006 #elif defined (_WIN32)
1007 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
1008 time_t ret
= win32_filetime (h
);
1009 return (OS_Time
) ret
;
1012 struct stat statbuf
;
1014 if (fstat (fd
, &statbuf
) != 0) {
1015 return (OS_Time
) -1;
1018 /* VMS has file versioning. */
1019 return (OS_Time
) statbuf
.st_ctime
;
1021 return (OS_Time
) statbuf
.st_mtime
;
1027 /* Set the file time stamp. */
1030 __gnat_set_file_time_name (char *name
, time_t time_stamp
)
1032 #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1034 /* Code to implement __gnat_set_file_time_name for these systems. */
1036 #elif defined (_WIN32)
1040 unsigned long long ull_time
;
1043 HANDLE h
= CreateFile (name
, GENERIC_WRITE
, FILE_SHARE_WRITE
, NULL
,
1044 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
,
1046 if (h
== INVALID_HANDLE_VALUE
)
1048 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1049 t_write
.ull_time
= ((unsigned long long)time_stamp
+ w32_epoch_offset
);
1050 /* Convert to 100 nanosecond units */
1051 t_write
.ull_time
*= 10000000ULL;
1053 SetFileTime(h
, NULL
, NULL
, &t_write
.ft_time
);
1063 unsigned long long backup
, create
, expire
, revise
;
1067 unsigned short value
;
1070 unsigned system
: 4;
1076 } Fat
= { 0, 0, 0, 0, 0, { 0 }};
1080 { ATR$S_CREDATE
, ATR$C_CREDATE
, &Fat
.create
},
1081 { ATR$S_REVDATE
, ATR$C_REVDATE
, &Fat
.revise
},
1082 { ATR$S_EXPDATE
, ATR$C_EXPDATE
, &Fat
.expire
},
1083 { ATR$S_BAKDATE
, ATR$C_BAKDATE
, &Fat
.backup
},
1084 { ATR$S_FPRO
, ATR$C_FPRO
, &Fat
.prot
},
1085 { ATR$S_UIC
, ATR$C_UIC
, &Fat
.uic
},
1090 struct dsc$descriptor_fib fibdsc
= {sizeof (fib
), (void *) &fib
};
1094 unsigned long long newtime
;
1095 unsigned long long revtime
;
1099 struct vstring file
;
1100 struct dsc$descriptor_s filedsc
1101 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) file
.string
};
1102 struct vstring device
;
1103 struct dsc$descriptor_s devicedsc
1104 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) device
.string
};
1105 struct vstring timev
;
1106 struct dsc$descriptor_s timedsc
1107 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) timev
.string
};
1108 struct vstring result
;
1109 struct dsc$descriptor_s resultdsc
1110 = {NAM$C_MAXRSS
, DSC$K_DTYPE_VT
, DSC$K_CLASS_VS
, (void *) result
.string
};
1112 tryfile
= (char *) __gnat_to_host_dir_spec (name
, 0);
1114 /* Allocate and initialize a FAB and NAM structures. */
1118 nam
.nam$l_esa
= file
.string
;
1119 nam
.nam$b_ess
= NAM$C_MAXRSS
;
1120 nam
.nam$l_rsa
= result
.string
;
1121 nam
.nam$b_rss
= NAM$C_MAXRSS
;
1122 fab
.fab$l_fna
= tryfile
;
1123 fab
.fab$b_fns
= strlen (tryfile
);
1124 fab
.fab$l_nam
= &nam
;
1126 /* Validate filespec syntax and device existence. */
1127 status
= SYS$
PARSE (&fab
, 0, 0);
1128 if ((status
& 1) != 1)
1129 LIB$
SIGNAL (status
);
1131 file
.string
[nam
.nam$b_esl
] = 0;
1133 /* Find matching filespec. */
1134 status
= SYS$
SEARCH (&fab
, 0, 0);
1135 if ((status
& 1) != 1)
1136 LIB$
SIGNAL (status
);
1138 file
.string
[nam
.nam$b_esl
] = 0;
1139 result
.string
[result
.length
=nam
.nam$b_rsl
] = 0;
1141 /* Get the device name and assign an IO channel. */
1142 strncpy (device
.string
, nam
.nam$l_dev
, nam
.nam$b_dev
);
1143 devicedsc
.dsc$w_length
= nam
.nam$b_dev
;
1145 status
= SYS$
ASSIGN (&devicedsc
, &chan
, 0, 0, 0);
1146 if ((status
& 1) != 1)
1147 LIB$
SIGNAL (status
);
1149 /* Initialize the FIB and fill in the directory id field. */
1150 memset (&fib
, 0, sizeof (fib
));
1151 fib
.fib$w_did
[0] = nam
.nam$w_did
[0];
1152 fib
.fib$w_did
[1] = nam
.nam$w_did
[1];
1153 fib
.fib$w_did
[2] = nam
.nam$w_did
[2];
1154 fib
.fib$l_acctl
= 0;
1156 strcpy (file
.string
, (strrchr (result
.string
, ']') + 1));
1157 filedsc
.dsc$w_length
= strlen (file
.string
);
1158 result
.string
[result
.length
= 0] = 0;
1160 /* Open and close the file to fill in the attributes. */
1162 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1163 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1164 if ((status
& 1) != 1)
1165 LIB$
SIGNAL (status
);
1166 if ((iosb
.status
& 1) != 1)
1167 LIB$
SIGNAL (iosb
.status
);
1169 result
.string
[result
.length
] = 0;
1170 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0, &fibdsc
, 0, 0, 0,
1172 if ((status
& 1) != 1)
1173 LIB$
SIGNAL (status
);
1174 if ((iosb
.status
& 1) != 1)
1175 LIB$
SIGNAL (iosb
.status
);
1180 /* Set creation time to requested time. */
1181 unix_time_to_vms (time_stamp
, newtime
);
1183 t
= time ((time_t) 0);
1185 /* Set revision time to now in local time. */
1186 unix_time_to_vms (t
, revtime
);
1189 /* Reopen the file, modify the times and then close. */
1190 fib
.fib$l_acctl
= FIB$M_WRITE
;
1192 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1193 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1194 if ((status
& 1) != 1)
1195 LIB$
SIGNAL (status
);
1196 if ((iosb
.status
& 1) != 1)
1197 LIB$
SIGNAL (iosb
.status
);
1199 Fat
.create
= newtime
;
1200 Fat
.revise
= revtime
;
1202 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0,
1203 &fibdsc
, 0, 0, 0, &atrlst
, 0);
1204 if ((status
& 1) != 1)
1205 LIB$
SIGNAL (status
);
1206 if ((iosb
.status
& 1) != 1)
1207 LIB$
SIGNAL (iosb
.status
);
1209 /* Deassign the channel and exit. */
1210 status
= SYS$
DASSGN (chan
);
1211 if ((status
& 1) != 1)
1212 LIB$
SIGNAL (status
);
1214 struct utimbuf utimbuf
;
1217 /* Set modification time to requested time. */
1218 utimbuf
.modtime
= time_stamp
;
1220 /* Set access time to now in local time. */
1221 t
= time ((time_t) 0);
1222 utimbuf
.actime
= mktime (localtime (&t
));
1224 utime (name
, &utimbuf
);
1229 __gnat_get_env_value_ptr (char *name
, int *len
, char **value
)
1231 *value
= getenv (name
);
1235 *len
= strlen (*value
);
1240 /* VMS specific declarations for set_env_value. */
1244 static char *to_host_path_spec (char *);
1248 unsigned short len
, mbz
;
1252 typedef struct _ile3
1254 unsigned short len
, code
;
1256 unsigned short *retlen_adr
;
1262 __gnat_set_env_value (char *name
, char *value
)
1267 struct descriptor_s name_desc
;
1268 /* Put in JOB table for now, so that the project stuff at least works. */
1269 struct descriptor_s table_desc
= {7, 0, "LNM$JOB"};
1270 char *host_pathspec
= value
;
1271 char *copy_pathspec
;
1272 int num_dirs_in_pathspec
= 1;
1276 name_desc
.len
= strlen (name
);
1278 name_desc
.adr
= name
;
1280 if (*host_pathspec
== 0)
1283 status
= LIB$
DELETE_LOGICAL (&name_desc
, &table_desc
);
1284 /* no need to check status; if the logical name is not
1285 defined, that's fine. */
1289 ptr
= host_pathspec
;
1292 num_dirs_in_pathspec
++;
1296 ile_s
*ile_array
= alloca (sizeof (ile_s
) * (num_dirs_in_pathspec
+ 1));
1297 char *copy_pathspec
= alloca (strlen (host_pathspec
) + 1);
1300 strcpy (copy_pathspec
, host_pathspec
);
1301 curr
= copy_pathspec
;
1302 for (i
= 0; i
< num_dirs_in_pathspec
; i
++)
1304 next
= strchr (curr
, ',');
1306 next
= strchr (curr
, 0);
1309 ile_array
[i
].len
= strlen (curr
);
1311 /* Code 2 from lnmdef.h means it's a string. */
1312 ile_array
[i
].code
= 2;
1313 ile_array
[i
].adr
= curr
;
1315 /* retlen_adr is ignored. */
1316 ile_array
[i
].retlen_adr
= 0;
1320 /* Terminating item must be zero. */
1321 ile_array
[i
].len
= 0;
1322 ile_array
[i
].code
= 0;
1323 ile_array
[i
].adr
= 0;
1324 ile_array
[i
].retlen_adr
= 0;
1326 status
= LIB$
SET_LOGICAL (&name_desc
, 0, &table_desc
, 0, ile_array
);
1327 if ((status
& 1) != 1)
1328 LIB$
SIGNAL (status
);
1332 int size
= strlen (name
) + strlen (value
) + 2;
1335 expression
= (char *) xmalloc (size
* sizeof (char));
1337 sprintf (expression
, "%s=%s", name
, value
);
1338 putenv (expression
);
1343 #include <windows.h>
1346 /* Get the list of installed standard libraries from the
1347 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1351 __gnat_get_libraries_from_registry (void)
1353 char *result
= (char *) "";
1355 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_COMPILE)
1358 DWORD name_size
, value_size
;
1365 /* First open the key. */
1366 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1368 if (res
== ERROR_SUCCESS
)
1369 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1370 KEY_READ
, ®_key
);
1372 if (res
== ERROR_SUCCESS
)
1373 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1375 if (res
== ERROR_SUCCESS
)
1376 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1378 /* If the key exists, read out all the values in it and concatenate them
1380 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1382 value_size
= name_size
= 256;
1383 res
= RegEnumValue (reg_key
, index
, name
, &name_size
, 0,
1384 &type
, (LPBYTE
)value
, &value_size
);
1386 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1388 char *old_result
= result
;
1390 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1391 strcpy (result
, old_result
);
1392 strcat (result
, value
);
1393 strcat (result
, ";");
1397 /* Remove the trailing ";". */
1399 result
[strlen (result
) - 1] = 0;
1406 __gnat_stat (char *name
, struct stat
*statbuf
)
1409 /* Under Windows the directory name for the stat function must not be
1410 terminated by a directory separator except if just after a drive name. */
1411 int name_len
= strlen (name
);
1412 char last_char
= name
[name_len
- 1];
1413 char win32_name
[GNAT_MAX_PATH_LEN
+ 2];
1415 if (name_len
> GNAT_MAX_PATH_LEN
)
1418 strcpy (win32_name
, name
);
1420 while (name_len
> 1 && (last_char
== '\\' || last_char
== '/'))
1422 win32_name
[name_len
- 1] = '\0';
1424 last_char
= win32_name
[name_len
- 1];
1427 if (name_len
== 2 && win32_name
[1] == ':')
1428 strcat (win32_name
, "\\");
1430 return stat (win32_name
, statbuf
);
1433 return stat (name
, statbuf
);
1438 __gnat_file_exists (char *name
)
1440 struct stat statbuf
;
1442 return !__gnat_stat (name
, &statbuf
);
1446 __gnat_is_absolute_path (char *name
, int length
)
1448 return (length
!= 0) &&
1449 (*name
== '/' || *name
== DIR_SEPARATOR
1450 #if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
1451 || (length
> 1 && isalpha (name
[0]) && name
[1] == ':')
1457 __gnat_is_regular_file (char *name
)
1460 struct stat statbuf
;
1462 ret
= __gnat_stat (name
, &statbuf
);
1463 return (!ret
&& S_ISREG (statbuf
.st_mode
));
1467 __gnat_is_directory (char *name
)
1470 struct stat statbuf
;
1472 ret
= __gnat_stat (name
, &statbuf
);
1473 return (!ret
&& S_ISDIR (statbuf
.st_mode
));
1477 __gnat_is_readable_file (char *name
)
1481 struct stat statbuf
;
1483 ret
= __gnat_stat (name
, &statbuf
);
1484 mode
= statbuf
.st_mode
& S_IRUSR
;
1485 return (!ret
&& mode
);
1489 __gnat_is_writable_file (char *name
)
1493 struct stat statbuf
;
1495 ret
= __gnat_stat (name
, &statbuf
);
1496 mode
= statbuf
.st_mode
& S_IWUSR
;
1497 return (!ret
&& mode
);
1501 __gnat_set_writable (char *name
)
1504 struct stat statbuf
;
1506 if (stat (name
, &statbuf
) == 0)
1508 statbuf
.st_mode
= statbuf
.st_mode
| S_IWUSR
;
1509 chmod (name
, statbuf
.st_mode
);
1515 __gnat_set_executable (char *name
)
1518 struct stat statbuf
;
1520 if (stat (name
, &statbuf
) == 0)
1522 statbuf
.st_mode
= statbuf
.st_mode
| S_IXUSR
;
1523 chmod (name
, statbuf
.st_mode
);
1529 __gnat_set_readonly (char *name
)
1532 struct stat statbuf
;
1534 if (stat (name
, &statbuf
) == 0)
1536 statbuf
.st_mode
= statbuf
.st_mode
& 07577;
1537 chmod (name
, statbuf
.st_mode
);
1543 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED
)
1545 #if defined (__vxworks)
1548 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
1550 struct stat statbuf
;
1552 ret
= lstat (name
, &statbuf
);
1553 return (!ret
&& S_ISLNK (statbuf
.st_mode
));
1560 #if defined (sun) && defined (__SVR4)
1561 /* Using fork on Solaris will duplicate all the threads. fork1, which
1562 duplicates only the active thread, must be used instead, or spawning
1563 subprocess from a program with tasking will lead into numerous problems. */
1568 __gnat_portable_spawn (char *args
[])
1571 int finished ATTRIBUTE_UNUSED
;
1572 int pid ATTRIBUTE_UNUSED
;
1574 #if defined (MSDOS) || defined (_WIN32)
1575 /* args[0] must be quotes as it could contain a full pathname with spaces */
1576 char *args_0
= args
[0];
1577 args
[0] = (char *)xmalloc (strlen (args_0
) + 3);
1578 strcpy (args
[0], "\"");
1579 strcat (args
[0], args_0
);
1580 strcat (args
[0], "\"");
1582 status
= spawnvp (P_WAIT
, args_0
, (const char* const*)args
);
1584 /* restore previous value */
1586 args
[0] = (char *)args_0
;
1593 #elif defined (__vxworks)
1598 pid
= spawnvp (P_NOWAIT
, args
[0], args
);
1610 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
1612 return -1; /* execv is in parent context on VMS. */
1620 finished
= waitpid (pid
, &status
, 0);
1622 if (finished
!= pid
|| WIFEXITED (status
) == 0)
1625 return WEXITSTATUS (status
);
1631 /* Create a copy of the given file descriptor.
1632 Return -1 if an error occurred. */
1635 __gnat_dup (int oldfd
)
1637 #if defined (__vxworks)
1638 /* Not supported on VxWorks. */
1645 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
1646 Return -1 if an error occurred. */
1649 __gnat_dup2 (int oldfd
, int newfd
)
1651 #if defined (__vxworks)
1652 /* Not supported on VxWorks. */
1655 return dup2 (oldfd
, newfd
);
1659 /* WIN32 code to implement a wait call that wait for any child process. */
1663 /* Synchronization code, to be thread safe. */
1665 static CRITICAL_SECTION plist_cs
;
1668 __gnat_plist_init (void)
1670 InitializeCriticalSection (&plist_cs
);
1676 EnterCriticalSection (&plist_cs
);
1682 LeaveCriticalSection (&plist_cs
);
1685 typedef struct _process_list
1688 struct _process_list
*next
;
1691 static Process_List
*PLIST
= NULL
;
1693 static int plist_length
= 0;
1696 add_handle (HANDLE h
)
1700 pl
= (Process_List
*) xmalloc (sizeof (Process_List
));
1704 /* -------------------- critical section -------------------- */
1709 /* -------------------- critical section -------------------- */
1715 remove_handle (HANDLE h
)
1718 Process_List
*prev
= NULL
;
1722 /* -------------------- critical section -------------------- */
1731 prev
->next
= pl
->next
;
1743 /* -------------------- critical section -------------------- */
1749 win32_no_block_spawn (char *command
, char *args
[])
1753 PROCESS_INFORMATION PI
;
1754 SECURITY_ATTRIBUTES SA
;
1759 /* compute the total command line length */
1763 csize
+= strlen (args
[k
]) + 1;
1767 full_command
= (char *) xmalloc (csize
);
1770 SI
.cb
= sizeof (STARTUPINFO
);
1771 SI
.lpReserved
= NULL
;
1772 SI
.lpReserved2
= NULL
;
1773 SI
.lpDesktop
= NULL
;
1777 SI
.wShowWindow
= SW_HIDE
;
1779 /* Security attributes. */
1780 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
1781 SA
.bInheritHandle
= TRUE
;
1782 SA
.lpSecurityDescriptor
= NULL
;
1784 /* Prepare the command string. */
1785 strcpy (full_command
, command
);
1786 strcat (full_command
, " ");
1791 strcat (full_command
, args
[k
]);
1792 strcat (full_command
, " ");
1796 result
= CreateProcess
1797 (NULL
, (char *) full_command
, &SA
, NULL
, TRUE
,
1798 GetPriorityClass (GetCurrentProcess()), NULL
, NULL
, &SI
, &PI
);
1800 free (full_command
);
1804 add_handle (PI
.hProcess
);
1805 CloseHandle (PI
.hThread
);
1806 return (int) PI
.hProcess
;
1813 win32_wait (int *status
)
1822 if (plist_length
== 0)
1828 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * plist_length
);
1833 /* -------------------- critical section -------------------- */
1840 /* -------------------- critical section -------------------- */
1844 res
= WaitForMultipleObjects (plist_length
, hl
, FALSE
, INFINITE
);
1845 h
= hl
[res
- WAIT_OBJECT_0
];
1850 GetExitCodeProcess (h
, &exitcode
);
1853 *status
= (int) exitcode
;
1860 __gnat_portable_no_block_spawn (char *args
[])
1864 #if defined (__EMX__) || defined (MSDOS)
1866 /* ??? For PC machines I (Franco) don't know the system calls to implement
1867 this routine. So I'll fake it as follows. This routine will behave
1868 exactly like the blocking portable_spawn and will systematically return
1869 a pid of 0 unless the spawned task did not complete successfully, in
1870 which case we return a pid of -1. To synchronize with this the
1871 portable_wait below systematically returns a pid of 0 and reports that
1872 the subprocess terminated successfully. */
1874 if (spawnvp (P_WAIT
, args
[0], args
) != 0)
1877 #elif defined (_WIN32)
1879 pid
= win32_no_block_spawn (args
[0], args
);
1882 #elif defined (__vxworks)
1891 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
1893 return -1; /* execv is in parent context on VMS. */
1905 __gnat_portable_wait (int *process_status
)
1910 #if defined (_WIN32)
1912 pid
= win32_wait (&status
);
1914 #elif defined (__EMX__) || defined (MSDOS)
1915 /* ??? See corresponding comment in portable_no_block_spawn. */
1917 #elif defined (__vxworks)
1918 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
1922 pid
= waitpid (-1, &status
, 0);
1923 status
= status
& 0xffff;
1926 *process_status
= status
;
1931 __gnat_os_exit (int status
)
1936 /* Locate a regular file, give a Path value. */
1939 __gnat_locate_regular_file (char *file_name
, char *path_val
)
1942 char *file_path
= alloca (strlen (file_name
) + 1);
1945 /* Remove quotes around file_name if present */
1951 strcpy (file_path
, ptr
);
1953 ptr
= file_path
+ strlen (file_path
) - 1;
1958 /* Handle absolute pathnames. */
1960 absolute
= __gnat_is_absolute_path (file_path
, strlen (file_name
));
1964 if (__gnat_is_regular_file (file_path
))
1965 return xstrdup (file_path
);
1970 /* If file_name include directory separator(s), try it first as
1971 a path name relative to the current directory */
1972 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
1977 if (__gnat_is_regular_file (file_name
))
1978 return xstrdup (file_name
);
1985 /* The result has to be smaller than path_val + file_name. */
1986 char *file_path
= alloca (strlen (path_val
) + strlen (file_name
) + 2);
1990 for (; *path_val
== PATH_SEPARATOR
; path_val
++)
1996 /* Skip the starting quote */
1998 if (*path_val
== '"')
2001 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
2002 *ptr
++ = *path_val
++;
2006 /* Skip the ending quote */
2011 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
2012 *++ptr
= DIR_SEPARATOR
;
2014 strcpy (++ptr
, file_name
);
2016 if (__gnat_is_regular_file (file_path
))
2017 return xstrdup (file_path
);
2024 /* Locate an executable given a Path argument. This routine is only used by
2025 gnatbl and should not be used otherwise. Use locate_exec_on_path
2029 __gnat_locate_exec (char *exec_name
, char *path_val
)
2031 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
2033 char *full_exec_name
2034 = alloca (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
2036 strcpy (full_exec_name
, exec_name
);
2037 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
2038 return __gnat_locate_regular_file (full_exec_name
, path_val
);
2041 return __gnat_locate_regular_file (exec_name
, path_val
);
2044 /* Locate an executable using the Systems default PATH. */
2047 __gnat_locate_exec_on_path (char *exec_name
)
2051 char *path_val
= "/VAXC$PATH";
2053 char *path_val
= getenv ("PATH");
2056 /* In Win32 systems we expand the PATH as for XP environment
2057 variables are not automatically expanded. We also prepend the
2058 ".;" to the path to match normal NT path search semantics */
2060 #define EXPAND_BUFFER_SIZE 32767
2062 apath_val
= alloca (EXPAND_BUFFER_SIZE
);
2064 apath_val
[0] = '.';
2065 apath_val
[1] = ';';
2067 DWORD res
= ExpandEnvironmentStrings
2068 (path_val
, apath_val
+ 2, EXPAND_BUFFER_SIZE
- 2);
2070 if (!res
) apath_val
[0] = '\0';
2072 apath_val
= alloca (strlen (path_val
) + 1);
2073 strcpy (apath_val
, path_val
);
2076 return __gnat_locate_exec (exec_name
, apath_val
);
2081 /* These functions are used to translate to and from VMS and Unix syntax
2082 file, directory and path specifications. */
2085 #define MAXNAMES 256
2086 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2088 static char new_canonical_dirspec
[MAXPATH
];
2089 static char new_canonical_filespec
[MAXPATH
];
2090 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
2091 static unsigned new_canonical_filelist_index
;
2092 static unsigned new_canonical_filelist_in_use
;
2093 static unsigned new_canonical_filelist_allocated
;
2094 static char **new_canonical_filelist
;
2095 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
2096 static char new_host_dirspec
[MAXPATH
];
2097 static char new_host_filespec
[MAXPATH
];
2099 /* Routine is called repeatedly by decc$from_vms via
2100 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2104 wildcard_translate_unix (char *name
)
2107 char buff
[MAXPATH
];
2109 strncpy (buff
, name
, MAXPATH
);
2110 buff
[MAXPATH
- 1] = (char) 0;
2111 ver
= strrchr (buff
, '.');
2113 /* Chop off the version. */
2117 /* Dynamically extend the allocation by the increment. */
2118 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
2120 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
2121 new_canonical_filelist
= (char **) xrealloc
2122 (new_canonical_filelist
,
2123 new_canonical_filelist_allocated
* sizeof (char *));
2126 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
2131 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2132 full translation and copy the results into a list (_init), then return them
2133 one at a time (_next). If onlydirs set, only expand directory files. */
2136 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
2139 char buff
[MAXPATH
];
2141 len
= strlen (filespec
);
2142 strncpy (buff
, filespec
, MAXPATH
);
2144 /* Only look for directories */
2145 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
2146 strncat (buff
, "*.dir", MAXPATH
);
2148 buff
[MAXPATH
- 1] = (char) 0;
2150 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
2152 /* Remove the .dir extension. */
2158 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
2160 ext
= strstr (new_canonical_filelist
[i
], ".dir");
2166 return new_canonical_filelist_in_use
;
2169 /* Return the next filespec in the list. */
2172 __gnat_to_canonical_file_list_next ()
2174 return new_canonical_filelist
[new_canonical_filelist_index
++];
2177 /* Free storage used in the wildcard expansion. */
2180 __gnat_to_canonical_file_list_free ()
2184 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
2185 free (new_canonical_filelist
[i
]);
2187 free (new_canonical_filelist
);
2189 new_canonical_filelist_in_use
= 0;
2190 new_canonical_filelist_allocated
= 0;
2191 new_canonical_filelist_index
= 0;
2192 new_canonical_filelist
= 0;
2195 /* Translate a VMS syntax directory specification in to Unix syntax. If
2196 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2197 found, return input string. Also translate a dirname that contains no
2198 slashes, in case it's a logical name. */
2201 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
2205 strcpy (new_canonical_dirspec
, "");
2206 if (strlen (dirspec
))
2210 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
2212 strncpy (new_canonical_dirspec
,
2213 (char *) decc$
translate_vms (dirspec
),
2216 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
2218 strncpy (new_canonical_dirspec
,
2219 (char *) decc$
translate_vms (dirspec1
),
2224 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
2228 len
= strlen (new_canonical_dirspec
);
2229 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
2230 strncat (new_canonical_dirspec
, "/", MAXPATH
);
2232 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
2234 return new_canonical_dirspec
;
2238 /* Translate a VMS syntax file specification into Unix syntax.
2239 If no indicators of VMS syntax found, check if it's an uppercase
2240 alphanumeric_ name and if so try it out as an environment
2241 variable (logical name). If all else fails return the
2245 __gnat_to_canonical_file_spec (char *filespec
)
2249 strncpy (new_canonical_filespec
, "", MAXPATH
);
2251 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
2253 char *tspec
= (char *) decc$
translate_vms (filespec
);
2255 if (tspec
!= (char *) -1)
2256 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
2258 else if ((strlen (filespec
) == strspn (filespec
,
2259 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
2260 && (filespec1
= getenv (filespec
)))
2262 char *tspec
= (char *) decc$
translate_vms (filespec1
);
2264 if (tspec
!= (char *) -1)
2265 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
2269 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
2272 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
2274 return new_canonical_filespec
;
2277 /* Translate a VMS syntax path specification into Unix syntax.
2278 If no indicators of VMS syntax found, return input string. */
2281 __gnat_to_canonical_path_spec (char *pathspec
)
2283 char *curr
, *next
, buff
[MAXPATH
];
2288 /* If there are /'s, assume it's a Unix path spec and return. */
2289 if (strchr (pathspec
, '/'))
2292 new_canonical_pathspec
[0] = 0;
2297 next
= strchr (curr
, ',');
2299 next
= strchr (curr
, 0);
2301 strncpy (buff
, curr
, next
- curr
);
2302 buff
[next
- curr
] = 0;
2304 /* Check for wildcards and expand if present. */
2305 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
2309 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
2310 for (i
= 0; i
< dirs
; i
++)
2314 next_dir
= __gnat_to_canonical_file_list_next ();
2315 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
2317 /* Don't append the separator after the last expansion. */
2319 strncat (new_canonical_pathspec
, ":", MAXPATH
);
2322 __gnat_to_canonical_file_list_free ();
2325 strncat (new_canonical_pathspec
,
2326 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
2331 strncat (new_canonical_pathspec
, ":", MAXPATH
);
2335 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
2337 return new_canonical_pathspec
;
2340 static char filename_buff
[MAXPATH
];
2343 translate_unix (char *name
, int type
)
2345 strncpy (filename_buff
, name
, MAXPATH
);
2346 filename_buff
[MAXPATH
- 1] = (char) 0;
2350 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
2354 to_host_path_spec (char *pathspec
)
2356 char *curr
, *next
, buff
[MAXPATH
];
2361 /* Can't very well test for colons, since that's the Unix separator! */
2362 if (strchr (pathspec
, ']') || strchr (pathspec
, ','))
2365 new_host_pathspec
[0] = 0;
2370 next
= strchr (curr
, ':');
2372 next
= strchr (curr
, 0);
2374 strncpy (buff
, curr
, next
- curr
);
2375 buff
[next
- curr
] = 0;
2377 strncat (new_host_pathspec
, __gnat_to_host_dir_spec (buff
, 0), MAXPATH
);
2380 strncat (new_host_pathspec
, ",", MAXPATH
);
2384 new_host_pathspec
[MAXPATH
- 1] = (char) 0;
2386 return new_host_pathspec
;
2389 /* Translate a Unix syntax directory specification into VMS syntax. The
2390 PREFIXFLAG has no effect, but is kept for symmetry with
2391 to_canonical_dir_spec. If indicators of VMS syntax found, return input
2395 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2397 int len
= strlen (dirspec
);
2399 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
2400 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
2402 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
2403 return new_host_dirspec
;
2405 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
2407 new_host_dirspec
[len
- 1] = 0;
2411 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
2412 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
2413 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
2415 return new_host_dirspec
;
2418 /* Translate a Unix syntax file specification into VMS syntax.
2419 If indicators of VMS syntax found, return input string. */
2422 __gnat_to_host_file_spec (char *filespec
)
2424 strncpy (new_host_filespec
, "", MAXPATH
);
2425 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
2427 strncpy (new_host_filespec
, filespec
, MAXPATH
);
2431 decc$
to_vms (filespec
, translate_unix
, 1, 1);
2432 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
2435 new_host_filespec
[MAXPATH
- 1] = (char) 0;
2437 return new_host_filespec
;
2441 __gnat_adjust_os_resource_limits ()
2443 SYS$
ADJWSL (131072, 0);
2448 /* Dummy functions for Osint import for non-VMS systems. */
2451 __gnat_to_canonical_file_list_init
2452 (char *dirspec ATTRIBUTE_UNUSED
, int onlydirs ATTRIBUTE_UNUSED
)
2458 __gnat_to_canonical_file_list_next (void)
2464 __gnat_to_canonical_file_list_free (void)
2469 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2475 __gnat_to_canonical_file_spec (char *filespec
)
2481 __gnat_to_canonical_path_spec (char *pathspec
)
2487 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2493 __gnat_to_host_file_spec (char *filespec
)
2499 __gnat_adjust_os_resource_limits (void)
2505 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
2506 to coordinate this with the EMX distribution. Consequently, we put the
2507 definition of dummy which is used for exception handling, here. */
2509 #if defined (__EMX__)
2513 #if defined (__mips_vxworks)
2517 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
2521 #if defined (CROSS_COMPILE) \
2522 || (! (defined (sparc) && defined (sun) && defined (__SVR4)) \
2523 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
2524 && ! defined (__FreeBSD__) \
2525 && ! defined (__hpux__) \
2526 && ! defined (__APPLE__) \
2527 && ! defined (_AIX) \
2528 && ! (defined (__alpha__) && defined (__osf__)) \
2529 && ! defined (__MINGW32__) \
2530 && ! (defined (__mips) && defined (__sgi)))
2532 /* Dummy function to satisfy g-trasym.o. Currently Solaris sparc, HP/UX,
2533 GNU/Linux x86{_64}, Tru64 & Windows provide a non-dummy version of this
2534 procedure in libaddr2line.a. */
2537 convert_addresses (void *addrs ATTRIBUTE_UNUSED
,
2538 int n_addr ATTRIBUTE_UNUSED
,
2539 void *buf ATTRIBUTE_UNUSED
,
2540 int *len ATTRIBUTE_UNUSED
)
2546 #if defined (_WIN32)
2547 int __gnat_argument_needs_quote
= 1;
2549 int __gnat_argument_needs_quote
= 0;
2552 /* This option is used to enable/disable object files handling from the
2553 binder file by the GNAT Project module. For example, this is disabled on
2554 Windows (prior to GCC 3.4) as it is already done by the mdll module.
2555 Stating with GCC 3.4 the shared libraries are not based on mdll
2556 anymore as it uses the GCC's -shared option */
2557 #if defined (_WIN32) \
2558 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
2559 int __gnat_prj_add_obj_files
= 0;
2561 int __gnat_prj_add_obj_files
= 1;
2564 /* char used as prefix/suffix for environment variables */
2565 #if defined (_WIN32)
2566 char __gnat_environment_char
= '%';
2568 char __gnat_environment_char
= '$';
2571 /* This functions copy the file attributes from a source file to a
2574 mode = 0 : In this mode copy only the file time stamps (last access and
2575 last modification time stamps).
2577 mode = 1 : In this mode, time stamps and read/write/execute attributes are
2580 Returns 0 if operation was successful and -1 in case of error. */
2583 __gnat_copy_attribs (char *from
, char *to
, int mode
)
2585 #if defined (VMS) || defined (__vxworks)
2589 struct utimbuf tbuf
;
2591 if (stat (from
, &fbuf
) == -1)
2596 tbuf
.actime
= fbuf
.st_atime
;
2597 tbuf
.modtime
= fbuf
.st_mtime
;
2599 if (utime (to
, &tbuf
) == -1)
2606 if (chmod (to
, fbuf
.st_mode
) == -1)
2616 /* This function is installed in libgcc.a. */
2617 extern void __gnat_install_locks (void (*) (void), void (*) (void));
2619 /* This function offers a hook for libgnarl to set the
2620 locking subprograms for libgcc_eh.
2621 This is only needed on OpenVMS, since other platforms use standard
2622 --enable-threads=posix option, or similar. */
2625 __gnatlib_install_locks (void (*lock
) (void) ATTRIBUTE_UNUSED
,
2626 void (*unlock
) (void) ATTRIBUTE_UNUSED
)
2628 #if defined (IN_RTS) && defined (VMS)
2629 __gnat_install_locks (lock
, unlock
);
2630 /* There is a bootstrap path issue if adaint is build with this
2631 symbol unresolved for the stage1 compiler. Since the compiler
2632 does not use tasking, we simply make __gnatlib_install_locks
2633 a no-op in this case. */
2638 __gnat_lseek (int fd
, long offset
, int whence
)
2640 return (int) lseek (fd
, offset
, whence
);
2643 /* This function returns the version of GCC being used. Here it's GCC 3. */
2645 get_gcc_version (void)
2651 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED
,
2652 int close_on_exec_p ATTRIBUTE_UNUSED
)
2654 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
2655 int flags
= fcntl (fd
, F_GETFD
, 0);
2658 if (close_on_exec_p
)
2659 flags
|= FD_CLOEXEC
;
2661 flags
&= ~FD_CLOEXEC
;
2662 return fcntl (fd
, F_SETFD
, flags
| FD_CLOEXEC
);
2665 /* For the Windows case, we should use SetHandleInformation to remove
2666 the HANDLE_INHERIT property from fd. This is not implemented yet,
2667 but for our purposes (support of GNAT.Expect) this does not matter,
2668 as by default handles are *not* inherited. */