1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2006, 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
)
416 TCHAR wfull_path
[GNAT_MAX_PATH_LEN
];
417 TCHAR wfile
[GNAT_MAX_PATH_LEN
];
418 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
420 S2WS (wdir
, dir
, GNAT_MAX_PATH_LEN
);
421 S2WS (wfile
, file
, GNAT_MAX_PATH_LEN
);
423 _stprintf (wfull_path
, _T("%s%c%s"), wdir
, _T(DIR_SEPARATOR
), wfile
);
424 fd
= _topen (wfull_path
, O_CREAT
| O_EXCL
, 0600);
428 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
429 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
439 #elif defined (__EMX__) || defined (VMS)
441 /* More cases that do not use link; identical code, to solve too long
445 __gnat_try_lock (char *dir
, char *file
)
450 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
451 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
462 /* Version using link(), more secure over NFS. */
463 /* See TN 6913-016 for discussion ??? */
466 __gnat_try_lock (char *dir
, char *file
)
470 struct stat stat_result
;
473 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
474 sprintf (temp_file
, "%s%cTMP-%ld-%ld",
475 dir
, DIR_SEPARATOR
, (long)getpid(), (long)getppid ());
477 /* Create the temporary file and write the process number. */
478 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
484 /* Link it with the new file. */
485 link (temp_file
, full_path
);
487 /* Count the references on the old one. If we have a count of two, then
488 the link did succeed. Remove the temporary file before returning. */
489 __gnat_stat (temp_file
, &stat_result
);
491 return stat_result
.st_nlink
== 2;
495 /* Return the maximum file name length. */
498 __gnat_get_maximum_file_name_length (void)
503 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
512 /* Return nonzero if file names are case sensitive. */
515 __gnat_get_file_names_case_sensitive (void)
517 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT)
525 __gnat_get_default_identifier_character_set (void)
527 #if defined (__EMX__) || defined (MSDOS)
534 /* Return the current working directory. */
537 __gnat_get_current_dir (char *dir
, int *length
)
539 #if defined (__MINGW32__)
540 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
542 _tgetcwd (wdir
, *length
);
544 WS2S (dir
, wdir
, GNAT_MAX_PATH_LEN
);
547 /* Force Unix style, which is what GNAT uses internally. */
548 getcwd (dir
, *length
, 0);
550 getcwd (dir
, *length
);
553 *length
= strlen (dir
);
555 if (dir
[*length
- 1] != DIR_SEPARATOR
)
557 dir
[*length
] = DIR_SEPARATOR
;
563 /* Return the suffix for object files. */
566 __gnat_get_object_suffix_ptr (int *len
, const char **value
)
568 *value
= HOST_OBJECT_SUFFIX
;
573 *len
= strlen (*value
);
578 /* Return the suffix for executable files. */
581 __gnat_get_executable_suffix_ptr (int *len
, const char **value
)
583 *value
= HOST_EXECUTABLE_SUFFIX
;
587 *len
= strlen (*value
);
592 /* Return the suffix for debuggable files. Usually this is the same as the
593 executable extension. */
596 __gnat_get_debuggable_suffix_ptr (int *len
, const char **value
)
599 *value
= HOST_EXECUTABLE_SUFFIX
;
601 /* On DOS, the extensionless COFF file is what gdb likes. */
608 *len
= strlen (*value
);
614 __gnat_open_read (char *path
, int fmode
)
617 int o_fmode
= O_BINARY
;
623 /* Optional arguments mbc,deq,fop increase read performance. */
624 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
625 "mbc=16", "deq=64", "fop=tef");
626 #elif defined (__vxworks)
627 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
628 #elif defined (__MINGW32__)
630 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
632 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
633 fd
= _topen (wpath
, O_RDONLY
| o_fmode
, 0444);
636 fd
= open (path
, O_RDONLY
| o_fmode
);
639 return fd
< 0 ? -1 : fd
;
642 #if defined (__EMX__) || defined (__MINGW32__)
643 #define PERM (S_IREAD | S_IWRITE)
645 /* Excerpt from DECC C RTL Reference Manual:
646 To create files with OpenVMS RMS default protections using the UNIX
647 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
648 and open with a file-protection mode argument of 0777 in a program
649 that never specifically calls umask. These default protections include
650 correctly establishing protections based on ACLs, previous versions of
654 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
658 __gnat_open_rw (char *path
, int fmode
)
661 int o_fmode
= O_BINARY
;
667 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
668 "mbc=16", "deq=64", "fop=tef");
669 #elif defined (__MINGW32__)
671 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
673 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
674 fd
= _topen (wpath
, O_RDWR
| o_fmode
, PERM
);
677 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
680 return fd
< 0 ? -1 : fd
;
684 __gnat_open_create (char *path
, int fmode
)
687 int o_fmode
= O_BINARY
;
693 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
694 "mbc=16", "deq=64", "fop=tef");
695 #elif defined (__MINGW32__)
697 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
699 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
700 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
703 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
706 return fd
< 0 ? -1 : fd
;
710 __gnat_create_output_file (char *path
)
714 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
,
715 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
716 "shr=del,get,put,upd");
717 #elif defined (__MINGW32__)
719 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
721 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
722 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
725 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
728 return fd
< 0 ? -1 : fd
;
732 __gnat_open_append (char *path
, int fmode
)
735 int o_fmode
= O_BINARY
;
741 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
742 "mbc=16", "deq=64", "fop=tef");
743 #elif defined (__MINGW32__)
745 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
747 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
748 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
751 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
754 return fd
< 0 ? -1 : fd
;
757 /* Open a new file. Return error (-1) if the file already exists. */
760 __gnat_open_new (char *path
, int fmode
)
763 int o_fmode
= O_BINARY
;
769 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
770 "mbc=16", "deq=64", "fop=tef");
771 #elif defined (__MINGW32__)
773 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
775 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
776 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
779 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
782 return fd
< 0 ? -1 : fd
;
785 /* Open a new temp file. Return error (-1) if the file already exists.
786 Special options for VMS allow the file to be shared between parent and child
787 processes, however they really slow down output. Used in gnatchop. */
790 __gnat_open_new_temp (char *path
, int fmode
)
793 int o_fmode
= O_BINARY
;
795 strcpy (path
, "GNAT-XXXXXX");
797 #if (defined (__FreeBSD__) || defined (linux)) && !defined (__vxworks)
798 return mkstemp (path
);
799 #elif defined (__Lynx__)
802 if (mktemp (path
) == NULL
)
810 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
811 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
812 "mbc=16", "deq=64", "fop=tef");
814 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
817 return fd
< 0 ? -1 : fd
;
820 /* Return the number of bytes in the specified file. */
823 __gnat_file_length (int fd
)
828 ret
= fstat (fd
, &statbuf
);
829 if (ret
|| !S_ISREG (statbuf
.st_mode
))
832 return (statbuf
.st_size
);
835 /* Return the number of bytes in the specified named file. */
838 __gnat_named_file_length (char *name
)
843 ret
= __gnat_stat (name
, &statbuf
);
844 if (ret
|| !S_ISREG (statbuf
.st_mode
))
847 return (statbuf
.st_size
);
850 /* Create a temporary filename and put it in string pointed to by
854 __gnat_tmp_name (char *tmp_filename
)
860 /* tempnam tries to create a temporary file in directory pointed to by
861 TMP environment variable, in c:\temp if TMP is not set, and in
862 directory specified by P_tmpdir in stdio.h if c:\temp does not
863 exist. The filename will be created with the prefix "gnat-". */
865 pname
= (char *) tempnam ("c:\\temp", "gnat-");
867 /* if pname is NULL, the file was not created properly, the disk is full
868 or there is no more free temporary files */
871 *tmp_filename
= '\0';
873 /* If pname start with a back slash and not path information it means that
874 the filename is valid for the current working directory. */
876 else if (pname
[0] == '\\')
878 strcpy (tmp_filename
, ".\\");
879 strcat (tmp_filename
, pname
+1);
882 strcpy (tmp_filename
, pname
);
887 #elif defined (linux) || defined (__FreeBSD__)
888 #define MAX_SAFE_PATH 1000
889 char *tmpdir
= getenv ("TMPDIR");
891 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
892 a buffer overflow. */
893 if (tmpdir
== NULL
|| strlen (tmpdir
) > MAX_SAFE_PATH
)
894 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
896 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
898 close (mkstemp(tmp_filename
));
900 tmpnam (tmp_filename
);
904 /* Open directory and returns a DIR pointer. */
906 DIR* __gnat_opendir (char *name
)
909 TCHAR wname
[GNAT_MAX_PATH_LEN
];
911 S2WS (wname
, name
, GNAT_MAX_PATH_LEN
);
912 return (DIR*)_topendir (wname
);
915 return opendir (name
);
919 /* Read the next entry in a directory. The returned string points somewhere
923 __gnat_readdir (DIR *dirp
, char *buffer
, int *len
)
925 #if defined (__MINGW32__)
926 struct _tdirent
*dirent
= _treaddir ((_TDIR
*)dirp
);
930 WS2S (buffer
, dirent
->d_name
, GNAT_MAX_PATH_LEN
);
931 *len
= strlen (buffer
);
938 #elif defined (HAVE_READDIR_R)
939 /* If possible, try to use the thread-safe version. */
940 if (readdir_r (dirp
, buffer
) != NULL
)
941 *len
= strlen (((struct dirent
*) buffer
)->d_name
);
942 return ((struct dirent
*) buffer
)->d_name
;
947 struct dirent
*dirent
= (struct dirent
*) readdir (dirp
);
951 strcpy (buffer
, dirent
->d_name
);
952 *len
= strlen (buffer
);
961 /* Close a directory entry. */
963 int __gnat_closedir (DIR *dirp
)
966 return _tclosedir ((_TDIR
*)dirp
);
969 return closedir (dirp
);
973 /* Returns 1 if readdir is thread safe, 0 otherwise. */
976 __gnat_readdir_is_thread_safe (void)
978 #ifdef HAVE_READDIR_R
986 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
987 static const unsigned long long w32_epoch_offset
= 11644473600ULL;
989 /* Returns the file modification timestamp using Win32 routines which are
990 immune against daylight saving time change. It is in fact not possible to
991 use fstat for this purpose as the DST modify the st_mtime field of the
995 win32_filetime (HANDLE h
)
1000 unsigned long long ull_time
;
1003 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1004 since <Jan 1st 1601>. This function must return the number of seconds
1005 since <Jan 1st 1970>. */
1007 if (GetFileTime (h
, NULL
, NULL
, &t_write
.ft_time
))
1008 return (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1013 /* Return a GNAT time stamp given a file name. */
1016 __gnat_file_time_name (char *name
)
1019 #if defined (__EMX__) || defined (MSDOS)
1020 int fd
= open (name
, O_RDONLY
| O_BINARY
);
1021 time_t ret
= __gnat_file_time_fd (fd
);
1023 return (OS_Time
)ret
;
1025 #elif defined (_WIN32)
1027 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1029 S2WS (wname
, name
, GNAT_MAX_PATH_LEN
);
1031 HANDLE h
= CreateFile
1032 (wname
, GENERIC_READ
, FILE_SHARE_READ
, 0,
1033 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
, 0);
1035 if (h
!= INVALID_HANDLE_VALUE
)
1037 ret
= win32_filetime (h
);
1040 return (OS_Time
) ret
;
1042 struct stat statbuf
;
1043 if (__gnat_stat (name
, &statbuf
) != 0) {
1047 /* VMS has file versioning. */
1048 return (OS_Time
)statbuf
.st_ctime
;
1050 return (OS_Time
)statbuf
.st_mtime
;
1056 /* Return a GNAT time stamp given a file descriptor. */
1059 __gnat_file_time_fd (int fd
)
1061 /* The following workaround code is due to the fact that under EMX and
1062 DJGPP fstat attempts to convert time values to GMT rather than keep the
1063 actual OS timestamp of the file. By using the OS2/DOS functions directly
1064 the GNAT timestamp are independent of this behavior, which is desired to
1065 facilitate the distribution of GNAT compiled libraries. */
1067 #if defined (__EMX__) || defined (MSDOS)
1071 int ret
= DosQueryFileInfo (fd
, 1, (unsigned char *) &fs
,
1072 sizeof (FILESTATUS
));
1074 unsigned file_year
= fs
.fdateLastWrite
.year
;
1075 unsigned file_month
= fs
.fdateLastWrite
.month
;
1076 unsigned file_day
= fs
.fdateLastWrite
.day
;
1077 unsigned file_hour
= fs
.ftimeLastWrite
.hours
;
1078 unsigned file_min
= fs
.ftimeLastWrite
.minutes
;
1079 unsigned file_tsec
= fs
.ftimeLastWrite
.twosecs
;
1083 int ret
= getftime (fd
, &fs
);
1085 unsigned file_year
= fs
.ft_year
;
1086 unsigned file_month
= fs
.ft_month
;
1087 unsigned file_day
= fs
.ft_day
;
1088 unsigned file_hour
= fs
.ft_hour
;
1089 unsigned file_min
= fs
.ft_min
;
1090 unsigned file_tsec
= fs
.ft_tsec
;
1093 /* Calculate the seconds since epoch from the time components. First count
1094 the whole days passed. The value for years returned by the DOS and OS2
1095 functions count years from 1980, so to compensate for the UNIX epoch which
1096 begins in 1970 start with 10 years worth of days and add days for each
1097 four year period since then. */
1100 int cum_days
[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
1101 int days_passed
= 3652 + (file_year
/ 4) * 1461;
1102 int years_since_leap
= file_year
% 4;
1104 if (years_since_leap
== 1)
1106 else if (years_since_leap
== 2)
1108 else if (years_since_leap
== 3)
1109 days_passed
+= 1096;
1114 days_passed
+= cum_days
[file_month
- 1];
1115 if (years_since_leap
== 0 && file_year
!= 20 && file_month
> 2)
1118 days_passed
+= file_day
- 1;
1120 /* OK - have whole days. Multiply -- then add in other parts. */
1122 tot_secs
= days_passed
* 86400;
1123 tot_secs
+= file_hour
* 3600;
1124 tot_secs
+= file_min
* 60;
1125 tot_secs
+= file_tsec
* 2;
1126 return (OS_Time
) tot_secs
;
1128 #elif defined (_WIN32)
1129 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
1130 time_t ret
= win32_filetime (h
);
1131 return (OS_Time
) ret
;
1134 struct stat statbuf
;
1136 if (fstat (fd
, &statbuf
) != 0) {
1137 return (OS_Time
) -1;
1140 /* VMS has file versioning. */
1141 return (OS_Time
) statbuf
.st_ctime
;
1143 return (OS_Time
) statbuf
.st_mtime
;
1149 /* Set the file time stamp. */
1152 __gnat_set_file_time_name (char *name
, time_t time_stamp
)
1154 #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1156 /* Code to implement __gnat_set_file_time_name for these systems. */
1158 #elif defined (_WIN32)
1162 unsigned long long ull_time
;
1164 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1166 S2WS (wname
, name
, GNAT_MAX_PATH_LEN
);
1168 HANDLE h
= CreateFile
1169 (wname
, GENERIC_WRITE
, FILE_SHARE_WRITE
, NULL
,
1170 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
,
1172 if (h
== INVALID_HANDLE_VALUE
)
1174 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1175 t_write
.ull_time
= ((unsigned long long)time_stamp
+ w32_epoch_offset
);
1176 /* Convert to 100 nanosecond units */
1177 t_write
.ull_time
*= 10000000ULL;
1179 SetFileTime(h
, NULL
, NULL
, &t_write
.ft_time
);
1189 unsigned long long backup
, create
, expire
, revise
;
1193 unsigned short value
;
1196 unsigned system
: 4;
1202 } Fat
= { 0, 0, 0, 0, 0, { 0 }};
1206 { ATR$S_CREDATE
, ATR$C_CREDATE
, &Fat
.create
},
1207 { ATR$S_REVDATE
, ATR$C_REVDATE
, &Fat
.revise
},
1208 { ATR$S_EXPDATE
, ATR$C_EXPDATE
, &Fat
.expire
},
1209 { ATR$S_BAKDATE
, ATR$C_BAKDATE
, &Fat
.backup
},
1210 { ATR$S_FPRO
, ATR$C_FPRO
, &Fat
.prot
},
1211 { ATR$S_UIC
, ATR$C_UIC
, &Fat
.uic
},
1216 struct dsc$descriptor_fib fibdsc
= {sizeof (fib
), (void *) &fib
};
1220 unsigned long long newtime
;
1221 unsigned long long revtime
;
1225 struct vstring file
;
1226 struct dsc$descriptor_s filedsc
1227 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) file
.string
};
1228 struct vstring device
;
1229 struct dsc$descriptor_s devicedsc
1230 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) device
.string
};
1231 struct vstring timev
;
1232 struct dsc$descriptor_s timedsc
1233 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) timev
.string
};
1234 struct vstring result
;
1235 struct dsc$descriptor_s resultdsc
1236 = {NAM$C_MAXRSS
, DSC$K_DTYPE_VT
, DSC$K_CLASS_VS
, (void *) result
.string
};
1238 /* Convert parameter name (a file spec) to host file form. Note that this
1239 is needed on VMS to prepare for subsequent calls to VMS RMS library
1240 routines. Note that it would not work to call __gnat_to_host_dir_spec
1241 as was done in a previous version, since this fails silently unless
1242 the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1243 (directory not found) condition is signalled. */
1244 tryfile
= (char *) __gnat_to_host_file_spec (name
);
1246 /* Allocate and initialize a FAB and NAM structures. */
1250 nam
.nam$l_esa
= file
.string
;
1251 nam
.nam$b_ess
= NAM$C_MAXRSS
;
1252 nam
.nam$l_rsa
= result
.string
;
1253 nam
.nam$b_rss
= NAM$C_MAXRSS
;
1254 fab
.fab$l_fna
= tryfile
;
1255 fab
.fab$b_fns
= strlen (tryfile
);
1256 fab
.fab$l_nam
= &nam
;
1258 /* Validate filespec syntax and device existence. */
1259 status
= SYS$
PARSE (&fab
, 0, 0);
1260 if ((status
& 1) != 1)
1261 LIB$
SIGNAL (status
);
1263 file
.string
[nam
.nam$b_esl
] = 0;
1265 /* Find matching filespec. */
1266 status
= SYS$
SEARCH (&fab
, 0, 0);
1267 if ((status
& 1) != 1)
1268 LIB$
SIGNAL (status
);
1270 file
.string
[nam
.nam$b_esl
] = 0;
1271 result
.string
[result
.length
=nam
.nam$b_rsl
] = 0;
1273 /* Get the device name and assign an IO channel. */
1274 strncpy (device
.string
, nam
.nam$l_dev
, nam
.nam$b_dev
);
1275 devicedsc
.dsc$w_length
= nam
.nam$b_dev
;
1277 status
= SYS$
ASSIGN (&devicedsc
, &chan
, 0, 0, 0);
1278 if ((status
& 1) != 1)
1279 LIB$
SIGNAL (status
);
1281 /* Initialize the FIB and fill in the directory id field. */
1282 memset (&fib
, 0, sizeof (fib
));
1283 fib
.fib$w_did
[0] = nam
.nam$w_did
[0];
1284 fib
.fib$w_did
[1] = nam
.nam$w_did
[1];
1285 fib
.fib$w_did
[2] = nam
.nam$w_did
[2];
1286 fib
.fib$l_acctl
= 0;
1288 strcpy (file
.string
, (strrchr (result
.string
, ']') + 1));
1289 filedsc
.dsc$w_length
= strlen (file
.string
);
1290 result
.string
[result
.length
= 0] = 0;
1292 /* Open and close the file to fill in the attributes. */
1294 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1295 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1296 if ((status
& 1) != 1)
1297 LIB$
SIGNAL (status
);
1298 if ((iosb
.status
& 1) != 1)
1299 LIB$
SIGNAL (iosb
.status
);
1301 result
.string
[result
.length
] = 0;
1302 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0, &fibdsc
, 0, 0, 0,
1304 if ((status
& 1) != 1)
1305 LIB$
SIGNAL (status
);
1306 if ((iosb
.status
& 1) != 1)
1307 LIB$
SIGNAL (iosb
.status
);
1312 /* Set creation time to requested time. */
1313 unix_time_to_vms (time_stamp
, newtime
);
1315 t
= time ((time_t) 0);
1317 /* Set revision time to now in local time. */
1318 unix_time_to_vms (t
, revtime
);
1321 /* Reopen the file, modify the times and then close. */
1322 fib
.fib$l_acctl
= FIB$M_WRITE
;
1324 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1325 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1326 if ((status
& 1) != 1)
1327 LIB$
SIGNAL (status
);
1328 if ((iosb
.status
& 1) != 1)
1329 LIB$
SIGNAL (iosb
.status
);
1331 Fat
.create
= newtime
;
1332 Fat
.revise
= revtime
;
1334 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0,
1335 &fibdsc
, 0, 0, 0, &atrlst
, 0);
1336 if ((status
& 1) != 1)
1337 LIB$
SIGNAL (status
);
1338 if ((iosb
.status
& 1) != 1)
1339 LIB$
SIGNAL (iosb
.status
);
1341 /* Deassign the channel and exit. */
1342 status
= SYS$
DASSGN (chan
);
1343 if ((status
& 1) != 1)
1344 LIB$
SIGNAL (status
);
1346 struct utimbuf utimbuf
;
1349 /* Set modification time to requested time. */
1350 utimbuf
.modtime
= time_stamp
;
1352 /* Set access time to now in local time. */
1353 t
= time ((time_t) 0);
1354 utimbuf
.actime
= mktime (localtime (&t
));
1356 utime (name
, &utimbuf
);
1361 #include <windows.h>
1364 /* Get the list of installed standard libraries from the
1365 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1369 __gnat_get_libraries_from_registry (void)
1371 char *result
= (char *) "";
1373 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_COMPILE)
1376 DWORD name_size
, value_size
;
1383 /* First open the key. */
1384 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1386 if (res
== ERROR_SUCCESS
)
1387 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1388 KEY_READ
, ®_key
);
1390 if (res
== ERROR_SUCCESS
)
1391 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1393 if (res
== ERROR_SUCCESS
)
1394 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1396 /* If the key exists, read out all the values in it and concatenate them
1398 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1400 value_size
= name_size
= 256;
1401 res
= RegEnumValue (reg_key
, index
, (TCHAR
*)name
, &name_size
, 0,
1402 &type
, (LPBYTE
)value
, &value_size
);
1404 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1406 char *old_result
= result
;
1408 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1409 strcpy (result
, old_result
);
1410 strcat (result
, value
);
1411 strcat (result
, ";");
1415 /* Remove the trailing ";". */
1417 result
[strlen (result
) - 1] = 0;
1424 __gnat_stat (char *name
, struct stat
*statbuf
)
1427 /* Under Windows the directory name for the stat function must not be
1428 terminated by a directory separator except if just after a drive name. */
1429 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
1433 S2WS (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
1434 name_len
= _tcslen (wname
);
1436 if (name_len
> GNAT_MAX_PATH_LEN
)
1439 last_char
= wname
[name_len
- 1];
1441 while (name_len
> 1 && (last_char
== _T('\\') || last_char
== _T('/')))
1443 wname
[name_len
- 1] = _T('\0');
1445 last_char
= wname
[name_len
- 1];
1448 /* Only a drive letter followed by ':', we must add a directory separator
1449 for the stat routine to work properly. */
1450 if (name_len
== 2 && wname
[1] == _T(':'))
1451 _tcscat (wname
, _T("\\"));
1453 return _tstat (wname
, statbuf
);
1456 return stat (name
, statbuf
);
1461 __gnat_file_exists (char *name
)
1463 struct stat statbuf
;
1465 return !__gnat_stat (name
, &statbuf
);
1469 __gnat_is_absolute_path (char *name
, int length
)
1471 return (length
!= 0) &&
1472 (*name
== '/' || *name
== DIR_SEPARATOR
1473 #if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
1474 || (length
> 1 && isalpha (name
[0]) && name
[1] == ':')
1480 __gnat_is_regular_file (char *name
)
1483 struct stat statbuf
;
1485 ret
= __gnat_stat (name
, &statbuf
);
1486 return (!ret
&& S_ISREG (statbuf
.st_mode
));
1490 __gnat_is_directory (char *name
)
1493 struct stat statbuf
;
1495 ret
= __gnat_stat (name
, &statbuf
);
1496 return (!ret
&& S_ISDIR (statbuf
.st_mode
));
1500 __gnat_is_readable_file (char *name
)
1504 struct stat statbuf
;
1506 ret
= __gnat_stat (name
, &statbuf
);
1507 mode
= statbuf
.st_mode
& S_IRUSR
;
1508 return (!ret
&& mode
);
1512 __gnat_is_writable_file (char *name
)
1516 struct stat statbuf
;
1518 ret
= __gnat_stat (name
, &statbuf
);
1519 mode
= statbuf
.st_mode
& S_IWUSR
;
1520 return (!ret
&& mode
);
1524 __gnat_set_writable (char *name
)
1527 struct stat statbuf
;
1529 if (stat (name
, &statbuf
) == 0)
1531 statbuf
.st_mode
= statbuf
.st_mode
| S_IWUSR
;
1532 chmod (name
, statbuf
.st_mode
);
1538 __gnat_set_executable (char *name
)
1541 struct stat statbuf
;
1543 if (stat (name
, &statbuf
) == 0)
1545 statbuf
.st_mode
= statbuf
.st_mode
| S_IXUSR
;
1546 chmod (name
, statbuf
.st_mode
);
1552 __gnat_set_readonly (char *name
)
1555 struct stat statbuf
;
1557 if (stat (name
, &statbuf
) == 0)
1559 statbuf
.st_mode
= statbuf
.st_mode
& 07577;
1560 chmod (name
, statbuf
.st_mode
);
1566 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED
)
1568 #if defined (__vxworks)
1571 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
1573 struct stat statbuf
;
1575 ret
= lstat (name
, &statbuf
);
1576 return (!ret
&& S_ISLNK (statbuf
.st_mode
));
1583 #if defined (sun) && defined (__SVR4)
1584 /* Using fork on Solaris will duplicate all the threads. fork1, which
1585 duplicates only the active thread, must be used instead, or spawning
1586 subprocess from a program with tasking will lead into numerous problems. */
1591 __gnat_portable_spawn (char *args
[])
1594 int finished ATTRIBUTE_UNUSED
;
1595 int pid ATTRIBUTE_UNUSED
;
1597 #if defined (MSDOS) || defined (_WIN32)
1598 /* args[0] must be quotes as it could contain a full pathname with spaces */
1599 char *args_0
= args
[0];
1600 args
[0] = (char *)xmalloc (strlen (args_0
) + 3);
1601 strcpy (args
[0], "\"");
1602 strcat (args
[0], args_0
);
1603 strcat (args
[0], "\"");
1605 status
= spawnvp (P_WAIT
, args_0
, (const char* const*)args
);
1607 /* restore previous value */
1609 args
[0] = (char *)args_0
;
1616 #elif defined (__vxworks)
1621 pid
= spawnvp (P_NOWAIT
, args
[0], args
);
1633 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
1635 return -1; /* execv is in parent context on VMS. */
1643 finished
= waitpid (pid
, &status
, 0);
1645 if (finished
!= pid
|| WIFEXITED (status
) == 0)
1648 return WEXITSTATUS (status
);
1654 /* Create a copy of the given file descriptor.
1655 Return -1 if an error occurred. */
1658 __gnat_dup (int oldfd
)
1660 #if defined (__vxworks) && !defined (__RTP__)
1661 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
1669 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
1670 Return -1 if an error occurred. */
1673 __gnat_dup2 (int oldfd
, int newfd
)
1675 #if defined (__vxworks) && !defined (__RTP__)
1676 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
1680 return dup2 (oldfd
, newfd
);
1684 /* WIN32 code to implement a wait call that wait for any child process. */
1688 /* Synchronization code, to be thread safe. */
1690 static CRITICAL_SECTION plist_cs
;
1693 __gnat_plist_init (void)
1695 InitializeCriticalSection (&plist_cs
);
1701 EnterCriticalSection (&plist_cs
);
1707 LeaveCriticalSection (&plist_cs
);
1710 typedef struct _process_list
1713 struct _process_list
*next
;
1716 static Process_List
*PLIST
= NULL
;
1718 static int plist_length
= 0;
1721 add_handle (HANDLE h
)
1725 pl
= (Process_List
*) xmalloc (sizeof (Process_List
));
1729 /* -------------------- critical section -------------------- */
1734 /* -------------------- critical section -------------------- */
1740 remove_handle (HANDLE h
)
1743 Process_List
*prev
= NULL
;
1747 /* -------------------- critical section -------------------- */
1756 prev
->next
= pl
->next
;
1768 /* -------------------- critical section -------------------- */
1774 win32_no_block_spawn (char *command
, char *args
[])
1778 PROCESS_INFORMATION PI
;
1779 SECURITY_ATTRIBUTES SA
;
1784 /* compute the total command line length */
1788 csize
+= strlen (args
[k
]) + 1;
1792 full_command
= (char *) xmalloc (csize
);
1795 SI
.cb
= sizeof (STARTUPINFO
);
1796 SI
.lpReserved
= NULL
;
1797 SI
.lpReserved2
= NULL
;
1798 SI
.lpDesktop
= NULL
;
1802 SI
.wShowWindow
= SW_HIDE
;
1804 /* Security attributes. */
1805 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
1806 SA
.bInheritHandle
= TRUE
;
1807 SA
.lpSecurityDescriptor
= NULL
;
1809 /* Prepare the command string. */
1810 strcpy (full_command
, command
);
1811 strcat (full_command
, " ");
1816 strcat (full_command
, args
[k
]);
1817 strcat (full_command
, " ");
1822 int wsize
= csize
* 2;
1823 TCHAR
*wcommand
= (TCHAR
*) xmalloc (wsize
);
1825 S2WS (wcommand
, full_command
, wsize
);
1827 free (full_command
);
1829 result
= CreateProcess
1830 (NULL
, wcommand
, &SA
, NULL
, TRUE
,
1831 GetPriorityClass (GetCurrentProcess()), NULL
, NULL
, &SI
, &PI
);
1838 add_handle (PI
.hProcess
);
1839 CloseHandle (PI
.hThread
);
1840 return (int) PI
.hProcess
;
1847 win32_wait (int *status
)
1856 if (plist_length
== 0)
1862 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * plist_length
);
1867 /* -------------------- critical section -------------------- */
1874 /* -------------------- critical section -------------------- */
1878 res
= WaitForMultipleObjects (plist_length
, hl
, FALSE
, INFINITE
);
1879 h
= hl
[res
- WAIT_OBJECT_0
];
1884 GetExitCodeProcess (h
, &exitcode
);
1887 *status
= (int) exitcode
;
1894 __gnat_portable_no_block_spawn (char *args
[])
1898 #if defined (__EMX__) || defined (MSDOS)
1900 /* ??? For PC machines I (Franco) don't know the system calls to implement
1901 this routine. So I'll fake it as follows. This routine will behave
1902 exactly like the blocking portable_spawn and will systematically return
1903 a pid of 0 unless the spawned task did not complete successfully, in
1904 which case we return a pid of -1. To synchronize with this the
1905 portable_wait below systematically returns a pid of 0 and reports that
1906 the subprocess terminated successfully. */
1908 if (spawnvp (P_WAIT
, args
[0], args
) != 0)
1911 #elif defined (_WIN32)
1913 pid
= win32_no_block_spawn (args
[0], args
);
1916 #elif defined (__vxworks)
1925 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
1927 return -1; /* execv is in parent context on VMS. */
1939 __gnat_portable_wait (int *process_status
)
1944 #if defined (_WIN32)
1946 pid
= win32_wait (&status
);
1948 #elif defined (__EMX__) || defined (MSDOS)
1949 /* ??? See corresponding comment in portable_no_block_spawn. */
1951 #elif defined (__vxworks)
1952 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
1956 pid
= waitpid (-1, &status
, 0);
1957 status
= status
& 0xffff;
1960 *process_status
= status
;
1965 __gnat_os_exit (int status
)
1970 /* Locate a regular file, give a Path value. */
1973 __gnat_locate_regular_file (char *file_name
, char *path_val
)
1976 char *file_path
= alloca (strlen (file_name
) + 1);
1979 /* Return immediately if file_name is empty */
1981 if (*file_name
== '\0')
1984 /* Remove quotes around file_name if present */
1990 strcpy (file_path
, ptr
);
1992 ptr
= file_path
+ strlen (file_path
) - 1;
1997 /* Handle absolute pathnames. */
1999 absolute
= __gnat_is_absolute_path (file_path
, strlen (file_name
));
2003 if (__gnat_is_regular_file (file_path
))
2004 return xstrdup (file_path
);
2009 /* If file_name include directory separator(s), try it first as
2010 a path name relative to the current directory */
2011 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
2016 if (__gnat_is_regular_file (file_name
))
2017 return xstrdup (file_name
);
2024 /* The result has to be smaller than path_val + file_name. */
2025 char *file_path
= alloca (strlen (path_val
) + strlen (file_name
) + 2);
2029 for (; *path_val
== PATH_SEPARATOR
; path_val
++)
2035 /* Skip the starting quote */
2037 if (*path_val
== '"')
2040 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
2041 *ptr
++ = *path_val
++;
2045 /* Skip the ending quote */
2050 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
2051 *++ptr
= DIR_SEPARATOR
;
2053 strcpy (++ptr
, file_name
);
2055 if (__gnat_is_regular_file (file_path
))
2056 return xstrdup (file_path
);
2063 /* Locate an executable given a Path argument. This routine is only used by
2064 gnatbl and should not be used otherwise. Use locate_exec_on_path
2068 __gnat_locate_exec (char *exec_name
, char *path_val
)
2071 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
2073 char *full_exec_name
2074 = alloca (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
2076 strcpy (full_exec_name
, exec_name
);
2077 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
2078 ptr
= __gnat_locate_regular_file (full_exec_name
, path_val
);
2081 return __gnat_locate_regular_file (exec_name
, path_val
);
2085 return __gnat_locate_regular_file (exec_name
, path_val
);
2088 /* Locate an executable using the Systems default PATH. */
2091 __gnat_locate_exec_on_path (char *exec_name
)
2096 TCHAR
*wpath_val
= _tgetenv (_T("PATH"));
2098 /* In Win32 systems we expand the PATH as for XP environment
2099 variables are not automatically expanded. We also prepend the
2100 ".;" to the path to match normal NT path search semantics */
2102 #define EXPAND_BUFFER_SIZE 32767
2104 wapath_val
= alloca (EXPAND_BUFFER_SIZE
);
2106 wapath_val
[0] = '.';
2107 wapath_val
[1] = ';';
2109 DWORD res
= ExpandEnvironmentStrings
2110 (wpath_val
, &wapath_val
[2], EXPAND_BUFFER_SIZE
- 2);
2112 if (!res
) wapath_val
[0] = _T('\0');
2114 apath_val
= alloca (EXPAND_BUFFER_SIZE
);
2116 WS2S (apath_val
, wapath_val
, EXPAND_BUFFER_SIZE
);
2117 return __gnat_locate_exec (exec_name
, apath_val
);
2122 char *path_val
= "/VAXC$PATH";
2124 char *path_val
= getenv ("PATH");
2126 apath_val
= alloca (strlen (path_val
) + 1);
2127 strcpy (apath_val
, path_val
);
2128 return __gnat_locate_exec (exec_name
, apath_val
);
2134 /* These functions are used to translate to and from VMS and Unix syntax
2135 file, directory and path specifications. */
2138 #define MAXNAMES 256
2139 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2141 static char new_canonical_dirspec
[MAXPATH
];
2142 static char new_canonical_filespec
[MAXPATH
];
2143 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
2144 static unsigned new_canonical_filelist_index
;
2145 static unsigned new_canonical_filelist_in_use
;
2146 static unsigned new_canonical_filelist_allocated
;
2147 static char **new_canonical_filelist
;
2148 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
2149 static char new_host_dirspec
[MAXPATH
];
2150 static char new_host_filespec
[MAXPATH
];
2152 /* Routine is called repeatedly by decc$from_vms via
2153 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2157 wildcard_translate_unix (char *name
)
2160 char buff
[MAXPATH
];
2162 strncpy (buff
, name
, MAXPATH
);
2163 buff
[MAXPATH
- 1] = (char) 0;
2164 ver
= strrchr (buff
, '.');
2166 /* Chop off the version. */
2170 /* Dynamically extend the allocation by the increment. */
2171 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
2173 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
2174 new_canonical_filelist
= (char **) xrealloc
2175 (new_canonical_filelist
,
2176 new_canonical_filelist_allocated
* sizeof (char *));
2179 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
2184 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2185 full translation and copy the results into a list (_init), then return them
2186 one at a time (_next). If onlydirs set, only expand directory files. */
2189 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
2192 char buff
[MAXPATH
];
2194 len
= strlen (filespec
);
2195 strncpy (buff
, filespec
, MAXPATH
);
2197 /* Only look for directories */
2198 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
2199 strncat (buff
, "*.dir", MAXPATH
);
2201 buff
[MAXPATH
- 1] = (char) 0;
2203 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
2205 /* Remove the .dir extension. */
2211 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
2213 ext
= strstr (new_canonical_filelist
[i
], ".dir");
2219 return new_canonical_filelist_in_use
;
2222 /* Return the next filespec in the list. */
2225 __gnat_to_canonical_file_list_next ()
2227 return new_canonical_filelist
[new_canonical_filelist_index
++];
2230 /* Free storage used in the wildcard expansion. */
2233 __gnat_to_canonical_file_list_free ()
2237 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
2238 free (new_canonical_filelist
[i
]);
2240 free (new_canonical_filelist
);
2242 new_canonical_filelist_in_use
= 0;
2243 new_canonical_filelist_allocated
= 0;
2244 new_canonical_filelist_index
= 0;
2245 new_canonical_filelist
= 0;
2248 /* Translate a VMS syntax directory specification in to Unix syntax. If
2249 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2250 found, return input string. Also translate a dirname that contains no
2251 slashes, in case it's a logical name. */
2254 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
2258 strcpy (new_canonical_dirspec
, "");
2259 if (strlen (dirspec
))
2263 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
2265 strncpy (new_canonical_dirspec
,
2266 (char *) decc$
translate_vms (dirspec
),
2269 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
2271 strncpy (new_canonical_dirspec
,
2272 (char *) decc$
translate_vms (dirspec1
),
2277 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
2281 len
= strlen (new_canonical_dirspec
);
2282 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
2283 strncat (new_canonical_dirspec
, "/", MAXPATH
);
2285 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
2287 return new_canonical_dirspec
;
2291 /* Translate a VMS syntax file specification into Unix syntax.
2292 If no indicators of VMS syntax found, check if it's an uppercase
2293 alphanumeric_ name and if so try it out as an environment
2294 variable (logical name). If all else fails return the
2298 __gnat_to_canonical_file_spec (char *filespec
)
2302 strncpy (new_canonical_filespec
, "", MAXPATH
);
2304 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
2306 char *tspec
= (char *) decc$
translate_vms (filespec
);
2308 if (tspec
!= (char *) -1)
2309 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
2311 else if ((strlen (filespec
) == strspn (filespec
,
2312 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
2313 && (filespec1
= getenv (filespec
)))
2315 char *tspec
= (char *) decc$
translate_vms (filespec1
);
2317 if (tspec
!= (char *) -1)
2318 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
2322 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
2325 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
2327 return new_canonical_filespec
;
2330 /* Translate a VMS syntax path specification into Unix syntax.
2331 If no indicators of VMS syntax found, return input string. */
2334 __gnat_to_canonical_path_spec (char *pathspec
)
2336 char *curr
, *next
, buff
[MAXPATH
];
2341 /* If there are /'s, assume it's a Unix path spec and return. */
2342 if (strchr (pathspec
, '/'))
2345 new_canonical_pathspec
[0] = 0;
2350 next
= strchr (curr
, ',');
2352 next
= strchr (curr
, 0);
2354 strncpy (buff
, curr
, next
- curr
);
2355 buff
[next
- curr
] = 0;
2357 /* Check for wildcards and expand if present. */
2358 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
2362 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
2363 for (i
= 0; i
< dirs
; i
++)
2367 next_dir
= __gnat_to_canonical_file_list_next ();
2368 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
2370 /* Don't append the separator after the last expansion. */
2372 strncat (new_canonical_pathspec
, ":", MAXPATH
);
2375 __gnat_to_canonical_file_list_free ();
2378 strncat (new_canonical_pathspec
,
2379 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
2384 strncat (new_canonical_pathspec
, ":", MAXPATH
);
2388 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
2390 return new_canonical_pathspec
;
2393 static char filename_buff
[MAXPATH
];
2396 translate_unix (char *name
, int type
)
2398 strncpy (filename_buff
, name
, MAXPATH
);
2399 filename_buff
[MAXPATH
- 1] = (char) 0;
2403 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
2407 to_host_path_spec (char *pathspec
)
2409 char *curr
, *next
, buff
[MAXPATH
];
2414 /* Can't very well test for colons, since that's the Unix separator! */
2415 if (strchr (pathspec
, ']') || strchr (pathspec
, ','))
2418 new_host_pathspec
[0] = 0;
2423 next
= strchr (curr
, ':');
2425 next
= strchr (curr
, 0);
2427 strncpy (buff
, curr
, next
- curr
);
2428 buff
[next
- curr
] = 0;
2430 strncat (new_host_pathspec
, __gnat_to_host_dir_spec (buff
, 0), MAXPATH
);
2433 strncat (new_host_pathspec
, ",", MAXPATH
);
2437 new_host_pathspec
[MAXPATH
- 1] = (char) 0;
2439 return new_host_pathspec
;
2442 /* Translate a Unix syntax directory specification into VMS syntax. The
2443 PREFIXFLAG has no effect, but is kept for symmetry with
2444 to_canonical_dir_spec. If indicators of VMS syntax found, return input
2448 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2450 int len
= strlen (dirspec
);
2452 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
2453 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
2455 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
2456 return new_host_dirspec
;
2458 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
2460 new_host_dirspec
[len
- 1] = 0;
2464 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
2465 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
2466 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
2468 return new_host_dirspec
;
2471 /* Translate a Unix syntax file specification into VMS syntax.
2472 If indicators of VMS syntax found, return input string. */
2475 __gnat_to_host_file_spec (char *filespec
)
2477 strncpy (new_host_filespec
, "", MAXPATH
);
2478 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
2480 strncpy (new_host_filespec
, filespec
, MAXPATH
);
2484 decc$
to_vms (filespec
, translate_unix
, 1, 1);
2485 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
2488 new_host_filespec
[MAXPATH
- 1] = (char) 0;
2490 return new_host_filespec
;
2494 __gnat_adjust_os_resource_limits ()
2496 SYS$
ADJWSL (131072, 0);
2501 /* Dummy functions for Osint import for non-VMS systems. */
2504 __gnat_to_canonical_file_list_init
2505 (char *dirspec ATTRIBUTE_UNUSED
, int onlydirs ATTRIBUTE_UNUSED
)
2511 __gnat_to_canonical_file_list_next (void)
2517 __gnat_to_canonical_file_list_free (void)
2522 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2528 __gnat_to_canonical_file_spec (char *filespec
)
2534 __gnat_to_canonical_path_spec (char *pathspec
)
2540 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2546 __gnat_to_host_file_spec (char *filespec
)
2552 __gnat_adjust_os_resource_limits (void)
2558 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
2559 to coordinate this with the EMX distribution. Consequently, we put the
2560 definition of dummy which is used for exception handling, here. */
2562 #if defined (__EMX__)
2566 #if defined (__mips_vxworks)
2570 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
2574 #if defined (CROSS_COMPILE) \
2575 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
2576 && defined (__SVR4)) \
2577 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
2578 && ! (defined (linux) && defined (__ia64__)) \
2579 && ! defined (__FreeBSD__) \
2580 && ! defined (__hpux__) \
2581 && ! defined (__APPLE__) \
2582 && ! defined (_AIX) \
2583 && ! (defined (__alpha__) && defined (__osf__)) \
2584 && ! defined (VMS) \
2585 && ! defined (__MINGW32__) \
2586 && ! (defined (__mips) && defined (__sgi)))
2588 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
2589 just above for a list of native platforms that provide a non-dummy
2590 version of this procedure in libaddr2line.a. */
2593 convert_addresses (void *addrs ATTRIBUTE_UNUSED
,
2594 int n_addr ATTRIBUTE_UNUSED
,
2595 void *buf ATTRIBUTE_UNUSED
,
2596 int *len ATTRIBUTE_UNUSED
)
2602 #if defined (_WIN32)
2603 int __gnat_argument_needs_quote
= 1;
2605 int __gnat_argument_needs_quote
= 0;
2608 /* This option is used to enable/disable object files handling from the
2609 binder file by the GNAT Project module. For example, this is disabled on
2610 Windows (prior to GCC 3.4) as it is already done by the mdll module.
2611 Stating with GCC 3.4 the shared libraries are not based on mdll
2612 anymore as it uses the GCC's -shared option */
2613 #if defined (_WIN32) \
2614 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
2615 int __gnat_prj_add_obj_files
= 0;
2617 int __gnat_prj_add_obj_files
= 1;
2620 /* char used as prefix/suffix for environment variables */
2621 #if defined (_WIN32)
2622 char __gnat_environment_char
= '%';
2624 char __gnat_environment_char
= '$';
2627 /* This functions copy the file attributes from a source file to a
2630 mode = 0 : In this mode copy only the file time stamps (last access and
2631 last modification time stamps).
2633 mode = 1 : In this mode, time stamps and read/write/execute attributes are
2636 Returns 0 if operation was successful and -1 in case of error. */
2639 __gnat_copy_attribs (char *from
, char *to
, int mode
)
2641 #if defined (VMS) || defined (__vxworks)
2645 struct utimbuf tbuf
;
2647 if (stat (from
, &fbuf
) == -1)
2652 tbuf
.actime
= fbuf
.st_atime
;
2653 tbuf
.modtime
= fbuf
.st_mtime
;
2655 if (utime (to
, &tbuf
) == -1)
2662 if (chmod (to
, fbuf
.st_mode
) == -1)
2673 __gnat_lseek (int fd
, long offset
, int whence
)
2675 return (int) lseek (fd
, offset
, whence
);
2678 /* This function returns the version of GCC being used. Here it's GCC 3. */
2680 get_gcc_version (void)
2686 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED
,
2687 int close_on_exec_p ATTRIBUTE_UNUSED
)
2689 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
2690 int flags
= fcntl (fd
, F_GETFD
, 0);
2693 if (close_on_exec_p
)
2694 flags
|= FD_CLOEXEC
;
2696 flags
&= ~FD_CLOEXEC
;
2697 return fcntl (fd
, F_SETFD
, flags
| FD_CLOEXEC
);
2700 /* For the Windows case, we should use SetHandleInformation to remove
2701 the HANDLE_INHERIT property from fd. This is not implemented yet,
2702 but for our purposes (support of GNAT.Expect) this does not matter,
2703 as by default handles are *not* inherited. */
2707 /* Indicates if platforms supports automatic initialization through the
2708 constructor mechanism */
2710 __gnat_binder_supports_auto_init ()
2719 /* Indicates that Stand-Alone Libraries are automatically initialized through
2720 the constructor mechanism */
2722 __gnat_sals_init_using_constructors ()
2724 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)