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. */
39 /* No need to redefine exit here. */
42 /* We want to use the POSIX variants of include files. */
46 #if defined (__mips_vxworks)
48 #endif /* __mips_vxworks */
50 /* If SMP, access vxCpuConfiguredGet */
51 #ifdef _WRS_CONFIG_SMP
53 #endif /* _WRS_CONFIG_SMP */
55 /* We need to know the VxWorks version because some file operations
56 (such as chmod) are only available on VxWorks 6. */
61 #if defined (__APPLE__)
65 #if defined (__hpux__)
66 #include <sys/param.h>
67 #include <sys/pstat.h>
72 #define HOST_EXECUTABLE_SUFFIX ".exe"
73 #define HOST_OBJECT_SUFFIX ".obj"
86 #if defined (__vxworks) || defined (__ANDROID__)
87 /* S_IREAD and S_IWRITE are not defined in VxWorks or Android */
89 #define S_IREAD (S_IRUSR | S_IRGRP | S_IROTH)
93 #define S_IWRITE (S_IWUSR)
97 /* We don't have libiberty, so use malloc. */
98 #define xmalloc(S) malloc (S)
99 #define xrealloc(V,S) realloc (V,S)
110 #if defined (__MINGW32__)
118 /* Current code page to use, set in initialize.c. */
119 UINT CurrentCodePage
;
122 #include <sys/utime.h>
124 /* For isalpha-like tests in the compiler, we're expected to resort to
125 safe-ctype.h/ISALPHA. This isn't available for the runtime library
126 build, so we fallback on ctype.h/isalpha there. */
130 #define ISALPHA isalpha
133 #elif defined (__Lynx__)
135 /* Lynx utime.h only defines the entities of interest to us if
136 defined (VMOS_DEV), so ... */
145 /* wait.h processing */
148 #include <sys/wait.h>
150 #elif defined (__vxworks) && defined (__RTP__)
152 #elif defined (__Lynx__)
153 /* ??? We really need wait.h and it includes resource.h on Lynx. GCC
154 has a resource.h header as well, included instead of the lynx
155 version in our setup, causing lots of errors. We don't really need
156 the lynx contents of this file, so just workaround the issue by
157 preventing the inclusion of the GCC header from doing anything. */
158 #define GCC_RESOURCE_H
159 #include <sys/wait.h>
160 #elif defined (__nucleus__)
161 /* No wait() or waitpid() calls available. */
164 #include <sys/wait.h>
170 /* Header files and definitions for __gnat_set_file_time_name. */
172 #define __NEW_STARLET 1
174 #include <vms/atrdef.h>
175 #include <vms/fibdef.h>
176 #include <vms/stsdef.h>
177 #include <vms/iodef.h>
179 #include <vms/descrip.h>
183 /* Use native 64-bit arithmetic. */
184 #define unix_time_to_vms(X,Y) \
186 unsigned long long reftime, tmptime = (X); \
187 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
188 SYS$BINTIM (&unixtime, &reftime); \
189 Y = tmptime * 10000000 + reftime; \
192 /* descrip.h doesn't have everything ... */
193 typedef struct fibdef
* __fibdef_ptr32
__attribute__ (( mode (SI
) ));
194 struct dsc$descriptor_fib
196 unsigned int fib$l_len
;
197 __fibdef_ptr32 fib$l_addr
;
200 /* I/O Status Block. */
203 unsigned short status
, count
;
207 static char *tryfile
;
209 /* Variable length string. */
213 char string
[NAM$C_MAXRSS
+1];
216 #define SYI$_ACTIVECPU_CNT 0x111e
217 extern int LIB$
GETSYI (int *, unsigned int *);
218 extern unsigned int LIB$
CALLG_64 (unsigned long long argument_list
[],
219 int (*user_procedure
)(void));
236 #define DIR_SEPARATOR '\\'
241 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
242 defined in the current system. On DOS-like systems these flags control
243 whether the file is opened/created in text-translation mode (CR/LF in
244 external file mapped to LF in internal file), but in Unix-like systems,
245 no text translation is required, so these flags have no effect. */
255 #ifndef HOST_EXECUTABLE_SUFFIX
256 #define HOST_EXECUTABLE_SUFFIX ""
259 #ifndef HOST_OBJECT_SUFFIX
260 #define HOST_OBJECT_SUFFIX ".o"
263 #ifndef PATH_SEPARATOR
264 #define PATH_SEPARATOR ':'
267 #ifndef DIR_SEPARATOR
268 #define DIR_SEPARATOR '/'
271 /* Check for cross-compilation. */
272 #if defined (CROSS_COMPILE) || defined (CROSS_DIRECTORY_STRUCTURE)
274 int __gnat_is_cross_compiler
= 1;
277 int __gnat_is_cross_compiler
= 0;
280 char __gnat_dir_separator
= DIR_SEPARATOR
;
282 char __gnat_path_separator
= PATH_SEPARATOR
;
284 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
285 the base filenames that libraries specified with -lsomelib options
286 may have. This is used by GNATMAKE to check whether an executable
287 is up-to-date or not. The syntax is
289 library_template ::= { pattern ; } pattern NUL
290 pattern ::= [ prefix ] * [ postfix ]
292 These should only specify names of static libraries as it makes
293 no sense to determine at link time if dynamic-link libraries are
294 up to date or not. Any libraries that are not found are supposed
297 * if they are needed but not present, the link
300 * otherwise they are libraries in the system paths and so
301 they are considered part of the system and not checked
304 ??? This should be part of a GNAT host-specific compiler
305 file instead of being included in all user applications
306 as well. This is only a temporary work-around for 3.11b. */
308 #ifndef GNAT_LIBRARY_TEMPLATE
310 #define GNAT_LIBRARY_TEMPLATE "*.olb"
312 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
316 const char *__gnat_library_template
= GNAT_LIBRARY_TEMPLATE
;
318 /* This variable is used in hostparm.ads to say whether the host is a VMS
327 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
329 #elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__)
330 #define GNAT_MAX_PATH_LEN PATH_MAX
334 #if defined (__MINGW32__)
338 #include <sys/param.h>
342 #include <sys/param.h>
346 #define GNAT_MAX_PATH_LEN MAXPATHLEN
348 #define GNAT_MAX_PATH_LEN 256
353 /* Used for runtime check that Ada constant File_Attributes_Size is no
354 less than the actual size of struct file_attributes (see Osint
356 int __gnat_size_of_file_attributes
= sizeof (struct file_attributes
);
358 void __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
);
360 /* The __gnat_max_path_len variable is used to export the maximum
361 length of a path name to Ada code. max_path_len is also provided
362 for compatibility with older GNAT versions, please do not use
365 int __gnat_max_path_len
= GNAT_MAX_PATH_LEN
;
366 int max_path_len
= GNAT_MAX_PATH_LEN
;
368 /* Control whether we can use ACL on Windows. */
370 int __gnat_use_acl
= 1;
372 /* The following macro HAVE_READDIR_R should be defined if the
373 system provides the routine readdir_r. */
374 #undef HAVE_READDIR_R
376 #if defined(VMS) && defined (__LONG_POINTERS)
378 /* Return a 32 bit pointer to an array of 32 bit pointers
379 given a 64 bit pointer to an array of 64 bit pointers */
381 typedef __char_ptr32
*__char_ptr_char_ptr32
__attribute__ ((mode (SI
)));
383 static __char_ptr_char_ptr32
384 to_ptr32 (char **ptr64
)
387 __char_ptr_char_ptr32 short_argv
;
389 for (argc
= 0; ptr64
[argc
]; argc
++)
392 /* Reallocate argv with 32 bit pointers. */
393 short_argv
= (__char_ptr_char_ptr32
) decc$malloc
394 (sizeof (__char_ptr32
) * (argc
+ 1));
396 for (argc
= 0; ptr64
[argc
]; argc
++)
397 short_argv
[argc
] = (__char_ptr32
) decc$
strdup (ptr64
[argc
]);
399 short_argv
[argc
] = (__char_ptr32
) 0;
403 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
405 #define MAYBE_TO_PTR32(argv) argv
408 static const char ATTR_UNSET
= 127;
410 /* Reset the file attributes as if no system call had been performed */
413 __gnat_reset_attributes (struct file_attributes
* attr
)
415 attr
->exists
= ATTR_UNSET
;
416 attr
->error
= EINVAL
;
418 attr
->writable
= ATTR_UNSET
;
419 attr
->readable
= ATTR_UNSET
;
420 attr
->executable
= ATTR_UNSET
;
422 attr
->regular
= ATTR_UNSET
;
423 attr
->symbolic_link
= ATTR_UNSET
;
424 attr
->directory
= ATTR_UNSET
;
426 attr
->timestamp
= (OS_Time
)-2;
427 attr
->file_length
= -1;
431 __gnat_error_attributes (struct file_attributes
*attr
) {
436 __gnat_current_time (void)
438 time_t res
= time (NULL
);
439 return (OS_Time
) res
;
442 /* Return the current local time as a string in the ISO 8601 format of
443 "YYYY-MM-DD HH:MM:SS.SS". The returned string is 22 + 1 (NULL) characters
447 __gnat_current_time_string (char *result
)
449 const char *format
= "%Y-%m-%d %H:%M:%S";
450 /* Format string necessary to describe the ISO 8601 format */
452 const time_t t_val
= time (NULL
);
454 strftime (result
, 22, format
, localtime (&t_val
));
455 /* Convert the local time into a string following the ISO format, copying
456 at most 22 characters into the result string. */
461 /* The sub-seconds are manually set to zero since type time_t lacks the
462 precision necessary for nanoseconds. */
466 __gnat_to_gm_time (OS_Time
*p_time
, int *p_year
, int *p_month
, int *p_day
,
467 int *p_hours
, int *p_mins
, int *p_secs
)
470 time_t time
= (time_t) *p_time
;
473 /* On Windows systems, the time is sometimes rounded up to the nearest
474 even second, so if the number of seconds is odd, increment it. */
480 res
= localtime (&time
);
482 res
= gmtime (&time
);
487 *p_year
= res
->tm_year
;
488 *p_month
= res
->tm_mon
;
489 *p_day
= res
->tm_mday
;
490 *p_hours
= res
->tm_hour
;
491 *p_mins
= res
->tm_min
;
492 *p_secs
= res
->tm_sec
;
495 *p_year
= *p_month
= *p_day
= *p_hours
= *p_mins
= *p_secs
= 0;
498 /* Place the contents of the symbolic link named PATH in the buffer BUF,
499 which has size BUFSIZ. If PATH is a symbolic link, then return the number
500 of characters of its content in BUF. Otherwise, return -1.
501 For systems not supporting symbolic links, always return -1. */
504 __gnat_readlink (char *path ATTRIBUTE_UNUSED
,
505 char *buf ATTRIBUTE_UNUSED
,
506 size_t bufsiz ATTRIBUTE_UNUSED
)
508 #if defined (_WIN32) || defined (VMS) \
509 || defined(__vxworks) || defined (__nucleus__)
512 return readlink (path
, buf
, bufsiz
);
516 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH.
517 If NEWPATH exists it will NOT be overwritten.
518 For systems not supporting symbolic links, always return -1. */
521 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED
,
522 char *newpath ATTRIBUTE_UNUSED
)
524 #if defined (_WIN32) || defined (VMS) \
525 || defined(__vxworks) || defined (__nucleus__)
528 return symlink (oldpath
, newpath
);
532 /* Try to lock a file, return 1 if success. */
534 #if defined (__vxworks) || defined (__nucleus__) \
535 || defined (_WIN32) || defined (VMS)
537 /* Version that does not use link. */
540 __gnat_try_lock (char *dir
, char *file
)
544 TCHAR wfull_path
[GNAT_MAX_PATH_LEN
];
545 TCHAR wfile
[GNAT_MAX_PATH_LEN
];
546 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
548 S2WSC (wdir
, dir
, GNAT_MAX_PATH_LEN
);
549 S2WSC (wfile
, file
, GNAT_MAX_PATH_LEN
);
551 _stprintf (wfull_path
, _T("%s%c%s"), wdir
, _T(DIR_SEPARATOR
), wfile
);
552 fd
= _topen (wfull_path
, O_CREAT
| O_EXCL
, 0600);
556 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
557 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
569 /* Version using link(), more secure over NFS. */
570 /* See TN 6913-016 for discussion ??? */
573 __gnat_try_lock (char *dir
, char *file
)
577 GNAT_STRUCT_STAT stat_result
;
580 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
581 sprintf (temp_file
, "%s%cTMP-%ld-%ld",
582 dir
, DIR_SEPARATOR
, (long)getpid(), (long)getppid ());
584 /* Create the temporary file and write the process number. */
585 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
591 /* Link it with the new file. */
592 link (temp_file
, full_path
);
594 /* Count the references on the old one. If we have a count of two, then
595 the link did succeed. Remove the temporary file before returning. */
596 __gnat_stat (temp_file
, &stat_result
);
598 return stat_result
.st_nlink
== 2;
602 /* Return the maximum file name length. */
605 __gnat_get_maximum_file_name_length (void)
608 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
617 /* Return nonzero if file names are case sensitive. */
619 static int file_names_case_sensitive_cache
= -1;
622 __gnat_get_file_names_case_sensitive (void)
624 if (file_names_case_sensitive_cache
== -1)
626 const char *sensitive
= getenv ("GNAT_FILE_NAME_CASE_SENSITIVE");
628 if (sensitive
!= NULL
629 && (sensitive
[0] == '0' || sensitive
[0] == '1')
630 && sensitive
[1] == '\0')
631 file_names_case_sensitive_cache
= sensitive
[0] - '0';
633 #if defined (VMS) || defined (WINNT) || defined (__APPLE__)
634 file_names_case_sensitive_cache
= 0;
636 file_names_case_sensitive_cache
= 1;
639 return file_names_case_sensitive_cache
;
642 /* Return nonzero if environment variables are case sensitive. */
645 __gnat_get_env_vars_case_sensitive (void)
647 #if defined (VMS) || defined (WINNT)
655 __gnat_get_default_identifier_character_set (void)
660 /* Return the current working directory. */
663 __gnat_get_current_dir (char *dir
, int *length
)
665 #if defined (__MINGW32__)
666 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
668 _tgetcwd (wdir
, *length
);
670 WS2SC (dir
, wdir
, GNAT_MAX_PATH_LEN
);
673 /* Force Unix style, which is what GNAT uses internally. */
674 getcwd (dir
, *length
, 0);
676 getcwd (dir
, *length
);
679 *length
= strlen (dir
);
681 if (dir
[*length
- 1] != DIR_SEPARATOR
)
683 dir
[*length
] = DIR_SEPARATOR
;
689 /* Return the suffix for object files. */
692 __gnat_get_object_suffix_ptr (int *len
, const char **value
)
694 *value
= HOST_OBJECT_SUFFIX
;
699 *len
= strlen (*value
);
704 /* Return the suffix for executable files. */
707 __gnat_get_executable_suffix_ptr (int *len
, const char **value
)
709 *value
= HOST_EXECUTABLE_SUFFIX
;
713 *len
= strlen (*value
);
718 /* Return the suffix for debuggable files. Usually this is the same as the
719 executable extension. */
722 __gnat_get_debuggable_suffix_ptr (int *len
, const char **value
)
724 *value
= HOST_EXECUTABLE_SUFFIX
;
729 *len
= strlen (*value
);
734 /* Returns the OS filename and corresponding encoding. */
737 __gnat_os_filename (char *filename ATTRIBUTE_UNUSED
,
738 char *w_filename ATTRIBUTE_UNUSED
,
739 char *os_name
, int *o_length
,
740 char *encoding ATTRIBUTE_UNUSED
, int *e_length
)
742 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
743 WS2SC (os_name
, (TCHAR
*)w_filename
, (DWORD
)*o_length
);
744 *o_length
= strlen (os_name
);
745 strcpy (encoding
, "encoding=utf8");
746 *e_length
= strlen (encoding
);
748 strcpy (os_name
, filename
);
749 *o_length
= strlen (filename
);
757 __gnat_unlink (char *path
)
759 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
761 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
763 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
764 return _tunlink (wpath
);
767 return unlink (path
);
774 __gnat_rename (char *from
, char *to
)
776 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
778 TCHAR wfrom
[GNAT_MAX_PATH_LEN
], wto
[GNAT_MAX_PATH_LEN
];
780 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
);
781 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
);
782 return _trename (wfrom
, wto
);
785 return rename (from
, to
);
789 /* Changing directory. */
792 __gnat_chdir (char *path
)
794 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
796 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
798 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
799 return _tchdir (wpath
);
806 /* Removing a directory. */
809 __gnat_rmdir (char *path
)
811 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
813 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
815 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
816 return _trmdir (wpath
);
818 #elif defined (VTHREADS)
819 /* rmdir not available */
827 __gnat_fopen (char *path
, char *mode
, int encoding ATTRIBUTE_UNUSED
,
828 char *vms_form ATTRIBUTE_UNUSED
)
830 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
831 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
834 S2WS (wmode
, mode
, 10);
836 if (encoding
== Encoding_Unspecified
)
837 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
838 else if (encoding
== Encoding_UTF8
)
839 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
841 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
843 return _tfopen (wpath
, wmode
);
846 return decc$
fopen (path
, mode
);
849 char *local_form
= (char *) alloca (strlen (vms_form
) + 1);
850 /* Allocate an argument list of guaranteed ample length. */
851 unsigned long long *arg_list
=
852 (unsigned long long *) alloca (strlen (vms_form
) + 3);
856 arg_list
[1] = (unsigned long long) path
;
857 arg_list
[2] = (unsigned long long) mode
;
858 strcpy (local_form
, vms_form
);
860 /* Given a string such as "\"rfm=udf\",\"rat=cr\""
861 Split it into an argument list as "rfm=udf","rat=cr". */
863 for (i
= 0; *ptrb
; i
++)
865 ptrb
= strchr (ptrb
, '"');
866 ptre
= strchr (ptrb
+ 1, '"');
868 arg_list
[i
+ 3] = (unsigned long long) (ptrb
+ 1);
871 arg_list
[0] = i
+ 2;
872 /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
873 always a 32bit pointer. */
874 return LIB$
CALLG_64 (arg_list
, &decc$fopen
);
877 return GNAT_FOPEN (path
, mode
);
882 __gnat_freopen (char *path
,
885 int encoding ATTRIBUTE_UNUSED
,
886 char *vms_form ATTRIBUTE_UNUSED
)
888 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
889 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
892 S2WS (wmode
, mode
, 10);
894 if (encoding
== Encoding_Unspecified
)
895 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
896 else if (encoding
== Encoding_UTF8
)
897 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
899 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
901 return _tfreopen (wpath
, wmode
, stream
);
904 return decc$
freopen (path
, mode
, stream
);
907 char *local_form
= (char *) alloca (strlen (vms_form
) + 1);
908 /* Allocate an argument list of guaranteed ample length. */
909 unsigned long long *arg_list
=
910 (unsigned long long *) alloca (strlen (vms_form
) + 4);
914 arg_list
[1] = (unsigned long long) path
;
915 arg_list
[2] = (unsigned long long) mode
;
916 arg_list
[3] = (unsigned long long) stream
;
917 strcpy (local_form
, vms_form
);
919 /* Given a string such as "\"rfm=udf\",\"rat=cr\""
920 Split it into an argument list as "rfm=udf","rat=cr". */
922 for (i
= 0; *ptrb
; i
++)
924 ptrb
= strchr (ptrb
, '"');
925 ptre
= strchr (ptrb
+ 1, '"');
927 arg_list
[i
+ 4] = (unsigned long long) (ptrb
+ 1);
930 arg_list
[0] = i
+ 3;
931 /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
932 always a 32bit pointer. */
933 return LIB$
CALLG_64 (arg_list
, &decc$freopen
);
936 return freopen (path
, mode
, stream
);
941 __gnat_open_read (char *path
, int fmode
)
944 int o_fmode
= O_BINARY
;
950 /* Optional arguments mbc,deq,fop increase read performance. */
951 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
952 "mbc=16", "deq=64", "fop=tef");
953 #elif defined (__vxworks)
954 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
955 #elif defined (__MINGW32__)
957 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
959 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
960 fd
= _topen (wpath
, O_RDONLY
| o_fmode
, 0444);
963 fd
= open (path
, O_RDONLY
| o_fmode
);
966 return fd
< 0 ? -1 : fd
;
969 #if defined (__MINGW32__)
970 #define PERM (S_IREAD | S_IWRITE)
972 /* Excerpt from DECC C RTL Reference Manual:
973 To create files with OpenVMS RMS default protections using the UNIX
974 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
975 and open with a file-protection mode argument of 0777 in a program
976 that never specifically calls umask. These default protections include
977 correctly establishing protections based on ACLs, previous versions of
981 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
985 __gnat_open_rw (char *path
, int fmode
)
988 int o_fmode
= O_BINARY
;
994 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
995 "mbc=16", "deq=64", "fop=tef");
996 #elif defined (__MINGW32__)
998 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1000 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1001 fd
= _topen (wpath
, O_RDWR
| o_fmode
, PERM
);
1004 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
1007 return fd
< 0 ? -1 : fd
;
1011 __gnat_open_create (char *path
, int fmode
)
1014 int o_fmode
= O_BINARY
;
1020 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
1021 "mbc=16", "deq=64", "fop=tef");
1022 #elif defined (__MINGW32__)
1024 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1026 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1027 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
1030 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
1033 return fd
< 0 ? -1 : fd
;
1037 __gnat_create_output_file (char *path
)
1041 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
,
1042 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
1043 "shr=del,get,put,upd");
1044 #elif defined (__MINGW32__)
1046 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1048 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1049 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
1052 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
1055 return fd
< 0 ? -1 : fd
;
1059 __gnat_create_output_file_new (char *path
)
1063 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
,
1064 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
1065 "shr=del,get,put,upd");
1066 #elif defined (__MINGW32__)
1068 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1070 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1071 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
1074 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
1077 return fd
< 0 ? -1 : fd
;
1081 __gnat_open_append (char *path
, int fmode
)
1084 int o_fmode
= O_BINARY
;
1090 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
1091 "mbc=16", "deq=64", "fop=tef");
1092 #elif defined (__MINGW32__)
1094 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1096 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1097 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
1100 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
1103 return fd
< 0 ? -1 : fd
;
1106 /* Open a new file. Return error (-1) if the file already exists. */
1109 __gnat_open_new (char *path
, int fmode
)
1112 int o_fmode
= O_BINARY
;
1118 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1119 "mbc=16", "deq=64", "fop=tef");
1120 #elif defined (__MINGW32__)
1122 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1124 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1125 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1128 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1131 return fd
< 0 ? -1 : fd
;
1134 /* Open a new temp file. Return error (-1) if the file already exists.
1135 Special options for VMS allow the file to be shared between parent and child
1136 processes, however they really slow down output. Used in gnatchop. */
1139 __gnat_open_new_temp (char *path
, int fmode
)
1142 int o_fmode
= O_BINARY
;
1144 strcpy (path
, "GNAT-XXXXXX");
1146 #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \
1147 || defined (linux) || defined(__GLIBC__)) && !defined (__vxworks)
1148 return mkstemp (path
);
1149 #elif defined (__Lynx__)
1151 #elif defined (__nucleus__)
1154 if (mktemp (path
) == NULL
)
1162 /* Passing rfm=stmlf for binary files seems questionable since it results
1163 in having an extraneous line feed added after every call to CRTL write,
1164 so pass rfm=udf (aka undefined) instead. */
1165 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1166 fmode
? "rfm=stmlf" : "rfm=udf", "ctx=rec", "rat=none",
1167 "shr=del,get,put,upd", "mbc=16", "deq=64", "fop=tef");
1169 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1172 return fd
< 0 ? -1 : fd
;
1175 /****************************************************************
1176 ** Perform a call to GNAT_STAT or GNAT_FSTAT, and extract as much information
1177 ** as possible from it, storing the result in a cache for later reuse
1178 ****************************************************************/
1181 __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
)
1183 GNAT_STRUCT_STAT statbuf
;
1187 /* GNAT_FSTAT returns -1 and sets errno for failure */
1188 ret
= GNAT_FSTAT (fd
, &statbuf
);
1189 error
= ret
? errno
: 0;
1192 /* __gnat_stat returns errno value directly */
1193 error
= __gnat_stat (name
, &statbuf
);
1194 ret
= error
? -1 : 0;
1198 * A missing file is reported as an attr structure with error == 0 and
1202 if (error
== 0 || error
== ENOENT
)
1205 attr
->error
= error
;
1207 attr
->regular
= (!ret
&& S_ISREG (statbuf
.st_mode
));
1208 attr
->directory
= (!ret
&& S_ISDIR (statbuf
.st_mode
));
1211 attr
->file_length
= 0;
1213 /* st_size may be 32 bits, or 64 bits which is converted to long. We
1214 don't return a useful value for files larger than 2 gigabytes in
1216 attr
->file_length
= statbuf
.st_size
; /* all systems */
1218 attr
->exists
= !ret
;
1220 #if !defined (_WIN32) || defined (RTX)
1221 /* on Windows requires extra system call, see __gnat_is_readable_file_attr */
1222 attr
->readable
= (!ret
&& (statbuf
.st_mode
& S_IRUSR
));
1223 attr
->writable
= (!ret
&& (statbuf
.st_mode
& S_IWUSR
));
1224 attr
->executable
= (!ret
&& (statbuf
.st_mode
& S_IXUSR
));
1228 attr
->timestamp
= (OS_Time
)-1;
1231 /* VMS has file versioning. */
1232 attr
->timestamp
= (OS_Time
)statbuf
.st_ctime
;
1234 attr
->timestamp
= (OS_Time
)statbuf
.st_mtime
;
1239 /****************************************************************
1240 ** Return the number of bytes in the specified file
1241 ****************************************************************/
1244 __gnat_file_length_attr (int fd
, char* name
, struct file_attributes
* attr
)
1246 if (attr
->file_length
== -1) {
1247 __gnat_stat_to_attr (fd
, name
, attr
);
1250 return attr
->file_length
;
1254 __gnat_file_length (int fd
)
1256 struct file_attributes attr
;
1257 __gnat_reset_attributes (&attr
);
1258 return __gnat_file_length_attr (fd
, NULL
, &attr
);
1262 __gnat_named_file_length (char *name
)
1264 struct file_attributes attr
;
1265 __gnat_reset_attributes (&attr
);
1266 return __gnat_file_length_attr (-1, name
, &attr
);
1269 /* Create a temporary filename and put it in string pointed to by
1273 __gnat_tmp_name (char *tmp_filename
)
1276 /* Variable used to create a series of unique names */
1277 static int counter
= 0;
1279 /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */
1280 strcpy (tmp_filename
, "c:\\WINDOWS\\Temp\\gnat-");
1281 sprintf (&tmp_filename
[strlen (tmp_filename
)], "%d\0", counter
++);
1283 #elif defined (__MINGW32__)
1288 /* tempnam tries to create a temporary file in directory pointed to by
1289 TMP environment variable, in c:\temp if TMP is not set, and in
1290 directory specified by P_tmpdir in stdio.h if c:\temp does not
1291 exist. The filename will be created with the prefix "gnat-". */
1293 sprintf (prefix
, "gnat-%d-", (int)getpid());
1294 pname
= (char *) _tempnam ("c:\\temp", prefix
);
1296 /* if pname is NULL, the file was not created properly, the disk is full
1297 or there is no more free temporary files */
1300 *tmp_filename
= '\0';
1302 /* If pname start with a back slash and not path information it means that
1303 the filename is valid for the current working directory. */
1305 else if (pname
[0] == '\\')
1307 strcpy (tmp_filename
, ".\\");
1308 strcat (tmp_filename
, pname
+1);
1311 strcpy (tmp_filename
, pname
);
1316 #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \
1317 || defined (__OpenBSD__) || defined(__GLIBC__)
1318 #define MAX_SAFE_PATH 1000
1319 char *tmpdir
= getenv ("TMPDIR");
1321 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
1322 a buffer overflow. */
1323 if (tmpdir
== NULL
|| strlen (tmpdir
) > MAX_SAFE_PATH
)
1324 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
1326 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
1328 close (mkstemp(tmp_filename
));
1329 #elif defined (__vxworks) && !(defined (__RTP__) || defined (VTHREADS))
1333 static ushort_t seed
= 0; /* used to generate unique name */
1335 /* generate unique name */
1336 strcpy (tmp_filename
, "tmp");
1338 /* fill up the name buffer from the last position */
1340 pos
= tmp_filename
+ strlen (tmp_filename
) + index
;
1344 for (t
= seed
; 0 <= --index
; t
>>= 3)
1345 *--pos
= '0' + (t
& 07);
1347 tmpnam (tmp_filename
);
1351 /* Open directory and returns a DIR pointer. */
1353 DIR* __gnat_opendir (char *name
)
1356 /* Not supported in RTX */
1360 #elif defined (__MINGW32__)
1361 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1363 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1364 return (DIR*)_topendir (wname
);
1367 return opendir (name
);
1371 /* Read the next entry in a directory. The returned string points somewhere
1375 __gnat_readdir (DIR *dirp
, char *buffer
, int *len
)
1378 /* Not supported in RTX */
1382 #elif defined (__MINGW32__)
1383 struct _tdirent
*dirent
= _treaddir ((_TDIR
*)dirp
);
1387 WS2SC (buffer
, dirent
->d_name
, GNAT_MAX_PATH_LEN
);
1388 *len
= strlen (buffer
);
1395 #elif defined (HAVE_READDIR_R)
1396 /* If possible, try to use the thread-safe version. */
1397 if (readdir_r (dirp
, buffer
) != NULL
)
1399 *len
= strlen (((struct dirent
*) buffer
)->d_name
);
1400 return ((struct dirent
*) buffer
)->d_name
;
1406 struct dirent
*dirent
= (struct dirent
*) readdir (dirp
);
1410 strcpy (buffer
, dirent
->d_name
);
1411 *len
= strlen (buffer
);
1420 /* Close a directory entry. */
1422 int __gnat_closedir (DIR *dirp
)
1425 /* Not supported in RTX */
1429 #elif defined (__MINGW32__)
1430 return _tclosedir ((_TDIR
*)dirp
);
1433 return closedir (dirp
);
1437 /* Returns 1 if readdir is thread safe, 0 otherwise. */
1440 __gnat_readdir_is_thread_safe (void)
1442 #ifdef HAVE_READDIR_R
1449 #if defined (_WIN32) && !defined (RTX)
1450 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
1451 static const unsigned long long w32_epoch_offset
= 11644473600ULL;
1453 /* Returns the file modification timestamp using Win32 routines which are
1454 immune against daylight saving time change. It is in fact not possible to
1455 use fstat for this purpose as the DST modify the st_mtime field of the
1459 win32_filetime (HANDLE h
)
1464 unsigned long long ull_time
;
1467 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1468 since <Jan 1st 1601>. This function must return the number of seconds
1469 since <Jan 1st 1970>. */
1471 if (GetFileTime (h
, NULL
, NULL
, &t_write
.ft_time
))
1472 return (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1476 /* As above but starting from a FILETIME. */
1478 f2t (const FILETIME
*ft
, time_t *t
)
1483 unsigned long long ull_time
;
1486 t_write
.ft_time
= *ft
;
1487 *t
= (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1491 /* Return a GNAT time stamp given a file name. */
1494 __gnat_file_time_name_attr (char* name
, struct file_attributes
* attr
)
1496 if (attr
->timestamp
== (OS_Time
)-2) {
1497 #if defined (_WIN32) && !defined (RTX)
1499 WIN32_FILE_ATTRIBUTE_DATA fad
;
1501 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1502 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1504 if ((res
= GetFileAttributesEx (wname
, GetFileExInfoStandard
, &fad
)))
1505 f2t (&fad
.ftLastWriteTime
, &ret
);
1506 attr
->timestamp
= (OS_Time
) ret
;
1508 __gnat_stat_to_attr (-1, name
, attr
);
1511 return attr
->timestamp
;
1515 __gnat_file_time_name (char *name
)
1517 struct file_attributes attr
;
1518 __gnat_reset_attributes (&attr
);
1519 return __gnat_file_time_name_attr (name
, &attr
);
1522 /* Return a GNAT time stamp given a file descriptor. */
1525 __gnat_file_time_fd_attr (int fd
, struct file_attributes
* attr
)
1527 if (attr
->timestamp
== (OS_Time
)-2) {
1528 #if defined (_WIN32) && !defined (RTX)
1529 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
1530 time_t ret
= win32_filetime (h
);
1531 attr
->timestamp
= (OS_Time
) ret
;
1534 __gnat_stat_to_attr (fd
, NULL
, attr
);
1538 return attr
->timestamp
;
1542 __gnat_file_time_fd (int fd
)
1544 struct file_attributes attr
;
1545 __gnat_reset_attributes (&attr
);
1546 return __gnat_file_time_fd_attr (fd
, &attr
);
1549 /* Set the file time stamp. */
1552 __gnat_set_file_time_name (char *name
, time_t time_stamp
)
1554 #if defined (__vxworks)
1556 /* Code to implement __gnat_set_file_time_name for these systems. */
1558 #elif defined (_WIN32) && !defined (RTX)
1562 unsigned long long ull_time
;
1564 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1566 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1568 HANDLE h
= CreateFile
1569 (wname
, GENERIC_WRITE
, FILE_SHARE_WRITE
, NULL
,
1570 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
,
1572 if (h
== INVALID_HANDLE_VALUE
)
1574 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1575 t_write
.ull_time
= ((unsigned long long)time_stamp
+ w32_epoch_offset
);
1576 /* Convert to 100 nanosecond units */
1577 t_write
.ull_time
*= 10000000ULL;
1579 SetFileTime(h
, NULL
, NULL
, &t_write
.ft_time
);
1589 unsigned long long backup
, create
, expire
, revise
;
1593 unsigned short value
;
1596 unsigned system
: 4;
1602 } Fat
= { 0, 0, 0, 0, 0, { 0 }};
1606 { ATR$S_CREDATE
, ATR$C_CREDATE
, &Fat
.create
},
1607 { ATR$S_REVDATE
, ATR$C_REVDATE
, &Fat
.revise
},
1608 { ATR$S_EXPDATE
, ATR$C_EXPDATE
, &Fat
.expire
},
1609 { ATR$S_BAKDATE
, ATR$C_BAKDATE
, &Fat
.backup
},
1610 { ATR$S_FPRO
, ATR$C_FPRO
, &Fat
.prot
},
1611 { ATR$S_UIC
, ATR$C_UIC
, &Fat
.uic
},
1616 struct dsc$descriptor_fib fibdsc
= {sizeof (fib
), (void *) &fib
};
1620 unsigned long long newtime
;
1621 unsigned long long revtime
;
1625 struct vstring file
;
1626 struct dsc$descriptor_s filedsc
1627 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) file
.string
};
1628 struct vstring device
;
1629 struct dsc$descriptor_s devicedsc
1630 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) device
.string
};
1631 struct vstring timev
;
1632 struct dsc$descriptor_s timedsc
1633 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) timev
.string
};
1634 struct vstring result
;
1635 struct dsc$descriptor_s resultdsc
1636 = {NAM$C_MAXRSS
, DSC$K_DTYPE_VT
, DSC$K_CLASS_VS
, (void *) result
.string
};
1638 /* Convert parameter name (a file spec) to host file form. Note that this
1639 is needed on VMS to prepare for subsequent calls to VMS RMS library
1640 routines. Note that it would not work to call __gnat_to_host_dir_spec
1641 as was done in a previous version, since this fails silently unless
1642 the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1643 (directory not found) condition is signalled. */
1644 tryfile
= (char *) __gnat_to_host_file_spec (name
);
1646 /* Allocate and initialize a FAB and NAM structures. */
1650 nam
.nam$l_esa
= file
.string
;
1651 nam
.nam$b_ess
= NAM$C_MAXRSS
;
1652 nam
.nam$l_rsa
= result
.string
;
1653 nam
.nam$b_rss
= NAM$C_MAXRSS
;
1654 fab
.fab$l_fna
= tryfile
;
1655 fab
.fab$b_fns
= strlen (tryfile
);
1656 fab
.fab$l_nam
= &nam
;
1658 /* Validate filespec syntax and device existence. */
1659 status
= SYS$
PARSE (&fab
, 0, 0);
1660 if ((status
& 1) != 1)
1661 LIB$
SIGNAL (status
);
1663 file
.string
[nam
.nam$b_esl
] = 0;
1665 /* Find matching filespec. */
1666 status
= SYS$
SEARCH (&fab
, 0, 0);
1667 if ((status
& 1) != 1)
1668 LIB$
SIGNAL (status
);
1670 file
.string
[nam
.nam$b_esl
] = 0;
1671 result
.string
[result
.length
=nam
.nam$b_rsl
] = 0;
1673 /* Get the device name and assign an IO channel. */
1674 strncpy (device
.string
, nam
.nam$l_dev
, nam
.nam$b_dev
);
1675 devicedsc
.dsc$w_length
= nam
.nam$b_dev
;
1677 status
= SYS$
ASSIGN (&devicedsc
, &chan
, 0, 0, 0);
1678 if ((status
& 1) != 1)
1679 LIB$
SIGNAL (status
);
1681 /* Initialize the FIB and fill in the directory id field. */
1682 memset (&fib
, 0, sizeof (fib
));
1683 fib
.fib$w_did
[0] = nam
.nam$w_did
[0];
1684 fib
.fib$w_did
[1] = nam
.nam$w_did
[1];
1685 fib
.fib$w_did
[2] = nam
.nam$w_did
[2];
1686 fib
.fib$l_acctl
= 0;
1688 strcpy (file
.string
, (strrchr (result
.string
, ']') + 1));
1689 filedsc
.dsc$w_length
= strlen (file
.string
);
1690 result
.string
[result
.length
= 0] = 0;
1692 /* Open and close the file to fill in the attributes. */
1694 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1695 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1696 if ((status
& 1) != 1)
1697 LIB$
SIGNAL (status
);
1698 if ((iosb
.status
& 1) != 1)
1699 LIB$
SIGNAL (iosb
.status
);
1701 result
.string
[result
.length
] = 0;
1702 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0, &fibdsc
, 0, 0, 0,
1704 if ((status
& 1) != 1)
1705 LIB$
SIGNAL (status
);
1706 if ((iosb
.status
& 1) != 1)
1707 LIB$
SIGNAL (iosb
.status
);
1712 /* Set creation time to requested time. */
1713 unix_time_to_vms (time_stamp
, newtime
);
1715 t
= time ((time_t) 0);
1717 /* Set revision time to now in local time. */
1718 unix_time_to_vms (t
, revtime
);
1721 /* Reopen the file, modify the times and then close. */
1722 fib
.fib$l_acctl
= FIB$M_WRITE
;
1724 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1725 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1726 if ((status
& 1) != 1)
1727 LIB$
SIGNAL (status
);
1728 if ((iosb
.status
& 1) != 1)
1729 LIB$
SIGNAL (iosb
.status
);
1731 Fat
.create
= newtime
;
1732 Fat
.revise
= revtime
;
1734 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0,
1735 &fibdsc
, 0, 0, 0, &atrlst
, 0);
1736 if ((status
& 1) != 1)
1737 LIB$
SIGNAL (status
);
1738 if ((iosb
.status
& 1) != 1)
1739 LIB$
SIGNAL (iosb
.status
);
1741 /* Deassign the channel and exit. */
1742 status
= SYS$
DASSGN (chan
);
1743 if ((status
& 1) != 1)
1744 LIB$
SIGNAL (status
);
1746 struct utimbuf utimbuf
;
1749 /* Set modification time to requested time. */
1750 utimbuf
.modtime
= time_stamp
;
1752 /* Set access time to now in local time. */
1753 t
= time ((time_t) 0);
1754 utimbuf
.actime
= mktime (localtime (&t
));
1756 utime (name
, &utimbuf
);
1760 /* Get the list of installed standard libraries from the
1761 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1765 __gnat_get_libraries_from_registry (void)
1767 char *result
= (char *) xmalloc (1);
1771 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) \
1775 DWORD name_size
, value_size
;
1782 /* First open the key. */
1783 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1785 if (res
== ERROR_SUCCESS
)
1786 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1787 KEY_READ
, ®_key
);
1789 if (res
== ERROR_SUCCESS
)
1790 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1792 if (res
== ERROR_SUCCESS
)
1793 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1795 /* If the key exists, read out all the values in it and concatenate them
1797 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1799 value_size
= name_size
= 256;
1800 res
= RegEnumValueA (reg_key
, index
, name
, &name_size
, 0,
1801 &type
, (LPBYTE
)value
, &value_size
);
1803 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1805 char *old_result
= result
;
1807 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1808 strcpy (result
, old_result
);
1809 strcat (result
, value
);
1810 strcat (result
, ";");
1815 /* Remove the trailing ";". */
1817 result
[strlen (result
) - 1] = 0;
1823 /* Query information for the given file NAME and return it in STATBUF.
1824 * Returns 0 for success, or errno value for failure.
1827 __gnat_stat (char *name
, GNAT_STRUCT_STAT
*statbuf
)
1830 WIN32_FILE_ATTRIBUTE_DATA fad
;
1831 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
1836 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
1837 name_len
= _tcslen (wname
);
1839 if (name_len
> GNAT_MAX_PATH_LEN
)
1842 ZeroMemory (statbuf
, sizeof(GNAT_STRUCT_STAT
));
1844 res
= GetFileAttributesEx (wname
, GetFileExInfoStandard
, &fad
);
1847 error
= GetLastError();
1849 /* Check file existence using GetFileAttributes() which does not fail on
1850 special Windows files like con:, aux:, nul: etc... */
1852 if (GetFileAttributes(wname
) != INVALID_FILE_ATTRIBUTES
) {
1853 /* Just pretend that it is a regular and readable file */
1854 statbuf
->st_mode
= S_IFREG
| S_IREAD
| S_IWRITE
;
1859 case ERROR_ACCESS_DENIED
:
1860 case ERROR_SHARING_VIOLATION
:
1861 case ERROR_LOCK_VIOLATION
:
1862 case ERROR_SHARING_BUFFER_EXCEEDED
:
1864 case ERROR_BUFFER_OVERFLOW
:
1865 return ENAMETOOLONG
;
1866 case ERROR_NOT_ENOUGH_MEMORY
:
1873 f2t (&fad
.ftCreationTime
, &statbuf
->st_ctime
);
1874 f2t (&fad
.ftLastWriteTime
, &statbuf
->st_mtime
);
1875 f2t (&fad
.ftLastAccessTime
, &statbuf
->st_atime
);
1877 statbuf
->st_size
= (off_t
)fad
.nFileSizeLow
;
1879 /* We do not have the S_IEXEC attribute, but this is not used on GNAT. */
1880 statbuf
->st_mode
= S_IREAD
;
1882 if (fad
.dwFileAttributes
& FILE_ATTRIBUTE_DIRECTORY
)
1883 statbuf
->st_mode
|= S_IFDIR
;
1885 statbuf
->st_mode
|= S_IFREG
;
1887 if (!(fad
.dwFileAttributes
& FILE_ATTRIBUTE_READONLY
))
1888 statbuf
->st_mode
|= S_IWRITE
;
1893 return GNAT_STAT (name
, statbuf
) == 0 ? 0 : errno
;
1897 /*************************************************************************
1898 ** Check whether a file exists
1899 *************************************************************************/
1902 __gnat_file_exists_attr (char* name
, struct file_attributes
* attr
)
1904 if (attr
->exists
== ATTR_UNSET
)
1905 __gnat_stat_to_attr (-1, name
, attr
);
1907 return attr
->exists
;
1911 __gnat_file_exists (char *name
)
1913 struct file_attributes attr
;
1914 __gnat_reset_attributes (&attr
);
1915 return __gnat_file_exists_attr (name
, &attr
);
1918 /**********************************************************************
1919 ** Whether name is an absolute path
1920 **********************************************************************/
1923 __gnat_is_absolute_path (char *name
, int length
)
1926 /* On VxWorks systems, an absolute path can be represented (depending on
1927 the host platform) as either /dir/file, or device:/dir/file, or
1928 device:drive_letter:/dir/file. */
1935 for (index
= 0; index
< length
; index
++)
1937 if (name
[index
] == ':' &&
1938 ((name
[index
+ 1] == '/') ||
1939 (isalpha (name
[index
+ 1]) && index
+ 2 <= length
&&
1940 name
[index
+ 2] == '/')))
1943 else if (name
[index
] == '/')
1948 return (length
!= 0) &&
1949 (*name
== '/' || *name
== DIR_SEPARATOR
1951 || (length
> 1 && ISALPHA (name
[0]) && name
[1] == ':')
1958 __gnat_is_regular_file_attr (char* name
, struct file_attributes
* attr
)
1960 if (attr
->regular
== ATTR_UNSET
)
1961 __gnat_stat_to_attr (-1, name
, attr
);
1963 return attr
->regular
;
1967 __gnat_is_regular_file (char *name
)
1969 struct file_attributes attr
;
1971 __gnat_reset_attributes (&attr
);
1972 return __gnat_is_regular_file_attr (name
, &attr
);
1976 __gnat_is_directory_attr (char* name
, struct file_attributes
* attr
)
1978 if (attr
->directory
== ATTR_UNSET
)
1979 __gnat_stat_to_attr (-1, name
, attr
);
1981 return attr
->directory
;
1985 __gnat_is_directory (char *name
)
1987 struct file_attributes attr
;
1989 __gnat_reset_attributes (&attr
);
1990 return __gnat_is_directory_attr (name
, &attr
);
1993 #if defined (_WIN32) && !defined (RTX)
1995 /* Returns the same constant as GetDriveType but takes a pathname as
1999 GetDriveTypeFromPath (TCHAR
*wfullpath
)
2001 TCHAR wdrv
[MAX_PATH
];
2002 TCHAR wpath
[MAX_PATH
];
2003 TCHAR wfilename
[MAX_PATH
];
2004 TCHAR wext
[MAX_PATH
];
2006 _tsplitpath (wfullpath
, wdrv
, wpath
, wfilename
, wext
);
2008 if (_tcslen (wdrv
) != 0)
2010 /* we have a drive specified. */
2011 _tcscat (wdrv
, _T("\\"));
2012 return GetDriveType (wdrv
);
2016 /* No drive specified. */
2018 /* Is this a relative path, if so get current drive type. */
2019 if (wpath
[0] != _T('\\') ||
2020 (_tcslen (wpath
) > 2 && wpath
[0] == _T('\\')
2021 && wpath
[1] != _T('\\')))
2022 return GetDriveType (NULL
);
2024 UINT result
= GetDriveType (wpath
);
2026 /* Cannot guess the drive type, is this \\.\ ? */
2028 if (result
== DRIVE_NO_ROOT_DIR
&&
2029 _tcslen (wpath
) >= 4 && wpath
[0] == _T('\\') && wpath
[1] == _T('\\')
2030 && wpath
[2] == _T('.') && wpath
[3] == _T('\\'))
2032 if (_tcslen (wpath
) == 4)
2033 _tcscat (wpath
, wfilename
);
2035 LPTSTR p
= &wpath
[4];
2036 LPTSTR b
= _tcschr (p
, _T('\\'));
2040 /* logical drive \\.\c\dir\file */
2046 _tcscat (p
, _T(":\\"));
2048 return GetDriveType (p
);
2055 /* This MingW section contains code to work with ACL. */
2057 __gnat_check_OWNER_ACL (TCHAR
*wname
,
2058 DWORD CheckAccessDesired
,
2059 GENERIC_MAPPING CheckGenericMapping
)
2061 DWORD dwAccessDesired
, dwAccessAllowed
;
2062 PRIVILEGE_SET PrivilegeSet
;
2063 DWORD dwPrivSetSize
= sizeof (PRIVILEGE_SET
);
2064 BOOL fAccessGranted
= FALSE
;
2065 HANDLE hToken
= NULL
;
2067 SECURITY_DESCRIPTOR
* pSD
= NULL
;
2070 (wname
, OWNER_SECURITY_INFORMATION
|
2071 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
2074 if ((pSD
= (SECURITY_DESCRIPTOR
*) HeapAlloc
2075 (GetProcessHeap (), HEAP_ZERO_MEMORY
, nLength
)) == NULL
)
2078 /* Obtain the security descriptor. */
2080 if (!GetFileSecurity
2081 (wname
, OWNER_SECURITY_INFORMATION
|
2082 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
2083 pSD
, nLength
, &nLength
))
2086 if (!ImpersonateSelf (SecurityImpersonation
))
2089 if (!OpenThreadToken
2090 (GetCurrentThread(), TOKEN_DUPLICATE
| TOKEN_QUERY
, FALSE
, &hToken
))
2093 /* Undoes the effect of ImpersonateSelf. */
2097 /* We want to test for write permissions. */
2099 dwAccessDesired
= CheckAccessDesired
;
2101 MapGenericMask (&dwAccessDesired
, &CheckGenericMapping
);
2104 (pSD
, /* security descriptor to check */
2105 hToken
, /* impersonation token */
2106 dwAccessDesired
, /* requested access rights */
2107 &CheckGenericMapping
, /* pointer to GENERIC_MAPPING */
2108 &PrivilegeSet
, /* receives privileges used in check */
2109 &dwPrivSetSize
, /* size of PrivilegeSet buffer */
2110 &dwAccessAllowed
, /* receives mask of allowed access rights */
2114 CloseHandle (hToken
);
2115 HeapFree (GetProcessHeap (), 0, pSD
);
2116 return fAccessGranted
;
2120 CloseHandle (hToken
);
2121 HeapFree (GetProcessHeap (), 0, pSD
);
2126 __gnat_set_OWNER_ACL (TCHAR
*wname
,
2128 DWORD AccessPermissions
)
2130 PACL pOldDACL
= NULL
;
2131 PACL pNewDACL
= NULL
;
2132 PSECURITY_DESCRIPTOR pSD
= NULL
;
2134 TCHAR username
[100];
2137 /* Get current user, he will act as the owner */
2139 if (!GetUserName (username
, &unsize
))
2142 if (GetNamedSecurityInfo
2145 DACL_SECURITY_INFORMATION
,
2146 NULL
, NULL
, &pOldDACL
, NULL
, &pSD
) != ERROR_SUCCESS
)
2149 BuildExplicitAccessWithName
2150 (&ea
, username
, AccessPermissions
, (ACCESS_MODE
) AccessMode
, NO_INHERITANCE
);
2152 if (AccessMode
== SET_ACCESS
)
2154 /* SET_ACCESS, we want to set an explicte set of permissions, do not
2155 merge with current DACL. */
2156 if (SetEntriesInAcl (1, &ea
, NULL
, &pNewDACL
) != ERROR_SUCCESS
)
2160 if (SetEntriesInAcl (1, &ea
, pOldDACL
, &pNewDACL
) != ERROR_SUCCESS
)
2163 if (SetNamedSecurityInfo
2164 (wname
, SE_FILE_OBJECT
,
2165 DACL_SECURITY_INFORMATION
, NULL
, NULL
, pNewDACL
, NULL
) != ERROR_SUCCESS
)
2169 LocalFree (pNewDACL
);
2172 /* Check if it is possible to use ACL for wname, the file must not be on a
2176 __gnat_can_use_acl (TCHAR
*wname
)
2178 return __gnat_use_acl
&& GetDriveTypeFromPath (wname
) != DRIVE_REMOTE
;
2181 #endif /* defined (_WIN32) && !defined (RTX) */
2184 __gnat_is_readable_file_attr (char* name
, struct file_attributes
* attr
)
2186 if (attr
->readable
== ATTR_UNSET
)
2188 #if defined (_WIN32) && !defined (RTX)
2189 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2190 GENERIC_MAPPING GenericMapping
;
2192 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2194 if (__gnat_can_use_acl (wname
))
2196 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2197 GenericMapping
.GenericRead
= GENERIC_READ
;
2199 __gnat_check_OWNER_ACL (wname
, FILE_READ_DATA
, GenericMapping
);
2202 attr
->readable
= GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
;
2204 __gnat_stat_to_attr (-1, name
, attr
);
2208 return attr
->readable
;
2212 __gnat_is_readable_file (char *name
)
2214 struct file_attributes attr
;
2216 __gnat_reset_attributes (&attr
);
2217 return __gnat_is_readable_file_attr (name
, &attr
);
2221 __gnat_is_writable_file_attr (char* name
, struct file_attributes
* attr
)
2223 if (attr
->writable
== ATTR_UNSET
)
2225 #if defined (_WIN32) && !defined (RTX)
2226 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2227 GENERIC_MAPPING GenericMapping
;
2229 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2231 if (__gnat_can_use_acl (wname
))
2233 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2234 GenericMapping
.GenericWrite
= GENERIC_WRITE
;
2236 attr
->writable
= __gnat_check_OWNER_ACL
2237 (wname
, FILE_WRITE_DATA
| FILE_APPEND_DATA
, GenericMapping
)
2238 && !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2242 !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2245 __gnat_stat_to_attr (-1, name
, attr
);
2249 return attr
->writable
;
2253 __gnat_is_writable_file (char *name
)
2255 struct file_attributes attr
;
2257 __gnat_reset_attributes (&attr
);
2258 return __gnat_is_writable_file_attr (name
, &attr
);
2262 __gnat_is_executable_file_attr (char* name
, struct file_attributes
* attr
)
2264 if (attr
->executable
== ATTR_UNSET
)
2266 #if defined (_WIN32) && !defined (RTX)
2267 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2268 GENERIC_MAPPING GenericMapping
;
2270 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2272 if (__gnat_can_use_acl (wname
))
2274 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2275 GenericMapping
.GenericExecute
= GENERIC_EXECUTE
;
2278 __gnat_check_OWNER_ACL (wname
, FILE_EXECUTE
, GenericMapping
);
2282 TCHAR
*l
, *last
= _tcsstr(wname
, _T(".exe"));
2284 /* look for last .exe */
2286 while ((l
= _tcsstr(last
+1, _T(".exe"))))
2290 GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
2291 && (last
- wname
) == (int) (_tcslen (wname
) - 4);
2294 __gnat_stat_to_attr (-1, name
, attr
);
2298 return attr
->regular
&& attr
->executable
;
2302 __gnat_is_executable_file (char *name
)
2304 struct file_attributes attr
;
2306 __gnat_reset_attributes (&attr
);
2307 return __gnat_is_executable_file_attr (name
, &attr
);
2311 __gnat_set_writable (char *name
)
2313 #if defined (_WIN32) && !defined (RTX)
2314 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2316 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2318 if (__gnat_can_use_acl (wname
))
2319 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_WRITE
);
2322 (wname
, GetFileAttributes (wname
) & ~FILE_ATTRIBUTE_READONLY
);
2323 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2324 ! defined(__nucleus__)
2325 GNAT_STRUCT_STAT statbuf
;
2327 if (GNAT_STAT (name
, &statbuf
) == 0)
2329 statbuf
.st_mode
= statbuf
.st_mode
| S_IWUSR
;
2330 chmod (name
, statbuf
.st_mode
);
2336 __gnat_set_executable (char *name
)
2338 #if defined (_WIN32) && !defined (RTX)
2339 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2341 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2343 if (__gnat_can_use_acl (wname
))
2344 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_EXECUTE
);
2346 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2347 ! defined(__nucleus__)
2348 GNAT_STRUCT_STAT statbuf
;
2350 if (GNAT_STAT (name
, &statbuf
) == 0)
2352 statbuf
.st_mode
= statbuf
.st_mode
| S_IXUSR
;
2353 chmod (name
, statbuf
.st_mode
);
2359 __gnat_set_non_writable (char *name
)
2361 #if defined (_WIN32) && !defined (RTX)
2362 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2364 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2366 if (__gnat_can_use_acl (wname
))
2367 __gnat_set_OWNER_ACL
2368 (wname
, DENY_ACCESS
,
2369 FILE_WRITE_DATA
| FILE_APPEND_DATA
|
2370 FILE_WRITE_EA
| FILE_WRITE_ATTRIBUTES
);
2373 (wname
, GetFileAttributes (wname
) | FILE_ATTRIBUTE_READONLY
);
2374 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2375 ! defined(__nucleus__)
2376 GNAT_STRUCT_STAT statbuf
;
2378 if (GNAT_STAT (name
, &statbuf
) == 0)
2380 statbuf
.st_mode
= statbuf
.st_mode
& 07577;
2381 chmod (name
, statbuf
.st_mode
);
2387 __gnat_set_readable (char *name
)
2389 #if defined (_WIN32) && !defined (RTX)
2390 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2392 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2394 if (__gnat_can_use_acl (wname
))
2395 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_READ
);
2397 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2398 ! defined(__nucleus__)
2399 GNAT_STRUCT_STAT statbuf
;
2401 if (GNAT_STAT (name
, &statbuf
) == 0)
2403 chmod (name
, statbuf
.st_mode
| S_IREAD
);
2409 __gnat_set_non_readable (char *name
)
2411 #if defined (_WIN32) && !defined (RTX)
2412 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2414 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2416 if (__gnat_can_use_acl (wname
))
2417 __gnat_set_OWNER_ACL (wname
, DENY_ACCESS
, FILE_GENERIC_READ
);
2419 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2420 ! defined(__nucleus__)
2421 GNAT_STRUCT_STAT statbuf
;
2423 if (GNAT_STAT (name
, &statbuf
) == 0)
2425 chmod (name
, statbuf
.st_mode
& (~S_IREAD
));
2431 __gnat_is_symbolic_link_attr (char* name ATTRIBUTE_UNUSED
,
2432 struct file_attributes
* attr
)
2434 if (attr
->symbolic_link
== ATTR_UNSET
)
2436 #if defined (__vxworks) || defined (__nucleus__)
2437 attr
->symbolic_link
= 0;
2439 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
2441 GNAT_STRUCT_STAT statbuf
;
2442 ret
= GNAT_LSTAT (name
, &statbuf
);
2443 attr
->symbolic_link
= (!ret
&& S_ISLNK (statbuf
.st_mode
));
2445 attr
->symbolic_link
= 0;
2448 return attr
->symbolic_link
;
2452 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED
)
2454 struct file_attributes attr
;
2456 __gnat_reset_attributes (&attr
);
2457 return __gnat_is_symbolic_link_attr (name
, &attr
);
2460 #if defined (sun) && defined (__SVR4)
2461 /* Using fork on Solaris will duplicate all the threads. fork1, which
2462 duplicates only the active thread, must be used instead, or spawning
2463 subprocess from a program with tasking will lead into numerous problems. */
2468 __gnat_portable_spawn (char *args
[])
2471 int finished ATTRIBUTE_UNUSED
;
2472 int pid ATTRIBUTE_UNUSED
;
2474 #if defined (__vxworks) || defined(__nucleus__) || defined(RTX)
2477 #elif defined (_WIN32)
2478 /* args[0] must be quotes as it could contain a full pathname with spaces */
2479 char *args_0
= args
[0];
2480 args
[0] = (char *)xmalloc (strlen (args_0
) + 3);
2481 strcpy (args
[0], "\"");
2482 strcat (args
[0], args_0
);
2483 strcat (args
[0], "\"");
2485 status
= spawnvp (P_WAIT
, args_0
, (char* const*)args
);
2487 /* restore previous value */
2489 args
[0] = (char *)args_0
;
2505 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2507 return -1; /* execv is in parent context on VMS. */
2514 finished
= waitpid (pid
, &status
, 0);
2516 if (finished
!= pid
|| WIFEXITED (status
) == 0)
2519 return WEXITSTATUS (status
);
2525 /* Create a copy of the given file descriptor.
2526 Return -1 if an error occurred. */
2529 __gnat_dup (int oldfd
)
2531 #if defined (__vxworks) && !defined (__RTP__)
2532 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2540 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
2541 Return -1 if an error occurred. */
2544 __gnat_dup2 (int oldfd
, int newfd
)
2546 #if defined (__vxworks) && !defined (__RTP__)
2547 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2550 #elif defined (_WIN32)
2551 /* Special case when oldfd and newfd are identical and are the standard
2552 input, output or error as this makes Windows XP hangs. Note that we
2553 do that only for standard file descriptors that are known to be valid. */
2554 if (oldfd
== newfd
&& newfd
>= 0 && newfd
<= 2)
2557 return dup2 (oldfd
, newfd
);
2559 return dup2 (oldfd
, newfd
);
2564 __gnat_number_of_cpus (void)
2568 #if defined (linux) || defined (sun) || defined (AIX) || defined (__APPLE__)
2569 cores
= (int) sysconf (_SC_NPROCESSORS_ONLN
);
2571 #elif defined (__hpux__)
2572 struct pst_dynamic psd
;
2573 if (pstat_getdynamic (&psd
, sizeof (psd
), 1, 0) != -1)
2574 cores
= (int) psd
.psd_proc_cnt
;
2576 #elif defined (_WIN32)
2577 SYSTEM_INFO sysinfo
;
2578 GetSystemInfo (&sysinfo
);
2579 cores
= (int) sysinfo
.dwNumberOfProcessors
;
2582 int code
= SYI$_ACTIVECPU_CNT
;
2586 status
= LIB$
GETSYI (&code
, &res
);
2587 if ((status
& 1) != 0)
2590 #elif defined (_WRS_CONFIG_SMP)
2591 unsigned int vxCpuConfiguredGet (void);
2593 cores
= vxCpuConfiguredGet ();
2600 /* WIN32 code to implement a wait call that wait for any child process. */
2602 #if defined (_WIN32) && !defined (RTX)
2604 /* Synchronization code, to be thread safe. */
2608 /* For the Cert run times on native Windows we use dummy functions
2609 for locking and unlocking tasks since we do not support multiple
2610 threads on this configuration (Cert run time on native Windows). */
2612 static void dummy (void)
2616 void (*Lock_Task
) () = &dummy
;
2617 void (*Unlock_Task
) () = &dummy
;
2621 #define Lock_Task system__soft_links__lock_task
2622 extern void (*Lock_Task
) (void);
2624 #define Unlock_Task system__soft_links__unlock_task
2625 extern void (*Unlock_Task
) (void);
2629 static HANDLE
*HANDLES_LIST
= NULL
;
2630 static int *PID_LIST
= NULL
, plist_length
= 0, plist_max_length
= 0;
2633 add_handle (HANDLE h
, int pid
)
2636 /* -------------------- critical section -------------------- */
2639 if (plist_length
== plist_max_length
)
2641 plist_max_length
+= 1000;
2643 (void **) xrealloc (HANDLES_LIST
, sizeof (HANDLE
) * plist_max_length
);
2645 (int *) xrealloc (PID_LIST
, sizeof (int) * plist_max_length
);
2648 HANDLES_LIST
[plist_length
] = h
;
2649 PID_LIST
[plist_length
] = pid
;
2653 /* -------------------- critical section -------------------- */
2657 __gnat_win32_remove_handle (HANDLE h
, int pid
)
2661 /* -------------------- critical section -------------------- */
2664 for (j
= 0; j
< plist_length
; j
++)
2666 if ((HANDLES_LIST
[j
] == h
) || (PID_LIST
[j
] == pid
))
2670 HANDLES_LIST
[j
] = HANDLES_LIST
[plist_length
];
2671 PID_LIST
[j
] = PID_LIST
[plist_length
];
2677 /* -------------------- critical section -------------------- */
2681 win32_no_block_spawn (char *command
, char *args
[], HANDLE
*h
, int *pid
)
2685 PROCESS_INFORMATION PI
;
2686 SECURITY_ATTRIBUTES SA
;
2691 /* compute the total command line length */
2695 csize
+= strlen (args
[k
]) + 1;
2699 full_command
= (char *) xmalloc (csize
);
2702 SI
.cb
= sizeof (STARTUPINFO
);
2703 SI
.lpReserved
= NULL
;
2704 SI
.lpReserved2
= NULL
;
2705 SI
.lpDesktop
= NULL
;
2709 SI
.wShowWindow
= SW_HIDE
;
2711 /* Security attributes. */
2712 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
2713 SA
.bInheritHandle
= TRUE
;
2714 SA
.lpSecurityDescriptor
= NULL
;
2716 /* Prepare the command string. */
2717 strcpy (full_command
, command
);
2718 strcat (full_command
, " ");
2723 strcat (full_command
, args
[k
]);
2724 strcat (full_command
, " ");
2729 int wsize
= csize
* 2;
2730 TCHAR
*wcommand
= (TCHAR
*) xmalloc (wsize
);
2732 S2WSC (wcommand
, full_command
, wsize
);
2734 free (full_command
);
2736 result
= CreateProcess
2737 (NULL
, wcommand
, &SA
, NULL
, TRUE
,
2738 GetPriorityClass (GetCurrentProcess()), NULL
, NULL
, &SI
, &PI
);
2745 CloseHandle (PI
.hThread
);
2747 *pid
= PI
.dwProcessId
;
2757 win32_wait (int *status
)
2759 DWORD exitcode
, pid
;
2766 if (plist_length
== 0)
2774 /* -------------------- critical section -------------------- */
2777 hl_len
= plist_length
;
2779 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * hl_len
);
2781 memmove (hl
, HANDLES_LIST
, sizeof (HANDLE
) * hl_len
);
2784 /* -------------------- critical section -------------------- */
2786 res
= WaitForMultipleObjects (hl_len
, hl
, FALSE
, INFINITE
);
2787 h
= hl
[res
- WAIT_OBJECT_0
];
2789 GetExitCodeProcess (h
, &exitcode
);
2790 pid
= PID_LIST
[res
- WAIT_OBJECT_0
];
2791 __gnat_win32_remove_handle (h
, -1);
2795 *status
= (int) exitcode
;
2802 __gnat_portable_no_block_spawn (char *args
[])
2805 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2808 #elif defined (_WIN32)
2813 win32_no_block_spawn (args
[0], args
, &h
, &pid
);
2816 add_handle (h
, pid
);
2829 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2831 return -1; /* execv is in parent context on VMS. */
2843 __gnat_portable_wait (int *process_status
)
2848 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2849 /* Not sure what to do here, so do nothing but return zero. */
2851 #elif defined (_WIN32)
2853 pid
= win32_wait (&status
);
2857 pid
= waitpid (-1, &status
, 0);
2858 status
= status
& 0xffff;
2861 *process_status
= status
;
2866 __gnat_os_exit (int status
)
2871 /* Locate file on path, that matches a predicate */
2874 __gnat_locate_file_with_predicate (char *file_name
, char *path_val
,
2875 int (*predicate
)(char *))
2878 char *file_path
= (char *) alloca (strlen (file_name
) + 1);
2881 /* Return immediately if file_name is empty */
2883 if (*file_name
== '\0')
2886 /* Remove quotes around file_name if present */
2892 strcpy (file_path
, ptr
);
2894 ptr
= file_path
+ strlen (file_path
) - 1;
2899 /* Handle absolute pathnames. */
2901 absolute
= __gnat_is_absolute_path (file_path
, strlen (file_name
));
2905 if (predicate (file_path
))
2906 return xstrdup (file_path
);
2911 /* If file_name include directory separator(s), try it first as
2912 a path name relative to the current directory */
2913 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
2918 if (predicate (file_name
))
2919 return xstrdup (file_name
);
2926 /* The result has to be smaller than path_val + file_name. */
2928 (char *) alloca (strlen (path_val
) + strlen (file_name
) + 2);
2932 /* Skip the starting quote */
2934 if (*path_val
== '"')
2937 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
2938 *ptr
++ = *path_val
++;
2940 /* If directory is empty, it is the current directory*/
2942 if (ptr
== file_path
)
2949 /* Skip the ending quote */
2954 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
2955 *++ptr
= DIR_SEPARATOR
;
2957 strcpy (++ptr
, file_name
);
2959 if (predicate (file_path
))
2960 return xstrdup (file_path
);
2965 /* Skip path separator */
2974 /* Locate an executable file, give a Path value. */
2977 __gnat_locate_executable_file (char *file_name
, char *path_val
)
2979 return __gnat_locate_file_with_predicate
2980 (file_name
, path_val
, &__gnat_is_executable_file
);
2983 /* Locate a regular file, give a Path value. */
2986 __gnat_locate_regular_file (char *file_name
, char *path_val
)
2988 return __gnat_locate_file_with_predicate
2989 (file_name
, path_val
, &__gnat_is_regular_file
);
2992 /* Locate an executable given a Path argument. This routine is only used by
2993 gnatbl and should not be used otherwise. Use locate_exec_on_path
2997 __gnat_locate_exec (char *exec_name
, char *path_val
)
3000 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
3002 char *full_exec_name
=
3004 (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
3006 strcpy (full_exec_name
, exec_name
);
3007 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
3008 ptr
= __gnat_locate_executable_file (full_exec_name
, path_val
);
3011 return __gnat_locate_executable_file (exec_name
, path_val
);
3015 return __gnat_locate_executable_file (exec_name
, path_val
);
3018 /* Locate an executable using the Systems default PATH. */
3021 __gnat_locate_exec_on_path (char *exec_name
)
3025 #if defined (_WIN32) && !defined (RTX)
3026 TCHAR
*wpath_val
= _tgetenv (_T("PATH"));
3028 /* In Win32 systems we expand the PATH as for XP environment
3029 variables are not automatically expanded. We also prepend the
3030 ".;" to the path to match normal NT path search semantics */
3032 #define EXPAND_BUFFER_SIZE 32767
3034 wapath_val
= (TCHAR
*) alloca (EXPAND_BUFFER_SIZE
);
3036 wapath_val
[0] = '.';
3037 wapath_val
[1] = ';';
3039 DWORD res
= ExpandEnvironmentStrings
3040 (wpath_val
, &wapath_val
[2], EXPAND_BUFFER_SIZE
- 2);
3042 if (!res
) wapath_val
[0] = _T('\0');
3044 apath_val
= (char *) alloca (EXPAND_BUFFER_SIZE
);
3046 WS2SC (apath_val
, wapath_val
, EXPAND_BUFFER_SIZE
);
3047 return __gnat_locate_exec (exec_name
, apath_val
);
3052 char *path_val
= "/VAXC$PATH";
3054 char *path_val
= getenv ("PATH");
3056 if (path_val
== NULL
) return NULL
;
3057 apath_val
= (char *) alloca (strlen (path_val
) + 1);
3058 strcpy (apath_val
, path_val
);
3059 return __gnat_locate_exec (exec_name
, apath_val
);
3065 /* These functions are used to translate to and from VMS and Unix syntax
3066 file, directory and path specifications. */
3069 #define MAXNAMES 256
3070 #define NEW_CANONICAL_FILELIST_INCREMENT 64
3072 static char new_canonical_dirspec
[MAXPATH
];
3073 static char new_canonical_filespec
[MAXPATH
];
3074 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
3075 static unsigned new_canonical_filelist_index
;
3076 static unsigned new_canonical_filelist_in_use
;
3077 static unsigned new_canonical_filelist_allocated
;
3078 static char **new_canonical_filelist
;
3079 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
3080 static char new_host_dirspec
[MAXPATH
];
3081 static char new_host_filespec
[MAXPATH
];
3083 /* Routine is called repeatedly by decc$from_vms via
3084 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
3088 wildcard_translate_unix (char *name
)
3091 char buff
[MAXPATH
];
3093 strncpy (buff
, name
, MAXPATH
);
3094 buff
[MAXPATH
- 1] = (char) 0;
3095 ver
= strrchr (buff
, '.');
3097 /* Chop off the version. */
3101 /* Dynamically extend the allocation by the increment. */
3102 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
3104 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
3105 new_canonical_filelist
= (char **) xrealloc
3106 (new_canonical_filelist
,
3107 new_canonical_filelist_allocated
* sizeof (char *));
3110 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
3115 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
3116 full translation and copy the results into a list (_init), then return them
3117 one at a time (_next). If onlydirs set, only expand directory files. */
3120 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
3123 char buff
[MAXPATH
];
3125 len
= strlen (filespec
);
3126 strncpy (buff
, filespec
, MAXPATH
);
3128 /* Only look for directories */
3129 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
3130 strncat (buff
, "*.dir", MAXPATH
);
3132 buff
[MAXPATH
- 1] = (char) 0;
3134 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
3136 /* Remove the .dir extension. */
3142 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3144 ext
= strstr (new_canonical_filelist
[i
], ".dir");
3150 return new_canonical_filelist_in_use
;
3153 /* Return the next filespec in the list. */
3156 __gnat_to_canonical_file_list_next (void)
3158 return new_canonical_filelist
[new_canonical_filelist_index
++];
3161 /* Free storage used in the wildcard expansion. */
3164 __gnat_to_canonical_file_list_free (void)
3168 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3169 free (new_canonical_filelist
[i
]);
3171 free (new_canonical_filelist
);
3173 new_canonical_filelist_in_use
= 0;
3174 new_canonical_filelist_allocated
= 0;
3175 new_canonical_filelist_index
= 0;
3176 new_canonical_filelist
= 0;
3179 /* The functional equivalent of decc$translate_vms routine.
3180 Designed to produce the same output, but is protected against
3181 malformed paths (original version ACCVIOs in this case) and
3182 does not require VMS-specific DECC RTL. */
3184 #define NAM$C_MAXRSS 1024
3187 __gnat_translate_vms (char *src
)
3189 static char retbuf
[NAM$C_MAXRSS
+ 1];
3190 char *srcendpos
, *pos1
, *pos2
, *retpos
;
3191 int disp
, path_present
= 0;
3196 srcendpos
= strchr (src
, '\0');
3199 /* Look for the node and/or device in front of the path. */
3201 pos2
= strchr (pos1
, ':');
3203 if (pos2
&& (pos2
< srcendpos
) && (*(pos2
+ 1) == ':'))
3205 /* There is a node name. "node_name::" becomes "node_name!". */
3207 strncpy (retbuf
, pos1
, disp
);
3208 retpos
[disp
] = '!';
3209 retpos
= retpos
+ disp
+ 1;
3211 pos2
= strchr (pos1
, ':');
3216 /* There is a device name. "dev_name:" becomes "/dev_name/". */
3219 strncpy (retpos
, pos1
, disp
);
3220 retpos
= retpos
+ disp
;
3225 /* No explicit device; we must look ahead and prepend /sys$disk/ if
3226 the path is absolute. */
3227 if ((*pos1
== '[' || *pos1
== '<') && (pos1
< srcendpos
)
3228 && !strchr (".-]>", *(pos1
+ 1)))
3230 strncpy (retpos
, "/sys$disk/", 10);
3234 /* Process the path part. */
3235 while (*pos1
== '[' || *pos1
== '<')
3239 if (*pos1
== ']' || *pos1
== '>')
3241 /* Special case, [] translates to '.'. */
3247 /* '[000000' means root dir. It can be present in the middle of
3248 the path due to expansion of logical devices, in which case
3250 if (!strncmp (pos1
, "000000", 6) && path_present
> 1 &&
3251 (*(pos1
+ 6) == ']' || *(pos1
+ 6) == '>' || *(pos1
+ 6) == '.'))
3254 if (*pos1
== '.') pos1
++;
3256 else if (*pos1
== '.')
3258 /* Relative path. */
3262 /* There is a qualified path. */
3263 while (*pos1
&& *pos1
!= ']' && *pos1
!= '>')
3268 /* '.' is used to separate directories. Replace it with '/'
3269 but only if there isn't already '/' just before. */
3270 if (*(retpos
- 1) != '/')
3273 if (pos1
+ 1 < srcendpos
3275 && *(pos1
+ 1) == '.')
3277 /* Ellipsis refers to entire subtree; replace
3286 /* When after '.' '[' '<' is equivalent to Unix ".." but
3287 there may be several in a row. */
3288 if (*(pos1
- 1) == '.' || *(pos1
- 1) == '[' ||
3291 while (*pos1
== '-')
3301 /* Otherwise fall through to default. */
3303 *(retpos
++) = *(pos1
++);
3310 if (pos1
< srcendpos
)
3312 /* Now add the actual file name, until the version suffix if any */
3315 pos2
= strchr (pos1
, ';');
3316 disp
= pos2
? (pos2
- pos1
) : (srcendpos
- pos1
);
3317 strncpy (retpos
, pos1
, disp
);
3319 if (pos2
&& pos2
< srcendpos
)
3321 /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
3323 disp
= srcendpos
- pos2
- 1;
3324 strncpy (retpos
, pos2
+ 1, disp
);
3334 /* Translate a VMS syntax directory specification in to Unix syntax. If
3335 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
3336 found, return input string. Also translate a dirname that contains no
3337 slashes, in case it's a logical name. */
3340 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
3344 strcpy (new_canonical_dirspec
, "");
3345 if (strlen (dirspec
))
3349 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
3351 strncpy (new_canonical_dirspec
,
3352 __gnat_translate_vms (dirspec
),
3355 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
3357 strncpy (new_canonical_dirspec
,
3358 __gnat_translate_vms (dirspec1
),
3363 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
3367 len
= strlen (new_canonical_dirspec
);
3368 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
3369 strncat (new_canonical_dirspec
, "/", MAXPATH
);
3371 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
3373 return new_canonical_dirspec
;
3377 /* Translate a VMS syntax file specification into Unix syntax.
3378 If no indicators of VMS syntax found, check if it's an uppercase
3379 alphanumeric_ name and if so try it out as an environment
3380 variable (logical name). If all else fails return the
3384 __gnat_to_canonical_file_spec (char *filespec
)
3388 strncpy (new_canonical_filespec
, "", MAXPATH
);
3390 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3392 char *tspec
= (char *) __gnat_translate_vms (filespec
);
3394 if (tspec
!= (char *) -1)
3395 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3397 else if ((strlen (filespec
) == strspn (filespec
,
3398 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
3399 && (filespec1
= getenv (filespec
)))
3401 char *tspec
= (char *) __gnat_translate_vms (filespec1
);
3403 if (tspec
!= (char *) -1)
3404 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3408 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
3411 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
3413 return new_canonical_filespec
;
3416 /* Translate a VMS syntax path specification into Unix syntax.
3417 If no indicators of VMS syntax found, return input string. */
3420 __gnat_to_canonical_path_spec (char *pathspec
)
3422 char *curr
, *next
, buff
[MAXPATH
];
3427 /* If there are /'s, assume it's a Unix path spec and return. */
3428 if (strchr (pathspec
, '/'))
3431 new_canonical_pathspec
[0] = 0;
3436 next
= strchr (curr
, ',');
3438 next
= strchr (curr
, 0);
3440 strncpy (buff
, curr
, next
- curr
);
3441 buff
[next
- curr
] = 0;
3443 /* Check for wildcards and expand if present. */
3444 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
3448 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
3449 for (i
= 0; i
< dirs
; i
++)
3453 next_dir
= __gnat_to_canonical_file_list_next ();
3454 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
3456 /* Don't append the separator after the last expansion. */
3458 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3461 __gnat_to_canonical_file_list_free ();
3464 strncat (new_canonical_pathspec
,
3465 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
3470 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3474 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
3476 return new_canonical_pathspec
;
3479 static char filename_buff
[MAXPATH
];
3482 translate_unix (char *name
, int type ATTRIBUTE_UNUSED
)
3484 strncpy (filename_buff
, name
, MAXPATH
);
3485 filename_buff
[MAXPATH
- 1] = (char) 0;
3489 /* Translate a Unix syntax directory specification into VMS syntax. The
3490 PREFIXFLAG has no effect, but is kept for symmetry with
3491 to_canonical_dir_spec. If indicators of VMS syntax found, return input
3495 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3497 int len
= strlen (dirspec
);
3499 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
3500 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3502 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
3503 return new_host_dirspec
;
3505 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
3507 new_host_dirspec
[len
- 1] = 0;
3511 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
3512 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
3513 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3515 return new_host_dirspec
;
3518 /* Translate a Unix syntax file specification into VMS syntax.
3519 If indicators of VMS syntax found, return input string. */
3522 __gnat_to_host_file_spec (char *filespec
)
3524 strncpy (new_host_filespec
, "", MAXPATH
);
3525 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3527 strncpy (new_host_filespec
, filespec
, MAXPATH
);
3531 decc$
to_vms (filespec
, translate_unix
, 1, 1);
3532 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
3535 new_host_filespec
[MAXPATH
- 1] = (char) 0;
3537 return new_host_filespec
;
3541 __gnat_adjust_os_resource_limits (void)
3543 SYS$
ADJWSL (131072, 0);
3548 /* Dummy functions for Osint import for non-VMS systems. */
3551 __gnat_to_canonical_file_list_init (char *dirspec ATTRIBUTE_UNUSED
,
3552 int onlydirs ATTRIBUTE_UNUSED
)
3558 __gnat_to_canonical_file_list_next (void)
3560 static char empty
[] = "";
3565 __gnat_to_canonical_file_list_free (void)
3570 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3576 __gnat_to_canonical_file_spec (char *filespec
)
3582 __gnat_to_canonical_path_spec (char *pathspec
)
3588 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3594 __gnat_to_host_file_spec (char *filespec
)
3600 __gnat_adjust_os_resource_limits (void)
3606 #if defined (__mips_vxworks)
3610 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
3614 #if defined (IS_CROSS) \
3615 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3616 && defined (__SVR4)) \
3617 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3618 && ! (defined (linux) && defined (__ia64__)) \
3619 && ! (defined (linux) && defined (powerpc)) \
3620 && ! defined (__FreeBSD__) \
3621 && ! defined (__Lynx__) \
3622 && ! defined (__hpux__) \
3623 && ! defined (__APPLE__) \
3624 && ! defined (_AIX) \
3625 && ! defined (VMS) \
3626 && ! defined (__MINGW32__))
3628 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3629 just above for a list of native platforms that provide a non-dummy
3630 version of this procedure in libaddr2line.a. */
3633 convert_addresses (const char *file_name ATTRIBUTE_UNUSED
,
3634 void *addrs ATTRIBUTE_UNUSED
,
3635 int n_addr ATTRIBUTE_UNUSED
,
3636 void *buf ATTRIBUTE_UNUSED
,
3637 int *len ATTRIBUTE_UNUSED
)
3643 #if defined (_WIN32)
3644 int __gnat_argument_needs_quote
= 1;
3646 int __gnat_argument_needs_quote
= 0;
3649 /* This option is used to enable/disable object files handling from the
3650 binder file by the GNAT Project module. For example, this is disabled on
3651 Windows (prior to GCC 3.4) as it is already done by the mdll module.
3652 Stating with GCC 3.4 the shared libraries are not based on mdll
3653 anymore as it uses the GCC's -shared option */
3654 #if defined (_WIN32) \
3655 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3656 int __gnat_prj_add_obj_files
= 0;
3658 int __gnat_prj_add_obj_files
= 1;
3661 /* char used as prefix/suffix for environment variables */
3662 #if defined (_WIN32)
3663 char __gnat_environment_char
= '%';
3665 char __gnat_environment_char
= '$';
3668 /* This functions copy the file attributes from a source file to a
3671 mode = 0 : In this mode copy only the file time stamps (last access and
3672 last modification time stamps).
3674 mode = 1 : In this mode, time stamps and read/write/execute attributes are
3677 Returns 0 if operation was successful and -1 in case of error. */
3680 __gnat_copy_attribs (char *from ATTRIBUTE_UNUSED
, char *to ATTRIBUTE_UNUSED
,
3681 int mode ATTRIBUTE_UNUSED
)
3683 #if defined (VMS) || (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \
3684 defined (__nucleus__)
3687 #elif defined (_WIN32) && !defined (RTX)
3688 TCHAR wfrom
[GNAT_MAX_PATH_LEN
+ 2];
3689 TCHAR wto
[GNAT_MAX_PATH_LEN
+ 2];
3691 FILETIME fct
, flat
, flwt
;
3694 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
+ 2);
3695 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
+ 2);
3697 /* retrieve from times */
3700 (wfrom
, GENERIC_READ
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3702 if (hfrom
== INVALID_HANDLE_VALUE
)
3705 res
= GetFileTime (hfrom
, &fct
, &flat
, &flwt
);
3707 CloseHandle (hfrom
);
3712 /* retrieve from times */
3715 (wto
, GENERIC_WRITE
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3717 if (hto
== INVALID_HANDLE_VALUE
)
3720 res
= SetFileTime (hto
, NULL
, &flat
, &flwt
);
3727 /* Set file attributes in full mode. */
3731 DWORD attribs
= GetFileAttributes (wfrom
);
3733 if (attribs
== INVALID_FILE_ATTRIBUTES
)
3736 res
= SetFileAttributes (wto
, attribs
);
3744 GNAT_STRUCT_STAT fbuf
;
3745 struct utimbuf tbuf
;
3747 if (GNAT_STAT (from
, &fbuf
) == -1)
3752 tbuf
.actime
= fbuf
.st_atime
;
3753 tbuf
.modtime
= fbuf
.st_mtime
;
3755 if (utime (to
, &tbuf
) == -1)
3762 if (chmod (to
, fbuf
.st_mode
) == -1)
3773 __gnat_lseek (int fd
, long offset
, int whence
)
3775 return (int) lseek (fd
, offset
, whence
);
3778 /* This function returns the major version number of GCC being used. */
3780 get_gcc_version (void)
3785 return (int) (version_string
[0] - '0');
3790 * Set Close_On_Exec as indicated.
3791 * Note: this is used for both GNAT.OS_Lib and GNAT.Sockets.
3795 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED
,
3796 int close_on_exec_p ATTRIBUTE_UNUSED
)
3798 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3799 int flags
= fcntl (fd
, F_GETFD
, 0);
3802 if (close_on_exec_p
)
3803 flags
|= FD_CLOEXEC
;
3805 flags
&= ~FD_CLOEXEC
;
3806 return fcntl (fd
, F_SETFD
, flags
| FD_CLOEXEC
);
3807 #elif defined(_WIN32)
3808 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
3809 if (h
== (HANDLE
) -1)
3811 if (close_on_exec_p
)
3812 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
, 0);
3813 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
,
3814 HANDLE_FLAG_INHERIT
);
3816 /* TODO: Unimplemented. */
3821 /* Indicates if platforms supports automatic initialization through the
3822 constructor mechanism */
3824 __gnat_binder_supports_auto_init (void)
3833 /* Indicates that Stand-Alone Libraries are automatically initialized through
3834 the constructor mechanism */
3836 __gnat_sals_init_using_constructors (void)
3838 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3847 /* In RTX mode, the procedure to get the time (as file time) is different
3848 in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3849 we introduce an intermediate procedure to link against the corresponding
3850 one in each situation. */
3852 extern void GetTimeAsFileTime (LPFILETIME pTime
);
3854 void GetTimeAsFileTime (LPFILETIME pTime
)
3857 RtGetRtssTimeAsFileTime (pTime
); /* RTSS interface */
3859 GetSystemTimeAsFileTime (pTime
); /* w32 interface */
3864 /* Add symbol that is required to link. It would otherwise be taken from
3865 libgcc.a and it would try to use the gcc constructors that are not
3866 supported by Microsoft linker. */
3868 extern void __main (void);
3876 #if defined (__ANDROID__)
3878 #include <pthread.h>
3881 __gnat_lwp_self (void)
3883 return (void *) pthread_self ();
3886 #elif defined (linux)
3887 /* There is no function in the glibc to retrieve the LWP of the current
3888 thread. We need to do a system call in order to retrieve this
3890 #include <sys/syscall.h>
3892 __gnat_lwp_self (void)
3894 return (void *) syscall (__NR_gettid
);
3899 /* glibc versions earlier than 2.7 do not define the routines to handle
3900 dynamically allocated CPU sets. For these targets, we use the static
3905 /* Dynamic cpu sets */
3908 __gnat_cpu_alloc (size_t count
)
3910 return CPU_ALLOC (count
);
3914 __gnat_cpu_alloc_size (size_t count
)
3916 return CPU_ALLOC_SIZE (count
);
3920 __gnat_cpu_free (cpu_set_t
*set
)
3926 __gnat_cpu_zero (size_t count
, cpu_set_t
*set
)
3928 CPU_ZERO_S (count
, set
);
3932 __gnat_cpu_set (int cpu
, size_t count
, cpu_set_t
*set
)
3934 /* Ada handles CPU numbers starting from 1, while C identifies the first
3935 CPU by a 0, so we need to adjust. */
3936 CPU_SET_S (cpu
- 1, count
, set
);
3939 #else /* !CPU_ALLOC */
3941 /* Static cpu sets */
3944 __gnat_cpu_alloc (size_t count ATTRIBUTE_UNUSED
)
3946 return (cpu_set_t
*) xmalloc (sizeof (cpu_set_t
));
3950 __gnat_cpu_alloc_size (size_t count ATTRIBUTE_UNUSED
)
3952 return sizeof (cpu_set_t
);
3956 __gnat_cpu_free (cpu_set_t
*set
)
3962 __gnat_cpu_zero (size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
3968 __gnat_cpu_set (int cpu
, size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
3970 /* Ada handles CPU numbers starting from 1, while C identifies the first
3971 CPU by a 0, so we need to adjust. */
3972 CPU_SET (cpu
- 1, set
);
3974 #endif /* !CPU_ALLOC */
3977 /* Return the load address of the executable, or 0 if not known. In the
3978 specific case of error, (void *)-1 can be returned. Beware: this unit may
3979 be in a shared library. As low-level units are needed, we allow #include
3982 #if defined (__APPLE__)
3983 #include <mach-o/dyld.h>
3984 #elif 0 && defined (__linux__)
3989 __gnat_get_executable_load_address (void)
3991 #if defined (__APPLE__)
3992 return _dyld_get_image_header (0);
3994 #elif 0 && defined (__linux__)
3995 /* Currently disabled as it needs at least -ldl. */
3996 struct link_map
*map
= _r_debug
.r_map
;
3998 return (const void *)map
->l_addr
;