1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2013, 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 Ada bindings */
354 int __gnat_size_of_file_attributes
= sizeof (struct file_attributes
);
356 void __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
);
358 /* The __gnat_max_path_len variable is used to export the maximum
359 length of a path name to Ada code. max_path_len is also provided
360 for compatibility with older GNAT versions, please do not use
363 int __gnat_max_path_len
= GNAT_MAX_PATH_LEN
;
364 int max_path_len
= GNAT_MAX_PATH_LEN
;
366 /* Control whether we can use ACL on Windows. */
368 int __gnat_use_acl
= 1;
370 /* The following macro HAVE_READDIR_R should be defined if the
371 system provides the routine readdir_r. */
372 #undef HAVE_READDIR_R
374 #if defined(VMS) && defined (__LONG_POINTERS)
376 /* Return a 32 bit pointer to an array of 32 bit pointers
377 given a 64 bit pointer to an array of 64 bit pointers */
379 typedef __char_ptr32
*__char_ptr_char_ptr32
__attribute__ ((mode (SI
)));
381 static __char_ptr_char_ptr32
382 to_ptr32 (char **ptr64
)
385 __char_ptr_char_ptr32 short_argv
;
387 for (argc
= 0; ptr64
[argc
]; argc
++)
390 /* Reallocate argv with 32 bit pointers. */
391 short_argv
= (__char_ptr_char_ptr32
) decc$malloc
392 (sizeof (__char_ptr32
) * (argc
+ 1));
394 for (argc
= 0; ptr64
[argc
]; argc
++)
395 short_argv
[argc
] = (__char_ptr32
) decc$
strdup (ptr64
[argc
]);
397 short_argv
[argc
] = (__char_ptr32
) 0;
401 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
403 #define MAYBE_TO_PTR32(argv) argv
406 static const char ATTR_UNSET
= 127;
408 /* Reset the file attributes as if no system call had been performed */
411 __gnat_reset_attributes (struct file_attributes
* attr
)
413 attr
->exists
= ATTR_UNSET
;
415 attr
->writable
= ATTR_UNSET
;
416 attr
->readable
= ATTR_UNSET
;
417 attr
->executable
= ATTR_UNSET
;
419 attr
->regular
= ATTR_UNSET
;
420 attr
->symbolic_link
= ATTR_UNSET
;
421 attr
->directory
= ATTR_UNSET
;
423 attr
->timestamp
= (OS_Time
)-2;
424 attr
->file_length
= -1;
428 __gnat_current_time (void)
430 time_t res
= time (NULL
);
431 return (OS_Time
) res
;
434 /* Return the current local time as a string in the ISO 8601 format of
435 "YYYY-MM-DD HH:MM:SS.SS". The returned string is 22 + 1 (NULL) characters
439 __gnat_current_time_string (char *result
)
441 const char *format
= "%Y-%m-%d %H:%M:%S";
442 /* Format string necessary to describe the ISO 8601 format */
444 const time_t t_val
= time (NULL
);
446 strftime (result
, 22, format
, localtime (&t_val
));
447 /* Convert the local time into a string following the ISO format, copying
448 at most 22 characters into the result string. */
453 /* The sub-seconds are manually set to zero since type time_t lacks the
454 precision necessary for nanoseconds. */
458 __gnat_to_gm_time (OS_Time
*p_time
, int *p_year
, int *p_month
, int *p_day
,
459 int *p_hours
, int *p_mins
, int *p_secs
)
462 time_t time
= (time_t) *p_time
;
465 /* On Windows systems, the time is sometimes rounded up to the nearest
466 even second, so if the number of seconds is odd, increment it. */
472 res
= localtime (&time
);
474 res
= gmtime (&time
);
479 *p_year
= res
->tm_year
;
480 *p_month
= res
->tm_mon
;
481 *p_day
= res
->tm_mday
;
482 *p_hours
= res
->tm_hour
;
483 *p_mins
= res
->tm_min
;
484 *p_secs
= res
->tm_sec
;
487 *p_year
= *p_month
= *p_day
= *p_hours
= *p_mins
= *p_secs
= 0;
490 /* Place the contents of the symbolic link named PATH in the buffer BUF,
491 which has size BUFSIZ. If PATH is a symbolic link, then return the number
492 of characters of its content in BUF. Otherwise, return -1.
493 For systems not supporting symbolic links, always return -1. */
496 __gnat_readlink (char *path ATTRIBUTE_UNUSED
,
497 char *buf ATTRIBUTE_UNUSED
,
498 size_t bufsiz ATTRIBUTE_UNUSED
)
500 #if defined (_WIN32) || defined (VMS) \
501 || defined(__vxworks) || defined (__nucleus__)
504 return readlink (path
, buf
, bufsiz
);
508 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH.
509 If NEWPATH exists it will NOT be overwritten.
510 For systems not supporting symbolic links, always return -1. */
513 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED
,
514 char *newpath ATTRIBUTE_UNUSED
)
516 #if defined (_WIN32) || defined (VMS) \
517 || defined(__vxworks) || defined (__nucleus__)
520 return symlink (oldpath
, newpath
);
524 /* Try to lock a file, return 1 if success. */
526 #if defined (__vxworks) || defined (__nucleus__) \
527 || defined (_WIN32) || defined (VMS)
529 /* Version that does not use link. */
532 __gnat_try_lock (char *dir
, char *file
)
536 TCHAR wfull_path
[GNAT_MAX_PATH_LEN
];
537 TCHAR wfile
[GNAT_MAX_PATH_LEN
];
538 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
540 S2WSC (wdir
, dir
, GNAT_MAX_PATH_LEN
);
541 S2WSC (wfile
, file
, GNAT_MAX_PATH_LEN
);
543 _stprintf (wfull_path
, _T("%s%c%s"), wdir
, _T(DIR_SEPARATOR
), wfile
);
544 fd
= _topen (wfull_path
, O_CREAT
| O_EXCL
, 0600);
548 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
549 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
561 /* Version using link(), more secure over NFS. */
562 /* See TN 6913-016 for discussion ??? */
565 __gnat_try_lock (char *dir
, char *file
)
569 GNAT_STRUCT_STAT stat_result
;
572 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
573 sprintf (temp_file
, "%s%cTMP-%ld-%ld",
574 dir
, DIR_SEPARATOR
, (long)getpid(), (long)getppid ());
576 /* Create the temporary file and write the process number. */
577 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
583 /* Link it with the new file. */
584 link (temp_file
, full_path
);
586 /* Count the references on the old one. If we have a count of two, then
587 the link did succeed. Remove the temporary file before returning. */
588 __gnat_stat (temp_file
, &stat_result
);
590 return stat_result
.st_nlink
== 2;
594 /* Return the maximum file name length. */
597 __gnat_get_maximum_file_name_length (void)
600 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
609 /* Return nonzero if file names are case sensitive. */
611 static int file_names_case_sensitive_cache
= -1;
614 __gnat_get_file_names_case_sensitive (void)
616 if (file_names_case_sensitive_cache
== -1)
618 const char *sensitive
= getenv ("GNAT_FILE_NAME_CASE_SENSITIVE");
620 if (sensitive
!= NULL
621 && (sensitive
[0] == '0' || sensitive
[0] == '1')
622 && sensitive
[1] == '\0')
623 file_names_case_sensitive_cache
= sensitive
[0] - '0';
625 #if defined (VMS) || defined (WINNT) || defined (__APPLE__)
626 file_names_case_sensitive_cache
= 0;
628 file_names_case_sensitive_cache
= 1;
631 return file_names_case_sensitive_cache
;
634 /* Return nonzero if environment variables are case sensitive. */
637 __gnat_get_env_vars_case_sensitive (void)
639 #if defined (VMS) || defined (WINNT)
647 __gnat_get_default_identifier_character_set (void)
652 /* Return the current working directory. */
655 __gnat_get_current_dir (char *dir
, int *length
)
657 #if defined (__MINGW32__)
658 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
660 _tgetcwd (wdir
, *length
);
662 WS2SC (dir
, wdir
, GNAT_MAX_PATH_LEN
);
665 /* Force Unix style, which is what GNAT uses internally. */
666 getcwd (dir
, *length
, 0);
668 getcwd (dir
, *length
);
671 *length
= strlen (dir
);
673 if (dir
[*length
- 1] != DIR_SEPARATOR
)
675 dir
[*length
] = DIR_SEPARATOR
;
681 /* Return the suffix for object files. */
684 __gnat_get_object_suffix_ptr (int *len
, const char **value
)
686 *value
= HOST_OBJECT_SUFFIX
;
691 *len
= strlen (*value
);
696 /* Return the suffix for executable files. */
699 __gnat_get_executable_suffix_ptr (int *len
, const char **value
)
701 *value
= HOST_EXECUTABLE_SUFFIX
;
705 *len
= strlen (*value
);
710 /* Return the suffix for debuggable files. Usually this is the same as the
711 executable extension. */
714 __gnat_get_debuggable_suffix_ptr (int *len
, const char **value
)
716 *value
= HOST_EXECUTABLE_SUFFIX
;
721 *len
= strlen (*value
);
726 /* Returns the OS filename and corresponding encoding. */
729 __gnat_os_filename (char *filename ATTRIBUTE_UNUSED
,
730 char *w_filename ATTRIBUTE_UNUSED
,
731 char *os_name
, int *o_length
,
732 char *encoding ATTRIBUTE_UNUSED
, int *e_length
)
734 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
735 WS2SC (os_name
, (TCHAR
*)w_filename
, (DWORD
)*o_length
);
736 *o_length
= strlen (os_name
);
737 strcpy (encoding
, "encoding=utf8");
738 *e_length
= strlen (encoding
);
740 strcpy (os_name
, filename
);
741 *o_length
= strlen (filename
);
749 __gnat_unlink (char *path
)
751 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
753 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
755 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
756 return _tunlink (wpath
);
759 return unlink (path
);
766 __gnat_rename (char *from
, char *to
)
768 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
770 TCHAR wfrom
[GNAT_MAX_PATH_LEN
], wto
[GNAT_MAX_PATH_LEN
];
772 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
);
773 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
);
774 return _trename (wfrom
, wto
);
777 return rename (from
, to
);
781 /* Changing directory. */
784 __gnat_chdir (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 _tchdir (wpath
);
798 /* Removing a directory. */
801 __gnat_rmdir (char *path
)
803 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
805 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
807 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
808 return _trmdir (wpath
);
810 #elif defined (VTHREADS)
811 /* rmdir not available */
819 __gnat_fopen (char *path
, char *mode
, int encoding ATTRIBUTE_UNUSED
,
820 char *vms_form ATTRIBUTE_UNUSED
)
822 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
823 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
826 S2WS (wmode
, mode
, 10);
828 if (encoding
== Encoding_Unspecified
)
829 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
830 else if (encoding
== Encoding_UTF8
)
831 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
833 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
835 return _tfopen (wpath
, wmode
);
838 return decc$
fopen (path
, mode
);
841 char *local_form
= (char *) alloca (strlen (vms_form
) + 1);
842 /* Allocate an argument list of guaranteed ample length. */
843 unsigned long long *arg_list
=
844 (unsigned long long *) alloca (strlen (vms_form
) + 3);
848 arg_list
[1] = (unsigned long long) path
;
849 arg_list
[2] = (unsigned long long) mode
;
850 strcpy (local_form
, vms_form
);
852 /* Given a string such as "\"rfm=udf\",\"rat=cr\""
853 Split it into an argument list as "rfm=udf","rat=cr". */
855 for (i
= 0; *ptrb
; i
++)
857 ptrb
= strchr (ptrb
, '"');
858 ptre
= strchr (ptrb
+ 1, '"');
860 arg_list
[i
+ 3] = (unsigned long long) (ptrb
+ 1);
863 arg_list
[0] = i
+ 2;
864 /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
865 always a 32bit pointer. */
866 return LIB$
CALLG_64 (arg_list
, &decc$fopen
);
869 return GNAT_FOPEN (path
, mode
);
874 __gnat_freopen (char *path
,
877 int encoding ATTRIBUTE_UNUSED
,
878 char *vms_form ATTRIBUTE_UNUSED
)
880 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
881 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
884 S2WS (wmode
, mode
, 10);
886 if (encoding
== Encoding_Unspecified
)
887 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
888 else if (encoding
== Encoding_UTF8
)
889 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
891 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
893 return _tfreopen (wpath
, wmode
, stream
);
896 return decc$
freopen (path
, mode
, stream
);
899 char *local_form
= (char *) alloca (strlen (vms_form
) + 1);
900 /* Allocate an argument list of guaranteed ample length. */
901 unsigned long long *arg_list
=
902 (unsigned long long *) alloca (strlen (vms_form
) + 4);
906 arg_list
[1] = (unsigned long long) path
;
907 arg_list
[2] = (unsigned long long) mode
;
908 arg_list
[3] = (unsigned long long) stream
;
909 strcpy (local_form
, vms_form
);
911 /* Given a string such as "\"rfm=udf\",\"rat=cr\""
912 Split it into an argument list as "rfm=udf","rat=cr". */
914 for (i
= 0; *ptrb
; i
++)
916 ptrb
= strchr (ptrb
, '"');
917 ptre
= strchr (ptrb
+ 1, '"');
919 arg_list
[i
+ 4] = (unsigned long long) (ptrb
+ 1);
922 arg_list
[0] = i
+ 3;
923 /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
924 always a 32bit pointer. */
925 return LIB$
CALLG_64 (arg_list
, &decc$freopen
);
928 return freopen (path
, mode
, stream
);
933 __gnat_open_read (char *path
, int fmode
)
936 int o_fmode
= O_BINARY
;
942 /* Optional arguments mbc,deq,fop increase read performance. */
943 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
944 "mbc=16", "deq=64", "fop=tef");
945 #elif defined (__vxworks)
946 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
947 #elif defined (__MINGW32__)
949 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
951 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
952 fd
= _topen (wpath
, O_RDONLY
| o_fmode
, 0444);
955 fd
= open (path
, O_RDONLY
| o_fmode
);
958 return fd
< 0 ? -1 : fd
;
961 #if defined (__MINGW32__)
962 #define PERM (S_IREAD | S_IWRITE)
964 /* Excerpt from DECC C RTL Reference Manual:
965 To create files with OpenVMS RMS default protections using the UNIX
966 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
967 and open with a file-protection mode argument of 0777 in a program
968 that never specifically calls umask. These default protections include
969 correctly establishing protections based on ACLs, previous versions of
973 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
977 __gnat_open_rw (char *path
, int fmode
)
980 int o_fmode
= O_BINARY
;
986 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
987 "mbc=16", "deq=64", "fop=tef");
988 #elif defined (__MINGW32__)
990 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
992 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
993 fd
= _topen (wpath
, O_RDWR
| o_fmode
, PERM
);
996 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
999 return fd
< 0 ? -1 : fd
;
1003 __gnat_open_create (char *path
, int fmode
)
1006 int o_fmode
= O_BINARY
;
1012 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
1013 "mbc=16", "deq=64", "fop=tef");
1014 #elif defined (__MINGW32__)
1016 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1018 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1019 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
1022 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
1025 return fd
< 0 ? -1 : fd
;
1029 __gnat_create_output_file (char *path
)
1033 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
,
1034 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
1035 "shr=del,get,put,upd");
1036 #elif defined (__MINGW32__)
1038 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1040 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1041 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
1044 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
1047 return fd
< 0 ? -1 : fd
;
1051 __gnat_create_output_file_new (char *path
)
1055 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
,
1056 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
1057 "shr=del,get,put,upd");
1058 #elif defined (__MINGW32__)
1060 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1062 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1063 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
1066 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
1069 return fd
< 0 ? -1 : fd
;
1073 __gnat_open_append (char *path
, int fmode
)
1076 int o_fmode
= O_BINARY
;
1082 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
1083 "mbc=16", "deq=64", "fop=tef");
1084 #elif defined (__MINGW32__)
1086 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1088 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1089 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
1092 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
1095 return fd
< 0 ? -1 : fd
;
1098 /* Open a new file. Return error (-1) if the file already exists. */
1101 __gnat_open_new (char *path
, int fmode
)
1104 int o_fmode
= O_BINARY
;
1110 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1111 "mbc=16", "deq=64", "fop=tef");
1112 #elif defined (__MINGW32__)
1114 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1116 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1117 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1120 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1123 return fd
< 0 ? -1 : fd
;
1126 /* Open a new temp file. Return error (-1) if the file already exists.
1127 Special options for VMS allow the file to be shared between parent and child
1128 processes, however they really slow down output. Used in gnatchop. */
1131 __gnat_open_new_temp (char *path
, int fmode
)
1134 int o_fmode
= O_BINARY
;
1136 strcpy (path
, "GNAT-XXXXXX");
1138 #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \
1139 || defined (linux) || defined(__GLIBC__)) && !defined (__vxworks)
1140 return mkstemp (path
);
1141 #elif defined (__Lynx__)
1143 #elif defined (__nucleus__)
1146 if (mktemp (path
) == NULL
)
1154 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1155 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
1156 "mbc=16", "deq=64", "fop=tef");
1158 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1161 return fd
< 0 ? -1 : fd
;
1164 /****************************************************************
1165 ** Perform a call to GNAT_STAT or GNAT_FSTAT, and extract as much information
1166 ** as possible from it, storing the result in a cache for later reuse
1167 ****************************************************************/
1170 __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
)
1172 GNAT_STRUCT_STAT statbuf
;
1176 ret
= GNAT_FSTAT (fd
, &statbuf
);
1178 ret
= __gnat_stat (name
, &statbuf
);
1180 attr
->regular
= (!ret
&& S_ISREG (statbuf
.st_mode
));
1181 attr
->directory
= (!ret
&& S_ISDIR (statbuf
.st_mode
));
1184 attr
->file_length
= 0;
1186 /* st_size may be 32 bits, or 64 bits which is converted to long. We
1187 don't return a useful value for files larger than 2 gigabytes in
1189 attr
->file_length
= statbuf
.st_size
; /* all systems */
1191 attr
->exists
= !ret
;
1193 #if !defined (_WIN32) || defined (RTX)
1194 /* on Windows requires extra system call, see __gnat_is_readable_file_attr */
1195 attr
->readable
= (!ret
&& (statbuf
.st_mode
& S_IRUSR
));
1196 attr
->writable
= (!ret
&& (statbuf
.st_mode
& S_IWUSR
));
1197 attr
->executable
= (!ret
&& (statbuf
.st_mode
& S_IXUSR
));
1201 attr
->timestamp
= (OS_Time
)-1;
1204 /* VMS has file versioning. */
1205 attr
->timestamp
= (OS_Time
)statbuf
.st_ctime
;
1207 attr
->timestamp
= (OS_Time
)statbuf
.st_mtime
;
1212 /****************************************************************
1213 ** Return the number of bytes in the specified file
1214 ****************************************************************/
1217 __gnat_file_length_attr (int fd
, char* name
, struct file_attributes
* attr
)
1219 if (attr
->file_length
== -1) {
1220 __gnat_stat_to_attr (fd
, name
, attr
);
1223 return attr
->file_length
;
1227 __gnat_file_length (int fd
)
1229 struct file_attributes attr
;
1230 __gnat_reset_attributes (&attr
);
1231 return __gnat_file_length_attr (fd
, NULL
, &attr
);
1235 __gnat_named_file_length (char *name
)
1237 struct file_attributes attr
;
1238 __gnat_reset_attributes (&attr
);
1239 return __gnat_file_length_attr (-1, name
, &attr
);
1242 /* Create a temporary filename and put it in string pointed to by
1246 __gnat_tmp_name (char *tmp_filename
)
1249 /* Variable used to create a series of unique names */
1250 static int counter
= 0;
1252 /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */
1253 strcpy (tmp_filename
, "c:\\WINDOWS\\Temp\\gnat-");
1254 sprintf (&tmp_filename
[strlen (tmp_filename
)], "%d\0", counter
++);
1256 #elif defined (__MINGW32__)
1261 /* tempnam tries to create a temporary file in directory pointed to by
1262 TMP environment variable, in c:\temp if TMP is not set, and in
1263 directory specified by P_tmpdir in stdio.h if c:\temp does not
1264 exist. The filename will be created with the prefix "gnat-". */
1266 sprintf (prefix
, "gnat-%d-", (int)getpid());
1267 pname
= (char *) _tempnam ("c:\\temp", prefix
);
1269 /* if pname is NULL, the file was not created properly, the disk is full
1270 or there is no more free temporary files */
1273 *tmp_filename
= '\0';
1275 /* If pname start with a back slash and not path information it means that
1276 the filename is valid for the current working directory. */
1278 else if (pname
[0] == '\\')
1280 strcpy (tmp_filename
, ".\\");
1281 strcat (tmp_filename
, pname
+1);
1284 strcpy (tmp_filename
, pname
);
1289 #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \
1290 || defined (__OpenBSD__) || defined(__GLIBC__)
1291 #define MAX_SAFE_PATH 1000
1292 char *tmpdir
= getenv ("TMPDIR");
1294 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
1295 a buffer overflow. */
1296 if (tmpdir
== NULL
|| strlen (tmpdir
) > MAX_SAFE_PATH
)
1297 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
1299 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
1301 close (mkstemp(tmp_filename
));
1302 #elif defined (__vxworks) && !(defined (__RTP__) || defined (VTHREADS))
1306 static ushort_t seed
= 0; /* used to generate unique name */
1308 /* generate unique name */
1309 strcpy (tmp_filename
, "tmp");
1311 /* fill up the name buffer from the last position */
1313 pos
= tmp_filename
+ strlen (tmp_filename
) + index
;
1317 for (t
= seed
; 0 <= --index
; t
>>= 3)
1318 *--pos
= '0' + (t
& 07);
1320 tmpnam (tmp_filename
);
1324 /* Open directory and returns a DIR pointer. */
1326 DIR* __gnat_opendir (char *name
)
1329 /* Not supported in RTX */
1333 #elif defined (__MINGW32__)
1334 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1336 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1337 return (DIR*)_topendir (wname
);
1340 return opendir (name
);
1344 /* Read the next entry in a directory. The returned string points somewhere
1348 __gnat_readdir (DIR *dirp
, char *buffer
, int *len
)
1351 /* Not supported in RTX */
1355 #elif defined (__MINGW32__)
1356 struct _tdirent
*dirent
= _treaddir ((_TDIR
*)dirp
);
1360 WS2SC (buffer
, dirent
->d_name
, GNAT_MAX_PATH_LEN
);
1361 *len
= strlen (buffer
);
1368 #elif defined (HAVE_READDIR_R)
1369 /* If possible, try to use the thread-safe version. */
1370 if (readdir_r (dirp
, buffer
) != NULL
)
1372 *len
= strlen (((struct dirent
*) buffer
)->d_name
);
1373 return ((struct dirent
*) buffer
)->d_name
;
1379 struct dirent
*dirent
= (struct dirent
*) readdir (dirp
);
1383 strcpy (buffer
, dirent
->d_name
);
1384 *len
= strlen (buffer
);
1393 /* Close a directory entry. */
1395 int __gnat_closedir (DIR *dirp
)
1398 /* Not supported in RTX */
1402 #elif defined (__MINGW32__)
1403 return _tclosedir ((_TDIR
*)dirp
);
1406 return closedir (dirp
);
1410 /* Returns 1 if readdir is thread safe, 0 otherwise. */
1413 __gnat_readdir_is_thread_safe (void)
1415 #ifdef HAVE_READDIR_R
1422 #if defined (_WIN32) && !defined (RTX)
1423 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
1424 static const unsigned long long w32_epoch_offset
= 11644473600ULL;
1426 /* Returns the file modification timestamp using Win32 routines which are
1427 immune against daylight saving time change. It is in fact not possible to
1428 use fstat for this purpose as the DST modify the st_mtime field of the
1432 win32_filetime (HANDLE h
)
1437 unsigned long long ull_time
;
1440 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1441 since <Jan 1st 1601>. This function must return the number of seconds
1442 since <Jan 1st 1970>. */
1444 if (GetFileTime (h
, NULL
, NULL
, &t_write
.ft_time
))
1445 return (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1449 /* As above but starting from a FILETIME. */
1451 f2t (const FILETIME
*ft
, time_t *t
)
1456 unsigned long long ull_time
;
1459 t_write
.ft_time
= *ft
;
1460 *t
= (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1464 /* Return a GNAT time stamp given a file name. */
1467 __gnat_file_time_name_attr (char* name
, struct file_attributes
* attr
)
1469 if (attr
->timestamp
== (OS_Time
)-2) {
1470 #if defined (_WIN32) && !defined (RTX)
1472 WIN32_FILE_ATTRIBUTE_DATA fad
;
1474 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1475 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1477 if ((res
= GetFileAttributesEx (wname
, GetFileExInfoStandard
, &fad
)))
1478 f2t (&fad
.ftLastWriteTime
, &ret
);
1479 attr
->timestamp
= (OS_Time
) ret
;
1481 __gnat_stat_to_attr (-1, name
, attr
);
1484 return attr
->timestamp
;
1488 __gnat_file_time_name (char *name
)
1490 struct file_attributes attr
;
1491 __gnat_reset_attributes (&attr
);
1492 return __gnat_file_time_name_attr (name
, &attr
);
1495 /* Return a GNAT time stamp given a file descriptor. */
1498 __gnat_file_time_fd_attr (int fd
, struct file_attributes
* attr
)
1500 if (attr
->timestamp
== (OS_Time
)-2) {
1501 #if defined (_WIN32) && !defined (RTX)
1502 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
1503 time_t ret
= win32_filetime (h
);
1504 attr
->timestamp
= (OS_Time
) ret
;
1507 __gnat_stat_to_attr (fd
, NULL
, attr
);
1511 return attr
->timestamp
;
1515 __gnat_file_time_fd (int fd
)
1517 struct file_attributes attr
;
1518 __gnat_reset_attributes (&attr
);
1519 return __gnat_file_time_fd_attr (fd
, &attr
);
1522 /* Set the file time stamp. */
1525 __gnat_set_file_time_name (char *name
, time_t time_stamp
)
1527 #if defined (__vxworks)
1529 /* Code to implement __gnat_set_file_time_name for these systems. */
1531 #elif defined (_WIN32) && !defined (RTX)
1535 unsigned long long ull_time
;
1537 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1539 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1541 HANDLE h
= CreateFile
1542 (wname
, GENERIC_WRITE
, FILE_SHARE_WRITE
, NULL
,
1543 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
,
1545 if (h
== INVALID_HANDLE_VALUE
)
1547 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1548 t_write
.ull_time
= ((unsigned long long)time_stamp
+ w32_epoch_offset
);
1549 /* Convert to 100 nanosecond units */
1550 t_write
.ull_time
*= 10000000ULL;
1552 SetFileTime(h
, NULL
, NULL
, &t_write
.ft_time
);
1562 unsigned long long backup
, create
, expire
, revise
;
1566 unsigned short value
;
1569 unsigned system
: 4;
1575 } Fat
= { 0, 0, 0, 0, 0, { 0 }};
1579 { ATR$S_CREDATE
, ATR$C_CREDATE
, &Fat
.create
},
1580 { ATR$S_REVDATE
, ATR$C_REVDATE
, &Fat
.revise
},
1581 { ATR$S_EXPDATE
, ATR$C_EXPDATE
, &Fat
.expire
},
1582 { ATR$S_BAKDATE
, ATR$C_BAKDATE
, &Fat
.backup
},
1583 { ATR$S_FPRO
, ATR$C_FPRO
, &Fat
.prot
},
1584 { ATR$S_UIC
, ATR$C_UIC
, &Fat
.uic
},
1589 struct dsc$descriptor_fib fibdsc
= {sizeof (fib
), (void *) &fib
};
1593 unsigned long long newtime
;
1594 unsigned long long revtime
;
1598 struct vstring file
;
1599 struct dsc$descriptor_s filedsc
1600 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) file
.string
};
1601 struct vstring device
;
1602 struct dsc$descriptor_s devicedsc
1603 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) device
.string
};
1604 struct vstring timev
;
1605 struct dsc$descriptor_s timedsc
1606 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) timev
.string
};
1607 struct vstring result
;
1608 struct dsc$descriptor_s resultdsc
1609 = {NAM$C_MAXRSS
, DSC$K_DTYPE_VT
, DSC$K_CLASS_VS
, (void *) result
.string
};
1611 /* Convert parameter name (a file spec) to host file form. Note that this
1612 is needed on VMS to prepare for subsequent calls to VMS RMS library
1613 routines. Note that it would not work to call __gnat_to_host_dir_spec
1614 as was done in a previous version, since this fails silently unless
1615 the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1616 (directory not found) condition is signalled. */
1617 tryfile
= (char *) __gnat_to_host_file_spec (name
);
1619 /* Allocate and initialize a FAB and NAM structures. */
1623 nam
.nam$l_esa
= file
.string
;
1624 nam
.nam$b_ess
= NAM$C_MAXRSS
;
1625 nam
.nam$l_rsa
= result
.string
;
1626 nam
.nam$b_rss
= NAM$C_MAXRSS
;
1627 fab
.fab$l_fna
= tryfile
;
1628 fab
.fab$b_fns
= strlen (tryfile
);
1629 fab
.fab$l_nam
= &nam
;
1631 /* Validate filespec syntax and device existence. */
1632 status
= SYS$
PARSE (&fab
, 0, 0);
1633 if ((status
& 1) != 1)
1634 LIB$
SIGNAL (status
);
1636 file
.string
[nam
.nam$b_esl
] = 0;
1638 /* Find matching filespec. */
1639 status
= SYS$
SEARCH (&fab
, 0, 0);
1640 if ((status
& 1) != 1)
1641 LIB$
SIGNAL (status
);
1643 file
.string
[nam
.nam$b_esl
] = 0;
1644 result
.string
[result
.length
=nam
.nam$b_rsl
] = 0;
1646 /* Get the device name and assign an IO channel. */
1647 strncpy (device
.string
, nam
.nam$l_dev
, nam
.nam$b_dev
);
1648 devicedsc
.dsc$w_length
= nam
.nam$b_dev
;
1650 status
= SYS$
ASSIGN (&devicedsc
, &chan
, 0, 0, 0);
1651 if ((status
& 1) != 1)
1652 LIB$
SIGNAL (status
);
1654 /* Initialize the FIB and fill in the directory id field. */
1655 memset (&fib
, 0, sizeof (fib
));
1656 fib
.fib$w_did
[0] = nam
.nam$w_did
[0];
1657 fib
.fib$w_did
[1] = nam
.nam$w_did
[1];
1658 fib
.fib$w_did
[2] = nam
.nam$w_did
[2];
1659 fib
.fib$l_acctl
= 0;
1661 strcpy (file
.string
, (strrchr (result
.string
, ']') + 1));
1662 filedsc
.dsc$w_length
= strlen (file
.string
);
1663 result
.string
[result
.length
= 0] = 0;
1665 /* Open and close the file to fill in the attributes. */
1667 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1668 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1669 if ((status
& 1) != 1)
1670 LIB$
SIGNAL (status
);
1671 if ((iosb
.status
& 1) != 1)
1672 LIB$
SIGNAL (iosb
.status
);
1674 result
.string
[result
.length
] = 0;
1675 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0, &fibdsc
, 0, 0, 0,
1677 if ((status
& 1) != 1)
1678 LIB$
SIGNAL (status
);
1679 if ((iosb
.status
& 1) != 1)
1680 LIB$
SIGNAL (iosb
.status
);
1685 /* Set creation time to requested time. */
1686 unix_time_to_vms (time_stamp
, newtime
);
1688 t
= time ((time_t) 0);
1690 /* Set revision time to now in local time. */
1691 unix_time_to_vms (t
, revtime
);
1694 /* Reopen the file, modify the times and then close. */
1695 fib
.fib$l_acctl
= FIB$M_WRITE
;
1697 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1698 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1699 if ((status
& 1) != 1)
1700 LIB$
SIGNAL (status
);
1701 if ((iosb
.status
& 1) != 1)
1702 LIB$
SIGNAL (iosb
.status
);
1704 Fat
.create
= newtime
;
1705 Fat
.revise
= revtime
;
1707 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0,
1708 &fibdsc
, 0, 0, 0, &atrlst
, 0);
1709 if ((status
& 1) != 1)
1710 LIB$
SIGNAL (status
);
1711 if ((iosb
.status
& 1) != 1)
1712 LIB$
SIGNAL (iosb
.status
);
1714 /* Deassign the channel and exit. */
1715 status
= SYS$
DASSGN (chan
);
1716 if ((status
& 1) != 1)
1717 LIB$
SIGNAL (status
);
1719 struct utimbuf utimbuf
;
1722 /* Set modification time to requested time. */
1723 utimbuf
.modtime
= time_stamp
;
1725 /* Set access time to now in local time. */
1726 t
= time ((time_t) 0);
1727 utimbuf
.actime
= mktime (localtime (&t
));
1729 utime (name
, &utimbuf
);
1733 /* Get the list of installed standard libraries from the
1734 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1738 __gnat_get_libraries_from_registry (void)
1740 char *result
= (char *) xmalloc (1);
1744 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) \
1748 DWORD name_size
, value_size
;
1755 /* First open the key. */
1756 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1758 if (res
== ERROR_SUCCESS
)
1759 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1760 KEY_READ
, ®_key
);
1762 if (res
== ERROR_SUCCESS
)
1763 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1765 if (res
== ERROR_SUCCESS
)
1766 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1768 /* If the key exists, read out all the values in it and concatenate them
1770 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1772 value_size
= name_size
= 256;
1773 res
= RegEnumValueA (reg_key
, index
, name
, &name_size
, 0,
1774 &type
, (LPBYTE
)value
, &value_size
);
1776 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1778 char *old_result
= result
;
1780 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1781 strcpy (result
, old_result
);
1782 strcat (result
, value
);
1783 strcat (result
, ";");
1788 /* Remove the trailing ";". */
1790 result
[strlen (result
) - 1] = 0;
1797 __gnat_stat (char *name
, GNAT_STRUCT_STAT
*statbuf
)
1800 WIN32_FILE_ATTRIBUTE_DATA fad
;
1801 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
1806 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
1807 name_len
= _tcslen (wname
);
1809 if (name_len
> GNAT_MAX_PATH_LEN
)
1812 ZeroMemory (statbuf
, sizeof(GNAT_STRUCT_STAT
));
1814 res
= GetFileAttributesEx (wname
, GetFileExInfoStandard
, &fad
);
1817 error
= GetLastError();
1819 /* Check file existence using GetFileAttributes() which does not fail on
1820 special Windows files like con:, aux:, nul: etc... */
1822 if (GetFileAttributes(wname
) != INVALID_FILE_ATTRIBUTES
) {
1823 /* Just pretend that it is a regular and readable file */
1824 statbuf
->st_mode
= S_IFREG
| S_IREAD
| S_IWRITE
;
1829 case ERROR_ACCESS_DENIED
:
1830 case ERROR_SHARING_VIOLATION
:
1831 case ERROR_LOCK_VIOLATION
:
1832 case ERROR_SHARING_BUFFER_EXCEEDED
:
1834 case ERROR_BUFFER_OVERFLOW
:
1835 return ENAMETOOLONG
;
1836 case ERROR_NOT_ENOUGH_MEMORY
:
1843 f2t (&fad
.ftCreationTime
, &statbuf
->st_ctime
);
1844 f2t (&fad
.ftLastWriteTime
, &statbuf
->st_mtime
);
1845 f2t (&fad
.ftLastAccessTime
, &statbuf
->st_atime
);
1847 statbuf
->st_size
= (off_t
)fad
.nFileSizeLow
;
1849 /* We do not have the S_IEXEC attribute, but this is not used on GNAT. */
1850 statbuf
->st_mode
= S_IREAD
;
1852 if (fad
.dwFileAttributes
& FILE_ATTRIBUTE_DIRECTORY
)
1853 statbuf
->st_mode
|= S_IFDIR
;
1855 statbuf
->st_mode
|= S_IFREG
;
1857 if (!(fad
.dwFileAttributes
& FILE_ATTRIBUTE_READONLY
))
1858 statbuf
->st_mode
|= S_IWRITE
;
1863 return GNAT_STAT (name
, statbuf
);
1867 /*************************************************************************
1868 ** Check whether a file exists
1869 *************************************************************************/
1872 __gnat_file_exists_attr (char* name
, struct file_attributes
* attr
)
1874 if (attr
->exists
== ATTR_UNSET
)
1875 __gnat_stat_to_attr (-1, name
, attr
);
1877 return attr
->exists
;
1881 __gnat_file_exists (char *name
)
1883 struct file_attributes attr
;
1884 __gnat_reset_attributes (&attr
);
1885 return __gnat_file_exists_attr (name
, &attr
);
1888 /**********************************************************************
1889 ** Whether name is an absolute path
1890 **********************************************************************/
1893 __gnat_is_absolute_path (char *name
, int length
)
1896 /* On VxWorks systems, an absolute path can be represented (depending on
1897 the host platform) as either /dir/file, or device:/dir/file, or
1898 device:drive_letter:/dir/file. */
1905 for (index
= 0; index
< length
; index
++)
1907 if (name
[index
] == ':' &&
1908 ((name
[index
+ 1] == '/') ||
1909 (isalpha (name
[index
+ 1]) && index
+ 2 <= length
&&
1910 name
[index
+ 2] == '/')))
1913 else if (name
[index
] == '/')
1918 return (length
!= 0) &&
1919 (*name
== '/' || *name
== DIR_SEPARATOR
1921 || (length
> 1 && ISALPHA (name
[0]) && name
[1] == ':')
1928 __gnat_is_regular_file_attr (char* name
, struct file_attributes
* attr
)
1930 if (attr
->regular
== ATTR_UNSET
)
1931 __gnat_stat_to_attr (-1, name
, attr
);
1933 return attr
->regular
;
1937 __gnat_is_regular_file (char *name
)
1939 struct file_attributes attr
;
1941 __gnat_reset_attributes (&attr
);
1942 return __gnat_is_regular_file_attr (name
, &attr
);
1946 __gnat_is_directory_attr (char* name
, struct file_attributes
* attr
)
1948 if (attr
->directory
== ATTR_UNSET
)
1949 __gnat_stat_to_attr (-1, name
, attr
);
1951 return attr
->directory
;
1955 __gnat_is_directory (char *name
)
1957 struct file_attributes attr
;
1959 __gnat_reset_attributes (&attr
);
1960 return __gnat_is_directory_attr (name
, &attr
);
1963 #if defined (_WIN32) && !defined (RTX)
1965 /* Returns the same constant as GetDriveType but takes a pathname as
1969 GetDriveTypeFromPath (TCHAR
*wfullpath
)
1971 TCHAR wdrv
[MAX_PATH
];
1972 TCHAR wpath
[MAX_PATH
];
1973 TCHAR wfilename
[MAX_PATH
];
1974 TCHAR wext
[MAX_PATH
];
1976 _tsplitpath (wfullpath
, wdrv
, wpath
, wfilename
, wext
);
1978 if (_tcslen (wdrv
) != 0)
1980 /* we have a drive specified. */
1981 _tcscat (wdrv
, _T("\\"));
1982 return GetDriveType (wdrv
);
1986 /* No drive specified. */
1988 /* Is this a relative path, if so get current drive type. */
1989 if (wpath
[0] != _T('\\') ||
1990 (_tcslen (wpath
) > 2 && wpath
[0] == _T('\\')
1991 && wpath
[1] != _T('\\')))
1992 return GetDriveType (NULL
);
1994 UINT result
= GetDriveType (wpath
);
1996 /* Cannot guess the drive type, is this \\.\ ? */
1998 if (result
== DRIVE_NO_ROOT_DIR
&&
1999 _tcslen (wpath
) >= 4 && wpath
[0] == _T('\\') && wpath
[1] == _T('\\')
2000 && wpath
[2] == _T('.') && wpath
[3] == _T('\\'))
2002 if (_tcslen (wpath
) == 4)
2003 _tcscat (wpath
, wfilename
);
2005 LPTSTR p
= &wpath
[4];
2006 LPTSTR b
= _tcschr (p
, _T('\\'));
2010 /* logical drive \\.\c\dir\file */
2016 _tcscat (p
, _T(":\\"));
2018 return GetDriveType (p
);
2025 /* This MingW section contains code to work with ACL. */
2027 __gnat_check_OWNER_ACL (TCHAR
*wname
,
2028 DWORD CheckAccessDesired
,
2029 GENERIC_MAPPING CheckGenericMapping
)
2031 DWORD dwAccessDesired
, dwAccessAllowed
;
2032 PRIVILEGE_SET PrivilegeSet
;
2033 DWORD dwPrivSetSize
= sizeof (PRIVILEGE_SET
);
2034 BOOL fAccessGranted
= FALSE
;
2035 HANDLE hToken
= NULL
;
2037 SECURITY_DESCRIPTOR
* pSD
= NULL
;
2040 (wname
, OWNER_SECURITY_INFORMATION
|
2041 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
2044 if ((pSD
= (SECURITY_DESCRIPTOR
*) HeapAlloc
2045 (GetProcessHeap (), HEAP_ZERO_MEMORY
, nLength
)) == NULL
)
2048 /* Obtain the security descriptor. */
2050 if (!GetFileSecurity
2051 (wname
, OWNER_SECURITY_INFORMATION
|
2052 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
2053 pSD
, nLength
, &nLength
))
2056 if (!ImpersonateSelf (SecurityImpersonation
))
2059 if (!OpenThreadToken
2060 (GetCurrentThread(), TOKEN_DUPLICATE
| TOKEN_QUERY
, FALSE
, &hToken
))
2063 /* Undoes the effect of ImpersonateSelf. */
2067 /* We want to test for write permissions. */
2069 dwAccessDesired
= CheckAccessDesired
;
2071 MapGenericMask (&dwAccessDesired
, &CheckGenericMapping
);
2074 (pSD
, /* security descriptor to check */
2075 hToken
, /* impersonation token */
2076 dwAccessDesired
, /* requested access rights */
2077 &CheckGenericMapping
, /* pointer to GENERIC_MAPPING */
2078 &PrivilegeSet
, /* receives privileges used in check */
2079 &dwPrivSetSize
, /* size of PrivilegeSet buffer */
2080 &dwAccessAllowed
, /* receives mask of allowed access rights */
2084 CloseHandle (hToken
);
2085 HeapFree (GetProcessHeap (), 0, pSD
);
2086 return fAccessGranted
;
2090 CloseHandle (hToken
);
2091 HeapFree (GetProcessHeap (), 0, pSD
);
2096 __gnat_set_OWNER_ACL (TCHAR
*wname
,
2098 DWORD AccessPermissions
)
2100 PACL pOldDACL
= NULL
;
2101 PACL pNewDACL
= NULL
;
2102 PSECURITY_DESCRIPTOR pSD
= NULL
;
2104 TCHAR username
[100];
2107 /* Get current user, he will act as the owner */
2109 if (!GetUserName (username
, &unsize
))
2112 if (GetNamedSecurityInfo
2115 DACL_SECURITY_INFORMATION
,
2116 NULL
, NULL
, &pOldDACL
, NULL
, &pSD
) != ERROR_SUCCESS
)
2119 BuildExplicitAccessWithName
2120 (&ea
, username
, AccessPermissions
, (ACCESS_MODE
) AccessMode
, NO_INHERITANCE
);
2122 if (AccessMode
== SET_ACCESS
)
2124 /* SET_ACCESS, we want to set an explicte set of permissions, do not
2125 merge with current DACL. */
2126 if (SetEntriesInAcl (1, &ea
, NULL
, &pNewDACL
) != ERROR_SUCCESS
)
2130 if (SetEntriesInAcl (1, &ea
, pOldDACL
, &pNewDACL
) != ERROR_SUCCESS
)
2133 if (SetNamedSecurityInfo
2134 (wname
, SE_FILE_OBJECT
,
2135 DACL_SECURITY_INFORMATION
, NULL
, NULL
, pNewDACL
, NULL
) != ERROR_SUCCESS
)
2139 LocalFree (pNewDACL
);
2142 /* Check if it is possible to use ACL for wname, the file must not be on a
2146 __gnat_can_use_acl (TCHAR
*wname
)
2148 return __gnat_use_acl
&& GetDriveTypeFromPath (wname
) != DRIVE_REMOTE
;
2151 #endif /* defined (_WIN32) && !defined (RTX) */
2154 __gnat_is_readable_file_attr (char* name
, struct file_attributes
* attr
)
2156 if (attr
->readable
== ATTR_UNSET
)
2158 #if defined (_WIN32) && !defined (RTX)
2159 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2160 GENERIC_MAPPING GenericMapping
;
2162 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2164 if (__gnat_can_use_acl (wname
))
2166 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2167 GenericMapping
.GenericRead
= GENERIC_READ
;
2169 __gnat_check_OWNER_ACL (wname
, FILE_READ_DATA
, GenericMapping
);
2172 attr
->readable
= GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
;
2174 __gnat_stat_to_attr (-1, name
, attr
);
2178 return attr
->readable
;
2182 __gnat_is_readable_file (char *name
)
2184 struct file_attributes attr
;
2186 __gnat_reset_attributes (&attr
);
2187 return __gnat_is_readable_file_attr (name
, &attr
);
2191 __gnat_is_writable_file_attr (char* name
, struct file_attributes
* attr
)
2193 if (attr
->writable
== ATTR_UNSET
)
2195 #if defined (_WIN32) && !defined (RTX)
2196 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2197 GENERIC_MAPPING GenericMapping
;
2199 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2201 if (__gnat_can_use_acl (wname
))
2203 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2204 GenericMapping
.GenericWrite
= GENERIC_WRITE
;
2206 attr
->writable
= __gnat_check_OWNER_ACL
2207 (wname
, FILE_WRITE_DATA
| FILE_APPEND_DATA
, GenericMapping
)
2208 && !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2212 !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2215 __gnat_stat_to_attr (-1, name
, attr
);
2219 return attr
->writable
;
2223 __gnat_is_writable_file (char *name
)
2225 struct file_attributes attr
;
2227 __gnat_reset_attributes (&attr
);
2228 return __gnat_is_writable_file_attr (name
, &attr
);
2232 __gnat_is_executable_file_attr (char* name
, struct file_attributes
* attr
)
2234 if (attr
->executable
== ATTR_UNSET
)
2236 #if defined (_WIN32) && !defined (RTX)
2237 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2238 GENERIC_MAPPING GenericMapping
;
2240 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2242 if (__gnat_can_use_acl (wname
))
2244 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2245 GenericMapping
.GenericExecute
= GENERIC_EXECUTE
;
2248 __gnat_check_OWNER_ACL (wname
, FILE_EXECUTE
, GenericMapping
);
2252 TCHAR
*l
, *last
= _tcsstr(wname
, _T(".exe"));
2254 /* look for last .exe */
2256 while ((l
= _tcsstr(last
+1, _T(".exe"))))
2260 GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
2261 && (last
- wname
) == (int) (_tcslen (wname
) - 4);
2264 __gnat_stat_to_attr (-1, name
, attr
);
2268 return attr
->regular
&& attr
->executable
;
2272 __gnat_is_executable_file (char *name
)
2274 struct file_attributes attr
;
2276 __gnat_reset_attributes (&attr
);
2277 return __gnat_is_executable_file_attr (name
, &attr
);
2281 __gnat_set_writable (char *name
)
2283 #if defined (_WIN32) && !defined (RTX)
2284 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2286 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2288 if (__gnat_can_use_acl (wname
))
2289 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_WRITE
);
2292 (wname
, GetFileAttributes (wname
) & ~FILE_ATTRIBUTE_READONLY
);
2293 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2294 ! defined(__nucleus__)
2295 GNAT_STRUCT_STAT statbuf
;
2297 if (GNAT_STAT (name
, &statbuf
) == 0)
2299 statbuf
.st_mode
= statbuf
.st_mode
| S_IWUSR
;
2300 chmod (name
, statbuf
.st_mode
);
2306 __gnat_set_executable (char *name
)
2308 #if defined (_WIN32) && !defined (RTX)
2309 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2311 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2313 if (__gnat_can_use_acl (wname
))
2314 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_EXECUTE
);
2316 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2317 ! defined(__nucleus__)
2318 GNAT_STRUCT_STAT statbuf
;
2320 if (GNAT_STAT (name
, &statbuf
) == 0)
2322 statbuf
.st_mode
= statbuf
.st_mode
| S_IXUSR
;
2323 chmod (name
, statbuf
.st_mode
);
2329 __gnat_set_non_writable (char *name
)
2331 #if defined (_WIN32) && !defined (RTX)
2332 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2334 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2336 if (__gnat_can_use_acl (wname
))
2337 __gnat_set_OWNER_ACL
2338 (wname
, DENY_ACCESS
,
2339 FILE_WRITE_DATA
| FILE_APPEND_DATA
|
2340 FILE_WRITE_EA
| FILE_WRITE_ATTRIBUTES
);
2343 (wname
, GetFileAttributes (wname
) | FILE_ATTRIBUTE_READONLY
);
2344 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2345 ! defined(__nucleus__)
2346 GNAT_STRUCT_STAT statbuf
;
2348 if (GNAT_STAT (name
, &statbuf
) == 0)
2350 statbuf
.st_mode
= statbuf
.st_mode
& 07577;
2351 chmod (name
, statbuf
.st_mode
);
2357 __gnat_set_readable (char *name
)
2359 #if defined (_WIN32) && !defined (RTX)
2360 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2362 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2364 if (__gnat_can_use_acl (wname
))
2365 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_READ
);
2367 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2368 ! defined(__nucleus__)
2369 GNAT_STRUCT_STAT statbuf
;
2371 if (GNAT_STAT (name
, &statbuf
) == 0)
2373 chmod (name
, statbuf
.st_mode
| S_IREAD
);
2379 __gnat_set_non_readable (char *name
)
2381 #if defined (_WIN32) && !defined (RTX)
2382 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2384 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2386 if (__gnat_can_use_acl (wname
))
2387 __gnat_set_OWNER_ACL (wname
, DENY_ACCESS
, FILE_GENERIC_READ
);
2389 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2390 ! defined(__nucleus__)
2391 GNAT_STRUCT_STAT statbuf
;
2393 if (GNAT_STAT (name
, &statbuf
) == 0)
2395 chmod (name
, statbuf
.st_mode
& (~S_IREAD
));
2401 __gnat_is_symbolic_link_attr (char* name ATTRIBUTE_UNUSED
,
2402 struct file_attributes
* attr
)
2404 if (attr
->symbolic_link
== ATTR_UNSET
)
2406 #if defined (__vxworks) || defined (__nucleus__)
2407 attr
->symbolic_link
= 0;
2409 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
2411 GNAT_STRUCT_STAT statbuf
;
2412 ret
= GNAT_LSTAT (name
, &statbuf
);
2413 attr
->symbolic_link
= (!ret
&& S_ISLNK (statbuf
.st_mode
));
2415 attr
->symbolic_link
= 0;
2418 return attr
->symbolic_link
;
2422 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED
)
2424 struct file_attributes attr
;
2426 __gnat_reset_attributes (&attr
);
2427 return __gnat_is_symbolic_link_attr (name
, &attr
);
2430 #if defined (sun) && defined (__SVR4)
2431 /* Using fork on Solaris will duplicate all the threads. fork1, which
2432 duplicates only the active thread, must be used instead, or spawning
2433 subprocess from a program with tasking will lead into numerous problems. */
2438 __gnat_portable_spawn (char *args
[])
2441 int finished ATTRIBUTE_UNUSED
;
2442 int pid ATTRIBUTE_UNUSED
;
2444 #if defined (__vxworks) || defined(__nucleus__) || defined(RTX)
2447 #elif defined (_WIN32)
2448 /* args[0] must be quotes as it could contain a full pathname with spaces */
2449 char *args_0
= args
[0];
2450 args
[0] = (char *)xmalloc (strlen (args_0
) + 3);
2451 strcpy (args
[0], "\"");
2452 strcat (args
[0], args_0
);
2453 strcat (args
[0], "\"");
2455 status
= spawnvp (P_WAIT
, args_0
, (char* const*)args
);
2457 /* restore previous value */
2459 args
[0] = (char *)args_0
;
2475 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2477 return -1; /* execv is in parent context on VMS. */
2484 finished
= waitpid (pid
, &status
, 0);
2486 if (finished
!= pid
|| WIFEXITED (status
) == 0)
2489 return WEXITSTATUS (status
);
2495 /* Create a copy of the given file descriptor.
2496 Return -1 if an error occurred. */
2499 __gnat_dup (int oldfd
)
2501 #if defined (__vxworks) && !defined (__RTP__)
2502 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2510 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
2511 Return -1 if an error occurred. */
2514 __gnat_dup2 (int oldfd
, int newfd
)
2516 #if defined (__vxworks) && !defined (__RTP__)
2517 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2520 #elif defined (_WIN32)
2521 /* Special case when oldfd and newfd are identical and are the standard
2522 input, output or error as this makes Windows XP hangs. Note that we
2523 do that only for standard file descriptors that are known to be valid. */
2524 if (oldfd
== newfd
&& newfd
>= 0 && newfd
<= 2)
2527 return dup2 (oldfd
, newfd
);
2529 return dup2 (oldfd
, newfd
);
2534 __gnat_number_of_cpus (void)
2538 #if defined (linux) || defined (sun) || defined (AIX) || defined (__APPLE__)
2539 cores
= (int) sysconf (_SC_NPROCESSORS_ONLN
);
2541 #elif defined (__hpux__)
2542 struct pst_dynamic psd
;
2543 if (pstat_getdynamic (&psd
, sizeof (psd
), 1, 0) != -1)
2544 cores
= (int) psd
.psd_proc_cnt
;
2546 #elif defined (_WIN32)
2547 SYSTEM_INFO sysinfo
;
2548 GetSystemInfo (&sysinfo
);
2549 cores
= (int) sysinfo
.dwNumberOfProcessors
;
2552 int code
= SYI$_ACTIVECPU_CNT
;
2556 status
= LIB$
GETSYI (&code
, &res
);
2557 if ((status
& 1) != 0)
2560 #elif defined (_WRS_CONFIG_SMP)
2561 unsigned int vxCpuConfiguredGet (void);
2563 cores
= vxCpuConfiguredGet ();
2570 /* WIN32 code to implement a wait call that wait for any child process. */
2572 #if defined (_WIN32) && !defined (RTX)
2574 /* Synchronization code, to be thread safe. */
2578 /* For the Cert run times on native Windows we use dummy functions
2579 for locking and unlocking tasks since we do not support multiple
2580 threads on this configuration (Cert run time on native Windows). */
2582 static void dummy (void)
2586 void (*Lock_Task
) () = &dummy
;
2587 void (*Unlock_Task
) () = &dummy
;
2591 #define Lock_Task system__soft_links__lock_task
2592 extern void (*Lock_Task
) (void);
2594 #define Unlock_Task system__soft_links__unlock_task
2595 extern void (*Unlock_Task
) (void);
2599 static HANDLE
*HANDLES_LIST
= NULL
;
2600 static int *PID_LIST
= NULL
, plist_length
= 0, plist_max_length
= 0;
2603 add_handle (HANDLE h
, int pid
)
2606 /* -------------------- critical section -------------------- */
2609 if (plist_length
== plist_max_length
)
2611 plist_max_length
+= 1000;
2613 (void **) xrealloc (HANDLES_LIST
, sizeof (HANDLE
) * plist_max_length
);
2615 (int *) xrealloc (PID_LIST
, sizeof (int) * plist_max_length
);
2618 HANDLES_LIST
[plist_length
] = h
;
2619 PID_LIST
[plist_length
] = pid
;
2623 /* -------------------- critical section -------------------- */
2627 __gnat_win32_remove_handle (HANDLE h
, int pid
)
2631 /* -------------------- critical section -------------------- */
2634 for (j
= 0; j
< plist_length
; j
++)
2636 if ((HANDLES_LIST
[j
] == h
) || (PID_LIST
[j
] == pid
))
2640 HANDLES_LIST
[j
] = HANDLES_LIST
[plist_length
];
2641 PID_LIST
[j
] = PID_LIST
[plist_length
];
2647 /* -------------------- critical section -------------------- */
2651 win32_no_block_spawn (char *command
, char *args
[], HANDLE
*h
, int *pid
)
2655 PROCESS_INFORMATION PI
;
2656 SECURITY_ATTRIBUTES SA
;
2661 /* compute the total command line length */
2665 csize
+= strlen (args
[k
]) + 1;
2669 full_command
= (char *) xmalloc (csize
);
2672 SI
.cb
= sizeof (STARTUPINFO
);
2673 SI
.lpReserved
= NULL
;
2674 SI
.lpReserved2
= NULL
;
2675 SI
.lpDesktop
= NULL
;
2679 SI
.wShowWindow
= SW_HIDE
;
2681 /* Security attributes. */
2682 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
2683 SA
.bInheritHandle
= TRUE
;
2684 SA
.lpSecurityDescriptor
= NULL
;
2686 /* Prepare the command string. */
2687 strcpy (full_command
, command
);
2688 strcat (full_command
, " ");
2693 strcat (full_command
, args
[k
]);
2694 strcat (full_command
, " ");
2699 int wsize
= csize
* 2;
2700 TCHAR
*wcommand
= (TCHAR
*) xmalloc (wsize
);
2702 S2WSC (wcommand
, full_command
, wsize
);
2704 free (full_command
);
2706 result
= CreateProcess
2707 (NULL
, wcommand
, &SA
, NULL
, TRUE
,
2708 GetPriorityClass (GetCurrentProcess()), NULL
, NULL
, &SI
, &PI
);
2715 CloseHandle (PI
.hThread
);
2717 *pid
= PI
.dwProcessId
;
2727 win32_wait (int *status
)
2729 DWORD exitcode
, pid
;
2736 if (plist_length
== 0)
2744 /* -------------------- critical section -------------------- */
2747 hl_len
= plist_length
;
2749 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * hl_len
);
2751 memmove (hl
, HANDLES_LIST
, sizeof (HANDLE
) * hl_len
);
2754 /* -------------------- critical section -------------------- */
2756 res
= WaitForMultipleObjects (hl_len
, hl
, FALSE
, INFINITE
);
2757 h
= hl
[res
- WAIT_OBJECT_0
];
2759 GetExitCodeProcess (h
, &exitcode
);
2760 pid
= PID_LIST
[res
- WAIT_OBJECT_0
];
2761 __gnat_win32_remove_handle (h
, -1);
2765 *status
= (int) exitcode
;
2772 __gnat_portable_no_block_spawn (char *args
[])
2775 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2778 #elif defined (_WIN32)
2783 win32_no_block_spawn (args
[0], args
, &h
, &pid
);
2786 add_handle (h
, pid
);
2799 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2801 return -1; /* execv is in parent context on VMS. */
2813 __gnat_portable_wait (int *process_status
)
2818 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2819 /* Not sure what to do here, so do nothing but return zero. */
2821 #elif defined (_WIN32)
2823 pid
= win32_wait (&status
);
2827 pid
= waitpid (-1, &status
, 0);
2828 status
= status
& 0xffff;
2831 *process_status
= status
;
2836 __gnat_os_exit (int status
)
2841 /* Locate file on path, that matches a predicate */
2844 __gnat_locate_file_with_predicate (char *file_name
, char *path_val
,
2845 int (*predicate
)(char *))
2848 char *file_path
= (char *) alloca (strlen (file_name
) + 1);
2851 /* Return immediately if file_name is empty */
2853 if (*file_name
== '\0')
2856 /* Remove quotes around file_name if present */
2862 strcpy (file_path
, ptr
);
2864 ptr
= file_path
+ strlen (file_path
) - 1;
2869 /* Handle absolute pathnames. */
2871 absolute
= __gnat_is_absolute_path (file_path
, strlen (file_name
));
2875 if (predicate (file_path
))
2876 return xstrdup (file_path
);
2881 /* If file_name include directory separator(s), try it first as
2882 a path name relative to the current directory */
2883 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
2888 if (predicate (file_name
))
2889 return xstrdup (file_name
);
2896 /* The result has to be smaller than path_val + file_name. */
2898 (char *) alloca (strlen (path_val
) + strlen (file_name
) + 2);
2902 /* Skip the starting quote */
2904 if (*path_val
== '"')
2907 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
2908 *ptr
++ = *path_val
++;
2910 /* If directory is empty, it is the current directory*/
2912 if (ptr
== file_path
)
2919 /* Skip the ending quote */
2924 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
2925 *++ptr
= DIR_SEPARATOR
;
2927 strcpy (++ptr
, file_name
);
2929 if (predicate (file_path
))
2930 return xstrdup (file_path
);
2935 /* Skip path separator */
2944 /* Locate an executable file, give a Path value. */
2947 __gnat_locate_executable_file (char *file_name
, char *path_val
)
2949 return __gnat_locate_file_with_predicate
2950 (file_name
, path_val
, &__gnat_is_executable_file
);
2953 /* Locate a regular file, give a Path value. */
2956 __gnat_locate_regular_file (char *file_name
, char *path_val
)
2958 return __gnat_locate_file_with_predicate
2959 (file_name
, path_val
, &__gnat_is_regular_file
);
2962 /* Locate an executable given a Path argument. This routine is only used by
2963 gnatbl and should not be used otherwise. Use locate_exec_on_path
2967 __gnat_locate_exec (char *exec_name
, char *path_val
)
2970 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
2972 char *full_exec_name
=
2974 (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
2976 strcpy (full_exec_name
, exec_name
);
2977 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
2978 ptr
= __gnat_locate_executable_file (full_exec_name
, path_val
);
2981 return __gnat_locate_executable_file (exec_name
, path_val
);
2985 return __gnat_locate_executable_file (exec_name
, path_val
);
2988 /* Locate an executable using the Systems default PATH. */
2991 __gnat_locate_exec_on_path (char *exec_name
)
2995 #if defined (_WIN32) && !defined (RTX)
2996 TCHAR
*wpath_val
= _tgetenv (_T("PATH"));
2998 /* In Win32 systems we expand the PATH as for XP environment
2999 variables are not automatically expanded. We also prepend the
3000 ".;" to the path to match normal NT path search semantics */
3002 #define EXPAND_BUFFER_SIZE 32767
3004 wapath_val
= (TCHAR
*) alloca (EXPAND_BUFFER_SIZE
);
3006 wapath_val
[0] = '.';
3007 wapath_val
[1] = ';';
3009 DWORD res
= ExpandEnvironmentStrings
3010 (wpath_val
, &wapath_val
[2], EXPAND_BUFFER_SIZE
- 2);
3012 if (!res
) wapath_val
[0] = _T('\0');
3014 apath_val
= (char *) alloca (EXPAND_BUFFER_SIZE
);
3016 WS2SC (apath_val
, wapath_val
, EXPAND_BUFFER_SIZE
);
3017 return __gnat_locate_exec (exec_name
, apath_val
);
3022 char *path_val
= "/VAXC$PATH";
3024 char *path_val
= getenv ("PATH");
3026 if (path_val
== NULL
) return NULL
;
3027 apath_val
= (char *) alloca (strlen (path_val
) + 1);
3028 strcpy (apath_val
, path_val
);
3029 return __gnat_locate_exec (exec_name
, apath_val
);
3035 /* These functions are used to translate to and from VMS and Unix syntax
3036 file, directory and path specifications. */
3039 #define MAXNAMES 256
3040 #define NEW_CANONICAL_FILELIST_INCREMENT 64
3042 static char new_canonical_dirspec
[MAXPATH
];
3043 static char new_canonical_filespec
[MAXPATH
];
3044 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
3045 static unsigned new_canonical_filelist_index
;
3046 static unsigned new_canonical_filelist_in_use
;
3047 static unsigned new_canonical_filelist_allocated
;
3048 static char **new_canonical_filelist
;
3049 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
3050 static char new_host_dirspec
[MAXPATH
];
3051 static char new_host_filespec
[MAXPATH
];
3053 /* Routine is called repeatedly by decc$from_vms via
3054 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
3058 wildcard_translate_unix (char *name
)
3061 char buff
[MAXPATH
];
3063 strncpy (buff
, name
, MAXPATH
);
3064 buff
[MAXPATH
- 1] = (char) 0;
3065 ver
= strrchr (buff
, '.');
3067 /* Chop off the version. */
3071 /* Dynamically extend the allocation by the increment. */
3072 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
3074 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
3075 new_canonical_filelist
= (char **) xrealloc
3076 (new_canonical_filelist
,
3077 new_canonical_filelist_allocated
* sizeof (char *));
3080 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
3085 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
3086 full translation and copy the results into a list (_init), then return them
3087 one at a time (_next). If onlydirs set, only expand directory files. */
3090 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
3093 char buff
[MAXPATH
];
3095 len
= strlen (filespec
);
3096 strncpy (buff
, filespec
, MAXPATH
);
3098 /* Only look for directories */
3099 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
3100 strncat (buff
, "*.dir", MAXPATH
);
3102 buff
[MAXPATH
- 1] = (char) 0;
3104 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
3106 /* Remove the .dir extension. */
3112 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3114 ext
= strstr (new_canonical_filelist
[i
], ".dir");
3120 return new_canonical_filelist_in_use
;
3123 /* Return the next filespec in the list. */
3126 __gnat_to_canonical_file_list_next (void)
3128 return new_canonical_filelist
[new_canonical_filelist_index
++];
3131 /* Free storage used in the wildcard expansion. */
3134 __gnat_to_canonical_file_list_free (void)
3138 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3139 free (new_canonical_filelist
[i
]);
3141 free (new_canonical_filelist
);
3143 new_canonical_filelist_in_use
= 0;
3144 new_canonical_filelist_allocated
= 0;
3145 new_canonical_filelist_index
= 0;
3146 new_canonical_filelist
= 0;
3149 /* The functional equivalent of decc$translate_vms routine.
3150 Designed to produce the same output, but is protected against
3151 malformed paths (original version ACCVIOs in this case) and
3152 does not require VMS-specific DECC RTL. */
3154 #define NAM$C_MAXRSS 1024
3157 __gnat_translate_vms (char *src
)
3159 static char retbuf
[NAM$C_MAXRSS
+ 1];
3160 char *srcendpos
, *pos1
, *pos2
, *retpos
;
3161 int disp
, path_present
= 0;
3166 srcendpos
= strchr (src
, '\0');
3169 /* Look for the node and/or device in front of the path. */
3171 pos2
= strchr (pos1
, ':');
3173 if (pos2
&& (pos2
< srcendpos
) && (*(pos2
+ 1) == ':'))
3175 /* There is a node name. "node_name::" becomes "node_name!". */
3177 strncpy (retbuf
, pos1
, disp
);
3178 retpos
[disp
] = '!';
3179 retpos
= retpos
+ disp
+ 1;
3181 pos2
= strchr (pos1
, ':');
3186 /* There is a device name. "dev_name:" becomes "/dev_name/". */
3189 strncpy (retpos
, pos1
, disp
);
3190 retpos
= retpos
+ disp
;
3195 /* No explicit device; we must look ahead and prepend /sys$disk/ if
3196 the path is absolute. */
3197 if ((*pos1
== '[' || *pos1
== '<') && (pos1
< srcendpos
)
3198 && !strchr (".-]>", *(pos1
+ 1)))
3200 strncpy (retpos
, "/sys$disk/", 10);
3204 /* Process the path part. */
3205 while (*pos1
== '[' || *pos1
== '<')
3209 if (*pos1
== ']' || *pos1
== '>')
3211 /* Special case, [] translates to '.'. */
3217 /* '[000000' means root dir. It can be present in the middle of
3218 the path due to expansion of logical devices, in which case
3220 if (!strncmp (pos1
, "000000", 6) && path_present
> 1 &&
3221 (*(pos1
+ 6) == ']' || *(pos1
+ 6) == '>' || *(pos1
+ 6) == '.'))
3224 if (*pos1
== '.') pos1
++;
3226 else if (*pos1
== '.')
3228 /* Relative path. */
3232 /* There is a qualified path. */
3233 while (*pos1
&& *pos1
!= ']' && *pos1
!= '>')
3238 /* '.' is used to separate directories. Replace it with '/'
3239 but only if there isn't already '/' just before. */
3240 if (*(retpos
- 1) != '/')
3243 if (pos1
+ 1 < srcendpos
3245 && *(pos1
+ 1) == '.')
3247 /* Ellipsis refers to entire subtree; replace
3256 /* When after '.' '[' '<' is equivalent to Unix ".." but
3257 there may be several in a row. */
3258 if (*(pos1
- 1) == '.' || *(pos1
- 1) == '[' ||
3261 while (*pos1
== '-')
3271 /* Otherwise fall through to default. */
3273 *(retpos
++) = *(pos1
++);
3280 if (pos1
< srcendpos
)
3282 /* Now add the actual file name, until the version suffix if any */
3285 pos2
= strchr (pos1
, ';');
3286 disp
= pos2
? (pos2
- pos1
) : (srcendpos
- pos1
);
3287 strncpy (retpos
, pos1
, disp
);
3289 if (pos2
&& pos2
< srcendpos
)
3291 /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
3293 disp
= srcendpos
- pos2
- 1;
3294 strncpy (retpos
, pos2
+ 1, disp
);
3304 /* Translate a VMS syntax directory specification in to Unix syntax. If
3305 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
3306 found, return input string. Also translate a dirname that contains no
3307 slashes, in case it's a logical name. */
3310 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
3314 strcpy (new_canonical_dirspec
, "");
3315 if (strlen (dirspec
))
3319 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
3321 strncpy (new_canonical_dirspec
,
3322 __gnat_translate_vms (dirspec
),
3325 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
3327 strncpy (new_canonical_dirspec
,
3328 __gnat_translate_vms (dirspec1
),
3333 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
3337 len
= strlen (new_canonical_dirspec
);
3338 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
3339 strncat (new_canonical_dirspec
, "/", MAXPATH
);
3341 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
3343 return new_canonical_dirspec
;
3347 /* Translate a VMS syntax file specification into Unix syntax.
3348 If no indicators of VMS syntax found, check if it's an uppercase
3349 alphanumeric_ name and if so try it out as an environment
3350 variable (logical name). If all else fails return the
3354 __gnat_to_canonical_file_spec (char *filespec
)
3358 strncpy (new_canonical_filespec
, "", MAXPATH
);
3360 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3362 char *tspec
= (char *) __gnat_translate_vms (filespec
);
3364 if (tspec
!= (char *) -1)
3365 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3367 else if ((strlen (filespec
) == strspn (filespec
,
3368 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
3369 && (filespec1
= getenv (filespec
)))
3371 char *tspec
= (char *) __gnat_translate_vms (filespec1
);
3373 if (tspec
!= (char *) -1)
3374 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3378 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
3381 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
3383 return new_canonical_filespec
;
3386 /* Translate a VMS syntax path specification into Unix syntax.
3387 If no indicators of VMS syntax found, return input string. */
3390 __gnat_to_canonical_path_spec (char *pathspec
)
3392 char *curr
, *next
, buff
[MAXPATH
];
3397 /* If there are /'s, assume it's a Unix path spec and return. */
3398 if (strchr (pathspec
, '/'))
3401 new_canonical_pathspec
[0] = 0;
3406 next
= strchr (curr
, ',');
3408 next
= strchr (curr
, 0);
3410 strncpy (buff
, curr
, next
- curr
);
3411 buff
[next
- curr
] = 0;
3413 /* Check for wildcards and expand if present. */
3414 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
3418 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
3419 for (i
= 0; i
< dirs
; i
++)
3423 next_dir
= __gnat_to_canonical_file_list_next ();
3424 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
3426 /* Don't append the separator after the last expansion. */
3428 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3431 __gnat_to_canonical_file_list_free ();
3434 strncat (new_canonical_pathspec
,
3435 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
3440 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3444 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
3446 return new_canonical_pathspec
;
3449 static char filename_buff
[MAXPATH
];
3452 translate_unix (char *name
, int type ATTRIBUTE_UNUSED
)
3454 strncpy (filename_buff
, name
, MAXPATH
);
3455 filename_buff
[MAXPATH
- 1] = (char) 0;
3459 /* Translate a Unix syntax directory specification into VMS syntax. The
3460 PREFIXFLAG has no effect, but is kept for symmetry with
3461 to_canonical_dir_spec. If indicators of VMS syntax found, return input
3465 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3467 int len
= strlen (dirspec
);
3469 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
3470 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3472 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
3473 return new_host_dirspec
;
3475 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
3477 new_host_dirspec
[len
- 1] = 0;
3481 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
3482 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
3483 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3485 return new_host_dirspec
;
3488 /* Translate a Unix syntax file specification into VMS syntax.
3489 If indicators of VMS syntax found, return input string. */
3492 __gnat_to_host_file_spec (char *filespec
)
3494 strncpy (new_host_filespec
, "", MAXPATH
);
3495 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3497 strncpy (new_host_filespec
, filespec
, MAXPATH
);
3501 decc$
to_vms (filespec
, translate_unix
, 1, 1);
3502 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
3505 new_host_filespec
[MAXPATH
- 1] = (char) 0;
3507 return new_host_filespec
;
3511 __gnat_adjust_os_resource_limits (void)
3513 SYS$
ADJWSL (131072, 0);
3518 /* Dummy functions for Osint import for non-VMS systems. */
3521 __gnat_to_canonical_file_list_init (char *dirspec ATTRIBUTE_UNUSED
,
3522 int onlydirs ATTRIBUTE_UNUSED
)
3528 __gnat_to_canonical_file_list_next (void)
3530 static char empty
[] = "";
3535 __gnat_to_canonical_file_list_free (void)
3540 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3546 __gnat_to_canonical_file_spec (char *filespec
)
3552 __gnat_to_canonical_path_spec (char *pathspec
)
3558 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3564 __gnat_to_host_file_spec (char *filespec
)
3570 __gnat_adjust_os_resource_limits (void)
3576 #if defined (__mips_vxworks)
3580 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
3584 #if defined (IS_CROSS) \
3585 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3586 && defined (__SVR4)) \
3587 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3588 && ! (defined (linux) && defined (__ia64__)) \
3589 && ! (defined (linux) && defined (powerpc)) \
3590 && ! defined (__FreeBSD__) \
3591 && ! defined (__Lynx__) \
3592 && ! defined (__hpux__) \
3593 && ! defined (__APPLE__) \
3594 && ! defined (_AIX) \
3595 && ! defined (VMS) \
3596 && ! defined (__MINGW32__))
3598 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3599 just above for a list of native platforms that provide a non-dummy
3600 version of this procedure in libaddr2line.a. */
3603 convert_addresses (const char *file_name ATTRIBUTE_UNUSED
,
3604 void *addrs ATTRIBUTE_UNUSED
,
3605 int n_addr ATTRIBUTE_UNUSED
,
3606 void *buf ATTRIBUTE_UNUSED
,
3607 int *len ATTRIBUTE_UNUSED
)
3613 #if defined (_WIN32)
3614 int __gnat_argument_needs_quote
= 1;
3616 int __gnat_argument_needs_quote
= 0;
3619 /* This option is used to enable/disable object files handling from the
3620 binder file by the GNAT Project module. For example, this is disabled on
3621 Windows (prior to GCC 3.4) as it is already done by the mdll module.
3622 Stating with GCC 3.4 the shared libraries are not based on mdll
3623 anymore as it uses the GCC's -shared option */
3624 #if defined (_WIN32) \
3625 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3626 int __gnat_prj_add_obj_files
= 0;
3628 int __gnat_prj_add_obj_files
= 1;
3631 /* char used as prefix/suffix for environment variables */
3632 #if defined (_WIN32)
3633 char __gnat_environment_char
= '%';
3635 char __gnat_environment_char
= '$';
3638 /* This functions copy the file attributes from a source file to a
3641 mode = 0 : In this mode copy only the file time stamps (last access and
3642 last modification time stamps).
3644 mode = 1 : In this mode, time stamps and read/write/execute attributes are
3647 Returns 0 if operation was successful and -1 in case of error. */
3650 __gnat_copy_attribs (char *from ATTRIBUTE_UNUSED
, char *to ATTRIBUTE_UNUSED
,
3651 int mode ATTRIBUTE_UNUSED
)
3653 #if defined (VMS) || (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \
3654 defined (__nucleus__)
3657 #elif defined (_WIN32) && !defined (RTX)
3658 TCHAR wfrom
[GNAT_MAX_PATH_LEN
+ 2];
3659 TCHAR wto
[GNAT_MAX_PATH_LEN
+ 2];
3661 FILETIME fct
, flat
, flwt
;
3664 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
+ 2);
3665 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
+ 2);
3667 /* retrieve from times */
3670 (wfrom
, GENERIC_READ
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3672 if (hfrom
== INVALID_HANDLE_VALUE
)
3675 res
= GetFileTime (hfrom
, &fct
, &flat
, &flwt
);
3677 CloseHandle (hfrom
);
3682 /* retrieve from times */
3685 (wto
, GENERIC_WRITE
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3687 if (hto
== INVALID_HANDLE_VALUE
)
3690 res
= SetFileTime (hto
, NULL
, &flat
, &flwt
);
3697 /* Set file attributes in full mode. */
3701 DWORD attribs
= GetFileAttributes (wfrom
);
3703 if (attribs
== INVALID_FILE_ATTRIBUTES
)
3706 res
= SetFileAttributes (wto
, attribs
);
3714 GNAT_STRUCT_STAT fbuf
;
3715 struct utimbuf tbuf
;
3717 if (GNAT_STAT (from
, &fbuf
) == -1)
3722 tbuf
.actime
= fbuf
.st_atime
;
3723 tbuf
.modtime
= fbuf
.st_mtime
;
3725 if (utime (to
, &tbuf
) == -1)
3732 if (chmod (to
, fbuf
.st_mode
) == -1)
3743 __gnat_lseek (int fd
, long offset
, int whence
)
3745 return (int) lseek (fd
, offset
, whence
);
3748 /* This function returns the major version number of GCC being used. */
3750 get_gcc_version (void)
3755 return (int) (version_string
[0] - '0');
3760 * Set Close_On_Exec as indicated.
3761 * Note: this is used for both GNAT.OS_Lib and GNAT.Sockets.
3765 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED
,
3766 int close_on_exec_p ATTRIBUTE_UNUSED
)
3768 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3769 int flags
= fcntl (fd
, F_GETFD
, 0);
3772 if (close_on_exec_p
)
3773 flags
|= FD_CLOEXEC
;
3775 flags
&= ~FD_CLOEXEC
;
3776 return fcntl (fd
, F_SETFD
, flags
| FD_CLOEXEC
);
3777 #elif defined(_WIN32)
3778 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
3779 if (h
== (HANDLE
) -1)
3781 if (close_on_exec_p
)
3782 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
, 0);
3783 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
,
3784 HANDLE_FLAG_INHERIT
);
3786 /* TODO: Unimplemented. */
3791 /* Indicates if platforms supports automatic initialization through the
3792 constructor mechanism */
3794 __gnat_binder_supports_auto_init (void)
3803 /* Indicates that Stand-Alone Libraries are automatically initialized through
3804 the constructor mechanism */
3806 __gnat_sals_init_using_constructors (void)
3808 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3817 /* In RTX mode, the procedure to get the time (as file time) is different
3818 in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3819 we introduce an intermediate procedure to link against the corresponding
3820 one in each situation. */
3822 extern void GetTimeAsFileTime (LPFILETIME pTime
);
3824 void GetTimeAsFileTime (LPFILETIME pTime
)
3827 RtGetRtssTimeAsFileTime (pTime
); /* RTSS interface */
3829 GetSystemTimeAsFileTime (pTime
); /* w32 interface */
3834 /* Add symbol that is required to link. It would otherwise be taken from
3835 libgcc.a and it would try to use the gcc constructors that are not
3836 supported by Microsoft linker. */
3838 extern void __main (void);
3846 #if defined (__ANDROID__)
3848 #include <pthread.h>
3851 __gnat_lwp_self (void)
3853 return (void *) pthread_self ();
3856 #elif defined (linux)
3857 /* There is no function in the glibc to retrieve the LWP of the current
3858 thread. We need to do a system call in order to retrieve this
3860 #include <sys/syscall.h>
3862 __gnat_lwp_self (void)
3864 return (void *) syscall (__NR_gettid
);
3869 /* glibc versions earlier than 2.7 do not define the routines to handle
3870 dynamically allocated CPU sets. For these targets, we use the static
3875 /* Dynamic cpu sets */
3878 __gnat_cpu_alloc (size_t count
)
3880 return CPU_ALLOC (count
);
3884 __gnat_cpu_alloc_size (size_t count
)
3886 return CPU_ALLOC_SIZE (count
);
3890 __gnat_cpu_free (cpu_set_t
*set
)
3896 __gnat_cpu_zero (size_t count
, cpu_set_t
*set
)
3898 CPU_ZERO_S (count
, set
);
3902 __gnat_cpu_set (int cpu
, size_t count
, cpu_set_t
*set
)
3904 /* Ada handles CPU numbers starting from 1, while C identifies the first
3905 CPU by a 0, so we need to adjust. */
3906 CPU_SET_S (cpu
- 1, count
, set
);
3909 #else /* !CPU_ALLOC */
3911 /* Static cpu sets */
3914 __gnat_cpu_alloc (size_t count ATTRIBUTE_UNUSED
)
3916 return (cpu_set_t
*) xmalloc (sizeof (cpu_set_t
));
3920 __gnat_cpu_alloc_size (size_t count ATTRIBUTE_UNUSED
)
3922 return sizeof (cpu_set_t
);
3926 __gnat_cpu_free (cpu_set_t
*set
)
3932 __gnat_cpu_zero (size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
3938 __gnat_cpu_set (int cpu
, size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
3940 /* Ada handles CPU numbers starting from 1, while C identifies the first
3941 CPU by a 0, so we need to adjust. */
3942 CPU_SET (cpu
- 1, set
);
3944 #endif /* !CPU_ALLOC */
3947 /* Return the load address of the executable, or 0 if not known. In the
3948 specific case of error, (void *)-1 can be returned. Beware: this unit may
3949 be in a shared library. As low-level units are needed, we allow #include
3952 #if defined (__APPLE__)
3953 #include <mach-o/dyld.h>
3954 #elif 0 && defined (__linux__)
3959 __gnat_get_executable_load_address (void)
3961 #if defined (__APPLE__)
3962 return _dyld_get_image_header (0);
3964 #elif 0 && defined (__linux__)
3965 /* Currently disabled as it needs at least -ldl. */
3966 struct link_map
*map
= _r_debug
.r_map
;
3968 return (const void *)map
->l_addr
;