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));
245 #define DIR_SEPARATOR '\\'
250 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
251 defined in the current system. On DOS-like systems these flags control
252 whether the file is opened/created in text-translation mode (CR/LF in
253 external file mapped to LF in internal file), but in Unix-like systems,
254 no text translation is required, so these flags have no effect. */
264 #ifndef HOST_EXECUTABLE_SUFFIX
265 #define HOST_EXECUTABLE_SUFFIX ""
268 #ifndef HOST_OBJECT_SUFFIX
269 #define HOST_OBJECT_SUFFIX ".o"
272 #ifndef PATH_SEPARATOR
273 #define PATH_SEPARATOR ':'
276 #ifndef DIR_SEPARATOR
277 #define DIR_SEPARATOR '/'
280 /* Check for cross-compilation. */
281 #if defined (CROSS_COMPILE) || defined (CROSS_DIRECTORY_STRUCTURE)
283 int __gnat_is_cross_compiler
= 1;
286 int __gnat_is_cross_compiler
= 0;
289 char __gnat_dir_separator
= DIR_SEPARATOR
;
291 char __gnat_path_separator
= PATH_SEPARATOR
;
293 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
294 the base filenames that libraries specified with -lsomelib options
295 may have. This is used by GNATMAKE to check whether an executable
296 is up-to-date or not. The syntax is
298 library_template ::= { pattern ; } pattern NUL
299 pattern ::= [ prefix ] * [ postfix ]
301 These should only specify names of static libraries as it makes
302 no sense to determine at link time if dynamic-link libraries are
303 up to date or not. Any libraries that are not found are supposed
306 * if they are needed but not present, the link
309 * otherwise they are libraries in the system paths and so
310 they are considered part of the system and not checked
313 ??? This should be part of a GNAT host-specific compiler
314 file instead of being included in all user applications
315 as well. This is only a temporary work-around for 3.11b. */
317 #ifndef GNAT_LIBRARY_TEMPLATE
319 #define GNAT_LIBRARY_TEMPLATE "*.olb"
321 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
325 const char *__gnat_library_template
= GNAT_LIBRARY_TEMPLATE
;
327 /* This variable is used in hostparm.ads to say whether the host is a VMS
336 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
338 #elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__)
339 #define GNAT_MAX_PATH_LEN PATH_MAX
343 #if defined (__MINGW32__)
347 #include <sys/param.h>
351 #include <sys/param.h>
355 #define GNAT_MAX_PATH_LEN MAXPATHLEN
357 #define GNAT_MAX_PATH_LEN 256
362 /* Used for runtime check that Ada constant File_Attributes_Size is no
363 less than the actual size of struct file_attributes (see Osint
365 int __gnat_size_of_file_attributes
= sizeof (struct file_attributes
);
367 void __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
);
369 /* The __gnat_max_path_len variable is used to export the maximum
370 length of a path name to Ada code. max_path_len is also provided
371 for compatibility with older GNAT versions, please do not use
374 int __gnat_max_path_len
= GNAT_MAX_PATH_LEN
;
375 int max_path_len
= GNAT_MAX_PATH_LEN
;
377 /* Control whether we can use ACL on Windows. */
379 int __gnat_use_acl
= 1;
381 /* The following macro HAVE_READDIR_R should be defined if the
382 system provides the routine readdir_r. */
383 #undef HAVE_READDIR_R
385 #if defined(VMS) && defined (__LONG_POINTERS)
387 /* Return a 32 bit pointer to an array of 32 bit pointers
388 given a 64 bit pointer to an array of 64 bit pointers */
390 typedef __char_ptr32
*__char_ptr_char_ptr32
__attribute__ ((mode (SI
)));
392 static __char_ptr_char_ptr32
393 to_ptr32 (char **ptr64
)
396 __char_ptr_char_ptr32 short_argv
;
398 for (argc
= 0; ptr64
[argc
]; argc
++)
401 /* Reallocate argv with 32 bit pointers. */
402 short_argv
= (__char_ptr_char_ptr32
) decc$malloc
403 (sizeof (__char_ptr32
) * (argc
+ 1));
405 for (argc
= 0; ptr64
[argc
]; argc
++)
406 short_argv
[argc
] = (__char_ptr32
) decc$
strdup (ptr64
[argc
]);
408 short_argv
[argc
] = (__char_ptr32
) 0;
412 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
414 #define MAYBE_TO_PTR32(argv) argv
417 static const char ATTR_UNSET
= 127;
419 /* Reset the file attributes as if no system call had been performed */
422 __gnat_reset_attributes (struct file_attributes
* attr
)
424 attr
->exists
= ATTR_UNSET
;
425 attr
->error
= EINVAL
;
427 attr
->writable
= ATTR_UNSET
;
428 attr
->readable
= ATTR_UNSET
;
429 attr
->executable
= ATTR_UNSET
;
431 attr
->regular
= ATTR_UNSET
;
432 attr
->symbolic_link
= ATTR_UNSET
;
433 attr
->directory
= ATTR_UNSET
;
435 attr
->timestamp
= (OS_Time
)-2;
436 attr
->file_length
= -1;
440 __gnat_error_attributes (struct file_attributes
*attr
) {
445 __gnat_current_time (void)
447 time_t res
= time (NULL
);
448 return (OS_Time
) res
;
451 /* Return the current local time as a string in the ISO 8601 format of
452 "YYYY-MM-DD HH:MM:SS.SS". The returned string is 22 + 1 (NULL) characters
456 __gnat_current_time_string (char *result
)
458 const char *format
= "%Y-%m-%d %H:%M:%S";
459 /* Format string necessary to describe the ISO 8601 format */
461 const time_t t_val
= time (NULL
);
463 strftime (result
, 22, format
, localtime (&t_val
));
464 /* Convert the local time into a string following the ISO format, copying
465 at most 22 characters into the result string. */
470 /* The sub-seconds are manually set to zero since type time_t lacks the
471 precision necessary for nanoseconds. */
475 __gnat_to_gm_time (OS_Time
*p_time
, int *p_year
, int *p_month
, int *p_day
,
476 int *p_hours
, int *p_mins
, int *p_secs
)
479 time_t time
= (time_t) *p_time
;
482 /* On Windows systems, the time is sometimes rounded up to the nearest
483 even second, so if the number of seconds is odd, increment it. */
489 res
= localtime (&time
);
491 res
= gmtime (&time
);
496 *p_year
= res
->tm_year
;
497 *p_month
= res
->tm_mon
;
498 *p_day
= res
->tm_mday
;
499 *p_hours
= res
->tm_hour
;
500 *p_mins
= res
->tm_min
;
501 *p_secs
= res
->tm_sec
;
504 *p_year
= *p_month
= *p_day
= *p_hours
= *p_mins
= *p_secs
= 0;
508 __gnat_to_os_time (OS_Time
*p_time
, int year
, int month
, int day
,
509 int hours
, int mins
, int secs
)
521 /* returns -1 of failing, this is s-os_lib Invalid_Time */
523 *p_time
= (OS_Time
) mktime (&v
);
526 /* Place the contents of the symbolic link named PATH in the buffer BUF,
527 which has size BUFSIZ. If PATH is a symbolic link, then return the number
528 of characters of its content in BUF. Otherwise, return -1.
529 For systems not supporting symbolic links, always return -1. */
532 __gnat_readlink (char *path ATTRIBUTE_UNUSED
,
533 char *buf ATTRIBUTE_UNUSED
,
534 size_t bufsiz ATTRIBUTE_UNUSED
)
536 #if defined (_WIN32) || defined (VMS) \
537 || defined(__vxworks) || defined (__nucleus__) || defined (__PikeOS__)
540 return readlink (path
, buf
, bufsiz
);
544 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH.
545 If NEWPATH exists it will NOT be overwritten.
546 For systems not supporting symbolic links, always return -1. */
549 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED
,
550 char *newpath ATTRIBUTE_UNUSED
)
552 #if defined (_WIN32) || defined (VMS) \
553 || defined(__vxworks) || defined (__nucleus__) || defined (__PikeOS__)
556 return symlink (oldpath
, newpath
);
560 /* Try to lock a file, return 1 if success. */
562 #if defined (__vxworks) || defined (__nucleus__) \
563 || defined (_WIN32) || defined (VMS) || defined (__PikeOS__)
565 /* Version that does not use link. */
568 __gnat_try_lock (char *dir
, char *file
)
572 TCHAR wfull_path
[GNAT_MAX_PATH_LEN
];
573 TCHAR wfile
[GNAT_MAX_PATH_LEN
];
574 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
576 S2WSC (wdir
, dir
, GNAT_MAX_PATH_LEN
);
577 S2WSC (wfile
, file
, GNAT_MAX_PATH_LEN
);
579 _stprintf (wfull_path
, _T("%s%c%s"), wdir
, _T(DIR_SEPARATOR
), wfile
);
580 fd
= _topen (wfull_path
, O_CREAT
| O_EXCL
, 0600);
584 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
585 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
597 /* Version using link(), more secure over NFS. */
598 /* See TN 6913-016 for discussion ??? */
601 __gnat_try_lock (char *dir
, char *file
)
605 GNAT_STRUCT_STAT stat_result
;
608 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
609 sprintf (temp_file
, "%s%cTMP-%ld-%ld",
610 dir
, DIR_SEPARATOR
, (long)getpid(), (long)getppid ());
612 /* Create the temporary file and write the process number. */
613 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
619 /* Link it with the new file. */
620 link (temp_file
, full_path
);
622 /* Count the references on the old one. If we have a count of two, then
623 the link did succeed. Remove the temporary file before returning. */
624 __gnat_stat (temp_file
, &stat_result
);
626 return stat_result
.st_nlink
== 2;
630 /* Return the maximum file name length. */
633 __gnat_get_maximum_file_name_length (void)
636 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
645 /* Return nonzero if file names are case sensitive. */
647 static int file_names_case_sensitive_cache
= -1;
650 __gnat_get_file_names_case_sensitive (void)
652 if (file_names_case_sensitive_cache
== -1)
654 const char *sensitive
= getenv ("GNAT_FILE_NAME_CASE_SENSITIVE");
656 if (sensitive
!= NULL
657 && (sensitive
[0] == '0' || sensitive
[0] == '1')
658 && sensitive
[1] == '\0')
659 file_names_case_sensitive_cache
= sensitive
[0] - '0';
661 #if defined (VMS) || defined (WINNT) || defined (__APPLE__)
662 file_names_case_sensitive_cache
= 0;
664 file_names_case_sensitive_cache
= 1;
667 return file_names_case_sensitive_cache
;
670 /* Return nonzero if environment variables are case sensitive. */
673 __gnat_get_env_vars_case_sensitive (void)
675 #if defined (VMS) || defined (WINNT)
683 __gnat_get_default_identifier_character_set (void)
688 /* Return the current working directory. */
691 __gnat_get_current_dir (char *dir
, int *length
)
693 #if defined (__MINGW32__)
694 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
696 _tgetcwd (wdir
, *length
);
698 WS2SC (dir
, wdir
, GNAT_MAX_PATH_LEN
);
701 /* Force Unix style, which is what GNAT uses internally. */
702 getcwd (dir
, *length
, 0);
704 getcwd (dir
, *length
);
707 *length
= strlen (dir
);
709 if (dir
[*length
- 1] != DIR_SEPARATOR
)
711 dir
[*length
] = DIR_SEPARATOR
;
717 /* Return the suffix for object files. */
720 __gnat_get_object_suffix_ptr (int *len
, const char **value
)
722 *value
= HOST_OBJECT_SUFFIX
;
727 *len
= strlen (*value
);
732 /* Return the suffix for executable files. */
735 __gnat_get_executable_suffix_ptr (int *len
, const char **value
)
737 *value
= HOST_EXECUTABLE_SUFFIX
;
741 *len
= strlen (*value
);
746 /* Return the suffix for debuggable files. Usually this is the same as the
747 executable extension. */
750 __gnat_get_debuggable_suffix_ptr (int *len
, const char **value
)
752 *value
= HOST_EXECUTABLE_SUFFIX
;
757 *len
= strlen (*value
);
762 /* Returns the OS filename and corresponding encoding. */
765 __gnat_os_filename (char *filename ATTRIBUTE_UNUSED
,
766 char *w_filename ATTRIBUTE_UNUSED
,
767 char *os_name
, int *o_length
,
768 char *encoding ATTRIBUTE_UNUSED
, int *e_length
)
770 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
771 WS2SC (os_name
, (TCHAR
*)w_filename
, (DWORD
)*o_length
);
772 *o_length
= strlen (os_name
);
773 strcpy (encoding
, "encoding=utf8");
774 *e_length
= strlen (encoding
);
776 strcpy (os_name
, filename
);
777 *o_length
= strlen (filename
);
785 __gnat_unlink (char *path
)
787 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
789 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
791 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
792 return _tunlink (wpath
);
795 return unlink (path
);
802 __gnat_rename (char *from
, char *to
)
804 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
806 TCHAR wfrom
[GNAT_MAX_PATH_LEN
], wto
[GNAT_MAX_PATH_LEN
];
808 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
);
809 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
);
810 return _trename (wfrom
, wto
);
813 return rename (from
, to
);
817 /* Changing directory. */
820 __gnat_chdir (char *path
)
822 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
824 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
826 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
827 return _tchdir (wpath
);
834 /* Removing a directory. */
837 __gnat_rmdir (char *path
)
839 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
841 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
843 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
844 return _trmdir (wpath
);
846 #elif defined (VTHREADS)
847 /* rmdir not available */
854 #if defined (_WIN32) || defined (linux) || defined (sun) \
855 || defined (__FreeBSD__)
856 #define HAS_TARGET_WCHAR_T
859 #ifdef HAS_TARGET_WCHAR_T
864 __gnat_fputwc(int c
, FILE *stream
)
866 #ifdef HAS_TARGET_WCHAR_T
867 return fputwc ((wchar_t)c
, stream
);
869 return fputc (c
, stream
);
874 __gnat_fopen (char *path
, char *mode
, int encoding ATTRIBUTE_UNUSED
,
875 char *vms_form ATTRIBUTE_UNUSED
)
877 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
878 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
881 S2WS (wmode
, mode
, 10);
883 if (encoding
== Encoding_Unspecified
)
884 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
885 else if (encoding
== Encoding_UTF8
)
886 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
888 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
890 return _tfopen (wpath
, wmode
);
893 return decc$
fopen (path
, mode
);
896 char *local_form
= (char *) alloca (strlen (vms_form
) + 1);
897 /* Allocate an argument list of guaranteed ample length. */
898 unsigned long long *arg_list
=
899 (unsigned long long *) alloca (strlen (vms_form
) + 3);
903 arg_list
[1] = (unsigned long long) path
;
904 arg_list
[2] = (unsigned long long) mode
;
905 strcpy (local_form
, vms_form
);
907 /* Given a string such as "\"rfm=udf\",\"rat=cr\""
908 Split it into an argument list as "rfm=udf","rat=cr". */
910 for (i
= 0; *ptrb
; i
++)
912 ptrb
= strchr (ptrb
, '"');
913 ptre
= strchr (ptrb
+ 1, '"');
915 arg_list
[i
+ 3] = (unsigned long long) (ptrb
+ 1);
918 arg_list
[0] = i
+ 2;
919 /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
920 always a 32bit pointer. */
921 return LIB$
CALLG_64 (arg_list
, &decc$fopen
);
924 return GNAT_FOPEN (path
, mode
);
929 __gnat_freopen (char *path
,
932 int encoding ATTRIBUTE_UNUSED
,
933 char *vms_form ATTRIBUTE_UNUSED
)
935 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
936 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
939 S2WS (wmode
, mode
, 10);
941 if (encoding
== Encoding_Unspecified
)
942 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
943 else if (encoding
== Encoding_UTF8
)
944 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
946 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
948 return _tfreopen (wpath
, wmode
, stream
);
951 return decc$
freopen (path
, mode
, stream
);
954 char *local_form
= (char *) alloca (strlen (vms_form
) + 1);
955 /* Allocate an argument list of guaranteed ample length. */
956 unsigned long long *arg_list
=
957 (unsigned long long *) alloca (strlen (vms_form
) + 4);
961 arg_list
[1] = (unsigned long long) path
;
962 arg_list
[2] = (unsigned long long) mode
;
963 arg_list
[3] = (unsigned long long) stream
;
964 strcpy (local_form
, vms_form
);
966 /* Given a string such as "\"rfm=udf\",\"rat=cr\""
967 Split it into an argument list as "rfm=udf","rat=cr". */
969 for (i
= 0; *ptrb
; i
++)
971 ptrb
= strchr (ptrb
, '"');
972 ptre
= strchr (ptrb
+ 1, '"');
974 arg_list
[i
+ 4] = (unsigned long long) (ptrb
+ 1);
977 arg_list
[0] = i
+ 3;
978 /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
979 always a 32bit pointer. */
980 return LIB$
CALLG_64 (arg_list
, &decc$freopen
);
983 return freopen (path
, mode
, stream
);
988 __gnat_open_read (char *path
, int fmode
)
991 int o_fmode
= O_BINARY
;
997 /* Optional arguments mbc,deq,fop increase read performance. */
998 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
999 "mbc=16", "deq=64", "fop=tef");
1000 #elif defined (__vxworks)
1001 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
1002 #elif defined (__MINGW32__)
1004 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1006 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1007 fd
= _topen (wpath
, O_RDONLY
| o_fmode
, 0444);
1010 fd
= open (path
, O_RDONLY
| o_fmode
);
1013 return fd
< 0 ? -1 : fd
;
1016 #if defined (__MINGW32__)
1017 #define PERM (S_IREAD | S_IWRITE)
1019 /* Excerpt from DECC C RTL Reference Manual:
1020 To create files with OpenVMS RMS default protections using the UNIX
1021 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
1022 and open with a file-protection mode argument of 0777 in a program
1023 that never specifically calls umask. These default protections include
1024 correctly establishing protections based on ACLs, previous versions of
1025 files, and so on. */
1028 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
1032 __gnat_open_rw (char *path
, int fmode
)
1035 int o_fmode
= O_BINARY
;
1041 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
1042 "mbc=16", "deq=64", "fop=tef");
1043 #elif defined (__MINGW32__)
1045 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1047 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1048 fd
= _topen (wpath
, O_RDWR
| o_fmode
, PERM
);
1051 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
1054 return fd
< 0 ? -1 : fd
;
1058 __gnat_open_create (char *path
, int fmode
)
1061 int o_fmode
= O_BINARY
;
1067 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
1068 "mbc=16", "deq=64", "fop=tef");
1069 #elif defined (__MINGW32__)
1071 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1073 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1074 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
1077 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
1080 return fd
< 0 ? -1 : fd
;
1084 __gnat_create_output_file (char *path
)
1088 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
,
1089 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
1090 "shr=del,get,put,upd");
1091 #elif defined (__MINGW32__)
1093 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1095 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1096 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
1099 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
1102 return fd
< 0 ? -1 : fd
;
1106 __gnat_create_output_file_new (char *path
)
1110 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
,
1111 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
1112 "shr=del,get,put,upd");
1113 #elif defined (__MINGW32__)
1115 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1117 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1118 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
1121 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
1124 return fd
< 0 ? -1 : fd
;
1128 __gnat_open_append (char *path
, int fmode
)
1131 int o_fmode
= O_BINARY
;
1137 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
1138 "mbc=16", "deq=64", "fop=tef");
1139 #elif defined (__MINGW32__)
1141 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1143 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1144 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
1147 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
1150 return fd
< 0 ? -1 : fd
;
1153 /* Open a new file. Return error (-1) if the file already exists. */
1156 __gnat_open_new (char *path
, int fmode
)
1159 int o_fmode
= O_BINARY
;
1165 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1166 "mbc=16", "deq=64", "fop=tef");
1167 #elif defined (__MINGW32__)
1169 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1171 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1172 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1175 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1178 return fd
< 0 ? -1 : fd
;
1181 /* Open a new temp file. Return error (-1) if the file already exists.
1182 Special options for VMS allow the file to be shared between parent and child
1183 processes, however they really slow down output. Used in gnatchop. */
1186 __gnat_open_new_temp (char *path
, int fmode
)
1189 int o_fmode
= O_BINARY
;
1191 strcpy (path
, "GNAT-XXXXXX");
1193 #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \
1194 || defined (linux) || defined(__GLIBC__)) && !defined (__vxworks)
1195 return mkstemp (path
);
1196 #elif defined (__Lynx__)
1198 #elif defined (__nucleus__)
1201 if (mktemp (path
) == NULL
)
1209 /* Passing rfm=stmlf for binary files seems questionable since it results
1210 in having an extraneous line feed added after every call to CRTL write,
1211 so pass rfm=udf (aka undefined) instead. */
1212 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1213 fmode
? "rfm=stmlf" : "rfm=udf", "ctx=rec", "rat=none",
1214 "shr=del,get,put,upd", "mbc=16", "deq=64", "fop=tef");
1216 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1219 return fd
< 0 ? -1 : fd
;
1222 /****************************************************************
1223 ** Perform a call to GNAT_STAT or GNAT_FSTAT, and extract as much information
1224 ** as possible from it, storing the result in a cache for later reuse
1225 ****************************************************************/
1228 __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
)
1230 GNAT_STRUCT_STAT statbuf
;
1234 /* GNAT_FSTAT returns -1 and sets errno for failure */
1235 ret
= GNAT_FSTAT (fd
, &statbuf
);
1236 error
= ret
? errno
: 0;
1239 /* __gnat_stat returns errno value directly */
1240 error
= __gnat_stat (name
, &statbuf
);
1241 ret
= error
? -1 : 0;
1245 * A missing file is reported as an attr structure with error == 0 and
1249 if (error
== 0 || error
== ENOENT
)
1252 attr
->error
= error
;
1254 attr
->regular
= (!ret
&& S_ISREG (statbuf
.st_mode
));
1255 attr
->directory
= (!ret
&& S_ISDIR (statbuf
.st_mode
));
1258 attr
->file_length
= 0;
1260 /* st_size may be 32 bits, or 64 bits which is converted to long. We
1261 don't return a useful value for files larger than 2 gigabytes in
1263 attr
->file_length
= statbuf
.st_size
; /* all systems */
1265 attr
->exists
= !ret
;
1267 #if !defined (_WIN32) || defined (RTX)
1268 /* on Windows requires extra system call, see __gnat_is_readable_file_attr */
1269 attr
->readable
= (!ret
&& (statbuf
.st_mode
& S_IRUSR
));
1270 attr
->writable
= (!ret
&& (statbuf
.st_mode
& S_IWUSR
));
1271 attr
->executable
= (!ret
&& (statbuf
.st_mode
& S_IXUSR
));
1275 attr
->timestamp
= (OS_Time
)-1;
1278 /* VMS has file versioning. */
1279 attr
->timestamp
= (OS_Time
)statbuf
.st_ctime
;
1281 attr
->timestamp
= (OS_Time
)statbuf
.st_mtime
;
1286 /****************************************************************
1287 ** Return the number of bytes in the specified file
1288 ****************************************************************/
1291 __gnat_file_length_attr (int fd
, char* name
, struct file_attributes
* attr
)
1293 if (attr
->file_length
== -1) {
1294 __gnat_stat_to_attr (fd
, name
, attr
);
1297 return attr
->file_length
;
1301 __gnat_file_length (int fd
)
1303 struct file_attributes attr
;
1304 __gnat_reset_attributes (&attr
);
1305 return __gnat_file_length_attr (fd
, NULL
, &attr
);
1309 __gnat_named_file_length (char *name
)
1311 struct file_attributes attr
;
1312 __gnat_reset_attributes (&attr
);
1313 return __gnat_file_length_attr (-1, name
, &attr
);
1316 /* Create a temporary filename and put it in string pointed to by
1320 __gnat_tmp_name (char *tmp_filename
)
1323 /* Variable used to create a series of unique names */
1324 static int counter
= 0;
1326 /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */
1327 strcpy (tmp_filename
, "c:\\WINDOWS\\Temp\\gnat-");
1328 sprintf (&tmp_filename
[strlen (tmp_filename
)], "%d\0", counter
++);
1330 #elif defined (__MINGW32__)
1335 /* tempnam tries to create a temporary file in directory pointed to by
1336 TMP environment variable, in c:\temp if TMP is not set, and in
1337 directory specified by P_tmpdir in stdio.h if c:\temp does not
1338 exist. The filename will be created with the prefix "gnat-". */
1340 sprintf (prefix
, "gnat-%d-", (int)getpid());
1341 pname
= (char *) _tempnam ("c:\\temp", prefix
);
1343 /* if pname is NULL, the file was not created properly, the disk is full
1344 or there is no more free temporary files */
1347 *tmp_filename
= '\0';
1349 /* If pname start with a back slash and not path information it means that
1350 the filename is valid for the current working directory. */
1352 else if (pname
[0] == '\\')
1354 strcpy (tmp_filename
, ".\\");
1355 strcat (tmp_filename
, pname
+1);
1358 strcpy (tmp_filename
, pname
);
1363 #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \
1364 || defined (__OpenBSD__) || defined(__GLIBC__) || defined (__ANDROID__)
1365 #define MAX_SAFE_PATH 1000
1366 char *tmpdir
= getenv ("TMPDIR");
1368 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
1369 a buffer overflow. */
1370 if (tmpdir
== NULL
|| strlen (tmpdir
) > MAX_SAFE_PATH
)
1372 strcpy (tmp_filename
, "/cache/gnat-XXXXXX");
1374 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
1377 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
1379 close (mkstemp(tmp_filename
));
1380 #elif defined (__vxworks) && !(defined (__RTP__) || defined (VTHREADS))
1384 static ushort_t seed
= 0; /* used to generate unique name */
1386 /* generate unique name */
1387 strcpy (tmp_filename
, "tmp");
1389 /* fill up the name buffer from the last position */
1391 pos
= tmp_filename
+ strlen (tmp_filename
) + index
;
1395 for (t
= seed
; 0 <= --index
; t
>>= 3)
1396 *--pos
= '0' + (t
& 07);
1398 tmpnam (tmp_filename
);
1402 /* Open directory and returns a DIR pointer. */
1404 DIR* __gnat_opendir (char *name
)
1407 /* Not supported in RTX */
1411 #elif defined (__MINGW32__)
1412 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1414 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1415 return (DIR*)_topendir (wname
);
1418 return opendir (name
);
1422 /* Read the next entry in a directory. The returned string points somewhere
1426 __gnat_readdir (DIR *dirp
, char *buffer
, int *len
)
1429 /* Not supported in RTX */
1433 #elif defined (__MINGW32__)
1434 struct _tdirent
*dirent
= _treaddir ((_TDIR
*)dirp
);
1438 WS2SC (buffer
, dirent
->d_name
, GNAT_MAX_PATH_LEN
);
1439 *len
= strlen (buffer
);
1446 #elif defined (HAVE_READDIR_R)
1447 /* If possible, try to use the thread-safe version. */
1448 if (readdir_r (dirp
, buffer
) != NULL
)
1450 *len
= strlen (((struct dirent
*) buffer
)->d_name
);
1451 return ((struct dirent
*) buffer
)->d_name
;
1457 struct dirent
*dirent
= (struct dirent
*) readdir (dirp
);
1461 strcpy (buffer
, dirent
->d_name
);
1462 *len
= strlen (buffer
);
1471 /* Close a directory entry. */
1473 int __gnat_closedir (DIR *dirp
)
1476 /* Not supported in RTX */
1480 #elif defined (__MINGW32__)
1481 return _tclosedir ((_TDIR
*)dirp
);
1484 return closedir (dirp
);
1488 /* Returns 1 if readdir is thread safe, 0 otherwise. */
1491 __gnat_readdir_is_thread_safe (void)
1493 #ifdef HAVE_READDIR_R
1500 #if defined (_WIN32) && !defined (RTX)
1501 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
1502 static const unsigned long long w32_epoch_offset
= 11644473600ULL;
1504 /* Returns the file modification timestamp using Win32 routines which are
1505 immune against daylight saving time change. It is in fact not possible to
1506 use fstat for this purpose as the DST modify the st_mtime field of the
1510 win32_filetime (HANDLE h
)
1515 unsigned long long ull_time
;
1518 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1519 since <Jan 1st 1601>. This function must return the number of seconds
1520 since <Jan 1st 1970>. */
1522 if (GetFileTime (h
, NULL
, NULL
, &t_write
.ft_time
))
1523 return (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1527 /* As above but starting from a FILETIME. */
1529 f2t (const FILETIME
*ft
, time_t *t
)
1534 unsigned long long ull_time
;
1537 t_write
.ft_time
= *ft
;
1538 *t
= (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1542 /* Return a GNAT time stamp given a file name. */
1545 __gnat_file_time_name_attr (char* name
, struct file_attributes
* attr
)
1547 if (attr
->timestamp
== (OS_Time
)-2) {
1548 #if defined (_WIN32) && !defined (RTX)
1550 WIN32_FILE_ATTRIBUTE_DATA fad
;
1552 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1553 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1555 if ((res
= GetFileAttributesEx (wname
, GetFileExInfoStandard
, &fad
)))
1556 f2t (&fad
.ftLastWriteTime
, &ret
);
1557 attr
->timestamp
= (OS_Time
) ret
;
1559 __gnat_stat_to_attr (-1, name
, attr
);
1562 return attr
->timestamp
;
1566 __gnat_file_time_name (char *name
)
1568 struct file_attributes attr
;
1569 __gnat_reset_attributes (&attr
);
1570 return __gnat_file_time_name_attr (name
, &attr
);
1573 /* Return a GNAT time stamp given a file descriptor. */
1576 __gnat_file_time_fd_attr (int fd
, struct file_attributes
* attr
)
1578 if (attr
->timestamp
== (OS_Time
)-2) {
1579 #if defined (_WIN32) && !defined (RTX)
1580 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
1581 time_t ret
= win32_filetime (h
);
1582 attr
->timestamp
= (OS_Time
) ret
;
1585 __gnat_stat_to_attr (fd
, NULL
, attr
);
1589 return attr
->timestamp
;
1593 __gnat_file_time_fd (int fd
)
1595 struct file_attributes attr
;
1596 __gnat_reset_attributes (&attr
);
1597 return __gnat_file_time_fd_attr (fd
, &attr
);
1600 /* Set the file time stamp. */
1603 __gnat_set_file_time_name (char *name
, time_t time_stamp
)
1605 #if defined (__vxworks)
1607 /* Code to implement __gnat_set_file_time_name for these systems. */
1609 #elif defined (_WIN32) && !defined (RTX)
1613 unsigned long long ull_time
;
1615 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1617 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1619 HANDLE h
= CreateFile
1620 (wname
, GENERIC_WRITE
, FILE_SHARE_WRITE
, NULL
,
1621 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
,
1623 if (h
== INVALID_HANDLE_VALUE
)
1625 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1626 t_write
.ull_time
= ((unsigned long long)time_stamp
+ w32_epoch_offset
);
1627 /* Convert to 100 nanosecond units */
1628 t_write
.ull_time
*= 10000000ULL;
1630 SetFileTime(h
, NULL
, NULL
, &t_write
.ft_time
);
1640 unsigned long long backup
, create
, expire
, revise
;
1644 unsigned short value
;
1647 unsigned system
: 4;
1653 } Fat
= { 0, 0, 0, 0, 0, { 0 }};
1657 { ATR$S_CREDATE
, ATR$C_CREDATE
, &Fat
.create
},
1658 { ATR$S_REVDATE
, ATR$C_REVDATE
, &Fat
.revise
},
1659 { ATR$S_EXPDATE
, ATR$C_EXPDATE
, &Fat
.expire
},
1660 { ATR$S_BAKDATE
, ATR$C_BAKDATE
, &Fat
.backup
},
1661 { ATR$S_FPRO
, ATR$C_FPRO
, &Fat
.prot
},
1662 { ATR$S_UIC
, ATR$C_UIC
, &Fat
.uic
},
1667 struct dsc$descriptor_fib fibdsc
= {sizeof (fib
), (void *) &fib
};
1671 unsigned long long newtime
;
1672 unsigned long long revtime
;
1676 struct vstring file
;
1677 struct dsc$descriptor_s filedsc
1678 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) file
.string
};
1679 struct vstring device
;
1680 struct dsc$descriptor_s devicedsc
1681 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) device
.string
};
1682 struct vstring timev
;
1683 struct dsc$descriptor_s timedsc
1684 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) timev
.string
};
1685 struct vstring result
;
1686 struct dsc$descriptor_s resultdsc
1687 = {NAM$C_MAXRSS
, DSC$K_DTYPE_VT
, DSC$K_CLASS_VS
, (void *) result
.string
};
1689 /* Convert parameter name (a file spec) to host file form. Note that this
1690 is needed on VMS to prepare for subsequent calls to VMS RMS library
1691 routines. Note that it would not work to call __gnat_to_host_dir_spec
1692 as was done in a previous version, since this fails silently unless
1693 the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1694 (directory not found) condition is signalled. */
1695 tryfile
= (char *) __gnat_to_host_file_spec (name
);
1697 /* Allocate and initialize a FAB and NAM structures. */
1701 nam
.nam$l_esa
= file
.string
;
1702 nam
.nam$b_ess
= NAM$C_MAXRSS
;
1703 nam
.nam$l_rsa
= result
.string
;
1704 nam
.nam$b_rss
= NAM$C_MAXRSS
;
1705 fab
.fab$l_fna
= tryfile
;
1706 fab
.fab$b_fns
= strlen (tryfile
);
1707 fab
.fab$l_nam
= &nam
;
1709 /* Validate filespec syntax and device existence. */
1710 status
= SYS$
PARSE (&fab
, 0, 0);
1711 if ((status
& 1) != 1)
1712 LIB$
SIGNAL (status
);
1714 file
.string
[nam
.nam$b_esl
] = 0;
1716 /* Find matching filespec. */
1717 status
= SYS$
SEARCH (&fab
, 0, 0);
1718 if ((status
& 1) != 1)
1719 LIB$
SIGNAL (status
);
1721 file
.string
[nam
.nam$b_esl
] = 0;
1722 result
.string
[result
.length
=nam
.nam$b_rsl
] = 0;
1724 /* Get the device name and assign an IO channel. */
1725 strncpy (device
.string
, nam
.nam$l_dev
, nam
.nam$b_dev
);
1726 devicedsc
.dsc$w_length
= nam
.nam$b_dev
;
1728 status
= SYS$
ASSIGN (&devicedsc
, &chan
, 0, 0, 0);
1729 if ((status
& 1) != 1)
1730 LIB$
SIGNAL (status
);
1732 /* Initialize the FIB and fill in the directory id field. */
1733 memset (&fib
, 0, sizeof (fib
));
1734 fib
.fib$w_did
[0] = nam
.nam$w_did
[0];
1735 fib
.fib$w_did
[1] = nam
.nam$w_did
[1];
1736 fib
.fib$w_did
[2] = nam
.nam$w_did
[2];
1737 fib
.fib$l_acctl
= 0;
1739 strcpy (file
.string
, (strrchr (result
.string
, ']') + 1));
1740 filedsc
.dsc$w_length
= strlen (file
.string
);
1741 result
.string
[result
.length
= 0] = 0;
1743 /* Open and close the file to fill in the attributes. */
1745 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1746 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1747 if ((status
& 1) != 1)
1748 LIB$
SIGNAL (status
);
1749 if ((iosb
.status
& 1) != 1)
1750 LIB$
SIGNAL (iosb
.status
);
1752 result
.string
[result
.length
] = 0;
1753 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0, &fibdsc
, 0, 0, 0,
1755 if ((status
& 1) != 1)
1756 LIB$
SIGNAL (status
);
1757 if ((iosb
.status
& 1) != 1)
1758 LIB$
SIGNAL (iosb
.status
);
1763 /* Set creation time to requested time. */
1764 unix_time_to_vms (time_stamp
, newtime
);
1766 t
= time ((time_t) 0);
1768 /* Set revision time to now in local time. */
1769 unix_time_to_vms (t
, revtime
);
1772 /* Reopen the file, modify the times and then close. */
1773 fib
.fib$l_acctl
= FIB$M_WRITE
;
1775 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1776 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1777 if ((status
& 1) != 1)
1778 LIB$
SIGNAL (status
);
1779 if ((iosb
.status
& 1) != 1)
1780 LIB$
SIGNAL (iosb
.status
);
1782 Fat
.create
= newtime
;
1783 Fat
.revise
= revtime
;
1785 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0,
1786 &fibdsc
, 0, 0, 0, &atrlst
, 0);
1787 if ((status
& 1) != 1)
1788 LIB$
SIGNAL (status
);
1789 if ((iosb
.status
& 1) != 1)
1790 LIB$
SIGNAL (iosb
.status
);
1792 /* Deassign the channel and exit. */
1793 status
= SYS$
DASSGN (chan
);
1794 if ((status
& 1) != 1)
1795 LIB$
SIGNAL (status
);
1797 struct utimbuf utimbuf
;
1800 /* Set modification time to requested time. */
1801 utimbuf
.modtime
= time_stamp
;
1803 /* Set access time to now in local time. */
1804 t
= time ((time_t) 0);
1805 utimbuf
.actime
= mktime (localtime (&t
));
1807 utime (name
, &utimbuf
);
1811 /* Get the list of installed standard libraries from the
1812 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1816 __gnat_get_libraries_from_registry (void)
1818 char *result
= (char *) xmalloc (1);
1822 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) \
1826 DWORD name_size
, value_size
;
1833 /* First open the key. */
1834 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1836 if (res
== ERROR_SUCCESS
)
1837 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1838 KEY_READ
, ®_key
);
1840 if (res
== ERROR_SUCCESS
)
1841 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1843 if (res
== ERROR_SUCCESS
)
1844 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1846 /* If the key exists, read out all the values in it and concatenate them
1848 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1850 value_size
= name_size
= 256;
1851 res
= RegEnumValueA (reg_key
, index
, name
, &name_size
, 0,
1852 &type
, (LPBYTE
)value
, &value_size
);
1854 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1856 char *old_result
= result
;
1858 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1859 strcpy (result
, old_result
);
1860 strcat (result
, value
);
1861 strcat (result
, ";");
1866 /* Remove the trailing ";". */
1868 result
[strlen (result
) - 1] = 0;
1874 /* Query information for the given file NAME and return it in STATBUF.
1875 * Returns 0 for success, or errno value for failure.
1878 __gnat_stat (char *name
, GNAT_STRUCT_STAT
*statbuf
)
1881 WIN32_FILE_ATTRIBUTE_DATA fad
;
1882 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
1887 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
1888 name_len
= _tcslen (wname
);
1890 if (name_len
> GNAT_MAX_PATH_LEN
)
1893 ZeroMemory (statbuf
, sizeof(GNAT_STRUCT_STAT
));
1895 res
= GetFileAttributesEx (wname
, GetFileExInfoStandard
, &fad
);
1898 error
= GetLastError();
1900 /* Check file existence using GetFileAttributes() which does not fail on
1901 special Windows files like con:, aux:, nul: etc... */
1903 if (GetFileAttributes(wname
) != INVALID_FILE_ATTRIBUTES
) {
1904 /* Just pretend that it is a regular and readable file */
1905 statbuf
->st_mode
= S_IFREG
| S_IREAD
| S_IWRITE
;
1910 case ERROR_ACCESS_DENIED
:
1911 case ERROR_SHARING_VIOLATION
:
1912 case ERROR_LOCK_VIOLATION
:
1913 case ERROR_SHARING_BUFFER_EXCEEDED
:
1915 case ERROR_BUFFER_OVERFLOW
:
1916 return ENAMETOOLONG
;
1917 case ERROR_NOT_ENOUGH_MEMORY
:
1924 f2t (&fad
.ftCreationTime
, &statbuf
->st_ctime
);
1925 f2t (&fad
.ftLastWriteTime
, &statbuf
->st_mtime
);
1926 f2t (&fad
.ftLastAccessTime
, &statbuf
->st_atime
);
1928 statbuf
->st_size
= (off_t
)fad
.nFileSizeLow
;
1930 /* We do not have the S_IEXEC attribute, but this is not used on GNAT. */
1931 statbuf
->st_mode
= S_IREAD
;
1933 if (fad
.dwFileAttributes
& FILE_ATTRIBUTE_DIRECTORY
)
1934 statbuf
->st_mode
|= S_IFDIR
;
1936 statbuf
->st_mode
|= S_IFREG
;
1938 if (!(fad
.dwFileAttributes
& FILE_ATTRIBUTE_READONLY
))
1939 statbuf
->st_mode
|= S_IWRITE
;
1944 return GNAT_STAT (name
, statbuf
) == 0 ? 0 : errno
;
1948 /*************************************************************************
1949 ** Check whether a file exists
1950 *************************************************************************/
1953 __gnat_file_exists_attr (char* name
, struct file_attributes
* attr
)
1955 if (attr
->exists
== ATTR_UNSET
)
1956 __gnat_stat_to_attr (-1, name
, attr
);
1958 return attr
->exists
;
1962 __gnat_file_exists (char *name
)
1964 struct file_attributes attr
;
1965 __gnat_reset_attributes (&attr
);
1966 return __gnat_file_exists_attr (name
, &attr
);
1969 /**********************************************************************
1970 ** Whether name is an absolute path
1971 **********************************************************************/
1974 __gnat_is_absolute_path (char *name
, int length
)
1977 /* On VxWorks systems, an absolute path can be represented (depending on
1978 the host platform) as either /dir/file, or device:/dir/file, or
1979 device:drive_letter:/dir/file. */
1986 for (index
= 0; index
< length
; index
++)
1988 if (name
[index
] == ':' &&
1989 ((name
[index
+ 1] == '/') ||
1990 (isalpha (name
[index
+ 1]) && index
+ 2 <= length
&&
1991 name
[index
+ 2] == '/')))
1994 else if (name
[index
] == '/')
1999 return (length
!= 0) &&
2000 (*name
== '/' || *name
== DIR_SEPARATOR
2002 || (length
> 1 && ISALPHA (name
[0]) && name
[1] == ':')
2009 __gnat_is_regular_file_attr (char* name
, struct file_attributes
* attr
)
2011 if (attr
->regular
== ATTR_UNSET
)
2012 __gnat_stat_to_attr (-1, name
, attr
);
2014 return attr
->regular
;
2018 __gnat_is_regular_file (char *name
)
2020 struct file_attributes attr
;
2022 __gnat_reset_attributes (&attr
);
2023 return __gnat_is_regular_file_attr (name
, &attr
);
2027 __gnat_is_regular_file_fd (int fd
)
2030 GNAT_STRUCT_STAT statbuf
;
2032 ret
= GNAT_FSTAT (fd
, &statbuf
);
2033 return (!ret
&& S_ISREG (statbuf
.st_mode
));
2037 __gnat_is_directory_attr (char* name
, struct file_attributes
* attr
)
2039 if (attr
->directory
== ATTR_UNSET
)
2040 __gnat_stat_to_attr (-1, name
, attr
);
2042 return attr
->directory
;
2046 __gnat_is_directory (char *name
)
2048 struct file_attributes attr
;
2050 __gnat_reset_attributes (&attr
);
2051 return __gnat_is_directory_attr (name
, &attr
);
2054 #if defined (_WIN32) && !defined (RTX)
2056 /* Returns the same constant as GetDriveType but takes a pathname as
2060 GetDriveTypeFromPath (TCHAR
*wfullpath
)
2062 TCHAR wdrv
[MAX_PATH
];
2063 TCHAR wpath
[MAX_PATH
];
2064 TCHAR wfilename
[MAX_PATH
];
2065 TCHAR wext
[MAX_PATH
];
2067 _tsplitpath (wfullpath
, wdrv
, wpath
, wfilename
, wext
);
2069 if (_tcslen (wdrv
) != 0)
2071 /* we have a drive specified. */
2072 _tcscat (wdrv
, _T("\\"));
2073 return GetDriveType (wdrv
);
2077 /* No drive specified. */
2079 /* Is this a relative path, if so get current drive type. */
2080 if (wpath
[0] != _T('\\') ||
2081 (_tcslen (wpath
) > 2 && wpath
[0] == _T('\\')
2082 && wpath
[1] != _T('\\')))
2083 return GetDriveType (NULL
);
2085 UINT result
= GetDriveType (wpath
);
2087 /* Cannot guess the drive type, is this \\.\ ? */
2089 if (result
== DRIVE_NO_ROOT_DIR
&&
2090 _tcslen (wpath
) >= 4 && wpath
[0] == _T('\\') && wpath
[1] == _T('\\')
2091 && wpath
[2] == _T('.') && wpath
[3] == _T('\\'))
2093 if (_tcslen (wpath
) == 4)
2094 _tcscat (wpath
, wfilename
);
2096 LPTSTR p
= &wpath
[4];
2097 LPTSTR b
= _tcschr (p
, _T('\\'));
2101 /* logical drive \\.\c\dir\file */
2107 _tcscat (p
, _T(":\\"));
2109 return GetDriveType (p
);
2116 /* This MingW section contains code to work with ACL. */
2118 __gnat_check_OWNER_ACL (TCHAR
*wname
,
2119 DWORD CheckAccessDesired
,
2120 GENERIC_MAPPING CheckGenericMapping
)
2122 DWORD dwAccessDesired
, dwAccessAllowed
;
2123 PRIVILEGE_SET PrivilegeSet
;
2124 DWORD dwPrivSetSize
= sizeof (PRIVILEGE_SET
);
2125 BOOL fAccessGranted
= FALSE
;
2126 HANDLE hToken
= NULL
;
2128 SECURITY_DESCRIPTOR
* pSD
= NULL
;
2131 (wname
, OWNER_SECURITY_INFORMATION
|
2132 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
2135 if ((pSD
= (SECURITY_DESCRIPTOR
*) HeapAlloc
2136 (GetProcessHeap (), HEAP_ZERO_MEMORY
, nLength
)) == NULL
)
2139 /* Obtain the security descriptor. */
2141 if (!GetFileSecurity
2142 (wname
, OWNER_SECURITY_INFORMATION
|
2143 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
2144 pSD
, nLength
, &nLength
))
2147 if (!ImpersonateSelf (SecurityImpersonation
))
2150 if (!OpenThreadToken
2151 (GetCurrentThread(), TOKEN_DUPLICATE
| TOKEN_QUERY
, FALSE
, &hToken
))
2154 /* Undoes the effect of ImpersonateSelf. */
2158 /* We want to test for write permissions. */
2160 dwAccessDesired
= CheckAccessDesired
;
2162 MapGenericMask (&dwAccessDesired
, &CheckGenericMapping
);
2165 (pSD
, /* security descriptor to check */
2166 hToken
, /* impersonation token */
2167 dwAccessDesired
, /* requested access rights */
2168 &CheckGenericMapping
, /* pointer to GENERIC_MAPPING */
2169 &PrivilegeSet
, /* receives privileges used in check */
2170 &dwPrivSetSize
, /* size of PrivilegeSet buffer */
2171 &dwAccessAllowed
, /* receives mask of allowed access rights */
2175 CloseHandle (hToken
);
2176 HeapFree (GetProcessHeap (), 0, pSD
);
2177 return fAccessGranted
;
2181 CloseHandle (hToken
);
2182 HeapFree (GetProcessHeap (), 0, pSD
);
2187 __gnat_set_OWNER_ACL (TCHAR
*wname
,
2189 DWORD AccessPermissions
)
2191 PACL pOldDACL
= NULL
;
2192 PACL pNewDACL
= NULL
;
2193 PSECURITY_DESCRIPTOR pSD
= NULL
;
2195 TCHAR username
[100];
2198 /* Get current user, he will act as the owner */
2200 if (!GetUserName (username
, &unsize
))
2203 if (GetNamedSecurityInfo
2206 DACL_SECURITY_INFORMATION
,
2207 NULL
, NULL
, &pOldDACL
, NULL
, &pSD
) != ERROR_SUCCESS
)
2210 BuildExplicitAccessWithName
2211 (&ea
, username
, AccessPermissions
, (ACCESS_MODE
) AccessMode
, NO_INHERITANCE
);
2213 if (AccessMode
== SET_ACCESS
)
2215 /* SET_ACCESS, we want to set an explicte set of permissions, do not
2216 merge with current DACL. */
2217 if (SetEntriesInAcl (1, &ea
, NULL
, &pNewDACL
) != ERROR_SUCCESS
)
2221 if (SetEntriesInAcl (1, &ea
, pOldDACL
, &pNewDACL
) != ERROR_SUCCESS
)
2224 if (SetNamedSecurityInfo
2225 (wname
, SE_FILE_OBJECT
,
2226 DACL_SECURITY_INFORMATION
, NULL
, NULL
, pNewDACL
, NULL
) != ERROR_SUCCESS
)
2230 LocalFree (pNewDACL
);
2233 /* Check if it is possible to use ACL for wname, the file must not be on a
2237 __gnat_can_use_acl (TCHAR
*wname
)
2239 return __gnat_use_acl
&& GetDriveTypeFromPath (wname
) != DRIVE_REMOTE
;
2242 #endif /* defined (_WIN32) && !defined (RTX) */
2245 __gnat_is_readable_file_attr (char* name
, struct file_attributes
* attr
)
2247 if (attr
->readable
== ATTR_UNSET
)
2249 #if defined (_WIN32) && !defined (RTX)
2250 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2251 GENERIC_MAPPING GenericMapping
;
2253 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2255 if (__gnat_can_use_acl (wname
))
2257 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2258 GenericMapping
.GenericRead
= GENERIC_READ
;
2260 __gnat_check_OWNER_ACL (wname
, FILE_READ_DATA
, GenericMapping
);
2263 attr
->readable
= GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
;
2265 __gnat_stat_to_attr (-1, name
, attr
);
2269 return attr
->readable
;
2273 __gnat_is_readable_file (char *name
)
2275 struct file_attributes attr
;
2277 __gnat_reset_attributes (&attr
);
2278 return __gnat_is_readable_file_attr (name
, &attr
);
2282 __gnat_is_writable_file_attr (char* name
, struct file_attributes
* attr
)
2284 if (attr
->writable
== ATTR_UNSET
)
2286 #if defined (_WIN32) && !defined (RTX)
2287 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2288 GENERIC_MAPPING GenericMapping
;
2290 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2292 if (__gnat_can_use_acl (wname
))
2294 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2295 GenericMapping
.GenericWrite
= GENERIC_WRITE
;
2297 attr
->writable
= __gnat_check_OWNER_ACL
2298 (wname
, FILE_WRITE_DATA
| FILE_APPEND_DATA
, GenericMapping
)
2299 && !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2303 !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2306 __gnat_stat_to_attr (-1, name
, attr
);
2310 return attr
->writable
;
2314 __gnat_is_writable_file (char *name
)
2316 struct file_attributes attr
;
2318 __gnat_reset_attributes (&attr
);
2319 return __gnat_is_writable_file_attr (name
, &attr
);
2323 __gnat_is_executable_file_attr (char* name
, struct file_attributes
* attr
)
2325 if (attr
->executable
== ATTR_UNSET
)
2327 #if defined (_WIN32) && !defined (RTX)
2328 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2329 GENERIC_MAPPING GenericMapping
;
2331 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2333 if (__gnat_can_use_acl (wname
))
2335 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2336 GenericMapping
.GenericExecute
= GENERIC_EXECUTE
;
2339 __gnat_check_OWNER_ACL (wname
, FILE_EXECUTE
, GenericMapping
);
2343 TCHAR
*l
, *last
= _tcsstr(wname
, _T(".exe"));
2345 /* look for last .exe */
2347 while ((l
= _tcsstr(last
+1, _T(".exe"))))
2351 GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
2352 && (last
- wname
) == (int) (_tcslen (wname
) - 4);
2355 __gnat_stat_to_attr (-1, name
, attr
);
2359 return attr
->regular
&& attr
->executable
;
2363 __gnat_is_executable_file (char *name
)
2365 struct file_attributes attr
;
2367 __gnat_reset_attributes (&attr
);
2368 return __gnat_is_executable_file_attr (name
, &attr
);
2372 __gnat_set_writable (char *name
)
2374 #if defined (_WIN32) && !defined (RTX)
2375 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2377 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2379 if (__gnat_can_use_acl (wname
))
2380 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_WRITE
);
2383 (wname
, GetFileAttributes (wname
) & ~FILE_ATTRIBUTE_READONLY
);
2384 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2385 ! defined(__nucleus__)
2386 GNAT_STRUCT_STAT statbuf
;
2388 if (GNAT_STAT (name
, &statbuf
) == 0)
2390 statbuf
.st_mode
= statbuf
.st_mode
| S_IWUSR
;
2391 chmod (name
, statbuf
.st_mode
);
2396 /* must match definition in s-os_lib.ads */
2402 __gnat_set_executable (char *name
, int mode
)
2404 #if defined (_WIN32) && !defined (RTX)
2405 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2407 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2409 if (__gnat_can_use_acl (wname
))
2410 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_EXECUTE
);
2412 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2413 ! defined(__nucleus__)
2414 GNAT_STRUCT_STAT statbuf
;
2416 if (GNAT_STAT (name
, &statbuf
) == 0)
2419 statbuf
.st_mode
= statbuf
.st_mode
| S_IXUSR
;
2421 statbuf
.st_mode
= statbuf
.st_mode
| S_IXGRP
;
2422 if (mode
& S_OTHERS
)
2423 statbuf
.st_mode
= statbuf
.st_mode
| S_IXOTH
;
2424 chmod (name
, statbuf
.st_mode
);
2430 __gnat_set_non_writable (char *name
)
2432 #if defined (_WIN32) && !defined (RTX)
2433 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2435 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2437 if (__gnat_can_use_acl (wname
))
2438 __gnat_set_OWNER_ACL
2439 (wname
, DENY_ACCESS
,
2440 FILE_WRITE_DATA
| FILE_APPEND_DATA
|
2441 FILE_WRITE_EA
| FILE_WRITE_ATTRIBUTES
);
2444 (wname
, GetFileAttributes (wname
) | FILE_ATTRIBUTE_READONLY
);
2445 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2446 ! defined(__nucleus__)
2447 GNAT_STRUCT_STAT statbuf
;
2449 if (GNAT_STAT (name
, &statbuf
) == 0)
2451 statbuf
.st_mode
= statbuf
.st_mode
& 07577;
2452 chmod (name
, statbuf
.st_mode
);
2458 __gnat_set_readable (char *name
)
2460 #if defined (_WIN32) && !defined (RTX)
2461 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2463 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2465 if (__gnat_can_use_acl (wname
))
2466 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_READ
);
2468 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2469 ! defined(__nucleus__)
2470 GNAT_STRUCT_STAT statbuf
;
2472 if (GNAT_STAT (name
, &statbuf
) == 0)
2474 chmod (name
, statbuf
.st_mode
| S_IREAD
);
2480 __gnat_set_non_readable (char *name
)
2482 #if defined (_WIN32) && !defined (RTX)
2483 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2485 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2487 if (__gnat_can_use_acl (wname
))
2488 __gnat_set_OWNER_ACL (wname
, DENY_ACCESS
, FILE_GENERIC_READ
);
2490 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2491 ! defined(__nucleus__)
2492 GNAT_STRUCT_STAT statbuf
;
2494 if (GNAT_STAT (name
, &statbuf
) == 0)
2496 chmod (name
, statbuf
.st_mode
& (~S_IREAD
));
2502 __gnat_is_symbolic_link_attr (char* name ATTRIBUTE_UNUSED
,
2503 struct file_attributes
* attr
)
2505 if (attr
->symbolic_link
== ATTR_UNSET
)
2507 #if defined (__vxworks) || defined (__nucleus__)
2508 attr
->symbolic_link
= 0;
2510 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
2512 GNAT_STRUCT_STAT statbuf
;
2513 ret
= GNAT_LSTAT (name
, &statbuf
);
2514 attr
->symbolic_link
= (!ret
&& S_ISLNK (statbuf
.st_mode
));
2516 attr
->symbolic_link
= 0;
2519 return attr
->symbolic_link
;
2523 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED
)
2525 struct file_attributes attr
;
2527 __gnat_reset_attributes (&attr
);
2528 return __gnat_is_symbolic_link_attr (name
, &attr
);
2531 #if defined (sun) && defined (__SVR4)
2532 /* Using fork on Solaris will duplicate all the threads. fork1, which
2533 duplicates only the active thread, must be used instead, or spawning
2534 subprocess from a program with tasking will lead into numerous problems. */
2539 __gnat_portable_spawn (char *args
[] ATTRIBUTE_UNUSED
)
2541 int status ATTRIBUTE_UNUSED
= 0;
2542 int finished ATTRIBUTE_UNUSED
;
2543 int pid ATTRIBUTE_UNUSED
;
2545 #if defined (__vxworks) || defined(__nucleus__) || defined(RTX) \
2546 || defined(__PikeOS__)
2549 #elif defined (_WIN32)
2550 /* args[0] must be quotes as it could contain a full pathname with spaces */
2551 char *args_0
= args
[0];
2552 args
[0] = (char *)xmalloc (strlen (args_0
) + 3);
2553 strcpy (args
[0], "\"");
2554 strcat (args
[0], args_0
);
2555 strcat (args
[0], "\"");
2557 status
= spawnvp (P_WAIT
, args_0
, (char* const*)args
);
2559 /* restore previous value */
2561 args
[0] = (char *)args_0
;
2577 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2579 return -1; /* execv is in parent context on VMS. */
2586 finished
= waitpid (pid
, &status
, 0);
2588 if (finished
!= pid
|| WIFEXITED (status
) == 0)
2591 return WEXITSTATUS (status
);
2597 /* Create a copy of the given file descriptor.
2598 Return -1 if an error occurred. */
2601 __gnat_dup (int oldfd
)
2603 #if defined (__vxworks) && !defined (__RTP__)
2604 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2612 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
2613 Return -1 if an error occurred. */
2616 __gnat_dup2 (int oldfd ATTRIBUTE_UNUSED
, int newfd ATTRIBUTE_UNUSED
)
2618 #if defined (__vxworks) && !defined (__RTP__)
2619 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2622 #elif defined (__PikeOS__)
2623 /* Not supported. */
2625 #elif defined (_WIN32)
2626 /* Special case when oldfd and newfd are identical and are the standard
2627 input, output or error as this makes Windows XP hangs. Note that we
2628 do that only for standard file descriptors that are known to be valid. */
2629 if (oldfd
== newfd
&& newfd
>= 0 && newfd
<= 2)
2632 return dup2 (oldfd
, newfd
);
2634 return dup2 (oldfd
, newfd
);
2639 __gnat_number_of_cpus (void)
2643 #if defined (linux) || defined (sun) || defined (AIX) || defined (__APPLE__)
2644 cores
= (int) sysconf (_SC_NPROCESSORS_ONLN
);
2646 #elif defined (__hpux__)
2647 struct pst_dynamic psd
;
2648 if (pstat_getdynamic (&psd
, sizeof (psd
), 1, 0) != -1)
2649 cores
= (int) psd
.psd_proc_cnt
;
2651 #elif defined (_WIN32)
2652 SYSTEM_INFO sysinfo
;
2653 GetSystemInfo (&sysinfo
);
2654 cores
= (int) sysinfo
.dwNumberOfProcessors
;
2657 int code
= SYI$_ACTIVECPU_CNT
;
2661 status
= LIB$
GETSYI (&code
, &res
);
2662 if ((status
& 1) != 0)
2665 #elif defined (_WRS_CONFIG_SMP)
2666 unsigned int vxCpuConfiguredGet (void);
2668 cores
= vxCpuConfiguredGet ();
2675 /* WIN32 code to implement a wait call that wait for any child process. */
2677 #if defined (_WIN32) && !defined (RTX)
2679 /* Synchronization code, to be thread safe. */
2683 /* For the Cert run times on native Windows we use dummy functions
2684 for locking and unlocking tasks since we do not support multiple
2685 threads on this configuration (Cert run time on native Windows). */
2687 static void dummy (void)
2691 void (*Lock_Task
) () = &dummy
;
2692 void (*Unlock_Task
) () = &dummy
;
2696 #define Lock_Task system__soft_links__lock_task
2697 extern void (*Lock_Task
) (void);
2699 #define Unlock_Task system__soft_links__unlock_task
2700 extern void (*Unlock_Task
) (void);
2704 static HANDLE
*HANDLES_LIST
= NULL
;
2705 static int *PID_LIST
= NULL
, plist_length
= 0, plist_max_length
= 0;
2708 add_handle (HANDLE h
, int pid
)
2711 /* -------------------- critical section -------------------- */
2714 if (plist_length
== plist_max_length
)
2716 plist_max_length
+= 1000;
2718 (void **) xrealloc (HANDLES_LIST
, sizeof (HANDLE
) * plist_max_length
);
2720 (int *) xrealloc (PID_LIST
, sizeof (int) * plist_max_length
);
2723 HANDLES_LIST
[plist_length
] = h
;
2724 PID_LIST
[plist_length
] = pid
;
2728 /* -------------------- critical section -------------------- */
2732 __gnat_win32_remove_handle (HANDLE h
, int pid
)
2736 /* -------------------- critical section -------------------- */
2739 for (j
= 0; j
< plist_length
; j
++)
2741 if ((HANDLES_LIST
[j
] == h
) || (PID_LIST
[j
] == pid
))
2745 HANDLES_LIST
[j
] = HANDLES_LIST
[plist_length
];
2746 PID_LIST
[j
] = PID_LIST
[plist_length
];
2752 /* -------------------- critical section -------------------- */
2756 win32_no_block_spawn (char *command
, char *args
[], HANDLE
*h
, int *pid
)
2760 PROCESS_INFORMATION PI
;
2761 SECURITY_ATTRIBUTES SA
;
2766 /* compute the total command line length */
2770 csize
+= strlen (args
[k
]) + 1;
2774 full_command
= (char *) xmalloc (csize
);
2777 SI
.cb
= sizeof (STARTUPINFO
);
2778 SI
.lpReserved
= NULL
;
2779 SI
.lpReserved2
= NULL
;
2780 SI
.lpDesktop
= NULL
;
2784 SI
.wShowWindow
= SW_HIDE
;
2786 /* Security attributes. */
2787 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
2788 SA
.bInheritHandle
= TRUE
;
2789 SA
.lpSecurityDescriptor
= NULL
;
2791 /* Prepare the command string. */
2792 strcpy (full_command
, command
);
2793 strcat (full_command
, " ");
2798 strcat (full_command
, args
[k
]);
2799 strcat (full_command
, " ");
2804 int wsize
= csize
* 2;
2805 TCHAR
*wcommand
= (TCHAR
*) xmalloc (wsize
);
2807 S2WSC (wcommand
, full_command
, wsize
);
2809 free (full_command
);
2811 result
= CreateProcess
2812 (NULL
, wcommand
, &SA
, NULL
, TRUE
,
2813 GetPriorityClass (GetCurrentProcess()), NULL
, NULL
, &SI
, &PI
);
2820 CloseHandle (PI
.hThread
);
2822 *pid
= PI
.dwProcessId
;
2832 win32_wait (int *status
)
2834 DWORD exitcode
, pid
;
2841 if (plist_length
== 0)
2849 /* -------------------- critical section -------------------- */
2852 hl_len
= plist_length
;
2854 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * hl_len
);
2856 memmove (hl
, HANDLES_LIST
, sizeof (HANDLE
) * hl_len
);
2859 /* -------------------- critical section -------------------- */
2861 res
= WaitForMultipleObjects (hl_len
, hl
, FALSE
, INFINITE
);
2862 h
= hl
[res
- WAIT_OBJECT_0
];
2864 GetExitCodeProcess (h
, &exitcode
);
2865 pid
= PID_LIST
[res
- WAIT_OBJECT_0
];
2866 __gnat_win32_remove_handle (h
, -1);
2870 *status
= (int) exitcode
;
2877 __gnat_portable_no_block_spawn (char *args
[] ATTRIBUTE_UNUSED
)
2880 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX) \
2881 || defined (__PikeOS__)
2882 /* Not supported. */
2885 #elif defined (_WIN32)
2890 win32_no_block_spawn (args
[0], args
, &h
, &pid
);
2893 add_handle (h
, pid
);
2906 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2908 return -1; /* execv is in parent context on VMS. */
2920 __gnat_portable_wait (int *process_status
)
2925 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX) \
2926 || defined (__PikeOS__)
2927 /* Not sure what to do here, so do nothing but return zero. */
2929 #elif defined (_WIN32)
2931 pid
= win32_wait (&status
);
2935 pid
= waitpid (-1, &status
, 0);
2936 status
= status
& 0xffff;
2939 *process_status
= status
;
2944 __gnat_os_exit (int status
)
2949 /* Locate file on path, that matches a predicate */
2952 __gnat_locate_file_with_predicate (char *file_name
, char *path_val
,
2953 int (*predicate
)(char *))
2956 char *file_path
= (char *) alloca (strlen (file_name
) + 1);
2959 /* Return immediately if file_name is empty */
2961 if (*file_name
== '\0')
2964 /* Remove quotes around file_name if present */
2970 strcpy (file_path
, ptr
);
2972 ptr
= file_path
+ strlen (file_path
) - 1;
2977 /* Handle absolute pathnames. */
2979 absolute
= __gnat_is_absolute_path (file_path
, strlen (file_name
));
2983 if (predicate (file_path
))
2984 return xstrdup (file_path
);
2989 /* If file_name include directory separator(s), try it first as
2990 a path name relative to the current directory */
2991 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
2996 if (predicate (file_name
))
2997 return xstrdup (file_name
);
3004 /* The result has to be smaller than path_val + file_name. */
3006 (char *) alloca (strlen (path_val
) + strlen (file_name
) + 2);
3010 /* Skip the starting quote */
3012 if (*path_val
== '"')
3015 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
3016 *ptr
++ = *path_val
++;
3018 /* If directory is empty, it is the current directory*/
3020 if (ptr
== file_path
)
3027 /* Skip the ending quote */
3032 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
3033 *++ptr
= DIR_SEPARATOR
;
3035 strcpy (++ptr
, file_name
);
3037 if (predicate (file_path
))
3038 return xstrdup (file_path
);
3043 /* Skip path separator */
3052 /* Locate an executable file, give a Path value. */
3055 __gnat_locate_executable_file (char *file_name
, char *path_val
)
3057 return __gnat_locate_file_with_predicate
3058 (file_name
, path_val
, &__gnat_is_executable_file
);
3061 /* Locate a regular file, give a Path value. */
3064 __gnat_locate_regular_file (char *file_name
, char *path_val
)
3066 return __gnat_locate_file_with_predicate
3067 (file_name
, path_val
, &__gnat_is_regular_file
);
3070 /* Locate an executable given a Path argument. This routine is only used by
3071 gnatbl and should not be used otherwise. Use locate_exec_on_path
3075 __gnat_locate_exec (char *exec_name
, char *path_val
)
3078 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
3080 char *full_exec_name
=
3082 (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
3084 strcpy (full_exec_name
, exec_name
);
3085 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
3086 ptr
= __gnat_locate_executable_file (full_exec_name
, path_val
);
3089 return __gnat_locate_executable_file (exec_name
, path_val
);
3093 return __gnat_locate_executable_file (exec_name
, path_val
);
3096 /* Locate an executable using the Systems default PATH. */
3099 __gnat_locate_exec_on_path (char *exec_name
)
3103 #if defined (_WIN32) && !defined (RTX)
3104 TCHAR
*wpath_val
= _tgetenv (_T("PATH"));
3106 /* In Win32 systems we expand the PATH as for XP environment
3107 variables are not automatically expanded. We also prepend the
3108 ".;" to the path to match normal NT path search semantics */
3110 #define EXPAND_BUFFER_SIZE 32767
3112 wapath_val
= (TCHAR
*) alloca (EXPAND_BUFFER_SIZE
);
3114 wapath_val
[0] = '.';
3115 wapath_val
[1] = ';';
3117 DWORD res
= ExpandEnvironmentStrings
3118 (wpath_val
, &wapath_val
[2], EXPAND_BUFFER_SIZE
- 2);
3120 if (!res
) wapath_val
[0] = _T('\0');
3122 apath_val
= (char *) alloca (EXPAND_BUFFER_SIZE
);
3124 WS2SC (apath_val
, wapath_val
, EXPAND_BUFFER_SIZE
);
3125 return __gnat_locate_exec (exec_name
, apath_val
);
3130 char *path_val
= "/VAXC$PATH";
3132 char *path_val
= getenv ("PATH");
3134 if (path_val
== NULL
) return NULL
;
3135 apath_val
= (char *) alloca (strlen (path_val
) + 1);
3136 strcpy (apath_val
, path_val
);
3137 return __gnat_locate_exec (exec_name
, apath_val
);
3143 /* These functions are used to translate to and from VMS and Unix syntax
3144 file, directory and path specifications. */
3147 #define MAXNAMES 256
3148 #define NEW_CANONICAL_FILELIST_INCREMENT 64
3150 static char new_canonical_dirspec
[MAXPATH
];
3151 static char new_canonical_filespec
[MAXPATH
];
3152 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
3153 static unsigned new_canonical_filelist_index
;
3154 static unsigned new_canonical_filelist_in_use
;
3155 static unsigned new_canonical_filelist_allocated
;
3156 static char **new_canonical_filelist
;
3157 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
3158 static char new_host_dirspec
[MAXPATH
];
3159 static char new_host_filespec
[MAXPATH
];
3161 /* Routine is called repeatedly by decc$from_vms via
3162 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
3166 wildcard_translate_unix (char *name
)
3169 char buff
[MAXPATH
];
3171 strncpy (buff
, name
, MAXPATH
);
3172 buff
[MAXPATH
- 1] = (char) 0;
3173 ver
= strrchr (buff
, '.');
3175 /* Chop off the version. */
3179 /* Dynamically extend the allocation by the increment. */
3180 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
3182 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
3183 new_canonical_filelist
= (char **) xrealloc
3184 (new_canonical_filelist
,
3185 new_canonical_filelist_allocated
* sizeof (char *));
3188 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
3193 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
3194 full translation and copy the results into a list (_init), then return them
3195 one at a time (_next). If onlydirs set, only expand directory files. */
3198 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
3201 char buff
[MAXPATH
];
3203 len
= strlen (filespec
);
3204 strncpy (buff
, filespec
, MAXPATH
);
3206 /* Only look for directories */
3207 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
3208 strncat (buff
, "*.dir", MAXPATH
);
3210 buff
[MAXPATH
- 1] = (char) 0;
3212 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
3214 /* Remove the .dir extension. */
3220 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3222 ext
= strstr (new_canonical_filelist
[i
], ".dir");
3228 return new_canonical_filelist_in_use
;
3231 /* Return the next filespec in the list. */
3234 __gnat_to_canonical_file_list_next (void)
3236 return new_canonical_filelist
[new_canonical_filelist_index
++];
3239 /* Free storage used in the wildcard expansion. */
3242 __gnat_to_canonical_file_list_free (void)
3246 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3247 free (new_canonical_filelist
[i
]);
3249 free (new_canonical_filelist
);
3251 new_canonical_filelist_in_use
= 0;
3252 new_canonical_filelist_allocated
= 0;
3253 new_canonical_filelist_index
= 0;
3254 new_canonical_filelist
= 0;
3257 /* The functional equivalent of decc$translate_vms routine.
3258 Designed to produce the same output, but is protected against
3259 malformed paths (original version ACCVIOs in this case) and
3260 does not require VMS-specific DECC RTL. */
3262 #define NAM$C_MAXRSS 1024
3265 __gnat_translate_vms (char *src
)
3267 static char retbuf
[NAM$C_MAXRSS
+ 1];
3268 char *srcendpos
, *pos1
, *pos2
, *retpos
;
3269 int disp
, path_present
= 0;
3274 srcendpos
= strchr (src
, '\0');
3277 /* Look for the node and/or device in front of the path. */
3279 pos2
= strchr (pos1
, ':');
3281 if (pos2
&& (pos2
< srcendpos
) && (*(pos2
+ 1) == ':'))
3283 /* There is a node name. "node_name::" becomes "node_name!". */
3285 strncpy (retbuf
, pos1
, disp
);
3286 retpos
[disp
] = '!';
3287 retpos
= retpos
+ disp
+ 1;
3289 pos2
= strchr (pos1
, ':');
3294 /* There is a device name. "dev_name:" becomes "/dev_name/". */
3297 strncpy (retpos
, pos1
, disp
);
3298 retpos
= retpos
+ disp
;
3303 /* No explicit device; we must look ahead and prepend /sys$disk/ if
3304 the path is absolute. */
3305 if ((*pos1
== '[' || *pos1
== '<') && (pos1
< srcendpos
)
3306 && !strchr (".-]>", *(pos1
+ 1)))
3308 strncpy (retpos
, "/sys$disk/", 10);
3312 /* Process the path part. */
3313 while (*pos1
== '[' || *pos1
== '<')
3317 if (*pos1
== ']' || *pos1
== '>')
3319 /* Special case, [] translates to '.'. */
3325 /* '[000000' means root dir. It can be present in the middle of
3326 the path due to expansion of logical devices, in which case
3328 if (!strncmp (pos1
, "000000", 6) && path_present
> 1 &&
3329 (*(pos1
+ 6) == ']' || *(pos1
+ 6) == '>' || *(pos1
+ 6) == '.'))
3332 if (*pos1
== '.') pos1
++;
3334 else if (*pos1
== '.')
3336 /* Relative path. */
3340 /* There is a qualified path. */
3341 while (*pos1
&& *pos1
!= ']' && *pos1
!= '>')
3346 /* '.' is used to separate directories. Replace it with '/'
3347 but only if there isn't already '/' just before. */
3348 if (*(retpos
- 1) != '/')
3351 if (pos1
+ 1 < srcendpos
3353 && *(pos1
+ 1) == '.')
3355 /* Ellipsis refers to entire subtree; replace
3364 /* When after '.' '[' '<' is equivalent to Unix ".." but
3365 there may be several in a row. */
3366 if (*(pos1
- 1) == '.' || *(pos1
- 1) == '[' ||
3369 while (*pos1
== '-')
3379 /* Otherwise fall through to default. */
3381 *(retpos
++) = *(pos1
++);
3388 if (pos1
< srcendpos
)
3390 /* Now add the actual file name, until the version suffix if any */
3393 pos2
= strchr (pos1
, ';');
3394 disp
= pos2
? (pos2
- pos1
) : (srcendpos
- pos1
);
3395 strncpy (retpos
, pos1
, disp
);
3397 if (pos2
&& pos2
< srcendpos
)
3399 /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
3401 disp
= srcendpos
- pos2
- 1;
3402 strncpy (retpos
, pos2
+ 1, disp
);
3412 /* Translate a VMS syntax directory specification in to Unix syntax. If
3413 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
3414 found, return input string. Also translate a dirname that contains no
3415 slashes, in case it's a logical name. */
3418 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
3422 strcpy (new_canonical_dirspec
, "");
3423 if (strlen (dirspec
))
3427 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
3429 strncpy (new_canonical_dirspec
,
3430 __gnat_translate_vms (dirspec
),
3433 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
3435 strncpy (new_canonical_dirspec
,
3436 __gnat_translate_vms (dirspec1
),
3441 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
3445 len
= strlen (new_canonical_dirspec
);
3446 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
3447 strncat (new_canonical_dirspec
, "/", MAXPATH
);
3449 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
3451 return new_canonical_dirspec
;
3455 /* Translate a VMS syntax file specification into Unix syntax.
3456 If no indicators of VMS syntax found, check if it's an uppercase
3457 alphanumeric_ name and if so try it out as an environment
3458 variable (logical name). If all else fails return the
3462 __gnat_to_canonical_file_spec (char *filespec
)
3466 strncpy (new_canonical_filespec
, "", MAXPATH
);
3468 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3470 char *tspec
= (char *) __gnat_translate_vms (filespec
);
3472 if (tspec
!= (char *) -1)
3473 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3475 else if ((strlen (filespec
) == strspn (filespec
,
3476 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
3477 && (filespec1
= getenv (filespec
)))
3479 char *tspec
= (char *) __gnat_translate_vms (filespec1
);
3481 if (tspec
!= (char *) -1)
3482 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3486 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
3489 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
3491 return new_canonical_filespec
;
3494 /* Translate a VMS syntax path specification into Unix syntax.
3495 If no indicators of VMS syntax found, return input string. */
3498 __gnat_to_canonical_path_spec (char *pathspec
)
3500 char *curr
, *next
, buff
[MAXPATH
];
3505 /* If there are /'s, assume it's a Unix path spec and return. */
3506 if (strchr (pathspec
, '/'))
3509 new_canonical_pathspec
[0] = 0;
3514 next
= strchr (curr
, ',');
3516 next
= strchr (curr
, 0);
3518 strncpy (buff
, curr
, next
- curr
);
3519 buff
[next
- curr
] = 0;
3521 /* Check for wildcards and expand if present. */
3522 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
3526 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
3527 for (i
= 0; i
< dirs
; i
++)
3531 next_dir
= __gnat_to_canonical_file_list_next ();
3532 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
3534 /* Don't append the separator after the last expansion. */
3536 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3539 __gnat_to_canonical_file_list_free ();
3542 strncat (new_canonical_pathspec
,
3543 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
3548 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3552 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
3554 return new_canonical_pathspec
;
3557 static char filename_buff
[MAXPATH
];
3560 translate_unix (char *name
, int type ATTRIBUTE_UNUSED
)
3562 strncpy (filename_buff
, name
, MAXPATH
);
3563 filename_buff
[MAXPATH
- 1] = (char) 0;
3567 /* Translate a Unix syntax directory specification into VMS syntax. The
3568 PREFIXFLAG has no effect, but is kept for symmetry with
3569 to_canonical_dir_spec. If indicators of VMS syntax found, return input
3573 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3575 int len
= strlen (dirspec
);
3577 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
3578 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3580 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
3581 return new_host_dirspec
;
3583 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
3585 new_host_dirspec
[len
- 1] = 0;
3589 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
3590 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
3591 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3593 return new_host_dirspec
;
3596 /* Translate a Unix syntax file specification into VMS syntax.
3597 If indicators of VMS syntax found, return input string. */
3600 __gnat_to_host_file_spec (char *filespec
)
3602 strncpy (new_host_filespec
, "", MAXPATH
);
3603 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3605 strncpy (new_host_filespec
, filespec
, MAXPATH
);
3609 decc$
to_vms (filespec
, translate_unix
, 1, 1);
3610 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
3613 new_host_filespec
[MAXPATH
- 1] = (char) 0;
3615 return new_host_filespec
;
3619 __gnat_adjust_os_resource_limits (void)
3621 SYS$
ADJWSL (131072, 0);
3626 /* Dummy functions for Osint import for non-VMS systems. */
3629 __gnat_to_canonical_file_list_init (char *dirspec ATTRIBUTE_UNUSED
,
3630 int onlydirs ATTRIBUTE_UNUSED
)
3636 __gnat_to_canonical_file_list_next (void)
3638 static char empty
[] = "";
3643 __gnat_to_canonical_file_list_free (void)
3648 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3654 __gnat_to_canonical_file_spec (char *filespec
)
3660 __gnat_to_canonical_path_spec (char *pathspec
)
3666 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3672 __gnat_to_host_file_spec (char *filespec
)
3678 __gnat_adjust_os_resource_limits (void)
3684 #if defined (__mips_vxworks)
3688 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
3692 #if defined (IS_CROSS) \
3693 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3694 && defined (__SVR4)) \
3695 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3696 && ! (defined (linux) && defined (__ia64__)) \
3697 && ! (defined (linux) && defined (powerpc)) \
3698 && ! defined (__FreeBSD__) \
3699 && ! defined (__Lynx__) \
3700 && ! defined (__hpux__) \
3701 && ! defined (__APPLE__) \
3702 && ! defined (_AIX) \
3703 && ! defined (VMS) \
3704 && ! defined (__MINGW32__))
3706 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3707 just above for a list of native platforms that provide a non-dummy
3708 version of this procedure in libaddr2line.a. */
3711 convert_addresses (const char *file_name ATTRIBUTE_UNUSED
,
3712 void *addrs ATTRIBUTE_UNUSED
,
3713 int n_addr ATTRIBUTE_UNUSED
,
3714 void *buf ATTRIBUTE_UNUSED
,
3715 int *len ATTRIBUTE_UNUSED
)
3721 #if defined (_WIN32)
3722 int __gnat_argument_needs_quote
= 1;
3724 int __gnat_argument_needs_quote
= 0;
3727 /* This option is used to enable/disable object files handling from the
3728 binder file by the GNAT Project module. For example, this is disabled on
3729 Windows (prior to GCC 3.4) as it is already done by the mdll module.
3730 Stating with GCC 3.4 the shared libraries are not based on mdll
3731 anymore as it uses the GCC's -shared option */
3732 #if defined (_WIN32) \
3733 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3734 int __gnat_prj_add_obj_files
= 0;
3736 int __gnat_prj_add_obj_files
= 1;
3739 /* char used as prefix/suffix for environment variables */
3740 #if defined (_WIN32)
3741 char __gnat_environment_char
= '%';
3743 char __gnat_environment_char
= '$';
3746 /* This functions copy the file attributes from a source file to a
3749 mode = 0 : In this mode copy only the file time stamps (last access and
3750 last modification time stamps).
3752 mode = 1 : In this mode, time stamps and read/write/execute attributes are
3755 Returns 0 if operation was successful and -1 in case of error. */
3758 __gnat_copy_attribs (char *from ATTRIBUTE_UNUSED
, char *to ATTRIBUTE_UNUSED
,
3759 int mode ATTRIBUTE_UNUSED
)
3761 #if defined (VMS) || (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \
3762 defined (__nucleus__)
3765 #elif defined (_WIN32) && !defined (RTX)
3766 TCHAR wfrom
[GNAT_MAX_PATH_LEN
+ 2];
3767 TCHAR wto
[GNAT_MAX_PATH_LEN
+ 2];
3769 FILETIME fct
, flat
, flwt
;
3772 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
+ 2);
3773 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
+ 2);
3775 /* retrieve from times */
3778 (wfrom
, GENERIC_READ
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3780 if (hfrom
== INVALID_HANDLE_VALUE
)
3783 res
= GetFileTime (hfrom
, &fct
, &flat
, &flwt
);
3785 CloseHandle (hfrom
);
3790 /* retrieve from times */
3793 (wto
, GENERIC_WRITE
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3795 if (hto
== INVALID_HANDLE_VALUE
)
3798 res
= SetFileTime (hto
, NULL
, &flat
, &flwt
);
3805 /* Set file attributes in full mode. */
3809 DWORD attribs
= GetFileAttributes (wfrom
);
3811 if (attribs
== INVALID_FILE_ATTRIBUTES
)
3814 res
= SetFileAttributes (wto
, attribs
);
3822 GNAT_STRUCT_STAT fbuf
;
3823 struct utimbuf tbuf
;
3825 if (GNAT_STAT (from
, &fbuf
) == -1)
3830 tbuf
.actime
= fbuf
.st_atime
;
3831 tbuf
.modtime
= fbuf
.st_mtime
;
3833 if (utime (to
, &tbuf
) == -1)
3840 if (chmod (to
, fbuf
.st_mode
) == -1)
3851 __gnat_lseek (int fd
, long offset
, int whence
)
3853 return (int) lseek (fd
, offset
, whence
);
3856 /* This function returns the major version number of GCC being used. */
3858 get_gcc_version (void)
3863 return (int) (version_string
[0] - '0');
3868 * Set Close_On_Exec as indicated.
3869 * Note: this is used for both GNAT.OS_Lib and GNAT.Sockets.
3873 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED
,
3874 int close_on_exec_p ATTRIBUTE_UNUSED
)
3876 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3877 int flags
= fcntl (fd
, F_GETFD
, 0);
3880 if (close_on_exec_p
)
3881 flags
|= FD_CLOEXEC
;
3883 flags
&= ~FD_CLOEXEC
;
3884 return fcntl (fd
, F_SETFD
, flags
| FD_CLOEXEC
);
3885 #elif defined(_WIN32)
3886 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
3887 if (h
== (HANDLE
) -1)
3889 if (close_on_exec_p
)
3890 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
, 0);
3891 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
,
3892 HANDLE_FLAG_INHERIT
);
3894 /* TODO: Unimplemented. */
3899 /* Indicates if platforms supports automatic initialization through the
3900 constructor mechanism */
3902 __gnat_binder_supports_auto_init (void)
3911 /* Indicates that Stand-Alone Libraries are automatically initialized through
3912 the constructor mechanism */
3914 __gnat_sals_init_using_constructors (void)
3916 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3925 /* In RTX mode, the procedure to get the time (as file time) is different
3926 in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3927 we introduce an intermediate procedure to link against the corresponding
3928 one in each situation. */
3930 extern void GetTimeAsFileTime (LPFILETIME pTime
);
3932 void GetTimeAsFileTime (LPFILETIME pTime
)
3935 RtGetRtssTimeAsFileTime (pTime
); /* RTSS interface */
3937 GetSystemTimeAsFileTime (pTime
); /* w32 interface */
3942 /* Add symbol that is required to link. It would otherwise be taken from
3943 libgcc.a and it would try to use the gcc constructors that are not
3944 supported by Microsoft linker. */
3946 extern void __main (void);
3954 #if defined (__ANDROID__)
3956 #include <pthread.h>
3959 __gnat_lwp_self (void)
3961 return (void *) pthread_self ();
3964 #elif defined (linux)
3965 /* There is no function in the glibc to retrieve the LWP of the current
3966 thread. We need to do a system call in order to retrieve this
3968 #include <sys/syscall.h>
3970 __gnat_lwp_self (void)
3972 return (void *) syscall (__NR_gettid
);
3977 /* glibc versions earlier than 2.7 do not define the routines to handle
3978 dynamically allocated CPU sets. For these targets, we use the static
3983 /* Dynamic cpu sets */
3986 __gnat_cpu_alloc (size_t count
)
3988 return CPU_ALLOC (count
);
3992 __gnat_cpu_alloc_size (size_t count
)
3994 return CPU_ALLOC_SIZE (count
);
3998 __gnat_cpu_free (cpu_set_t
*set
)
4004 __gnat_cpu_zero (size_t count
, cpu_set_t
*set
)
4006 CPU_ZERO_S (count
, set
);
4010 __gnat_cpu_set (int cpu
, size_t count
, cpu_set_t
*set
)
4012 /* Ada handles CPU numbers starting from 1, while C identifies the first
4013 CPU by a 0, so we need to adjust. */
4014 CPU_SET_S (cpu
- 1, count
, set
);
4017 #else /* !CPU_ALLOC */
4019 /* Static cpu sets */
4022 __gnat_cpu_alloc (size_t count ATTRIBUTE_UNUSED
)
4024 return (cpu_set_t
*) xmalloc (sizeof (cpu_set_t
));
4028 __gnat_cpu_alloc_size (size_t count ATTRIBUTE_UNUSED
)
4030 return sizeof (cpu_set_t
);
4034 __gnat_cpu_free (cpu_set_t
*set
)
4040 __gnat_cpu_zero (size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
4046 __gnat_cpu_set (int cpu
, size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
4048 /* Ada handles CPU numbers starting from 1, while C identifies the first
4049 CPU by a 0, so we need to adjust. */
4050 CPU_SET (cpu
- 1, set
);
4052 #endif /* !CPU_ALLOC */
4055 /* Return the load address of the executable, or 0 if not known. In the
4056 specific case of error, (void *)-1 can be returned. Beware: this unit may
4057 be in a shared library. As low-level units are needed, we allow #include
4060 #if defined (__APPLE__)
4061 #include <mach-o/dyld.h>
4062 #elif 0 && defined (__linux__)
4067 __gnat_get_executable_load_address (void)
4069 #if defined (__APPLE__)
4070 return _dyld_get_image_header (0);
4072 #elif 0 && defined (__linux__)
4073 /* Currently disabled as it needs at least -ldl. */
4074 struct link_map
*map
= _r_debug
.r_map
;
4076 return (const void *)map
->l_addr
;