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 to use, set in initialize.c. */
127 UINT CurrentCodePage
;
130 #include <sys/utime.h>
132 /* For isalpha-like tests in the compiler, we're expected to resort to
133 safe-ctype.h/ISALPHA. This isn't available for the runtime library
134 build, so we fallback on ctype.h/isalpha there. */
138 #define ISALPHA isalpha
141 #elif defined (__Lynx__)
143 /* Lynx utime.h only defines the entities of interest to us if
144 defined (VMOS_DEV), so ... */
153 /* wait.h processing */
156 # include <sys/wait.h>
158 #elif defined (__vxworks) && defined (__RTP__)
160 #elif defined (__Lynx__)
161 /* ??? We really need wait.h and it includes resource.h on Lynx. GCC
162 has a resource.h header as well, included instead of the lynx
163 version in our setup, causing lots of errors. We don't really need
164 the lynx contents of this file, so just workaround the issue by
165 preventing the inclusion of the GCC header from doing anything. */
166 # define GCC_RESOURCE_H
167 # include <sys/wait.h>
168 #elif defined (__nucleus__) || defined (__PikeOS__)
169 /* No wait() or waitpid() calls available. */
172 #include <sys/wait.h>
178 /* Header files and definitions for __gnat_set_file_time_name. */
180 #define __NEW_STARLET 1
182 #include <vms/atrdef.h>
183 #include <vms/fibdef.h>
184 #include <vms/stsdef.h>
185 #include <vms/iodef.h>
187 #include <vms/descrip.h>
191 /* Use native 64-bit arithmetic. */
192 #define unix_time_to_vms(X,Y) \
194 unsigned long long reftime, tmptime = (X); \
195 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
196 SYS$BINTIM (&unixtime, &reftime); \
197 Y = tmptime * 10000000 + reftime; \
200 /* descrip.h doesn't have everything ... */
201 typedef struct fibdef
* __fibdef_ptr32
__attribute__ (( mode (SI
) ));
202 struct dsc$descriptor_fib
204 unsigned int fib$l_len
;
205 __fibdef_ptr32 fib$l_addr
;
208 /* I/O Status Block. */
211 unsigned short status
, count
;
215 static char *tryfile
;
217 /* Variable length string. */
221 char string
[NAM$C_MAXRSS
+1];
224 #define SYI$_ACTIVECPU_CNT 0x111e
225 extern int LIB$
GETSYI (int *, unsigned int *);
226 extern unsigned int LIB$
CALLG_64 (unsigned long long argument_list
[],
227 int (*user_procedure
)(void));
244 #define DIR_SEPARATOR '\\'
249 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
250 defined in the current system. On DOS-like systems these flags control
251 whether the file is opened/created in text-translation mode (CR/LF in
252 external file mapped to LF in internal file), but in Unix-like systems,
253 no text translation is required, so these flags have no effect. */
263 #ifndef HOST_EXECUTABLE_SUFFIX
264 #define HOST_EXECUTABLE_SUFFIX ""
267 #ifndef HOST_OBJECT_SUFFIX
268 #define HOST_OBJECT_SUFFIX ".o"
271 #ifndef PATH_SEPARATOR
272 #define PATH_SEPARATOR ':'
275 #ifndef DIR_SEPARATOR
276 #define DIR_SEPARATOR '/'
279 /* Check for cross-compilation. */
280 #if defined (CROSS_COMPILE) || defined (CROSS_DIRECTORY_STRUCTURE)
282 int __gnat_is_cross_compiler
= 1;
285 int __gnat_is_cross_compiler
= 0;
288 char __gnat_dir_separator
= DIR_SEPARATOR
;
290 char __gnat_path_separator
= PATH_SEPARATOR
;
292 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
293 the base filenames that libraries specified with -lsomelib options
294 may have. This is used by GNATMAKE to check whether an executable
295 is up-to-date or not. The syntax is
297 library_template ::= { pattern ; } pattern NUL
298 pattern ::= [ prefix ] * [ postfix ]
300 These should only specify names of static libraries as it makes
301 no sense to determine at link time if dynamic-link libraries are
302 up to date or not. Any libraries that are not found are supposed
305 * if they are needed but not present, the link
308 * otherwise they are libraries in the system paths and so
309 they are considered part of the system and not checked
312 ??? This should be part of a GNAT host-specific compiler
313 file instead of being included in all user applications
314 as well. This is only a temporary work-around for 3.11b. */
316 #ifndef GNAT_LIBRARY_TEMPLATE
318 #define GNAT_LIBRARY_TEMPLATE "*.olb"
320 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
324 const char *__gnat_library_template
= GNAT_LIBRARY_TEMPLATE
;
326 /* This variable is used in hostparm.ads to say whether the host is a VMS
335 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
337 #elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__)
338 #define GNAT_MAX_PATH_LEN PATH_MAX
342 #if defined (__MINGW32__)
346 #include <sys/param.h>
350 #include <sys/param.h>
354 #define GNAT_MAX_PATH_LEN MAXPATHLEN
356 #define GNAT_MAX_PATH_LEN 256
361 /* Used for runtime check that Ada constant File_Attributes_Size is no
362 less than the actual size of struct file_attributes (see Osint
364 int __gnat_size_of_file_attributes
= sizeof (struct file_attributes
);
366 void __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
);
368 /* The __gnat_max_path_len variable is used to export the maximum
369 length of a path name to Ada code. max_path_len is also provided
370 for compatibility with older GNAT versions, please do not use
373 int __gnat_max_path_len
= GNAT_MAX_PATH_LEN
;
374 int max_path_len
= GNAT_MAX_PATH_LEN
;
376 /* Control whether we can use ACL on Windows. */
378 int __gnat_use_acl
= 1;
380 /* The following macro HAVE_READDIR_R should be defined if the
381 system provides the routine readdir_r. */
382 #undef HAVE_READDIR_R
384 #if defined(VMS) && defined (__LONG_POINTERS)
386 /* Return a 32 bit pointer to an array of 32 bit pointers
387 given a 64 bit pointer to an array of 64 bit pointers */
389 typedef __char_ptr32
*__char_ptr_char_ptr32
__attribute__ ((mode (SI
)));
391 static __char_ptr_char_ptr32
392 to_ptr32 (char **ptr64
)
395 __char_ptr_char_ptr32 short_argv
;
397 for (argc
= 0; ptr64
[argc
]; argc
++)
400 /* Reallocate argv with 32 bit pointers. */
401 short_argv
= (__char_ptr_char_ptr32
) decc$malloc
402 (sizeof (__char_ptr32
) * (argc
+ 1));
404 for (argc
= 0; ptr64
[argc
]; argc
++)
405 short_argv
[argc
] = (__char_ptr32
) decc$
strdup (ptr64
[argc
]);
407 short_argv
[argc
] = (__char_ptr32
) 0;
411 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
413 #define MAYBE_TO_PTR32(argv) argv
416 static const char ATTR_UNSET
= 127;
418 /* Reset the file attributes as if no system call had been performed */
421 __gnat_reset_attributes (struct file_attributes
* attr
)
423 attr
->exists
= ATTR_UNSET
;
424 attr
->error
= EINVAL
;
426 attr
->writable
= ATTR_UNSET
;
427 attr
->readable
= ATTR_UNSET
;
428 attr
->executable
= ATTR_UNSET
;
430 attr
->regular
= ATTR_UNSET
;
431 attr
->symbolic_link
= ATTR_UNSET
;
432 attr
->directory
= ATTR_UNSET
;
434 attr
->timestamp
= (OS_Time
)-2;
435 attr
->file_length
= -1;
439 __gnat_error_attributes (struct file_attributes
*attr
) {
444 __gnat_current_time (void)
446 time_t res
= time (NULL
);
447 return (OS_Time
) res
;
450 /* Return the current local time as a string in the ISO 8601 format of
451 "YYYY-MM-DD HH:MM:SS.SS". The returned string is 22 + 1 (NULL) characters
455 __gnat_current_time_string (char *result
)
457 const char *format
= "%Y-%m-%d %H:%M:%S";
458 /* Format string necessary to describe the ISO 8601 format */
460 const time_t t_val
= time (NULL
);
462 strftime (result
, 22, format
, localtime (&t_val
));
463 /* Convert the local time into a string following the ISO format, copying
464 at most 22 characters into the result string. */
469 /* The sub-seconds are manually set to zero since type time_t lacks the
470 precision necessary for nanoseconds. */
474 __gnat_to_gm_time (OS_Time
*p_time
, int *p_year
, int *p_month
, int *p_day
,
475 int *p_hours
, int *p_mins
, int *p_secs
)
478 time_t time
= (time_t) *p_time
;
481 /* On Windows systems, the time is sometimes rounded up to the nearest
482 even second, so if the number of seconds is odd, increment it. */
488 res
= localtime (&time
);
490 res
= gmtime (&time
);
495 *p_year
= res
->tm_year
;
496 *p_month
= res
->tm_mon
;
497 *p_day
= res
->tm_mday
;
498 *p_hours
= res
->tm_hour
;
499 *p_mins
= res
->tm_min
;
500 *p_secs
= res
->tm_sec
;
503 *p_year
= *p_month
= *p_day
= *p_hours
= *p_mins
= *p_secs
= 0;
507 __gnat_to_os_time (OS_Time
*p_time
, int year
, int month
, int day
,
508 int hours
, int mins
, int secs
)
520 /* returns -1 of failing, this is s-os_lib Invalid_Time */
522 *p_time
= (OS_Time
) mktime (&v
);
525 /* Place the contents of the symbolic link named PATH in the buffer BUF,
526 which has size BUFSIZ. If PATH is a symbolic link, then return the number
527 of characters of its content in BUF. Otherwise, return -1.
528 For systems not supporting symbolic links, always return -1. */
531 __gnat_readlink (char *path ATTRIBUTE_UNUSED
,
532 char *buf ATTRIBUTE_UNUSED
,
533 size_t bufsiz ATTRIBUTE_UNUSED
)
535 #if defined (_WIN32) || defined (VMS) \
536 || defined(__vxworks) || defined (__nucleus__) || defined (__PikeOS__)
539 return readlink (path
, buf
, bufsiz
);
543 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH.
544 If NEWPATH exists it will NOT be overwritten.
545 For systems not supporting symbolic links, always return -1. */
548 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED
,
549 char *newpath ATTRIBUTE_UNUSED
)
551 #if defined (_WIN32) || defined (VMS) \
552 || defined(__vxworks) || defined (__nucleus__) || defined (__PikeOS__)
555 return symlink (oldpath
, newpath
);
559 /* Try to lock a file, return 1 if success. */
561 #if defined (__vxworks) || defined (__nucleus__) \
562 || defined (_WIN32) || defined (VMS) || defined (__PikeOS__)
564 /* Version that does not use link. */
567 __gnat_try_lock (char *dir
, char *file
)
571 TCHAR wfull_path
[GNAT_MAX_PATH_LEN
];
572 TCHAR wfile
[GNAT_MAX_PATH_LEN
];
573 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
575 S2WSC (wdir
, dir
, GNAT_MAX_PATH_LEN
);
576 S2WSC (wfile
, file
, GNAT_MAX_PATH_LEN
);
578 _stprintf (wfull_path
, _T("%s%c%s"), wdir
, _T(DIR_SEPARATOR
), wfile
);
579 fd
= _topen (wfull_path
, O_CREAT
| O_EXCL
, 0600);
583 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
584 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
596 /* Version using link(), more secure over NFS. */
597 /* See TN 6913-016 for discussion ??? */
600 __gnat_try_lock (char *dir
, char *file
)
604 GNAT_STRUCT_STAT stat_result
;
607 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
608 sprintf (temp_file
, "%s%cTMP-%ld-%ld",
609 dir
, DIR_SEPARATOR
, (long)getpid(), (long)getppid ());
611 /* Create the temporary file and write the process number. */
612 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
618 /* Link it with the new file. */
619 link (temp_file
, full_path
);
621 /* Count the references on the old one. If we have a count of two, then
622 the link did succeed. Remove the temporary file before returning. */
623 __gnat_stat (temp_file
, &stat_result
);
625 return stat_result
.st_nlink
== 2;
629 /* Return the maximum file name length. */
632 __gnat_get_maximum_file_name_length (void)
635 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
644 /* Return nonzero if file names are case sensitive. */
646 static int file_names_case_sensitive_cache
= -1;
649 __gnat_get_file_names_case_sensitive (void)
651 if (file_names_case_sensitive_cache
== -1)
653 const char *sensitive
= getenv ("GNAT_FILE_NAME_CASE_SENSITIVE");
655 if (sensitive
!= NULL
656 && (sensitive
[0] == '0' || sensitive
[0] == '1')
657 && sensitive
[1] == '\0')
658 file_names_case_sensitive_cache
= sensitive
[0] - '0';
660 #if defined (VMS) || defined (WINNT) || defined (__APPLE__)
661 file_names_case_sensitive_cache
= 0;
663 file_names_case_sensitive_cache
= 1;
666 return file_names_case_sensitive_cache
;
669 /* Return nonzero if environment variables are case sensitive. */
672 __gnat_get_env_vars_case_sensitive (void)
674 #if defined (VMS) || defined (WINNT)
682 __gnat_get_default_identifier_character_set (void)
687 /* Return the current working directory. */
690 __gnat_get_current_dir (char *dir
, int *length
)
692 #if defined (__MINGW32__)
693 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
695 _tgetcwd (wdir
, *length
);
697 WS2SC (dir
, wdir
, GNAT_MAX_PATH_LEN
);
700 /* Force Unix style, which is what GNAT uses internally. */
701 getcwd (dir
, *length
, 0);
703 getcwd (dir
, *length
);
706 *length
= strlen (dir
);
708 if (dir
[*length
- 1] != DIR_SEPARATOR
)
710 dir
[*length
] = DIR_SEPARATOR
;
716 /* Return the suffix for object files. */
719 __gnat_get_object_suffix_ptr (int *len
, const char **value
)
721 *value
= HOST_OBJECT_SUFFIX
;
726 *len
= strlen (*value
);
731 /* Return the suffix for executable files. */
734 __gnat_get_executable_suffix_ptr (int *len
, const char **value
)
736 *value
= HOST_EXECUTABLE_SUFFIX
;
740 *len
= strlen (*value
);
745 /* Return the suffix for debuggable files. Usually this is the same as the
746 executable extension. */
749 __gnat_get_debuggable_suffix_ptr (int *len
, const char **value
)
751 *value
= HOST_EXECUTABLE_SUFFIX
;
756 *len
= strlen (*value
);
761 /* Returns the OS filename and corresponding encoding. */
764 __gnat_os_filename (char *filename ATTRIBUTE_UNUSED
,
765 char *w_filename ATTRIBUTE_UNUSED
,
766 char *os_name
, int *o_length
,
767 char *encoding ATTRIBUTE_UNUSED
, int *e_length
)
769 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
770 WS2SC (os_name
, (TCHAR
*)w_filename
, (DWORD
)*o_length
);
771 *o_length
= strlen (os_name
);
772 strcpy (encoding
, "encoding=utf8");
773 *e_length
= strlen (encoding
);
775 strcpy (os_name
, filename
);
776 *o_length
= strlen (filename
);
784 __gnat_unlink (char *path
)
786 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
788 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
790 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
791 return _tunlink (wpath
);
794 return unlink (path
);
801 __gnat_rename (char *from
, char *to
)
803 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
805 TCHAR wfrom
[GNAT_MAX_PATH_LEN
], wto
[GNAT_MAX_PATH_LEN
];
807 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
);
808 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
);
809 return _trename (wfrom
, wto
);
812 return rename (from
, to
);
816 /* Changing directory. */
819 __gnat_chdir (char *path
)
821 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
823 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
825 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
826 return _tchdir (wpath
);
833 /* Removing a directory. */
836 __gnat_rmdir (char *path
)
838 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
840 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
842 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
843 return _trmdir (wpath
);
845 #elif defined (VTHREADS)
846 /* rmdir not available */
854 __gnat_fopen (char *path
, char *mode
, int encoding ATTRIBUTE_UNUSED
,
855 char *vms_form ATTRIBUTE_UNUSED
)
857 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
858 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
861 S2WS (wmode
, mode
, 10);
863 if (encoding
== Encoding_Unspecified
)
864 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
865 else if (encoding
== Encoding_UTF8
)
866 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
868 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
870 return _tfopen (wpath
, wmode
);
873 return decc$
fopen (path
, mode
);
876 char *local_form
= (char *) alloca (strlen (vms_form
) + 1);
877 /* Allocate an argument list of guaranteed ample length. */
878 unsigned long long *arg_list
=
879 (unsigned long long *) alloca (strlen (vms_form
) + 3);
883 arg_list
[1] = (unsigned long long) path
;
884 arg_list
[2] = (unsigned long long) mode
;
885 strcpy (local_form
, vms_form
);
887 /* Given a string such as "\"rfm=udf\",\"rat=cr\""
888 Split it into an argument list as "rfm=udf","rat=cr". */
890 for (i
= 0; *ptrb
; i
++)
892 ptrb
= strchr (ptrb
, '"');
893 ptre
= strchr (ptrb
+ 1, '"');
895 arg_list
[i
+ 3] = (unsigned long long) (ptrb
+ 1);
898 arg_list
[0] = i
+ 2;
899 /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
900 always a 32bit pointer. */
901 return LIB$
CALLG_64 (arg_list
, &decc$fopen
);
904 return GNAT_FOPEN (path
, mode
);
909 __gnat_freopen (char *path
,
912 int encoding ATTRIBUTE_UNUSED
,
913 char *vms_form ATTRIBUTE_UNUSED
)
915 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
916 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
919 S2WS (wmode
, mode
, 10);
921 if (encoding
== Encoding_Unspecified
)
922 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
923 else if (encoding
== Encoding_UTF8
)
924 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
926 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
928 return _tfreopen (wpath
, wmode
, stream
);
931 return decc$
freopen (path
, mode
, stream
);
934 char *local_form
= (char *) alloca (strlen (vms_form
) + 1);
935 /* Allocate an argument list of guaranteed ample length. */
936 unsigned long long *arg_list
=
937 (unsigned long long *) alloca (strlen (vms_form
) + 4);
941 arg_list
[1] = (unsigned long long) path
;
942 arg_list
[2] = (unsigned long long) mode
;
943 arg_list
[3] = (unsigned long long) stream
;
944 strcpy (local_form
, vms_form
);
946 /* Given a string such as "\"rfm=udf\",\"rat=cr\""
947 Split it into an argument list as "rfm=udf","rat=cr". */
949 for (i
= 0; *ptrb
; i
++)
951 ptrb
= strchr (ptrb
, '"');
952 ptre
= strchr (ptrb
+ 1, '"');
954 arg_list
[i
+ 4] = (unsigned long long) (ptrb
+ 1);
957 arg_list
[0] = i
+ 3;
958 /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
959 always a 32bit pointer. */
960 return LIB$
CALLG_64 (arg_list
, &decc$freopen
);
963 return freopen (path
, mode
, stream
);
968 __gnat_open_read (char *path
, int fmode
)
971 int o_fmode
= O_BINARY
;
977 /* Optional arguments mbc,deq,fop increase read performance. */
978 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
979 "mbc=16", "deq=64", "fop=tef");
980 #elif defined (__vxworks)
981 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
982 #elif defined (__MINGW32__)
984 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
986 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
987 fd
= _topen (wpath
, O_RDONLY
| o_fmode
, 0444);
990 fd
= open (path
, O_RDONLY
| o_fmode
);
993 return fd
< 0 ? -1 : fd
;
996 #if defined (__MINGW32__)
997 #define PERM (S_IREAD | S_IWRITE)
999 /* Excerpt from DECC C RTL Reference Manual:
1000 To create files with OpenVMS RMS default protections using the UNIX
1001 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
1002 and open with a file-protection mode argument of 0777 in a program
1003 that never specifically calls umask. These default protections include
1004 correctly establishing protections based on ACLs, previous versions of
1005 files, and so on. */
1008 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
1012 __gnat_open_rw (char *path
, int fmode
)
1015 int o_fmode
= O_BINARY
;
1021 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
1022 "mbc=16", "deq=64", "fop=tef");
1023 #elif defined (__MINGW32__)
1025 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1027 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1028 fd
= _topen (wpath
, O_RDWR
| o_fmode
, PERM
);
1031 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
1034 return fd
< 0 ? -1 : fd
;
1038 __gnat_open_create (char *path
, int fmode
)
1041 int o_fmode
= O_BINARY
;
1047 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
1048 "mbc=16", "deq=64", "fop=tef");
1049 #elif defined (__MINGW32__)
1051 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1053 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1054 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
1057 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
1060 return fd
< 0 ? -1 : fd
;
1064 __gnat_create_output_file (char *path
)
1068 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
,
1069 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
1070 "shr=del,get,put,upd");
1071 #elif defined (__MINGW32__)
1073 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1075 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1076 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
1079 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
1082 return fd
< 0 ? -1 : fd
;
1086 __gnat_create_output_file_new (char *path
)
1090 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
,
1091 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
1092 "shr=del,get,put,upd");
1093 #elif defined (__MINGW32__)
1095 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1097 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1098 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
1101 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
1104 return fd
< 0 ? -1 : fd
;
1108 __gnat_open_append (char *path
, int fmode
)
1111 int o_fmode
= O_BINARY
;
1117 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
1118 "mbc=16", "deq=64", "fop=tef");
1119 #elif defined (__MINGW32__)
1121 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1123 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1124 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
1127 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
1130 return fd
< 0 ? -1 : fd
;
1133 /* Open a new file. Return error (-1) if the file already exists. */
1136 __gnat_open_new (char *path
, int fmode
)
1139 int o_fmode
= O_BINARY
;
1145 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1146 "mbc=16", "deq=64", "fop=tef");
1147 #elif defined (__MINGW32__)
1149 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1151 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1152 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1155 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1158 return fd
< 0 ? -1 : fd
;
1161 /* Open a new temp file. Return error (-1) if the file already exists.
1162 Special options for VMS allow the file to be shared between parent and child
1163 processes, however they really slow down output. Used in gnatchop. */
1166 __gnat_open_new_temp (char *path
, int fmode
)
1169 int o_fmode
= O_BINARY
;
1171 strcpy (path
, "GNAT-XXXXXX");
1173 #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \
1174 || defined (linux) || defined(__GLIBC__)) && !defined (__vxworks)
1175 return mkstemp (path
);
1176 #elif defined (__Lynx__)
1178 #elif defined (__nucleus__)
1181 if (mktemp (path
) == NULL
)
1189 /* Passing rfm=stmlf for binary files seems questionable since it results
1190 in having an extraneous line feed added after every call to CRTL write,
1191 so pass rfm=udf (aka undefined) instead. */
1192 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1193 fmode
? "rfm=stmlf" : "rfm=udf", "ctx=rec", "rat=none",
1194 "shr=del,get,put,upd", "mbc=16", "deq=64", "fop=tef");
1196 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1199 return fd
< 0 ? -1 : fd
;
1202 /****************************************************************
1203 ** Perform a call to GNAT_STAT or GNAT_FSTAT, and extract as much information
1204 ** as possible from it, storing the result in a cache for later reuse
1205 ****************************************************************/
1208 __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
)
1210 GNAT_STRUCT_STAT statbuf
;
1214 /* GNAT_FSTAT returns -1 and sets errno for failure */
1215 ret
= GNAT_FSTAT (fd
, &statbuf
);
1216 error
= ret
? errno
: 0;
1219 /* __gnat_stat returns errno value directly */
1220 error
= __gnat_stat (name
, &statbuf
);
1221 ret
= error
? -1 : 0;
1225 * A missing file is reported as an attr structure with error == 0 and
1229 if (error
== 0 || error
== ENOENT
)
1232 attr
->error
= error
;
1234 attr
->regular
= (!ret
&& S_ISREG (statbuf
.st_mode
));
1235 attr
->directory
= (!ret
&& S_ISDIR (statbuf
.st_mode
));
1238 attr
->file_length
= 0;
1240 /* st_size may be 32 bits, or 64 bits which is converted to long. We
1241 don't return a useful value for files larger than 2 gigabytes in
1243 attr
->file_length
= statbuf
.st_size
; /* all systems */
1245 attr
->exists
= !ret
;
1247 #if !defined (_WIN32) || defined (RTX)
1248 /* on Windows requires extra system call, see __gnat_is_readable_file_attr */
1249 attr
->readable
= (!ret
&& (statbuf
.st_mode
& S_IRUSR
));
1250 attr
->writable
= (!ret
&& (statbuf
.st_mode
& S_IWUSR
));
1251 attr
->executable
= (!ret
&& (statbuf
.st_mode
& S_IXUSR
));
1255 attr
->timestamp
= (OS_Time
)-1;
1258 /* VMS has file versioning. */
1259 attr
->timestamp
= (OS_Time
)statbuf
.st_ctime
;
1261 attr
->timestamp
= (OS_Time
)statbuf
.st_mtime
;
1266 /****************************************************************
1267 ** Return the number of bytes in the specified file
1268 ****************************************************************/
1271 __gnat_file_length_attr (int fd
, char* name
, struct file_attributes
* attr
)
1273 if (attr
->file_length
== -1) {
1274 __gnat_stat_to_attr (fd
, name
, attr
);
1277 return attr
->file_length
;
1281 __gnat_file_length (int fd
)
1283 struct file_attributes attr
;
1284 __gnat_reset_attributes (&attr
);
1285 return __gnat_file_length_attr (fd
, NULL
, &attr
);
1289 __gnat_named_file_length (char *name
)
1291 struct file_attributes attr
;
1292 __gnat_reset_attributes (&attr
);
1293 return __gnat_file_length_attr (-1, name
, &attr
);
1296 /* Create a temporary filename and put it in string pointed to by
1300 __gnat_tmp_name (char *tmp_filename
)
1303 /* Variable used to create a series of unique names */
1304 static int counter
= 0;
1306 /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */
1307 strcpy (tmp_filename
, "c:\\WINDOWS\\Temp\\gnat-");
1308 sprintf (&tmp_filename
[strlen (tmp_filename
)], "%d\0", counter
++);
1310 #elif defined (__MINGW32__)
1315 /* tempnam tries to create a temporary file in directory pointed to by
1316 TMP environment variable, in c:\temp if TMP is not set, and in
1317 directory specified by P_tmpdir in stdio.h if c:\temp does not
1318 exist. The filename will be created with the prefix "gnat-". */
1320 sprintf (prefix
, "gnat-%d-", (int)getpid());
1321 pname
= (char *) _tempnam ("c:\\temp", prefix
);
1323 /* if pname is NULL, the file was not created properly, the disk is full
1324 or there is no more free temporary files */
1327 *tmp_filename
= '\0';
1329 /* If pname start with a back slash and not path information it means that
1330 the filename is valid for the current working directory. */
1332 else if (pname
[0] == '\\')
1334 strcpy (tmp_filename
, ".\\");
1335 strcat (tmp_filename
, pname
+1);
1338 strcpy (tmp_filename
, pname
);
1343 #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \
1344 || defined (__OpenBSD__) || defined(__GLIBC__)
1345 #define MAX_SAFE_PATH 1000
1346 char *tmpdir
= getenv ("TMPDIR");
1348 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
1349 a buffer overflow. */
1350 if (tmpdir
== NULL
|| strlen (tmpdir
) > MAX_SAFE_PATH
)
1351 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
1353 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
1355 close (mkstemp(tmp_filename
));
1356 #elif defined (__vxworks) && !(defined (__RTP__) || defined (VTHREADS))
1360 static ushort_t seed
= 0; /* used to generate unique name */
1362 /* generate unique name */
1363 strcpy (tmp_filename
, "tmp");
1365 /* fill up the name buffer from the last position */
1367 pos
= tmp_filename
+ strlen (tmp_filename
) + index
;
1371 for (t
= seed
; 0 <= --index
; t
>>= 3)
1372 *--pos
= '0' + (t
& 07);
1374 tmpnam (tmp_filename
);
1378 /* Open directory and returns a DIR pointer. */
1380 DIR* __gnat_opendir (char *name
)
1383 /* Not supported in RTX */
1387 #elif defined (__MINGW32__)
1388 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1390 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1391 return (DIR*)_topendir (wname
);
1394 return opendir (name
);
1398 /* Read the next entry in a directory. The returned string points somewhere
1402 __gnat_readdir (DIR *dirp
, char *buffer
, int *len
)
1405 /* Not supported in RTX */
1409 #elif defined (__MINGW32__)
1410 struct _tdirent
*dirent
= _treaddir ((_TDIR
*)dirp
);
1414 WS2SC (buffer
, dirent
->d_name
, GNAT_MAX_PATH_LEN
);
1415 *len
= strlen (buffer
);
1422 #elif defined (HAVE_READDIR_R)
1423 /* If possible, try to use the thread-safe version. */
1424 if (readdir_r (dirp
, buffer
) != NULL
)
1426 *len
= strlen (((struct dirent
*) buffer
)->d_name
);
1427 return ((struct dirent
*) buffer
)->d_name
;
1433 struct dirent
*dirent
= (struct dirent
*) readdir (dirp
);
1437 strcpy (buffer
, dirent
->d_name
);
1438 *len
= strlen (buffer
);
1447 /* Close a directory entry. */
1449 int __gnat_closedir (DIR *dirp
)
1452 /* Not supported in RTX */
1456 #elif defined (__MINGW32__)
1457 return _tclosedir ((_TDIR
*)dirp
);
1460 return closedir (dirp
);
1464 /* Returns 1 if readdir is thread safe, 0 otherwise. */
1467 __gnat_readdir_is_thread_safe (void)
1469 #ifdef HAVE_READDIR_R
1476 #if defined (_WIN32) && !defined (RTX)
1477 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
1478 static const unsigned long long w32_epoch_offset
= 11644473600ULL;
1480 /* Returns the file modification timestamp using Win32 routines which are
1481 immune against daylight saving time change. It is in fact not possible to
1482 use fstat for this purpose as the DST modify the st_mtime field of the
1486 win32_filetime (HANDLE h
)
1491 unsigned long long ull_time
;
1494 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1495 since <Jan 1st 1601>. This function must return the number of seconds
1496 since <Jan 1st 1970>. */
1498 if (GetFileTime (h
, NULL
, NULL
, &t_write
.ft_time
))
1499 return (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1503 /* As above but starting from a FILETIME. */
1505 f2t (const FILETIME
*ft
, time_t *t
)
1510 unsigned long long ull_time
;
1513 t_write
.ft_time
= *ft
;
1514 *t
= (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1518 /* Return a GNAT time stamp given a file name. */
1521 __gnat_file_time_name_attr (char* name
, struct file_attributes
* attr
)
1523 if (attr
->timestamp
== (OS_Time
)-2) {
1524 #if defined (_WIN32) && !defined (RTX)
1526 WIN32_FILE_ATTRIBUTE_DATA fad
;
1528 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1529 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1531 if ((res
= GetFileAttributesEx (wname
, GetFileExInfoStandard
, &fad
)))
1532 f2t (&fad
.ftLastWriteTime
, &ret
);
1533 attr
->timestamp
= (OS_Time
) ret
;
1535 __gnat_stat_to_attr (-1, name
, attr
);
1538 return attr
->timestamp
;
1542 __gnat_file_time_name (char *name
)
1544 struct file_attributes attr
;
1545 __gnat_reset_attributes (&attr
);
1546 return __gnat_file_time_name_attr (name
, &attr
);
1549 /* Return a GNAT time stamp given a file descriptor. */
1552 __gnat_file_time_fd_attr (int fd
, struct file_attributes
* attr
)
1554 if (attr
->timestamp
== (OS_Time
)-2) {
1555 #if defined (_WIN32) && !defined (RTX)
1556 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
1557 time_t ret
= win32_filetime (h
);
1558 attr
->timestamp
= (OS_Time
) ret
;
1561 __gnat_stat_to_attr (fd
, NULL
, attr
);
1565 return attr
->timestamp
;
1569 __gnat_file_time_fd (int fd
)
1571 struct file_attributes attr
;
1572 __gnat_reset_attributes (&attr
);
1573 return __gnat_file_time_fd_attr (fd
, &attr
);
1576 /* Set the file time stamp. */
1579 __gnat_set_file_time_name (char *name
, time_t time_stamp
)
1581 #if defined (__vxworks)
1583 /* Code to implement __gnat_set_file_time_name for these systems. */
1585 #elif defined (_WIN32) && !defined (RTX)
1589 unsigned long long ull_time
;
1591 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1593 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1595 HANDLE h
= CreateFile
1596 (wname
, GENERIC_WRITE
, FILE_SHARE_WRITE
, NULL
,
1597 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
,
1599 if (h
== INVALID_HANDLE_VALUE
)
1601 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1602 t_write
.ull_time
= ((unsigned long long)time_stamp
+ w32_epoch_offset
);
1603 /* Convert to 100 nanosecond units */
1604 t_write
.ull_time
*= 10000000ULL;
1606 SetFileTime(h
, NULL
, NULL
, &t_write
.ft_time
);
1616 unsigned long long backup
, create
, expire
, revise
;
1620 unsigned short value
;
1623 unsigned system
: 4;
1629 } Fat
= { 0, 0, 0, 0, 0, { 0 }};
1633 { ATR$S_CREDATE
, ATR$C_CREDATE
, &Fat
.create
},
1634 { ATR$S_REVDATE
, ATR$C_REVDATE
, &Fat
.revise
},
1635 { ATR$S_EXPDATE
, ATR$C_EXPDATE
, &Fat
.expire
},
1636 { ATR$S_BAKDATE
, ATR$C_BAKDATE
, &Fat
.backup
},
1637 { ATR$S_FPRO
, ATR$C_FPRO
, &Fat
.prot
},
1638 { ATR$S_UIC
, ATR$C_UIC
, &Fat
.uic
},
1643 struct dsc$descriptor_fib fibdsc
= {sizeof (fib
), (void *) &fib
};
1647 unsigned long long newtime
;
1648 unsigned long long revtime
;
1652 struct vstring file
;
1653 struct dsc$descriptor_s filedsc
1654 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) file
.string
};
1655 struct vstring device
;
1656 struct dsc$descriptor_s devicedsc
1657 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) device
.string
};
1658 struct vstring timev
;
1659 struct dsc$descriptor_s timedsc
1660 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) timev
.string
};
1661 struct vstring result
;
1662 struct dsc$descriptor_s resultdsc
1663 = {NAM$C_MAXRSS
, DSC$K_DTYPE_VT
, DSC$K_CLASS_VS
, (void *) result
.string
};
1665 /* Convert parameter name (a file spec) to host file form. Note that this
1666 is needed on VMS to prepare for subsequent calls to VMS RMS library
1667 routines. Note that it would not work to call __gnat_to_host_dir_spec
1668 as was done in a previous version, since this fails silently unless
1669 the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1670 (directory not found) condition is signalled. */
1671 tryfile
= (char *) __gnat_to_host_file_spec (name
);
1673 /* Allocate and initialize a FAB and NAM structures. */
1677 nam
.nam$l_esa
= file
.string
;
1678 nam
.nam$b_ess
= NAM$C_MAXRSS
;
1679 nam
.nam$l_rsa
= result
.string
;
1680 nam
.nam$b_rss
= NAM$C_MAXRSS
;
1681 fab
.fab$l_fna
= tryfile
;
1682 fab
.fab$b_fns
= strlen (tryfile
);
1683 fab
.fab$l_nam
= &nam
;
1685 /* Validate filespec syntax and device existence. */
1686 status
= SYS$
PARSE (&fab
, 0, 0);
1687 if ((status
& 1) != 1)
1688 LIB$
SIGNAL (status
);
1690 file
.string
[nam
.nam$b_esl
] = 0;
1692 /* Find matching filespec. */
1693 status
= SYS$
SEARCH (&fab
, 0, 0);
1694 if ((status
& 1) != 1)
1695 LIB$
SIGNAL (status
);
1697 file
.string
[nam
.nam$b_esl
] = 0;
1698 result
.string
[result
.length
=nam
.nam$b_rsl
] = 0;
1700 /* Get the device name and assign an IO channel. */
1701 strncpy (device
.string
, nam
.nam$l_dev
, nam
.nam$b_dev
);
1702 devicedsc
.dsc$w_length
= nam
.nam$b_dev
;
1704 status
= SYS$
ASSIGN (&devicedsc
, &chan
, 0, 0, 0);
1705 if ((status
& 1) != 1)
1706 LIB$
SIGNAL (status
);
1708 /* Initialize the FIB and fill in the directory id field. */
1709 memset (&fib
, 0, sizeof (fib
));
1710 fib
.fib$w_did
[0] = nam
.nam$w_did
[0];
1711 fib
.fib$w_did
[1] = nam
.nam$w_did
[1];
1712 fib
.fib$w_did
[2] = nam
.nam$w_did
[2];
1713 fib
.fib$l_acctl
= 0;
1715 strcpy (file
.string
, (strrchr (result
.string
, ']') + 1));
1716 filedsc
.dsc$w_length
= strlen (file
.string
);
1717 result
.string
[result
.length
= 0] = 0;
1719 /* Open and close the file to fill in the attributes. */
1721 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1722 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1723 if ((status
& 1) != 1)
1724 LIB$
SIGNAL (status
);
1725 if ((iosb
.status
& 1) != 1)
1726 LIB$
SIGNAL (iosb
.status
);
1728 result
.string
[result
.length
] = 0;
1729 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0, &fibdsc
, 0, 0, 0,
1731 if ((status
& 1) != 1)
1732 LIB$
SIGNAL (status
);
1733 if ((iosb
.status
& 1) != 1)
1734 LIB$
SIGNAL (iosb
.status
);
1739 /* Set creation time to requested time. */
1740 unix_time_to_vms (time_stamp
, newtime
);
1742 t
= time ((time_t) 0);
1744 /* Set revision time to now in local time. */
1745 unix_time_to_vms (t
, revtime
);
1748 /* Reopen the file, modify the times and then close. */
1749 fib
.fib$l_acctl
= FIB$M_WRITE
;
1751 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1752 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1753 if ((status
& 1) != 1)
1754 LIB$
SIGNAL (status
);
1755 if ((iosb
.status
& 1) != 1)
1756 LIB$
SIGNAL (iosb
.status
);
1758 Fat
.create
= newtime
;
1759 Fat
.revise
= revtime
;
1761 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0,
1762 &fibdsc
, 0, 0, 0, &atrlst
, 0);
1763 if ((status
& 1) != 1)
1764 LIB$
SIGNAL (status
);
1765 if ((iosb
.status
& 1) != 1)
1766 LIB$
SIGNAL (iosb
.status
);
1768 /* Deassign the channel and exit. */
1769 status
= SYS$
DASSGN (chan
);
1770 if ((status
& 1) != 1)
1771 LIB$
SIGNAL (status
);
1773 struct utimbuf utimbuf
;
1776 /* Set modification time to requested time. */
1777 utimbuf
.modtime
= time_stamp
;
1779 /* Set access time to now in local time. */
1780 t
= time ((time_t) 0);
1781 utimbuf
.actime
= mktime (localtime (&t
));
1783 utime (name
, &utimbuf
);
1787 /* Get the list of installed standard libraries from the
1788 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1792 __gnat_get_libraries_from_registry (void)
1794 char *result
= (char *) xmalloc (1);
1798 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) \
1802 DWORD name_size
, value_size
;
1809 /* First open the key. */
1810 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1812 if (res
== ERROR_SUCCESS
)
1813 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1814 KEY_READ
, ®_key
);
1816 if (res
== ERROR_SUCCESS
)
1817 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1819 if (res
== ERROR_SUCCESS
)
1820 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1822 /* If the key exists, read out all the values in it and concatenate them
1824 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1826 value_size
= name_size
= 256;
1827 res
= RegEnumValueA (reg_key
, index
, name
, &name_size
, 0,
1828 &type
, (LPBYTE
)value
, &value_size
);
1830 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1832 char *old_result
= result
;
1834 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1835 strcpy (result
, old_result
);
1836 strcat (result
, value
);
1837 strcat (result
, ";");
1842 /* Remove the trailing ";". */
1844 result
[strlen (result
) - 1] = 0;
1850 /* Query information for the given file NAME and return it in STATBUF.
1851 * Returns 0 for success, or errno value for failure.
1854 __gnat_stat (char *name
, GNAT_STRUCT_STAT
*statbuf
)
1857 WIN32_FILE_ATTRIBUTE_DATA fad
;
1858 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
1863 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
1864 name_len
= _tcslen (wname
);
1866 if (name_len
> GNAT_MAX_PATH_LEN
)
1869 ZeroMemory (statbuf
, sizeof(GNAT_STRUCT_STAT
));
1871 res
= GetFileAttributesEx (wname
, GetFileExInfoStandard
, &fad
);
1874 error
= GetLastError();
1876 /* Check file existence using GetFileAttributes() which does not fail on
1877 special Windows files like con:, aux:, nul: etc... */
1879 if (GetFileAttributes(wname
) != INVALID_FILE_ATTRIBUTES
) {
1880 /* Just pretend that it is a regular and readable file */
1881 statbuf
->st_mode
= S_IFREG
| S_IREAD
| S_IWRITE
;
1886 case ERROR_ACCESS_DENIED
:
1887 case ERROR_SHARING_VIOLATION
:
1888 case ERROR_LOCK_VIOLATION
:
1889 case ERROR_SHARING_BUFFER_EXCEEDED
:
1891 case ERROR_BUFFER_OVERFLOW
:
1892 return ENAMETOOLONG
;
1893 case ERROR_NOT_ENOUGH_MEMORY
:
1900 f2t (&fad
.ftCreationTime
, &statbuf
->st_ctime
);
1901 f2t (&fad
.ftLastWriteTime
, &statbuf
->st_mtime
);
1902 f2t (&fad
.ftLastAccessTime
, &statbuf
->st_atime
);
1904 statbuf
->st_size
= (off_t
)fad
.nFileSizeLow
;
1906 /* We do not have the S_IEXEC attribute, but this is not used on GNAT. */
1907 statbuf
->st_mode
= S_IREAD
;
1909 if (fad
.dwFileAttributes
& FILE_ATTRIBUTE_DIRECTORY
)
1910 statbuf
->st_mode
|= S_IFDIR
;
1912 statbuf
->st_mode
|= S_IFREG
;
1914 if (!(fad
.dwFileAttributes
& FILE_ATTRIBUTE_READONLY
))
1915 statbuf
->st_mode
|= S_IWRITE
;
1920 return GNAT_STAT (name
, statbuf
) == 0 ? 0 : errno
;
1924 /*************************************************************************
1925 ** Check whether a file exists
1926 *************************************************************************/
1929 __gnat_file_exists_attr (char* name
, struct file_attributes
* attr
)
1931 if (attr
->exists
== ATTR_UNSET
)
1932 __gnat_stat_to_attr (-1, name
, attr
);
1934 return attr
->exists
;
1938 __gnat_file_exists (char *name
)
1940 struct file_attributes attr
;
1941 __gnat_reset_attributes (&attr
);
1942 return __gnat_file_exists_attr (name
, &attr
);
1945 /**********************************************************************
1946 ** Whether name is an absolute path
1947 **********************************************************************/
1950 __gnat_is_absolute_path (char *name
, int length
)
1953 /* On VxWorks systems, an absolute path can be represented (depending on
1954 the host platform) as either /dir/file, or device:/dir/file, or
1955 device:drive_letter:/dir/file. */
1962 for (index
= 0; index
< length
; index
++)
1964 if (name
[index
] == ':' &&
1965 ((name
[index
+ 1] == '/') ||
1966 (isalpha (name
[index
+ 1]) && index
+ 2 <= length
&&
1967 name
[index
+ 2] == '/')))
1970 else if (name
[index
] == '/')
1975 return (length
!= 0) &&
1976 (*name
== '/' || *name
== DIR_SEPARATOR
1978 || (length
> 1 && ISALPHA (name
[0]) && name
[1] == ':')
1985 __gnat_is_regular_file_attr (char* name
, struct file_attributes
* attr
)
1987 if (attr
->regular
== ATTR_UNSET
)
1988 __gnat_stat_to_attr (-1, name
, attr
);
1990 return attr
->regular
;
1994 __gnat_is_regular_file (char *name
)
1996 struct file_attributes attr
;
1998 __gnat_reset_attributes (&attr
);
1999 return __gnat_is_regular_file_attr (name
, &attr
);
2003 __gnat_is_directory_attr (char* name
, struct file_attributes
* attr
)
2005 if (attr
->directory
== ATTR_UNSET
)
2006 __gnat_stat_to_attr (-1, name
, attr
);
2008 return attr
->directory
;
2012 __gnat_is_directory (char *name
)
2014 struct file_attributes attr
;
2016 __gnat_reset_attributes (&attr
);
2017 return __gnat_is_directory_attr (name
, &attr
);
2020 #if defined (_WIN32) && !defined (RTX)
2022 /* Returns the same constant as GetDriveType but takes a pathname as
2026 GetDriveTypeFromPath (TCHAR
*wfullpath
)
2028 TCHAR wdrv
[MAX_PATH
];
2029 TCHAR wpath
[MAX_PATH
];
2030 TCHAR wfilename
[MAX_PATH
];
2031 TCHAR wext
[MAX_PATH
];
2033 _tsplitpath (wfullpath
, wdrv
, wpath
, wfilename
, wext
);
2035 if (_tcslen (wdrv
) != 0)
2037 /* we have a drive specified. */
2038 _tcscat (wdrv
, _T("\\"));
2039 return GetDriveType (wdrv
);
2043 /* No drive specified. */
2045 /* Is this a relative path, if so get current drive type. */
2046 if (wpath
[0] != _T('\\') ||
2047 (_tcslen (wpath
) > 2 && wpath
[0] == _T('\\')
2048 && wpath
[1] != _T('\\')))
2049 return GetDriveType (NULL
);
2051 UINT result
= GetDriveType (wpath
);
2053 /* Cannot guess the drive type, is this \\.\ ? */
2055 if (result
== DRIVE_NO_ROOT_DIR
&&
2056 _tcslen (wpath
) >= 4 && wpath
[0] == _T('\\') && wpath
[1] == _T('\\')
2057 && wpath
[2] == _T('.') && wpath
[3] == _T('\\'))
2059 if (_tcslen (wpath
) == 4)
2060 _tcscat (wpath
, wfilename
);
2062 LPTSTR p
= &wpath
[4];
2063 LPTSTR b
= _tcschr (p
, _T('\\'));
2067 /* logical drive \\.\c\dir\file */
2073 _tcscat (p
, _T(":\\"));
2075 return GetDriveType (p
);
2082 /* This MingW section contains code to work with ACL. */
2084 __gnat_check_OWNER_ACL (TCHAR
*wname
,
2085 DWORD CheckAccessDesired
,
2086 GENERIC_MAPPING CheckGenericMapping
)
2088 DWORD dwAccessDesired
, dwAccessAllowed
;
2089 PRIVILEGE_SET PrivilegeSet
;
2090 DWORD dwPrivSetSize
= sizeof (PRIVILEGE_SET
);
2091 BOOL fAccessGranted
= FALSE
;
2092 HANDLE hToken
= NULL
;
2094 SECURITY_DESCRIPTOR
* pSD
= NULL
;
2097 (wname
, OWNER_SECURITY_INFORMATION
|
2098 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
2101 if ((pSD
= (SECURITY_DESCRIPTOR
*) HeapAlloc
2102 (GetProcessHeap (), HEAP_ZERO_MEMORY
, nLength
)) == NULL
)
2105 /* Obtain the security descriptor. */
2107 if (!GetFileSecurity
2108 (wname
, OWNER_SECURITY_INFORMATION
|
2109 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
2110 pSD
, nLength
, &nLength
))
2113 if (!ImpersonateSelf (SecurityImpersonation
))
2116 if (!OpenThreadToken
2117 (GetCurrentThread(), TOKEN_DUPLICATE
| TOKEN_QUERY
, FALSE
, &hToken
))
2120 /* Undoes the effect of ImpersonateSelf. */
2124 /* We want to test for write permissions. */
2126 dwAccessDesired
= CheckAccessDesired
;
2128 MapGenericMask (&dwAccessDesired
, &CheckGenericMapping
);
2131 (pSD
, /* security descriptor to check */
2132 hToken
, /* impersonation token */
2133 dwAccessDesired
, /* requested access rights */
2134 &CheckGenericMapping
, /* pointer to GENERIC_MAPPING */
2135 &PrivilegeSet
, /* receives privileges used in check */
2136 &dwPrivSetSize
, /* size of PrivilegeSet buffer */
2137 &dwAccessAllowed
, /* receives mask of allowed access rights */
2141 CloseHandle (hToken
);
2142 HeapFree (GetProcessHeap (), 0, pSD
);
2143 return fAccessGranted
;
2147 CloseHandle (hToken
);
2148 HeapFree (GetProcessHeap (), 0, pSD
);
2153 __gnat_set_OWNER_ACL (TCHAR
*wname
,
2155 DWORD AccessPermissions
)
2157 PACL pOldDACL
= NULL
;
2158 PACL pNewDACL
= NULL
;
2159 PSECURITY_DESCRIPTOR pSD
= NULL
;
2161 TCHAR username
[100];
2164 /* Get current user, he will act as the owner */
2166 if (!GetUserName (username
, &unsize
))
2169 if (GetNamedSecurityInfo
2172 DACL_SECURITY_INFORMATION
,
2173 NULL
, NULL
, &pOldDACL
, NULL
, &pSD
) != ERROR_SUCCESS
)
2176 BuildExplicitAccessWithName
2177 (&ea
, username
, AccessPermissions
, (ACCESS_MODE
) AccessMode
, NO_INHERITANCE
);
2179 if (AccessMode
== SET_ACCESS
)
2181 /* SET_ACCESS, we want to set an explicte set of permissions, do not
2182 merge with current DACL. */
2183 if (SetEntriesInAcl (1, &ea
, NULL
, &pNewDACL
) != ERROR_SUCCESS
)
2187 if (SetEntriesInAcl (1, &ea
, pOldDACL
, &pNewDACL
) != ERROR_SUCCESS
)
2190 if (SetNamedSecurityInfo
2191 (wname
, SE_FILE_OBJECT
,
2192 DACL_SECURITY_INFORMATION
, NULL
, NULL
, pNewDACL
, NULL
) != ERROR_SUCCESS
)
2196 LocalFree (pNewDACL
);
2199 /* Check if it is possible to use ACL for wname, the file must not be on a
2203 __gnat_can_use_acl (TCHAR
*wname
)
2205 return __gnat_use_acl
&& GetDriveTypeFromPath (wname
) != DRIVE_REMOTE
;
2208 #endif /* defined (_WIN32) && !defined (RTX) */
2211 __gnat_is_readable_file_attr (char* name
, struct file_attributes
* attr
)
2213 if (attr
->readable
== ATTR_UNSET
)
2215 #if defined (_WIN32) && !defined (RTX)
2216 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2217 GENERIC_MAPPING GenericMapping
;
2219 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2221 if (__gnat_can_use_acl (wname
))
2223 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2224 GenericMapping
.GenericRead
= GENERIC_READ
;
2226 __gnat_check_OWNER_ACL (wname
, FILE_READ_DATA
, GenericMapping
);
2229 attr
->readable
= GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
;
2231 __gnat_stat_to_attr (-1, name
, attr
);
2235 return attr
->readable
;
2239 __gnat_is_readable_file (char *name
)
2241 struct file_attributes attr
;
2243 __gnat_reset_attributes (&attr
);
2244 return __gnat_is_readable_file_attr (name
, &attr
);
2248 __gnat_is_writable_file_attr (char* name
, struct file_attributes
* attr
)
2250 if (attr
->writable
== ATTR_UNSET
)
2252 #if defined (_WIN32) && !defined (RTX)
2253 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2254 GENERIC_MAPPING GenericMapping
;
2256 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2258 if (__gnat_can_use_acl (wname
))
2260 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2261 GenericMapping
.GenericWrite
= GENERIC_WRITE
;
2263 attr
->writable
= __gnat_check_OWNER_ACL
2264 (wname
, FILE_WRITE_DATA
| FILE_APPEND_DATA
, GenericMapping
)
2265 && !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2269 !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2272 __gnat_stat_to_attr (-1, name
, attr
);
2276 return attr
->writable
;
2280 __gnat_is_writable_file (char *name
)
2282 struct file_attributes attr
;
2284 __gnat_reset_attributes (&attr
);
2285 return __gnat_is_writable_file_attr (name
, &attr
);
2289 __gnat_is_executable_file_attr (char* name
, struct file_attributes
* attr
)
2291 if (attr
->executable
== ATTR_UNSET
)
2293 #if defined (_WIN32) && !defined (RTX)
2294 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2295 GENERIC_MAPPING GenericMapping
;
2297 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2299 if (__gnat_can_use_acl (wname
))
2301 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2302 GenericMapping
.GenericExecute
= GENERIC_EXECUTE
;
2305 __gnat_check_OWNER_ACL (wname
, FILE_EXECUTE
, GenericMapping
);
2309 TCHAR
*l
, *last
= _tcsstr(wname
, _T(".exe"));
2311 /* look for last .exe */
2313 while ((l
= _tcsstr(last
+1, _T(".exe"))))
2317 GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
2318 && (last
- wname
) == (int) (_tcslen (wname
) - 4);
2321 __gnat_stat_to_attr (-1, name
, attr
);
2325 return attr
->regular
&& attr
->executable
;
2329 __gnat_is_executable_file (char *name
)
2331 struct file_attributes attr
;
2333 __gnat_reset_attributes (&attr
);
2334 return __gnat_is_executable_file_attr (name
, &attr
);
2338 __gnat_set_writable (char *name
)
2340 #if defined (_WIN32) && !defined (RTX)
2341 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2343 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2345 if (__gnat_can_use_acl (wname
))
2346 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_WRITE
);
2349 (wname
, GetFileAttributes (wname
) & ~FILE_ATTRIBUTE_READONLY
);
2350 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2351 ! defined(__nucleus__)
2352 GNAT_STRUCT_STAT statbuf
;
2354 if (GNAT_STAT (name
, &statbuf
) == 0)
2356 statbuf
.st_mode
= statbuf
.st_mode
| S_IWUSR
;
2357 chmod (name
, statbuf
.st_mode
);
2362 /* must match definition in s-os_lib.ads */
2368 __gnat_set_executable (char *name
, int mode
)
2370 #if defined (_WIN32) && !defined (RTX)
2371 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2373 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2375 if (__gnat_can_use_acl (wname
))
2376 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_EXECUTE
);
2378 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2379 ! defined(__nucleus__)
2380 GNAT_STRUCT_STAT statbuf
;
2382 if (GNAT_STAT (name
, &statbuf
) == 0)
2385 statbuf
.st_mode
= statbuf
.st_mode
| S_IXUSR
;
2387 statbuf
.st_mode
= statbuf
.st_mode
| S_IXGRP
;
2388 if (mode
& S_OTHERS
)
2389 statbuf
.st_mode
= statbuf
.st_mode
| S_IXOTH
;
2390 chmod (name
, statbuf
.st_mode
);
2396 __gnat_set_non_writable (char *name
)
2398 #if defined (_WIN32) && !defined (RTX)
2399 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2401 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2403 if (__gnat_can_use_acl (wname
))
2404 __gnat_set_OWNER_ACL
2405 (wname
, DENY_ACCESS
,
2406 FILE_WRITE_DATA
| FILE_APPEND_DATA
|
2407 FILE_WRITE_EA
| FILE_WRITE_ATTRIBUTES
);
2410 (wname
, GetFileAttributes (wname
) | FILE_ATTRIBUTE_READONLY
);
2411 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2412 ! defined(__nucleus__)
2413 GNAT_STRUCT_STAT statbuf
;
2415 if (GNAT_STAT (name
, &statbuf
) == 0)
2417 statbuf
.st_mode
= statbuf
.st_mode
& 07577;
2418 chmod (name
, statbuf
.st_mode
);
2424 __gnat_set_readable (char *name
)
2426 #if defined (_WIN32) && !defined (RTX)
2427 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2429 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2431 if (__gnat_can_use_acl (wname
))
2432 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_READ
);
2434 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2435 ! defined(__nucleus__)
2436 GNAT_STRUCT_STAT statbuf
;
2438 if (GNAT_STAT (name
, &statbuf
) == 0)
2440 chmod (name
, statbuf
.st_mode
| S_IREAD
);
2446 __gnat_set_non_readable (char *name
)
2448 #if defined (_WIN32) && !defined (RTX)
2449 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2451 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2453 if (__gnat_can_use_acl (wname
))
2454 __gnat_set_OWNER_ACL (wname
, DENY_ACCESS
, FILE_GENERIC_READ
);
2456 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2457 ! defined(__nucleus__)
2458 GNAT_STRUCT_STAT statbuf
;
2460 if (GNAT_STAT (name
, &statbuf
) == 0)
2462 chmod (name
, statbuf
.st_mode
& (~S_IREAD
));
2468 __gnat_is_symbolic_link_attr (char* name ATTRIBUTE_UNUSED
,
2469 struct file_attributes
* attr
)
2471 if (attr
->symbolic_link
== ATTR_UNSET
)
2473 #if defined (__vxworks) || defined (__nucleus__)
2474 attr
->symbolic_link
= 0;
2476 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
2478 GNAT_STRUCT_STAT statbuf
;
2479 ret
= GNAT_LSTAT (name
, &statbuf
);
2480 attr
->symbolic_link
= (!ret
&& S_ISLNK (statbuf
.st_mode
));
2482 attr
->symbolic_link
= 0;
2485 return attr
->symbolic_link
;
2489 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED
)
2491 struct file_attributes attr
;
2493 __gnat_reset_attributes (&attr
);
2494 return __gnat_is_symbolic_link_attr (name
, &attr
);
2497 #if defined (sun) && defined (__SVR4)
2498 /* Using fork on Solaris will duplicate all the threads. fork1, which
2499 duplicates only the active thread, must be used instead, or spawning
2500 subprocess from a program with tasking will lead into numerous problems. */
2505 __gnat_portable_spawn (char *args
[] ATTRIBUTE_UNUSED
)
2507 int status ATTRIBUTE_UNUSED
= 0;
2508 int finished ATTRIBUTE_UNUSED
;
2509 int pid ATTRIBUTE_UNUSED
;
2511 #if defined (__vxworks) || defined(__nucleus__) || defined(RTX) \
2512 || defined(__PikeOS__)
2515 #elif defined (_WIN32)
2516 /* args[0] must be quotes as it could contain a full pathname with spaces */
2517 char *args_0
= args
[0];
2518 args
[0] = (char *)xmalloc (strlen (args_0
) + 3);
2519 strcpy (args
[0], "\"");
2520 strcat (args
[0], args_0
);
2521 strcat (args
[0], "\"");
2523 status
= spawnvp (P_WAIT
, args_0
, (char* const*)args
);
2525 /* restore previous value */
2527 args
[0] = (char *)args_0
;
2543 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2545 return -1; /* execv is in parent context on VMS. */
2552 finished
= waitpid (pid
, &status
, 0);
2554 if (finished
!= pid
|| WIFEXITED (status
) == 0)
2557 return WEXITSTATUS (status
);
2563 /* Create a copy of the given file descriptor.
2564 Return -1 if an error occurred. */
2567 __gnat_dup (int oldfd
)
2569 #if defined (__vxworks) && !defined (__RTP__)
2570 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2578 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
2579 Return -1 if an error occurred. */
2582 __gnat_dup2 (int oldfd ATTRIBUTE_UNUSED
, int newfd ATTRIBUTE_UNUSED
)
2584 #if defined (__vxworks) && !defined (__RTP__)
2585 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2588 #elif defined (__PikeOS__)
2589 /* Not supported. */
2591 #elif defined (_WIN32)
2592 /* Special case when oldfd and newfd are identical and are the standard
2593 input, output or error as this makes Windows XP hangs. Note that we
2594 do that only for standard file descriptors that are known to be valid. */
2595 if (oldfd
== newfd
&& newfd
>= 0 && newfd
<= 2)
2598 return dup2 (oldfd
, newfd
);
2600 return dup2 (oldfd
, newfd
);
2605 __gnat_number_of_cpus (void)
2609 #if defined (linux) || defined (sun) || defined (AIX) || defined (__APPLE__)
2610 cores
= (int) sysconf (_SC_NPROCESSORS_ONLN
);
2612 #elif defined (__hpux__)
2613 struct pst_dynamic psd
;
2614 if (pstat_getdynamic (&psd
, sizeof (psd
), 1, 0) != -1)
2615 cores
= (int) psd
.psd_proc_cnt
;
2617 #elif defined (_WIN32)
2618 SYSTEM_INFO sysinfo
;
2619 GetSystemInfo (&sysinfo
);
2620 cores
= (int) sysinfo
.dwNumberOfProcessors
;
2623 int code
= SYI$_ACTIVECPU_CNT
;
2627 status
= LIB$
GETSYI (&code
, &res
);
2628 if ((status
& 1) != 0)
2631 #elif defined (_WRS_CONFIG_SMP)
2632 unsigned int vxCpuConfiguredGet (void);
2634 cores
= vxCpuConfiguredGet ();
2641 /* WIN32 code to implement a wait call that wait for any child process. */
2643 #if defined (_WIN32) && !defined (RTX)
2645 /* Synchronization code, to be thread safe. */
2649 /* For the Cert run times on native Windows we use dummy functions
2650 for locking and unlocking tasks since we do not support multiple
2651 threads on this configuration (Cert run time on native Windows). */
2653 static void dummy (void)
2657 void (*Lock_Task
) () = &dummy
;
2658 void (*Unlock_Task
) () = &dummy
;
2662 #define Lock_Task system__soft_links__lock_task
2663 extern void (*Lock_Task
) (void);
2665 #define Unlock_Task system__soft_links__unlock_task
2666 extern void (*Unlock_Task
) (void);
2670 static HANDLE
*HANDLES_LIST
= NULL
;
2671 static int *PID_LIST
= NULL
, plist_length
= 0, plist_max_length
= 0;
2674 add_handle (HANDLE h
, int pid
)
2677 /* -------------------- critical section -------------------- */
2680 if (plist_length
== plist_max_length
)
2682 plist_max_length
+= 1000;
2684 (void **) xrealloc (HANDLES_LIST
, sizeof (HANDLE
) * plist_max_length
);
2686 (int *) xrealloc (PID_LIST
, sizeof (int) * plist_max_length
);
2689 HANDLES_LIST
[plist_length
] = h
;
2690 PID_LIST
[plist_length
] = pid
;
2694 /* -------------------- critical section -------------------- */
2698 __gnat_win32_remove_handle (HANDLE h
, int pid
)
2702 /* -------------------- critical section -------------------- */
2705 for (j
= 0; j
< plist_length
; j
++)
2707 if ((HANDLES_LIST
[j
] == h
) || (PID_LIST
[j
] == pid
))
2711 HANDLES_LIST
[j
] = HANDLES_LIST
[plist_length
];
2712 PID_LIST
[j
] = PID_LIST
[plist_length
];
2718 /* -------------------- critical section -------------------- */
2722 win32_no_block_spawn (char *command
, char *args
[], HANDLE
*h
, int *pid
)
2726 PROCESS_INFORMATION PI
;
2727 SECURITY_ATTRIBUTES SA
;
2732 /* compute the total command line length */
2736 csize
+= strlen (args
[k
]) + 1;
2740 full_command
= (char *) xmalloc (csize
);
2743 SI
.cb
= sizeof (STARTUPINFO
);
2744 SI
.lpReserved
= NULL
;
2745 SI
.lpReserved2
= NULL
;
2746 SI
.lpDesktop
= NULL
;
2750 SI
.wShowWindow
= SW_HIDE
;
2752 /* Security attributes. */
2753 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
2754 SA
.bInheritHandle
= TRUE
;
2755 SA
.lpSecurityDescriptor
= NULL
;
2757 /* Prepare the command string. */
2758 strcpy (full_command
, command
);
2759 strcat (full_command
, " ");
2764 strcat (full_command
, args
[k
]);
2765 strcat (full_command
, " ");
2770 int wsize
= csize
* 2;
2771 TCHAR
*wcommand
= (TCHAR
*) xmalloc (wsize
);
2773 S2WSC (wcommand
, full_command
, wsize
);
2775 free (full_command
);
2777 result
= CreateProcess
2778 (NULL
, wcommand
, &SA
, NULL
, TRUE
,
2779 GetPriorityClass (GetCurrentProcess()), NULL
, NULL
, &SI
, &PI
);
2786 CloseHandle (PI
.hThread
);
2788 *pid
= PI
.dwProcessId
;
2798 win32_wait (int *status
)
2800 DWORD exitcode
, pid
;
2807 if (plist_length
== 0)
2815 /* -------------------- critical section -------------------- */
2818 hl_len
= plist_length
;
2820 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * hl_len
);
2822 memmove (hl
, HANDLES_LIST
, sizeof (HANDLE
) * hl_len
);
2825 /* -------------------- critical section -------------------- */
2827 res
= WaitForMultipleObjects (hl_len
, hl
, FALSE
, INFINITE
);
2828 h
= hl
[res
- WAIT_OBJECT_0
];
2830 GetExitCodeProcess (h
, &exitcode
);
2831 pid
= PID_LIST
[res
- WAIT_OBJECT_0
];
2832 __gnat_win32_remove_handle (h
, -1);
2836 *status
= (int) exitcode
;
2843 __gnat_portable_no_block_spawn (char *args
[] ATTRIBUTE_UNUSED
)
2846 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX) \
2847 || defined (__PikeOS__)
2848 /* Not supported. */
2851 #elif defined (_WIN32)
2856 win32_no_block_spawn (args
[0], args
, &h
, &pid
);
2859 add_handle (h
, pid
);
2872 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2874 return -1; /* execv is in parent context on VMS. */
2886 __gnat_portable_wait (int *process_status
)
2891 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX) \
2892 || defined (__PikeOS__)
2893 /* Not sure what to do here, so do nothing but return zero. */
2895 #elif defined (_WIN32)
2897 pid
= win32_wait (&status
);
2901 pid
= waitpid (-1, &status
, 0);
2902 status
= status
& 0xffff;
2905 *process_status
= status
;
2910 __gnat_os_exit (int status
)
2915 /* Locate file on path, that matches a predicate */
2918 __gnat_locate_file_with_predicate (char *file_name
, char *path_val
,
2919 int (*predicate
)(char *))
2922 char *file_path
= (char *) alloca (strlen (file_name
) + 1);
2925 /* Return immediately if file_name is empty */
2927 if (*file_name
== '\0')
2930 /* Remove quotes around file_name if present */
2936 strcpy (file_path
, ptr
);
2938 ptr
= file_path
+ strlen (file_path
) - 1;
2943 /* Handle absolute pathnames. */
2945 absolute
= __gnat_is_absolute_path (file_path
, strlen (file_name
));
2949 if (predicate (file_path
))
2950 return xstrdup (file_path
);
2955 /* If file_name include directory separator(s), try it first as
2956 a path name relative to the current directory */
2957 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
2962 if (predicate (file_name
))
2963 return xstrdup (file_name
);
2970 /* The result has to be smaller than path_val + file_name. */
2972 (char *) alloca (strlen (path_val
) + strlen (file_name
) + 2);
2976 /* Skip the starting quote */
2978 if (*path_val
== '"')
2981 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
2982 *ptr
++ = *path_val
++;
2984 /* If directory is empty, it is the current directory*/
2986 if (ptr
== file_path
)
2993 /* Skip the ending quote */
2998 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
2999 *++ptr
= DIR_SEPARATOR
;
3001 strcpy (++ptr
, file_name
);
3003 if (predicate (file_path
))
3004 return xstrdup (file_path
);
3009 /* Skip path separator */
3018 /* Locate an executable file, give a Path value. */
3021 __gnat_locate_executable_file (char *file_name
, char *path_val
)
3023 return __gnat_locate_file_with_predicate
3024 (file_name
, path_val
, &__gnat_is_executable_file
);
3027 /* Locate a regular file, give a Path value. */
3030 __gnat_locate_regular_file (char *file_name
, char *path_val
)
3032 return __gnat_locate_file_with_predicate
3033 (file_name
, path_val
, &__gnat_is_regular_file
);
3036 /* Locate an executable given a Path argument. This routine is only used by
3037 gnatbl and should not be used otherwise. Use locate_exec_on_path
3041 __gnat_locate_exec (char *exec_name
, char *path_val
)
3044 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
3046 char *full_exec_name
=
3048 (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
3050 strcpy (full_exec_name
, exec_name
);
3051 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
3052 ptr
= __gnat_locate_executable_file (full_exec_name
, path_val
);
3055 return __gnat_locate_executable_file (exec_name
, path_val
);
3059 return __gnat_locate_executable_file (exec_name
, path_val
);
3062 /* Locate an executable using the Systems default PATH. */
3065 __gnat_locate_exec_on_path (char *exec_name
)
3069 #if defined (_WIN32) && !defined (RTX)
3070 TCHAR
*wpath_val
= _tgetenv (_T("PATH"));
3072 /* In Win32 systems we expand the PATH as for XP environment
3073 variables are not automatically expanded. We also prepend the
3074 ".;" to the path to match normal NT path search semantics */
3076 #define EXPAND_BUFFER_SIZE 32767
3078 wapath_val
= (TCHAR
*) alloca (EXPAND_BUFFER_SIZE
);
3080 wapath_val
[0] = '.';
3081 wapath_val
[1] = ';';
3083 DWORD res
= ExpandEnvironmentStrings
3084 (wpath_val
, &wapath_val
[2], EXPAND_BUFFER_SIZE
- 2);
3086 if (!res
) wapath_val
[0] = _T('\0');
3088 apath_val
= (char *) alloca (EXPAND_BUFFER_SIZE
);
3090 WS2SC (apath_val
, wapath_val
, EXPAND_BUFFER_SIZE
);
3091 return __gnat_locate_exec (exec_name
, apath_val
);
3096 char *path_val
= "/VAXC$PATH";
3098 char *path_val
= getenv ("PATH");
3100 if (path_val
== NULL
) return NULL
;
3101 apath_val
= (char *) alloca (strlen (path_val
) + 1);
3102 strcpy (apath_val
, path_val
);
3103 return __gnat_locate_exec (exec_name
, apath_val
);
3109 /* These functions are used to translate to and from VMS and Unix syntax
3110 file, directory and path specifications. */
3113 #define MAXNAMES 256
3114 #define NEW_CANONICAL_FILELIST_INCREMENT 64
3116 static char new_canonical_dirspec
[MAXPATH
];
3117 static char new_canonical_filespec
[MAXPATH
];
3118 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
3119 static unsigned new_canonical_filelist_index
;
3120 static unsigned new_canonical_filelist_in_use
;
3121 static unsigned new_canonical_filelist_allocated
;
3122 static char **new_canonical_filelist
;
3123 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
3124 static char new_host_dirspec
[MAXPATH
];
3125 static char new_host_filespec
[MAXPATH
];
3127 /* Routine is called repeatedly by decc$from_vms via
3128 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
3132 wildcard_translate_unix (char *name
)
3135 char buff
[MAXPATH
];
3137 strncpy (buff
, name
, MAXPATH
);
3138 buff
[MAXPATH
- 1] = (char) 0;
3139 ver
= strrchr (buff
, '.');
3141 /* Chop off the version. */
3145 /* Dynamically extend the allocation by the increment. */
3146 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
3148 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
3149 new_canonical_filelist
= (char **) xrealloc
3150 (new_canonical_filelist
,
3151 new_canonical_filelist_allocated
* sizeof (char *));
3154 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
3159 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
3160 full translation and copy the results into a list (_init), then return them
3161 one at a time (_next). If onlydirs set, only expand directory files. */
3164 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
3167 char buff
[MAXPATH
];
3169 len
= strlen (filespec
);
3170 strncpy (buff
, filespec
, MAXPATH
);
3172 /* Only look for directories */
3173 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
3174 strncat (buff
, "*.dir", MAXPATH
);
3176 buff
[MAXPATH
- 1] = (char) 0;
3178 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
3180 /* Remove the .dir extension. */
3186 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3188 ext
= strstr (new_canonical_filelist
[i
], ".dir");
3194 return new_canonical_filelist_in_use
;
3197 /* Return the next filespec in the list. */
3200 __gnat_to_canonical_file_list_next (void)
3202 return new_canonical_filelist
[new_canonical_filelist_index
++];
3205 /* Free storage used in the wildcard expansion. */
3208 __gnat_to_canonical_file_list_free (void)
3212 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3213 free (new_canonical_filelist
[i
]);
3215 free (new_canonical_filelist
);
3217 new_canonical_filelist_in_use
= 0;
3218 new_canonical_filelist_allocated
= 0;
3219 new_canonical_filelist_index
= 0;
3220 new_canonical_filelist
= 0;
3223 /* The functional equivalent of decc$translate_vms routine.
3224 Designed to produce the same output, but is protected against
3225 malformed paths (original version ACCVIOs in this case) and
3226 does not require VMS-specific DECC RTL. */
3228 #define NAM$C_MAXRSS 1024
3231 __gnat_translate_vms (char *src
)
3233 static char retbuf
[NAM$C_MAXRSS
+ 1];
3234 char *srcendpos
, *pos1
, *pos2
, *retpos
;
3235 int disp
, path_present
= 0;
3240 srcendpos
= strchr (src
, '\0');
3243 /* Look for the node and/or device in front of the path. */
3245 pos2
= strchr (pos1
, ':');
3247 if (pos2
&& (pos2
< srcendpos
) && (*(pos2
+ 1) == ':'))
3249 /* There is a node name. "node_name::" becomes "node_name!". */
3251 strncpy (retbuf
, pos1
, disp
);
3252 retpos
[disp
] = '!';
3253 retpos
= retpos
+ disp
+ 1;
3255 pos2
= strchr (pos1
, ':');
3260 /* There is a device name. "dev_name:" becomes "/dev_name/". */
3263 strncpy (retpos
, pos1
, disp
);
3264 retpos
= retpos
+ disp
;
3269 /* No explicit device; we must look ahead and prepend /sys$disk/ if
3270 the path is absolute. */
3271 if ((*pos1
== '[' || *pos1
== '<') && (pos1
< srcendpos
)
3272 && !strchr (".-]>", *(pos1
+ 1)))
3274 strncpy (retpos
, "/sys$disk/", 10);
3278 /* Process the path part. */
3279 while (*pos1
== '[' || *pos1
== '<')
3283 if (*pos1
== ']' || *pos1
== '>')
3285 /* Special case, [] translates to '.'. */
3291 /* '[000000' means root dir. It can be present in the middle of
3292 the path due to expansion of logical devices, in which case
3294 if (!strncmp (pos1
, "000000", 6) && path_present
> 1 &&
3295 (*(pos1
+ 6) == ']' || *(pos1
+ 6) == '>' || *(pos1
+ 6) == '.'))
3298 if (*pos1
== '.') pos1
++;
3300 else if (*pos1
== '.')
3302 /* Relative path. */
3306 /* There is a qualified path. */
3307 while (*pos1
&& *pos1
!= ']' && *pos1
!= '>')
3312 /* '.' is used to separate directories. Replace it with '/'
3313 but only if there isn't already '/' just before. */
3314 if (*(retpos
- 1) != '/')
3317 if (pos1
+ 1 < srcendpos
3319 && *(pos1
+ 1) == '.')
3321 /* Ellipsis refers to entire subtree; replace
3330 /* When after '.' '[' '<' is equivalent to Unix ".." but
3331 there may be several in a row. */
3332 if (*(pos1
- 1) == '.' || *(pos1
- 1) == '[' ||
3335 while (*pos1
== '-')
3345 /* Otherwise fall through to default. */
3347 *(retpos
++) = *(pos1
++);
3354 if (pos1
< srcendpos
)
3356 /* Now add the actual file name, until the version suffix if any */
3359 pos2
= strchr (pos1
, ';');
3360 disp
= pos2
? (pos2
- pos1
) : (srcendpos
- pos1
);
3361 strncpy (retpos
, pos1
, disp
);
3363 if (pos2
&& pos2
< srcendpos
)
3365 /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
3367 disp
= srcendpos
- pos2
- 1;
3368 strncpy (retpos
, pos2
+ 1, disp
);
3378 /* Translate a VMS syntax directory specification in to Unix syntax. If
3379 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
3380 found, return input string. Also translate a dirname that contains no
3381 slashes, in case it's a logical name. */
3384 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
3388 strcpy (new_canonical_dirspec
, "");
3389 if (strlen (dirspec
))
3393 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
3395 strncpy (new_canonical_dirspec
,
3396 __gnat_translate_vms (dirspec
),
3399 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
3401 strncpy (new_canonical_dirspec
,
3402 __gnat_translate_vms (dirspec1
),
3407 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
3411 len
= strlen (new_canonical_dirspec
);
3412 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
3413 strncat (new_canonical_dirspec
, "/", MAXPATH
);
3415 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
3417 return new_canonical_dirspec
;
3421 /* Translate a VMS syntax file specification into Unix syntax.
3422 If no indicators of VMS syntax found, check if it's an uppercase
3423 alphanumeric_ name and if so try it out as an environment
3424 variable (logical name). If all else fails return the
3428 __gnat_to_canonical_file_spec (char *filespec
)
3432 strncpy (new_canonical_filespec
, "", MAXPATH
);
3434 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3436 char *tspec
= (char *) __gnat_translate_vms (filespec
);
3438 if (tspec
!= (char *) -1)
3439 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3441 else if ((strlen (filespec
) == strspn (filespec
,
3442 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
3443 && (filespec1
= getenv (filespec
)))
3445 char *tspec
= (char *) __gnat_translate_vms (filespec1
);
3447 if (tspec
!= (char *) -1)
3448 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3452 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
3455 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
3457 return new_canonical_filespec
;
3460 /* Translate a VMS syntax path specification into Unix syntax.
3461 If no indicators of VMS syntax found, return input string. */
3464 __gnat_to_canonical_path_spec (char *pathspec
)
3466 char *curr
, *next
, buff
[MAXPATH
];
3471 /* If there are /'s, assume it's a Unix path spec and return. */
3472 if (strchr (pathspec
, '/'))
3475 new_canonical_pathspec
[0] = 0;
3480 next
= strchr (curr
, ',');
3482 next
= strchr (curr
, 0);
3484 strncpy (buff
, curr
, next
- curr
);
3485 buff
[next
- curr
] = 0;
3487 /* Check for wildcards and expand if present. */
3488 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
3492 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
3493 for (i
= 0; i
< dirs
; i
++)
3497 next_dir
= __gnat_to_canonical_file_list_next ();
3498 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
3500 /* Don't append the separator after the last expansion. */
3502 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3505 __gnat_to_canonical_file_list_free ();
3508 strncat (new_canonical_pathspec
,
3509 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
3514 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3518 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
3520 return new_canonical_pathspec
;
3523 static char filename_buff
[MAXPATH
];
3526 translate_unix (char *name
, int type ATTRIBUTE_UNUSED
)
3528 strncpy (filename_buff
, name
, MAXPATH
);
3529 filename_buff
[MAXPATH
- 1] = (char) 0;
3533 /* Translate a Unix syntax directory specification into VMS syntax. The
3534 PREFIXFLAG has no effect, but is kept for symmetry with
3535 to_canonical_dir_spec. If indicators of VMS syntax found, return input
3539 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3541 int len
= strlen (dirspec
);
3543 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
3544 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3546 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
3547 return new_host_dirspec
;
3549 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
3551 new_host_dirspec
[len
- 1] = 0;
3555 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
3556 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
3557 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3559 return new_host_dirspec
;
3562 /* Translate a Unix syntax file specification into VMS syntax.
3563 If indicators of VMS syntax found, return input string. */
3566 __gnat_to_host_file_spec (char *filespec
)
3568 strncpy (new_host_filespec
, "", MAXPATH
);
3569 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3571 strncpy (new_host_filespec
, filespec
, MAXPATH
);
3575 decc$
to_vms (filespec
, translate_unix
, 1, 1);
3576 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
3579 new_host_filespec
[MAXPATH
- 1] = (char) 0;
3581 return new_host_filespec
;
3585 __gnat_adjust_os_resource_limits (void)
3587 SYS$
ADJWSL (131072, 0);
3592 /* Dummy functions for Osint import for non-VMS systems. */
3595 __gnat_to_canonical_file_list_init (char *dirspec ATTRIBUTE_UNUSED
,
3596 int onlydirs ATTRIBUTE_UNUSED
)
3602 __gnat_to_canonical_file_list_next (void)
3604 static char empty
[] = "";
3609 __gnat_to_canonical_file_list_free (void)
3614 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3620 __gnat_to_canonical_file_spec (char *filespec
)
3626 __gnat_to_canonical_path_spec (char *pathspec
)
3632 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3638 __gnat_to_host_file_spec (char *filespec
)
3644 __gnat_adjust_os_resource_limits (void)
3650 #if defined (__mips_vxworks)
3654 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
3658 #if defined (IS_CROSS) \
3659 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3660 && defined (__SVR4)) \
3661 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3662 && ! (defined (linux) && defined (__ia64__)) \
3663 && ! (defined (linux) && defined (powerpc)) \
3664 && ! defined (__FreeBSD__) \
3665 && ! defined (__Lynx__) \
3666 && ! defined (__hpux__) \
3667 && ! defined (__APPLE__) \
3668 && ! defined (_AIX) \
3669 && ! defined (VMS) \
3670 && ! defined (__MINGW32__))
3672 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3673 just above for a list of native platforms that provide a non-dummy
3674 version of this procedure in libaddr2line.a. */
3677 convert_addresses (const char *file_name ATTRIBUTE_UNUSED
,
3678 void *addrs ATTRIBUTE_UNUSED
,
3679 int n_addr ATTRIBUTE_UNUSED
,
3680 void *buf ATTRIBUTE_UNUSED
,
3681 int *len ATTRIBUTE_UNUSED
)
3687 #if defined (_WIN32)
3688 int __gnat_argument_needs_quote
= 1;
3690 int __gnat_argument_needs_quote
= 0;
3693 /* This option is used to enable/disable object files handling from the
3694 binder file by the GNAT Project module. For example, this is disabled on
3695 Windows (prior to GCC 3.4) as it is already done by the mdll module.
3696 Stating with GCC 3.4 the shared libraries are not based on mdll
3697 anymore as it uses the GCC's -shared option */
3698 #if defined (_WIN32) \
3699 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3700 int __gnat_prj_add_obj_files
= 0;
3702 int __gnat_prj_add_obj_files
= 1;
3705 /* char used as prefix/suffix for environment variables */
3706 #if defined (_WIN32)
3707 char __gnat_environment_char
= '%';
3709 char __gnat_environment_char
= '$';
3712 /* This functions copy the file attributes from a source file to a
3715 mode = 0 : In this mode copy only the file time stamps (last access and
3716 last modification time stamps).
3718 mode = 1 : In this mode, time stamps and read/write/execute attributes are
3721 Returns 0 if operation was successful and -1 in case of error. */
3724 __gnat_copy_attribs (char *from ATTRIBUTE_UNUSED
, char *to ATTRIBUTE_UNUSED
,
3725 int mode ATTRIBUTE_UNUSED
)
3727 #if defined (VMS) || (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \
3728 defined (__nucleus__)
3731 #elif defined (_WIN32) && !defined (RTX)
3732 TCHAR wfrom
[GNAT_MAX_PATH_LEN
+ 2];
3733 TCHAR wto
[GNAT_MAX_PATH_LEN
+ 2];
3735 FILETIME fct
, flat
, flwt
;
3738 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
+ 2);
3739 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
+ 2);
3741 /* retrieve from times */
3744 (wfrom
, GENERIC_READ
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3746 if (hfrom
== INVALID_HANDLE_VALUE
)
3749 res
= GetFileTime (hfrom
, &fct
, &flat
, &flwt
);
3751 CloseHandle (hfrom
);
3756 /* retrieve from times */
3759 (wto
, GENERIC_WRITE
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3761 if (hto
== INVALID_HANDLE_VALUE
)
3764 res
= SetFileTime (hto
, NULL
, &flat
, &flwt
);
3771 /* Set file attributes in full mode. */
3775 DWORD attribs
= GetFileAttributes (wfrom
);
3777 if (attribs
== INVALID_FILE_ATTRIBUTES
)
3780 res
= SetFileAttributes (wto
, attribs
);
3788 GNAT_STRUCT_STAT fbuf
;
3789 struct utimbuf tbuf
;
3791 if (GNAT_STAT (from
, &fbuf
) == -1)
3796 tbuf
.actime
= fbuf
.st_atime
;
3797 tbuf
.modtime
= fbuf
.st_mtime
;
3799 if (utime (to
, &tbuf
) == -1)
3806 if (chmod (to
, fbuf
.st_mode
) == -1)
3817 __gnat_lseek (int fd
, long offset
, int whence
)
3819 return (int) lseek (fd
, offset
, whence
);
3822 /* This function returns the major version number of GCC being used. */
3824 get_gcc_version (void)
3829 return (int) (version_string
[0] - '0');
3834 * Set Close_On_Exec as indicated.
3835 * Note: this is used for both GNAT.OS_Lib and GNAT.Sockets.
3839 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED
,
3840 int close_on_exec_p ATTRIBUTE_UNUSED
)
3842 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3843 int flags
= fcntl (fd
, F_GETFD
, 0);
3846 if (close_on_exec_p
)
3847 flags
|= FD_CLOEXEC
;
3849 flags
&= ~FD_CLOEXEC
;
3850 return fcntl (fd
, F_SETFD
, flags
| FD_CLOEXEC
);
3851 #elif defined(_WIN32)
3852 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
3853 if (h
== (HANDLE
) -1)
3855 if (close_on_exec_p
)
3856 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
, 0);
3857 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
,
3858 HANDLE_FLAG_INHERIT
);
3860 /* TODO: Unimplemented. */
3865 /* Indicates if platforms supports automatic initialization through the
3866 constructor mechanism */
3868 __gnat_binder_supports_auto_init (void)
3877 /* Indicates that Stand-Alone Libraries are automatically initialized through
3878 the constructor mechanism */
3880 __gnat_sals_init_using_constructors (void)
3882 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3891 /* In RTX mode, the procedure to get the time (as file time) is different
3892 in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3893 we introduce an intermediate procedure to link against the corresponding
3894 one in each situation. */
3896 extern void GetTimeAsFileTime (LPFILETIME pTime
);
3898 void GetTimeAsFileTime (LPFILETIME pTime
)
3901 RtGetRtssTimeAsFileTime (pTime
); /* RTSS interface */
3903 GetSystemTimeAsFileTime (pTime
); /* w32 interface */
3908 /* Add symbol that is required to link. It would otherwise be taken from
3909 libgcc.a and it would try to use the gcc constructors that are not
3910 supported by Microsoft linker. */
3912 extern void __main (void);
3920 #if defined (__ANDROID__)
3922 #include <pthread.h>
3925 __gnat_lwp_self (void)
3927 return (void *) pthread_self ();
3930 #elif defined (linux)
3931 /* There is no function in the glibc to retrieve the LWP of the current
3932 thread. We need to do a system call in order to retrieve this
3934 #include <sys/syscall.h>
3936 __gnat_lwp_self (void)
3938 return (void *) syscall (__NR_gettid
);
3943 /* glibc versions earlier than 2.7 do not define the routines to handle
3944 dynamically allocated CPU sets. For these targets, we use the static
3949 /* Dynamic cpu sets */
3952 __gnat_cpu_alloc (size_t count
)
3954 return CPU_ALLOC (count
);
3958 __gnat_cpu_alloc_size (size_t count
)
3960 return CPU_ALLOC_SIZE (count
);
3964 __gnat_cpu_free (cpu_set_t
*set
)
3970 __gnat_cpu_zero (size_t count
, cpu_set_t
*set
)
3972 CPU_ZERO_S (count
, set
);
3976 __gnat_cpu_set (int cpu
, size_t count
, cpu_set_t
*set
)
3978 /* Ada handles CPU numbers starting from 1, while C identifies the first
3979 CPU by a 0, so we need to adjust. */
3980 CPU_SET_S (cpu
- 1, count
, set
);
3983 #else /* !CPU_ALLOC */
3985 /* Static cpu sets */
3988 __gnat_cpu_alloc (size_t count ATTRIBUTE_UNUSED
)
3990 return (cpu_set_t
*) xmalloc (sizeof (cpu_set_t
));
3994 __gnat_cpu_alloc_size (size_t count ATTRIBUTE_UNUSED
)
3996 return sizeof (cpu_set_t
);
4000 __gnat_cpu_free (cpu_set_t
*set
)
4006 __gnat_cpu_zero (size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
4012 __gnat_cpu_set (int cpu
, size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
4014 /* Ada handles CPU numbers starting from 1, while C identifies the first
4015 CPU by a 0, so we need to adjust. */
4016 CPU_SET (cpu
- 1, set
);
4018 #endif /* !CPU_ALLOC */
4021 /* Return the load address of the executable, or 0 if not known. In the
4022 specific case of error, (void *)-1 can be returned. Beware: this unit may
4023 be in a shared library. As low-level units are needed, we allow #include
4026 #if defined (__APPLE__)
4027 #include <mach-o/dyld.h>
4028 #elif 0 && defined (__linux__)
4033 __gnat_get_executable_load_address (void)
4035 #if defined (__APPLE__)
4036 return _dyld_get_image_header (0);
4038 #elif 0 && defined (__linux__)
4039 /* Currently disabled as it needs at least -ldl. */
4040 struct link_map
*map
= _r_debug
.r_map
;
4042 return (const void *)map
->l_addr
;