1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2003, 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)
154 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
155 defined in the current system. On DOS-like systems these flags control
156 whether the file is opened/created in text-translation mode (CR/LF in
157 external file mapped to LF in internal file), but in Unix-like systems,
158 no text translation is required, so these flags have no effect. */
160 #if defined (__EMX__)
176 #ifndef HOST_EXECUTABLE_SUFFIX
177 #define HOST_EXECUTABLE_SUFFIX ""
180 #ifndef HOST_OBJECT_SUFFIX
181 #define HOST_OBJECT_SUFFIX ".o"
184 #ifndef PATH_SEPARATOR
185 #define PATH_SEPARATOR ':'
188 #ifndef DIR_SEPARATOR
189 #define DIR_SEPARATOR '/'
192 char __gnat_dir_separator
= DIR_SEPARATOR
;
194 char __gnat_path_separator
= PATH_SEPARATOR
;
196 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
197 the base filenames that libraries specified with -lsomelib options
198 may have. This is used by GNATMAKE to check whether an executable
199 is up-to-date or not. The syntax is
201 library_template ::= { pattern ; } pattern NUL
202 pattern ::= [ prefix ] * [ postfix ]
204 These should only specify names of static libraries as it makes
205 no sense to determine at link time if dynamic-link libraries are
206 up to date or not. Any libraries that are not found are supposed
209 * if they are needed but not present, the link
212 * otherwise they are libraries in the system paths and so
213 they are considered part of the system and not checked
216 ??? This should be part of a GNAT host-specific compiler
217 file instead of being included in all user applications
218 as well. This is only a temporary work-around for 3.11b. */
220 #ifndef GNAT_LIBRARY_TEMPLATE
221 #if defined (__EMX__)
222 #define GNAT_LIBRARY_TEMPLATE "*.a"
224 #define GNAT_LIBRARY_TEMPLATE "*.olb"
226 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
230 const char *__gnat_library_template
= GNAT_LIBRARY_TEMPLATE
;
232 /* This variable is used in hostparm.ads to say whether the host is a VMS
235 const int __gnat_vmsp
= 1;
237 const int __gnat_vmsp
= 0;
241 #define GNAT_MAX_PATH_LEN MAX_PATH
244 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
246 #elif defined (__vxworks) || defined (__OPENNT)
247 #define GNAT_MAX_PATH_LEN PATH_MAX
251 #if defined (__MINGW32__)
255 #include <sys/param.h>
259 #include <sys/param.h>
262 #define GNAT_MAX_PATH_LEN MAXPATHLEN
266 /* The __gnat_max_path_len variable is used to export the maximum
267 length of a path name to Ada code. max_path_len is also provided
268 for compatibility with older GNAT versions, please do not use
271 int __gnat_max_path_len
= GNAT_MAX_PATH_LEN
;
272 int max_path_len
= GNAT_MAX_PATH_LEN
;
274 /* The following macro HAVE_READDIR_R should be defined if the
275 system provides the routine readdir_r. */
276 #undef HAVE_READDIR_R
289 time_t time
= (time_t) *p_time
;
292 /* On Windows systems, the time is sometimes rounded up to the nearest
293 even second, so if the number of seconds is odd, increment it. */
299 res
= localtime (&time
);
301 res
= gmtime (&time
);
306 *p_year
= res
->tm_year
;
307 *p_month
= res
->tm_mon
;
308 *p_day
= res
->tm_mday
;
309 *p_hours
= res
->tm_hour
;
310 *p_mins
= res
->tm_min
;
311 *p_secs
= res
->tm_sec
;
314 *p_year
= *p_month
= *p_day
= *p_hours
= *p_mins
= *p_secs
= 0;
317 /* Place the contents of the symbolic link named PATH in the buffer BUF,
318 which has size BUFSIZ. If PATH is a symbolic link, then return the number
319 of characters of its content in BUF. Otherwise, return -1. For Windows,
320 OS/2 and vxworks, always return -1. */
323 __gnat_readlink (char *path ATTRIBUTE_UNUSED
,
324 char *buf ATTRIBUTE_UNUSED
,
325 size_t bufsiz ATTRIBUTE_UNUSED
)
327 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
329 #elif defined (__INTERIX) || defined (VMS)
331 #elif defined (__vxworks)
334 return readlink (path
, buf
, bufsiz
);
338 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH. If
339 NEWPATH exists it will NOT be overwritten. For Windows, OS/2, VxWorks,
340 Interix and VMS, always return -1. */
343 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED
,
344 char *newpath ATTRIBUTE_UNUSED
)
346 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
348 #elif defined (__INTERIX) || defined (VMS)
350 #elif defined (__vxworks)
353 return symlink (oldpath
, newpath
);
357 /* Try to lock a file, return 1 if success. */
359 #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32)
361 /* Version that does not use link. */
364 __gnat_try_lock (char *dir
, char *file
)
369 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
370 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
378 #elif defined (__EMX__) || defined (VMS)
380 /* More cases that do not use link; identical code, to solve too long
384 __gnat_try_lock (char *dir
, char *file
)
389 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
390 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
400 /* Version using link(), more secure over NFS. */
401 /* See TN 6913-016 for discussion ??? */
404 __gnat_try_lock (char *dir
, char *file
)
408 struct stat stat_result
;
411 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
412 sprintf (temp_file
, "%s-%ld-%ld", dir
, (long) getpid(), (long) getppid ());
414 /* Create the temporary file and write the process number. */
415 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
421 /* Link it with the new file. */
422 link (temp_file
, full_path
);
424 /* Count the references on the old one. If we have a count of two, then
425 the link did succeed. Remove the temporary file before returning. */
426 __gnat_stat (temp_file
, &stat_result
);
428 return stat_result
.st_nlink
== 2;
432 /* Return the maximum file name length. */
435 __gnat_get_maximum_file_name_length (void)
440 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
449 /* Return nonzero if file names are case sensitive. */
452 __gnat_get_file_names_case_sensitive (void)
454 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT)
462 __gnat_get_default_identifier_character_set (void)
464 #if defined (__EMX__) || defined (MSDOS)
471 /* Return the current working directory. */
474 __gnat_get_current_dir (char *dir
, int *length
)
477 /* Force Unix style, which is what GNAT uses internally. */
478 getcwd (dir
, *length
, 0);
480 getcwd (dir
, *length
);
483 *length
= strlen (dir
);
485 if (dir
[*length
- 1] != DIR_SEPARATOR
)
487 dir
[*length
] = DIR_SEPARATOR
;
493 /* Return the suffix for object files. */
496 __gnat_get_object_suffix_ptr (int *len
, const char **value
)
498 *value
= HOST_OBJECT_SUFFIX
;
503 *len
= strlen (*value
);
508 /* Return the suffix for executable files. */
511 __gnat_get_executable_suffix_ptr (int *len
, const char **value
)
513 *value
= HOST_EXECUTABLE_SUFFIX
;
517 *len
= strlen (*value
);
522 /* Return the suffix for debuggable files. Usually this is the same as the
523 executable extension. */
526 __gnat_get_debuggable_suffix_ptr (int *len
, const char **value
)
529 *value
= HOST_EXECUTABLE_SUFFIX
;
531 /* On DOS, the extensionless COFF file is what gdb likes. */
538 *len
= strlen (*value
);
544 __gnat_open_read (char *path
, int fmode
)
547 int o_fmode
= O_BINARY
;
553 /* Optional arguments mbc,deq,fop increase read performance. */
554 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
555 "mbc=16", "deq=64", "fop=tef");
556 #elif defined (__vxworks)
557 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
559 fd
= open (path
, O_RDONLY
| o_fmode
);
562 return fd
< 0 ? -1 : fd
;
565 #if defined (__EMX__) || defined (__MINGW32__)
566 #define PERM (S_IREAD | S_IWRITE)
568 /* Excerpt from DECC C RTL Reference Manual:
569 To create files with OpenVMS RMS default protections using the UNIX
570 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
571 and open with a file-protection mode argument of 0777 in a program
572 that never specifically calls umask. These default protections include
573 correctly establishing protections based on ACLs, previous versions of
577 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
581 __gnat_open_rw (char *path
, int fmode
)
584 int o_fmode
= O_BINARY
;
590 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
591 "mbc=16", "deq=64", "fop=tef");
593 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
596 return fd
< 0 ? -1 : fd
;
600 __gnat_open_create (char *path
, int fmode
)
603 int o_fmode
= O_BINARY
;
609 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
610 "mbc=16", "deq=64", "fop=tef");
612 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
615 return fd
< 0 ? -1 : fd
;
619 __gnat_open_append (char *path
, int fmode
)
622 int o_fmode
= O_BINARY
;
628 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
629 "mbc=16", "deq=64", "fop=tef");
631 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
634 return fd
< 0 ? -1 : fd
;
637 /* Open a new file. Return error (-1) if the file already exists. */
640 __gnat_open_new (char *path
, int fmode
)
643 int o_fmode
= O_BINARY
;
649 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
650 "mbc=16", "deq=64", "fop=tef");
652 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
655 return fd
< 0 ? -1 : fd
;
658 /* Open a new temp file. Return error (-1) if the file already exists.
659 Special options for VMS allow the file to be shared between parent and child
660 processes, however they really slow down output. Used in gnatchop. */
663 __gnat_open_new_temp (char *path
, int fmode
)
666 int o_fmode
= O_BINARY
;
668 strcpy (path
, "GNAT-XXXXXX");
670 #if (defined (__FreeBSD__) || defined (linux)) && !defined (__vxworks)
671 return mkstemp (path
);
672 #elif defined (__Lynx__)
675 if (mktemp (path
) == NULL
)
683 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
684 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
685 "mbc=16", "deq=64", "fop=tef");
687 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
690 return fd
< 0 ? -1 : fd
;
693 /* Return the number of bytes in the specified file. */
696 __gnat_file_length (int fd
)
701 ret
= fstat (fd
, &statbuf
);
702 if (ret
|| !S_ISREG (statbuf
.st_mode
))
705 return (statbuf
.st_size
);
708 /* Create a temporary filename and put it in string pointed to by
712 __gnat_tmp_name (char *tmp_filename
)
718 /* tempnam tries to create a temporary file in directory pointed to by
719 TMP environment variable, in c:\temp if TMP is not set, and in
720 directory specified by P_tmpdir in stdio.h if c:\temp does not
721 exist. The filename will be created with the prefix "gnat-". */
723 pname
= (char *) tempnam ("c:\\temp", "gnat-");
725 /* if pname is NULL, the file was not created properly, the disk is full
726 or there is no more free temporary files */
729 *tmp_filename
= '\0';
731 /* If pname start with a back slash and not path information it means that
732 the filename is valid for the current working directory. */
734 else if (pname
[0] == '\\')
736 strcpy (tmp_filename
, ".\\");
737 strcat (tmp_filename
, pname
+1);
740 strcpy (tmp_filename
, pname
);
745 #elif defined (linux) || defined (__FreeBSD__)
746 #define MAX_SAFE_PATH 1000
747 char *tmpdir
= getenv ("TMPDIR");
749 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
750 a buffer overflow. */
751 if (tmpdir
== NULL
|| strlen (tmpdir
) > MAX_SAFE_PATH
)
752 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
754 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
756 close (mkstemp(tmp_filename
));
758 tmpnam (tmp_filename
);
762 /* Read the next entry in a directory. The returned string points somewhere
766 __gnat_readdir (DIR *dirp
, char *buffer
)
768 /* If possible, try to use the thread-safe version. */
769 #ifdef HAVE_READDIR_R
770 if (readdir_r (dirp
, buffer
) != NULL
)
771 return ((struct dirent
*) buffer
)->d_name
;
776 struct dirent
*dirent
= readdir (dirp
);
780 strcpy (buffer
, dirent
->d_name
);
789 /* Returns 1 if readdir is thread safe, 0 otherwise. */
792 __gnat_readdir_is_thread_safe (void)
794 #ifdef HAVE_READDIR_R
802 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
803 static const unsigned long long w32_epoch_offset
= 11644473600ULL;
805 /* Returns the file modification timestamp using Win32 routines which are
806 immune against daylight saving time change. It is in fact not possible to
807 use fstat for this purpose as the DST modify the st_mtime field of the
811 win32_filetime (HANDLE h
)
816 unsigned long long ull_time
;
819 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
820 since <Jan 1st 1601>. This function must return the number of seconds
821 since <Jan 1st 1970>. */
823 if (GetFileTime (h
, NULL
, NULL
, &t_write
.ft_time
))
824 return (time_t) (t_write
.ull_time
/ 10000000ULL
830 /* Return a GNAT time stamp given a file name. */
833 __gnat_file_time_name (char *name
)
836 #if defined (__EMX__) || defined (MSDOS)
837 int fd
= open (name
, O_RDONLY
| O_BINARY
);
838 time_t ret
= __gnat_file_time_fd (fd
);
842 #elif defined (_WIN32)
844 HANDLE h
= CreateFile (name
, GENERIC_READ
, FILE_SHARE_READ
, 0,
845 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
, 0);
847 if (h
!= INVALID_HANDLE_VALUE
)
849 ret
= win32_filetime (h
);
855 (void) __gnat_stat (name
, &statbuf
);
857 /* VMS has file versioning. */
858 return statbuf
.st_ctime
;
860 return statbuf
.st_mtime
;
865 /* Return a GNAT time stamp given a file descriptor. */
868 __gnat_file_time_fd (int fd
)
870 /* The following workaround code is due to the fact that under EMX and
871 DJGPP fstat attempts to convert time values to GMT rather than keep the
872 actual OS timestamp of the file. By using the OS2/DOS functions directly
873 the GNAT timestamp are independent of this behavior, which is desired to
874 facilitate the distribution of GNAT compiled libraries. */
876 #if defined (__EMX__) || defined (MSDOS)
880 int ret
= DosQueryFileInfo (fd
, 1, (unsigned char *) &fs
,
881 sizeof (FILESTATUS
));
883 unsigned file_year
= fs
.fdateLastWrite
.year
;
884 unsigned file_month
= fs
.fdateLastWrite
.month
;
885 unsigned file_day
= fs
.fdateLastWrite
.day
;
886 unsigned file_hour
= fs
.ftimeLastWrite
.hours
;
887 unsigned file_min
= fs
.ftimeLastWrite
.minutes
;
888 unsigned file_tsec
= fs
.ftimeLastWrite
.twosecs
;
892 int ret
= getftime (fd
, &fs
);
894 unsigned file_year
= fs
.ft_year
;
895 unsigned file_month
= fs
.ft_month
;
896 unsigned file_day
= fs
.ft_day
;
897 unsigned file_hour
= fs
.ft_hour
;
898 unsigned file_min
= fs
.ft_min
;
899 unsigned file_tsec
= fs
.ft_tsec
;
902 /* Calculate the seconds since epoch from the time components. First count
903 the whole days passed. The value for years returned by the DOS and OS2
904 functions count years from 1980, so to compensate for the UNIX epoch which
905 begins in 1970 start with 10 years worth of days and add days for each
906 four year period since then. */
909 int cum_days
[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
910 int days_passed
= 3652 + (file_year
/ 4) * 1461;
911 int years_since_leap
= file_year
% 4;
913 if (years_since_leap
== 1)
915 else if (years_since_leap
== 2)
917 else if (years_since_leap
== 3)
923 days_passed
+= cum_days
[file_month
- 1];
924 if (years_since_leap
== 0 && file_year
!= 20 && file_month
> 2)
927 days_passed
+= file_day
- 1;
929 /* OK - have whole days. Multiply -- then add in other parts. */
931 tot_secs
= days_passed
* 86400;
932 tot_secs
+= file_hour
* 3600;
933 tot_secs
+= file_min
* 60;
934 tot_secs
+= file_tsec
* 2;
937 #elif defined (_WIN32)
938 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
939 time_t ret
= win32_filetime (h
);
945 (void) fstat (fd
, &statbuf
);
948 /* VMS has file versioning. */
949 return statbuf
.st_ctime
;
951 return statbuf
.st_mtime
;
956 /* Set the file time stamp. */
959 __gnat_set_file_time_name (char *name
, time_t time_stamp
)
961 #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
963 /* Code to implement __gnat_set_file_time_name for these systems. */
965 #elif defined (_WIN32)
969 unsigned long long ull_time
;
972 HANDLE h
= CreateFile (name
, GENERIC_WRITE
, FILE_SHARE_WRITE
, NULL
,
973 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
,
975 if (h
== INVALID_HANDLE_VALUE
)
977 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
978 t_write
.ull_time
= ((unsigned long long)time_stamp
+ w32_epoch_offset
);
979 /* Convert to 100 nanosecond units */
980 t_write
.ull_time
*= 10000000ULL;
982 SetFileTime(h
, NULL
, NULL
, &t_write
.ft_time
);
992 unsigned long long backup
, create
, expire
, revise
;
996 unsigned short value
;
1005 } Fat
= { 0, 0, 0, 0, 0, { 0 }};
1009 { ATR$S_CREDATE
, ATR$C_CREDATE
, &Fat
.create
},
1010 { ATR$S_REVDATE
, ATR$C_REVDATE
, &Fat
.revise
},
1011 { ATR$S_EXPDATE
, ATR$C_EXPDATE
, &Fat
.expire
},
1012 { ATR$S_BAKDATE
, ATR$C_BAKDATE
, &Fat
.backup
},
1013 { ATR$S_FPRO
, ATR$C_FPRO
, &Fat
.prot
},
1014 { ATR$S_UIC
, ATR$C_UIC
, &Fat
.uic
},
1019 struct dsc$descriptor_fib fibdsc
= {sizeof (fib
), (void *) &fib
};
1023 unsigned long long newtime
;
1024 unsigned long long revtime
;
1028 struct vstring file
;
1029 struct dsc$descriptor_s filedsc
1030 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) file
.string
};
1031 struct vstring device
;
1032 struct dsc$descriptor_s devicedsc
1033 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) device
.string
};
1034 struct vstring timev
;
1035 struct dsc$descriptor_s timedsc
1036 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) timev
.string
};
1037 struct vstring result
;
1038 struct dsc$descriptor_s resultdsc
1039 = {NAM$C_MAXRSS
, DSC$K_DTYPE_VT
, DSC$K_CLASS_VS
, (void *) result
.string
};
1041 tryfile
= (char *) __gnat_to_host_dir_spec (name
, 0);
1043 /* Allocate and initialize a FAB and NAM structures. */
1047 nam
.nam$l_esa
= file
.string
;
1048 nam
.nam$b_ess
= NAM$C_MAXRSS
;
1049 nam
.nam$l_rsa
= result
.string
;
1050 nam
.nam$b_rss
= NAM$C_MAXRSS
;
1051 fab
.fab$l_fna
= tryfile
;
1052 fab
.fab$b_fns
= strlen (tryfile
);
1053 fab
.fab$l_nam
= &nam
;
1055 /* Validate filespec syntax and device existence. */
1056 status
= SYS$
PARSE (&fab
, 0, 0);
1057 if ((status
& 1) != 1)
1058 LIB$
SIGNAL (status
);
1060 file
.string
[nam
.nam$b_esl
] = 0;
1062 /* Find matching filespec. */
1063 status
= SYS$
SEARCH (&fab
, 0, 0);
1064 if ((status
& 1) != 1)
1065 LIB$
SIGNAL (status
);
1067 file
.string
[nam
.nam$b_esl
] = 0;
1068 result
.string
[result
.length
=nam
.nam$b_rsl
] = 0;
1070 /* Get the device name and assign an IO channel. */
1071 strncpy (device
.string
, nam
.nam$l_dev
, nam
.nam$b_dev
);
1072 devicedsc
.dsc$w_length
= nam
.nam$b_dev
;
1074 status
= SYS$
ASSIGN (&devicedsc
, &chan
, 0, 0, 0);
1075 if ((status
& 1) != 1)
1076 LIB$
SIGNAL (status
);
1078 /* Initialize the FIB and fill in the directory id field. */
1079 memset (&fib
, 0, sizeof (fib
));
1080 fib
.fib$w_did
[0] = nam
.nam$w_did
[0];
1081 fib
.fib$w_did
[1] = nam
.nam$w_did
[1];
1082 fib
.fib$w_did
[2] = nam
.nam$w_did
[2];
1083 fib
.fib$l_acctl
= 0;
1085 strcpy (file
.string
, (strrchr (result
.string
, ']') + 1));
1086 filedsc
.dsc$w_length
= strlen (file
.string
);
1087 result
.string
[result
.length
= 0] = 0;
1089 /* Open and close the file to fill in the attributes. */
1091 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1092 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1093 if ((status
& 1) != 1)
1094 LIB$
SIGNAL (status
);
1095 if ((iosb
.status
& 1) != 1)
1096 LIB$
SIGNAL (iosb
.status
);
1098 result
.string
[result
.length
] = 0;
1099 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0, &fibdsc
, 0, 0, 0,
1101 if ((status
& 1) != 1)
1102 LIB$
SIGNAL (status
);
1103 if ((iosb
.status
& 1) != 1)
1104 LIB$
SIGNAL (iosb
.status
);
1109 /* Set creation time to requested time. */
1110 unix_time_to_vms (time_stamp
, newtime
);
1112 t
= time ((time_t) 0);
1114 /* Set revision time to now in local time. */
1115 unix_time_to_vms (t
, revtime
);
1118 /* Reopen the file, modify the times and then close. */
1119 fib
.fib$l_acctl
= FIB$M_WRITE
;
1121 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1122 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1123 if ((status
& 1) != 1)
1124 LIB$
SIGNAL (status
);
1125 if ((iosb
.status
& 1) != 1)
1126 LIB$
SIGNAL (iosb
.status
);
1128 Fat
.create
= newtime
;
1129 Fat
.revise
= revtime
;
1131 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0,
1132 &fibdsc
, 0, 0, 0, &atrlst
, 0);
1133 if ((status
& 1) != 1)
1134 LIB$
SIGNAL (status
);
1135 if ((iosb
.status
& 1) != 1)
1136 LIB$
SIGNAL (iosb
.status
);
1138 /* Deassign the channel and exit. */
1139 status
= SYS$
DASSGN (chan
);
1140 if ((status
& 1) != 1)
1141 LIB$
SIGNAL (status
);
1143 struct utimbuf utimbuf
;
1146 /* Set modification time to requested time. */
1147 utimbuf
.modtime
= time_stamp
;
1149 /* Set access time to now in local time. */
1150 t
= time ((time_t) 0);
1151 utimbuf
.actime
= mktime (localtime (&t
));
1153 utime (name
, &utimbuf
);
1158 __gnat_get_env_value_ptr (char *name
, int *len
, char **value
)
1160 *value
= getenv (name
);
1164 *len
= strlen (*value
);
1169 /* VMS specific declarations for set_env_value. */
1173 static char *to_host_path_spec (char *);
1177 unsigned short len
, mbz
;
1181 typedef struct _ile3
1183 unsigned short len
, code
;
1185 unsigned short *retlen_adr
;
1191 __gnat_set_env_value (char *name
, char *value
)
1196 struct descriptor_s name_desc
;
1197 /* Put in JOB table for now, so that the project stuff at least works. */
1198 struct descriptor_s table_desc
= {7, 0, "LNM$JOB"};
1199 char *host_pathspec
= value
;
1200 char *copy_pathspec
;
1201 int num_dirs_in_pathspec
= 1;
1205 name_desc
.len
= strlen (name
);
1207 name_desc
.adr
= name
;
1209 if (*host_pathspec
== 0)
1212 status
= LIB$
DELETE_LOGICAL (&name_desc
, &table_desc
);
1213 /* no need to check status; if the logical name is not
1214 defined, that's fine. */
1218 ptr
= host_pathspec
;
1221 num_dirs_in_pathspec
++;
1225 ile_s
*ile_array
= alloca (sizeof (ile_s
) * (num_dirs_in_pathspec
+ 1));
1226 char *copy_pathspec
= alloca (strlen (host_pathspec
) + 1);
1229 strcpy (copy_pathspec
, host_pathspec
);
1230 curr
= copy_pathspec
;
1231 for (i
= 0; i
< num_dirs_in_pathspec
; i
++)
1233 next
= strchr (curr
, ',');
1235 next
= strchr (curr
, 0);
1238 ile_array
[i
].len
= strlen (curr
);
1240 /* Code 2 from lnmdef.h means its a string. */
1241 ile_array
[i
].code
= 2;
1242 ile_array
[i
].adr
= curr
;
1244 /* retlen_adr is ignored. */
1245 ile_array
[i
].retlen_adr
= 0;
1249 /* Terminating item must be zero. */
1250 ile_array
[i
].len
= 0;
1251 ile_array
[i
].code
= 0;
1252 ile_array
[i
].adr
= 0;
1253 ile_array
[i
].retlen_adr
= 0;
1255 status
= LIB$
SET_LOGICAL (&name_desc
, 0, &table_desc
, 0, ile_array
);
1256 if ((status
& 1) != 1)
1257 LIB$
SIGNAL (status
);
1261 int size
= strlen (name
) + strlen (value
) + 2;
1264 expression
= (char *) xmalloc (size
* sizeof (char));
1266 sprintf (expression
, "%s=%s", name
, value
);
1267 putenv (expression
);
1272 #include <windows.h>
1275 /* Get the list of installed standard libraries from the
1276 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1280 __gnat_get_libraries_from_registry (void)
1282 char *result
= (char *) "";
1284 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_COMPILE)
1287 DWORD name_size
, value_size
;
1294 /* First open the key. */
1295 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1297 if (res
== ERROR_SUCCESS
)
1298 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1299 KEY_READ
, ®_key
);
1301 if (res
== ERROR_SUCCESS
)
1302 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1304 if (res
== ERROR_SUCCESS
)
1305 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1307 /* If the key exists, read out all the values in it and concatenate them
1309 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1311 value_size
= name_size
= 256;
1312 res
= RegEnumValue (reg_key
, index
, name
, &name_size
, 0,
1313 &type
, value
, &value_size
);
1315 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1317 char *old_result
= result
;
1319 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1320 strcpy (result
, old_result
);
1321 strcat (result
, value
);
1322 strcat (result
, ";");
1326 /* Remove the trailing ";". */
1328 result
[strlen (result
) - 1] = 0;
1335 __gnat_stat (char *name
, struct stat
*statbuf
)
1338 /* Under Windows the directory name for the stat function must not be
1339 terminated by a directory separator except if just after a drive name. */
1340 int name_len
= strlen (name
);
1341 char last_char
= name
[name_len
- 1];
1342 char win32_name
[GNAT_MAX_PATH_LEN
+ 2];
1344 if (name_len
> GNAT_MAX_PATH_LEN
)
1347 strcpy (win32_name
, name
);
1349 while (name_len
> 1 && (last_char
== '\\' || last_char
== '/'))
1351 win32_name
[name_len
- 1] = '\0';
1353 last_char
= win32_name
[name_len
- 1];
1356 if (name_len
== 2 && win32_name
[1] == ':')
1357 strcat (win32_name
, "\\");
1359 return stat (win32_name
, statbuf
);
1362 return stat (name
, statbuf
);
1367 __gnat_file_exists (char *name
)
1369 struct stat statbuf
;
1371 return !__gnat_stat (name
, &statbuf
);
1375 __gnat_is_absolute_path (char *name
)
1377 return (*name
== '/' || *name
== DIR_SEPARATOR
1378 #if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
1379 || (strlen (name
) > 1 && isalpha (name
[0]) && name
[1] == ':')
1385 __gnat_is_regular_file (char *name
)
1388 struct stat statbuf
;
1390 ret
= __gnat_stat (name
, &statbuf
);
1391 return (!ret
&& S_ISREG (statbuf
.st_mode
));
1395 __gnat_is_directory (char *name
)
1398 struct stat statbuf
;
1400 ret
= __gnat_stat (name
, &statbuf
);
1401 return (!ret
&& S_ISDIR (statbuf
.st_mode
));
1405 __gnat_is_readable_file (char *name
)
1409 struct stat statbuf
;
1411 ret
= __gnat_stat (name
, &statbuf
);
1412 mode
= statbuf
.st_mode
& S_IRUSR
;
1413 return (!ret
&& mode
);
1417 __gnat_is_writable_file (char *name
)
1421 struct stat statbuf
;
1423 ret
= __gnat_stat (name
, &statbuf
);
1424 mode
= statbuf
.st_mode
& S_IWUSR
;
1425 return (!ret
&& mode
);
1429 __gnat_set_writable (char *name
)
1432 struct stat statbuf
;
1434 if (stat (name
, &statbuf
) == 0)
1436 statbuf
.st_mode
= statbuf
.st_mode
| S_IWUSR
;
1437 chmod (name
, statbuf
.st_mode
);
1443 __gnat_set_readonly (char *name
)
1446 struct stat statbuf
;
1448 if (stat (name
, &statbuf
) == 0)
1450 statbuf
.st_mode
= statbuf
.st_mode
& 07577;
1451 chmod (name
, statbuf
.st_mode
);
1457 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED
)
1459 #if defined (__vxworks)
1462 #elif defined (_AIX) || defined (unix)
1464 struct stat statbuf
;
1466 ret
= lstat (name
, &statbuf
);
1467 return (!ret
&& S_ISLNK (statbuf
.st_mode
));
1475 /* Defined in VMS header files. */
1476 #if defined (__ALPHA)
1477 #define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
1478 LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1)
1479 #elif defined (__IA64)
1480 #define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
1481 LIB$I64_GET_CURR_INVO_CONTEXT(decc$$get_vfork_jmpbuf()) : -1)
1485 #if defined (sun) && defined (__SVR4)
1486 /* Using fork on Solaris will duplicate all the threads. fork1, which
1487 duplicates only the active thread, must be used instead, or spawning
1488 subprocess from a program with tasking will lead into numerous problems. */
1493 __gnat_portable_spawn (char *args
[])
1496 int finished ATTRIBUTE_UNUSED
;
1497 int pid ATTRIBUTE_UNUSED
;
1499 #if defined (MSDOS) || defined (_WIN32)
1500 status
= spawnvp (P_WAIT
, args
[0],(const char* const*)args
);
1506 #elif defined (__vxworks)
1511 pid
= spawnvp (P_NOWAIT
, args
[0], args
);
1523 if (execv (args
[0], args
) != 0)
1525 return -1; /* execv is in parent context on VMS. */
1533 finished
= waitpid (pid
, &status
, 0);
1535 if (finished
!= pid
|| WIFEXITED (status
) == 0)
1538 return WEXITSTATUS (status
);
1544 /* WIN32 code to implement a wait call that wait for any child process. */
1548 /* Synchronization code, to be thread safe. */
1550 static CRITICAL_SECTION plist_cs
;
1553 __gnat_plist_init (void)
1555 InitializeCriticalSection (&plist_cs
);
1561 EnterCriticalSection (&plist_cs
);
1567 LeaveCriticalSection (&plist_cs
);
1570 typedef struct _process_list
1573 struct _process_list
*next
;
1576 static Process_List
*PLIST
= NULL
;
1578 static int plist_length
= 0;
1581 add_handle (HANDLE h
)
1585 pl
= (Process_List
*) xmalloc (sizeof (Process_List
));
1589 /* -------------------- critical section -------------------- */
1594 /* -------------------- critical section -------------------- */
1600 remove_handle (HANDLE h
)
1603 Process_List
*prev
= NULL
;
1607 /* -------------------- critical section -------------------- */
1616 prev
->next
= pl
->next
;
1628 /* -------------------- critical section -------------------- */
1634 win32_no_block_spawn (char *command
, char *args
[])
1638 PROCESS_INFORMATION PI
;
1639 SECURITY_ATTRIBUTES SA
;
1644 /* compute the total command line length */
1648 csize
+= strlen (args
[k
]) + 1;
1652 full_command
= (char *) xmalloc (csize
);
1655 SI
.cb
= sizeof (STARTUPINFO
);
1656 SI
.lpReserved
= NULL
;
1657 SI
.lpReserved2
= NULL
;
1658 SI
.lpDesktop
= NULL
;
1662 SI
.wShowWindow
= SW_HIDE
;
1664 /* Security attributes. */
1665 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
1666 SA
.bInheritHandle
= TRUE
;
1667 SA
.lpSecurityDescriptor
= NULL
;
1669 /* Prepare the command string. */
1670 strcpy (full_command
, command
);
1671 strcat (full_command
, " ");
1676 strcat (full_command
, args
[k
]);
1677 strcat (full_command
, " ");
1681 result
= CreateProcess (NULL
, (char *) full_command
, &SA
, NULL
, TRUE
,
1682 NORMAL_PRIORITY_CLASS
, NULL
, NULL
, &SI
, &PI
);
1684 free (full_command
);
1688 add_handle (PI
.hProcess
);
1689 CloseHandle (PI
.hThread
);
1690 return (int) PI
.hProcess
;
1697 win32_wait (int *status
)
1706 if (plist_length
== 0)
1712 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * plist_length
);
1717 /* -------------------- critical section -------------------- */
1724 /* -------------------- critical section -------------------- */
1728 res
= WaitForMultipleObjects (plist_length
, hl
, FALSE
, INFINITE
);
1729 h
= hl
[res
- WAIT_OBJECT_0
];
1734 GetExitCodeProcess (h
, &exitcode
);
1737 *status
= (int) exitcode
;
1744 __gnat_portable_no_block_spawn (char *args
[])
1748 #if defined (__EMX__) || defined (MSDOS)
1750 /* ??? For PC machines I (Franco) don't know the system calls to implement
1751 this routine. So I'll fake it as follows. This routine will behave
1752 exactly like the blocking portable_spawn and will systematically return
1753 a pid of 0 unless the spawned task did not complete successfully, in
1754 which case we return a pid of -1. To synchronize with this the
1755 portable_wait below systematically returns a pid of 0 and reports that
1756 the subprocess terminated successfully. */
1758 if (spawnvp (P_WAIT
, args
[0], args
) != 0)
1761 #elif defined (_WIN32)
1763 pid
= win32_no_block_spawn (args
[0], args
);
1766 #elif defined (__vxworks)
1775 if (execv (args
[0], args
) != 0)
1777 return -1; /* execv is in parent context on VMS. */
1789 __gnat_portable_wait (int *process_status
)
1794 #if defined (_WIN32)
1796 pid
= win32_wait (&status
);
1798 #elif defined (__EMX__) || defined (MSDOS)
1799 /* ??? See corresponding comment in portable_no_block_spawn. */
1801 #elif defined (__vxworks)
1802 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
1806 pid
= waitpid (-1, &status
, 0);
1807 status
= status
& 0xffff;
1810 *process_status
= status
;
1815 __gnat_waitpid (int pid
)
1819 #if defined (_WIN32)
1820 cwait (&status
, pid
, _WAIT_CHILD
);
1821 #elif defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1822 /* Status is already zero, so nothing to do. */
1824 waitpid (pid
, &status
, 0);
1825 status
= WEXITSTATUS (status
);
1832 __gnat_os_exit (int status
)
1837 /* Locate a regular file, give a Path value. */
1840 __gnat_locate_regular_file (char *file_name
, char *path_val
)
1843 int absolute
= __gnat_is_absolute_path (file_name
);
1845 /* Handle absolute pathnames. */
1848 if (__gnat_is_regular_file (file_name
))
1849 return xstrdup (file_name
);
1854 /* If file_name include directory separator(s), try it first as
1855 a path name relative to the current directory */
1856 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
1861 if (__gnat_is_regular_file (file_name
))
1862 return xstrdup (file_name
);
1869 /* The result has to be smaller than path_val + file_name. */
1870 char *file_path
= alloca (strlen (path_val
) + strlen (file_name
) + 2);
1874 for (; *path_val
== PATH_SEPARATOR
; path_val
++)
1880 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
1881 *ptr
++ = *path_val
++;
1884 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
1885 *++ptr
= DIR_SEPARATOR
;
1887 strcpy (++ptr
, file_name
);
1889 if (__gnat_is_regular_file (file_path
))
1890 return xstrdup (file_path
);
1897 /* Locate an executable given a Path argument. This routine is only used by
1898 gnatbl and should not be used otherwise. Use locate_exec_on_path
1902 __gnat_locate_exec (char *exec_name
, char *path_val
)
1904 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
1906 char *full_exec_name
1907 = alloca (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
1909 strcpy (full_exec_name
, exec_name
);
1910 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
1911 return __gnat_locate_regular_file (full_exec_name
, path_val
);
1914 return __gnat_locate_regular_file (exec_name
, path_val
);
1917 /* Locate an executable using the Systems default PATH. */
1920 __gnat_locate_exec_on_path (char *exec_name
)
1924 char *path_val
= "/VAXC$PATH";
1926 char *path_val
= getenv ("PATH");
1929 /* In Win32 systems we expand the PATH as for XP environment
1930 variables are not automatically expanded. */
1931 int len
= strlen (path_val
) * 3;
1932 char *expanded_path_val
= alloca (len
+ 1);
1934 DWORD res
= ExpandEnvironmentStrings (path_val
, expanded_path_val
, len
);
1938 path_val
= expanded_path_val
;
1942 apath_val
= alloca (strlen (path_val
) + 1);
1943 strcpy (apath_val
, path_val
);
1945 return __gnat_locate_exec (exec_name
, apath_val
);
1950 /* These functions are used to translate to and from VMS and Unix syntax
1951 file, directory and path specifications. */
1954 #define MAXNAMES 256
1955 #define NEW_CANONICAL_FILELIST_INCREMENT 64
1957 static char new_canonical_dirspec
[MAXPATH
];
1958 static char new_canonical_filespec
[MAXPATH
];
1959 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
1960 static unsigned new_canonical_filelist_index
;
1961 static unsigned new_canonical_filelist_in_use
;
1962 static unsigned new_canonical_filelist_allocated
;
1963 static char **new_canonical_filelist
;
1964 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
1965 static char new_host_dirspec
[MAXPATH
];
1966 static char new_host_filespec
[MAXPATH
];
1968 /* Routine is called repeatedly by decc$from_vms via
1969 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
1973 wildcard_translate_unix (char *name
)
1976 char buff
[MAXPATH
];
1978 strncpy (buff
, name
, MAXPATH
);
1979 buff
[MAXPATH
- 1] = (char) 0;
1980 ver
= strrchr (buff
, '.');
1982 /* Chop off the version. */
1986 /* Dynamically extend the allocation by the increment. */
1987 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
1989 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
1990 new_canonical_filelist
= (char **) xrealloc
1991 (new_canonical_filelist
,
1992 new_canonical_filelist_allocated
* sizeof (char *));
1995 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
2000 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2001 full translation and copy the results into a list (_init), then return them
2002 one at a time (_next). If onlydirs set, only expand directory files. */
2005 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
2008 char buff
[MAXPATH
];
2010 len
= strlen (filespec
);
2011 strncpy (buff
, filespec
, MAXPATH
);
2013 /* Only look for directories */
2014 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
2015 strncat (buff
, "*.dir", MAXPATH
);
2017 buff
[MAXPATH
- 1] = (char) 0;
2019 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
2021 /* Remove the .dir extension. */
2027 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
2029 ext
= strstr (new_canonical_filelist
[i
], ".dir");
2035 return new_canonical_filelist_in_use
;
2038 /* Return the next filespec in the list. */
2041 __gnat_to_canonical_file_list_next ()
2043 return new_canonical_filelist
[new_canonical_filelist_index
++];
2046 /* Free storage used in the wildcard expansion. */
2049 __gnat_to_canonical_file_list_free ()
2053 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
2054 free (new_canonical_filelist
[i
]);
2056 free (new_canonical_filelist
);
2058 new_canonical_filelist_in_use
= 0;
2059 new_canonical_filelist_allocated
= 0;
2060 new_canonical_filelist_index
= 0;
2061 new_canonical_filelist
= 0;
2064 /* Translate a VMS syntax directory specification in to Unix syntax. If
2065 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2066 found, return input string. Also translate a dirname that contains no
2067 slashes, in case it's a logical name. */
2070 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
2074 strcpy (new_canonical_dirspec
, "");
2075 if (strlen (dirspec
))
2079 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
2081 strncpy (new_canonical_dirspec
,
2082 (char *) decc$
translate_vms (dirspec
),
2085 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
2087 strncpy (new_canonical_dirspec
,
2088 (char *) decc$
translate_vms (dirspec1
),
2093 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
2097 len
= strlen (new_canonical_dirspec
);
2098 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
2099 strncat (new_canonical_dirspec
, "/", MAXPATH
);
2101 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
2103 return new_canonical_dirspec
;
2107 /* Translate a VMS syntax file specification into Unix syntax.
2108 If no indicators of VMS syntax found, return input string. */
2111 __gnat_to_canonical_file_spec (char *filespec
)
2113 strncpy (new_canonical_filespec
, "", MAXPATH
);
2115 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
2117 strncpy (new_canonical_filespec
,
2118 (char *) decc$
translate_vms (filespec
),
2123 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
2126 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
2128 return new_canonical_filespec
;
2131 /* Translate a VMS syntax path specification into Unix syntax.
2132 If no indicators of VMS syntax found, return input string. */
2135 __gnat_to_canonical_path_spec (char *pathspec
)
2137 char *curr
, *next
, buff
[MAXPATH
];
2142 /* If there are /'s, assume it's a Unix path spec and return. */
2143 if (strchr (pathspec
, '/'))
2146 new_canonical_pathspec
[0] = 0;
2151 next
= strchr (curr
, ',');
2153 next
= strchr (curr
, 0);
2155 strncpy (buff
, curr
, next
- curr
);
2156 buff
[next
- curr
] = 0;
2158 /* Check for wildcards and expand if present. */
2159 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
2163 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
2164 for (i
= 0; i
< dirs
; i
++)
2168 next_dir
= __gnat_to_canonical_file_list_next ();
2169 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
2171 /* Don't append the separator after the last expansion. */
2173 strncat (new_canonical_pathspec
, ":", MAXPATH
);
2176 __gnat_to_canonical_file_list_free ();
2179 strncat (new_canonical_pathspec
,
2180 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
2185 strncat (new_canonical_pathspec
, ":", MAXPATH
);
2189 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
2191 return new_canonical_pathspec
;
2194 static char filename_buff
[MAXPATH
];
2197 translate_unix (char *name
, int type
)
2199 strncpy (filename_buff
, name
, MAXPATH
);
2200 filename_buff
[MAXPATH
- 1] = (char) 0;
2204 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
2208 to_host_path_spec (char *pathspec
)
2210 char *curr
, *next
, buff
[MAXPATH
];
2215 /* Can't very well test for colons, since that's the Unix separator! */
2216 if (strchr (pathspec
, ']') || strchr (pathspec
, ','))
2219 new_host_pathspec
[0] = 0;
2224 next
= strchr (curr
, ':');
2226 next
= strchr (curr
, 0);
2228 strncpy (buff
, curr
, next
- curr
);
2229 buff
[next
- curr
] = 0;
2231 strncat (new_host_pathspec
, __gnat_to_host_dir_spec (buff
, 0), MAXPATH
);
2234 strncat (new_host_pathspec
, ",", MAXPATH
);
2238 new_host_pathspec
[MAXPATH
- 1] = (char) 0;
2240 return new_host_pathspec
;
2243 /* Translate a Unix syntax directory specification into VMS syntax. The
2244 PREFIXFLAG has no effect, but is kept for symmetry with
2245 to_canonical_dir_spec. If indicators of VMS syntax found, return input
2249 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2251 int len
= strlen (dirspec
);
2253 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
2254 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
2256 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
2257 return new_host_dirspec
;
2259 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
2261 new_host_dirspec
[len
- 1] = 0;
2265 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
2266 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
2267 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
2269 return new_host_dirspec
;
2272 /* Translate a Unix syntax file specification into VMS syntax.
2273 If indicators of VMS syntax found, return input string. */
2276 __gnat_to_host_file_spec (char *filespec
)
2278 strncpy (new_host_filespec
, "", MAXPATH
);
2279 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
2281 strncpy (new_host_filespec
, filespec
, MAXPATH
);
2285 decc$
to_vms (filespec
, translate_unix
, 1, 1);
2286 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
2289 new_host_filespec
[MAXPATH
- 1] = (char) 0;
2291 return new_host_filespec
;
2295 __gnat_adjust_os_resource_limits ()
2297 SYS$
ADJWSL (131072, 0);
2302 /* Dummy functions for Osint import for non-VMS systems. */
2305 __gnat_to_canonical_file_list_init
2306 (char *dirspec ATTRIBUTE_UNUSED
, int onlydirs ATTRIBUTE_UNUSED
)
2312 __gnat_to_canonical_file_list_next (void)
2318 __gnat_to_canonical_file_list_free (void)
2323 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2329 __gnat_to_canonical_file_spec (char *filespec
)
2335 __gnat_to_canonical_path_spec (char *pathspec
)
2341 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
2347 __gnat_to_host_file_spec (char *filespec
)
2353 __gnat_adjust_os_resource_limits (void)
2359 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
2360 to coordinate this with the EMX distribution. Consequently, we put the
2361 definition of dummy which is used for exception handling, here. */
2363 #if defined (__EMX__)
2367 #if defined (__mips_vxworks)
2371 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
2375 #if defined (CROSS_COMPILE) \
2376 || (! (defined (sparc) && defined (sun) && defined (__SVR4)) \
2377 && ! (defined (linux) && defined (i386)) \
2378 && ! defined (hpux) \
2379 && ! defined (_AIX) \
2380 && ! (defined (__alpha__) && defined (__osf__)) \
2381 && ! defined (__MINGW32__))
2383 /* Dummy function to satisfy g-trasym.o. Currently Solaris sparc, HP/UX,
2384 GNU/Linux x86, Tru64 & Windows provide a non-dummy version of this
2385 procedure in libaddr2line.a. */
2388 convert_addresses (void *addrs ATTRIBUTE_UNUSED
,
2389 int n_addr ATTRIBUTE_UNUSED
,
2390 void *buf ATTRIBUTE_UNUSED
,
2391 int *len ATTRIBUTE_UNUSED
)
2397 #if defined (_WIN32)
2398 int __gnat_argument_needs_quote
= 1;
2400 int __gnat_argument_needs_quote
= 0;
2403 /* This option is used to enable/disable object files handling from the
2404 binder file by the GNAT Project module. For example, this is disabled on
2405 Windows as it is already done by the mdll module. */
2406 #if defined (_WIN32)
2407 int __gnat_prj_add_obj_files
= 0;
2409 int __gnat_prj_add_obj_files
= 1;
2412 /* char used as prefix/suffix for environment variables */
2413 #if defined (_WIN32)
2414 char __gnat_environment_char
= '%';
2416 char __gnat_environment_char
= '$';
2419 /* This functions copy the file attributes from a source file to a
2422 mode = 0 : In this mode copy only the file time stamps (last access and
2423 last modification time stamps).
2425 mode = 1 : In this mode, time stamps and read/write/execute attributes are
2428 Returns 0 if operation was successful and -1 in case of error. */
2431 __gnat_copy_attribs (char *from
, char *to
, int mode
)
2433 #if defined (VMS) || defined (__vxworks)
2437 struct utimbuf tbuf
;
2439 if (stat (from
, &fbuf
) == -1)
2444 tbuf
.actime
= fbuf
.st_atime
;
2445 tbuf
.modtime
= fbuf
.st_mtime
;
2447 if (utime (to
, &tbuf
) == -1)
2454 if (chmod (to
, fbuf
.st_mode
) == -1)
2464 /* This function is installed in libgcc.a. */
2465 extern void __gnat_install_locks (void (*) (void), void (*) (void));
2467 /* This function offers a hook for libgnarl to set the
2468 locking subprograms for libgcc_eh.
2469 This is only needed on OpenVMS, since other platforms use standard
2470 --enable-threads=posix option, or similar. */
2473 __gnatlib_install_locks (void (*lock
) (void) ATTRIBUTE_UNUSED
,
2474 void (*unlock
) (void) ATTRIBUTE_UNUSED
)
2476 #if defined (IN_RTS) && defined (VMS)
2477 __gnat_install_locks (lock
, unlock
);
2478 /* There is a bootstrap path issue if adaint is build with this
2479 symbol unresolved for the stage1 compiler. Since the compiler
2480 does not use tasking, we simply make __gnatlib_install_locks
2481 a no-op in this case. */
2486 __gnat_lseek (int fd
, long offset
, int whence
)
2488 return (int) lseek (fd
, offset
, whence
);