1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2004, 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, 59 Temple Place - Suite 330, Boston, *
20 * MA 02111-1307, 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 */
68 /* We don't have libiberty, so use malloc. */
69 #define xmalloc(S) malloc (S)
70 #define xrealloc(V,S) realloc (V,S)
78 #include <sys/utime.h>
94 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
97 /* Header files and definitions for __gnat_set_file_time_name. */
109 /* Use native 64-bit arithmetic. */
110 #define unix_time_to_vms(X,Y) \
111 { unsigned long long reftime, tmptime = (X); \
112 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
113 SYS$BINTIM (&unixtime, &reftime); \
114 Y = tmptime * 10000000 + reftime; }
116 /* descrip.h doesn't have everything ... */
117 struct dsc$descriptor_fib
119 unsigned long fib$l_len
;
120 struct fibdef
*fib$l_addr
;
123 /* I/O Status Block. */
126 unsigned short status
, count
;
127 unsigned long devdep
;
130 static char *tryfile
;
132 /* Variable length string. */
136 char string
[NAM$C_MAXRSS
+1];
143 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
151 #define DIR_SEPARATOR '\\'
156 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
157 defined in the current system. On DOS-like systems these flags control
158 whether the file is opened/created in text-translation mode (CR/LF in
159 external file mapped to LF in internal file), but in Unix-like systems,
160 no text translation is required, so these flags have no effect. */
162 #if defined (__EMX__)
178 #ifndef HOST_EXECUTABLE_SUFFIX
179 #define HOST_EXECUTABLE_SUFFIX ""
182 #ifndef HOST_OBJECT_SUFFIX
183 #define HOST_OBJECT_SUFFIX ".o"
186 #ifndef PATH_SEPARATOR
187 #define PATH_SEPARATOR ':'
190 #ifndef DIR_SEPARATOR
191 #define DIR_SEPARATOR '/'
194 char __gnat_dir_separator
= DIR_SEPARATOR
;
196 char __gnat_path_separator
= PATH_SEPARATOR
;
198 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
199 the base filenames that libraries specified with -lsomelib options
200 may have. This is used by GNATMAKE to check whether an executable
201 is up-to-date or not. The syntax is
203 library_template ::= { pattern ; } pattern NUL
204 pattern ::= [ prefix ] * [ postfix ]
206 These should only specify names of static libraries as it makes
207 no sense to determine at link time if dynamic-link libraries are
208 up to date or not. Any libraries that are not found are supposed
211 * if they are needed but not present, the link
214 * otherwise they are libraries in the system paths and so
215 they are considered part of the system and not checked
218 ??? This should be part of a GNAT host-specific compiler
219 file instead of being included in all user applications
220 as well. This is only a temporary work-around for 3.11b. */
222 #ifndef GNAT_LIBRARY_TEMPLATE
223 #if defined (__EMX__)
224 #define GNAT_LIBRARY_TEMPLATE "*.a"
226 #define GNAT_LIBRARY_TEMPLATE "*.olb"
228 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
232 const char *__gnat_library_template
= GNAT_LIBRARY_TEMPLATE
;
234 /* This variable is used in hostparm.ads to say whether the host is a VMS
237 const int __gnat_vmsp
= 1;
239 const int __gnat_vmsp
= 0;
243 #define GNAT_MAX_PATH_LEN MAX_PATH
246 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
248 #elif defined (__vxworks) || defined (__OPENNT)
249 #define GNAT_MAX_PATH_LEN PATH_MAX
253 #if defined (__MINGW32__)
257 #include <sys/param.h>
261 #include <sys/param.h>
264 #define GNAT_MAX_PATH_LEN MAXPATHLEN
268 /* The __gnat_max_path_len variable is used to export the maximum
269 length of a path name to Ada code. max_path_len is also provided
270 for compatibility with older GNAT versions, please do not use
273 int __gnat_max_path_len
= GNAT_MAX_PATH_LEN
;
274 int max_path_len
= GNAT_MAX_PATH_LEN
;
276 /* The following macro HAVE_READDIR_R should be defined if the
277 system provides the routine readdir_r. */
278 #undef HAVE_READDIR_R
291 time_t time
= (time_t) *p_time
;
294 /* On Windows systems, the time is sometimes rounded up to the nearest
295 even second, so if the number of seconds is odd, increment it. */
301 res
= localtime (&time
);
303 res
= gmtime (&time
);
308 *p_year
= res
->tm_year
;
309 *p_month
= res
->tm_mon
;
310 *p_day
= res
->tm_mday
;
311 *p_hours
= res
->tm_hour
;
312 *p_mins
= res
->tm_min
;
313 *p_secs
= res
->tm_sec
;
316 *p_year
= *p_month
= *p_day
= *p_hours
= *p_mins
= *p_secs
= 0;
319 /* Place the contents of the symbolic link named PATH in the buffer BUF,
320 which has size BUFSIZ. If PATH is a symbolic link, then return the number
321 of characters of its content in BUF. Otherwise, return -1. For Windows,
322 OS/2 and vxworks, always return -1. */
325 __gnat_readlink (char *path ATTRIBUTE_UNUSED
,
326 char *buf ATTRIBUTE_UNUSED
,
327 size_t bufsiz ATTRIBUTE_UNUSED
)
329 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
331 #elif defined (__INTERIX) || defined (VMS)
333 #elif defined (__vxworks)
336 return readlink (path
, buf
, bufsiz
);
340 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH. If
341 NEWPATH exists it will NOT be overwritten. For Windows, OS/2, VxWorks,
342 Interix and VMS, always return -1. */
345 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED
,
346 char *newpath ATTRIBUTE_UNUSED
)
348 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
350 #elif defined (__INTERIX) || defined (VMS)
352 #elif defined (__vxworks)
355 return symlink (oldpath
, newpath
);
359 /* Try to lock a file, return 1 if success. */
361 #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32)
363 /* Version that does not use link. */
366 __gnat_try_lock (char *dir
, char *file
)
371 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
372 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
380 #elif defined (__EMX__) || defined (VMS)
382 /* More cases that do not use link; identical code, to solve too long
386 __gnat_try_lock (char *dir
, char *file
)
391 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
392 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
402 /* Version using link(), more secure over NFS. */
403 /* See TN 6913-016 for discussion ??? */
406 __gnat_try_lock (char *dir
, char *file
)
410 struct stat stat_result
;
413 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
414 sprintf (temp_file
, "%s%cTMP-%ld-%ld",
415 dir
, DIR_SEPARATOR
, (long)getpid(), (long)getppid ());
417 /* Create the temporary file and write the process number. */
418 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
424 /* Link it with the new file. */
425 link (temp_file
, full_path
);
427 /* Count the references on the old one. If we have a count of two, then
428 the link did succeed. Remove the temporary file before returning. */
429 __gnat_stat (temp_file
, &stat_result
);
431 return stat_result
.st_nlink
== 2;
435 /* Return the maximum file name length. */
438 __gnat_get_maximum_file_name_length (void)
443 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
452 /* Return nonzero if file names are case sensitive. */
455 __gnat_get_file_names_case_sensitive (void)
457 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT)
465 __gnat_get_default_identifier_character_set (void)
467 #if defined (__EMX__) || defined (MSDOS)
474 /* Return the current working directory. */
477 __gnat_get_current_dir (char *dir
, int *length
)
480 /* Force Unix style, which is what GNAT uses internally. */
481 getcwd (dir
, *length
, 0);
483 getcwd (dir
, *length
);
486 *length
= strlen (dir
);
488 if (dir
[*length
- 1] != DIR_SEPARATOR
)
490 dir
[*length
] = DIR_SEPARATOR
;
496 /* Return the suffix for object files. */
499 __gnat_get_object_suffix_ptr (int *len
, const char **value
)
501 *value
= HOST_OBJECT_SUFFIX
;
506 *len
= strlen (*value
);
511 /* Return the suffix for executable files. */
514 __gnat_get_executable_suffix_ptr (int *len
, const char **value
)
516 *value
= HOST_EXECUTABLE_SUFFIX
;
520 *len
= strlen (*value
);
525 /* Return the suffix for debuggable files. Usually this is the same as the
526 executable extension. */
529 __gnat_get_debuggable_suffix_ptr (int *len
, const char **value
)
532 *value
= HOST_EXECUTABLE_SUFFIX
;
534 /* On DOS, the extensionless COFF file is what gdb likes. */
541 *len
= strlen (*value
);
547 __gnat_open_read (char *path
, int fmode
)
550 int o_fmode
= O_BINARY
;
556 /* Optional arguments mbc,deq,fop increase read performance. */
557 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
558 "mbc=16", "deq=64", "fop=tef");
559 #elif defined (__vxworks)
560 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
562 fd
= open (path
, O_RDONLY
| o_fmode
);
565 return fd
< 0 ? -1 : fd
;
568 #if defined (__EMX__) || defined (__MINGW32__)
569 #define PERM (S_IREAD | S_IWRITE)
571 /* Excerpt from DECC C RTL Reference Manual:
572 To create files with OpenVMS RMS default protections using the UNIX
573 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
574 and open with a file-protection mode argument of 0777 in a program
575 that never specifically calls umask. These default protections include
576 correctly establishing protections based on ACLs, previous versions of
580 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
584 __gnat_open_rw (char *path
, int fmode
)
587 int o_fmode
= O_BINARY
;
593 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
594 "mbc=16", "deq=64", "fop=tef");
596 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
599 return fd
< 0 ? -1 : fd
;
603 __gnat_open_create (char *path
, int fmode
)
606 int o_fmode
= O_BINARY
;
612 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
613 "mbc=16", "deq=64", "fop=tef");
615 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
618 return fd
< 0 ? -1 : fd
;
622 __gnat_create_output_file (char *path
)
626 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
,
627 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
628 "shr=del,get,put,upd");
630 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
633 return fd
< 0 ? -1 : fd
;
637 __gnat_open_append (char *path
, int fmode
)
640 int o_fmode
= O_BINARY
;
646 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
647 "mbc=16", "deq=64", "fop=tef");
649 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
652 return fd
< 0 ? -1 : fd
;
655 /* Open a new file. Return error (-1) if the file already exists. */
658 __gnat_open_new (char *path
, int fmode
)
661 int o_fmode
= O_BINARY
;
667 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
668 "mbc=16", "deq=64", "fop=tef");
670 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
673 return fd
< 0 ? -1 : fd
;
676 /* Open a new temp file. Return error (-1) if the file already exists.
677 Special options for VMS allow the file to be shared between parent and child
678 processes, however they really slow down output. Used in gnatchop. */
681 __gnat_open_new_temp (char *path
, int fmode
)
684 int o_fmode
= O_BINARY
;
686 strcpy (path
, "GNAT-XXXXXX");
688 #if (defined (__FreeBSD__) || defined (linux)) && !defined (__vxworks)
689 return mkstemp (path
);
690 #elif defined (__Lynx__)
693 if (mktemp (path
) == NULL
)
701 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
702 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
703 "mbc=16", "deq=64", "fop=tef");
705 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
708 return fd
< 0 ? -1 : fd
;
711 /* Return the number of bytes in the specified file. */
714 __gnat_file_length (int fd
)
719 ret
= fstat (fd
, &statbuf
);
720 if (ret
|| !S_ISREG (statbuf
.st_mode
))
723 return (statbuf
.st_size
);
726 /* Return the number of bytes in the specified named file. */
729 __gnat_named_file_length (char *name
)
734 ret
= __gnat_stat (name
, &statbuf
);
735 if (ret
|| !S_ISREG (statbuf
.st_mode
))
738 return (statbuf
.st_size
);
741 /* Create a temporary filename and put it in string pointed to by
745 __gnat_tmp_name (char *tmp_filename
)
751 /* tempnam tries to create a temporary file in directory pointed to by
752 TMP environment variable, in c:\temp if TMP is not set, and in
753 directory specified by P_tmpdir in stdio.h if c:\temp does not
754 exist. The filename will be created with the prefix "gnat-". */
756 pname
= (char *) tempnam ("c:\\temp", "gnat-");
758 /* if pname is NULL, the file was not created properly, the disk is full
759 or there is no more free temporary files */
762 *tmp_filename
= '\0';
764 /* If pname start with a back slash and not path information it means that
765 the filename is valid for the current working directory. */
767 else if (pname
[0] == '\\')
769 strcpy (tmp_filename
, ".\\");
770 strcat (tmp_filename
, pname
+1);
773 strcpy (tmp_filename
, pname
);
778 #elif defined (linux) || defined (__FreeBSD__)
779 #define MAX_SAFE_PATH 1000
780 char *tmpdir
= getenv ("TMPDIR");
782 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
783 a buffer overflow. */
784 if (tmpdir
== NULL
|| strlen (tmpdir
) > MAX_SAFE_PATH
)
785 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
787 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
789 close (mkstemp(tmp_filename
));
791 tmpnam (tmp_filename
);
795 /* Read the next entry in a directory. The returned string points somewhere
799 __gnat_readdir (DIR *dirp
, char *buffer
)
801 /* If possible, try to use the thread-safe version. */
802 #ifdef HAVE_READDIR_R
803 if (readdir_r (dirp
, buffer
) != NULL
)
804 return ((struct dirent
*) buffer
)->d_name
;
809 struct dirent
*dirent
= (struct dirent
*) readdir (dirp
);
813 strcpy (buffer
, dirent
->d_name
);
822 /* Returns 1 if readdir is thread safe, 0 otherwise. */
825 __gnat_readdir_is_thread_safe (void)
827 #ifdef HAVE_READDIR_R
835 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
836 static const unsigned long long w32_epoch_offset
= 11644473600ULL;
838 /* Returns the file modification timestamp using Win32 routines which are
839 immune against daylight saving time change. It is in fact not possible to
840 use fstat for this purpose as the DST modify the st_mtime field of the
844 win32_filetime (HANDLE h
)
849 unsigned long long ull_time
;
852 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
853 since <Jan 1st 1601>. This function must return the number of seconds
854 since <Jan 1st 1970>. */
856 if (GetFileTime (h
, NULL
, NULL
, &t_write
.ft_time
))
857 return (time_t) (t_write
.ull_time
/ 10000000ULL
863 /* Return a GNAT time stamp given a file name. */
866 __gnat_file_time_name (char *name
)
869 #if defined (__EMX__) || defined (MSDOS)
870 int fd
= open (name
, O_RDONLY
| O_BINARY
);
871 time_t ret
= __gnat_file_time_fd (fd
);
875 #elif defined (_WIN32)
877 HANDLE h
= CreateFile (name
, GENERIC_READ
, FILE_SHARE_READ
, 0,
878 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
, 0);
880 if (h
!= INVALID_HANDLE_VALUE
)
882 ret
= win32_filetime (h
);
885 return (OS_Time
) ret
;
888 if (__gnat_stat (name
, &statbuf
) != 0) {
892 /* VMS has file versioning. */
893 return (OS_Time
)statbuf
.st_ctime
;
895 return (OS_Time
)statbuf
.st_mtime
;
901 /* Return a GNAT time stamp given a file descriptor. */
904 __gnat_file_time_fd (int fd
)
906 /* The following workaround code is due to the fact that under EMX and
907 DJGPP fstat attempts to convert time values to GMT rather than keep the
908 actual OS timestamp of the file. By using the OS2/DOS functions directly
909 the GNAT timestamp are independent of this behavior, which is desired to
910 facilitate the distribution of GNAT compiled libraries. */
912 #if defined (__EMX__) || defined (MSDOS)
916 int ret
= DosQueryFileInfo (fd
, 1, (unsigned char *) &fs
,
917 sizeof (FILESTATUS
));
919 unsigned file_year
= fs
.fdateLastWrite
.year
;
920 unsigned file_month
= fs
.fdateLastWrite
.month
;
921 unsigned file_day
= fs
.fdateLastWrite
.day
;
922 unsigned file_hour
= fs
.ftimeLastWrite
.hours
;
923 unsigned file_min
= fs
.ftimeLastWrite
.minutes
;
924 unsigned file_tsec
= fs
.ftimeLastWrite
.twosecs
;
928 int ret
= getftime (fd
, &fs
);
930 unsigned file_year
= fs
.ft_year
;
931 unsigned file_month
= fs
.ft_month
;
932 unsigned file_day
= fs
.ft_day
;
933 unsigned file_hour
= fs
.ft_hour
;
934 unsigned file_min
= fs
.ft_min
;
935 unsigned file_tsec
= fs
.ft_tsec
;
938 /* Calculate the seconds since epoch from the time components. First count
939 the whole days passed. The value for years returned by the DOS and OS2
940 functions count years from 1980, so to compensate for the UNIX epoch which
941 begins in 1970 start with 10 years worth of days and add days for each
942 four year period since then. */
945 int cum_days
[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
946 int days_passed
= 3652 + (file_year
/ 4) * 1461;
947 int years_since_leap
= file_year
% 4;
949 if (years_since_leap
== 1)
951 else if (years_since_leap
== 2)
953 else if (years_since_leap
== 3)
959 days_passed
+= cum_days
[file_month
- 1];
960 if (years_since_leap
== 0 && file_year
!= 20 && file_month
> 2)
963 days_passed
+= file_day
- 1;
965 /* OK - have whole days. Multiply -- then add in other parts. */
967 tot_secs
= days_passed
* 86400;
968 tot_secs
+= file_hour
* 3600;
969 tot_secs
+= file_min
* 60;
970 tot_secs
+= file_tsec
* 2;
971 return (OS_Time
) tot_secs
;
973 #elif defined (_WIN32)
974 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
975 time_t ret
= win32_filetime (h
);
976 return (OS_Time
) ret
;
981 if (fstat (fd
, &statbuf
) != 0) {
985 /* VMS has file versioning. */
986 return (OS_Time
) statbuf
.st_ctime
;
988 return (OS_Time
) statbuf
.st_mtime
;
994 /* Set the file time stamp. */
997 __gnat_set_file_time_name (char *name
, time_t time_stamp
)
999 #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1001 /* Code to implement __gnat_set_file_time_name for these systems. */
1003 #elif defined (_WIN32)
1007 unsigned long long ull_time
;
1010 HANDLE h
= CreateFile (name
, GENERIC_WRITE
, FILE_SHARE_WRITE
, NULL
,
1011 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
,
1013 if (h
== INVALID_HANDLE_VALUE
)
1015 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1016 t_write
.ull_time
= ((unsigned long long)time_stamp
+ w32_epoch_offset
);
1017 /* Convert to 100 nanosecond units */
1018 t_write
.ull_time
*= 10000000ULL;
1020 SetFileTime(h
, NULL
, NULL
, &t_write
.ft_time
);
1030 unsigned long long backup
, create
, expire
, revise
;
1034 unsigned short value
;
1037 unsigned system
: 4;
1043 } Fat
= { 0, 0, 0, 0, 0, { 0 }};
1047 { ATR$S_CREDATE
, ATR$C_CREDATE
, &Fat
.create
},
1048 { ATR$S_REVDATE
, ATR$C_REVDATE
, &Fat
.revise
},
1049 { ATR$S_EXPDATE
, ATR$C_EXPDATE
, &Fat
.expire
},
1050 { ATR$S_BAKDATE
, ATR$C_BAKDATE
, &Fat
.backup
},
1051 { ATR$S_FPRO
, ATR$C_FPRO
, &Fat
.prot
},
1052 { ATR$S_UIC
, ATR$C_UIC
, &Fat
.uic
},
1057 struct dsc$descriptor_fib fibdsc
= {sizeof (fib
), (void *) &fib
};
1061 unsigned long long newtime
;
1062 unsigned long long revtime
;
1066 struct vstring file
;
1067 struct dsc$descriptor_s filedsc
1068 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) file
.string
};
1069 struct vstring device
;
1070 struct dsc$descriptor_s devicedsc
1071 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) device
.string
};
1072 struct vstring timev
;
1073 struct dsc$descriptor_s timedsc
1074 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) timev
.string
};
1075 struct vstring result
;
1076 struct dsc$descriptor_s resultdsc
1077 = {NAM$C_MAXRSS
, DSC$K_DTYPE_VT
, DSC$K_CLASS_VS
, (void *) result
.string
};
1079 tryfile
= (char *) __gnat_to_host_dir_spec (name
, 0);
1081 /* Allocate and initialize a FAB and NAM structures. */
1085 nam
.nam$l_esa
= file
.string
;
1086 nam
.nam$b_ess
= NAM$C_MAXRSS
;
1087 nam
.nam$l_rsa
= result
.string
;
1088 nam
.nam$b_rss
= NAM$C_MAXRSS
;
1089 fab
.fab$l_fna
= tryfile
;
1090 fab
.fab$b_fns
= strlen (tryfile
);
1091 fab
.fab$l_nam
= &nam
;
1093 /* Validate filespec syntax and device existence. */
1094 status
= SYS$
PARSE (&fab
, 0, 0);
1095 if ((status
& 1) != 1)
1096 LIB$
SIGNAL (status
);
1098 file
.string
[nam
.nam$b_esl
] = 0;
1100 /* Find matching filespec. */
1101 status
= SYS$
SEARCH (&fab
, 0, 0);
1102 if ((status
& 1) != 1)
1103 LIB$
SIGNAL (status
);
1105 file
.string
[nam
.nam$b_esl
] = 0;
1106 result
.string
[result
.length
=nam
.nam$b_rsl
] = 0;
1108 /* Get the device name and assign an IO channel. */
1109 strncpy (device
.string
, nam
.nam$l_dev
, nam
.nam$b_dev
);
1110 devicedsc
.dsc$w_length
= nam
.nam$b_dev
;
1112 status
= SYS$
ASSIGN (&devicedsc
, &chan
, 0, 0, 0);
1113 if ((status
& 1) != 1)
1114 LIB$
SIGNAL (status
);
1116 /* Initialize the FIB and fill in the directory id field. */
1117 memset (&fib
, 0, sizeof (fib
));
1118 fib
.fib$w_did
[0] = nam
.nam$w_did
[0];
1119 fib
.fib$w_did
[1] = nam
.nam$w_did
[1];
1120 fib
.fib$w_did
[2] = nam
.nam$w_did
[2];
1121 fib
.fib$l_acctl
= 0;
1123 strcpy (file
.string
, (strrchr (result
.string
, ']') + 1));
1124 filedsc
.dsc$w_length
= strlen (file
.string
);
1125 result
.string
[result
.length
= 0] = 0;
1127 /* Open and close the file to fill in the attributes. */
1129 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1130 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1131 if ((status
& 1) != 1)
1132 LIB$
SIGNAL (status
);
1133 if ((iosb
.status
& 1) != 1)
1134 LIB$
SIGNAL (iosb
.status
);
1136 result
.string
[result
.length
] = 0;
1137 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0, &fibdsc
, 0, 0, 0,
1139 if ((status
& 1) != 1)
1140 LIB$
SIGNAL (status
);
1141 if ((iosb
.status
& 1) != 1)
1142 LIB$
SIGNAL (iosb
.status
);
1147 /* Set creation time to requested time. */
1148 unix_time_to_vms (time_stamp
, newtime
);
1150 t
= time ((time_t) 0);
1152 /* Set revision time to now in local time. */
1153 unix_time_to_vms (t
, revtime
);
1156 /* Reopen the file, modify the times and then close. */
1157 fib
.fib$l_acctl
= FIB$M_WRITE
;
1159 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1160 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1161 if ((status
& 1) != 1)
1162 LIB$
SIGNAL (status
);
1163 if ((iosb
.status
& 1) != 1)
1164 LIB$
SIGNAL (iosb
.status
);
1166 Fat
.create
= newtime
;
1167 Fat
.revise
= revtime
;
1169 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0,
1170 &fibdsc
, 0, 0, 0, &atrlst
, 0);
1171 if ((status
& 1) != 1)
1172 LIB$
SIGNAL (status
);
1173 if ((iosb
.status
& 1) != 1)
1174 LIB$
SIGNAL (iosb
.status
);
1176 /* Deassign the channel and exit. */
1177 status
= SYS$
DASSGN (chan
);
1178 if ((status
& 1) != 1)
1179 LIB$
SIGNAL (status
);
1181 struct utimbuf utimbuf
;
1184 /* Set modification time to requested time. */
1185 utimbuf
.modtime
= time_stamp
;
1187 /* Set access time to now in local time. */
1188 t
= time ((time_t) 0);
1189 utimbuf
.actime
= mktime (localtime (&t
));
1191 utime (name
, &utimbuf
);
1196 __gnat_get_env_value_ptr (char *name
, int *len
, char **value
)
1198 *value
= getenv (name
);
1202 *len
= strlen (*value
);
1207 /* VMS specific declarations for set_env_value. */
1211 static char *to_host_path_spec (char *);
1215 unsigned short len
, mbz
;
1219 typedef struct _ile3
1221 unsigned short len
, code
;
1223 unsigned short *retlen_adr
;
1229 __gnat_set_env_value (char *name
, char *value
)
1234 struct descriptor_s name_desc
;
1235 /* Put in JOB table for now, so that the project stuff at least works. */
1236 struct descriptor_s table_desc
= {7, 0, "LNM$JOB"};
1237 char *host_pathspec
= value
;
1238 char *copy_pathspec
;
1239 int num_dirs_in_pathspec
= 1;
1243 name_desc
.len
= strlen (name
);
1245 name_desc
.adr
= name
;
1247 if (*host_pathspec
== 0)
1250 status
= LIB$
DELETE_LOGICAL (&name_desc
, &table_desc
);
1251 /* no need to check status; if the logical name is not
1252 defined, that's fine. */
1256 ptr
= host_pathspec
;
1259 num_dirs_in_pathspec
++;
1263 ile_s
*ile_array
= alloca (sizeof (ile_s
) * (num_dirs_in_pathspec
+ 1));
1264 char *copy_pathspec
= alloca (strlen (host_pathspec
) + 1);
1267 strcpy (copy_pathspec
, host_pathspec
);
1268 curr
= copy_pathspec
;
1269 for (i
= 0; i
< num_dirs_in_pathspec
; i
++)
1271 next
= strchr (curr
, ',');
1273 next
= strchr (curr
, 0);
1276 ile_array
[i
].len
= strlen (curr
);
1278 /* Code 2 from lnmdef.h means its a string. */
1279 ile_array
[i
].code
= 2;
1280 ile_array
[i
].adr
= curr
;
1282 /* retlen_adr is ignored. */
1283 ile_array
[i
].retlen_adr
= 0;
1287 /* Terminating item must be zero. */
1288 ile_array
[i
].len
= 0;
1289 ile_array
[i
].code
= 0;
1290 ile_array
[i
].adr
= 0;
1291 ile_array
[i
].retlen_adr
= 0;
1293 status
= LIB$
SET_LOGICAL (&name_desc
, 0, &table_desc
, 0, ile_array
);
1294 if ((status
& 1) != 1)
1295 LIB$
SIGNAL (status
);
1299 int size
= strlen (name
) + strlen (value
) + 2;
1302 expression
= (char *) xmalloc (size
* sizeof (char));
1304 sprintf (expression
, "%s=%s", name
, value
);
1305 putenv (expression
);
1310 #include <windows.h>
1313 /* Get the list of installed standard libraries from the
1314 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1318 __gnat_get_libraries_from_registry (void)
1320 char *result
= (char *) "";
1322 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_COMPILE)
1325 DWORD name_size
, value_size
;
1332 /* First open the key. */
1333 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1335 if (res
== ERROR_SUCCESS
)
1336 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1337 KEY_READ
, ®_key
);
1339 if (res
== ERROR_SUCCESS
)
1340 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1342 if (res
== ERROR_SUCCESS
)
1343 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1345 /* If the key exists, read out all the values in it and concatenate them
1347 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1349 value_size
= name_size
= 256;
1350 res
= RegEnumValue (reg_key
, index
, name
, &name_size
, 0,
1351 &type
, (LPBYTE
)value
, &value_size
);
1353 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1355 char *old_result
= result
;
1357 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1358 strcpy (result
, old_result
);
1359 strcat (result
, value
);
1360 strcat (result
, ";");
1364 /* Remove the trailing ";". */
1366 result
[strlen (result
) - 1] = 0;
1373 __gnat_stat (char *name
, struct stat
*statbuf
)
1376 /* Under Windows the directory name for the stat function must not be
1377 terminated by a directory separator except if just after a drive name. */
1378 int name_len
= strlen (name
);
1379 char last_char
= name
[name_len
- 1];
1380 char win32_name
[GNAT_MAX_PATH_LEN
+ 2];
1382 if (name_len
> GNAT_MAX_PATH_LEN
)
1385 strcpy (win32_name
, name
);
1387 while (name_len
> 1 && (last_char
== '\\' || last_char
== '/'))
1389 win32_name
[name_len
- 1] = '\0';
1391 last_char
= win32_name
[name_len
- 1];
1394 if (name_len
== 2 && win32_name
[1] == ':')
1395 strcat (win32_name
, "\\");
1397 return stat (win32_name
, statbuf
);
1400 return stat (name
, statbuf
);
1405 __gnat_file_exists (char *name
)
1407 struct stat statbuf
;
1409 return !__gnat_stat (name
, &statbuf
);
1413 __gnat_is_absolute_path (char *name
, int length
)
1415 return (length
!= 0) &&
1416 (*name
== '/' || *name
== DIR_SEPARATOR
1417 #if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
1418 || (length
> 1 && isalpha (name
[0]) && name
[1] == ':')
1424 __gnat_is_regular_file (char *name
)
1427 struct stat statbuf
;
1429 ret
= __gnat_stat (name
, &statbuf
);
1430 return (!ret
&& S_ISREG (statbuf
.st_mode
));
1434 __gnat_is_directory (char *name
)
1437 struct stat statbuf
;
1439 ret
= __gnat_stat (name
, &statbuf
);
1440 return (!ret
&& S_ISDIR (statbuf
.st_mode
));
1444 __gnat_is_readable_file (char *name
)
1448 struct stat statbuf
;
1450 ret
= __gnat_stat (name
, &statbuf
);
1451 mode
= statbuf
.st_mode
& S_IRUSR
;
1452 return (!ret
&& mode
);
1456 __gnat_is_writable_file (char *name
)
1460 struct stat statbuf
;
1462 ret
= __gnat_stat (name
, &statbuf
);
1463 mode
= statbuf
.st_mode
& S_IWUSR
;
1464 return (!ret
&& mode
);
1468 __gnat_set_writable (char *name
)
1471 struct stat statbuf
;
1473 if (stat (name
, &statbuf
) == 0)
1475 statbuf
.st_mode
= statbuf
.st_mode
| S_IWUSR
;
1476 chmod (name
, statbuf
.st_mode
);
1482 __gnat_set_executable (char *name
)
1485 struct stat statbuf
;
1487 if (stat (name
, &statbuf
) == 0)
1489 statbuf
.st_mode
= statbuf
.st_mode
| S_IXUSR
;
1490 chmod (name
, statbuf
.st_mode
);
1496 __gnat_set_readonly (char *name
)
1499 struct stat statbuf
;
1501 if (stat (name
, &statbuf
) == 0)
1503 statbuf
.st_mode
= statbuf
.st_mode
& 07577;
1504 chmod (name
, statbuf
.st_mode
);
1510 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED
)
1512 #if defined (__vxworks)
1515 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
1517 struct stat statbuf
;
1519 ret
= lstat (name
, &statbuf
);
1520 return (!ret
&& S_ISLNK (statbuf
.st_mode
));
1528 /* Defined in VMS header files. */
1529 #if defined (__ALPHA)
1530 #define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
1531 LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1)
1532 #elif defined (__IA64)
1533 #define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
1534 LIB$I64_GET_CURR_INVO_CONTEXT(decc$$get_vfork_jmpbuf()) : -1)
1538 #if defined (sun) && defined (__SVR4)
1539 /* Using fork on Solaris will duplicate all the threads. fork1, which
1540 duplicates only the active thread, must be used instead, or spawning
1541 subprocess from a program with tasking will lead into numerous problems. */
1546 __gnat_portable_spawn (char *args
[])
1549 int finished ATTRIBUTE_UNUSED
;
1550 int pid ATTRIBUTE_UNUSED
;
1552 #if defined (MSDOS) || defined (_WIN32)
1553 /* args[0] must be quotes as it could contain a full pathname with spaces */
1554 char *args_0
= args
[0];
1555 args
[0] = (char *)xmalloc (strlen (args_0
) + 3);
1556 strcpy (args
[0], "\"");
1557 strcat (args
[0], args_0
);
1558 strcat (args
[0], "\"");
1560 status
= spawnvp (P_WAIT
, args_0
, (char* const*)args
);
1562 /* restore previous value */
1564 args
[0] = (char *)args_0
;
1571 #elif defined (__vxworks)
1576 pid
= spawnvp (P_NOWAIT
, args
[0], args
);
1588 if (execv (args
[0], args
) != 0)
1590 return -1; /* execv is in parent context on VMS. */
1598 finished
= waitpid (pid
, &status
, 0);
1600 if (finished
!= pid
|| WIFEXITED (status
) == 0)
1603 return WEXITSTATUS (status
);
1609 /* Create a copy of the given file descriptor.
1610 Return -1 if an error occurred. */
1613 __gnat_dup (int oldfd
)
1615 #if defined (__vxworks)
1616 /* Not supported on VxWorks. */
1623 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
1624 Return -1 if an error occured. */
1627 __gnat_dup2 (int oldfd
, int newfd
)
1629 #if defined (__vxworks)
1630 /* Not supported on VxWorks. */
1633 return dup2 (oldfd
, newfd
);
1637 /* WIN32 code to implement a wait call that wait for any child process. */
1641 /* Synchronization code, to be thread safe. */
1643 static CRITICAL_SECTION plist_cs
;
1646 __gnat_plist_init (void)
1648 InitializeCriticalSection (&plist_cs
);
1654 EnterCriticalSection (&plist_cs
);
1660 LeaveCriticalSection (&plist_cs
);
1663 typedef struct _process_list
1666 struct _process_list
*next
;
1669 static Process_List
*PLIST
= NULL
;
1671 static int plist_length
= 0;
1674 add_handle (HANDLE h
)
1678 pl
= (Process_List
*) xmalloc (sizeof (Process_List
));
1682 /* -------------------- critical section -------------------- */
1687 /* -------------------- critical section -------------------- */
1693 remove_handle (HANDLE h
)
1696 Process_List
*prev
= NULL
;
1700 /* -------------------- critical section -------------------- */
1709 prev
->next
= pl
->next
;
1721 /* -------------------- critical section -------------------- */
1727 win32_no_block_spawn (char *command
, char *args
[])
1731 PROCESS_INFORMATION PI
;
1732 SECURITY_ATTRIBUTES SA
;
1737 /* compute the total command line length */
1741 csize
+= strlen (args
[k
]) + 1;
1745 full_command
= (char *) xmalloc (csize
);
1748 SI
.cb
= sizeof (STARTUPINFO
);
1749 SI
.lpReserved
= NULL
;
1750 SI
.lpReserved2
= NULL
;
1751 SI
.lpDesktop
= NULL
;
1755 SI
.wShowWindow
= SW_HIDE
;
1757 /* Security attributes. */
1758 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
1759 SA
.bInheritHandle
= TRUE
;
1760 SA
.lpSecurityDescriptor
= NULL
;
1762 /* Prepare the command string. */
1763 strcpy (full_command
, command
);
1764 strcat (full_command
, " ");
1769 strcat (full_command
, args
[k
]);
1770 strcat (full_command
, " ");
1774 result
= CreateProcess
1775 (NULL
, (char *) full_command
, &SA
, NULL
, TRUE
,
1776 GetPriorityClass (GetCurrentProcess()), NULL
, NULL
, &SI
, &PI
);
1778 free (full_command
);
1782 add_handle (PI
.hProcess
);
1783 CloseHandle (PI
.hThread
);
1784 return (int) PI
.hProcess
;
1791 win32_wait (int *status
)
1800 if (plist_length
== 0)
1806 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * plist_length
);
1811 /* -------------------- critical section -------------------- */
1818 /* -------------------- critical section -------------------- */
1822 res
= WaitForMultipleObjects (plist_length
, hl
, FALSE
, INFINITE
);
1823 h
= hl
[res
- WAIT_OBJECT_0
];
1828 GetExitCodeProcess (h
, &exitcode
);
1831 *status
= (int) exitcode
;
1838 __gnat_portable_no_block_spawn (char *args
[])
1842 #if defined (__EMX__) || defined (MSDOS)
1844 /* ??? For PC machines I (Franco) don't know the system calls to implement
1845 this routine. So I'll fake it as follows. This routine will behave
1846 exactly like the blocking portable_spawn and will systematically return
1847 a pid of 0 unless the spawned task did not complete successfully, in
1848 which case we return a pid of -1. To synchronize with this the
1849 portable_wait below systematically returns a pid of 0 and reports that
1850 the subprocess terminated successfully. */
1852 if (spawnvp (P_WAIT
, args
[0], args
) != 0)
1855 #elif defined (_WIN32)
1857 pid
= win32_no_block_spawn (args
[0], args
);
1860 #elif defined (__vxworks)
1869 if (execv (args
[0], args
) != 0)
1871 return -1; /* execv is in parent context on VMS. */
1883 __gnat_portable_wait (int *process_status
)
1888 #if defined (_WIN32)
1890 pid
= win32_wait (&status
);
1892 #elif defined (__EMX__) || defined (MSDOS)
1893 /* ??? See corresponding comment in portable_no_block_spawn. */
1895 #elif defined (__vxworks)
1896 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
1900 pid
= waitpid (-1, &status
, 0);
1901 status
= status
& 0xffff;
1904 *process_status
= status
;
1909 __gnat_waitpid (int pid
)
1913 #if defined (_WIN32)
1914 cwait (&status
, pid
, _WAIT_CHILD
);
1915 #elif defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1916 /* Status is already zero, so nothing to do. */
1918 waitpid (pid
, &status
, 0);
1919 status
= WEXITSTATUS (status
);
1926 __gnat_os_exit (int status
)
1931 /* Locate a regular file, give a Path value. */
1934 __gnat_locate_regular_file (char *file_name
, char *path_val
)
1937 int absolute
= __gnat_is_absolute_path (file_name
, strlen (file_name
));
1939 /* Handle absolute pathnames. */
1942 if (__gnat_is_regular_file (file_name
))
1943 return xstrdup (file_name
);
1948 /* If file_name include directory separator(s), try it first as
1949 a path name relative to the current directory */
1950 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
1955 if (__gnat_is_regular_file (file_name
))
1956 return xstrdup (file_name
);
1963 /* The result has to be smaller than path_val + file_name. */
1964 char *file_path
= alloca (strlen (path_val
) + strlen (file_name
) + 2);
1968 for (; *path_val
== PATH_SEPARATOR
; path_val
++)
1974 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
1975 *ptr
++ = *path_val
++;
1978 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
1979 *++ptr
= DIR_SEPARATOR
;
1981 strcpy (++ptr
, file_name
);
1983 if (__gnat_is_regular_file (file_path
))
1984 return xstrdup (file_path
);
1991 /* Locate an executable given a Path argument. This routine is only used by
1992 gnatbl and should not be used otherwise. Use locate_exec_on_path
1996 __gnat_locate_exec (char *exec_name
, char *path_val
)
1998 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
2000 char *full_exec_name
2001 = alloca (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
2003 strcpy (full_exec_name
, exec_name
);
2004 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
2005 return __gnat_locate_regular_file (full_exec_name
, path_val
);
2008 return __gnat_locate_regular_file (exec_name
, path_val
);
2011 /* Locate an executable using the Systems default PATH. */
2014 __gnat_locate_exec_on_path (char *exec_name
)
2018 char *path_val
= "/VAXC$PATH";
2020 char *path_val
= getenv ("PATH");
2023 /* In Win32 systems we expand the PATH as for XP environment
2024 variables are not automatically expanded. */
2025 int len
= strlen (path_val
) * 3;
2026 char *expanded_path_val
= alloca (len
+ 1);
2028 DWORD res
= ExpandEnvironmentStrings (path_val
, expanded_path_val
, len
);
2032 path_val
= expanded_path_val
;
2036 apath_val
= alloca (strlen (path_val
) + 1);
2037 strcpy (apath_val
, path_val
);
2039 return __gnat_locate_exec (exec_name
, apath_val
);
2044 /* These functions are used to translate to and from VMS and Unix syntax
2045 file, directory and path specifications. */
2048 #define MAXNAMES 256
2049 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2051 static char new_canonical_dirspec
[MAXPATH
];
2052 static char new_canonical_filespec
[MAXPATH
];
2053 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
2054 static unsigned new_canonical_filelist_index
;
2055 static unsigned new_canonical_filelist_in_use
;
2056 static unsigned new_canonical_filelist_allocated
;
2057 static char **new_canonical_filelist
;
2058 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
2059 static char new_host_dirspec
[MAXPATH
];
2060 static char new_host_filespec
[MAXPATH
];
2062 /* Routine is called repeatedly by decc$from_vms via
2063 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2067 wildcard_translate_unix (char *name
)
2070 char buff
[MAXPATH
];
2072 strncpy (buff
, name
, MAXPATH
);
2073 buff
[MAXPATH
- 1] = (char) 0;
2074 ver
= strrchr (buff
, '.');
2076 /* Chop off the version. */
2080 /* Dynamically extend the allocation by the increment. */
2081 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
2083 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
2084 new_canonical_filelist
= (char **) xrealloc
2085 (new_canonical_filelist
,
2086 new_canonical_filelist_allocated
* sizeof (char *));
2089 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
2094 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2095 full translation and copy the results into a list (_init), then return them
2096 one at a time (_next). If onlydirs set, only expand directory files. */
2099 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
2102 char buff
[MAXPATH
];
2104 len
= strlen (filespec
);
2105 strncpy (buff
, filespec
, MAXPATH
);
2107 /* Only look for directories */
2108 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
2109 strncat (buff
, "*.dir", MAXPATH
);
2111 buff
[MAXPATH
- 1] = (char) 0;
2113 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
2115 /* Remove the .dir extension. */
2121 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
2123 ext
= strstr (new_canonical_filelist
[i
], ".dir");
2129 return new_canonical_filelist_in_use
;
2132 /* Return the next filespec in the list. */
2135 __gnat_to_canonical_file_list_next ()
2137 return new_canonical_filelist
[new_canonical_filelist_index
++];
2140 /* Free storage used in the wildcard expansion. */
2143 __gnat_to_canonical_file_list_free ()
2147 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
2148 free (new_canonical_filelist
[i
]);
2150 free (new_canonical_filelist
);
2152 new_canonical_filelist_in_use
= 0;
2153 new_canonical_filelist_allocated
= 0;
2154 new_canonical_filelist_index
= 0;
2155 new_canonical_filelist
= 0;
2158 /* Translate a VMS syntax directory specification in to Unix syntax. If
2159 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2160 found, return input string. Also translate a dirname that contains no
2161 slashes, in case it's a logical name. */
2164 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
2168 strcpy (new_canonical_dirspec
, "");
2169 if (strlen (dirspec
))
2173 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
2175 strncpy (new_canonical_dirspec
,
2176 (char *) decc$
translate_vms (dirspec
),
2179 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
2181 strncpy (new_canonical_dirspec
,
2182 (char *) decc$
translate_vms (dirspec1
),
2187 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
2191 len
= strlen (new_canonical_dirspec
);
2192 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
2193 strncat (new_canonical_dirspec
, "/", MAXPATH
);
2195 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
2197 return new_canonical_dirspec
;
2201 /* Translate a VMS syntax file specification into Unix syntax.
2202 If no indicators of VMS syntax found, return input string. */
2205 __gnat_to_canonical_file_spec (char *filespec
)
2207 strncpy (new_canonical_filespec
, "", MAXPATH
);
2209 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
2211 strncpy (new_canonical_filespec
,
2212 (char *) decc$
translate_vms (filespec
),
2217 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
2220 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
2222 return new_canonical_filespec
;
2225 /* Translate a VMS syntax path specification into Unix syntax.
2226 If no indicators of VMS syntax found, return input string. */
2229 __gnat_to_canonical_path_spec (char *pathspec
)
2231 char *curr
, *next
, buff
[MAXPATH
];
2236 /* If there are /'s, assume it's a Unix path spec and return. */
2237 if (strchr (pathspec
, '/'))
2240 new_canonical_pathspec
[0] = 0;
2245 next
= strchr (curr
, ',');
2247 next
= strchr (curr
, 0);
2249 strncpy (buff
, curr
, next
- curr
);
2250 buff
[next
- curr
] = 0;
2252 /* Check for wildcards and expand if present. */
2253 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
2257 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
2258 for (i
= 0; i
< dirs
; i
++)
2262 next_dir
= __gnat_to_canonical_file_list_next ();
2263 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
2265 /* Don't append the separator after the last expansion. */
2267 strncat (new_canonical_pathspec
, ":", MAXPATH
);
2270 __gnat_to_canonical_file_list_free ();
2273 strncat (new_canonical_pathspec
,
2274 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
2279 strncat (new_canonical_pathspec
, ":", MAXPATH
);
2283 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
2285 return new_canonical_pathspec
;
2288 static char filename_buff
[MAXPATH
];
2291 translate_unix (char *name
, int type
)
2293 strncpy (filename_buff
, name
, MAXPATH
);
2294 filename_buff
[MAXPATH
- 1] = (char) 0;
2298 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
2302 to_host_path_spec (char *pathspec
)
2304 char *curr
, *next
, buff
[MAXPATH
];
2309 /* Can't very well test for colons, since that's the Unix separator! */
2310 if (strchr (pathspec
, ']') || strchr (pathspec
, ','))
2313 new_host_pathspec
[0] = 0;
2318 next
= strchr (curr
, ':');
2320 next
= strchr (curr
, 0);
2322 strncpy (buff
, curr
, next
- curr
);
2323 buff
[next
- curr
] = 0;
2325 strncat (new_host_pathspec
, __gnat_to_host_dir_spec (buff
, 0), MAXPATH
);
2328 strncat (new_host_pathspec
, ",", MAXPATH
);
2332 new_host_pathspec
[MAXPATH
- 1] = (char) 0;
2334 return new_host_pathspec
;
2337 /* Translate a Unix syntax directory specification into VMS syntax. The
2338 PREFIXFLAG has no effect, but is kept for symmetry with
2339 to_canonical_dir_spec. If indicators of VMS syntax found, return input
2343 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2345 int len
= strlen (dirspec
);
2347 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
2348 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
2350 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
2351 return new_host_dirspec
;
2353 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
2355 new_host_dirspec
[len
- 1] = 0;
2359 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
2360 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
2361 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
2363 return new_host_dirspec
;
2366 /* Translate a Unix syntax file specification into VMS syntax.
2367 If indicators of VMS syntax found, return input string. */
2370 __gnat_to_host_file_spec (char *filespec
)
2372 strncpy (new_host_filespec
, "", MAXPATH
);
2373 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
2375 strncpy (new_host_filespec
, filespec
, MAXPATH
);
2379 decc$
to_vms (filespec
, translate_unix
, 1, 1);
2380 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
2383 new_host_filespec
[MAXPATH
- 1] = (char) 0;
2385 return new_host_filespec
;
2389 __gnat_adjust_os_resource_limits ()
2391 SYS$
ADJWSL (131072, 0);
2396 /* Dummy functions for Osint import for non-VMS systems. */
2399 __gnat_to_canonical_file_list_init
2400 (char *dirspec ATTRIBUTE_UNUSED
, int onlydirs ATTRIBUTE_UNUSED
)
2406 __gnat_to_canonical_file_list_next (void)
2412 __gnat_to_canonical_file_list_free (void)
2417 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2423 __gnat_to_canonical_file_spec (char *filespec
)
2429 __gnat_to_canonical_path_spec (char *pathspec
)
2435 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2441 __gnat_to_host_file_spec (char *filespec
)
2447 __gnat_adjust_os_resource_limits (void)
2453 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
2454 to coordinate this with the EMX distribution. Consequently, we put the
2455 definition of dummy which is used for exception handling, here. */
2457 #if defined (__EMX__)
2461 #if defined (__mips_vxworks)
2465 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
2469 #if defined (CROSS_COMPILE) \
2470 || (! (defined (sparc) && defined (sun) && defined (__SVR4)) \
2471 && ! (defined (linux) && defined (i386)) \
2472 && ! defined (__FreeBSD__) \
2473 && ! defined (__hpux__) \
2474 && ! defined (_AIX) \
2475 && ! (defined (__alpha__) && defined (__osf__)) \
2476 && ! defined (__MINGW32__) \
2477 && ! (defined (__mips) && defined (__sgi)))
2479 /* Dummy function to satisfy g-trasym.o. Currently Solaris sparc, HP/UX,
2480 GNU/Linux x86, Tru64 & Windows provide a non-dummy version of this
2481 procedure in libaddr2line.a. */
2484 convert_addresses (void *addrs ATTRIBUTE_UNUSED
,
2485 int n_addr ATTRIBUTE_UNUSED
,
2486 void *buf ATTRIBUTE_UNUSED
,
2487 int *len ATTRIBUTE_UNUSED
)
2493 #if defined (_WIN32)
2494 int __gnat_argument_needs_quote
= 1;
2496 int __gnat_argument_needs_quote
= 0;
2499 /* This option is used to enable/disable object files handling from the
2500 binder file by the GNAT Project module. For example, this is disabled on
2501 Windows (prior to GCC 3.4) as it is already done by the mdll module.
2502 Stating with GCC 3.4 the shared libraries are not based on mdll
2503 anymore as it uses the GCC's -shared option */
2504 #if defined (_WIN32) \
2505 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
2506 int __gnat_prj_add_obj_files
= 0;
2508 int __gnat_prj_add_obj_files
= 1;
2511 /* char used as prefix/suffix for environment variables */
2512 #if defined (_WIN32)
2513 char __gnat_environment_char
= '%';
2515 char __gnat_environment_char
= '$';
2518 /* This functions copy the file attributes from a source file to a
2521 mode = 0 : In this mode copy only the file time stamps (last access and
2522 last modification time stamps).
2524 mode = 1 : In this mode, time stamps and read/write/execute attributes are
2527 Returns 0 if operation was successful and -1 in case of error. */
2530 __gnat_copy_attribs (char *from
, char *to
, int mode
)
2532 #if defined (VMS) || defined (__vxworks)
2536 struct utimbuf tbuf
;
2538 if (stat (from
, &fbuf
) == -1)
2543 tbuf
.actime
= fbuf
.st_atime
;
2544 tbuf
.modtime
= fbuf
.st_mtime
;
2546 if (utime (to
, &tbuf
) == -1)
2553 if (chmod (to
, fbuf
.st_mode
) == -1)
2563 /* This function is installed in libgcc.a. */
2564 extern void __gnat_install_locks (void (*) (void), void (*) (void));
2566 /* This function offers a hook for libgnarl to set the
2567 locking subprograms for libgcc_eh.
2568 This is only needed on OpenVMS, since other platforms use standard
2569 --enable-threads=posix option, or similar. */
2572 __gnatlib_install_locks (void (*lock
) (void) ATTRIBUTE_UNUSED
,
2573 void (*unlock
) (void) ATTRIBUTE_UNUSED
)
2575 #if defined (IN_RTS) && defined (VMS)
2576 __gnat_install_locks (lock
, unlock
);
2577 /* There is a bootstrap path issue if adaint is build with this
2578 symbol unresolved for the stage1 compiler. Since the compiler
2579 does not use tasking, we simply make __gnatlib_install_locks
2580 a no-op in this case. */
2585 __gnat_lseek (int fd
, long offset
, int whence
)
2587 return (int) lseek (fd
, offset
, whence
);
2590 /* This function returns the version of GCC being used. Here it's GCC 3. */
2592 get_gcc_version (void)