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)
81 #include <sys/utime.h>
93 #elif defined (__vxworks) && defined (__RTP__)
99 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
102 /* Header files and definitions for __gnat_set_file_time_name. */
105 #include <vms/atrdef.h>
106 #include <vms/fibdef.h>
107 #include <vms/stsdef.h>
108 #include <vms/iodef.h>
110 #include <vms/descrip.h>
114 /* Use native 64-bit arithmetic. */
115 #define unix_time_to_vms(X,Y) \
116 { unsigned long long reftime, tmptime = (X); \
117 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
118 SYS$BINTIM (&unixtime, &reftime); \
119 Y = tmptime * 10000000 + reftime; }
121 /* descrip.h doesn't have everything ... */
122 struct dsc$descriptor_fib
124 unsigned long fib$l_len
;
125 struct fibdef
*fib$l_addr
;
128 /* I/O Status Block. */
131 unsigned short status
, count
;
132 unsigned long devdep
;
135 static char *tryfile
;
137 /* Variable length string. */
141 char string
[NAM$C_MAXRSS
+1];
148 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
156 #define DIR_SEPARATOR '\\'
161 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
162 defined in the current system. On DOS-like systems these flags control
163 whether the file is opened/created in text-translation mode (CR/LF in
164 external file mapped to LF in internal file), but in Unix-like systems,
165 no text translation is required, so these flags have no effect. */
167 #if defined (__EMX__)
183 #ifndef HOST_EXECUTABLE_SUFFIX
184 #define HOST_EXECUTABLE_SUFFIX ""
187 #ifndef HOST_OBJECT_SUFFIX
188 #define HOST_OBJECT_SUFFIX ".o"
191 #ifndef PATH_SEPARATOR
192 #define PATH_SEPARATOR ':'
195 #ifndef DIR_SEPARATOR
196 #define DIR_SEPARATOR '/'
199 /* Check for cross-compilation */
200 #ifdef CROSS_DIRECTORY_STRUCTURE
201 int __gnat_is_cross_compiler
= 1;
203 int __gnat_is_cross_compiler
= 0;
206 char __gnat_dir_separator
= DIR_SEPARATOR
;
208 char __gnat_path_separator
= PATH_SEPARATOR
;
210 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
211 the base filenames that libraries specified with -lsomelib options
212 may have. This is used by GNATMAKE to check whether an executable
213 is up-to-date or not. The syntax is
215 library_template ::= { pattern ; } pattern NUL
216 pattern ::= [ prefix ] * [ postfix ]
218 These should only specify names of static libraries as it makes
219 no sense to determine at link time if dynamic-link libraries are
220 up to date or not. Any libraries that are not found are supposed
223 * if they are needed but not present, the link
226 * otherwise they are libraries in the system paths and so
227 they are considered part of the system and not checked
230 ??? This should be part of a GNAT host-specific compiler
231 file instead of being included in all user applications
232 as well. This is only a temporary work-around for 3.11b. */
234 #ifndef GNAT_LIBRARY_TEMPLATE
235 #if defined (__EMX__)
236 #define GNAT_LIBRARY_TEMPLATE "*.a"
238 #define GNAT_LIBRARY_TEMPLATE "*.olb"
240 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
244 const char *__gnat_library_template
= GNAT_LIBRARY_TEMPLATE
;
246 /* This variable is used in hostparm.ads to say whether the host is a VMS
249 const int __gnat_vmsp
= 1;
251 const int __gnat_vmsp
= 0;
255 #define GNAT_MAX_PATH_LEN MAX_PATH
258 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
260 #elif defined (__vxworks) || defined (__OPENNT)
261 #define GNAT_MAX_PATH_LEN PATH_MAX
265 #if defined (__MINGW32__)
269 #include <sys/param.h>
273 #include <sys/param.h>
277 #define GNAT_MAX_PATH_LEN MAXPATHLEN
279 #define GNAT_MAX_PATH_LEN 256
284 /* The __gnat_max_path_len variable is used to export the maximum
285 length of a path name to Ada code. max_path_len is also provided
286 for compatibility with older GNAT versions, please do not use
289 int __gnat_max_path_len
= GNAT_MAX_PATH_LEN
;
290 int max_path_len
= GNAT_MAX_PATH_LEN
;
292 /* The following macro HAVE_READDIR_R should be defined if the
293 system provides the routine readdir_r. */
294 #undef HAVE_READDIR_R
296 #if defined(VMS) && defined (__LONG_POINTERS)
298 /* Return a 32 bit pointer to an array of 32 bit pointers
299 given a 64 bit pointer to an array of 64 bit pointers */
301 typedef __char_ptr32
*__char_ptr_char_ptr32
__attribute__ ((mode (SI
)));
303 static __char_ptr_char_ptr32
304 to_ptr32 (char **ptr64
)
307 __char_ptr_char_ptr32 short_argv
;
309 for (argc
=0; ptr64
[argc
]; argc
++);
311 /* Reallocate argv with 32 bit pointers. */
312 short_argv
= (__char_ptr_char_ptr32
) decc$malloc
313 (sizeof (__char_ptr32
) * (argc
+ 1));
315 for (argc
=0; ptr64
[argc
]; argc
++)
316 short_argv
[argc
] = (__char_ptr32
) decc$
strdup (ptr64
[argc
]);
318 short_argv
[argc
] = (__char_ptr32
) 0;
322 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
324 #define MAYBE_TO_PTR32(argv) argv
338 time_t time
= (time_t) *p_time
;
341 /* On Windows systems, the time is sometimes rounded up to the nearest
342 even second, so if the number of seconds is odd, increment it. */
348 res
= localtime (&time
);
350 res
= gmtime (&time
);
355 *p_year
= res
->tm_year
;
356 *p_month
= res
->tm_mon
;
357 *p_day
= res
->tm_mday
;
358 *p_hours
= res
->tm_hour
;
359 *p_mins
= res
->tm_min
;
360 *p_secs
= res
->tm_sec
;
363 *p_year
= *p_month
= *p_day
= *p_hours
= *p_mins
= *p_secs
= 0;
366 /* Place the contents of the symbolic link named PATH in the buffer BUF,
367 which has size BUFSIZ. If PATH is a symbolic link, then return the number
368 of characters of its content in BUF. Otherwise, return -1. For Windows,
369 OS/2 and vxworks, always return -1. */
372 __gnat_readlink (char *path ATTRIBUTE_UNUSED
,
373 char *buf ATTRIBUTE_UNUSED
,
374 size_t bufsiz ATTRIBUTE_UNUSED
)
376 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
378 #elif defined (__INTERIX) || defined (VMS)
380 #elif defined (__vxworks)
383 return readlink (path
, buf
, bufsiz
);
387 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH. If
388 NEWPATH exists it will NOT be overwritten. For Windows, OS/2, VxWorks,
389 Interix and VMS, always return -1. */
392 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED
,
393 char *newpath ATTRIBUTE_UNUSED
)
395 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
397 #elif defined (__INTERIX) || defined (VMS)
399 #elif defined (__vxworks)
402 return symlink (oldpath
, newpath
);
406 /* Try to lock a file, return 1 if success. */
408 #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32)
410 /* Version that does not use link. */
413 __gnat_try_lock (char *dir
, char *file
)
417 TCHAR wfull_path
[GNAT_MAX_PATH_LEN
];
418 TCHAR wfile
[GNAT_MAX_PATH_LEN
];
419 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
421 S2WS (wdir
, dir
, GNAT_MAX_PATH_LEN
);
422 S2WS (wfile
, file
, GNAT_MAX_PATH_LEN
);
424 _stprintf (wfull_path
, _T("%s%c%s"), wdir
, _T(DIR_SEPARATOR
), wfile
);
425 fd
= _topen (wfull_path
, O_CREAT
| O_EXCL
, 0600);
429 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
430 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
440 #elif defined (__EMX__) || defined (VMS)
442 /* More cases that do not use link; identical code, to solve too long
446 __gnat_try_lock (char *dir
, char *file
)
451 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
452 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
463 /* Version using link(), more secure over NFS. */
464 /* See TN 6913-016 for discussion ??? */
467 __gnat_try_lock (char *dir
, char *file
)
471 struct stat stat_result
;
474 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
475 sprintf (temp_file
, "%s%cTMP-%ld-%ld",
476 dir
, DIR_SEPARATOR
, (long)getpid(), (long)getppid ());
478 /* Create the temporary file and write the process number. */
479 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
485 /* Link it with the new file. */
486 link (temp_file
, full_path
);
488 /* Count the references on the old one. If we have a count of two, then
489 the link did succeed. Remove the temporary file before returning. */
490 __gnat_stat (temp_file
, &stat_result
);
492 return stat_result
.st_nlink
== 2;
496 /* Return the maximum file name length. */
499 __gnat_get_maximum_file_name_length (void)
504 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
513 /* Return nonzero if file names are case sensitive. */
516 __gnat_get_file_names_case_sensitive (void)
518 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT)
526 __gnat_get_default_identifier_character_set (void)
528 #if defined (__EMX__) || defined (MSDOS)
535 /* Return the current working directory. */
538 __gnat_get_current_dir (char *dir
, int *length
)
540 #if defined (__MINGW32__)
541 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
543 _tgetcwd (wdir
, *length
);
545 WS2S (dir
, wdir
, GNAT_MAX_PATH_LEN
);
548 /* Force Unix style, which is what GNAT uses internally. */
549 getcwd (dir
, *length
, 0);
551 getcwd (dir
, *length
);
554 *length
= strlen (dir
);
556 if (dir
[*length
- 1] != DIR_SEPARATOR
)
558 dir
[*length
] = DIR_SEPARATOR
;
564 /* Return the suffix for object files. */
567 __gnat_get_object_suffix_ptr (int *len
, const char **value
)
569 *value
= HOST_OBJECT_SUFFIX
;
574 *len
= strlen (*value
);
579 /* Return the suffix for executable files. */
582 __gnat_get_executable_suffix_ptr (int *len
, const char **value
)
584 *value
= HOST_EXECUTABLE_SUFFIX
;
588 *len
= strlen (*value
);
593 /* Return the suffix for debuggable files. Usually this is the same as the
594 executable extension. */
597 __gnat_get_debuggable_suffix_ptr (int *len
, const char **value
)
600 *value
= HOST_EXECUTABLE_SUFFIX
;
602 /* On DOS, the extensionless COFF file is what gdb likes. */
609 *len
= strlen (*value
);
615 __gnat_fopen (char *path
, char *mode
)
617 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE)
618 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
621 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
622 S2WS (wmode
, mode
, 10);
623 return _tfopen (wpath
, wmode
);
625 return fopen (path
, mode
);
631 __gnat_freopen (char *path
, char *mode
, FILE *stream
)
633 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE)
634 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
637 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
638 S2WS (wmode
, mode
, 10);
639 return _tfreopen (wpath
, wmode
, stream
);
641 return freopen (path
, mode
, stream
);
646 __gnat_open_read (char *path
, int fmode
)
649 int o_fmode
= O_BINARY
;
655 /* Optional arguments mbc,deq,fop increase read performance. */
656 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
657 "mbc=16", "deq=64", "fop=tef");
658 #elif defined (__vxworks)
659 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
660 #elif defined (__MINGW32__)
662 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
664 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
665 fd
= _topen (wpath
, O_RDONLY
| o_fmode
, 0444);
668 fd
= open (path
, O_RDONLY
| o_fmode
);
671 return fd
< 0 ? -1 : fd
;
674 #if defined (__EMX__) || defined (__MINGW32__)
675 #define PERM (S_IREAD | S_IWRITE)
677 /* Excerpt from DECC C RTL Reference Manual:
678 To create files with OpenVMS RMS default protections using the UNIX
679 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
680 and open with a file-protection mode argument of 0777 in a program
681 that never specifically calls umask. These default protections include
682 correctly establishing protections based on ACLs, previous versions of
686 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
690 __gnat_open_rw (char *path
, int fmode
)
693 int o_fmode
= O_BINARY
;
699 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
700 "mbc=16", "deq=64", "fop=tef");
701 #elif defined (__MINGW32__)
703 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
705 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
706 fd
= _topen (wpath
, O_RDWR
| o_fmode
, PERM
);
709 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
712 return fd
< 0 ? -1 : fd
;
716 __gnat_open_create (char *path
, int fmode
)
719 int o_fmode
= O_BINARY
;
725 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
726 "mbc=16", "deq=64", "fop=tef");
727 #elif defined (__MINGW32__)
729 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
731 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
732 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
735 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
738 return fd
< 0 ? -1 : fd
;
742 __gnat_create_output_file (char *path
)
746 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
,
747 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
748 "shr=del,get,put,upd");
749 #elif defined (__MINGW32__)
751 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
753 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
754 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
757 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
760 return fd
< 0 ? -1 : fd
;
764 __gnat_open_append (char *path
, int fmode
)
767 int o_fmode
= O_BINARY
;
773 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
774 "mbc=16", "deq=64", "fop=tef");
775 #elif defined (__MINGW32__)
777 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
779 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
780 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
783 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
786 return fd
< 0 ? -1 : fd
;
789 /* Open a new file. Return error (-1) if the file already exists. */
792 __gnat_open_new (char *path
, int fmode
)
795 int o_fmode
= O_BINARY
;
801 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
802 "mbc=16", "deq=64", "fop=tef");
803 #elif defined (__MINGW32__)
805 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
807 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
808 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
811 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
814 return fd
< 0 ? -1 : fd
;
817 /* Open a new temp file. Return error (-1) if the file already exists.
818 Special options for VMS allow the file to be shared between parent and child
819 processes, however they really slow down output. Used in gnatchop. */
822 __gnat_open_new_temp (char *path
, int fmode
)
825 int o_fmode
= O_BINARY
;
827 strcpy (path
, "GNAT-XXXXXX");
829 #if (defined (__FreeBSD__) || defined (linux)) && !defined (__vxworks)
830 return mkstemp (path
);
831 #elif defined (__Lynx__)
834 if (mktemp (path
) == NULL
)
842 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
843 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
844 "mbc=16", "deq=64", "fop=tef");
846 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
849 return fd
< 0 ? -1 : fd
;
852 /* Return the number of bytes in the specified file. */
855 __gnat_file_length (int fd
)
860 ret
= fstat (fd
, &statbuf
);
861 if (ret
|| !S_ISREG (statbuf
.st_mode
))
864 return (statbuf
.st_size
);
867 /* Return the number of bytes in the specified named file. */
870 __gnat_named_file_length (char *name
)
875 ret
= __gnat_stat (name
, &statbuf
);
876 if (ret
|| !S_ISREG (statbuf
.st_mode
))
879 return (statbuf
.st_size
);
882 /* Create a temporary filename and put it in string pointed to by
886 __gnat_tmp_name (char *tmp_filename
)
892 /* tempnam tries to create a temporary file in directory pointed to by
893 TMP environment variable, in c:\temp if TMP is not set, and in
894 directory specified by P_tmpdir in stdio.h if c:\temp does not
895 exist. The filename will be created with the prefix "gnat-". */
897 pname
= (char *) tempnam ("c:\\temp", "gnat-");
899 /* if pname is NULL, the file was not created properly, the disk is full
900 or there is no more free temporary files */
903 *tmp_filename
= '\0';
905 /* If pname start with a back slash and not path information it means that
906 the filename is valid for the current working directory. */
908 else if (pname
[0] == '\\')
910 strcpy (tmp_filename
, ".\\");
911 strcat (tmp_filename
, pname
+1);
914 strcpy (tmp_filename
, pname
);
919 #elif defined (linux) || defined (__FreeBSD__)
920 #define MAX_SAFE_PATH 1000
921 char *tmpdir
= getenv ("TMPDIR");
923 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
924 a buffer overflow. */
925 if (tmpdir
== NULL
|| strlen (tmpdir
) > MAX_SAFE_PATH
)
926 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
928 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
930 close (mkstemp(tmp_filename
));
932 tmpnam (tmp_filename
);
936 /* Open directory and returns a DIR pointer. */
938 DIR* __gnat_opendir (char *name
)
941 TCHAR wname
[GNAT_MAX_PATH_LEN
];
943 S2WS (wname
, name
, GNAT_MAX_PATH_LEN
);
944 return (DIR*)_topendir (wname
);
947 return opendir (name
);
951 /* Read the next entry in a directory. The returned string points somewhere
955 __gnat_readdir (DIR *dirp
, char *buffer
, int *len
)
957 #if defined (__MINGW32__)
958 struct _tdirent
*dirent
= _treaddir ((_TDIR
*)dirp
);
962 WS2S (buffer
, dirent
->d_name
, GNAT_MAX_PATH_LEN
);
963 *len
= strlen (buffer
);
970 #elif defined (HAVE_READDIR_R)
971 /* If possible, try to use the thread-safe version. */
972 if (readdir_r (dirp
, buffer
) != NULL
)
973 *len
= strlen (((struct dirent
*) buffer
)->d_name
);
974 return ((struct dirent
*) buffer
)->d_name
;
979 struct dirent
*dirent
= (struct dirent
*) readdir (dirp
);
983 strcpy (buffer
, dirent
->d_name
);
984 *len
= strlen (buffer
);
993 /* Close a directory entry. */
995 int __gnat_closedir (DIR *dirp
)
998 return _tclosedir ((_TDIR
*)dirp
);
1001 return closedir (dirp
);
1005 /* Returns 1 if readdir is thread safe, 0 otherwise. */
1008 __gnat_readdir_is_thread_safe (void)
1010 #ifdef HAVE_READDIR_R
1018 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
1019 static const unsigned long long w32_epoch_offset
= 11644473600ULL;
1021 /* Returns the file modification timestamp using Win32 routines which are
1022 immune against daylight saving time change. It is in fact not possible to
1023 use fstat for this purpose as the DST modify the st_mtime field of the
1027 win32_filetime (HANDLE h
)
1032 unsigned long long ull_time
;
1035 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1036 since <Jan 1st 1601>. This function must return the number of seconds
1037 since <Jan 1st 1970>. */
1039 if (GetFileTime (h
, NULL
, NULL
, &t_write
.ft_time
))
1040 return (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1045 /* Return a GNAT time stamp given a file name. */
1048 __gnat_file_time_name (char *name
)
1051 #if defined (__EMX__) || defined (MSDOS)
1052 int fd
= open (name
, O_RDONLY
| O_BINARY
);
1053 time_t ret
= __gnat_file_time_fd (fd
);
1055 return (OS_Time
)ret
;
1057 #elif defined (_WIN32)
1059 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1061 S2WS (wname
, name
, GNAT_MAX_PATH_LEN
);
1063 HANDLE h
= CreateFile
1064 (wname
, GENERIC_READ
, FILE_SHARE_READ
, 0,
1065 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
, 0);
1067 if (h
!= INVALID_HANDLE_VALUE
)
1069 ret
= win32_filetime (h
);
1072 return (OS_Time
) ret
;
1074 struct stat statbuf
;
1075 if (__gnat_stat (name
, &statbuf
) != 0) {
1079 /* VMS has file versioning. */
1080 return (OS_Time
)statbuf
.st_ctime
;
1082 return (OS_Time
)statbuf
.st_mtime
;
1088 /* Return a GNAT time stamp given a file descriptor. */
1091 __gnat_file_time_fd (int fd
)
1093 /* The following workaround code is due to the fact that under EMX and
1094 DJGPP fstat attempts to convert time values to GMT rather than keep the
1095 actual OS timestamp of the file. By using the OS2/DOS functions directly
1096 the GNAT timestamp are independent of this behavior, which is desired to
1097 facilitate the distribution of GNAT compiled libraries. */
1099 #if defined (__EMX__) || defined (MSDOS)
1103 int ret
= DosQueryFileInfo (fd
, 1, (unsigned char *) &fs
,
1104 sizeof (FILESTATUS
));
1106 unsigned file_year
= fs
.fdateLastWrite
.year
;
1107 unsigned file_month
= fs
.fdateLastWrite
.month
;
1108 unsigned file_day
= fs
.fdateLastWrite
.day
;
1109 unsigned file_hour
= fs
.ftimeLastWrite
.hours
;
1110 unsigned file_min
= fs
.ftimeLastWrite
.minutes
;
1111 unsigned file_tsec
= fs
.ftimeLastWrite
.twosecs
;
1115 int ret
= getftime (fd
, &fs
);
1117 unsigned file_year
= fs
.ft_year
;
1118 unsigned file_month
= fs
.ft_month
;
1119 unsigned file_day
= fs
.ft_day
;
1120 unsigned file_hour
= fs
.ft_hour
;
1121 unsigned file_min
= fs
.ft_min
;
1122 unsigned file_tsec
= fs
.ft_tsec
;
1125 /* Calculate the seconds since epoch from the time components. First count
1126 the whole days passed. The value for years returned by the DOS and OS2
1127 functions count years from 1980, so to compensate for the UNIX epoch which
1128 begins in 1970 start with 10 years worth of days and add days for each
1129 four year period since then. */
1132 int cum_days
[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
1133 int days_passed
= 3652 + (file_year
/ 4) * 1461;
1134 int years_since_leap
= file_year
% 4;
1136 if (years_since_leap
== 1)
1138 else if (years_since_leap
== 2)
1140 else if (years_since_leap
== 3)
1141 days_passed
+= 1096;
1146 days_passed
+= cum_days
[file_month
- 1];
1147 if (years_since_leap
== 0 && file_year
!= 20 && file_month
> 2)
1150 days_passed
+= file_day
- 1;
1152 /* OK - have whole days. Multiply -- then add in other parts. */
1154 tot_secs
= days_passed
* 86400;
1155 tot_secs
+= file_hour
* 3600;
1156 tot_secs
+= file_min
* 60;
1157 tot_secs
+= file_tsec
* 2;
1158 return (OS_Time
) tot_secs
;
1160 #elif defined (_WIN32)
1161 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
1162 time_t ret
= win32_filetime (h
);
1163 return (OS_Time
) ret
;
1166 struct stat statbuf
;
1168 if (fstat (fd
, &statbuf
) != 0) {
1169 return (OS_Time
) -1;
1172 /* VMS has file versioning. */
1173 return (OS_Time
) statbuf
.st_ctime
;
1175 return (OS_Time
) statbuf
.st_mtime
;
1181 /* Set the file time stamp. */
1184 __gnat_set_file_time_name (char *name
, time_t time_stamp
)
1186 #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1188 /* Code to implement __gnat_set_file_time_name for these systems. */
1190 #elif defined (_WIN32)
1194 unsigned long long ull_time
;
1196 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1198 S2WS (wname
, name
, GNAT_MAX_PATH_LEN
);
1200 HANDLE h
= CreateFile
1201 (wname
, GENERIC_WRITE
, FILE_SHARE_WRITE
, NULL
,
1202 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
,
1204 if (h
== INVALID_HANDLE_VALUE
)
1206 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1207 t_write
.ull_time
= ((unsigned long long)time_stamp
+ w32_epoch_offset
);
1208 /* Convert to 100 nanosecond units */
1209 t_write
.ull_time
*= 10000000ULL;
1211 SetFileTime(h
, NULL
, NULL
, &t_write
.ft_time
);
1221 unsigned long long backup
, create
, expire
, revise
;
1225 unsigned short value
;
1228 unsigned system
: 4;
1234 } Fat
= { 0, 0, 0, 0, 0, { 0 }};
1238 { ATR$S_CREDATE
, ATR$C_CREDATE
, &Fat
.create
},
1239 { ATR$S_REVDATE
, ATR$C_REVDATE
, &Fat
.revise
},
1240 { ATR$S_EXPDATE
, ATR$C_EXPDATE
, &Fat
.expire
},
1241 { ATR$S_BAKDATE
, ATR$C_BAKDATE
, &Fat
.backup
},
1242 { ATR$S_FPRO
, ATR$C_FPRO
, &Fat
.prot
},
1243 { ATR$S_UIC
, ATR$C_UIC
, &Fat
.uic
},
1248 struct dsc$descriptor_fib fibdsc
= {sizeof (fib
), (void *) &fib
};
1252 unsigned long long newtime
;
1253 unsigned long long revtime
;
1257 struct vstring file
;
1258 struct dsc$descriptor_s filedsc
1259 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) file
.string
};
1260 struct vstring device
;
1261 struct dsc$descriptor_s devicedsc
1262 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) device
.string
};
1263 struct vstring timev
;
1264 struct dsc$descriptor_s timedsc
1265 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) timev
.string
};
1266 struct vstring result
;
1267 struct dsc$descriptor_s resultdsc
1268 = {NAM$C_MAXRSS
, DSC$K_DTYPE_VT
, DSC$K_CLASS_VS
, (void *) result
.string
};
1270 /* Convert parameter name (a file spec) to host file form. Note that this
1271 is needed on VMS to prepare for subsequent calls to VMS RMS library
1272 routines. Note that it would not work to call __gnat_to_host_dir_spec
1273 as was done in a previous version, since this fails silently unless
1274 the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1275 (directory not found) condition is signalled. */
1276 tryfile
= (char *) __gnat_to_host_file_spec (name
);
1278 /* Allocate and initialize a FAB and NAM structures. */
1282 nam
.nam$l_esa
= file
.string
;
1283 nam
.nam$b_ess
= NAM$C_MAXRSS
;
1284 nam
.nam$l_rsa
= result
.string
;
1285 nam
.nam$b_rss
= NAM$C_MAXRSS
;
1286 fab
.fab$l_fna
= tryfile
;
1287 fab
.fab$b_fns
= strlen (tryfile
);
1288 fab
.fab$l_nam
= &nam
;
1290 /* Validate filespec syntax and device existence. */
1291 status
= SYS$
PARSE (&fab
, 0, 0);
1292 if ((status
& 1) != 1)
1293 LIB$
SIGNAL (status
);
1295 file
.string
[nam
.nam$b_esl
] = 0;
1297 /* Find matching filespec. */
1298 status
= SYS$
SEARCH (&fab
, 0, 0);
1299 if ((status
& 1) != 1)
1300 LIB$
SIGNAL (status
);
1302 file
.string
[nam
.nam$b_esl
] = 0;
1303 result
.string
[result
.length
=nam
.nam$b_rsl
] = 0;
1305 /* Get the device name and assign an IO channel. */
1306 strncpy (device
.string
, nam
.nam$l_dev
, nam
.nam$b_dev
);
1307 devicedsc
.dsc$w_length
= nam
.nam$b_dev
;
1309 status
= SYS$
ASSIGN (&devicedsc
, &chan
, 0, 0, 0);
1310 if ((status
& 1) != 1)
1311 LIB$
SIGNAL (status
);
1313 /* Initialize the FIB and fill in the directory id field. */
1314 memset (&fib
, 0, sizeof (fib
));
1315 fib
.fib$w_did
[0] = nam
.nam$w_did
[0];
1316 fib
.fib$w_did
[1] = nam
.nam$w_did
[1];
1317 fib
.fib$w_did
[2] = nam
.nam$w_did
[2];
1318 fib
.fib$l_acctl
= 0;
1320 strcpy (file
.string
, (strrchr (result
.string
, ']') + 1));
1321 filedsc
.dsc$w_length
= strlen (file
.string
);
1322 result
.string
[result
.length
= 0] = 0;
1324 /* Open and close the file to fill in the attributes. */
1326 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1327 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1328 if ((status
& 1) != 1)
1329 LIB$
SIGNAL (status
);
1330 if ((iosb
.status
& 1) != 1)
1331 LIB$
SIGNAL (iosb
.status
);
1333 result
.string
[result
.length
] = 0;
1334 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0, &fibdsc
, 0, 0, 0,
1336 if ((status
& 1) != 1)
1337 LIB$
SIGNAL (status
);
1338 if ((iosb
.status
& 1) != 1)
1339 LIB$
SIGNAL (iosb
.status
);
1344 /* Set creation time to requested time. */
1345 unix_time_to_vms (time_stamp
, newtime
);
1347 t
= time ((time_t) 0);
1349 /* Set revision time to now in local time. */
1350 unix_time_to_vms (t
, revtime
);
1353 /* Reopen the file, modify the times and then close. */
1354 fib
.fib$l_acctl
= FIB$M_WRITE
;
1356 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1357 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1358 if ((status
& 1) != 1)
1359 LIB$
SIGNAL (status
);
1360 if ((iosb
.status
& 1) != 1)
1361 LIB$
SIGNAL (iosb
.status
);
1363 Fat
.create
= newtime
;
1364 Fat
.revise
= revtime
;
1366 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0,
1367 &fibdsc
, 0, 0, 0, &atrlst
, 0);
1368 if ((status
& 1) != 1)
1369 LIB$
SIGNAL (status
);
1370 if ((iosb
.status
& 1) != 1)
1371 LIB$
SIGNAL (iosb
.status
);
1373 /* Deassign the channel and exit. */
1374 status
= SYS$
DASSGN (chan
);
1375 if ((status
& 1) != 1)
1376 LIB$
SIGNAL (status
);
1378 struct utimbuf utimbuf
;
1381 /* Set modification time to requested time. */
1382 utimbuf
.modtime
= time_stamp
;
1384 /* Set access time to now in local time. */
1385 t
= time ((time_t) 0);
1386 utimbuf
.actime
= mktime (localtime (&t
));
1388 utime (name
, &utimbuf
);
1393 #include <windows.h>
1396 /* Get the list of installed standard libraries from the
1397 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1401 __gnat_get_libraries_from_registry (void)
1403 char *result
= (char *) "";
1405 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE)
1408 DWORD name_size
, value_size
;
1415 /* First open the key. */
1416 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1418 if (res
== ERROR_SUCCESS
)
1419 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1420 KEY_READ
, ®_key
);
1422 if (res
== ERROR_SUCCESS
)
1423 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1425 if (res
== ERROR_SUCCESS
)
1426 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1428 /* If the key exists, read out all the values in it and concatenate them
1430 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1432 value_size
= name_size
= 256;
1433 res
= RegEnumValueA (reg_key
, index
, (TCHAR
*)name
, &name_size
, 0,
1434 &type
, (LPBYTE
)value
, &value_size
);
1436 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1438 char *old_result
= result
;
1440 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1441 strcpy (result
, old_result
);
1442 strcat (result
, value
);
1443 strcat (result
, ";");
1447 /* Remove the trailing ";". */
1449 result
[strlen (result
) - 1] = 0;
1456 __gnat_stat (char *name
, struct stat
*statbuf
)
1459 /* Under Windows the directory name for the stat function must not be
1460 terminated by a directory separator except if just after a drive name. */
1461 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
1465 S2WS (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
1466 name_len
= _tcslen (wname
);
1468 if (name_len
> GNAT_MAX_PATH_LEN
)
1471 last_char
= wname
[name_len
- 1];
1473 while (name_len
> 1 && (last_char
== _T('\\') || last_char
== _T('/')))
1475 wname
[name_len
- 1] = _T('\0');
1477 last_char
= wname
[name_len
- 1];
1480 /* Only a drive letter followed by ':', we must add a directory separator
1481 for the stat routine to work properly. */
1482 if (name_len
== 2 && wname
[1] == _T(':'))
1483 _tcscat (wname
, _T("\\"));
1485 return _tstat (wname
, statbuf
);
1488 return stat (name
, statbuf
);
1493 __gnat_file_exists (char *name
)
1495 struct stat statbuf
;
1497 return !__gnat_stat (name
, &statbuf
);
1501 __gnat_is_absolute_path (char *name
, int length
)
1503 return (length
!= 0) &&
1504 (*name
== '/' || *name
== DIR_SEPARATOR
1505 #if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
1506 || (length
> 1 && isalpha (name
[0]) && name
[1] == ':')
1512 __gnat_is_regular_file (char *name
)
1515 struct stat statbuf
;
1517 ret
= __gnat_stat (name
, &statbuf
);
1518 return (!ret
&& S_ISREG (statbuf
.st_mode
));
1522 __gnat_is_directory (char *name
)
1525 struct stat statbuf
;
1527 ret
= __gnat_stat (name
, &statbuf
);
1528 return (!ret
&& S_ISDIR (statbuf
.st_mode
));
1532 __gnat_is_readable_file (char *name
)
1536 struct stat statbuf
;
1538 ret
= __gnat_stat (name
, &statbuf
);
1539 mode
= statbuf
.st_mode
& S_IRUSR
;
1540 return (!ret
&& mode
);
1544 __gnat_is_writable_file (char *name
)
1548 struct stat statbuf
;
1550 ret
= __gnat_stat (name
, &statbuf
);
1551 mode
= statbuf
.st_mode
& S_IWUSR
;
1552 return (!ret
&& mode
);
1556 __gnat_set_writable (char *name
)
1559 struct stat statbuf
;
1561 if (stat (name
, &statbuf
) == 0)
1563 statbuf
.st_mode
= statbuf
.st_mode
| S_IWUSR
;
1564 chmod (name
, statbuf
.st_mode
);
1570 __gnat_set_executable (char *name
)
1573 struct stat statbuf
;
1575 if (stat (name
, &statbuf
) == 0)
1577 statbuf
.st_mode
= statbuf
.st_mode
| S_IXUSR
;
1578 chmod (name
, statbuf
.st_mode
);
1584 __gnat_set_readonly (char *name
)
1587 struct stat statbuf
;
1589 if (stat (name
, &statbuf
) == 0)
1591 statbuf
.st_mode
= statbuf
.st_mode
& 07577;
1592 chmod (name
, statbuf
.st_mode
);
1598 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED
)
1600 #if defined (__vxworks)
1603 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
1605 struct stat statbuf
;
1607 ret
= lstat (name
, &statbuf
);
1608 return (!ret
&& S_ISLNK (statbuf
.st_mode
));
1615 #if defined (sun) && defined (__SVR4)
1616 /* Using fork on Solaris will duplicate all the threads. fork1, which
1617 duplicates only the active thread, must be used instead, or spawning
1618 subprocess from a program with tasking will lead into numerous problems. */
1623 __gnat_portable_spawn (char *args
[])
1626 int finished ATTRIBUTE_UNUSED
;
1627 int pid ATTRIBUTE_UNUSED
;
1629 #if defined (MSDOS) || defined (_WIN32)
1630 /* args[0] must be quotes as it could contain a full pathname with spaces */
1631 char *args_0
= args
[0];
1632 args
[0] = (char *)xmalloc (strlen (args_0
) + 3);
1633 strcpy (args
[0], "\"");
1634 strcat (args
[0], args_0
);
1635 strcat (args
[0], "\"");
1637 status
= spawnvp (P_WAIT
, args_0
, (const char* const*)args
);
1639 /* restore previous value */
1641 args
[0] = (char *)args_0
;
1648 #elif defined (__vxworks)
1653 pid
= spawnvp (P_NOWAIT
, args
[0], args
);
1665 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
1667 return -1; /* execv is in parent context on VMS. */
1675 finished
= waitpid (pid
, &status
, 0);
1677 if (finished
!= pid
|| WIFEXITED (status
) == 0)
1680 return WEXITSTATUS (status
);
1686 /* Create a copy of the given file descriptor.
1687 Return -1 if an error occurred. */
1690 __gnat_dup (int oldfd
)
1692 #if defined (__vxworks) && !defined (__RTP__)
1693 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
1701 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
1702 Return -1 if an error occurred. */
1705 __gnat_dup2 (int oldfd
, int newfd
)
1707 #if defined (__vxworks) && !defined (__RTP__)
1708 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
1712 return dup2 (oldfd
, newfd
);
1716 /* WIN32 code to implement a wait call that wait for any child process. */
1720 /* Synchronization code, to be thread safe. */
1722 static CRITICAL_SECTION plist_cs
;
1725 __gnat_plist_init (void)
1727 InitializeCriticalSection (&plist_cs
);
1733 EnterCriticalSection (&plist_cs
);
1739 LeaveCriticalSection (&plist_cs
);
1742 typedef struct _process_list
1745 struct _process_list
*next
;
1748 static Process_List
*PLIST
= NULL
;
1750 static int plist_length
= 0;
1753 add_handle (HANDLE h
)
1757 pl
= (Process_List
*) xmalloc (sizeof (Process_List
));
1761 /* -------------------- critical section -------------------- */
1766 /* -------------------- critical section -------------------- */
1772 remove_handle (HANDLE h
)
1775 Process_List
*prev
= NULL
;
1779 /* -------------------- critical section -------------------- */
1788 prev
->next
= pl
->next
;
1800 /* -------------------- critical section -------------------- */
1806 win32_no_block_spawn (char *command
, char *args
[])
1810 PROCESS_INFORMATION PI
;
1811 SECURITY_ATTRIBUTES SA
;
1816 /* compute the total command line length */
1820 csize
+= strlen (args
[k
]) + 1;
1824 full_command
= (char *) xmalloc (csize
);
1827 SI
.cb
= sizeof (STARTUPINFO
);
1828 SI
.lpReserved
= NULL
;
1829 SI
.lpReserved2
= NULL
;
1830 SI
.lpDesktop
= NULL
;
1834 SI
.wShowWindow
= SW_HIDE
;
1836 /* Security attributes. */
1837 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
1838 SA
.bInheritHandle
= TRUE
;
1839 SA
.lpSecurityDescriptor
= NULL
;
1841 /* Prepare the command string. */
1842 strcpy (full_command
, command
);
1843 strcat (full_command
, " ");
1848 strcat (full_command
, args
[k
]);
1849 strcat (full_command
, " ");
1854 int wsize
= csize
* 2;
1855 TCHAR
*wcommand
= (TCHAR
*) xmalloc (wsize
);
1857 S2WS (wcommand
, full_command
, wsize
);
1859 free (full_command
);
1861 result
= CreateProcess
1862 (NULL
, wcommand
, &SA
, NULL
, TRUE
,
1863 GetPriorityClass (GetCurrentProcess()), NULL
, NULL
, &SI
, &PI
);
1870 add_handle (PI
.hProcess
);
1871 CloseHandle (PI
.hThread
);
1872 return (int) PI
.hProcess
;
1879 win32_wait (int *status
)
1888 if (plist_length
== 0)
1894 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * plist_length
);
1899 /* -------------------- critical section -------------------- */
1906 /* -------------------- critical section -------------------- */
1910 res
= WaitForMultipleObjects (plist_length
, hl
, FALSE
, INFINITE
);
1911 h
= hl
[res
- WAIT_OBJECT_0
];
1916 GetExitCodeProcess (h
, &exitcode
);
1919 *status
= (int) exitcode
;
1926 __gnat_portable_no_block_spawn (char *args
[])
1930 #if defined (__EMX__) || defined (MSDOS)
1932 /* ??? For PC machines I (Franco) don't know the system calls to implement
1933 this routine. So I'll fake it as follows. This routine will behave
1934 exactly like the blocking portable_spawn and will systematically return
1935 a pid of 0 unless the spawned task did not complete successfully, in
1936 which case we return a pid of -1. To synchronize with this the
1937 portable_wait below systematically returns a pid of 0 and reports that
1938 the subprocess terminated successfully. */
1940 if (spawnvp (P_WAIT
, args
[0], args
) != 0)
1943 #elif defined (_WIN32)
1945 pid
= win32_no_block_spawn (args
[0], args
);
1948 #elif defined (__vxworks)
1957 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
1959 return -1; /* execv is in parent context on VMS. */
1971 __gnat_portable_wait (int *process_status
)
1976 #if defined (_WIN32)
1978 pid
= win32_wait (&status
);
1980 #elif defined (__EMX__) || defined (MSDOS)
1981 /* ??? See corresponding comment in portable_no_block_spawn. */
1983 #elif defined (__vxworks)
1984 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
1988 pid
= waitpid (-1, &status
, 0);
1989 status
= status
& 0xffff;
1992 *process_status
= status
;
1997 __gnat_os_exit (int status
)
2002 /* Locate a regular file, give a Path value. */
2005 __gnat_locate_regular_file (char *file_name
, char *path_val
)
2008 char *file_path
= alloca (strlen (file_name
) + 1);
2011 /* Return immediately if file_name is empty */
2013 if (*file_name
== '\0')
2016 /* Remove quotes around file_name if present */
2022 strcpy (file_path
, ptr
);
2024 ptr
= file_path
+ strlen (file_path
) - 1;
2029 /* Handle absolute pathnames. */
2031 absolute
= __gnat_is_absolute_path (file_path
, strlen (file_name
));
2035 if (__gnat_is_regular_file (file_path
))
2036 return xstrdup (file_path
);
2041 /* If file_name include directory separator(s), try it first as
2042 a path name relative to the current directory */
2043 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
2048 if (__gnat_is_regular_file (file_name
))
2049 return xstrdup (file_name
);
2056 /* The result has to be smaller than path_val + file_name. */
2057 char *file_path
= alloca (strlen (path_val
) + strlen (file_name
) + 2);
2061 for (; *path_val
== PATH_SEPARATOR
; path_val
++)
2067 /* Skip the starting quote */
2069 if (*path_val
== '"')
2072 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
2073 *ptr
++ = *path_val
++;
2077 /* Skip the ending quote */
2082 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
2083 *++ptr
= DIR_SEPARATOR
;
2085 strcpy (++ptr
, file_name
);
2087 if (__gnat_is_regular_file (file_path
))
2088 return xstrdup (file_path
);
2095 /* Locate an executable given a Path argument. This routine is only used by
2096 gnatbl and should not be used otherwise. Use locate_exec_on_path
2100 __gnat_locate_exec (char *exec_name
, char *path_val
)
2103 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
2105 char *full_exec_name
2106 = alloca (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
2108 strcpy (full_exec_name
, exec_name
);
2109 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
2110 ptr
= __gnat_locate_regular_file (full_exec_name
, path_val
);
2113 return __gnat_locate_regular_file (exec_name
, path_val
);
2117 return __gnat_locate_regular_file (exec_name
, path_val
);
2120 /* Locate an executable using the Systems default PATH. */
2123 __gnat_locate_exec_on_path (char *exec_name
)
2128 TCHAR
*wpath_val
= _tgetenv (_T("PATH"));
2130 /* In Win32 systems we expand the PATH as for XP environment
2131 variables are not automatically expanded. We also prepend the
2132 ".;" to the path to match normal NT path search semantics */
2134 #define EXPAND_BUFFER_SIZE 32767
2136 wapath_val
= alloca (EXPAND_BUFFER_SIZE
);
2138 wapath_val
[0] = '.';
2139 wapath_val
[1] = ';';
2141 DWORD res
= ExpandEnvironmentStrings
2142 (wpath_val
, &wapath_val
[2], EXPAND_BUFFER_SIZE
- 2);
2144 if (!res
) wapath_val
[0] = _T('\0');
2146 apath_val
= alloca (EXPAND_BUFFER_SIZE
);
2148 WS2S (apath_val
, wapath_val
, EXPAND_BUFFER_SIZE
);
2149 return __gnat_locate_exec (exec_name
, apath_val
);
2154 char *path_val
= "/VAXC$PATH";
2156 char *path_val
= getenv ("PATH");
2158 if (path_val
== NULL
) return NULL
;
2159 apath_val
= alloca (strlen (path_val
) + 1);
2160 strcpy (apath_val
, path_val
);
2161 return __gnat_locate_exec (exec_name
, apath_val
);
2167 /* These functions are used to translate to and from VMS and Unix syntax
2168 file, directory and path specifications. */
2171 #define MAXNAMES 256
2172 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2174 static char new_canonical_dirspec
[MAXPATH
];
2175 static char new_canonical_filespec
[MAXPATH
];
2176 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
2177 static unsigned new_canonical_filelist_index
;
2178 static unsigned new_canonical_filelist_in_use
;
2179 static unsigned new_canonical_filelist_allocated
;
2180 static char **new_canonical_filelist
;
2181 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
2182 static char new_host_dirspec
[MAXPATH
];
2183 static char new_host_filespec
[MAXPATH
];
2185 /* Routine is called repeatedly by decc$from_vms via
2186 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2190 wildcard_translate_unix (char *name
)
2193 char buff
[MAXPATH
];
2195 strncpy (buff
, name
, MAXPATH
);
2196 buff
[MAXPATH
- 1] = (char) 0;
2197 ver
= strrchr (buff
, '.');
2199 /* Chop off the version. */
2203 /* Dynamically extend the allocation by the increment. */
2204 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
2206 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
2207 new_canonical_filelist
= (char **) xrealloc
2208 (new_canonical_filelist
,
2209 new_canonical_filelist_allocated
* sizeof (char *));
2212 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
2217 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2218 full translation and copy the results into a list (_init), then return them
2219 one at a time (_next). If onlydirs set, only expand directory files. */
2222 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
2225 char buff
[MAXPATH
];
2227 len
= strlen (filespec
);
2228 strncpy (buff
, filespec
, MAXPATH
);
2230 /* Only look for directories */
2231 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
2232 strncat (buff
, "*.dir", MAXPATH
);
2234 buff
[MAXPATH
- 1] = (char) 0;
2236 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
2238 /* Remove the .dir extension. */
2244 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
2246 ext
= strstr (new_canonical_filelist
[i
], ".dir");
2252 return new_canonical_filelist_in_use
;
2255 /* Return the next filespec in the list. */
2258 __gnat_to_canonical_file_list_next ()
2260 return new_canonical_filelist
[new_canonical_filelist_index
++];
2263 /* Free storage used in the wildcard expansion. */
2266 __gnat_to_canonical_file_list_free ()
2270 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
2271 free (new_canonical_filelist
[i
]);
2273 free (new_canonical_filelist
);
2275 new_canonical_filelist_in_use
= 0;
2276 new_canonical_filelist_allocated
= 0;
2277 new_canonical_filelist_index
= 0;
2278 new_canonical_filelist
= 0;
2281 /* Translate a VMS syntax directory specification in to Unix syntax. If
2282 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2283 found, return input string. Also translate a dirname that contains no
2284 slashes, in case it's a logical name. */
2287 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
2291 strcpy (new_canonical_dirspec
, "");
2292 if (strlen (dirspec
))
2296 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
2298 strncpy (new_canonical_dirspec
,
2299 (char *) decc$
translate_vms (dirspec
),
2302 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
2304 strncpy (new_canonical_dirspec
,
2305 (char *) decc$
translate_vms (dirspec1
),
2310 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
2314 len
= strlen (new_canonical_dirspec
);
2315 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
2316 strncat (new_canonical_dirspec
, "/", MAXPATH
);
2318 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
2320 return new_canonical_dirspec
;
2324 /* Translate a VMS syntax file specification into Unix syntax.
2325 If no indicators of VMS syntax found, check if it's an uppercase
2326 alphanumeric_ name and if so try it out as an environment
2327 variable (logical name). If all else fails return the
2331 __gnat_to_canonical_file_spec (char *filespec
)
2335 strncpy (new_canonical_filespec
, "", MAXPATH
);
2337 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
2339 char *tspec
= (char *) decc$
translate_vms (filespec
);
2341 if (tspec
!= (char *) -1)
2342 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
2344 else if ((strlen (filespec
) == strspn (filespec
,
2345 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
2346 && (filespec1
= getenv (filespec
)))
2348 char *tspec
= (char *) decc$
translate_vms (filespec1
);
2350 if (tspec
!= (char *) -1)
2351 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
2355 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
2358 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
2360 return new_canonical_filespec
;
2363 /* Translate a VMS syntax path specification into Unix syntax.
2364 If no indicators of VMS syntax found, return input string. */
2367 __gnat_to_canonical_path_spec (char *pathspec
)
2369 char *curr
, *next
, buff
[MAXPATH
];
2374 /* If there are /'s, assume it's a Unix path spec and return. */
2375 if (strchr (pathspec
, '/'))
2378 new_canonical_pathspec
[0] = 0;
2383 next
= strchr (curr
, ',');
2385 next
= strchr (curr
, 0);
2387 strncpy (buff
, curr
, next
- curr
);
2388 buff
[next
- curr
] = 0;
2390 /* Check for wildcards and expand if present. */
2391 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
2395 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
2396 for (i
= 0; i
< dirs
; i
++)
2400 next_dir
= __gnat_to_canonical_file_list_next ();
2401 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
2403 /* Don't append the separator after the last expansion. */
2405 strncat (new_canonical_pathspec
, ":", MAXPATH
);
2408 __gnat_to_canonical_file_list_free ();
2411 strncat (new_canonical_pathspec
,
2412 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
2417 strncat (new_canonical_pathspec
, ":", MAXPATH
);
2421 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
2423 return new_canonical_pathspec
;
2426 static char filename_buff
[MAXPATH
];
2429 translate_unix (char *name
, int type
)
2431 strncpy (filename_buff
, name
, MAXPATH
);
2432 filename_buff
[MAXPATH
- 1] = (char) 0;
2436 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
2440 to_host_path_spec (char *pathspec
)
2442 char *curr
, *next
, buff
[MAXPATH
];
2447 /* Can't very well test for colons, since that's the Unix separator! */
2448 if (strchr (pathspec
, ']') || strchr (pathspec
, ','))
2451 new_host_pathspec
[0] = 0;
2456 next
= strchr (curr
, ':');
2458 next
= strchr (curr
, 0);
2460 strncpy (buff
, curr
, next
- curr
);
2461 buff
[next
- curr
] = 0;
2463 strncat (new_host_pathspec
, __gnat_to_host_dir_spec (buff
, 0), MAXPATH
);
2466 strncat (new_host_pathspec
, ",", MAXPATH
);
2470 new_host_pathspec
[MAXPATH
- 1] = (char) 0;
2472 return new_host_pathspec
;
2475 /* Translate a Unix syntax directory specification into VMS syntax. The
2476 PREFIXFLAG has no effect, but is kept for symmetry with
2477 to_canonical_dir_spec. If indicators of VMS syntax found, return input
2481 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2483 int len
= strlen (dirspec
);
2485 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
2486 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
2488 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
2489 return new_host_dirspec
;
2491 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
2493 new_host_dirspec
[len
- 1] = 0;
2497 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
2498 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
2499 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
2501 return new_host_dirspec
;
2504 /* Translate a Unix syntax file specification into VMS syntax.
2505 If indicators of VMS syntax found, return input string. */
2508 __gnat_to_host_file_spec (char *filespec
)
2510 strncpy (new_host_filespec
, "", MAXPATH
);
2511 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
2513 strncpy (new_host_filespec
, filespec
, MAXPATH
);
2517 decc$
to_vms (filespec
, translate_unix
, 1, 1);
2518 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
2521 new_host_filespec
[MAXPATH
- 1] = (char) 0;
2523 return new_host_filespec
;
2527 __gnat_adjust_os_resource_limits ()
2529 SYS$
ADJWSL (131072, 0);
2534 /* Dummy functions for Osint import for non-VMS systems. */
2537 __gnat_to_canonical_file_list_init
2538 (char *dirspec ATTRIBUTE_UNUSED
, int onlydirs ATTRIBUTE_UNUSED
)
2544 __gnat_to_canonical_file_list_next (void)
2550 __gnat_to_canonical_file_list_free (void)
2555 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2561 __gnat_to_canonical_file_spec (char *filespec
)
2567 __gnat_to_canonical_path_spec (char *pathspec
)
2573 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2579 __gnat_to_host_file_spec (char *filespec
)
2585 __gnat_adjust_os_resource_limits (void)
2591 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
2592 to coordinate this with the EMX distribution. Consequently, we put the
2593 definition of dummy which is used for exception handling, here. */
2595 #if defined (__EMX__)
2599 #if defined (__mips_vxworks)
2603 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
2607 #if defined (CROSS_DIRECTORY_STRUCTURE) \
2608 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
2609 && defined (__SVR4)) \
2610 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
2611 && ! (defined (linux) && defined (__ia64__)) \
2612 && ! defined (__FreeBSD__) \
2613 && ! defined (__hpux__) \
2614 && ! defined (__APPLE__) \
2615 && ! defined (_AIX) \
2616 && ! (defined (__alpha__) && defined (__osf__)) \
2617 && ! defined (VMS) \
2618 && ! defined (__MINGW32__) \
2619 && ! (defined (__mips) && defined (__sgi)))
2621 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
2622 just above for a list of native platforms that provide a non-dummy
2623 version of this procedure in libaddr2line.a. */
2626 convert_addresses (void *addrs ATTRIBUTE_UNUSED
,
2627 int n_addr ATTRIBUTE_UNUSED
,
2628 void *buf ATTRIBUTE_UNUSED
,
2629 int *len ATTRIBUTE_UNUSED
)
2635 #if defined (_WIN32)
2636 int __gnat_argument_needs_quote
= 1;
2638 int __gnat_argument_needs_quote
= 0;
2641 /* This option is used to enable/disable object files handling from the
2642 binder file by the GNAT Project module. For example, this is disabled on
2643 Windows (prior to GCC 3.4) as it is already done by the mdll module.
2644 Stating with GCC 3.4 the shared libraries are not based on mdll
2645 anymore as it uses the GCC's -shared option */
2646 #if defined (_WIN32) \
2647 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
2648 int __gnat_prj_add_obj_files
= 0;
2650 int __gnat_prj_add_obj_files
= 1;
2653 /* char used as prefix/suffix for environment variables */
2654 #if defined (_WIN32)
2655 char __gnat_environment_char
= '%';
2657 char __gnat_environment_char
= '$';
2660 /* This functions copy the file attributes from a source file to a
2663 mode = 0 : In this mode copy only the file time stamps (last access and
2664 last modification time stamps).
2666 mode = 1 : In this mode, time stamps and read/write/execute attributes are
2669 Returns 0 if operation was successful and -1 in case of error. */
2672 __gnat_copy_attribs (char *from
, char *to
, int mode
)
2674 #if defined (VMS) || defined (__vxworks)
2678 struct utimbuf tbuf
;
2680 if (stat (from
, &fbuf
) == -1)
2685 tbuf
.actime
= fbuf
.st_atime
;
2686 tbuf
.modtime
= fbuf
.st_mtime
;
2688 if (utime (to
, &tbuf
) == -1)
2695 if (chmod (to
, fbuf
.st_mode
) == -1)
2706 __gnat_lseek (int fd
, long offset
, int whence
)
2708 return (int) lseek (fd
, offset
, whence
);
2711 /* This function returns the major version number of GCC being used. */
2713 get_gcc_version (void)
2718 return (int) (version_string
[0] - '0');
2723 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED
,
2724 int close_on_exec_p ATTRIBUTE_UNUSED
)
2726 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
2727 int flags
= fcntl (fd
, F_GETFD
, 0);
2730 if (close_on_exec_p
)
2731 flags
|= FD_CLOEXEC
;
2733 flags
&= ~FD_CLOEXEC
;
2734 return fcntl (fd
, F_SETFD
, flags
| FD_CLOEXEC
);
2737 /* For the Windows case, we should use SetHandleInformation to remove
2738 the HANDLE_INHERIT property from fd. This is not implemented yet,
2739 but for our purposes (support of GNAT.Expect) this does not matter,
2740 as by default handles are *not* inherited. */
2744 /* Indicates if platforms supports automatic initialization through the
2745 constructor mechanism */
2747 __gnat_binder_supports_auto_init ()
2756 /* Indicates that Stand-Alone Libraries are automatically initialized through
2757 the constructor mechanism */
2759 __gnat_sals_init_using_constructors ()
2761 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)