1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2014, 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 3, 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. *
18 * As a special exception under Section 7 of GPL version 3, you are granted *
19 * additional permissions described in the GCC Runtime Library Exception, *
20 * version 3.1, as published by the Free Software Foundation. *
22 * You should have received a copy of the GNU General Public License and *
23 * a copy of the GCC Runtime Library Exception along with this program; *
24 * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see *
25 * <http://www.gnu.org/licenses/>. *
27 * GNAT was originally developed by the GNAT team at New York University. *
28 * Extensive contributions were provided by Ada Core Technologies Inc. *
30 ****************************************************************************/
32 /* This file contains those routines named by Import pragmas in
33 packages in the GNAT hierarchy (especially GNAT.OS_Lib) and in
34 package Osint. Many of the subprograms in OS_Lib import standard
35 library calls directly. This file contains all other routines. */
37 /* Ensure access to errno is thread safe. */
43 /* No need to redefine exit here. */
46 /* We want to use the POSIX variants of include files. */
50 #if defined (__mips_vxworks)
52 #endif /* __mips_vxworks */
54 /* If SMP, access vxCpuConfiguredGet */
55 #ifdef _WRS_CONFIG_SMP
57 #endif /* _WRS_CONFIG_SMP */
59 /* We need to know the VxWorks version because some file operations
60 (such as chmod) are only available on VxWorks 6. */
65 #if defined (__APPLE__)
69 #if defined (__hpux__)
70 #include <sys/param.h>
71 #include <sys/pstat.h>
76 #define HOST_EXECUTABLE_SUFFIX ".exe"
77 #define HOST_OBJECT_SUFFIX ".obj"
81 #define __BSD_VISIBLE 1
94 #if defined (__vxworks) || defined (__ANDROID__)
95 /* S_IREAD and S_IWRITE are not defined in VxWorks or Android */
97 #define S_IREAD (S_IRUSR | S_IRGRP | S_IROTH)
101 #define S_IWRITE (S_IWUSR)
105 /* We don't have libiberty, so use malloc. */
106 #define xmalloc(S) malloc (S)
107 #define xrealloc(V,S) realloc (V,S)
118 #if defined (__MINGW32__)
126 /* Current code page and CCS encoding to use, set in initialize.c. */
127 UINT CurrentCodePage
;
128 UINT CurrentCCSEncoding
;
131 #include <sys/utime.h>
133 /* For isalpha-like tests in the compiler, we're expected to resort to
134 safe-ctype.h/ISALPHA. This isn't available for the runtime library
135 build, so we fallback on ctype.h/isalpha there. */
139 #define ISALPHA isalpha
142 #elif defined (__Lynx__)
144 /* Lynx utime.h only defines the entities of interest to us if
145 defined (VMOS_DEV), so ... */
154 /* wait.h processing */
157 # include <sys/wait.h>
159 #elif defined (__vxworks) && defined (__RTP__)
161 #elif defined (__Lynx__)
162 /* ??? We really need wait.h and it includes resource.h on Lynx. GCC
163 has a resource.h header as well, included instead of the lynx
164 version in our setup, causing lots of errors. We don't really need
165 the lynx contents of this file, so just workaround the issue by
166 preventing the inclusion of the GCC header from doing anything. */
167 # define GCC_RESOURCE_H
168 # include <sys/wait.h>
169 #elif defined (__nucleus__) || defined (__PikeOS__)
170 /* No wait() or waitpid() calls available. */
173 #include <sys/wait.h>
179 /* Header files and definitions for __gnat_set_file_time_name. */
181 #define __NEW_STARLET 1
183 #include <vms/atrdef.h>
184 #include <vms/fibdef.h>
185 #include <vms/stsdef.h>
186 #include <vms/iodef.h>
188 #include <vms/descrip.h>
192 /* Use native 64-bit arithmetic. */
193 #define unix_time_to_vms(X,Y) \
195 unsigned long long reftime, tmptime = (X); \
196 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
197 SYS$BINTIM (&unixtime, &reftime); \
198 Y = tmptime * 10000000 + reftime; \
201 /* descrip.h doesn't have everything ... */
202 typedef struct fibdef
* __fibdef_ptr32
__attribute__ (( mode (SI
) ));
203 struct dsc$descriptor_fib
205 unsigned int fib$l_len
;
206 __fibdef_ptr32 fib$l_addr
;
209 /* I/O Status Block. */
212 unsigned short status
, count
;
216 static char *tryfile
;
218 /* Variable length string. */
222 char string
[NAM$C_MAXRSS
+1];
225 #define SYI$_ACTIVECPU_CNT 0x111e
226 extern int LIB$
GETSYI (int *, unsigned int *);
227 extern unsigned int LIB$
CALLG_64 (unsigned long long argument_list
[],
228 int (*user_procedure
)(void));
232 #if ! defined (__vxworks)
248 #define DIR_SEPARATOR '\\'
253 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
254 defined in the current system. On DOS-like systems these flags control
255 whether the file is opened/created in text-translation mode (CR/LF in
256 external file mapped to LF in internal file), but in Unix-like systems,
257 no text translation is required, so these flags have no effect. */
267 #ifndef HOST_EXECUTABLE_SUFFIX
268 #define HOST_EXECUTABLE_SUFFIX ""
271 #ifndef HOST_OBJECT_SUFFIX
272 #define HOST_OBJECT_SUFFIX ".o"
275 #ifndef PATH_SEPARATOR
276 #define PATH_SEPARATOR ':'
279 #ifndef DIR_SEPARATOR
280 #define DIR_SEPARATOR '/'
283 /* Check for cross-compilation. */
284 #if defined (CROSS_COMPILE) || defined (CROSS_DIRECTORY_STRUCTURE)
286 int __gnat_is_cross_compiler
= 1;
289 int __gnat_is_cross_compiler
= 0;
292 char __gnat_dir_separator
= DIR_SEPARATOR
;
294 char __gnat_path_separator
= PATH_SEPARATOR
;
296 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
297 the base filenames that libraries specified with -lsomelib options
298 may have. This is used by GNATMAKE to check whether an executable
299 is up-to-date or not. The syntax is
301 library_template ::= { pattern ; } pattern NUL
302 pattern ::= [ prefix ] * [ postfix ]
304 These should only specify names of static libraries as it makes
305 no sense to determine at link time if dynamic-link libraries are
306 up to date or not. Any libraries that are not found are supposed
309 * if they are needed but not present, the link
312 * otherwise they are libraries in the system paths and so
313 they are considered part of the system and not checked
316 ??? This should be part of a GNAT host-specific compiler
317 file instead of being included in all user applications
318 as well. This is only a temporary work-around for 3.11b. */
320 #ifndef GNAT_LIBRARY_TEMPLATE
322 #define GNAT_LIBRARY_TEMPLATE "*.olb"
324 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
328 const char *__gnat_library_template
= GNAT_LIBRARY_TEMPLATE
;
330 /* This variable is used in hostparm.ads to say whether the host is a VMS
339 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
341 #elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__)
342 #define GNAT_MAX_PATH_LEN PATH_MAX
346 #if defined (__MINGW32__)
350 #include <sys/param.h>
354 #include <sys/param.h>
358 #define GNAT_MAX_PATH_LEN MAXPATHLEN
360 #define GNAT_MAX_PATH_LEN 256
365 /* Used for runtime check that Ada constant File_Attributes_Size is no
366 less than the actual size of struct file_attributes (see Osint
368 int __gnat_size_of_file_attributes
= sizeof (struct file_attributes
);
370 void __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
);
372 /* The __gnat_max_path_len variable is used to export the maximum
373 length of a path name to Ada code. max_path_len is also provided
374 for compatibility with older GNAT versions, please do not use
377 int __gnat_max_path_len
= GNAT_MAX_PATH_LEN
;
378 int max_path_len
= GNAT_MAX_PATH_LEN
;
380 /* Control whether we can use ACL on Windows. */
382 int __gnat_use_acl
= 1;
384 /* The following macro HAVE_READDIR_R should be defined if the
385 system provides the routine readdir_r. */
386 #undef HAVE_READDIR_R
388 #if defined(VMS) && defined (__LONG_POINTERS)
390 /* Return a 32 bit pointer to an array of 32 bit pointers
391 given a 64 bit pointer to an array of 64 bit pointers */
393 typedef __char_ptr32
*__char_ptr_char_ptr32
__attribute__ ((mode (SI
)));
395 static __char_ptr_char_ptr32
396 to_ptr32 (char **ptr64
)
399 __char_ptr_char_ptr32 short_argv
;
401 for (argc
= 0; ptr64
[argc
]; argc
++)
404 /* Reallocate argv with 32 bit pointers. */
405 short_argv
= (__char_ptr_char_ptr32
) decc$malloc
406 (sizeof (__char_ptr32
) * (argc
+ 1));
408 for (argc
= 0; ptr64
[argc
]; argc
++)
409 short_argv
[argc
] = (__char_ptr32
) decc$
strdup (ptr64
[argc
]);
411 short_argv
[argc
] = (__char_ptr32
) 0;
415 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
417 #define MAYBE_TO_PTR32(argv) argv
420 static const char ATTR_UNSET
= 127;
422 /* Reset the file attributes as if no system call had been performed */
425 __gnat_reset_attributes (struct file_attributes
* attr
)
427 attr
->exists
= ATTR_UNSET
;
428 attr
->error
= EINVAL
;
430 attr
->writable
= ATTR_UNSET
;
431 attr
->readable
= ATTR_UNSET
;
432 attr
->executable
= ATTR_UNSET
;
434 attr
->regular
= ATTR_UNSET
;
435 attr
->symbolic_link
= ATTR_UNSET
;
436 attr
->directory
= ATTR_UNSET
;
438 attr
->timestamp
= (OS_Time
)-2;
439 attr
->file_length
= -1;
443 __gnat_error_attributes (struct file_attributes
*attr
) {
448 __gnat_current_time (void)
450 time_t res
= time (NULL
);
451 return (OS_Time
) res
;
454 /* Return the current local time as a string in the ISO 8601 format of
455 "YYYY-MM-DD HH:MM:SS.SS". The returned string is 22 + 1 (NULL) characters
459 __gnat_current_time_string (char *result
)
461 const char *format
= "%Y-%m-%d %H:%M:%S";
462 /* Format string necessary to describe the ISO 8601 format */
464 const time_t t_val
= time (NULL
);
466 strftime (result
, 22, format
, localtime (&t_val
));
467 /* Convert the local time into a string following the ISO format, copying
468 at most 22 characters into the result string. */
473 /* The sub-seconds are manually set to zero since type time_t lacks the
474 precision necessary for nanoseconds. */
478 __gnat_to_gm_time (OS_Time
*p_time
, int *p_year
, int *p_month
, int *p_day
,
479 int *p_hours
, int *p_mins
, int *p_secs
)
482 time_t time
= (time_t) *p_time
;
485 /* On Windows systems, the time is sometimes rounded up to the nearest
486 even second, so if the number of seconds is odd, increment it. */
492 res
= localtime (&time
);
494 res
= gmtime (&time
);
499 *p_year
= res
->tm_year
;
500 *p_month
= res
->tm_mon
;
501 *p_day
= res
->tm_mday
;
502 *p_hours
= res
->tm_hour
;
503 *p_mins
= res
->tm_min
;
504 *p_secs
= res
->tm_sec
;
507 *p_year
= *p_month
= *p_day
= *p_hours
= *p_mins
= *p_secs
= 0;
511 __gnat_to_os_time (OS_Time
*p_time
, int year
, int month
, int day
,
512 int hours
, int mins
, int secs
)
524 /* returns -1 of failing, this is s-os_lib Invalid_Time */
526 *p_time
= (OS_Time
) mktime (&v
);
529 /* Place the contents of the symbolic link named PATH in the buffer BUF,
530 which has size BUFSIZ. If PATH is a symbolic link, then return the number
531 of characters of its content in BUF. Otherwise, return -1.
532 For systems not supporting symbolic links, always return -1. */
535 __gnat_readlink (char *path ATTRIBUTE_UNUSED
,
536 char *buf ATTRIBUTE_UNUSED
,
537 size_t bufsiz ATTRIBUTE_UNUSED
)
539 #if defined (_WIN32) || defined (VMS) \
540 || defined(__vxworks) || defined (__nucleus__) || defined (__PikeOS__)
543 return readlink (path
, buf
, bufsiz
);
547 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH.
548 If NEWPATH exists it will NOT be overwritten.
549 For systems not supporting symbolic links, always return -1. */
552 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED
,
553 char *newpath ATTRIBUTE_UNUSED
)
555 #if defined (_WIN32) || defined (VMS) \
556 || defined(__vxworks) || defined (__nucleus__) || defined (__PikeOS__)
559 return symlink (oldpath
, newpath
);
563 /* Try to lock a file, return 1 if success. */
565 #if defined (__vxworks) || defined (__nucleus__) \
566 || defined (_WIN32) || defined (VMS) || defined (__PikeOS__)
568 /* Version that does not use link. */
571 __gnat_try_lock (char *dir
, char *file
)
575 TCHAR wfull_path
[GNAT_MAX_PATH_LEN
];
576 TCHAR wfile
[GNAT_MAX_PATH_LEN
];
577 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
579 S2WSC (wdir
, dir
, GNAT_MAX_PATH_LEN
);
580 S2WSC (wfile
, file
, GNAT_MAX_PATH_LEN
);
582 _stprintf (wfull_path
, _T("%s%c%s"), wdir
, _T(DIR_SEPARATOR
), wfile
);
583 fd
= _topen (wfull_path
, O_CREAT
| O_EXCL
, 0600);
587 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
588 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
600 /* Version using link(), more secure over NFS. */
601 /* See TN 6913-016 for discussion ??? */
604 __gnat_try_lock (char *dir
, char *file
)
608 GNAT_STRUCT_STAT stat_result
;
611 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
612 sprintf (temp_file
, "%s%cTMP-%ld-%ld",
613 dir
, DIR_SEPARATOR
, (long)getpid(), (long)getppid ());
615 /* Create the temporary file and write the process number. */
616 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
622 /* Link it with the new file. */
623 link (temp_file
, full_path
);
625 /* Count the references on the old one. If we have a count of two, then
626 the link did succeed. Remove the temporary file before returning. */
627 __gnat_stat (temp_file
, &stat_result
);
629 return stat_result
.st_nlink
== 2;
633 /* Return the maximum file name length. */
636 __gnat_get_maximum_file_name_length (void)
639 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
648 /* Return nonzero if file names are case sensitive. */
650 static int file_names_case_sensitive_cache
= -1;
653 __gnat_get_file_names_case_sensitive (void)
655 if (file_names_case_sensitive_cache
== -1)
657 const char *sensitive
= getenv ("GNAT_FILE_NAME_CASE_SENSITIVE");
659 if (sensitive
!= NULL
660 && (sensitive
[0] == '0' || sensitive
[0] == '1')
661 && sensitive
[1] == '\0')
662 file_names_case_sensitive_cache
= sensitive
[0] - '0';
664 #if defined (VMS) || defined (WINNT) || defined (__APPLE__)
665 file_names_case_sensitive_cache
= 0;
667 file_names_case_sensitive_cache
= 1;
670 return file_names_case_sensitive_cache
;
673 /* Return nonzero if environment variables are case sensitive. */
676 __gnat_get_env_vars_case_sensitive (void)
678 #if defined (VMS) || defined (WINNT)
686 __gnat_get_default_identifier_character_set (void)
691 /* Return the current working directory. */
694 __gnat_get_current_dir (char *dir
, int *length
)
696 #if defined (__MINGW32__)
697 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
699 _tgetcwd (wdir
, *length
);
701 WS2SC (dir
, wdir
, GNAT_MAX_PATH_LEN
);
704 /* Force Unix style, which is what GNAT uses internally. */
705 getcwd (dir
, *length
, 0);
707 getcwd (dir
, *length
);
710 *length
= strlen (dir
);
712 if (dir
[*length
- 1] != DIR_SEPARATOR
)
714 dir
[*length
] = DIR_SEPARATOR
;
720 /* Return the suffix for object files. */
723 __gnat_get_object_suffix_ptr (int *len
, const char **value
)
725 *value
= HOST_OBJECT_SUFFIX
;
730 *len
= strlen (*value
);
735 /* Return the suffix for executable files. */
738 __gnat_get_executable_suffix_ptr (int *len
, const char **value
)
740 *value
= HOST_EXECUTABLE_SUFFIX
;
744 *len
= strlen (*value
);
749 /* Return the suffix for debuggable files. Usually this is the same as the
750 executable extension. */
753 __gnat_get_debuggable_suffix_ptr (int *len
, const char **value
)
755 *value
= HOST_EXECUTABLE_SUFFIX
;
760 *len
= strlen (*value
);
765 /* Returns the OS filename and corresponding encoding. */
768 __gnat_os_filename (char *filename ATTRIBUTE_UNUSED
,
769 char *w_filename ATTRIBUTE_UNUSED
,
770 char *os_name
, int *o_length
,
771 char *encoding ATTRIBUTE_UNUSED
, int *e_length
)
773 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
774 WS2SC (os_name
, (TCHAR
*)w_filename
, (DWORD
)*o_length
);
775 *o_length
= strlen (os_name
);
776 strcpy (encoding
, "encoding=utf8");
777 *e_length
= strlen (encoding
);
779 strcpy (os_name
, filename
);
780 *o_length
= strlen (filename
);
788 __gnat_unlink (char *path
)
790 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
792 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
794 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
795 return _tunlink (wpath
);
798 return unlink (path
);
805 __gnat_rename (char *from
, char *to
)
807 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
809 TCHAR wfrom
[GNAT_MAX_PATH_LEN
], wto
[GNAT_MAX_PATH_LEN
];
811 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
);
812 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
);
813 return _trename (wfrom
, wto
);
816 return rename (from
, to
);
820 /* Changing directory. */
823 __gnat_chdir (char *path
)
825 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
827 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
829 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
830 return _tchdir (wpath
);
837 /* Removing a directory. */
840 __gnat_rmdir (char *path
)
842 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
844 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
846 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
847 return _trmdir (wpath
);
849 #elif defined (VTHREADS)
850 /* rmdir not available */
858 __gnat_fputwc(int c
, FILE *stream
)
860 #if ! defined (__vxworks)
861 return fputwc ((wchar_t)c
, stream
);
863 return fputc (c
, stream
);
868 __gnat_fopen (char *path
, char *mode
, int encoding ATTRIBUTE_UNUSED
,
869 char *vms_form ATTRIBUTE_UNUSED
)
871 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
872 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
875 S2WS (wmode
, mode
, 10);
877 if (encoding
== Encoding_Unspecified
)
878 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
879 else if (encoding
== Encoding_UTF8
)
880 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
882 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
884 return _tfopen (wpath
, wmode
);
887 return decc$
fopen (path
, mode
);
890 char *local_form
= (char *) alloca (strlen (vms_form
) + 1);
891 /* Allocate an argument list of guaranteed ample length. */
892 unsigned long long *arg_list
=
893 (unsigned long long *) alloca (strlen (vms_form
) + 3);
897 arg_list
[1] = (unsigned long long) path
;
898 arg_list
[2] = (unsigned long long) mode
;
899 strcpy (local_form
, vms_form
);
901 /* Given a string such as "\"rfm=udf\",\"rat=cr\""
902 Split it into an argument list as "rfm=udf","rat=cr". */
904 for (i
= 0; *ptrb
; i
++)
906 ptrb
= strchr (ptrb
, '"');
907 ptre
= strchr (ptrb
+ 1, '"');
909 arg_list
[i
+ 3] = (unsigned long long) (ptrb
+ 1);
912 arg_list
[0] = i
+ 2;
913 /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
914 always a 32bit pointer. */
915 return LIB$
CALLG_64 (arg_list
, &decc$fopen
);
918 return GNAT_FOPEN (path
, mode
);
923 __gnat_freopen (char *path
,
926 int encoding ATTRIBUTE_UNUSED
,
927 char *vms_form ATTRIBUTE_UNUSED
)
929 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
930 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
933 S2WS (wmode
, mode
, 10);
935 if (encoding
== Encoding_Unspecified
)
936 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
937 else if (encoding
== Encoding_UTF8
)
938 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
940 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
942 return _tfreopen (wpath
, wmode
, stream
);
945 return decc$
freopen (path
, mode
, stream
);
948 char *local_form
= (char *) alloca (strlen (vms_form
) + 1);
949 /* Allocate an argument list of guaranteed ample length. */
950 unsigned long long *arg_list
=
951 (unsigned long long *) alloca (strlen (vms_form
) + 4);
955 arg_list
[1] = (unsigned long long) path
;
956 arg_list
[2] = (unsigned long long) mode
;
957 arg_list
[3] = (unsigned long long) stream
;
958 strcpy (local_form
, vms_form
);
960 /* Given a string such as "\"rfm=udf\",\"rat=cr\""
961 Split it into an argument list as "rfm=udf","rat=cr". */
963 for (i
= 0; *ptrb
; i
++)
965 ptrb
= strchr (ptrb
, '"');
966 ptre
= strchr (ptrb
+ 1, '"');
968 arg_list
[i
+ 4] = (unsigned long long) (ptrb
+ 1);
971 arg_list
[0] = i
+ 3;
972 /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
973 always a 32bit pointer. */
974 return LIB$
CALLG_64 (arg_list
, &decc$freopen
);
977 return freopen (path
, mode
, stream
);
982 __gnat_open_read (char *path
, int fmode
)
985 int o_fmode
= O_BINARY
;
991 /* Optional arguments mbc,deq,fop increase read performance. */
992 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
993 "mbc=16", "deq=64", "fop=tef");
994 #elif defined (__vxworks)
995 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
996 #elif defined (__MINGW32__)
998 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1000 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1001 fd
= _topen (wpath
, O_RDONLY
| o_fmode
, 0444);
1004 fd
= open (path
, O_RDONLY
| o_fmode
);
1007 return fd
< 0 ? -1 : fd
;
1010 #if defined (__MINGW32__)
1011 #define PERM (S_IREAD | S_IWRITE)
1013 /* Excerpt from DECC C RTL Reference Manual:
1014 To create files with OpenVMS RMS default protections using the UNIX
1015 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
1016 and open with a file-protection mode argument of 0777 in a program
1017 that never specifically calls umask. These default protections include
1018 correctly establishing protections based on ACLs, previous versions of
1019 files, and so on. */
1022 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
1026 __gnat_open_rw (char *path
, int fmode
)
1029 int o_fmode
= O_BINARY
;
1035 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
1036 "mbc=16", "deq=64", "fop=tef");
1037 #elif defined (__MINGW32__)
1039 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1041 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1042 fd
= _topen (wpath
, O_RDWR
| o_fmode
, PERM
);
1045 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
1048 return fd
< 0 ? -1 : fd
;
1052 __gnat_open_create (char *path
, int fmode
)
1055 int o_fmode
= O_BINARY
;
1061 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
1062 "mbc=16", "deq=64", "fop=tef");
1063 #elif defined (__MINGW32__)
1065 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1067 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1068 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
1071 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
1074 return fd
< 0 ? -1 : fd
;
1078 __gnat_create_output_file (char *path
)
1082 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
,
1083 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
1084 "shr=del,get,put,upd");
1085 #elif defined (__MINGW32__)
1087 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1089 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1090 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
1093 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
1096 return fd
< 0 ? -1 : fd
;
1100 __gnat_create_output_file_new (char *path
)
1104 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
,
1105 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
1106 "shr=del,get,put,upd");
1107 #elif defined (__MINGW32__)
1109 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1111 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1112 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
1115 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
1118 return fd
< 0 ? -1 : fd
;
1122 __gnat_open_append (char *path
, int fmode
)
1125 int o_fmode
= O_BINARY
;
1131 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
1132 "mbc=16", "deq=64", "fop=tef");
1133 #elif defined (__MINGW32__)
1135 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1137 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1138 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
1141 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
1144 return fd
< 0 ? -1 : fd
;
1147 /* Open a new file. Return error (-1) if the file already exists. */
1150 __gnat_open_new (char *path
, int fmode
)
1153 int o_fmode
= O_BINARY
;
1159 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1160 "mbc=16", "deq=64", "fop=tef");
1161 #elif defined (__MINGW32__)
1163 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1165 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1166 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1169 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1172 return fd
< 0 ? -1 : fd
;
1175 /* Open a new temp file. Return error (-1) if the file already exists.
1176 Special options for VMS allow the file to be shared between parent and child
1177 processes, however they really slow down output. Used in gnatchop. */
1180 __gnat_open_new_temp (char *path
, int fmode
)
1183 int o_fmode
= O_BINARY
;
1185 strcpy (path
, "GNAT-XXXXXX");
1187 #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \
1188 || defined (linux) || defined(__GLIBC__)) && !defined (__vxworks)
1189 return mkstemp (path
);
1190 #elif defined (__Lynx__)
1192 #elif defined (__nucleus__)
1195 if (mktemp (path
) == NULL
)
1203 /* Passing rfm=stmlf for binary files seems questionable since it results
1204 in having an extraneous line feed added after every call to CRTL write,
1205 so pass rfm=udf (aka undefined) instead. */
1206 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1207 fmode
? "rfm=stmlf" : "rfm=udf", "ctx=rec", "rat=none",
1208 "shr=del,get,put,upd", "mbc=16", "deq=64", "fop=tef");
1210 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1213 return fd
< 0 ? -1 : fd
;
1216 /****************************************************************
1217 ** Perform a call to GNAT_STAT or GNAT_FSTAT, and extract as much information
1218 ** as possible from it, storing the result in a cache for later reuse
1219 ****************************************************************/
1222 __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
)
1224 GNAT_STRUCT_STAT statbuf
;
1228 /* GNAT_FSTAT returns -1 and sets errno for failure */
1229 ret
= GNAT_FSTAT (fd
, &statbuf
);
1230 error
= ret
? errno
: 0;
1233 /* __gnat_stat returns errno value directly */
1234 error
= __gnat_stat (name
, &statbuf
);
1235 ret
= error
? -1 : 0;
1239 * A missing file is reported as an attr structure with error == 0 and
1243 if (error
== 0 || error
== ENOENT
)
1246 attr
->error
= error
;
1248 attr
->regular
= (!ret
&& S_ISREG (statbuf
.st_mode
));
1249 attr
->directory
= (!ret
&& S_ISDIR (statbuf
.st_mode
));
1252 attr
->file_length
= 0;
1254 /* st_size may be 32 bits, or 64 bits which is converted to long. We
1255 don't return a useful value for files larger than 2 gigabytes in
1257 attr
->file_length
= statbuf
.st_size
; /* all systems */
1259 attr
->exists
= !ret
;
1261 #if !defined (_WIN32) || defined (RTX)
1262 /* on Windows requires extra system call, see __gnat_is_readable_file_attr */
1263 attr
->readable
= (!ret
&& (statbuf
.st_mode
& S_IRUSR
));
1264 attr
->writable
= (!ret
&& (statbuf
.st_mode
& S_IWUSR
));
1265 attr
->executable
= (!ret
&& (statbuf
.st_mode
& S_IXUSR
));
1269 attr
->timestamp
= (OS_Time
)-1;
1272 /* VMS has file versioning. */
1273 attr
->timestamp
= (OS_Time
)statbuf
.st_ctime
;
1275 attr
->timestamp
= (OS_Time
)statbuf
.st_mtime
;
1280 /****************************************************************
1281 ** Return the number of bytes in the specified file
1282 ****************************************************************/
1285 __gnat_file_length_attr (int fd
, char* name
, struct file_attributes
* attr
)
1287 if (attr
->file_length
== -1) {
1288 __gnat_stat_to_attr (fd
, name
, attr
);
1291 return attr
->file_length
;
1295 __gnat_file_length (int fd
)
1297 struct file_attributes attr
;
1298 __gnat_reset_attributes (&attr
);
1299 return __gnat_file_length_attr (fd
, NULL
, &attr
);
1303 __gnat_named_file_length (char *name
)
1305 struct file_attributes attr
;
1306 __gnat_reset_attributes (&attr
);
1307 return __gnat_file_length_attr (-1, name
, &attr
);
1310 /* Create a temporary filename and put it in string pointed to by
1314 __gnat_tmp_name (char *tmp_filename
)
1317 /* Variable used to create a series of unique names */
1318 static int counter
= 0;
1320 /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */
1321 strcpy (tmp_filename
, "c:\\WINDOWS\\Temp\\gnat-");
1322 sprintf (&tmp_filename
[strlen (tmp_filename
)], "%d\0", counter
++);
1324 #elif defined (__MINGW32__)
1329 /* tempnam tries to create a temporary file in directory pointed to by
1330 TMP environment variable, in c:\temp if TMP is not set, and in
1331 directory specified by P_tmpdir in stdio.h if c:\temp does not
1332 exist. The filename will be created with the prefix "gnat-". */
1334 sprintf (prefix
, "gnat-%d-", (int)getpid());
1335 pname
= (char *) _tempnam ("c:\\temp", prefix
);
1337 /* if pname is NULL, the file was not created properly, the disk is full
1338 or there is no more free temporary files */
1341 *tmp_filename
= '\0';
1343 /* If pname start with a back slash and not path information it means that
1344 the filename is valid for the current working directory. */
1346 else if (pname
[0] == '\\')
1348 strcpy (tmp_filename
, ".\\");
1349 strcat (tmp_filename
, pname
+1);
1352 strcpy (tmp_filename
, pname
);
1357 #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \
1358 || defined (__OpenBSD__) || defined(__GLIBC__)
1359 #define MAX_SAFE_PATH 1000
1360 char *tmpdir
= getenv ("TMPDIR");
1362 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
1363 a buffer overflow. */
1364 if (tmpdir
== NULL
|| strlen (tmpdir
) > MAX_SAFE_PATH
)
1365 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
1367 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
1369 close (mkstemp(tmp_filename
));
1370 #elif defined (__vxworks) && !(defined (__RTP__) || defined (VTHREADS))
1374 static ushort_t seed
= 0; /* used to generate unique name */
1376 /* generate unique name */
1377 strcpy (tmp_filename
, "tmp");
1379 /* fill up the name buffer from the last position */
1381 pos
= tmp_filename
+ strlen (tmp_filename
) + index
;
1385 for (t
= seed
; 0 <= --index
; t
>>= 3)
1386 *--pos
= '0' + (t
& 07);
1388 tmpnam (tmp_filename
);
1392 /* Open directory and returns a DIR pointer. */
1394 DIR* __gnat_opendir (char *name
)
1397 /* Not supported in RTX */
1401 #elif defined (__MINGW32__)
1402 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1404 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1405 return (DIR*)_topendir (wname
);
1408 return opendir (name
);
1412 /* Read the next entry in a directory. The returned string points somewhere
1416 __gnat_readdir (DIR *dirp
, char *buffer
, int *len
)
1419 /* Not supported in RTX */
1423 #elif defined (__MINGW32__)
1424 struct _tdirent
*dirent
= _treaddir ((_TDIR
*)dirp
);
1428 WS2SC (buffer
, dirent
->d_name
, GNAT_MAX_PATH_LEN
);
1429 *len
= strlen (buffer
);
1436 #elif defined (HAVE_READDIR_R)
1437 /* If possible, try to use the thread-safe version. */
1438 if (readdir_r (dirp
, buffer
) != NULL
)
1440 *len
= strlen (((struct dirent
*) buffer
)->d_name
);
1441 return ((struct dirent
*) buffer
)->d_name
;
1447 struct dirent
*dirent
= (struct dirent
*) readdir (dirp
);
1451 strcpy (buffer
, dirent
->d_name
);
1452 *len
= strlen (buffer
);
1461 /* Close a directory entry. */
1463 int __gnat_closedir (DIR *dirp
)
1466 /* Not supported in RTX */
1470 #elif defined (__MINGW32__)
1471 return _tclosedir ((_TDIR
*)dirp
);
1474 return closedir (dirp
);
1478 /* Returns 1 if readdir is thread safe, 0 otherwise. */
1481 __gnat_readdir_is_thread_safe (void)
1483 #ifdef HAVE_READDIR_R
1490 #if defined (_WIN32) && !defined (RTX)
1491 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
1492 static const unsigned long long w32_epoch_offset
= 11644473600ULL;
1494 /* Returns the file modification timestamp using Win32 routines which are
1495 immune against daylight saving time change. It is in fact not possible to
1496 use fstat for this purpose as the DST modify the st_mtime field of the
1500 win32_filetime (HANDLE h
)
1505 unsigned long long ull_time
;
1508 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1509 since <Jan 1st 1601>. This function must return the number of seconds
1510 since <Jan 1st 1970>. */
1512 if (GetFileTime (h
, NULL
, NULL
, &t_write
.ft_time
))
1513 return (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1517 /* As above but starting from a FILETIME. */
1519 f2t (const FILETIME
*ft
, time_t *t
)
1524 unsigned long long ull_time
;
1527 t_write
.ft_time
= *ft
;
1528 *t
= (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1532 /* Return a GNAT time stamp given a file name. */
1535 __gnat_file_time_name_attr (char* name
, struct file_attributes
* attr
)
1537 if (attr
->timestamp
== (OS_Time
)-2) {
1538 #if defined (_WIN32) && !defined (RTX)
1540 WIN32_FILE_ATTRIBUTE_DATA fad
;
1542 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1543 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1545 if ((res
= GetFileAttributesEx (wname
, GetFileExInfoStandard
, &fad
)))
1546 f2t (&fad
.ftLastWriteTime
, &ret
);
1547 attr
->timestamp
= (OS_Time
) ret
;
1549 __gnat_stat_to_attr (-1, name
, attr
);
1552 return attr
->timestamp
;
1556 __gnat_file_time_name (char *name
)
1558 struct file_attributes attr
;
1559 __gnat_reset_attributes (&attr
);
1560 return __gnat_file_time_name_attr (name
, &attr
);
1563 /* Return a GNAT time stamp given a file descriptor. */
1566 __gnat_file_time_fd_attr (int fd
, struct file_attributes
* attr
)
1568 if (attr
->timestamp
== (OS_Time
)-2) {
1569 #if defined (_WIN32) && !defined (RTX)
1570 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
1571 time_t ret
= win32_filetime (h
);
1572 attr
->timestamp
= (OS_Time
) ret
;
1575 __gnat_stat_to_attr (fd
, NULL
, attr
);
1579 return attr
->timestamp
;
1583 __gnat_file_time_fd (int fd
)
1585 struct file_attributes attr
;
1586 __gnat_reset_attributes (&attr
);
1587 return __gnat_file_time_fd_attr (fd
, &attr
);
1590 /* Set the file time stamp. */
1593 __gnat_set_file_time_name (char *name
, time_t time_stamp
)
1595 #if defined (__vxworks)
1597 /* Code to implement __gnat_set_file_time_name for these systems. */
1599 #elif defined (_WIN32) && !defined (RTX)
1603 unsigned long long ull_time
;
1605 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1607 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1609 HANDLE h
= CreateFile
1610 (wname
, GENERIC_WRITE
, FILE_SHARE_WRITE
, NULL
,
1611 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
,
1613 if (h
== INVALID_HANDLE_VALUE
)
1615 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1616 t_write
.ull_time
= ((unsigned long long)time_stamp
+ w32_epoch_offset
);
1617 /* Convert to 100 nanosecond units */
1618 t_write
.ull_time
*= 10000000ULL;
1620 SetFileTime(h
, NULL
, NULL
, &t_write
.ft_time
);
1630 unsigned long long backup
, create
, expire
, revise
;
1634 unsigned short value
;
1637 unsigned system
: 4;
1643 } Fat
= { 0, 0, 0, 0, 0, { 0 }};
1647 { ATR$S_CREDATE
, ATR$C_CREDATE
, &Fat
.create
},
1648 { ATR$S_REVDATE
, ATR$C_REVDATE
, &Fat
.revise
},
1649 { ATR$S_EXPDATE
, ATR$C_EXPDATE
, &Fat
.expire
},
1650 { ATR$S_BAKDATE
, ATR$C_BAKDATE
, &Fat
.backup
},
1651 { ATR$S_FPRO
, ATR$C_FPRO
, &Fat
.prot
},
1652 { ATR$S_UIC
, ATR$C_UIC
, &Fat
.uic
},
1657 struct dsc$descriptor_fib fibdsc
= {sizeof (fib
), (void *) &fib
};
1661 unsigned long long newtime
;
1662 unsigned long long revtime
;
1666 struct vstring file
;
1667 struct dsc$descriptor_s filedsc
1668 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) file
.string
};
1669 struct vstring device
;
1670 struct dsc$descriptor_s devicedsc
1671 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) device
.string
};
1672 struct vstring timev
;
1673 struct dsc$descriptor_s timedsc
1674 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) timev
.string
};
1675 struct vstring result
;
1676 struct dsc$descriptor_s resultdsc
1677 = {NAM$C_MAXRSS
, DSC$K_DTYPE_VT
, DSC$K_CLASS_VS
, (void *) result
.string
};
1679 /* Convert parameter name (a file spec) to host file form. Note that this
1680 is needed on VMS to prepare for subsequent calls to VMS RMS library
1681 routines. Note that it would not work to call __gnat_to_host_dir_spec
1682 as was done in a previous version, since this fails silently unless
1683 the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1684 (directory not found) condition is signalled. */
1685 tryfile
= (char *) __gnat_to_host_file_spec (name
);
1687 /* Allocate and initialize a FAB and NAM structures. */
1691 nam
.nam$l_esa
= file
.string
;
1692 nam
.nam$b_ess
= NAM$C_MAXRSS
;
1693 nam
.nam$l_rsa
= result
.string
;
1694 nam
.nam$b_rss
= NAM$C_MAXRSS
;
1695 fab
.fab$l_fna
= tryfile
;
1696 fab
.fab$b_fns
= strlen (tryfile
);
1697 fab
.fab$l_nam
= &nam
;
1699 /* Validate filespec syntax and device existence. */
1700 status
= SYS$
PARSE (&fab
, 0, 0);
1701 if ((status
& 1) != 1)
1702 LIB$
SIGNAL (status
);
1704 file
.string
[nam
.nam$b_esl
] = 0;
1706 /* Find matching filespec. */
1707 status
= SYS$
SEARCH (&fab
, 0, 0);
1708 if ((status
& 1) != 1)
1709 LIB$
SIGNAL (status
);
1711 file
.string
[nam
.nam$b_esl
] = 0;
1712 result
.string
[result
.length
=nam
.nam$b_rsl
] = 0;
1714 /* Get the device name and assign an IO channel. */
1715 strncpy (device
.string
, nam
.nam$l_dev
, nam
.nam$b_dev
);
1716 devicedsc
.dsc$w_length
= nam
.nam$b_dev
;
1718 status
= SYS$
ASSIGN (&devicedsc
, &chan
, 0, 0, 0);
1719 if ((status
& 1) != 1)
1720 LIB$
SIGNAL (status
);
1722 /* Initialize the FIB and fill in the directory id field. */
1723 memset (&fib
, 0, sizeof (fib
));
1724 fib
.fib$w_did
[0] = nam
.nam$w_did
[0];
1725 fib
.fib$w_did
[1] = nam
.nam$w_did
[1];
1726 fib
.fib$w_did
[2] = nam
.nam$w_did
[2];
1727 fib
.fib$l_acctl
= 0;
1729 strcpy (file
.string
, (strrchr (result
.string
, ']') + 1));
1730 filedsc
.dsc$w_length
= strlen (file
.string
);
1731 result
.string
[result
.length
= 0] = 0;
1733 /* Open and close the file to fill in the attributes. */
1735 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1736 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1737 if ((status
& 1) != 1)
1738 LIB$
SIGNAL (status
);
1739 if ((iosb
.status
& 1) != 1)
1740 LIB$
SIGNAL (iosb
.status
);
1742 result
.string
[result
.length
] = 0;
1743 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0, &fibdsc
, 0, 0, 0,
1745 if ((status
& 1) != 1)
1746 LIB$
SIGNAL (status
);
1747 if ((iosb
.status
& 1) != 1)
1748 LIB$
SIGNAL (iosb
.status
);
1753 /* Set creation time to requested time. */
1754 unix_time_to_vms (time_stamp
, newtime
);
1756 t
= time ((time_t) 0);
1758 /* Set revision time to now in local time. */
1759 unix_time_to_vms (t
, revtime
);
1762 /* Reopen the file, modify the times and then close. */
1763 fib
.fib$l_acctl
= FIB$M_WRITE
;
1765 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1766 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1767 if ((status
& 1) != 1)
1768 LIB$
SIGNAL (status
);
1769 if ((iosb
.status
& 1) != 1)
1770 LIB$
SIGNAL (iosb
.status
);
1772 Fat
.create
= newtime
;
1773 Fat
.revise
= revtime
;
1775 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0,
1776 &fibdsc
, 0, 0, 0, &atrlst
, 0);
1777 if ((status
& 1) != 1)
1778 LIB$
SIGNAL (status
);
1779 if ((iosb
.status
& 1) != 1)
1780 LIB$
SIGNAL (iosb
.status
);
1782 /* Deassign the channel and exit. */
1783 status
= SYS$
DASSGN (chan
);
1784 if ((status
& 1) != 1)
1785 LIB$
SIGNAL (status
);
1787 struct utimbuf utimbuf
;
1790 /* Set modification time to requested time. */
1791 utimbuf
.modtime
= time_stamp
;
1793 /* Set access time to now in local time. */
1794 t
= time ((time_t) 0);
1795 utimbuf
.actime
= mktime (localtime (&t
));
1797 utime (name
, &utimbuf
);
1801 /* Get the list of installed standard libraries from the
1802 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1806 __gnat_get_libraries_from_registry (void)
1808 char *result
= (char *) xmalloc (1);
1812 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) \
1816 DWORD name_size
, value_size
;
1823 /* First open the key. */
1824 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1826 if (res
== ERROR_SUCCESS
)
1827 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1828 KEY_READ
, ®_key
);
1830 if (res
== ERROR_SUCCESS
)
1831 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1833 if (res
== ERROR_SUCCESS
)
1834 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1836 /* If the key exists, read out all the values in it and concatenate them
1838 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1840 value_size
= name_size
= 256;
1841 res
= RegEnumValueA (reg_key
, index
, name
, &name_size
, 0,
1842 &type
, (LPBYTE
)value
, &value_size
);
1844 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1846 char *old_result
= result
;
1848 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1849 strcpy (result
, old_result
);
1850 strcat (result
, value
);
1851 strcat (result
, ";");
1856 /* Remove the trailing ";". */
1858 result
[strlen (result
) - 1] = 0;
1864 /* Query information for the given file NAME and return it in STATBUF.
1865 * Returns 0 for success, or errno value for failure.
1868 __gnat_stat (char *name
, GNAT_STRUCT_STAT
*statbuf
)
1871 WIN32_FILE_ATTRIBUTE_DATA fad
;
1872 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
1877 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
1878 name_len
= _tcslen (wname
);
1880 if (name_len
> GNAT_MAX_PATH_LEN
)
1883 ZeroMemory (statbuf
, sizeof(GNAT_STRUCT_STAT
));
1885 res
= GetFileAttributesEx (wname
, GetFileExInfoStandard
, &fad
);
1888 error
= GetLastError();
1890 /* Check file existence using GetFileAttributes() which does not fail on
1891 special Windows files like con:, aux:, nul: etc... */
1893 if (GetFileAttributes(wname
) != INVALID_FILE_ATTRIBUTES
) {
1894 /* Just pretend that it is a regular and readable file */
1895 statbuf
->st_mode
= S_IFREG
| S_IREAD
| S_IWRITE
;
1900 case ERROR_ACCESS_DENIED
:
1901 case ERROR_SHARING_VIOLATION
:
1902 case ERROR_LOCK_VIOLATION
:
1903 case ERROR_SHARING_BUFFER_EXCEEDED
:
1905 case ERROR_BUFFER_OVERFLOW
:
1906 return ENAMETOOLONG
;
1907 case ERROR_NOT_ENOUGH_MEMORY
:
1914 f2t (&fad
.ftCreationTime
, &statbuf
->st_ctime
);
1915 f2t (&fad
.ftLastWriteTime
, &statbuf
->st_mtime
);
1916 f2t (&fad
.ftLastAccessTime
, &statbuf
->st_atime
);
1918 statbuf
->st_size
= (off_t
)fad
.nFileSizeLow
;
1920 /* We do not have the S_IEXEC attribute, but this is not used on GNAT. */
1921 statbuf
->st_mode
= S_IREAD
;
1923 if (fad
.dwFileAttributes
& FILE_ATTRIBUTE_DIRECTORY
)
1924 statbuf
->st_mode
|= S_IFDIR
;
1926 statbuf
->st_mode
|= S_IFREG
;
1928 if (!(fad
.dwFileAttributes
& FILE_ATTRIBUTE_READONLY
))
1929 statbuf
->st_mode
|= S_IWRITE
;
1934 return GNAT_STAT (name
, statbuf
) == 0 ? 0 : errno
;
1938 /*************************************************************************
1939 ** Check whether a file exists
1940 *************************************************************************/
1943 __gnat_file_exists_attr (char* name
, struct file_attributes
* attr
)
1945 if (attr
->exists
== ATTR_UNSET
)
1946 __gnat_stat_to_attr (-1, name
, attr
);
1948 return attr
->exists
;
1952 __gnat_file_exists (char *name
)
1954 struct file_attributes attr
;
1955 __gnat_reset_attributes (&attr
);
1956 return __gnat_file_exists_attr (name
, &attr
);
1959 /**********************************************************************
1960 ** Whether name is an absolute path
1961 **********************************************************************/
1964 __gnat_is_absolute_path (char *name
, int length
)
1967 /* On VxWorks systems, an absolute path can be represented (depending on
1968 the host platform) as either /dir/file, or device:/dir/file, or
1969 device:drive_letter:/dir/file. */
1976 for (index
= 0; index
< length
; index
++)
1978 if (name
[index
] == ':' &&
1979 ((name
[index
+ 1] == '/') ||
1980 (isalpha (name
[index
+ 1]) && index
+ 2 <= length
&&
1981 name
[index
+ 2] == '/')))
1984 else if (name
[index
] == '/')
1989 return (length
!= 0) &&
1990 (*name
== '/' || *name
== DIR_SEPARATOR
1992 || (length
> 1 && ISALPHA (name
[0]) && name
[1] == ':')
1999 __gnat_is_regular_file_attr (char* name
, struct file_attributes
* attr
)
2001 if (attr
->regular
== ATTR_UNSET
)
2002 __gnat_stat_to_attr (-1, name
, attr
);
2004 return attr
->regular
;
2008 __gnat_is_regular_file (char *name
)
2010 struct file_attributes attr
;
2012 __gnat_reset_attributes (&attr
);
2013 return __gnat_is_regular_file_attr (name
, &attr
);
2017 __gnat_is_directory_attr (char* name
, struct file_attributes
* attr
)
2019 if (attr
->directory
== ATTR_UNSET
)
2020 __gnat_stat_to_attr (-1, name
, attr
);
2022 return attr
->directory
;
2026 __gnat_is_directory (char *name
)
2028 struct file_attributes attr
;
2030 __gnat_reset_attributes (&attr
);
2031 return __gnat_is_directory_attr (name
, &attr
);
2034 #if defined (_WIN32) && !defined (RTX)
2036 /* Returns the same constant as GetDriveType but takes a pathname as
2040 GetDriveTypeFromPath (TCHAR
*wfullpath
)
2042 TCHAR wdrv
[MAX_PATH
];
2043 TCHAR wpath
[MAX_PATH
];
2044 TCHAR wfilename
[MAX_PATH
];
2045 TCHAR wext
[MAX_PATH
];
2047 _tsplitpath (wfullpath
, wdrv
, wpath
, wfilename
, wext
);
2049 if (_tcslen (wdrv
) != 0)
2051 /* we have a drive specified. */
2052 _tcscat (wdrv
, _T("\\"));
2053 return GetDriveType (wdrv
);
2057 /* No drive specified. */
2059 /* Is this a relative path, if so get current drive type. */
2060 if (wpath
[0] != _T('\\') ||
2061 (_tcslen (wpath
) > 2 && wpath
[0] == _T('\\')
2062 && wpath
[1] != _T('\\')))
2063 return GetDriveType (NULL
);
2065 UINT result
= GetDriveType (wpath
);
2067 /* Cannot guess the drive type, is this \\.\ ? */
2069 if (result
== DRIVE_NO_ROOT_DIR
&&
2070 _tcslen (wpath
) >= 4 && wpath
[0] == _T('\\') && wpath
[1] == _T('\\')
2071 && wpath
[2] == _T('.') && wpath
[3] == _T('\\'))
2073 if (_tcslen (wpath
) == 4)
2074 _tcscat (wpath
, wfilename
);
2076 LPTSTR p
= &wpath
[4];
2077 LPTSTR b
= _tcschr (p
, _T('\\'));
2081 /* logical drive \\.\c\dir\file */
2087 _tcscat (p
, _T(":\\"));
2089 return GetDriveType (p
);
2096 /* This MingW section contains code to work with ACL. */
2098 __gnat_check_OWNER_ACL (TCHAR
*wname
,
2099 DWORD CheckAccessDesired
,
2100 GENERIC_MAPPING CheckGenericMapping
)
2102 DWORD dwAccessDesired
, dwAccessAllowed
;
2103 PRIVILEGE_SET PrivilegeSet
;
2104 DWORD dwPrivSetSize
= sizeof (PRIVILEGE_SET
);
2105 BOOL fAccessGranted
= FALSE
;
2106 HANDLE hToken
= NULL
;
2108 SECURITY_DESCRIPTOR
* pSD
= NULL
;
2111 (wname
, OWNER_SECURITY_INFORMATION
|
2112 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
2115 if ((pSD
= (SECURITY_DESCRIPTOR
*) HeapAlloc
2116 (GetProcessHeap (), HEAP_ZERO_MEMORY
, nLength
)) == NULL
)
2119 /* Obtain the security descriptor. */
2121 if (!GetFileSecurity
2122 (wname
, OWNER_SECURITY_INFORMATION
|
2123 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
2124 pSD
, nLength
, &nLength
))
2127 if (!ImpersonateSelf (SecurityImpersonation
))
2130 if (!OpenThreadToken
2131 (GetCurrentThread(), TOKEN_DUPLICATE
| TOKEN_QUERY
, FALSE
, &hToken
))
2134 /* Undoes the effect of ImpersonateSelf. */
2138 /* We want to test for write permissions. */
2140 dwAccessDesired
= CheckAccessDesired
;
2142 MapGenericMask (&dwAccessDesired
, &CheckGenericMapping
);
2145 (pSD
, /* security descriptor to check */
2146 hToken
, /* impersonation token */
2147 dwAccessDesired
, /* requested access rights */
2148 &CheckGenericMapping
, /* pointer to GENERIC_MAPPING */
2149 &PrivilegeSet
, /* receives privileges used in check */
2150 &dwPrivSetSize
, /* size of PrivilegeSet buffer */
2151 &dwAccessAllowed
, /* receives mask of allowed access rights */
2155 CloseHandle (hToken
);
2156 HeapFree (GetProcessHeap (), 0, pSD
);
2157 return fAccessGranted
;
2161 CloseHandle (hToken
);
2162 HeapFree (GetProcessHeap (), 0, pSD
);
2167 __gnat_set_OWNER_ACL (TCHAR
*wname
,
2169 DWORD AccessPermissions
)
2171 PACL pOldDACL
= NULL
;
2172 PACL pNewDACL
= NULL
;
2173 PSECURITY_DESCRIPTOR pSD
= NULL
;
2175 TCHAR username
[100];
2178 /* Get current user, he will act as the owner */
2180 if (!GetUserName (username
, &unsize
))
2183 if (GetNamedSecurityInfo
2186 DACL_SECURITY_INFORMATION
,
2187 NULL
, NULL
, &pOldDACL
, NULL
, &pSD
) != ERROR_SUCCESS
)
2190 BuildExplicitAccessWithName
2191 (&ea
, username
, AccessPermissions
, (ACCESS_MODE
) AccessMode
, NO_INHERITANCE
);
2193 if (AccessMode
== SET_ACCESS
)
2195 /* SET_ACCESS, we want to set an explicte set of permissions, do not
2196 merge with current DACL. */
2197 if (SetEntriesInAcl (1, &ea
, NULL
, &pNewDACL
) != ERROR_SUCCESS
)
2201 if (SetEntriesInAcl (1, &ea
, pOldDACL
, &pNewDACL
) != ERROR_SUCCESS
)
2204 if (SetNamedSecurityInfo
2205 (wname
, SE_FILE_OBJECT
,
2206 DACL_SECURITY_INFORMATION
, NULL
, NULL
, pNewDACL
, NULL
) != ERROR_SUCCESS
)
2210 LocalFree (pNewDACL
);
2213 /* Check if it is possible to use ACL for wname, the file must not be on a
2217 __gnat_can_use_acl (TCHAR
*wname
)
2219 return __gnat_use_acl
&& GetDriveTypeFromPath (wname
) != DRIVE_REMOTE
;
2222 #endif /* defined (_WIN32) && !defined (RTX) */
2225 __gnat_is_readable_file_attr (char* name
, struct file_attributes
* attr
)
2227 if (attr
->readable
== ATTR_UNSET
)
2229 #if defined (_WIN32) && !defined (RTX)
2230 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2231 GENERIC_MAPPING GenericMapping
;
2233 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2235 if (__gnat_can_use_acl (wname
))
2237 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2238 GenericMapping
.GenericRead
= GENERIC_READ
;
2240 __gnat_check_OWNER_ACL (wname
, FILE_READ_DATA
, GenericMapping
);
2243 attr
->readable
= GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
;
2245 __gnat_stat_to_attr (-1, name
, attr
);
2249 return attr
->readable
;
2253 __gnat_is_readable_file (char *name
)
2255 struct file_attributes attr
;
2257 __gnat_reset_attributes (&attr
);
2258 return __gnat_is_readable_file_attr (name
, &attr
);
2262 __gnat_is_writable_file_attr (char* name
, struct file_attributes
* attr
)
2264 if (attr
->writable
== ATTR_UNSET
)
2266 #if defined (_WIN32) && !defined (RTX)
2267 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2268 GENERIC_MAPPING GenericMapping
;
2270 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2272 if (__gnat_can_use_acl (wname
))
2274 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2275 GenericMapping
.GenericWrite
= GENERIC_WRITE
;
2277 attr
->writable
= __gnat_check_OWNER_ACL
2278 (wname
, FILE_WRITE_DATA
| FILE_APPEND_DATA
, GenericMapping
)
2279 && !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2283 !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2286 __gnat_stat_to_attr (-1, name
, attr
);
2290 return attr
->writable
;
2294 __gnat_is_writable_file (char *name
)
2296 struct file_attributes attr
;
2298 __gnat_reset_attributes (&attr
);
2299 return __gnat_is_writable_file_attr (name
, &attr
);
2303 __gnat_is_executable_file_attr (char* name
, struct file_attributes
* attr
)
2305 if (attr
->executable
== ATTR_UNSET
)
2307 #if defined (_WIN32) && !defined (RTX)
2308 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2309 GENERIC_MAPPING GenericMapping
;
2311 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2313 if (__gnat_can_use_acl (wname
))
2315 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2316 GenericMapping
.GenericExecute
= GENERIC_EXECUTE
;
2319 __gnat_check_OWNER_ACL (wname
, FILE_EXECUTE
, GenericMapping
);
2323 TCHAR
*l
, *last
= _tcsstr(wname
, _T(".exe"));
2325 /* look for last .exe */
2327 while ((l
= _tcsstr(last
+1, _T(".exe"))))
2331 GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
2332 && (last
- wname
) == (int) (_tcslen (wname
) - 4);
2335 __gnat_stat_to_attr (-1, name
, attr
);
2339 return attr
->regular
&& attr
->executable
;
2343 __gnat_is_executable_file (char *name
)
2345 struct file_attributes attr
;
2347 __gnat_reset_attributes (&attr
);
2348 return __gnat_is_executable_file_attr (name
, &attr
);
2352 __gnat_set_writable (char *name
)
2354 #if defined (_WIN32) && !defined (RTX)
2355 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2357 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2359 if (__gnat_can_use_acl (wname
))
2360 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_WRITE
);
2363 (wname
, GetFileAttributes (wname
) & ~FILE_ATTRIBUTE_READONLY
);
2364 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2365 ! defined(__nucleus__)
2366 GNAT_STRUCT_STAT statbuf
;
2368 if (GNAT_STAT (name
, &statbuf
) == 0)
2370 statbuf
.st_mode
= statbuf
.st_mode
| S_IWUSR
;
2371 chmod (name
, statbuf
.st_mode
);
2376 /* must match definition in s-os_lib.ads */
2382 __gnat_set_executable (char *name
, int mode
)
2384 #if defined (_WIN32) && !defined (RTX)
2385 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2387 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2389 if (__gnat_can_use_acl (wname
))
2390 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_EXECUTE
);
2392 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2393 ! defined(__nucleus__)
2394 GNAT_STRUCT_STAT statbuf
;
2396 if (GNAT_STAT (name
, &statbuf
) == 0)
2399 statbuf
.st_mode
= statbuf
.st_mode
| S_IXUSR
;
2401 statbuf
.st_mode
= statbuf
.st_mode
| S_IXGRP
;
2402 if (mode
& S_OTHERS
)
2403 statbuf
.st_mode
= statbuf
.st_mode
| S_IXOTH
;
2404 chmod (name
, statbuf
.st_mode
);
2410 __gnat_set_non_writable (char *name
)
2412 #if defined (_WIN32) && !defined (RTX)
2413 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2415 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2417 if (__gnat_can_use_acl (wname
))
2418 __gnat_set_OWNER_ACL
2419 (wname
, DENY_ACCESS
,
2420 FILE_WRITE_DATA
| FILE_APPEND_DATA
|
2421 FILE_WRITE_EA
| FILE_WRITE_ATTRIBUTES
);
2424 (wname
, GetFileAttributes (wname
) | FILE_ATTRIBUTE_READONLY
);
2425 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2426 ! defined(__nucleus__)
2427 GNAT_STRUCT_STAT statbuf
;
2429 if (GNAT_STAT (name
, &statbuf
) == 0)
2431 statbuf
.st_mode
= statbuf
.st_mode
& 07577;
2432 chmod (name
, statbuf
.st_mode
);
2438 __gnat_set_readable (char *name
)
2440 #if defined (_WIN32) && !defined (RTX)
2441 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2443 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2445 if (__gnat_can_use_acl (wname
))
2446 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_READ
);
2448 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2449 ! defined(__nucleus__)
2450 GNAT_STRUCT_STAT statbuf
;
2452 if (GNAT_STAT (name
, &statbuf
) == 0)
2454 chmod (name
, statbuf
.st_mode
| S_IREAD
);
2460 __gnat_set_non_readable (char *name
)
2462 #if defined (_WIN32) && !defined (RTX)
2463 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2465 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2467 if (__gnat_can_use_acl (wname
))
2468 __gnat_set_OWNER_ACL (wname
, DENY_ACCESS
, FILE_GENERIC_READ
);
2470 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2471 ! defined(__nucleus__)
2472 GNAT_STRUCT_STAT statbuf
;
2474 if (GNAT_STAT (name
, &statbuf
) == 0)
2476 chmod (name
, statbuf
.st_mode
& (~S_IREAD
));
2482 __gnat_is_symbolic_link_attr (char* name ATTRIBUTE_UNUSED
,
2483 struct file_attributes
* attr
)
2485 if (attr
->symbolic_link
== ATTR_UNSET
)
2487 #if defined (__vxworks) || defined (__nucleus__)
2488 attr
->symbolic_link
= 0;
2490 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
2492 GNAT_STRUCT_STAT statbuf
;
2493 ret
= GNAT_LSTAT (name
, &statbuf
);
2494 attr
->symbolic_link
= (!ret
&& S_ISLNK (statbuf
.st_mode
));
2496 attr
->symbolic_link
= 0;
2499 return attr
->symbolic_link
;
2503 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED
)
2505 struct file_attributes attr
;
2507 __gnat_reset_attributes (&attr
);
2508 return __gnat_is_symbolic_link_attr (name
, &attr
);
2511 #if defined (sun) && defined (__SVR4)
2512 /* Using fork on Solaris will duplicate all the threads. fork1, which
2513 duplicates only the active thread, must be used instead, or spawning
2514 subprocess from a program with tasking will lead into numerous problems. */
2519 __gnat_portable_spawn (char *args
[] ATTRIBUTE_UNUSED
)
2521 int status ATTRIBUTE_UNUSED
= 0;
2522 int finished ATTRIBUTE_UNUSED
;
2523 int pid ATTRIBUTE_UNUSED
;
2525 #if defined (__vxworks) || defined(__nucleus__) || defined(RTX) \
2526 || defined(__PikeOS__)
2529 #elif defined (_WIN32)
2530 /* args[0] must be quotes as it could contain a full pathname with spaces */
2531 char *args_0
= args
[0];
2532 args
[0] = (char *)xmalloc (strlen (args_0
) + 3);
2533 strcpy (args
[0], "\"");
2534 strcat (args
[0], args_0
);
2535 strcat (args
[0], "\"");
2537 status
= spawnvp (P_WAIT
, args_0
, (char* const*)args
);
2539 /* restore previous value */
2541 args
[0] = (char *)args_0
;
2557 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2559 return -1; /* execv is in parent context on VMS. */
2566 finished
= waitpid (pid
, &status
, 0);
2568 if (finished
!= pid
|| WIFEXITED (status
) == 0)
2571 return WEXITSTATUS (status
);
2577 /* Create a copy of the given file descriptor.
2578 Return -1 if an error occurred. */
2581 __gnat_dup (int oldfd
)
2583 #if defined (__vxworks) && !defined (__RTP__)
2584 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2592 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
2593 Return -1 if an error occurred. */
2596 __gnat_dup2 (int oldfd ATTRIBUTE_UNUSED
, int newfd ATTRIBUTE_UNUSED
)
2598 #if defined (__vxworks) && !defined (__RTP__)
2599 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2602 #elif defined (__PikeOS__)
2603 /* Not supported. */
2605 #elif defined (_WIN32)
2606 /* Special case when oldfd and newfd are identical and are the standard
2607 input, output or error as this makes Windows XP hangs. Note that we
2608 do that only for standard file descriptors that are known to be valid. */
2609 if (oldfd
== newfd
&& newfd
>= 0 && newfd
<= 2)
2612 return dup2 (oldfd
, newfd
);
2614 return dup2 (oldfd
, newfd
);
2619 __gnat_number_of_cpus (void)
2623 #if defined (linux) || defined (sun) || defined (AIX) || defined (__APPLE__)
2624 cores
= (int) sysconf (_SC_NPROCESSORS_ONLN
);
2626 #elif defined (__hpux__)
2627 struct pst_dynamic psd
;
2628 if (pstat_getdynamic (&psd
, sizeof (psd
), 1, 0) != -1)
2629 cores
= (int) psd
.psd_proc_cnt
;
2631 #elif defined (_WIN32)
2632 SYSTEM_INFO sysinfo
;
2633 GetSystemInfo (&sysinfo
);
2634 cores
= (int) sysinfo
.dwNumberOfProcessors
;
2637 int code
= SYI$_ACTIVECPU_CNT
;
2641 status
= LIB$
GETSYI (&code
, &res
);
2642 if ((status
& 1) != 0)
2645 #elif defined (_WRS_CONFIG_SMP)
2646 unsigned int vxCpuConfiguredGet (void);
2648 cores
= vxCpuConfiguredGet ();
2655 /* WIN32 code to implement a wait call that wait for any child process. */
2657 #if defined (_WIN32) && !defined (RTX)
2659 /* Synchronization code, to be thread safe. */
2663 /* For the Cert run times on native Windows we use dummy functions
2664 for locking and unlocking tasks since we do not support multiple
2665 threads on this configuration (Cert run time on native Windows). */
2667 static void dummy (void)
2671 void (*Lock_Task
) () = &dummy
;
2672 void (*Unlock_Task
) () = &dummy
;
2676 #define Lock_Task system__soft_links__lock_task
2677 extern void (*Lock_Task
) (void);
2679 #define Unlock_Task system__soft_links__unlock_task
2680 extern void (*Unlock_Task
) (void);
2684 static HANDLE
*HANDLES_LIST
= NULL
;
2685 static int *PID_LIST
= NULL
, plist_length
= 0, plist_max_length
= 0;
2688 add_handle (HANDLE h
, int pid
)
2691 /* -------------------- critical section -------------------- */
2694 if (plist_length
== plist_max_length
)
2696 plist_max_length
+= 1000;
2698 (void **) xrealloc (HANDLES_LIST
, sizeof (HANDLE
) * plist_max_length
);
2700 (int *) xrealloc (PID_LIST
, sizeof (int) * plist_max_length
);
2703 HANDLES_LIST
[plist_length
] = h
;
2704 PID_LIST
[plist_length
] = pid
;
2708 /* -------------------- critical section -------------------- */
2712 __gnat_win32_remove_handle (HANDLE h
, int pid
)
2716 /* -------------------- critical section -------------------- */
2719 for (j
= 0; j
< plist_length
; j
++)
2721 if ((HANDLES_LIST
[j
] == h
) || (PID_LIST
[j
] == pid
))
2725 HANDLES_LIST
[j
] = HANDLES_LIST
[plist_length
];
2726 PID_LIST
[j
] = PID_LIST
[plist_length
];
2732 /* -------------------- critical section -------------------- */
2736 win32_no_block_spawn (char *command
, char *args
[], HANDLE
*h
, int *pid
)
2740 PROCESS_INFORMATION PI
;
2741 SECURITY_ATTRIBUTES SA
;
2746 /* compute the total command line length */
2750 csize
+= strlen (args
[k
]) + 1;
2754 full_command
= (char *) xmalloc (csize
);
2757 SI
.cb
= sizeof (STARTUPINFO
);
2758 SI
.lpReserved
= NULL
;
2759 SI
.lpReserved2
= NULL
;
2760 SI
.lpDesktop
= NULL
;
2764 SI
.wShowWindow
= SW_HIDE
;
2766 /* Security attributes. */
2767 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
2768 SA
.bInheritHandle
= TRUE
;
2769 SA
.lpSecurityDescriptor
= NULL
;
2771 /* Prepare the command string. */
2772 strcpy (full_command
, command
);
2773 strcat (full_command
, " ");
2778 strcat (full_command
, args
[k
]);
2779 strcat (full_command
, " ");
2784 int wsize
= csize
* 2;
2785 TCHAR
*wcommand
= (TCHAR
*) xmalloc (wsize
);
2787 S2WSC (wcommand
, full_command
, wsize
);
2789 free (full_command
);
2791 result
= CreateProcess
2792 (NULL
, wcommand
, &SA
, NULL
, TRUE
,
2793 GetPriorityClass (GetCurrentProcess()), NULL
, NULL
, &SI
, &PI
);
2800 CloseHandle (PI
.hThread
);
2802 *pid
= PI
.dwProcessId
;
2812 win32_wait (int *status
)
2814 DWORD exitcode
, pid
;
2821 if (plist_length
== 0)
2829 /* -------------------- critical section -------------------- */
2832 hl_len
= plist_length
;
2834 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * hl_len
);
2836 memmove (hl
, HANDLES_LIST
, sizeof (HANDLE
) * hl_len
);
2839 /* -------------------- critical section -------------------- */
2841 res
= WaitForMultipleObjects (hl_len
, hl
, FALSE
, INFINITE
);
2842 h
= hl
[res
- WAIT_OBJECT_0
];
2844 GetExitCodeProcess (h
, &exitcode
);
2845 pid
= PID_LIST
[res
- WAIT_OBJECT_0
];
2846 __gnat_win32_remove_handle (h
, -1);
2850 *status
= (int) exitcode
;
2857 __gnat_portable_no_block_spawn (char *args
[] ATTRIBUTE_UNUSED
)
2860 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX) \
2861 || defined (__PikeOS__)
2862 /* Not supported. */
2865 #elif defined (_WIN32)
2870 win32_no_block_spawn (args
[0], args
, &h
, &pid
);
2873 add_handle (h
, pid
);
2886 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2888 return -1; /* execv is in parent context on VMS. */
2900 __gnat_portable_wait (int *process_status
)
2905 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX) \
2906 || defined (__PikeOS__)
2907 /* Not sure what to do here, so do nothing but return zero. */
2909 #elif defined (_WIN32)
2911 pid
= win32_wait (&status
);
2915 pid
= waitpid (-1, &status
, 0);
2916 status
= status
& 0xffff;
2919 *process_status
= status
;
2924 __gnat_os_exit (int status
)
2929 /* Locate file on path, that matches a predicate */
2932 __gnat_locate_file_with_predicate (char *file_name
, char *path_val
,
2933 int (*predicate
)(char *))
2936 char *file_path
= (char *) alloca (strlen (file_name
) + 1);
2939 /* Return immediately if file_name is empty */
2941 if (*file_name
== '\0')
2944 /* Remove quotes around file_name if present */
2950 strcpy (file_path
, ptr
);
2952 ptr
= file_path
+ strlen (file_path
) - 1;
2957 /* Handle absolute pathnames. */
2959 absolute
= __gnat_is_absolute_path (file_path
, strlen (file_name
));
2963 if (predicate (file_path
))
2964 return xstrdup (file_path
);
2969 /* If file_name include directory separator(s), try it first as
2970 a path name relative to the current directory */
2971 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
2976 if (predicate (file_name
))
2977 return xstrdup (file_name
);
2984 /* The result has to be smaller than path_val + file_name. */
2986 (char *) alloca (strlen (path_val
) + strlen (file_name
) + 2);
2990 /* Skip the starting quote */
2992 if (*path_val
== '"')
2995 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
2996 *ptr
++ = *path_val
++;
2998 /* If directory is empty, it is the current directory*/
3000 if (ptr
== file_path
)
3007 /* Skip the ending quote */
3012 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
3013 *++ptr
= DIR_SEPARATOR
;
3015 strcpy (++ptr
, file_name
);
3017 if (predicate (file_path
))
3018 return xstrdup (file_path
);
3023 /* Skip path separator */
3032 /* Locate an executable file, give a Path value. */
3035 __gnat_locate_executable_file (char *file_name
, char *path_val
)
3037 return __gnat_locate_file_with_predicate
3038 (file_name
, path_val
, &__gnat_is_executable_file
);
3041 /* Locate a regular file, give a Path value. */
3044 __gnat_locate_regular_file (char *file_name
, char *path_val
)
3046 return __gnat_locate_file_with_predicate
3047 (file_name
, path_val
, &__gnat_is_regular_file
);
3050 /* Locate an executable given a Path argument. This routine is only used by
3051 gnatbl and should not be used otherwise. Use locate_exec_on_path
3055 __gnat_locate_exec (char *exec_name
, char *path_val
)
3058 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
3060 char *full_exec_name
=
3062 (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
3064 strcpy (full_exec_name
, exec_name
);
3065 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
3066 ptr
= __gnat_locate_executable_file (full_exec_name
, path_val
);
3069 return __gnat_locate_executable_file (exec_name
, path_val
);
3073 return __gnat_locate_executable_file (exec_name
, path_val
);
3076 /* Locate an executable using the Systems default PATH. */
3079 __gnat_locate_exec_on_path (char *exec_name
)
3083 #if defined (_WIN32) && !defined (RTX)
3084 TCHAR
*wpath_val
= _tgetenv (_T("PATH"));
3086 /* In Win32 systems we expand the PATH as for XP environment
3087 variables are not automatically expanded. We also prepend the
3088 ".;" to the path to match normal NT path search semantics */
3090 #define EXPAND_BUFFER_SIZE 32767
3092 wapath_val
= (TCHAR
*) alloca (EXPAND_BUFFER_SIZE
);
3094 wapath_val
[0] = '.';
3095 wapath_val
[1] = ';';
3097 DWORD res
= ExpandEnvironmentStrings
3098 (wpath_val
, &wapath_val
[2], EXPAND_BUFFER_SIZE
- 2);
3100 if (!res
) wapath_val
[0] = _T('\0');
3102 apath_val
= (char *) alloca (EXPAND_BUFFER_SIZE
);
3104 WS2SC (apath_val
, wapath_val
, EXPAND_BUFFER_SIZE
);
3105 return __gnat_locate_exec (exec_name
, apath_val
);
3110 char *path_val
= "/VAXC$PATH";
3112 char *path_val
= getenv ("PATH");
3114 if (path_val
== NULL
) return NULL
;
3115 apath_val
= (char *) alloca (strlen (path_val
) + 1);
3116 strcpy (apath_val
, path_val
);
3117 return __gnat_locate_exec (exec_name
, apath_val
);
3123 /* These functions are used to translate to and from VMS and Unix syntax
3124 file, directory and path specifications. */
3127 #define MAXNAMES 256
3128 #define NEW_CANONICAL_FILELIST_INCREMENT 64
3130 static char new_canonical_dirspec
[MAXPATH
];
3131 static char new_canonical_filespec
[MAXPATH
];
3132 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
3133 static unsigned new_canonical_filelist_index
;
3134 static unsigned new_canonical_filelist_in_use
;
3135 static unsigned new_canonical_filelist_allocated
;
3136 static char **new_canonical_filelist
;
3137 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
3138 static char new_host_dirspec
[MAXPATH
];
3139 static char new_host_filespec
[MAXPATH
];
3141 /* Routine is called repeatedly by decc$from_vms via
3142 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
3146 wildcard_translate_unix (char *name
)
3149 char buff
[MAXPATH
];
3151 strncpy (buff
, name
, MAXPATH
);
3152 buff
[MAXPATH
- 1] = (char) 0;
3153 ver
= strrchr (buff
, '.');
3155 /* Chop off the version. */
3159 /* Dynamically extend the allocation by the increment. */
3160 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
3162 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
3163 new_canonical_filelist
= (char **) xrealloc
3164 (new_canonical_filelist
,
3165 new_canonical_filelist_allocated
* sizeof (char *));
3168 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
3173 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
3174 full translation and copy the results into a list (_init), then return them
3175 one at a time (_next). If onlydirs set, only expand directory files. */
3178 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
3181 char buff
[MAXPATH
];
3183 len
= strlen (filespec
);
3184 strncpy (buff
, filespec
, MAXPATH
);
3186 /* Only look for directories */
3187 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
3188 strncat (buff
, "*.dir", MAXPATH
);
3190 buff
[MAXPATH
- 1] = (char) 0;
3192 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
3194 /* Remove the .dir extension. */
3200 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3202 ext
= strstr (new_canonical_filelist
[i
], ".dir");
3208 return new_canonical_filelist_in_use
;
3211 /* Return the next filespec in the list. */
3214 __gnat_to_canonical_file_list_next (void)
3216 return new_canonical_filelist
[new_canonical_filelist_index
++];
3219 /* Free storage used in the wildcard expansion. */
3222 __gnat_to_canonical_file_list_free (void)
3226 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3227 free (new_canonical_filelist
[i
]);
3229 free (new_canonical_filelist
);
3231 new_canonical_filelist_in_use
= 0;
3232 new_canonical_filelist_allocated
= 0;
3233 new_canonical_filelist_index
= 0;
3234 new_canonical_filelist
= 0;
3237 /* The functional equivalent of decc$translate_vms routine.
3238 Designed to produce the same output, but is protected against
3239 malformed paths (original version ACCVIOs in this case) and
3240 does not require VMS-specific DECC RTL. */
3242 #define NAM$C_MAXRSS 1024
3245 __gnat_translate_vms (char *src
)
3247 static char retbuf
[NAM$C_MAXRSS
+ 1];
3248 char *srcendpos
, *pos1
, *pos2
, *retpos
;
3249 int disp
, path_present
= 0;
3254 srcendpos
= strchr (src
, '\0');
3257 /* Look for the node and/or device in front of the path. */
3259 pos2
= strchr (pos1
, ':');
3261 if (pos2
&& (pos2
< srcendpos
) && (*(pos2
+ 1) == ':'))
3263 /* There is a node name. "node_name::" becomes "node_name!". */
3265 strncpy (retbuf
, pos1
, disp
);
3266 retpos
[disp
] = '!';
3267 retpos
= retpos
+ disp
+ 1;
3269 pos2
= strchr (pos1
, ':');
3274 /* There is a device name. "dev_name:" becomes "/dev_name/". */
3277 strncpy (retpos
, pos1
, disp
);
3278 retpos
= retpos
+ disp
;
3283 /* No explicit device; we must look ahead and prepend /sys$disk/ if
3284 the path is absolute. */
3285 if ((*pos1
== '[' || *pos1
== '<') && (pos1
< srcendpos
)
3286 && !strchr (".-]>", *(pos1
+ 1)))
3288 strncpy (retpos
, "/sys$disk/", 10);
3292 /* Process the path part. */
3293 while (*pos1
== '[' || *pos1
== '<')
3297 if (*pos1
== ']' || *pos1
== '>')
3299 /* Special case, [] translates to '.'. */
3305 /* '[000000' means root dir. It can be present in the middle of
3306 the path due to expansion of logical devices, in which case
3308 if (!strncmp (pos1
, "000000", 6) && path_present
> 1 &&
3309 (*(pos1
+ 6) == ']' || *(pos1
+ 6) == '>' || *(pos1
+ 6) == '.'))
3312 if (*pos1
== '.') pos1
++;
3314 else if (*pos1
== '.')
3316 /* Relative path. */
3320 /* There is a qualified path. */
3321 while (*pos1
&& *pos1
!= ']' && *pos1
!= '>')
3326 /* '.' is used to separate directories. Replace it with '/'
3327 but only if there isn't already '/' just before. */
3328 if (*(retpos
- 1) != '/')
3331 if (pos1
+ 1 < srcendpos
3333 && *(pos1
+ 1) == '.')
3335 /* Ellipsis refers to entire subtree; replace
3344 /* When after '.' '[' '<' is equivalent to Unix ".." but
3345 there may be several in a row. */
3346 if (*(pos1
- 1) == '.' || *(pos1
- 1) == '[' ||
3349 while (*pos1
== '-')
3359 /* Otherwise fall through to default. */
3361 *(retpos
++) = *(pos1
++);
3368 if (pos1
< srcendpos
)
3370 /* Now add the actual file name, until the version suffix if any */
3373 pos2
= strchr (pos1
, ';');
3374 disp
= pos2
? (pos2
- pos1
) : (srcendpos
- pos1
);
3375 strncpy (retpos
, pos1
, disp
);
3377 if (pos2
&& pos2
< srcendpos
)
3379 /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
3381 disp
= srcendpos
- pos2
- 1;
3382 strncpy (retpos
, pos2
+ 1, disp
);
3392 /* Translate a VMS syntax directory specification in to Unix syntax. If
3393 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
3394 found, return input string. Also translate a dirname that contains no
3395 slashes, in case it's a logical name. */
3398 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
3402 strcpy (new_canonical_dirspec
, "");
3403 if (strlen (dirspec
))
3407 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
3409 strncpy (new_canonical_dirspec
,
3410 __gnat_translate_vms (dirspec
),
3413 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
3415 strncpy (new_canonical_dirspec
,
3416 __gnat_translate_vms (dirspec1
),
3421 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
3425 len
= strlen (new_canonical_dirspec
);
3426 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
3427 strncat (new_canonical_dirspec
, "/", MAXPATH
);
3429 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
3431 return new_canonical_dirspec
;
3435 /* Translate a VMS syntax file specification into Unix syntax.
3436 If no indicators of VMS syntax found, check if it's an uppercase
3437 alphanumeric_ name and if so try it out as an environment
3438 variable (logical name). If all else fails return the
3442 __gnat_to_canonical_file_spec (char *filespec
)
3446 strncpy (new_canonical_filespec
, "", MAXPATH
);
3448 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3450 char *tspec
= (char *) __gnat_translate_vms (filespec
);
3452 if (tspec
!= (char *) -1)
3453 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3455 else if ((strlen (filespec
) == strspn (filespec
,
3456 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
3457 && (filespec1
= getenv (filespec
)))
3459 char *tspec
= (char *) __gnat_translate_vms (filespec1
);
3461 if (tspec
!= (char *) -1)
3462 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3466 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
3469 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
3471 return new_canonical_filespec
;
3474 /* Translate a VMS syntax path specification into Unix syntax.
3475 If no indicators of VMS syntax found, return input string. */
3478 __gnat_to_canonical_path_spec (char *pathspec
)
3480 char *curr
, *next
, buff
[MAXPATH
];
3485 /* If there are /'s, assume it's a Unix path spec and return. */
3486 if (strchr (pathspec
, '/'))
3489 new_canonical_pathspec
[0] = 0;
3494 next
= strchr (curr
, ',');
3496 next
= strchr (curr
, 0);
3498 strncpy (buff
, curr
, next
- curr
);
3499 buff
[next
- curr
] = 0;
3501 /* Check for wildcards and expand if present. */
3502 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
3506 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
3507 for (i
= 0; i
< dirs
; i
++)
3511 next_dir
= __gnat_to_canonical_file_list_next ();
3512 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
3514 /* Don't append the separator after the last expansion. */
3516 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3519 __gnat_to_canonical_file_list_free ();
3522 strncat (new_canonical_pathspec
,
3523 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
3528 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3532 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
3534 return new_canonical_pathspec
;
3537 static char filename_buff
[MAXPATH
];
3540 translate_unix (char *name
, int type ATTRIBUTE_UNUSED
)
3542 strncpy (filename_buff
, name
, MAXPATH
);
3543 filename_buff
[MAXPATH
- 1] = (char) 0;
3547 /* Translate a Unix syntax directory specification into VMS syntax. The
3548 PREFIXFLAG has no effect, but is kept for symmetry with
3549 to_canonical_dir_spec. If indicators of VMS syntax found, return input
3553 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3555 int len
= strlen (dirspec
);
3557 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
3558 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3560 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
3561 return new_host_dirspec
;
3563 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
3565 new_host_dirspec
[len
- 1] = 0;
3569 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
3570 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
3571 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3573 return new_host_dirspec
;
3576 /* Translate a Unix syntax file specification into VMS syntax.
3577 If indicators of VMS syntax found, return input string. */
3580 __gnat_to_host_file_spec (char *filespec
)
3582 strncpy (new_host_filespec
, "", MAXPATH
);
3583 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3585 strncpy (new_host_filespec
, filespec
, MAXPATH
);
3589 decc$
to_vms (filespec
, translate_unix
, 1, 1);
3590 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
3593 new_host_filespec
[MAXPATH
- 1] = (char) 0;
3595 return new_host_filespec
;
3599 __gnat_adjust_os_resource_limits (void)
3601 SYS$
ADJWSL (131072, 0);
3606 /* Dummy functions for Osint import for non-VMS systems. */
3609 __gnat_to_canonical_file_list_init (char *dirspec ATTRIBUTE_UNUSED
,
3610 int onlydirs ATTRIBUTE_UNUSED
)
3616 __gnat_to_canonical_file_list_next (void)
3618 static char empty
[] = "";
3623 __gnat_to_canonical_file_list_free (void)
3628 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3634 __gnat_to_canonical_file_spec (char *filespec
)
3640 __gnat_to_canonical_path_spec (char *pathspec
)
3646 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3652 __gnat_to_host_file_spec (char *filespec
)
3658 __gnat_adjust_os_resource_limits (void)
3664 #if defined (__mips_vxworks)
3668 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
3672 #if defined (IS_CROSS) \
3673 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3674 && defined (__SVR4)) \
3675 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3676 && ! (defined (linux) && defined (__ia64__)) \
3677 && ! (defined (linux) && defined (powerpc)) \
3678 && ! defined (__FreeBSD__) \
3679 && ! defined (__Lynx__) \
3680 && ! defined (__hpux__) \
3681 && ! defined (__APPLE__) \
3682 && ! defined (_AIX) \
3683 && ! defined (VMS) \
3684 && ! defined (__MINGW32__))
3686 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3687 just above for a list of native platforms that provide a non-dummy
3688 version of this procedure in libaddr2line.a. */
3691 convert_addresses (const char *file_name ATTRIBUTE_UNUSED
,
3692 void *addrs ATTRIBUTE_UNUSED
,
3693 int n_addr ATTRIBUTE_UNUSED
,
3694 void *buf ATTRIBUTE_UNUSED
,
3695 int *len ATTRIBUTE_UNUSED
)
3701 #if defined (_WIN32)
3702 int __gnat_argument_needs_quote
= 1;
3704 int __gnat_argument_needs_quote
= 0;
3707 /* This option is used to enable/disable object files handling from the
3708 binder file by the GNAT Project module. For example, this is disabled on
3709 Windows (prior to GCC 3.4) as it is already done by the mdll module.
3710 Stating with GCC 3.4 the shared libraries are not based on mdll
3711 anymore as it uses the GCC's -shared option */
3712 #if defined (_WIN32) \
3713 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3714 int __gnat_prj_add_obj_files
= 0;
3716 int __gnat_prj_add_obj_files
= 1;
3719 /* char used as prefix/suffix for environment variables */
3720 #if defined (_WIN32)
3721 char __gnat_environment_char
= '%';
3723 char __gnat_environment_char
= '$';
3726 /* This functions copy the file attributes from a source file to a
3729 mode = 0 : In this mode copy only the file time stamps (last access and
3730 last modification time stamps).
3732 mode = 1 : In this mode, time stamps and read/write/execute attributes are
3735 Returns 0 if operation was successful and -1 in case of error. */
3738 __gnat_copy_attribs (char *from ATTRIBUTE_UNUSED
, char *to ATTRIBUTE_UNUSED
,
3739 int mode ATTRIBUTE_UNUSED
)
3741 #if defined (VMS) || (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \
3742 defined (__nucleus__)
3745 #elif defined (_WIN32) && !defined (RTX)
3746 TCHAR wfrom
[GNAT_MAX_PATH_LEN
+ 2];
3747 TCHAR wto
[GNAT_MAX_PATH_LEN
+ 2];
3749 FILETIME fct
, flat
, flwt
;
3752 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
+ 2);
3753 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
+ 2);
3755 /* retrieve from times */
3758 (wfrom
, GENERIC_READ
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3760 if (hfrom
== INVALID_HANDLE_VALUE
)
3763 res
= GetFileTime (hfrom
, &fct
, &flat
, &flwt
);
3765 CloseHandle (hfrom
);
3770 /* retrieve from times */
3773 (wto
, GENERIC_WRITE
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3775 if (hto
== INVALID_HANDLE_VALUE
)
3778 res
= SetFileTime (hto
, NULL
, &flat
, &flwt
);
3785 /* Set file attributes in full mode. */
3789 DWORD attribs
= GetFileAttributes (wfrom
);
3791 if (attribs
== INVALID_FILE_ATTRIBUTES
)
3794 res
= SetFileAttributes (wto
, attribs
);
3802 GNAT_STRUCT_STAT fbuf
;
3803 struct utimbuf tbuf
;
3805 if (GNAT_STAT (from
, &fbuf
) == -1)
3810 tbuf
.actime
= fbuf
.st_atime
;
3811 tbuf
.modtime
= fbuf
.st_mtime
;
3813 if (utime (to
, &tbuf
) == -1)
3820 if (chmod (to
, fbuf
.st_mode
) == -1)
3831 __gnat_lseek (int fd
, long offset
, int whence
)
3833 return (int) lseek (fd
, offset
, whence
);
3836 /* This function returns the major version number of GCC being used. */
3838 get_gcc_version (void)
3843 return (int) (version_string
[0] - '0');
3848 * Set Close_On_Exec as indicated.
3849 * Note: this is used for both GNAT.OS_Lib and GNAT.Sockets.
3853 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED
,
3854 int close_on_exec_p ATTRIBUTE_UNUSED
)
3856 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3857 int flags
= fcntl (fd
, F_GETFD
, 0);
3860 if (close_on_exec_p
)
3861 flags
|= FD_CLOEXEC
;
3863 flags
&= ~FD_CLOEXEC
;
3864 return fcntl (fd
, F_SETFD
, flags
| FD_CLOEXEC
);
3865 #elif defined(_WIN32)
3866 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
3867 if (h
== (HANDLE
) -1)
3869 if (close_on_exec_p
)
3870 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
, 0);
3871 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
,
3872 HANDLE_FLAG_INHERIT
);
3874 /* TODO: Unimplemented. */
3879 /* Indicates if platforms supports automatic initialization through the
3880 constructor mechanism */
3882 __gnat_binder_supports_auto_init (void)
3891 /* Indicates that Stand-Alone Libraries are automatically initialized through
3892 the constructor mechanism */
3894 __gnat_sals_init_using_constructors (void)
3896 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3905 /* In RTX mode, the procedure to get the time (as file time) is different
3906 in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3907 we introduce an intermediate procedure to link against the corresponding
3908 one in each situation. */
3910 extern void GetTimeAsFileTime (LPFILETIME pTime
);
3912 void GetTimeAsFileTime (LPFILETIME pTime
)
3915 RtGetRtssTimeAsFileTime (pTime
); /* RTSS interface */
3917 GetSystemTimeAsFileTime (pTime
); /* w32 interface */
3922 /* Add symbol that is required to link. It would otherwise be taken from
3923 libgcc.a and it would try to use the gcc constructors that are not
3924 supported by Microsoft linker. */
3926 extern void __main (void);
3934 #if defined (__ANDROID__)
3936 #include <pthread.h>
3939 __gnat_lwp_self (void)
3941 return (void *) pthread_self ();
3944 #elif defined (linux)
3945 /* There is no function in the glibc to retrieve the LWP of the current
3946 thread. We need to do a system call in order to retrieve this
3948 #include <sys/syscall.h>
3950 __gnat_lwp_self (void)
3952 return (void *) syscall (__NR_gettid
);
3957 /* glibc versions earlier than 2.7 do not define the routines to handle
3958 dynamically allocated CPU sets. For these targets, we use the static
3963 /* Dynamic cpu sets */
3966 __gnat_cpu_alloc (size_t count
)
3968 return CPU_ALLOC (count
);
3972 __gnat_cpu_alloc_size (size_t count
)
3974 return CPU_ALLOC_SIZE (count
);
3978 __gnat_cpu_free (cpu_set_t
*set
)
3984 __gnat_cpu_zero (size_t count
, cpu_set_t
*set
)
3986 CPU_ZERO_S (count
, set
);
3990 __gnat_cpu_set (int cpu
, size_t count
, cpu_set_t
*set
)
3992 /* Ada handles CPU numbers starting from 1, while C identifies the first
3993 CPU by a 0, so we need to adjust. */
3994 CPU_SET_S (cpu
- 1, count
, set
);
3997 #else /* !CPU_ALLOC */
3999 /* Static cpu sets */
4002 __gnat_cpu_alloc (size_t count ATTRIBUTE_UNUSED
)
4004 return (cpu_set_t
*) xmalloc (sizeof (cpu_set_t
));
4008 __gnat_cpu_alloc_size (size_t count ATTRIBUTE_UNUSED
)
4010 return sizeof (cpu_set_t
);
4014 __gnat_cpu_free (cpu_set_t
*set
)
4020 __gnat_cpu_zero (size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
4026 __gnat_cpu_set (int cpu
, size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
4028 /* Ada handles CPU numbers starting from 1, while C identifies the first
4029 CPU by a 0, so we need to adjust. */
4030 CPU_SET (cpu
- 1, set
);
4032 #endif /* !CPU_ALLOC */
4035 /* Return the load address of the executable, or 0 if not known. In the
4036 specific case of error, (void *)-1 can be returned. Beware: this unit may
4037 be in a shared library. As low-level units are needed, we allow #include
4040 #if defined (__APPLE__)
4041 #include <mach-o/dyld.h>
4042 #elif 0 && defined (__linux__)
4047 __gnat_get_executable_load_address (void)
4049 #if defined (__APPLE__)
4050 return _dyld_get_image_header (0);
4052 #elif 0 && defined (__linux__)
4053 /* Currently disabled as it needs at least -ldl. */
4054 struct link_map
*map
= _r_debug
.r_map
;
4056 return (const void *)map
->l_addr
;