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) \
185 { unsigned long long reftime, tmptime = (X); \
186 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
187 SYS$BINTIM (&unixtime, &reftime); \
188 Y = tmptime * 10000000 + reftime; }
190 /* descrip.h doesn't have everything ... */
191 typedef struct fibdef
* __fibdef_ptr32
__attribute__ (( mode (SI
) ));
192 struct dsc$descriptor_fib
194 unsigned int fib$l_len
;
195 __fibdef_ptr32 fib$l_addr
;
198 /* I/O Status Block. */
201 unsigned short status
, count
;
205 static char *tryfile
;
207 /* Variable length string. */
211 char string
[NAM$C_MAXRSS
+1];
214 #define SYI$_ACTIVECPU_CNT 0x111e
215 extern int LIB$
GETSYI (int *, unsigned int *);
216 extern unsigned int LIB$CALLG_64
217 ( unsigned long long argument_list
[], int (*user_procedure
)(void));
234 #define DIR_SEPARATOR '\\'
239 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
240 defined in the current system. On DOS-like systems these flags control
241 whether the file is opened/created in text-translation mode (CR/LF in
242 external file mapped to LF in internal file), but in Unix-like systems,
243 no text translation is required, so these flags have no effect. */
253 #ifndef HOST_EXECUTABLE_SUFFIX
254 #define HOST_EXECUTABLE_SUFFIX ""
257 #ifndef HOST_OBJECT_SUFFIX
258 #define HOST_OBJECT_SUFFIX ".o"
261 #ifndef PATH_SEPARATOR
262 #define PATH_SEPARATOR ':'
265 #ifndef DIR_SEPARATOR
266 #define DIR_SEPARATOR '/'
269 /* Check for cross-compilation */
270 #if defined (CROSS_COMPILE) || defined (CROSS_DIRECTORY_STRUCTURE)
272 int __gnat_is_cross_compiler
= 1;
275 int __gnat_is_cross_compiler
= 0;
278 char __gnat_dir_separator
= DIR_SEPARATOR
;
280 char __gnat_path_separator
= PATH_SEPARATOR
;
282 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
283 the base filenames that libraries specified with -lsomelib options
284 may have. This is used by GNATMAKE to check whether an executable
285 is up-to-date or not. The syntax is
287 library_template ::= { pattern ; } pattern NUL
288 pattern ::= [ prefix ] * [ postfix ]
290 These should only specify names of static libraries as it makes
291 no sense to determine at link time if dynamic-link libraries are
292 up to date or not. Any libraries that are not found are supposed
295 * if they are needed but not present, the link
298 * otherwise they are libraries in the system paths and so
299 they are considered part of the system and not checked
302 ??? This should be part of a GNAT host-specific compiler
303 file instead of being included in all user applications
304 as well. This is only a temporary work-around for 3.11b. */
306 #ifndef GNAT_LIBRARY_TEMPLATE
308 #define GNAT_LIBRARY_TEMPLATE "*.olb"
310 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
314 const char *__gnat_library_template
= GNAT_LIBRARY_TEMPLATE
;
316 /* This variable is used in hostparm.ads to say whether the host is a VMS
325 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
327 #elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__)
328 #define GNAT_MAX_PATH_LEN PATH_MAX
332 #if defined (__MINGW32__)
336 #include <sys/param.h>
340 #include <sys/param.h>
344 #define GNAT_MAX_PATH_LEN MAXPATHLEN
346 #define GNAT_MAX_PATH_LEN 256
351 /* Used for Ada bindings */
352 int __gnat_size_of_file_attributes
= sizeof (struct file_attributes
);
354 void __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
);
356 /* The __gnat_max_path_len variable is used to export the maximum
357 length of a path name to Ada code. max_path_len is also provided
358 for compatibility with older GNAT versions, please do not use
361 int __gnat_max_path_len
= GNAT_MAX_PATH_LEN
;
362 int max_path_len
= GNAT_MAX_PATH_LEN
;
364 /* Control whether we can use ACL on Windows. */
366 int __gnat_use_acl
= 1;
368 /* The following macro HAVE_READDIR_R should be defined if the
369 system provides the routine readdir_r. */
370 #undef HAVE_READDIR_R
372 #if defined(VMS) && defined (__LONG_POINTERS)
374 /* Return a 32 bit pointer to an array of 32 bit pointers
375 given a 64 bit pointer to an array of 64 bit pointers */
377 typedef __char_ptr32
*__char_ptr_char_ptr32
__attribute__ ((mode (SI
)));
379 static __char_ptr_char_ptr32
380 to_ptr32 (char **ptr64
)
383 __char_ptr_char_ptr32 short_argv
;
385 for (argc
=0; ptr64
[argc
]; argc
++);
387 /* Reallocate argv with 32 bit pointers. */
388 short_argv
= (__char_ptr_char_ptr32
) decc$malloc
389 (sizeof (__char_ptr32
) * (argc
+ 1));
391 for (argc
=0; ptr64
[argc
]; argc
++)
392 short_argv
[argc
] = (__char_ptr32
) decc$
strdup (ptr64
[argc
]);
394 short_argv
[argc
] = (__char_ptr32
) 0;
398 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
400 #define MAYBE_TO_PTR32(argv) argv
403 static const char ATTR_UNSET
= 127;
405 /* Reset the file attributes as if no system call had been performed */
408 __gnat_reset_attributes
409 (struct file_attributes
* attr
)
411 attr
->exists
= ATTR_UNSET
;
413 attr
->writable
= ATTR_UNSET
;
414 attr
->readable
= ATTR_UNSET
;
415 attr
->executable
= ATTR_UNSET
;
417 attr
->regular
= ATTR_UNSET
;
418 attr
->symbolic_link
= ATTR_UNSET
;
419 attr
->directory
= ATTR_UNSET
;
421 attr
->timestamp
= (OS_Time
)-2;
422 attr
->file_length
= -1;
429 time_t res
= time (NULL
);
430 return (OS_Time
) res
;
433 /* Return the current local time as a string in the ISO 8601 format of
434 "YYYY-MM-DD HH:MM:SS.SS". The returned string is 22 + 1 (NULL) characters
438 __gnat_current_time_string
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. */
468 time_t time
= (time_t) *p_time
;
471 /* On Windows systems, the time is sometimes rounded up to the nearest
472 even second, so if the number of seconds is odd, increment it. */
478 res
= localtime (&time
);
480 res
= gmtime (&time
);
485 *p_year
= res
->tm_year
;
486 *p_month
= res
->tm_mon
;
487 *p_day
= res
->tm_mday
;
488 *p_hours
= res
->tm_hour
;
489 *p_mins
= res
->tm_min
;
490 *p_secs
= res
->tm_sec
;
493 *p_year
= *p_month
= *p_day
= *p_hours
= *p_mins
= *p_secs
= 0;
496 /* Place the contents of the symbolic link named PATH in the buffer BUF,
497 which has size BUFSIZ. If PATH is a symbolic link, then return the number
498 of characters of its content in BUF. Otherwise, return -1.
499 For systems not supporting symbolic links, always return -1. */
502 __gnat_readlink (char *path ATTRIBUTE_UNUSED
,
503 char *buf ATTRIBUTE_UNUSED
,
504 size_t bufsiz ATTRIBUTE_UNUSED
)
506 #if defined (_WIN32) || defined (VMS) \
507 || defined(__vxworks) || defined (__nucleus__)
510 return readlink (path
, buf
, bufsiz
);
514 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH.
515 If NEWPATH exists it will NOT be overwritten.
516 For systems not supporting symbolic links, always return -1. */
519 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED
,
520 char *newpath ATTRIBUTE_UNUSED
)
522 #if defined (_WIN32) || defined (VMS) \
523 || defined(__vxworks) || defined (__nucleus__)
526 return symlink (oldpath
, newpath
);
530 /* Try to lock a file, return 1 if success. */
532 #if defined (__vxworks) || defined (__nucleus__) \
533 || defined (_WIN32) || defined (VMS)
535 /* Version that does not use link. */
538 __gnat_try_lock (char *dir
, char *file
)
542 TCHAR wfull_path
[GNAT_MAX_PATH_LEN
];
543 TCHAR wfile
[GNAT_MAX_PATH_LEN
];
544 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
546 S2WSC (wdir
, dir
, GNAT_MAX_PATH_LEN
);
547 S2WSC (wfile
, file
, GNAT_MAX_PATH_LEN
);
549 _stprintf (wfull_path
, _T("%s%c%s"), wdir
, _T(DIR_SEPARATOR
), wfile
);
550 fd
= _topen (wfull_path
, O_CREAT
| O_EXCL
, 0600);
554 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
555 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
567 /* Version using link(), more secure over NFS. */
568 /* See TN 6913-016 for discussion ??? */
571 __gnat_try_lock (char *dir
, char *file
)
575 GNAT_STRUCT_STAT stat_result
;
578 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
579 sprintf (temp_file
, "%s%cTMP-%ld-%ld",
580 dir
, DIR_SEPARATOR
, (long)getpid(), (long)getppid ());
582 /* Create the temporary file and write the process number. */
583 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
589 /* Link it with the new file. */
590 link (temp_file
, full_path
);
592 /* Count the references on the old one. If we have a count of two, then
593 the link did succeed. Remove the temporary file before returning. */
594 __gnat_stat (temp_file
, &stat_result
);
596 return stat_result
.st_nlink
== 2;
600 /* Return the maximum file name length. */
603 __gnat_get_maximum_file_name_length (void)
606 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
615 /* Return nonzero if file names are case sensitive. */
617 static int file_names_case_sensitive_cache
= -1;
620 __gnat_get_file_names_case_sensitive (void)
622 if (file_names_case_sensitive_cache
== -1)
624 const char *sensitive
= getenv ("GNAT_FILE_NAME_CASE_SENSITIVE");
626 if (sensitive
!= NULL
627 && (sensitive
[0] == '0' || sensitive
[0] == '1')
628 && sensitive
[1] == '\0')
629 file_names_case_sensitive_cache
= sensitive
[0] - '0';
631 #if defined (VMS) || defined (WINNT) || defined (__APPLE__)
632 file_names_case_sensitive_cache
= 0;
634 file_names_case_sensitive_cache
= 1;
637 return file_names_case_sensitive_cache
;
640 /* Return nonzero if environment variables are case sensitive. */
643 __gnat_get_env_vars_case_sensitive (void)
645 #if defined (VMS) || defined (WINNT)
653 __gnat_get_default_identifier_character_set (void)
658 /* Return the current working directory. */
661 __gnat_get_current_dir (char *dir
, int *length
)
663 #if defined (__MINGW32__)
664 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
666 _tgetcwd (wdir
, *length
);
668 WS2SC (dir
, wdir
, GNAT_MAX_PATH_LEN
);
671 /* Force Unix style, which is what GNAT uses internally. */
672 getcwd (dir
, *length
, 0);
674 getcwd (dir
, *length
);
677 *length
= strlen (dir
);
679 if (dir
[*length
- 1] != DIR_SEPARATOR
)
681 dir
[*length
] = DIR_SEPARATOR
;
687 /* Return the suffix for object files. */
690 __gnat_get_object_suffix_ptr (int *len
, const char **value
)
692 *value
= HOST_OBJECT_SUFFIX
;
697 *len
= strlen (*value
);
702 /* Return the suffix for executable files. */
705 __gnat_get_executable_suffix_ptr (int *len
, const char **value
)
707 *value
= HOST_EXECUTABLE_SUFFIX
;
711 *len
= strlen (*value
);
716 /* Return the suffix for debuggable files. Usually this is the same as the
717 executable extension. */
720 __gnat_get_debuggable_suffix_ptr (int *len
, const char **value
)
722 *value
= HOST_EXECUTABLE_SUFFIX
;
727 *len
= strlen (*value
);
732 /* Returns the OS filename and corresponding encoding. */
735 __gnat_os_filename (char *filename ATTRIBUTE_UNUSED
,
736 char *w_filename ATTRIBUTE_UNUSED
,
737 char *os_name
, int *o_length
,
738 char *encoding ATTRIBUTE_UNUSED
, int *e_length
)
740 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
741 WS2SC (os_name
, (TCHAR
*)w_filename
, (DWORD
)*o_length
);
742 *o_length
= strlen (os_name
);
743 strcpy (encoding
, "encoding=utf8");
744 *e_length
= strlen (encoding
);
746 strcpy (os_name
, filename
);
747 *o_length
= strlen (filename
);
755 __gnat_unlink (char *path
)
757 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
759 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
761 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
762 return _tunlink (wpath
);
765 return unlink (path
);
772 __gnat_rename (char *from
, char *to
)
774 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
776 TCHAR wfrom
[GNAT_MAX_PATH_LEN
], wto
[GNAT_MAX_PATH_LEN
];
778 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
);
779 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
);
780 return _trename (wfrom
, wto
);
783 return rename (from
, to
);
787 /* Changing directory. */
790 __gnat_chdir (char *path
)
792 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
794 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
796 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
797 return _tchdir (wpath
);
804 /* Removing a directory. */
807 __gnat_rmdir (char *path
)
809 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
811 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
813 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
814 return _trmdir (wpath
);
816 #elif defined (VTHREADS)
817 /* rmdir not available */
825 __gnat_fopen (char *path
, char *mode
, int encoding ATTRIBUTE_UNUSED
,
826 char *vms_form ATTRIBUTE_UNUSED
)
828 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
829 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
832 S2WS (wmode
, mode
, 10);
834 if (encoding
== Encoding_Unspecified
)
835 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
836 else if (encoding
== Encoding_UTF8
)
837 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
839 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
841 return _tfopen (wpath
, wmode
);
844 return decc$
fopen (path
, mode
);
847 char *local_form
= (char *) alloca (strlen (vms_form
) + 1);
848 /* Allocate an argument list of guaranteed ample length. */
849 unsigned long long *arg_list
=
850 (unsigned long long *) alloca (strlen (vms_form
) + 3);
854 arg_list
[1] = (unsigned long long) path
;
855 arg_list
[2] = (unsigned long long) mode
;
856 strcpy (local_form
, vms_form
);
858 /* Given a string such as "\"rfm=udf\",\"rat=cr\""
859 Split it into an argument list as "rfm=udf","rat=cr". */
861 for (i
= 0; *ptrb
; i
++)
863 ptrb
= strchr (ptrb
, '"');
864 ptre
= strchr (ptrb
+ 1, '"');
866 arg_list
[i
+ 3] = (unsigned long long) (ptrb
+ 1);
869 arg_list
[0] = i
+ 2;
870 /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
871 always a 32bit pointer. */
872 return LIB$
CALLG_64 (arg_list
, &decc$fopen
);
875 return GNAT_FOPEN (path
, mode
);
880 __gnat_freopen (char *path
,
883 int encoding ATTRIBUTE_UNUSED
,
884 char *vms_form ATTRIBUTE_UNUSED
)
886 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
887 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
890 S2WS (wmode
, mode
, 10);
892 if (encoding
== Encoding_Unspecified
)
893 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
894 else if (encoding
== Encoding_UTF8
)
895 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
897 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
899 return _tfreopen (wpath
, wmode
, stream
);
902 return decc$
freopen (path
, mode
, stream
);
905 char *local_form
= (char *) alloca (strlen (vms_form
) + 1);
906 /* Allocate an argument list of guaranteed ample length. */
907 unsigned long long *arg_list
=
908 (unsigned long long *) alloca (strlen (vms_form
) + 4);
912 arg_list
[1] = (unsigned long long) path
;
913 arg_list
[2] = (unsigned long long) mode
;
914 arg_list
[3] = (unsigned long long) stream
;
915 strcpy (local_form
, vms_form
);
917 /* Given a string such as "\"rfm=udf\",\"rat=cr\""
918 Split it into an argument list as "rfm=udf","rat=cr". */
920 for (i
= 0; *ptrb
; i
++)
922 ptrb
= strchr (ptrb
, '"');
923 ptre
= strchr (ptrb
+ 1, '"');
925 arg_list
[i
+ 4] = (unsigned long long) (ptrb
+ 1);
928 arg_list
[0] = i
+ 3;
929 /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
930 always a 32bit pointer. */
931 return LIB$
CALLG_64 (arg_list
, &decc$freopen
);
934 return freopen (path
, mode
, stream
);
939 __gnat_open_read (char *path
, int fmode
)
942 int o_fmode
= O_BINARY
;
948 /* Optional arguments mbc,deq,fop increase read performance. */
949 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
950 "mbc=16", "deq=64", "fop=tef");
951 #elif defined (__vxworks)
952 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
953 #elif defined (__MINGW32__)
955 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
957 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
958 fd
= _topen (wpath
, O_RDONLY
| o_fmode
, 0444);
961 fd
= open (path
, O_RDONLY
| o_fmode
);
964 return fd
< 0 ? -1 : fd
;
967 #if defined (__MINGW32__)
968 #define PERM (S_IREAD | S_IWRITE)
970 /* Excerpt from DECC C RTL Reference Manual:
971 To create files with OpenVMS RMS default protections using the UNIX
972 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
973 and open with a file-protection mode argument of 0777 in a program
974 that never specifically calls umask. These default protections include
975 correctly establishing protections based on ACLs, previous versions of
979 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
983 __gnat_open_rw (char *path
, int fmode
)
986 int o_fmode
= O_BINARY
;
992 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
993 "mbc=16", "deq=64", "fop=tef");
994 #elif defined (__MINGW32__)
996 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
998 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
999 fd
= _topen (wpath
, O_RDWR
| o_fmode
, PERM
);
1002 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
1005 return fd
< 0 ? -1 : fd
;
1009 __gnat_open_create (char *path
, int fmode
)
1012 int o_fmode
= O_BINARY
;
1018 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
1019 "mbc=16", "deq=64", "fop=tef");
1020 #elif defined (__MINGW32__)
1022 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1024 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1025 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
1028 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
1031 return fd
< 0 ? -1 : fd
;
1035 __gnat_create_output_file (char *path
)
1039 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
,
1040 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
1041 "shr=del,get,put,upd");
1042 #elif defined (__MINGW32__)
1044 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1046 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1047 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
1050 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
1053 return fd
< 0 ? -1 : fd
;
1057 __gnat_create_output_file_new (char *path
)
1061 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
,
1062 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
1063 "shr=del,get,put,upd");
1064 #elif defined (__MINGW32__)
1066 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1068 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1069 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
1072 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
1075 return fd
< 0 ? -1 : fd
;
1079 __gnat_open_append (char *path
, int fmode
)
1082 int o_fmode
= O_BINARY
;
1088 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
1089 "mbc=16", "deq=64", "fop=tef");
1090 #elif defined (__MINGW32__)
1092 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1094 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1095 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
1098 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
1101 return fd
< 0 ? -1 : fd
;
1104 /* Open a new file. Return error (-1) if the file already exists. */
1107 __gnat_open_new (char *path
, int fmode
)
1110 int o_fmode
= O_BINARY
;
1116 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1117 "mbc=16", "deq=64", "fop=tef");
1118 #elif defined (__MINGW32__)
1120 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1122 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1123 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1126 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1129 return fd
< 0 ? -1 : fd
;
1132 /* Open a new temp file. Return error (-1) if the file already exists.
1133 Special options for VMS allow the file to be shared between parent and child
1134 processes, however they really slow down output. Used in gnatchop. */
1137 __gnat_open_new_temp (char *path
, int fmode
)
1140 int o_fmode
= O_BINARY
;
1142 strcpy (path
, "GNAT-XXXXXX");
1144 #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \
1145 || defined (linux) || defined(__GLIBC__)) && !defined (__vxworks)
1146 return mkstemp (path
);
1147 #elif defined (__Lynx__)
1149 #elif defined (__nucleus__)
1152 if (mktemp (path
) == NULL
)
1160 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1161 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
1162 "mbc=16", "deq=64", "fop=tef");
1164 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1167 return fd
< 0 ? -1 : fd
;
1170 /****************************************************************
1171 ** Perform a call to GNAT_STAT or GNAT_FSTAT, and extract as much information
1172 ** as possible from it, storing the result in a cache for later reuse
1173 ****************************************************************/
1176 __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
)
1178 GNAT_STRUCT_STAT statbuf
;
1182 ret
= GNAT_FSTAT (fd
, &statbuf
);
1184 ret
= __gnat_stat (name
, &statbuf
);
1186 attr
->regular
= (!ret
&& S_ISREG (statbuf
.st_mode
));
1187 attr
->directory
= (!ret
&& S_ISDIR (statbuf
.st_mode
));
1190 attr
->file_length
= 0;
1192 /* st_size may be 32 bits, or 64 bits which is converted to long. We
1193 don't return a useful value for files larger than 2 gigabytes in
1195 attr
->file_length
= statbuf
.st_size
; /* all systems */
1197 attr
->exists
= !ret
;
1199 #if !defined (_WIN32) || defined (RTX)
1200 /* on Windows requires extra system call, see __gnat_is_readable_file_attr */
1201 attr
->readable
= (!ret
&& (statbuf
.st_mode
& S_IRUSR
));
1202 attr
->writable
= (!ret
&& (statbuf
.st_mode
& S_IWUSR
));
1203 attr
->executable
= (!ret
&& (statbuf
.st_mode
& S_IXUSR
));
1207 attr
->timestamp
= (OS_Time
)-1;
1210 /* VMS has file versioning. */
1211 attr
->timestamp
= (OS_Time
)statbuf
.st_ctime
;
1213 attr
->timestamp
= (OS_Time
)statbuf
.st_mtime
;
1218 /****************************************************************
1219 ** Return the number of bytes in the specified file
1220 ****************************************************************/
1223 __gnat_file_length_attr (int fd
, char* name
, struct file_attributes
* attr
)
1225 if (attr
->file_length
== -1) {
1226 __gnat_stat_to_attr (fd
, name
, attr
);
1229 return attr
->file_length
;
1233 __gnat_file_length (int fd
)
1235 struct file_attributes attr
;
1236 __gnat_reset_attributes (&attr
);
1237 return __gnat_file_length_attr (fd
, NULL
, &attr
);
1241 __gnat_named_file_length (char *name
)
1243 struct file_attributes attr
;
1244 __gnat_reset_attributes (&attr
);
1245 return __gnat_file_length_attr (-1, name
, &attr
);
1248 /* Create a temporary filename and put it in string pointed to by
1252 __gnat_tmp_name (char *tmp_filename
)
1255 /* Variable used to create a series of unique names */
1256 static int counter
= 0;
1258 /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */
1259 strcpy (tmp_filename
, "c:\\WINDOWS\\Temp\\gnat-");
1260 sprintf (&tmp_filename
[strlen (tmp_filename
)], "%d\0", counter
++);
1262 #elif defined (__MINGW32__)
1267 /* tempnam tries to create a temporary file in directory pointed to by
1268 TMP environment variable, in c:\temp if TMP is not set, and in
1269 directory specified by P_tmpdir in stdio.h if c:\temp does not
1270 exist. The filename will be created with the prefix "gnat-". */
1272 sprintf (prefix
, "gnat-%d-", (int)getpid());
1273 pname
= (char *) _tempnam ("c:\\temp", prefix
);
1275 /* if pname is NULL, the file was not created properly, the disk is full
1276 or there is no more free temporary files */
1279 *tmp_filename
= '\0';
1281 /* If pname start with a back slash and not path information it means that
1282 the filename is valid for the current working directory. */
1284 else if (pname
[0] == '\\')
1286 strcpy (tmp_filename
, ".\\");
1287 strcat (tmp_filename
, pname
+1);
1290 strcpy (tmp_filename
, pname
);
1295 #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \
1296 || defined (__OpenBSD__) || defined(__GLIBC__)
1297 #define MAX_SAFE_PATH 1000
1298 char *tmpdir
= getenv ("TMPDIR");
1300 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
1301 a buffer overflow. */
1302 if (tmpdir
== NULL
|| strlen (tmpdir
) > MAX_SAFE_PATH
)
1303 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
1305 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
1307 close (mkstemp(tmp_filename
));
1308 #elif defined (__vxworks) && !(defined (__RTP__) || defined (VTHREADS))
1312 static ushort_t seed
= 0; /* used to generate unique name */
1314 /* generate unique name */
1315 strcpy (tmp_filename
, "tmp");
1317 /* fill up the name buffer from the last position */
1319 pos
= tmp_filename
+ strlen (tmp_filename
) + index
;
1323 for (t
= seed
; 0 <= --index
; t
>>= 3)
1324 *--pos
= '0' + (t
& 07);
1326 tmpnam (tmp_filename
);
1330 /* Open directory and returns a DIR pointer. */
1332 DIR* __gnat_opendir (char *name
)
1335 /* Not supported in RTX */
1339 #elif defined (__MINGW32__)
1340 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1342 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1343 return (DIR*)_topendir (wname
);
1346 return opendir (name
);
1350 /* Read the next entry in a directory. The returned string points somewhere
1354 __gnat_readdir (DIR *dirp
, char *buffer
, int *len
)
1357 /* Not supported in RTX */
1361 #elif defined (__MINGW32__)
1362 struct _tdirent
*dirent
= _treaddir ((_TDIR
*)dirp
);
1366 WS2SC (buffer
, dirent
->d_name
, GNAT_MAX_PATH_LEN
);
1367 *len
= strlen (buffer
);
1374 #elif defined (HAVE_READDIR_R)
1375 /* If possible, try to use the thread-safe version. */
1376 if (readdir_r (dirp
, buffer
) != NULL
)
1378 *len
= strlen (((struct dirent
*) buffer
)->d_name
);
1379 return ((struct dirent
*) buffer
)->d_name
;
1385 struct dirent
*dirent
= (struct dirent
*) readdir (dirp
);
1389 strcpy (buffer
, dirent
->d_name
);
1390 *len
= strlen (buffer
);
1399 /* Close a directory entry. */
1401 int __gnat_closedir (DIR *dirp
)
1404 /* Not supported in RTX */
1408 #elif defined (__MINGW32__)
1409 return _tclosedir ((_TDIR
*)dirp
);
1412 return closedir (dirp
);
1416 /* Returns 1 if readdir is thread safe, 0 otherwise. */
1419 __gnat_readdir_is_thread_safe (void)
1421 #ifdef HAVE_READDIR_R
1428 #if defined (_WIN32) && !defined (RTX)
1429 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
1430 static const unsigned long long w32_epoch_offset
= 11644473600ULL;
1432 /* Returns the file modification timestamp using Win32 routines which are
1433 immune against daylight saving time change. It is in fact not possible to
1434 use fstat for this purpose as the DST modify the st_mtime field of the
1438 win32_filetime (HANDLE h
)
1443 unsigned long long ull_time
;
1446 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1447 since <Jan 1st 1601>. This function must return the number of seconds
1448 since <Jan 1st 1970>. */
1450 if (GetFileTime (h
, NULL
, NULL
, &t_write
.ft_time
))
1451 return (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1455 /* As above but starting from a FILETIME. */
1457 f2t (const FILETIME
*ft
, time_t *t
)
1462 unsigned long long ull_time
;
1465 t_write
.ft_time
= *ft
;
1466 *t
= (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1470 /* Return a GNAT time stamp given a file name. */
1473 __gnat_file_time_name_attr (char* name
, struct file_attributes
* attr
)
1475 if (attr
->timestamp
== (OS_Time
)-2) {
1476 #if defined (_WIN32) && !defined (RTX)
1478 WIN32_FILE_ATTRIBUTE_DATA fad
;
1480 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1481 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1483 if ((res
= GetFileAttributesEx (wname
, GetFileExInfoStandard
, &fad
)))
1484 f2t (&fad
.ftLastWriteTime
, &ret
);
1485 attr
->timestamp
= (OS_Time
) ret
;
1487 __gnat_stat_to_attr (-1, name
, attr
);
1490 return attr
->timestamp
;
1494 __gnat_file_time_name (char *name
)
1496 struct file_attributes attr
;
1497 __gnat_reset_attributes (&attr
);
1498 return __gnat_file_time_name_attr (name
, &attr
);
1501 /* Return a GNAT time stamp given a file descriptor. */
1504 __gnat_file_time_fd_attr (int fd
, struct file_attributes
* attr
)
1506 if (attr
->timestamp
== (OS_Time
)-2) {
1507 #if defined (_WIN32) && !defined (RTX)
1508 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
1509 time_t ret
= win32_filetime (h
);
1510 attr
->timestamp
= (OS_Time
) ret
;
1513 __gnat_stat_to_attr (fd
, NULL
, attr
);
1517 return attr
->timestamp
;
1521 __gnat_file_time_fd (int fd
)
1523 struct file_attributes attr
;
1524 __gnat_reset_attributes (&attr
);
1525 return __gnat_file_time_fd_attr (fd
, &attr
);
1528 /* Set the file time stamp. */
1531 __gnat_set_file_time_name (char *name
, time_t time_stamp
)
1533 #if defined (__vxworks)
1535 /* Code to implement __gnat_set_file_time_name for these systems. */
1537 #elif defined (_WIN32) && !defined (RTX)
1541 unsigned long long ull_time
;
1543 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1545 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1547 HANDLE h
= CreateFile
1548 (wname
, GENERIC_WRITE
, FILE_SHARE_WRITE
, NULL
,
1549 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
,
1551 if (h
== INVALID_HANDLE_VALUE
)
1553 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1554 t_write
.ull_time
= ((unsigned long long)time_stamp
+ w32_epoch_offset
);
1555 /* Convert to 100 nanosecond units */
1556 t_write
.ull_time
*= 10000000ULL;
1558 SetFileTime(h
, NULL
, NULL
, &t_write
.ft_time
);
1568 unsigned long long backup
, create
, expire
, revise
;
1572 unsigned short value
;
1575 unsigned system
: 4;
1581 } Fat
= { 0, 0, 0, 0, 0, { 0 }};
1585 { ATR$S_CREDATE
, ATR$C_CREDATE
, &Fat
.create
},
1586 { ATR$S_REVDATE
, ATR$C_REVDATE
, &Fat
.revise
},
1587 { ATR$S_EXPDATE
, ATR$C_EXPDATE
, &Fat
.expire
},
1588 { ATR$S_BAKDATE
, ATR$C_BAKDATE
, &Fat
.backup
},
1589 { ATR$S_FPRO
, ATR$C_FPRO
, &Fat
.prot
},
1590 { ATR$S_UIC
, ATR$C_UIC
, &Fat
.uic
},
1595 struct dsc$descriptor_fib fibdsc
= {sizeof (fib
), (void *) &fib
};
1599 unsigned long long newtime
;
1600 unsigned long long revtime
;
1604 struct vstring file
;
1605 struct dsc$descriptor_s filedsc
1606 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) file
.string
};
1607 struct vstring device
;
1608 struct dsc$descriptor_s devicedsc
1609 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) device
.string
};
1610 struct vstring timev
;
1611 struct dsc$descriptor_s timedsc
1612 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) timev
.string
};
1613 struct vstring result
;
1614 struct dsc$descriptor_s resultdsc
1615 = {NAM$C_MAXRSS
, DSC$K_DTYPE_VT
, DSC$K_CLASS_VS
, (void *) result
.string
};
1617 /* Convert parameter name (a file spec) to host file form. Note that this
1618 is needed on VMS to prepare for subsequent calls to VMS RMS library
1619 routines. Note that it would not work to call __gnat_to_host_dir_spec
1620 as was done in a previous version, since this fails silently unless
1621 the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1622 (directory not found) condition is signalled. */
1623 tryfile
= (char *) __gnat_to_host_file_spec (name
);
1625 /* Allocate and initialize a FAB and NAM structures. */
1629 nam
.nam$l_esa
= file
.string
;
1630 nam
.nam$b_ess
= NAM$C_MAXRSS
;
1631 nam
.nam$l_rsa
= result
.string
;
1632 nam
.nam$b_rss
= NAM$C_MAXRSS
;
1633 fab
.fab$l_fna
= tryfile
;
1634 fab
.fab$b_fns
= strlen (tryfile
);
1635 fab
.fab$l_nam
= &nam
;
1637 /* Validate filespec syntax and device existence. */
1638 status
= SYS$
PARSE (&fab
, 0, 0);
1639 if ((status
& 1) != 1)
1640 LIB$
SIGNAL (status
);
1642 file
.string
[nam
.nam$b_esl
] = 0;
1644 /* Find matching filespec. */
1645 status
= SYS$
SEARCH (&fab
, 0, 0);
1646 if ((status
& 1) != 1)
1647 LIB$
SIGNAL (status
);
1649 file
.string
[nam
.nam$b_esl
] = 0;
1650 result
.string
[result
.length
=nam
.nam$b_rsl
] = 0;
1652 /* Get the device name and assign an IO channel. */
1653 strncpy (device
.string
, nam
.nam$l_dev
, nam
.nam$b_dev
);
1654 devicedsc
.dsc$w_length
= nam
.nam$b_dev
;
1656 status
= SYS$
ASSIGN (&devicedsc
, &chan
, 0, 0, 0);
1657 if ((status
& 1) != 1)
1658 LIB$
SIGNAL (status
);
1660 /* Initialize the FIB and fill in the directory id field. */
1661 memset (&fib
, 0, sizeof (fib
));
1662 fib
.fib$w_did
[0] = nam
.nam$w_did
[0];
1663 fib
.fib$w_did
[1] = nam
.nam$w_did
[1];
1664 fib
.fib$w_did
[2] = nam
.nam$w_did
[2];
1665 fib
.fib$l_acctl
= 0;
1667 strcpy (file
.string
, (strrchr (result
.string
, ']') + 1));
1668 filedsc
.dsc$w_length
= strlen (file
.string
);
1669 result
.string
[result
.length
= 0] = 0;
1671 /* Open and close the file to fill in the attributes. */
1673 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1674 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1675 if ((status
& 1) != 1)
1676 LIB$
SIGNAL (status
);
1677 if ((iosb
.status
& 1) != 1)
1678 LIB$
SIGNAL (iosb
.status
);
1680 result
.string
[result
.length
] = 0;
1681 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0, &fibdsc
, 0, 0, 0,
1683 if ((status
& 1) != 1)
1684 LIB$
SIGNAL (status
);
1685 if ((iosb
.status
& 1) != 1)
1686 LIB$
SIGNAL (iosb
.status
);
1691 /* Set creation time to requested time. */
1692 unix_time_to_vms (time_stamp
, newtime
);
1694 t
= time ((time_t) 0);
1696 /* Set revision time to now in local time. */
1697 unix_time_to_vms (t
, revtime
);
1700 /* Reopen the file, modify the times and then close. */
1701 fib
.fib$l_acctl
= FIB$M_WRITE
;
1703 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1704 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1705 if ((status
& 1) != 1)
1706 LIB$
SIGNAL (status
);
1707 if ((iosb
.status
& 1) != 1)
1708 LIB$
SIGNAL (iosb
.status
);
1710 Fat
.create
= newtime
;
1711 Fat
.revise
= revtime
;
1713 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0,
1714 &fibdsc
, 0, 0, 0, &atrlst
, 0);
1715 if ((status
& 1) != 1)
1716 LIB$
SIGNAL (status
);
1717 if ((iosb
.status
& 1) != 1)
1718 LIB$
SIGNAL (iosb
.status
);
1720 /* Deassign the channel and exit. */
1721 status
= SYS$
DASSGN (chan
);
1722 if ((status
& 1) != 1)
1723 LIB$
SIGNAL (status
);
1725 struct utimbuf utimbuf
;
1728 /* Set modification time to requested time. */
1729 utimbuf
.modtime
= time_stamp
;
1731 /* Set access time to now in local time. */
1732 t
= time ((time_t) 0);
1733 utimbuf
.actime
= mktime (localtime (&t
));
1735 utime (name
, &utimbuf
);
1739 /* Get the list of installed standard libraries from the
1740 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1744 __gnat_get_libraries_from_registry (void)
1746 char *result
= (char *) xmalloc (1);
1750 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) \
1754 DWORD name_size
, value_size
;
1761 /* First open the key. */
1762 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1764 if (res
== ERROR_SUCCESS
)
1765 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1766 KEY_READ
, ®_key
);
1768 if (res
== ERROR_SUCCESS
)
1769 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1771 if (res
== ERROR_SUCCESS
)
1772 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1774 /* If the key exists, read out all the values in it and concatenate them
1776 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1778 value_size
= name_size
= 256;
1779 res
= RegEnumValueA (reg_key
, index
, name
, &name_size
, 0,
1780 &type
, (LPBYTE
)value
, &value_size
);
1782 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1784 char *old_result
= result
;
1786 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1787 strcpy (result
, old_result
);
1788 strcat (result
, value
);
1789 strcat (result
, ";");
1794 /* Remove the trailing ";". */
1796 result
[strlen (result
) - 1] = 0;
1803 __gnat_stat (char *name
, GNAT_STRUCT_STAT
*statbuf
)
1806 WIN32_FILE_ATTRIBUTE_DATA fad
;
1807 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
1812 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
1813 name_len
= _tcslen (wname
);
1815 if (name_len
> GNAT_MAX_PATH_LEN
)
1818 ZeroMemory (statbuf
, sizeof(GNAT_STRUCT_STAT
));
1820 res
= GetFileAttributesEx (wname
, GetFileExInfoStandard
, &fad
);
1823 error
= GetLastError();
1825 /* Check file existence using GetFileAttributes() which does not fail on
1826 special Windows files like con:, aux:, nul: etc... */
1828 if (GetFileAttributes(wname
) != INVALID_FILE_ATTRIBUTES
) {
1829 /* Just pretend that it is a regular and readable file */
1830 statbuf
->st_mode
= S_IFREG
| S_IREAD
| S_IWRITE
;
1835 case ERROR_ACCESS_DENIED
:
1836 case ERROR_SHARING_VIOLATION
:
1837 case ERROR_LOCK_VIOLATION
:
1838 case ERROR_SHARING_BUFFER_EXCEEDED
:
1840 case ERROR_BUFFER_OVERFLOW
:
1841 return ENAMETOOLONG
;
1842 case ERROR_NOT_ENOUGH_MEMORY
:
1849 f2t (&fad
.ftCreationTime
, &statbuf
->st_ctime
);
1850 f2t (&fad
.ftLastWriteTime
, &statbuf
->st_mtime
);
1851 f2t (&fad
.ftLastAccessTime
, &statbuf
->st_atime
);
1853 statbuf
->st_size
= (off_t
)fad
.nFileSizeLow
;
1855 /* We do not have the S_IEXEC attribute, but this is not used on GNAT. */
1856 statbuf
->st_mode
= S_IREAD
;
1858 if (fad
.dwFileAttributes
& FILE_ATTRIBUTE_DIRECTORY
)
1859 statbuf
->st_mode
|= S_IFDIR
;
1861 statbuf
->st_mode
|= S_IFREG
;
1863 if (!(fad
.dwFileAttributes
& FILE_ATTRIBUTE_READONLY
))
1864 statbuf
->st_mode
|= S_IWRITE
;
1869 return GNAT_STAT (name
, statbuf
);
1873 /*************************************************************************
1874 ** Check whether a file exists
1875 *************************************************************************/
1878 __gnat_file_exists_attr (char* name
, struct file_attributes
* attr
)
1880 if (attr
->exists
== ATTR_UNSET
) {
1881 __gnat_stat_to_attr (-1, name
, attr
);
1884 return attr
->exists
;
1888 __gnat_file_exists (char *name
)
1890 struct file_attributes attr
;
1891 __gnat_reset_attributes (&attr
);
1892 return __gnat_file_exists_attr (name
, &attr
);
1895 /**********************************************************************
1896 ** Whether name is an absolute path
1897 **********************************************************************/
1900 __gnat_is_absolute_path (char *name
, int length
)
1903 /* On VxWorks systems, an absolute path can be represented (depending on
1904 the host platform) as either /dir/file, or device:/dir/file, or
1905 device:drive_letter:/dir/file. */
1912 for (index
= 0; index
< length
; index
++)
1914 if (name
[index
] == ':' &&
1915 ((name
[index
+ 1] == '/') ||
1916 (isalpha (name
[index
+ 1]) && index
+ 2 <= length
&&
1917 name
[index
+ 2] == '/')))
1920 else if (name
[index
] == '/')
1925 return (length
!= 0) &&
1926 (*name
== '/' || *name
== DIR_SEPARATOR
1928 || (length
> 1 && ISALPHA (name
[0]) && name
[1] == ':')
1935 __gnat_is_regular_file_attr (char* name
, struct file_attributes
* attr
)
1937 if (attr
->regular
== ATTR_UNSET
) {
1938 __gnat_stat_to_attr (-1, name
, attr
);
1941 return attr
->regular
;
1945 __gnat_is_regular_file (char *name
)
1947 struct file_attributes attr
;
1948 __gnat_reset_attributes (&attr
);
1949 return __gnat_is_regular_file_attr (name
, &attr
);
1953 __gnat_is_directory_attr (char* name
, struct file_attributes
* attr
)
1955 if (attr
->directory
== ATTR_UNSET
) {
1956 __gnat_stat_to_attr (-1, name
, attr
);
1959 return attr
->directory
;
1963 __gnat_is_directory (char *name
)
1965 struct file_attributes attr
;
1966 __gnat_reset_attributes (&attr
);
1967 return __gnat_is_directory_attr (name
, &attr
);
1970 #if defined (_WIN32) && !defined (RTX)
1972 /* Returns the same constant as GetDriveType but takes a pathname as
1976 GetDriveTypeFromPath (TCHAR
*wfullpath
)
1978 TCHAR wdrv
[MAX_PATH
];
1979 TCHAR wpath
[MAX_PATH
];
1980 TCHAR wfilename
[MAX_PATH
];
1981 TCHAR wext
[MAX_PATH
];
1983 _tsplitpath (wfullpath
, wdrv
, wpath
, wfilename
, wext
);
1985 if (_tcslen (wdrv
) != 0)
1987 /* we have a drive specified. */
1988 _tcscat (wdrv
, _T("\\"));
1989 return GetDriveType (wdrv
);
1993 /* No drive specified. */
1995 /* Is this a relative path, if so get current drive type. */
1996 if (wpath
[0] != _T('\\') ||
1997 (_tcslen (wpath
) > 2 && wpath
[0] == _T('\\') && wpath
[1] != _T('\\')))
1998 return GetDriveType (NULL
);
2000 UINT result
= GetDriveType (wpath
);
2002 /* Cannot guess the drive type, is this \\.\ ? */
2004 if (result
== DRIVE_NO_ROOT_DIR
&&
2005 _tcslen (wpath
) >= 4 && wpath
[0] == _T('\\') && wpath
[1] == _T('\\')
2006 && wpath
[2] == _T('.') && wpath
[3] == _T('\\'))
2008 if (_tcslen (wpath
) == 4)
2009 _tcscat (wpath
, wfilename
);
2011 LPTSTR p
= &wpath
[4];
2012 LPTSTR b
= _tcschr (p
, _T('\\'));
2015 { /* logical drive \\.\c\dir\file */
2021 _tcscat (p
, _T(":\\"));
2023 return GetDriveType (p
);
2030 /* This MingW section contains code to work with ACL. */
2032 __gnat_check_OWNER_ACL
2034 DWORD CheckAccessDesired
,
2035 GENERIC_MAPPING CheckGenericMapping
)
2037 DWORD dwAccessDesired
, dwAccessAllowed
;
2038 PRIVILEGE_SET PrivilegeSet
;
2039 DWORD dwPrivSetSize
= sizeof (PRIVILEGE_SET
);
2040 BOOL fAccessGranted
= FALSE
;
2041 HANDLE hToken
= NULL
;
2043 SECURITY_DESCRIPTOR
* pSD
= NULL
;
2046 (wname
, OWNER_SECURITY_INFORMATION
|
2047 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
2050 if ((pSD
= (SECURITY_DESCRIPTOR
*) HeapAlloc
2051 (GetProcessHeap (), HEAP_ZERO_MEMORY
, nLength
)) == NULL
)
2054 /* Obtain the security descriptor. */
2056 if (!GetFileSecurity
2057 (wname
, OWNER_SECURITY_INFORMATION
|
2058 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
2059 pSD
, nLength
, &nLength
))
2062 if (!ImpersonateSelf (SecurityImpersonation
))
2065 if (!OpenThreadToken
2066 (GetCurrentThread(), TOKEN_DUPLICATE
| TOKEN_QUERY
, FALSE
, &hToken
))
2069 /* Undoes the effect of ImpersonateSelf. */
2073 /* We want to test for write permissions. */
2075 dwAccessDesired
= CheckAccessDesired
;
2077 MapGenericMask (&dwAccessDesired
, &CheckGenericMapping
);
2080 (pSD
, /* security descriptor to check */
2081 hToken
, /* impersonation token */
2082 dwAccessDesired
, /* requested access rights */
2083 &CheckGenericMapping
, /* pointer to GENERIC_MAPPING */
2084 &PrivilegeSet
, /* receives privileges used in check */
2085 &dwPrivSetSize
, /* size of PrivilegeSet buffer */
2086 &dwAccessAllowed
, /* receives mask of allowed access rights */
2090 CloseHandle (hToken
);
2091 HeapFree (GetProcessHeap (), 0, pSD
);
2092 return fAccessGranted
;
2096 CloseHandle (hToken
);
2097 HeapFree (GetProcessHeap (), 0, pSD
);
2102 __gnat_set_OWNER_ACL
2105 DWORD AccessPermissions
)
2107 PACL pOldDACL
= NULL
;
2108 PACL pNewDACL
= NULL
;
2109 PSECURITY_DESCRIPTOR pSD
= NULL
;
2111 TCHAR username
[100];
2114 /* Get current user, he will act as the owner */
2116 if (!GetUserName (username
, &unsize
))
2119 if (GetNamedSecurityInfo
2122 DACL_SECURITY_INFORMATION
,
2123 NULL
, NULL
, &pOldDACL
, NULL
, &pSD
) != ERROR_SUCCESS
)
2126 BuildExplicitAccessWithName
2127 (&ea
, username
, AccessPermissions
, (ACCESS_MODE
) AccessMode
, NO_INHERITANCE
);
2129 if (AccessMode
== SET_ACCESS
)
2131 /* SET_ACCESS, we want to set an explicte set of permissions, do not
2132 merge with current DACL. */
2133 if (SetEntriesInAcl (1, &ea
, NULL
, &pNewDACL
) != ERROR_SUCCESS
)
2137 if (SetEntriesInAcl (1, &ea
, pOldDACL
, &pNewDACL
) != ERROR_SUCCESS
)
2140 if (SetNamedSecurityInfo
2141 (wname
, SE_FILE_OBJECT
,
2142 DACL_SECURITY_INFORMATION
, NULL
, NULL
, pNewDACL
, NULL
) != ERROR_SUCCESS
)
2146 LocalFree (pNewDACL
);
2149 /* Check if it is possible to use ACL for wname, the file must not be on a
2153 __gnat_can_use_acl (TCHAR
*wname
)
2155 return __gnat_use_acl
&& GetDriveTypeFromPath (wname
) != DRIVE_REMOTE
;
2158 #endif /* defined (_WIN32) && !defined (RTX) */
2161 __gnat_is_readable_file_attr (char* name
, struct file_attributes
* attr
)
2163 if (attr
->readable
== ATTR_UNSET
) {
2164 #if defined (_WIN32) && !defined (RTX)
2165 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2166 GENERIC_MAPPING GenericMapping
;
2168 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2170 if (__gnat_can_use_acl (wname
))
2172 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2173 GenericMapping
.GenericRead
= GENERIC_READ
;
2175 __gnat_check_OWNER_ACL (wname
, FILE_READ_DATA
, GenericMapping
);
2178 attr
->readable
= GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
;
2180 __gnat_stat_to_attr (-1, name
, attr
);
2184 return attr
->readable
;
2188 __gnat_is_readable_file (char *name
)
2190 struct file_attributes attr
;
2191 __gnat_reset_attributes (&attr
);
2192 return __gnat_is_readable_file_attr (name
, &attr
);
2196 __gnat_is_writable_file_attr (char* name
, struct file_attributes
* attr
)
2198 if (attr
->writable
== ATTR_UNSET
) {
2199 #if defined (_WIN32) && !defined (RTX)
2200 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2201 GENERIC_MAPPING GenericMapping
;
2203 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2205 if (__gnat_can_use_acl (wname
))
2207 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2208 GenericMapping
.GenericWrite
= GENERIC_WRITE
;
2210 attr
->writable
= __gnat_check_OWNER_ACL
2211 (wname
, FILE_WRITE_DATA
| FILE_APPEND_DATA
, GenericMapping
)
2212 && !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2215 attr
->writable
= !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2218 __gnat_stat_to_attr (-1, name
, attr
);
2222 return attr
->writable
;
2226 __gnat_is_writable_file (char *name
)
2228 struct file_attributes attr
;
2229 __gnat_reset_attributes (&attr
);
2230 return __gnat_is_writable_file_attr (name
, &attr
);
2234 __gnat_is_executable_file_attr (char* name
, struct file_attributes
* attr
)
2236 if (attr
->executable
== ATTR_UNSET
) {
2237 #if defined (_WIN32) && !defined (RTX)
2238 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2239 GENERIC_MAPPING GenericMapping
;
2241 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2243 if (__gnat_can_use_acl (wname
))
2245 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2246 GenericMapping
.GenericExecute
= GENERIC_EXECUTE
;
2249 __gnat_check_OWNER_ACL (wname
, FILE_EXECUTE
, GenericMapping
);
2253 TCHAR
*l
, *last
= _tcsstr(wname
, _T(".exe"));
2255 /* look for last .exe */
2257 while ((l
= _tcsstr(last
+1, _T(".exe")))) last
= l
;
2259 attr
->executable
= GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
2260 && (last
- wname
) == (int) (_tcslen (wname
) - 4);
2263 __gnat_stat_to_attr (-1, name
, attr
);
2267 return attr
->regular
&& attr
->executable
;
2271 __gnat_is_executable_file (char *name
)
2273 struct file_attributes attr
;
2274 __gnat_reset_attributes (&attr
);
2275 return __gnat_is_executable_file_attr (name
, &attr
);
2279 __gnat_set_writable (char *name
)
2281 #if defined (_WIN32) && !defined (RTX)
2282 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2284 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2286 if (__gnat_can_use_acl (wname
))
2287 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_WRITE
);
2290 (wname
, GetFileAttributes (wname
) & ~FILE_ATTRIBUTE_READONLY
);
2291 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2292 ! defined(__nucleus__)
2293 GNAT_STRUCT_STAT statbuf
;
2295 if (GNAT_STAT (name
, &statbuf
) == 0)
2297 statbuf
.st_mode
= statbuf
.st_mode
| S_IWUSR
;
2298 chmod (name
, statbuf
.st_mode
);
2304 __gnat_set_executable (char *name
)
2306 #if defined (_WIN32) && !defined (RTX)
2307 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2309 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2311 if (__gnat_can_use_acl (wname
))
2312 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_EXECUTE
);
2314 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2315 ! defined(__nucleus__)
2316 GNAT_STRUCT_STAT statbuf
;
2318 if (GNAT_STAT (name
, &statbuf
) == 0)
2320 statbuf
.st_mode
= statbuf
.st_mode
| S_IXUSR
;
2321 chmod (name
, statbuf
.st_mode
);
2327 __gnat_set_non_writable (char *name
)
2329 #if defined (_WIN32) && !defined (RTX)
2330 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2332 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2334 if (__gnat_can_use_acl (wname
))
2335 __gnat_set_OWNER_ACL
2336 (wname
, DENY_ACCESS
,
2337 FILE_WRITE_DATA
| FILE_APPEND_DATA
|
2338 FILE_WRITE_EA
| FILE_WRITE_ATTRIBUTES
);
2341 (wname
, GetFileAttributes (wname
) | FILE_ATTRIBUTE_READONLY
);
2342 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2343 ! defined(__nucleus__)
2344 GNAT_STRUCT_STAT statbuf
;
2346 if (GNAT_STAT (name
, &statbuf
) == 0)
2348 statbuf
.st_mode
= statbuf
.st_mode
& 07577;
2349 chmod (name
, statbuf
.st_mode
);
2355 __gnat_set_readable (char *name
)
2357 #if defined (_WIN32) && !defined (RTX)
2358 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2360 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2362 if (__gnat_can_use_acl (wname
))
2363 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_READ
);
2365 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2366 ! defined(__nucleus__)
2367 GNAT_STRUCT_STAT statbuf
;
2369 if (GNAT_STAT (name
, &statbuf
) == 0)
2371 chmod (name
, statbuf
.st_mode
| S_IREAD
);
2377 __gnat_set_non_readable (char *name
)
2379 #if defined (_WIN32) && !defined (RTX)
2380 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2382 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2384 if (__gnat_can_use_acl (wname
))
2385 __gnat_set_OWNER_ACL (wname
, DENY_ACCESS
, FILE_GENERIC_READ
);
2387 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2388 ! defined(__nucleus__)
2389 GNAT_STRUCT_STAT statbuf
;
2391 if (GNAT_STAT (name
, &statbuf
) == 0)
2393 chmod (name
, statbuf
.st_mode
& (~S_IREAD
));
2399 __gnat_is_symbolic_link_attr (char* name ATTRIBUTE_UNUSED
,
2400 struct file_attributes
* attr
)
2402 if (attr
->symbolic_link
== ATTR_UNSET
) {
2403 #if defined (__vxworks) || defined (__nucleus__)
2404 attr
->symbolic_link
= 0;
2406 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
2408 GNAT_STRUCT_STAT statbuf
;
2409 ret
= GNAT_LSTAT (name
, &statbuf
);
2410 attr
->symbolic_link
= (!ret
&& S_ISLNK (statbuf
.st_mode
));
2412 attr
->symbolic_link
= 0;
2415 return attr
->symbolic_link
;
2419 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED
)
2421 struct file_attributes attr
;
2422 __gnat_reset_attributes (&attr
);
2423 return __gnat_is_symbolic_link_attr (name
, &attr
);
2427 #if defined (sun) && defined (__SVR4)
2428 /* Using fork on Solaris will duplicate all the threads. fork1, which
2429 duplicates only the active thread, must be used instead, or spawning
2430 subprocess from a program with tasking will lead into numerous problems. */
2435 __gnat_portable_spawn (char *args
[])
2438 int finished ATTRIBUTE_UNUSED
;
2439 int pid ATTRIBUTE_UNUSED
;
2441 #if defined (__vxworks) || defined(__nucleus__) || defined(RTX)
2444 #elif defined (_WIN32)
2445 /* args[0] must be quotes as it could contain a full pathname with spaces */
2446 char *args_0
= args
[0];
2447 args
[0] = (char *)xmalloc (strlen (args_0
) + 3);
2448 strcpy (args
[0], "\"");
2449 strcat (args
[0], args_0
);
2450 strcat (args
[0], "\"");
2452 status
= spawnvp (P_WAIT
, args_0
, (char* const*)args
);
2454 /* restore previous value */
2456 args
[0] = (char *)args_0
;
2472 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2474 return -1; /* execv is in parent context on VMS. */
2481 finished
= waitpid (pid
, &status
, 0);
2483 if (finished
!= pid
|| WIFEXITED (status
) == 0)
2486 return WEXITSTATUS (status
);
2492 /* Create a copy of the given file descriptor.
2493 Return -1 if an error occurred. */
2496 __gnat_dup (int oldfd
)
2498 #if defined (__vxworks) && !defined (__RTP__)
2499 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2507 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
2508 Return -1 if an error occurred. */
2511 __gnat_dup2 (int oldfd
, int newfd
)
2513 #if defined (__vxworks) && !defined (__RTP__)
2514 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2517 #elif defined (_WIN32)
2518 /* Special case when oldfd and newfd are identical and are the standard
2519 input, output or error as this makes Windows XP hangs. Note that we
2520 do that only for standard file descriptors that are known to be valid. */
2521 if (oldfd
== newfd
&& newfd
>= 0 && newfd
<= 2)
2524 return dup2 (oldfd
, newfd
);
2526 return dup2 (oldfd
, newfd
);
2531 __gnat_number_of_cpus (void)
2535 #if defined (linux) || defined (sun) || defined (AIX) || defined (__APPLE__)
2536 cores
= (int) sysconf (_SC_NPROCESSORS_ONLN
);
2538 #elif defined (__hpux__)
2539 struct pst_dynamic psd
;
2540 if (pstat_getdynamic (&psd
, sizeof (psd
), 1, 0) != -1)
2541 cores
= (int) psd
.psd_proc_cnt
;
2543 #elif defined (_WIN32)
2544 SYSTEM_INFO sysinfo
;
2545 GetSystemInfo (&sysinfo
);
2546 cores
= (int) sysinfo
.dwNumberOfProcessors
;
2549 int code
= SYI$_ACTIVECPU_CNT
;
2553 status
= LIB$
GETSYI (&code
, &res
);
2554 if ((status
& 1) != 0)
2557 #elif defined (_WRS_CONFIG_SMP)
2558 unsigned int vxCpuConfiguredGet (void);
2560 cores
= vxCpuConfiguredGet ();
2567 /* WIN32 code to implement a wait call that wait for any child process. */
2569 #if defined (_WIN32) && !defined (RTX)
2571 /* Synchronization code, to be thread safe. */
2575 /* For the Cert run times on native Windows we use dummy functions
2576 for locking and unlocking tasks since we do not support multiple
2577 threads on this configuration (Cert run time on native Windows). */
2579 void dummy (void) {}
2581 void (*Lock_Task
) () = &dummy
;
2582 void (*Unlock_Task
) () = &dummy
;
2586 #define Lock_Task system__soft_links__lock_task
2587 extern void (*Lock_Task
) (void);
2589 #define Unlock_Task system__soft_links__unlock_task
2590 extern void (*Unlock_Task
) (void);
2594 static HANDLE
*HANDLES_LIST
= NULL
;
2595 static int *PID_LIST
= NULL
, plist_length
= 0, plist_max_length
= 0;
2598 add_handle (HANDLE h
, int pid
)
2601 /* -------------------- critical section -------------------- */
2604 if (plist_length
== plist_max_length
)
2606 plist_max_length
+= 1000;
2608 (void **) xrealloc (HANDLES_LIST
, sizeof (HANDLE
) * plist_max_length
);
2610 (int *) xrealloc (PID_LIST
, sizeof (int) * plist_max_length
);
2613 HANDLES_LIST
[plist_length
] = h
;
2614 PID_LIST
[plist_length
] = pid
;
2618 /* -------------------- critical section -------------------- */
2622 __gnat_win32_remove_handle (HANDLE h
, int pid
)
2626 /* -------------------- critical section -------------------- */
2629 for (j
= 0; j
< plist_length
; j
++)
2631 if ((HANDLES_LIST
[j
] == h
) || (PID_LIST
[j
] == pid
))
2635 HANDLES_LIST
[j
] = HANDLES_LIST
[plist_length
];
2636 PID_LIST
[j
] = PID_LIST
[plist_length
];
2642 /* -------------------- critical section -------------------- */
2646 win32_no_block_spawn (char *command
, char *args
[], HANDLE
*h
, int *pid
)
2650 PROCESS_INFORMATION PI
;
2651 SECURITY_ATTRIBUTES SA
;
2656 /* compute the total command line length */
2660 csize
+= strlen (args
[k
]) + 1;
2664 full_command
= (char *) xmalloc (csize
);
2667 SI
.cb
= sizeof (STARTUPINFO
);
2668 SI
.lpReserved
= NULL
;
2669 SI
.lpReserved2
= NULL
;
2670 SI
.lpDesktop
= NULL
;
2674 SI
.wShowWindow
= SW_HIDE
;
2676 /* Security attributes. */
2677 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
2678 SA
.bInheritHandle
= TRUE
;
2679 SA
.lpSecurityDescriptor
= NULL
;
2681 /* Prepare the command string. */
2682 strcpy (full_command
, command
);
2683 strcat (full_command
, " ");
2688 strcat (full_command
, args
[k
]);
2689 strcat (full_command
, " ");
2694 int wsize
= csize
* 2;
2695 TCHAR
*wcommand
= (TCHAR
*) xmalloc (wsize
);
2697 S2WSC (wcommand
, full_command
, wsize
);
2699 free (full_command
);
2701 result
= CreateProcess
2702 (NULL
, wcommand
, &SA
, NULL
, TRUE
,
2703 GetPriorityClass (GetCurrentProcess()), NULL
, NULL
, &SI
, &PI
);
2710 CloseHandle (PI
.hThread
);
2712 *pid
= PI
.dwProcessId
;
2722 win32_wait (int *status
)
2724 DWORD exitcode
, pid
;
2731 if (plist_length
== 0)
2739 /* -------------------- critical section -------------------- */
2742 hl_len
= plist_length
;
2744 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * hl_len
);
2746 memmove (hl
, HANDLES_LIST
, sizeof (HANDLE
) * hl_len
);
2749 /* -------------------- critical section -------------------- */
2751 res
= WaitForMultipleObjects (hl_len
, hl
, FALSE
, INFINITE
);
2752 h
= hl
[res
- WAIT_OBJECT_0
];
2754 GetExitCodeProcess (h
, &exitcode
);
2755 pid
= PID_LIST
[res
- WAIT_OBJECT_0
];
2756 __gnat_win32_remove_handle (h
, -1);
2760 *status
= (int) exitcode
;
2767 __gnat_portable_no_block_spawn (char *args
[])
2770 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2773 #elif defined (_WIN32)
2778 win32_no_block_spawn (args
[0], args
, &h
, &pid
);
2781 add_handle (h
, pid
);
2794 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2796 return -1; /* execv is in parent context on VMS. */
2808 __gnat_portable_wait (int *process_status
)
2813 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2814 /* Not sure what to do here, so do nothing but return zero. */
2816 #elif defined (_WIN32)
2818 pid
= win32_wait (&status
);
2822 pid
= waitpid (-1, &status
, 0);
2823 status
= status
& 0xffff;
2826 *process_status
= status
;
2831 __gnat_os_exit (int status
)
2836 /* Locate file on path, that matches a predicate */
2839 __gnat_locate_file_with_predicate
2840 (char *file_name
, char *path_val
, int (*predicate
)(char*))
2843 char *file_path
= (char *) alloca (strlen (file_name
) + 1);
2846 /* Return immediately if file_name is empty */
2848 if (*file_name
== '\0')
2851 /* Remove quotes around file_name if present */
2857 strcpy (file_path
, ptr
);
2859 ptr
= file_path
+ strlen (file_path
) - 1;
2864 /* Handle absolute pathnames. */
2866 absolute
= __gnat_is_absolute_path (file_path
, strlen (file_name
));
2870 if (predicate (file_path
))
2871 return xstrdup (file_path
);
2876 /* If file_name include directory separator(s), try it first as
2877 a path name relative to the current directory */
2878 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
2883 if (predicate (file_name
))
2884 return xstrdup (file_name
);
2891 /* The result has to be smaller than path_val + file_name. */
2893 (char *) alloca (strlen (path_val
) + strlen (file_name
) + 2);
2897 /* Skip the starting quote */
2899 if (*path_val
== '"')
2902 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
2903 *ptr
++ = *path_val
++;
2905 /* If directory is empty, it is the current directory*/
2907 if (ptr
== file_path
)
2914 /* Skip the ending quote */
2919 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
2920 *++ptr
= DIR_SEPARATOR
;
2922 strcpy (++ptr
, file_name
);
2924 if (predicate (file_path
))
2925 return xstrdup (file_path
);
2930 /* Skip path separator */
2939 /* Locate an executable file, give a Path value. */
2942 __gnat_locate_executable_file (char *file_name
, char *path_val
)
2944 return __gnat_locate_file_with_predicate
2945 (file_name
, path_val
, &__gnat_is_executable_file
);
2948 /* Locate a regular file, give a Path value. */
2951 __gnat_locate_regular_file (char *file_name
, char *path_val
)
2953 return __gnat_locate_file_with_predicate
2954 (file_name
, path_val
, &__gnat_is_regular_file
);
2957 /* Locate an executable given a Path argument. This routine is only used by
2958 gnatbl and should not be used otherwise. Use locate_exec_on_path
2962 __gnat_locate_exec (char *exec_name
, char *path_val
)
2965 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
2967 char *full_exec_name
=
2969 (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
2971 strcpy (full_exec_name
, exec_name
);
2972 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
2973 ptr
= __gnat_locate_executable_file (full_exec_name
, path_val
);
2976 return __gnat_locate_executable_file (exec_name
, path_val
);
2980 return __gnat_locate_executable_file (exec_name
, path_val
);
2983 /* Locate an executable using the Systems default PATH. */
2986 __gnat_locate_exec_on_path (char *exec_name
)
2990 #if defined (_WIN32) && !defined (RTX)
2991 TCHAR
*wpath_val
= _tgetenv (_T("PATH"));
2993 /* In Win32 systems we expand the PATH as for XP environment
2994 variables are not automatically expanded. We also prepend the
2995 ".;" to the path to match normal NT path search semantics */
2997 #define EXPAND_BUFFER_SIZE 32767
2999 wapath_val
= (TCHAR
*) alloca (EXPAND_BUFFER_SIZE
);
3001 wapath_val
[0] = '.';
3002 wapath_val
[1] = ';';
3004 DWORD res
= ExpandEnvironmentStrings
3005 (wpath_val
, &wapath_val
[2], EXPAND_BUFFER_SIZE
- 2);
3007 if (!res
) wapath_val
[0] = _T('\0');
3009 apath_val
= (char *) alloca (EXPAND_BUFFER_SIZE
);
3011 WS2SC (apath_val
, wapath_val
, EXPAND_BUFFER_SIZE
);
3012 return __gnat_locate_exec (exec_name
, apath_val
);
3017 char *path_val
= "/VAXC$PATH";
3019 char *path_val
= getenv ("PATH");
3021 if (path_val
== NULL
) return NULL
;
3022 apath_val
= (char *) alloca (strlen (path_val
) + 1);
3023 strcpy (apath_val
, path_val
);
3024 return __gnat_locate_exec (exec_name
, apath_val
);
3030 /* These functions are used to translate to and from VMS and Unix syntax
3031 file, directory and path specifications. */
3034 #define MAXNAMES 256
3035 #define NEW_CANONICAL_FILELIST_INCREMENT 64
3037 static char new_canonical_dirspec
[MAXPATH
];
3038 static char new_canonical_filespec
[MAXPATH
];
3039 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
3040 static unsigned new_canonical_filelist_index
;
3041 static unsigned new_canonical_filelist_in_use
;
3042 static unsigned new_canonical_filelist_allocated
;
3043 static char **new_canonical_filelist
;
3044 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
3045 static char new_host_dirspec
[MAXPATH
];
3046 static char new_host_filespec
[MAXPATH
];
3048 /* Routine is called repeatedly by decc$from_vms via
3049 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
3053 wildcard_translate_unix (char *name
)
3056 char buff
[MAXPATH
];
3058 strncpy (buff
, name
, MAXPATH
);
3059 buff
[MAXPATH
- 1] = (char) 0;
3060 ver
= strrchr (buff
, '.');
3062 /* Chop off the version. */
3066 /* Dynamically extend the allocation by the increment. */
3067 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
3069 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
3070 new_canonical_filelist
= (char **) xrealloc
3071 (new_canonical_filelist
,
3072 new_canonical_filelist_allocated
* sizeof (char *));
3075 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
3080 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
3081 full translation and copy the results into a list (_init), then return them
3082 one at a time (_next). If onlydirs set, only expand directory files. */
3085 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
3088 char buff
[MAXPATH
];
3090 len
= strlen (filespec
);
3091 strncpy (buff
, filespec
, MAXPATH
);
3093 /* Only look for directories */
3094 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
3095 strncat (buff
, "*.dir", MAXPATH
);
3097 buff
[MAXPATH
- 1] = (char) 0;
3099 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
3101 /* Remove the .dir extension. */
3107 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3109 ext
= strstr (new_canonical_filelist
[i
], ".dir");
3115 return new_canonical_filelist_in_use
;
3118 /* Return the next filespec in the list. */
3121 __gnat_to_canonical_file_list_next ()
3123 return new_canonical_filelist
[new_canonical_filelist_index
++];
3126 /* Free storage used in the wildcard expansion. */
3129 __gnat_to_canonical_file_list_free ()
3133 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3134 free (new_canonical_filelist
[i
]);
3136 free (new_canonical_filelist
);
3138 new_canonical_filelist_in_use
= 0;
3139 new_canonical_filelist_allocated
= 0;
3140 new_canonical_filelist_index
= 0;
3141 new_canonical_filelist
= 0;
3144 /* The functional equivalent of decc$translate_vms routine.
3145 Designed to produce the same output, but is protected against
3146 malformed paths (original version ACCVIOs in this case) and
3147 does not require VMS-specific DECC RTL */
3149 #define NAM$C_MAXRSS 1024
3152 __gnat_translate_vms (char *src
)
3154 static char retbuf
[NAM$C_MAXRSS
+ 1];
3155 char *srcendpos
, *pos1
, *pos2
, *retpos
;
3156 int disp
, path_present
= 0;
3161 srcendpos
= strchr (src
, '\0');
3164 /* Look for the node and/or device in front of the path */
3166 pos2
= strchr (pos1
, ':');
3168 if (pos2
&& (pos2
< srcendpos
) && (*(pos2
+ 1) == ':'))
3170 /* There is a node name. "node_name::" becomes "node_name!" */
3172 strncpy (retbuf
, pos1
, disp
);
3173 retpos
[disp
] = '!';
3174 retpos
= retpos
+ disp
+ 1;
3176 pos2
= strchr (pos1
, ':');
3181 /* There is a device name. "dev_name:" becomes "/dev_name/" */
3184 strncpy (retpos
, pos1
, disp
);
3185 retpos
= retpos
+ disp
;
3190 /* No explicit device; we must look ahead and prepend /sys$disk/ if
3191 the path is absolute */
3192 if ((*pos1
== '[' || *pos1
== '<') && (pos1
< srcendpos
)
3193 && !strchr (".-]>", *(pos1
+ 1)))
3195 strncpy (retpos
, "/sys$disk/", 10);
3199 /* Process the path part */
3200 while (*pos1
== '[' || *pos1
== '<')
3204 if (*pos1
== ']' || *pos1
== '>')
3206 /* Special case, [] translates to '.' */
3212 /* '[000000' means root dir. It can be present in the middle of
3213 the path due to expansion of logical devices, in which case
3215 if (!strncmp (pos1
, "000000", 6) && path_present
> 1 &&
3216 (*(pos1
+ 6) == ']' || *(pos1
+ 6) == '>' || *(pos1
+ 6) == '.'))
3219 if (*pos1
== '.') pos1
++;
3221 else if (*pos1
== '.')
3227 /* There is a qualified path */
3228 while (*pos1
&& *pos1
!= ']' && *pos1
!= '>')
3233 /* '.' is used to separate directories. Replace it with '/' but
3234 only if there isn't already '/' just before */
3235 if (*(retpos
- 1) != '/')
3238 if (pos1
+ 1 < srcendpos
&& *pos1
== '.' && *(pos1
+ 1) == '.')
3240 /* ellipsis refers to entire subtree; replace with '**' */
3248 /* When after '.' '[' '<' is equivalent to Unix ".." but there
3249 may be several in a row */
3250 if (*(pos1
- 1) == '.' || *(pos1
- 1) == '[' ||
3253 while (*pos1
== '-')
3263 /* otherwise fall through to default */
3265 *(retpos
++) = *(pos1
++);
3272 if (pos1
< srcendpos
)
3274 /* Now add the actual file name, until the version suffix if any */
3277 pos2
= strchr (pos1
, ';');
3278 disp
= pos2
? (pos2
- pos1
) : (srcendpos
- pos1
);
3279 strncpy (retpos
, pos1
, disp
);
3281 if (pos2
&& pos2
< srcendpos
)
3283 /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
3285 disp
= srcendpos
- pos2
- 1;
3286 strncpy (retpos
, pos2
+ 1, disp
);
3296 /* Translate a VMS syntax directory specification in to Unix syntax. If
3297 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
3298 found, return input string. Also translate a dirname that contains no
3299 slashes, in case it's a logical name. */
3302 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
3306 strcpy (new_canonical_dirspec
, "");
3307 if (strlen (dirspec
))
3311 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
3313 strncpy (new_canonical_dirspec
,
3314 __gnat_translate_vms (dirspec
),
3317 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
3319 strncpy (new_canonical_dirspec
,
3320 __gnat_translate_vms (dirspec1
),
3325 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
3329 len
= strlen (new_canonical_dirspec
);
3330 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
3331 strncat (new_canonical_dirspec
, "/", MAXPATH
);
3333 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
3335 return new_canonical_dirspec
;
3339 /* Translate a VMS syntax file specification into Unix syntax.
3340 If no indicators of VMS syntax found, check if it's an uppercase
3341 alphanumeric_ name and if so try it out as an environment
3342 variable (logical name). If all else fails return the
3346 __gnat_to_canonical_file_spec (char *filespec
)
3350 strncpy (new_canonical_filespec
, "", MAXPATH
);
3352 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3354 char *tspec
= (char *) __gnat_translate_vms (filespec
);
3356 if (tspec
!= (char *) -1)
3357 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3359 else if ((strlen (filespec
) == strspn (filespec
,
3360 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
3361 && (filespec1
= getenv (filespec
)))
3363 char *tspec
= (char *) __gnat_translate_vms (filespec1
);
3365 if (tspec
!= (char *) -1)
3366 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3370 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
3373 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
3375 return new_canonical_filespec
;
3378 /* Translate a VMS syntax path specification into Unix syntax.
3379 If no indicators of VMS syntax found, return input string. */
3382 __gnat_to_canonical_path_spec (char *pathspec
)
3384 char *curr
, *next
, buff
[MAXPATH
];
3389 /* If there are /'s, assume it's a Unix path spec and return. */
3390 if (strchr (pathspec
, '/'))
3393 new_canonical_pathspec
[0] = 0;
3398 next
= strchr (curr
, ',');
3400 next
= strchr (curr
, 0);
3402 strncpy (buff
, curr
, next
- curr
);
3403 buff
[next
- curr
] = 0;
3405 /* Check for wildcards and expand if present. */
3406 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
3410 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
3411 for (i
= 0; i
< dirs
; i
++)
3415 next_dir
= __gnat_to_canonical_file_list_next ();
3416 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
3418 /* Don't append the separator after the last expansion. */
3420 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3423 __gnat_to_canonical_file_list_free ();
3426 strncat (new_canonical_pathspec
,
3427 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
3432 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3436 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
3438 return new_canonical_pathspec
;
3441 static char filename_buff
[MAXPATH
];
3444 translate_unix (char *name
, int type ATTRIBUTE_UNUSED
)
3446 strncpy (filename_buff
, name
, MAXPATH
);
3447 filename_buff
[MAXPATH
- 1] = (char) 0;
3451 /* Translate a Unix syntax directory specification into VMS syntax. The
3452 PREFIXFLAG has no effect, but is kept for symmetry with
3453 to_canonical_dir_spec. If indicators of VMS syntax found, return input
3457 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3459 int len
= strlen (dirspec
);
3461 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
3462 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3464 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
3465 return new_host_dirspec
;
3467 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
3469 new_host_dirspec
[len
- 1] = 0;
3473 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
3474 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
3475 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3477 return new_host_dirspec
;
3480 /* Translate a Unix syntax file specification into VMS syntax.
3481 If indicators of VMS syntax found, return input string. */
3484 __gnat_to_host_file_spec (char *filespec
)
3486 strncpy (new_host_filespec
, "", MAXPATH
);
3487 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3489 strncpy (new_host_filespec
, filespec
, MAXPATH
);
3493 decc$
to_vms (filespec
, translate_unix
, 1, 1);
3494 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
3497 new_host_filespec
[MAXPATH
- 1] = (char) 0;
3499 return new_host_filespec
;
3503 __gnat_adjust_os_resource_limits ()
3505 SYS$
ADJWSL (131072, 0);
3510 /* Dummy functions for Osint import for non-VMS systems. */
3513 __gnat_to_canonical_file_list_init
3514 (char *dirspec ATTRIBUTE_UNUSED
, int onlydirs ATTRIBUTE_UNUSED
)
3520 __gnat_to_canonical_file_list_next (void)
3522 static char empty
[] = "";
3527 __gnat_to_canonical_file_list_free (void)
3532 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3538 __gnat_to_canonical_file_spec (char *filespec
)
3544 __gnat_to_canonical_path_spec (char *pathspec
)
3550 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3556 __gnat_to_host_file_spec (char *filespec
)
3562 __gnat_adjust_os_resource_limits (void)
3568 #if defined (__mips_vxworks)
3572 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
3576 #if defined (IS_CROSS) \
3577 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3578 && defined (__SVR4)) \
3579 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3580 && ! (defined (linux) && defined (__ia64__)) \
3581 && ! (defined (linux) && defined (powerpc)) \
3582 && ! defined (__FreeBSD__) \
3583 && ! defined (__Lynx__) \
3584 && ! defined (__hpux__) \
3585 && ! defined (__APPLE__) \
3586 && ! defined (_AIX) \
3587 && ! defined (VMS) \
3588 && ! defined (__MINGW32__))
3590 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3591 just above for a list of native platforms that provide a non-dummy
3592 version of this procedure in libaddr2line.a. */
3595 convert_addresses (const char *file_name ATTRIBUTE_UNUSED
,
3596 void *addrs ATTRIBUTE_UNUSED
,
3597 int n_addr ATTRIBUTE_UNUSED
,
3598 void *buf ATTRIBUTE_UNUSED
,
3599 int *len ATTRIBUTE_UNUSED
)
3605 #if defined (_WIN32)
3606 int __gnat_argument_needs_quote
= 1;
3608 int __gnat_argument_needs_quote
= 0;
3611 /* This option is used to enable/disable object files handling from the
3612 binder file by the GNAT Project module. For example, this is disabled on
3613 Windows (prior to GCC 3.4) as it is already done by the mdll module.
3614 Stating with GCC 3.4 the shared libraries are not based on mdll
3615 anymore as it uses the GCC's -shared option */
3616 #if defined (_WIN32) \
3617 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3618 int __gnat_prj_add_obj_files
= 0;
3620 int __gnat_prj_add_obj_files
= 1;
3623 /* char used as prefix/suffix for environment variables */
3624 #if defined (_WIN32)
3625 char __gnat_environment_char
= '%';
3627 char __gnat_environment_char
= '$';
3630 /* This functions copy the file attributes from a source file to a
3633 mode = 0 : In this mode copy only the file time stamps (last access and
3634 last modification time stamps).
3636 mode = 1 : In this mode, time stamps and read/write/execute attributes are
3639 Returns 0 if operation was successful and -1 in case of error. */
3642 __gnat_copy_attribs (char *from ATTRIBUTE_UNUSED
, char *to ATTRIBUTE_UNUSED
,
3643 int mode ATTRIBUTE_UNUSED
)
3645 #if defined (VMS) || (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \
3646 defined (__nucleus__)
3649 #elif defined (_WIN32) && !defined (RTX)
3650 TCHAR wfrom
[GNAT_MAX_PATH_LEN
+ 2];
3651 TCHAR wto
[GNAT_MAX_PATH_LEN
+ 2];
3653 FILETIME fct
, flat
, flwt
;
3656 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
+ 2);
3657 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
+ 2);
3659 /* retrieve from times */
3662 (wfrom
, GENERIC_READ
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3664 if (hfrom
== INVALID_HANDLE_VALUE
)
3667 res
= GetFileTime (hfrom
, &fct
, &flat
, &flwt
);
3669 CloseHandle (hfrom
);
3674 /* retrieve from times */
3677 (wto
, GENERIC_WRITE
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3679 if (hto
== INVALID_HANDLE_VALUE
)
3682 res
= SetFileTime (hto
, NULL
, &flat
, &flwt
);
3689 /* Set file attributes in full mode. */
3693 DWORD attribs
= GetFileAttributes (wfrom
);
3695 if (attribs
== INVALID_FILE_ATTRIBUTES
)
3698 res
= SetFileAttributes (wto
, attribs
);
3706 GNAT_STRUCT_STAT fbuf
;
3707 struct utimbuf tbuf
;
3709 if (GNAT_STAT (from
, &fbuf
) == -1)
3714 tbuf
.actime
= fbuf
.st_atime
;
3715 tbuf
.modtime
= fbuf
.st_mtime
;
3717 if (utime (to
, &tbuf
) == -1)
3724 if (chmod (to
, fbuf
.st_mode
) == -1)
3735 __gnat_lseek (int fd
, long offset
, int whence
)
3737 return (int) lseek (fd
, offset
, whence
);
3740 /* This function returns the major version number of GCC being used. */
3742 get_gcc_version (void)
3747 return (int) (version_string
[0] - '0');
3752 * Set Close_On_Exec as indicated.
3753 * Note: this is used for both GNAT.OS_Lib and GNAT.Sockets.
3757 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED
,
3758 int close_on_exec_p ATTRIBUTE_UNUSED
)
3760 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3761 int flags
= fcntl (fd
, F_GETFD
, 0);
3764 if (close_on_exec_p
)
3765 flags
|= FD_CLOEXEC
;
3767 flags
&= ~FD_CLOEXEC
;
3768 return fcntl (fd
, F_SETFD
, flags
| FD_CLOEXEC
);
3769 #elif defined(_WIN32)
3770 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
3771 if (h
== (HANDLE
) -1)
3773 if (close_on_exec_p
)
3774 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
, 0);
3775 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
,
3776 HANDLE_FLAG_INHERIT
);
3778 /* TODO: Unimplemented. */
3783 /* Indicates if platforms supports automatic initialization through the
3784 constructor mechanism */
3786 __gnat_binder_supports_auto_init (void)
3795 /* Indicates that Stand-Alone Libraries are automatically initialized through
3796 the constructor mechanism */
3798 __gnat_sals_init_using_constructors (void)
3800 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3809 /* In RTX mode, the procedure to get the time (as file time) is different
3810 in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3811 we introduce an intermediate procedure to link against the corresponding
3812 one in each situation. */
3814 extern void GetTimeAsFileTime(LPFILETIME pTime
);
3816 void GetTimeAsFileTime(LPFILETIME pTime
)
3819 RtGetRtssTimeAsFileTime (pTime
); /* RTSS interface */
3821 GetSystemTimeAsFileTime (pTime
); /* w32 interface */
3826 /* Add symbol that is required to link. It would otherwise be taken from
3827 libgcc.a and it would try to use the gcc constructors that are not
3828 supported by Microsoft linker. */
3830 extern void __main (void);
3832 void __main (void) {}
3836 #if defined (__ANDROID__)
3838 #include <pthread.h>
3840 void *__gnat_lwp_self (void)
3842 return (void *) pthread_self ();
3845 #elif defined (linux)
3846 /* There is no function in the glibc to retrieve the LWP of the current
3847 thread. We need to do a system call in order to retrieve this
3849 #include <sys/syscall.h>
3850 void *__gnat_lwp_self (void)
3852 return (void *) syscall (__NR_gettid
);
3857 /* glibc versions earlier than 2.7 do not define the routines to handle
3858 dynamically allocated CPU sets. For these targets, we use the static
3863 /* Dynamic cpu sets */
3865 cpu_set_t
*__gnat_cpu_alloc (size_t count
)
3867 return CPU_ALLOC (count
);
3870 size_t __gnat_cpu_alloc_size (size_t count
)
3872 return CPU_ALLOC_SIZE (count
);
3875 void __gnat_cpu_free (cpu_set_t
*set
)
3880 void __gnat_cpu_zero (size_t count
, cpu_set_t
*set
)
3882 CPU_ZERO_S (count
, set
);
3885 void __gnat_cpu_set (int cpu
, size_t count
, cpu_set_t
*set
)
3887 /* Ada handles CPU numbers starting from 1, while C identifies the first
3888 CPU by a 0, so we need to adjust. */
3889 CPU_SET_S (cpu
- 1, count
, set
);
3894 /* Static cpu sets */
3896 cpu_set_t
*__gnat_cpu_alloc (size_t count ATTRIBUTE_UNUSED
)
3898 return (cpu_set_t
*) xmalloc (sizeof (cpu_set_t
));
3901 size_t __gnat_cpu_alloc_size (size_t count ATTRIBUTE_UNUSED
)
3903 return sizeof (cpu_set_t
);
3906 void __gnat_cpu_free (cpu_set_t
*set
)
3911 void __gnat_cpu_zero (size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
3916 void __gnat_cpu_set (int cpu
, size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
3918 /* Ada handles CPU numbers starting from 1, while C identifies the first
3919 CPU by a 0, so we need to adjust. */
3920 CPU_SET (cpu
- 1, set
);