1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
9 * C Implementation File *
11 * Copyright (C) 1992-2001, Free Software Foundation, Inc. *
13 * GNAT is free software; you can redistribute it and/or modify it under *
14 * terms of the GNU General Public License as published by the Free Soft- *
15 * ware Foundation; either version 2, or (at your option) any later ver- *
16 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
17 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
18 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
19 * for more details. You should have received a copy of the GNU General *
20 * Public License distributed with GNAT; see file COPYING. If not, write *
21 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
22 * MA 02111-1307, USA. *
24 * As a special exception, if you link this file with other files to *
25 * produce an executable, this file does not by itself cause the resulting *
26 * executable to be covered by the GNU General Public License. This except- *
27 * ion does not however invalidate any other reasons why the executable *
28 * file might be covered by the GNU Public License. *
30 * GNAT was originally developed by the GNAT team at New York University. *
31 * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
33 ****************************************************************************/
35 /* This file contains those routines named by Import pragmas in packages */
36 /* in the GNAT hierarchy (especially GNAT.OS_Lib) and in package Osint. */
37 /* Many of the subprograms in OS_Lib import standard library calls */
38 /* directly. This file contains all other routines. */
41 /* No need to redefine exit here */
45 /* We want to use the POSIX variants of include files. */
49 #if defined (__mips_vxworks)
51 #endif /* __mips_vxworks */
62 /* We don't have libiberty, so us malloc. */
63 #define xmalloc(S) malloc (S)
70 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
81 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
82 defined in the current system. On DOS-like systems these flags control
83 whether the file is opened/created in text-translation mode (CR/LF in
84 external file mapped to LF in internal file), but in Unix-like systems,
85 no text translation is required, so these flags have no effect. */
103 #ifndef HOST_EXECUTABLE_SUFFIX
104 #define HOST_EXECUTABLE_SUFFIX ""
107 #ifndef HOST_OBJECT_SUFFIX
108 #define HOST_OBJECT_SUFFIX ".o"
111 #ifndef PATH_SEPARATOR
112 #define PATH_SEPARATOR ':'
115 #ifndef DIR_SEPARATOR
116 #define DIR_SEPARATOR '/'
119 char __gnat_dir_separator
= DIR_SEPARATOR
;
121 char __gnat_path_separator
= PATH_SEPARATOR
;
123 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
124 the base filenames that libraries specified with -lsomelib options
125 may have. This is used by GNATMAKE to check whether an executable
126 is up-to-date or not. The syntax is
128 library_template ::= { pattern ; } pattern NUL
129 pattern ::= [ prefix ] * [ postfix ]
131 These should only specify names of static libraries as it makes
132 no sense to determine at link time if dynamic-link libraries are
133 up to date or not. Any libraries that are not found are supposed
136 * if they are needed but not present, the link
139 * otherwise they are libraries in the system paths and so
140 they are considered part of the system and not checked
143 ??? This should be part of a GNAT host-specific compiler
144 file instead of being included in all user applications
145 as well. This is only a temporary work-around for 3.11b. */
147 #ifndef GNAT_LIBRARY_TEMPLATE
149 #define GNAT_LIBRARY_TEMPLATE "*.a"
151 #define GNAT_LIBRARY_TEMPLATE "*.olb"
153 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
157 const char *__gnat_library_template
= GNAT_LIBRARY_TEMPLATE
;
159 /* The following macro HAVE_READDIR_R should be defined if the
160 system provides the routine readdir_r */
161 #undef HAVE_READDIR_R
164 __gnat_to_gm_time (p_time
, p_year
, p_month
, p_day
, p_hours
, p_mins
, p_secs
)
166 int *p_year
, *p_month
, *p_day
, *p_hours
, *p_mins
, *p_secs
;
169 time_t time
= *p_time
;
172 /* On Windows systems, the time is sometimes rounded up to the nearest
173 even second, so if the number of seconds is odd, increment it. */
178 res
= gmtime (&time
);
182 *p_year
= res
->tm_year
;
183 *p_month
= res
->tm_mon
;
184 *p_day
= res
->tm_mday
;
185 *p_hours
= res
->tm_hour
;
186 *p_mins
= res
->tm_min
;
187 *p_secs
= res
->tm_sec
;
190 *p_year
= *p_month
= *p_day
= *p_hours
= *p_mins
= *p_secs
= 0;
193 /* Place the contents of the symbolic link named PATH in the buffer BUF,
194 which has size BUFSIZ. If PATH is a symbolic link, then return the number
195 of characters of its content in BUF. Otherwise, return -1. For Windows,
196 OS/2 and vxworks, always return -1. */
199 __gnat_readlink (path
, buf
, bufsiz
)
204 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
206 #elif defined (__INTERIX) || defined (VMS)
208 #elif defined (__vxworks)
211 return readlink (path
, buf
, bufsiz
);
215 /* Creates a symbolic link named newpath
216 which contains the string oldpath.
217 If newpath exists it will NOT be overwritten.
218 For Windows, OS/2, vxworks, Interix and VMS, always retur -1. */
221 __gnat_symlink (oldpath
, newpath
)
225 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
227 #elif defined (__INTERIX) || defined (VMS)
229 #elif defined (__vxworks)
232 return symlink (oldpath
, newpath
);
236 /* Try to lock a file, return 1 if success */
238 #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32)
240 /* Version that does not use link. */
243 __gnat_try_lock (dir
, file
)
247 char full_path
[256];
250 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
251 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
259 #elif defined (__EMX__) || defined (VMS)
261 /* More cases that do not use link; identical code, to solve too long
265 __gnat_try_lock (dir
, file
)
269 char full_path
[256];
272 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
273 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
282 /* Version using link(), more secure over NFS. */
285 __gnat_try_lock (dir
, file
)
289 char full_path
[256];
290 char temp_file
[256];
291 struct stat stat_result
;
294 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
295 sprintf (temp_file
, "%s-%d-%d", dir
, getpid(), getppid ());
297 /* Create the temporary file and write the process number */
298 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
304 /* Link it with the new file */
305 link (temp_file
, full_path
);
307 /* Count the references on the old one. If we have a count of two, then
308 the link did succeed. Remove the temporary file before returning. */
309 __gnat_stat (temp_file
, &stat_result
);
311 return stat_result
.st_nlink
== 2;
315 /* Return the maximum file name length. */
318 __gnat_get_maximum_file_name_length ()
323 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
332 /* Return the default switch character. */
335 __gnat_get_switch_character ()
337 /* Under MSDOS, the switch character is not normally a hyphen, but this is
338 the convention DJGPP uses. Similarly under OS2, the switch character is
339 not normally a hypen, but this is the convention EMX uses. */
344 /* Return nonzero if file names are case sensitive. */
347 __gnat_get_file_names_case_sensitive ()
349 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined(WINNT)
357 __gnat_get_default_identifier_character_set ()
359 #if defined (__EMX__) || defined (MSDOS)
366 /* Return the current working directory */
369 __gnat_get_current_dir (dir
, length
)
374 /* Force Unix style, which is what GNAT uses internally. */
375 getcwd (dir
, *length
, 0);
377 getcwd (dir
, *length
);
380 *length
= strlen (dir
);
382 dir
[*length
] = DIR_SEPARATOR
;
384 dir
[*length
] = '\0';
387 /* Return the suffix for object files. */
390 __gnat_get_object_suffix_ptr (len
, value
)
394 *value
= HOST_OBJECT_SUFFIX
;
399 *len
= strlen (*value
);
404 /* Return the suffix for executable files */
407 __gnat_get_executable_suffix_ptr (len
, value
)
411 *value
= HOST_EXECUTABLE_SUFFIX
;
415 *len
= strlen (*value
);
420 /* Return the suffix for debuggable files. Usually this is the same as the
421 executable extension. */
424 __gnat_get_debuggable_suffix_ptr (len
, value
)
429 *value
= HOST_EXECUTABLE_SUFFIX
;
431 /* On DOS, the extensionless COFF file is what gdb likes. */
438 *len
= strlen (*value
);
444 __gnat_open_read (path
, fmode
)
449 int o_fmode
= O_BINARY
;
455 /* Optional arguments mbc,deq,fop increase read performance */
456 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
457 "mbc=16", "deq=64", "fop=tef");
458 #elif defined(__vxworks)
459 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
461 fd
= open (path
, O_RDONLY
| o_fmode
);
463 return fd
< 0 ? -1 : fd
;
466 #if defined (__EMX__)
467 #define PERM (S_IREAD | S_IWRITE)
469 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
473 __gnat_open_rw (path
, fmode
)
478 int o_fmode
= O_BINARY
;
484 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
485 "mbc=16", "deq=64", "fop=tef");
487 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
490 return fd
< 0 ? -1 : fd
;
494 __gnat_open_create (path
, fmode
)
499 int o_fmode
= O_BINARY
;
505 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
506 "mbc=16", "deq=64", "fop=tef");
508 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
511 return fd
< 0 ? -1 : fd
;
515 __gnat_open_append (path
, fmode
)
520 int o_fmode
= O_BINARY
;
526 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
527 "mbc=16", "deq=64", "fop=tef");
529 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
532 return fd
< 0 ? -1 : fd
;
535 /* Open a new file. Return error (-1) if the file already exists. */
538 __gnat_open_new (path
, fmode
)
543 int o_fmode
= O_BINARY
;
549 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
550 "mbc=16", "deq=64", "fop=tef");
552 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
555 return fd
< 0 ? -1 : fd
;
558 /* Open a new temp file. Return error (-1) if the file already exists.
559 Special options for VMS allow the file to be shared between parent and
560 child processes, however they really slow down output. Used in
564 __gnat_open_new_temp (path
, fmode
)
569 int o_fmode
= O_BINARY
;
571 strcpy (path
, "GNAT-XXXXXX");
573 #if defined (linux) && !defined (__vxworks)
574 return mkstemp (path
);
577 if (mktemp (path
) == NULL
)
585 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
586 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
587 "mbc=16", "deq=64", "fop=tef");
589 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
592 return fd
< 0 ? -1 : fd
;
596 __gnat_mkdir (dir_name
)
599 /* On some systems, mkdir has two args and on some it has one. If we
600 are being built as part of the compiler, autoconf has figured that out
601 for us. Otherwise, we have to do it ourselves. */
603 return mkdir (dir_name
, S_IRWXU
| S_IRWXG
| S_IRWXO
);
605 #if defined (_WIN32) || defined (__vxworks)
606 return mkdir (dir_name
);
608 return mkdir (dir_name
, S_IRWXU
| S_IRWXG
| S_IRWXO
);
613 /* Return the number of bytes in the specified file. */
616 __gnat_file_length (fd
)
622 ret
= fstat (fd
, &statbuf
);
623 if (ret
|| !S_ISREG (statbuf
.st_mode
))
626 return (statbuf
.st_size
);
629 /* Create a temporary filename and put it in string pointed to by
633 __gnat_tmp_name (tmp_filename
)
640 /* tempnam tries to create a temporary file in directory pointed to by
641 TMP environment variable, in c:\temp if TMP is not set, and in
642 directory specified by P_tmpdir in stdio.h if c:\temp does not
643 exist. The filename will be created with the prefix "gnat-". */
645 pname
= (char *) tempnam ("c:\\temp", "gnat-");
647 /* if pname start with a back slash and not path information it means that
648 the filename is valid for the current working directory */
650 if (pname
[0] == '\\')
652 strcpy (tmp_filename
, ".\\");
653 strcat (tmp_filename
, pname
+1);
656 strcpy (tmp_filename
, pname
);
660 #elif defined (linux)
661 char *tmpdir
= getenv ("TMPDIR");
664 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
666 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
668 close (mkstemp(tmp_filename
));
670 tmpnam (tmp_filename
);
674 /* Read the next entry in a directory. The returned string points somewhere
678 __gnat_readdir (dirp
, buffer
)
682 /* If possible, try to use the thread-safe version. */
683 #ifdef HAVE_READDIR_R
684 if (readdir_r (dirp
, buffer
) != NULL
)
685 return ((struct dirent
*) buffer
)->d_name
;
690 struct dirent
*dirent
= readdir (dirp
);
694 strcpy (buffer
, dirent
->d_name
);
703 /* Returns 1 if readdir is thread safe, 0 otherwise. */
706 __gnat_readdir_is_thread_safe ()
708 #ifdef HAVE_READDIR_R
717 /* Returns the file modification timestamp using Win32 routines which are
718 immune against daylight saving time change. It is in fact not possible to
719 use fstat for this purpose as the DST modify the st_mtime field of the
730 unsigned long long timestamp
;
732 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
733 unsigned long long offset
= 11644473600;
735 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
736 since <Jan 1st 1601>. This function must return the number of seconds
737 since <Jan 1st 1970>. */
739 res
= GetFileTime (h
, &t_create
, &t_access
, &t_write
);
741 timestamp
= (((long long) t_write
.dwHighDateTime
<< 32)
742 + t_write
.dwLowDateTime
);
744 timestamp
= timestamp
/ 10000000 - offset
;
746 return (time_t) timestamp
;
750 /* Return a GNAT time stamp given a file name. */
753 __gnat_file_time_name (name
)
758 #if defined (__EMX__) || defined (MSDOS)
759 int fd
= open (name
, O_RDONLY
| O_BINARY
);
760 time_t ret
= __gnat_file_time_fd (fd
);
764 #elif defined (_WIN32)
765 HANDLE h
= CreateFile (name
, GENERIC_READ
, FILE_SHARE_READ
, 0,
766 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
, 0);
767 time_t ret
= win32_filetime (h
);
772 (void) __gnat_stat (name
, &statbuf
);
774 /* VMS has file versioning */
775 return statbuf
.st_ctime
;
777 return statbuf
.st_mtime
;
782 /* Return a GNAT time stamp given a file descriptor. */
785 __gnat_file_time_fd (fd
)
788 /* The following workaround code is due to the fact that under EMX and
789 DJGPP fstat attempts to convert time values to GMT rather than keep the
790 actual OS timestamp of the file. By using the OS2/DOS functions directly
791 the GNAT timestamp are independent of this behavior, which is desired to
792 facilitate the distribution of GNAT compiled libraries. */
794 #if defined (__EMX__) || defined (MSDOS)
798 int ret
= DosQueryFileInfo (fd
, 1, (unsigned char *) &fs
,
799 sizeof (FILESTATUS
));
801 unsigned file_year
= fs
.fdateLastWrite
.year
;
802 unsigned file_month
= fs
.fdateLastWrite
.month
;
803 unsigned file_day
= fs
.fdateLastWrite
.day
;
804 unsigned file_hour
= fs
.ftimeLastWrite
.hours
;
805 unsigned file_min
= fs
.ftimeLastWrite
.minutes
;
806 unsigned file_tsec
= fs
.ftimeLastWrite
.twosecs
;
810 int ret
= getftime (fd
, &fs
);
812 unsigned file_year
= fs
.ft_year
;
813 unsigned file_month
= fs
.ft_month
;
814 unsigned file_day
= fs
.ft_day
;
815 unsigned file_hour
= fs
.ft_hour
;
816 unsigned file_min
= fs
.ft_min
;
817 unsigned file_tsec
= fs
.ft_tsec
;
820 /* Calculate the seconds since epoch from the time components. First count
821 the whole days passed. The value for years returned by the DOS and OS2
822 functions count years from 1980, so to compensate for the UNIX epoch which
823 begins in 1970 start with 10 years worth of days and add days for each
824 four year period since then. */
827 int cum_days
[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
828 int days_passed
= 3652 + (file_year
/ 4) * 1461;
829 int years_since_leap
= file_year
% 4;
831 if (years_since_leap
== 1)
833 else if (years_since_leap
== 2)
835 else if (years_since_leap
== 3)
841 days_passed
+= cum_days
[file_month
- 1];
842 if (years_since_leap
== 0 && file_year
!= 20 && file_month
> 2)
845 days_passed
+= file_day
- 1;
847 /* OK - have whole days. Multiply -- then add in other parts. */
849 tot_secs
= days_passed
* 86400;
850 tot_secs
+= file_hour
* 3600;
851 tot_secs
+= file_min
* 60;
852 tot_secs
+= file_tsec
* 2;
855 #elif defined (_WIN32)
856 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
857 time_t ret
= win32_filetime (h
);
864 (void) fstat (fd
, &statbuf
);
867 /* VMS has file versioning */
868 return statbuf
.st_ctime
;
870 return statbuf
.st_mtime
;
876 __gnat_get_env_value_ptr (name
, len
, value
)
881 *value
= getenv (name
);
885 *len
= strlen (*value
);
890 /* VMS specific declarations for set_env_value. */
894 static char *to_host_path_spec
PROTO ((char *));
898 unsigned short len
, mbz
;
904 unsigned short len
, code
;
906 unsigned short *retlen_adr
;
912 __gnat_set_env_value (name
, value
)
919 struct descriptor_s name_desc
;
920 /* Put in JOB table for now, so that the project stuff at least works */
921 struct descriptor_s table_desc
= {7, 0, "LNM$JOB"};
922 char *host_pathspec
= to_host_path_spec (value
);
924 int num_dirs_in_pathspec
= 1;
927 if (*host_pathspec
== 0)
930 name_desc
.len
= strlen (name
);
932 name_desc
.adr
= name
;
937 num_dirs_in_pathspec
++;
941 ile_s
*ile_array
= alloca (sizeof (ile_s
) * (num_dirs_in_pathspec
+ 1));
942 char *copy_pathspec
= alloca (strlen (host_pathspec
) + 1);
945 strcpy (copy_pathspec
, host_pathspec
);
946 curr
= copy_pathspec
;
947 for (i
= 0; i
< num_dirs_in_pathspec
; i
++)
949 next
= strchr (curr
, ',');
951 next
= strchr (curr
, 0);
954 ile_array
[i
].len
= strlen (curr
);
956 /* Code 2 from lnmdef.h means its a string */
957 ile_array
[i
].code
= 2;
958 ile_array
[i
].adr
= curr
;
960 /* retlen_adr is ignored */
961 ile_array
[i
].retlen_adr
= 0;
965 /* Terminating item must be zero */
966 ile_array
[i
].len
= 0;
967 ile_array
[i
].code
= 0;
968 ile_array
[i
].adr
= 0;
969 ile_array
[i
].retlen_adr
= 0;
971 status
= LIB$
SET_LOGICAL (&name_desc
, 0, &table_desc
, 0, ile_array
);
972 if ((status
& 1) != 1)
977 int size
= strlen (name
) + strlen (value
) + 2;
980 expression
= (char *) xmalloc (size
* sizeof (char));
982 sprintf (expression
, "%s=%s", name
, value
);
991 /* Get the list of installed standard libraries from the
992 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
996 __gnat_get_libraries_from_registry ()
998 char *result
= (char *) "";
1000 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_COMPILE)
1003 DWORD name_size
, value_size
;
1010 /* First open the key. */
1011 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1013 if (res
== ERROR_SUCCESS
)
1014 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1015 KEY_READ
, ®_key
);
1017 if (res
== ERROR_SUCCESS
)
1018 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1020 if (res
== ERROR_SUCCESS
)
1021 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1023 /* If the key exists, read out all the values in it and concatenate them
1025 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1027 value_size
= name_size
= 256;
1028 res
= RegEnumValue (reg_key
, index
, name
, &name_size
, 0,
1029 &type
, value
, &value_size
);
1031 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1033 char *old_result
= result
;
1035 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1036 strcpy (result
, old_result
);
1037 strcat (result
, value
);
1038 strcat (result
, ";");
1042 /* Remove the trailing ";". */
1044 result
[strlen (result
) - 1] = 0;
1051 __gnat_stat (name
, statbuf
)
1053 struct stat
*statbuf
;
1056 /* Under Windows the directory name for the stat function must not be
1057 terminated by a directory separator except if just after a drive name. */
1058 int name_len
= strlen (name
);
1059 char last_char
= name
[name_len
- 1];
1060 char win32_name
[4096];
1062 strcpy (win32_name
, name
);
1064 while (name_len
> 1 && (last_char
== '\\' || last_char
== '/'))
1066 win32_name
[name_len
- 1] = '\0';
1068 last_char
= win32_name
[name_len
- 1];
1071 if (name_len
== 2 && win32_name
[1] == ':')
1072 strcat (win32_name
, "\\");
1074 return stat (win32_name
, statbuf
);
1077 return stat (name
, statbuf
);
1082 __gnat_file_exists (name
)
1085 struct stat statbuf
;
1087 return !__gnat_stat (name
, &statbuf
);
1091 __gnat_is_absolute_path (name
)
1094 return (*name
== '/' || *name
== DIR_SEPARATOR
1095 #if defined(__EMX__) || defined(MSDOS) || defined(WINNT)
1096 || strlen (name
) > 1 && isalpha (name
[0]) && name
[1] == ':'
1102 __gnat_is_regular_file (name
)
1106 struct stat statbuf
;
1108 ret
= __gnat_stat (name
, &statbuf
);
1109 return (!ret
&& S_ISREG (statbuf
.st_mode
));
1113 __gnat_is_directory (name
)
1117 struct stat statbuf
;
1119 ret
= __gnat_stat (name
, &statbuf
);
1120 return (!ret
&& S_ISDIR (statbuf
.st_mode
));
1124 __gnat_is_writable_file (name
)
1129 struct stat statbuf
;
1131 ret
= __gnat_stat (name
, &statbuf
);
1132 mode
= statbuf
.st_mode
& S_IWUSR
;
1133 return (!ret
&& mode
);
1137 /* Defined in VMS header files */
1138 #define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
1139 LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1)
1142 #if defined (sun) && defined (__SVR4)
1143 /* Using fork on Solaris will duplicate all the threads. fork1, which
1144 duplicates only the active thread, must be used instead, or spawning
1145 subprocess from a program with tasking will lead into numerous problems. */
1150 __gnat_portable_spawn (args
)
1157 #if defined (MSDOS) || defined (_WIN32)
1158 status
= spawnvp (P_WAIT
, args
[0], args
);
1164 #elif defined(__vxworks) /* Mods for VxWorks */
1165 pid
= sp (args
[0], args
); /* Spawn process and save pid */
1169 while (taskIdVerify(pid
) >= 0)
1170 /* Wait until spawned task is complete then continue. */
1175 pid
= spawnvp (P_NOWAIT
, args
[0], args
);
1183 if (pid
== 0 && execv (args
[0], args
) != 0)
1188 finished
= waitpid (pid
, &status
, 0);
1190 if (finished
!= pid
|| WIFEXITED (status
) == 0)
1193 return WEXITSTATUS (status
);
1198 /* WIN32 code to implement a wait call that wait for any child process */
1201 /* Synchronization code, to be thread safe. */
1203 static CRITICAL_SECTION plist_cs
;
1206 __gnat_plist_init ()
1208 InitializeCriticalSection (&plist_cs
);
1214 EnterCriticalSection (&plist_cs
);
1220 LeaveCriticalSection (&plist_cs
);
1223 typedef struct _process_list
1226 struct _process_list
*next
;
1229 static Process_List
*PLIST
= NULL
;
1231 static int plist_length
= 0;
1239 pl
= (Process_List
*) xmalloc (sizeof (Process_List
));
1243 /* -------------------- critical section -------------------- */
1248 /* -------------------- critical section -------------------- */
1253 void remove_handle (h
)
1256 Process_List
*pl
, *prev
;
1260 /* -------------------- critical section -------------------- */
1269 prev
->next
= pl
->next
;
1281 /* -------------------- critical section -------------------- */
1287 win32_no_block_spawn (command
, args
)
1293 PROCESS_INFORMATION PI
;
1294 SECURITY_ATTRIBUTES SA
;
1296 char full_command
[2000];
1300 SI
.cb
= sizeof (STARTUPINFO
);
1301 SI
.lpReserved
= NULL
;
1302 SI
.lpReserved2
= NULL
;
1303 SI
.lpDesktop
= NULL
;
1307 SI
.wShowWindow
= SW_HIDE
;
1309 /* Security attributes. */
1310 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
1311 SA
.bInheritHandle
= TRUE
;
1312 SA
.lpSecurityDescriptor
= NULL
;
1314 /* Prepare the command string. */
1315 strcpy (full_command
, command
);
1316 strcat (full_command
, " ");
1321 strcat (full_command
, args
[k
]);
1322 strcat (full_command
, " ");
1326 result
= CreateProcess (NULL
, (char *) full_command
, &SA
, NULL
, TRUE
,
1327 NORMAL_PRIORITY_CLASS
, NULL
, NULL
, &SI
, &PI
);
1331 add_handle (PI
.hProcess
);
1332 CloseHandle (PI
.hThread
);
1333 return (int) PI
.hProcess
;
1350 if (plist_length
== 0)
1356 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * plist_length
);
1361 /* -------------------- critical section -------------------- */
1368 /* -------------------- critical section -------------------- */
1372 res
= WaitForMultipleObjects (plist_length
, hl
, FALSE
, INFINITE
);
1373 h
= hl
[res
- WAIT_OBJECT_0
];
1378 GetExitCodeProcess (h
, &exitcode
);
1381 *status
= (int) exitcode
;
1388 __gnat_portable_no_block_spawn (args
)
1393 #if defined (__EMX__) || defined (MSDOS)
1395 /* ??? For PC machines I (Franco) don't know the system calls to implement
1396 this routine. So I'll fake it as follows. This routine will behave
1397 exactly like the blocking portable_spawn and will systematically return
1398 a pid of 0 unless the spawned task did not complete successfully, in
1399 which case we return a pid of -1. To synchronize with this the
1400 portable_wait below systematically returns a pid of 0 and reports that
1401 the subprocess terminated successfully. */
1403 if (spawnvp (P_WAIT
, args
[0], args
) != 0)
1406 #elif defined (_WIN32)
1408 pid
= win32_no_block_spawn (args
[0], args
);
1411 #elif defined (__vxworks) /* Mods for VxWorks */
1412 pid
= sp (args
[0], args
); /* Spawn task and then return (no waiting) */
1421 if (pid
== 0 && execv (args
[0], args
) != 0)
1429 __gnat_portable_wait (process_status
)
1430 int *process_status
;
1435 #if defined (_WIN32)
1437 pid
= win32_wait (&status
);
1439 #elif defined (__EMX__) || defined (MSDOS)
1440 /* ??? See corresponding comment in portable_no_block_spawn. */
1442 #elif defined (__vxworks)
1443 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
1448 /* Wait doesn't do the right thing on VMS */
1449 pid
= waitpid (-1, &status
, 0);
1451 pid
= wait (&status
);
1453 status
= status
& 0xffff;
1456 *process_status
= status
;
1461 __gnat_os_exit (status
)
1465 /* Exit without changing 0 to 1 */
1466 __posix_exit (status
);
1472 /* Locate a regular file, give a Path value */
1475 __gnat_locate_regular_file (file_name
, path_val
)
1481 /* Handle absolute pathnames. */
1482 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
1486 #if defined(__EMX__) || defined(MSDOS) || defined(WINNT)
1487 || isalpha (file_name
[0]) && file_name
[1] == ':'
1491 if (__gnat_is_regular_file (file_name
))
1492 return xstrdup (file_name
);
1501 /* The result has to be smaller than path_val + file_name. */
1502 char *file_path
= alloca (strlen (path_val
) + strlen (file_name
) + 2);
1506 for (; *path_val
== PATH_SEPARATOR
; path_val
++)
1512 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
1513 *ptr
++ = *path_val
++;
1516 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
1517 *++ptr
= DIR_SEPARATOR
;
1519 strcpy (++ptr
, file_name
);
1521 if (__gnat_is_regular_file (file_path
))
1522 return xstrdup (file_path
);
1530 /* Locate an executable given a Path argument. This routine is only used by
1531 gnatbl and should not be used otherwise. Use locate_exec_on_path
1535 __gnat_locate_exec (exec_name
, path_val
)
1539 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
1541 char *full_exec_name
1542 = alloca (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
1544 strcpy (full_exec_name
, exec_name
);
1545 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
1546 return __gnat_locate_regular_file (full_exec_name
, path_val
);
1549 return __gnat_locate_regular_file (exec_name
, path_val
);
1552 /* Locate an executable using the Systems default PATH */
1555 __gnat_locate_exec_on_path (exec_name
)
1559 char *path_val
= "/VAXC$PATH";
1561 char *path_val
= getenv ("PATH");
1563 char *apath_val
= alloca (strlen (path_val
) + 1);
1565 strcpy (apath_val
, path_val
);
1566 return __gnat_locate_exec (exec_name
, apath_val
);
1571 /* These functions are used to translate to and from VMS and Unix syntax
1572 file, directory and path specifications. */
1574 #define MAXNAMES 256
1575 #define NEW_CANONICAL_FILELIST_INCREMENT 64
1577 static char new_canonical_dirspec
[255];
1578 static char new_canonical_filespec
[255];
1579 static char new_canonical_pathspec
[MAXNAMES
*255];
1580 static unsigned new_canonical_filelist_index
;
1581 static unsigned new_canonical_filelist_in_use
;
1582 static unsigned new_canonical_filelist_allocated
;
1583 static char **new_canonical_filelist
;
1584 static char new_host_pathspec
[MAXNAMES
*255];
1585 static char new_host_dirspec
[255];
1586 static char new_host_filespec
[255];
1588 /* Routine is called repeatedly by decc$from_vms via
1589 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
1593 wildcard_translate_unix (name
)
1599 strcpy (buff
, name
);
1600 ver
= strrchr (buff
, '.');
1602 /* Chop off the version */
1606 /* Dynamically extend the allocation by the increment */
1607 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
1609 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
1610 new_canonical_filelist
= (char **) realloc
1611 (new_canonical_filelist
,
1612 new_canonical_filelist_allocated
* sizeof (char *));
1615 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
1620 /* Translate a wildcard VMS file spec into a list of Unix file
1621 specs. First do full translation and copy the results into a list (_init),
1622 then return them one at a time (_next). If onlydirs set, only expand
1626 __gnat_to_canonical_file_list_init (filespec
, onlydirs
)
1633 len
= strlen (filespec
);
1634 strcpy (buff
, filespec
);
1636 /* Only look for directories */
1637 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
1638 strcat (buff
, "*.dir");
1640 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
1642 /* Remove the .dir extension */
1648 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
1650 ext
= strstr (new_canonical_filelist
[i
], ".dir");
1656 return new_canonical_filelist_in_use
;
1659 /* Return the next filespec in the list */
1662 __gnat_to_canonical_file_list_next ()
1664 return new_canonical_filelist
[new_canonical_filelist_index
++];
1667 /* Free up storage used in the wildcard expansion */
1670 __gnat_to_canonical_file_list_free ()
1674 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
1675 free (new_canonical_filelist
[i
]);
1677 free (new_canonical_filelist
);
1679 new_canonical_filelist_in_use
= 0;
1680 new_canonical_filelist_allocated
= 0;
1681 new_canonical_filelist_index
= 0;
1682 new_canonical_filelist
= 0;
1685 /* Translate a VMS syntax directory specification in to Unix syntax.
1686 If prefixflag is set, append an underscore "/". If no indicators
1687 of VMS syntax found, return input string. Also translate a dirname
1688 that contains no slashes, in case it's a logical name. */
1691 __gnat_to_canonical_dir_spec (dirspec
,prefixflag
)
1697 strcpy (new_canonical_dirspec
, "");
1698 if (strlen (dirspec
))
1702 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
1703 strcpy (new_canonical_dirspec
, (char *) decc$
translate_vms (dirspec
));
1704 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
1705 strcpy (new_canonical_dirspec
, (char *) decc$
translate_vms (dirspec1
));
1707 strcpy (new_canonical_dirspec
, dirspec
);
1710 len
= strlen (new_canonical_dirspec
);
1711 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
1712 strcat (new_canonical_dirspec
, "/");
1714 return new_canonical_dirspec
;
1718 /* Translate a VMS syntax file specification into Unix syntax.
1719 If no indicators of VMS syntax found, return input string. */
1722 __gnat_to_canonical_file_spec (filespec
)
1725 strcpy (new_canonical_filespec
, "");
1726 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
1727 strcpy (new_canonical_filespec
, (char *) decc$
translate_vms (filespec
));
1729 strcpy (new_canonical_filespec
, filespec
);
1731 return new_canonical_filespec
;
1734 /* Translate a VMS syntax path specification into Unix syntax.
1735 If no indicators of VMS syntax found, return input string. */
1738 __gnat_to_canonical_path_spec (pathspec
)
1741 char *curr
, *next
, buff
[256];
1746 /* If there are /'s, assume it's a Unix path spec and return */
1747 if (strchr (pathspec
, '/'))
1750 new_canonical_pathspec
[0] = 0;
1755 next
= strchr (curr
, ',');
1757 next
= strchr (curr
, 0);
1759 strncpy (buff
, curr
, next
- curr
);
1760 buff
[next
- curr
] = 0;
1762 /* Check for wildcards and expand if present */
1763 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
1767 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
1768 for (i
= 0; i
< dirs
; i
++)
1772 next_dir
= __gnat_to_canonical_file_list_next ();
1773 strcat (new_canonical_pathspec
, next_dir
);
1775 /* Don't append the separator after the last expansion */
1777 strcat (new_canonical_pathspec
, ":");
1780 __gnat_to_canonical_file_list_free ();
1783 strcat (new_canonical_pathspec
,
1784 __gnat_to_canonical_dir_spec (buff
, 0));
1789 strcat (new_canonical_pathspec
, ":");
1793 return new_canonical_pathspec
;
1796 static char filename_buff
[256];
1799 translate_unix (name
, type
)
1803 strcpy (filename_buff
, name
);
1807 /* Translate a Unix syntax path spec into a VMS style (comma separated
1808 list of directories. Only used in this file so make it static */
1811 to_host_path_spec (pathspec
)
1814 char *curr
, *next
, buff
[256];
1819 /* Can't very well test for colons, since that's the Unix separator! */
1820 if (strchr (pathspec
, ']') || strchr (pathspec
, ','))
1823 new_host_pathspec
[0] = 0;
1828 next
= strchr (curr
, ':');
1830 next
= strchr (curr
, 0);
1832 strncpy (buff
, curr
, next
- curr
);
1833 buff
[next
- curr
] = 0;
1835 strcat (new_host_pathspec
, __gnat_to_host_dir_spec (buff
, 0));
1838 strcat (new_host_pathspec
, ",");
1842 return new_host_pathspec
;
1845 /* Translate a Unix syntax directory specification into VMS syntax.
1846 The prefixflag has no effect, but is kept for symmetry with
1847 to_canonical_dir_spec.
1848 If indicators of VMS syntax found, return input string. */
1851 __gnat_to_host_dir_spec (dirspec
, prefixflag
)
1855 int len
= strlen (dirspec
);
1857 strcpy (new_host_dirspec
, dirspec
);
1859 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
1860 return new_host_dirspec
;
1862 while (len
> 1 && new_host_dirspec
[len
-1] == '/')
1864 new_host_dirspec
[len
-1] = 0;
1868 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
1869 strcpy (new_host_dirspec
, filename_buff
);
1871 return new_host_dirspec
;
1875 /* Translate a Unix syntax file specification into VMS syntax.
1876 If indicators of VMS syntax found, return input string. */
1879 __gnat_to_host_file_spec (filespec
)
1882 strcpy (new_host_filespec
, "");
1883 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
1884 strcpy (new_host_filespec
, filespec
);
1887 decc$
to_vms (filespec
, translate_unix
, 1, 1);
1888 strcpy (new_host_filespec
, filename_buff
);
1891 return new_host_filespec
;
1895 __gnat_adjust_os_resource_limits ()
1897 SYS$
ADJWSL (131072, 0);
1902 /* Dummy functions for Osint import for non-VMS systems */
1905 __gnat_to_canonical_file_list_init (dirspec
, onlydirs
)
1906 char *dirspec ATTRIBUTE_UNUSED
;
1907 int onlydirs ATTRIBUTE_UNUSED
;
1913 __gnat_to_canonical_file_list_next ()
1919 __gnat_to_canonical_file_list_free ()
1924 __gnat_to_canonical_dir_spec (dirspec
, prefixflag
)
1926 int prefixflag ATTRIBUTE_UNUSED
;
1932 __gnat_to_canonical_file_spec (filespec
)
1939 __gnat_to_canonical_path_spec (pathspec
)
1946 __gnat_to_host_dir_spec (dirspec
, prefixflag
)
1948 int prefixflag ATTRIBUTE_UNUSED
;
1954 __gnat_to_host_file_spec (filespec
)
1961 __gnat_adjust_os_resource_limits ()
1967 /* for EMX, we cannot include dummy in libgcc, since it is too difficult
1968 to coordinate this with the EMX distribution. Consequently, we put the
1969 definition of dummy() which is used for exception handling, here */
1971 #if defined (__EMX__)
1975 #if defined (__mips_vxworks)
1978 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
1982 #if defined (CROSS_COMPILE) \
1983 || (! (defined (sparc) && defined (sun) && defined (__SVR4)) \
1984 && ! defined (linux) \
1985 && ! defined (sgi) \
1986 && ! defined (hpux) \
1987 && ! (defined (__alpha__) && defined (__osf__)) \
1988 && ! defined (__MINGW32__))
1989 /* Dummy function to satisfy g-trasym.o.
1990 Currently Solaris sparc, HP/UX, IRIX, GNU/Linux, Tru64 & Windows provide a
1991 non-dummy version of this procedure in libaddr2line.a */
1994 convert_addresses (addrs
, n_addr
, buf
, len
)
1995 void *addrs ATTRIBUTE_UNUSED
;
1996 int n_addr ATTRIBUTE_UNUSED
;
1997 void *buf ATTRIBUTE_UNUSED
;