1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2009, 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 */
54 #define HOST_EXECUTABLE_SUFFIX ".exe"
55 #define HOST_OBJECT_SUFFIX ".obj"
69 /* We don't have libiberty, so use malloc. */
70 #define xmalloc(S) malloc (S)
71 #define xrealloc(V,S) realloc (V,S)
78 #if defined (__MINGW32__)
86 /* Current code page to use, set in initialize.c. */
90 #include <sys/utime.h>
92 /* For isalpha-like tests in the compiler, we're expected to resort to
93 safe-ctype.h/ISALPHA. This isn't available for the runtime library
94 build, so we fallback on ctype.h/isalpha there. */
98 #define ISALPHA isalpha
101 #elif defined (__Lynx__)
103 /* Lynx utime.h only defines the entities of interest to us if
104 defined (VMOS_DEV), so ... */
113 /* wait.h processing */
116 #include <sys/wait.h>
118 #elif defined (__vxworks) && defined (__RTP__)
120 #elif defined (__Lynx__)
121 /* ??? We really need wait.h and it includes resource.h on Lynx. GCC
122 has a resource.h header as well, included instead of the lynx
123 version in our setup, causing lots of errors. We don't really need
124 the lynx contents of this file, so just workaround the issue by
125 preventing the inclusion of the GCC header from doing anything. */
126 #define GCC_RESOURCE_H
127 #include <sys/wait.h>
128 #elif defined (__nucleus__)
129 /* No wait() or waitpid() calls available */
132 #include <sys/wait.h>
135 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
138 /* Header files and definitions for __gnat_set_file_time_name. */
140 #define __NEW_STARLET 1
142 #include <vms/atrdef.h>
143 #include <vms/fibdef.h>
144 #include <vms/stsdef.h>
145 #include <vms/iodef.h>
147 #include <vms/descrip.h>
151 /* Use native 64-bit arithmetic. */
152 #define unix_time_to_vms(X,Y) \
153 { unsigned long long reftime, tmptime = (X); \
154 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
155 SYS$BINTIM (&unixtime, &reftime); \
156 Y = tmptime * 10000000 + reftime; }
158 /* descrip.h doesn't have everything ... */
159 typedef struct fibdef
* __fibdef_ptr32
__attribute__ (( mode (SI
) ));
160 struct dsc$descriptor_fib
162 unsigned int fib$l_len
;
163 __fibdef_ptr32 fib$l_addr
;
166 /* I/O Status Block. */
169 unsigned short status
, count
;
173 static char *tryfile
;
175 /* Variable length string. */
179 char string
[NAM$C_MAXRSS
+1];
186 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
197 #define DIR_SEPARATOR '\\'
202 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
203 defined in the current system. On DOS-like systems these flags control
204 whether the file is opened/created in text-translation mode (CR/LF in
205 external file mapped to LF in internal file), but in Unix-like systems,
206 no text translation is required, so these flags have no effect. */
208 #if defined (__EMX__)
224 #ifndef HOST_EXECUTABLE_SUFFIX
225 #define HOST_EXECUTABLE_SUFFIX ""
228 #ifndef HOST_OBJECT_SUFFIX
229 #define HOST_OBJECT_SUFFIX ".o"
232 #ifndef PATH_SEPARATOR
233 #define PATH_SEPARATOR ':'
236 #ifndef DIR_SEPARATOR
237 #define DIR_SEPARATOR '/'
240 /* Check for cross-compilation */
241 #if defined (CROSS_COMPILE) || defined (CROSS_DIRECTORY_STRUCTURE)
243 int __gnat_is_cross_compiler
= 1;
246 int __gnat_is_cross_compiler
= 0;
249 char __gnat_dir_separator
= DIR_SEPARATOR
;
251 char __gnat_path_separator
= PATH_SEPARATOR
;
253 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
254 the base filenames that libraries specified with -lsomelib options
255 may have. This is used by GNATMAKE to check whether an executable
256 is up-to-date or not. The syntax is
258 library_template ::= { pattern ; } pattern NUL
259 pattern ::= [ prefix ] * [ postfix ]
261 These should only specify names of static libraries as it makes
262 no sense to determine at link time if dynamic-link libraries are
263 up to date or not. Any libraries that are not found are supposed
266 * if they are needed but not present, the link
269 * otherwise they are libraries in the system paths and so
270 they are considered part of the system and not checked
273 ??? This should be part of a GNAT host-specific compiler
274 file instead of being included in all user applications
275 as well. This is only a temporary work-around for 3.11b. */
277 #ifndef GNAT_LIBRARY_TEMPLATE
278 #if defined (__EMX__)
279 #define GNAT_LIBRARY_TEMPLATE "*.a"
281 #define GNAT_LIBRARY_TEMPLATE "*.olb"
283 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
287 const char *__gnat_library_template
= GNAT_LIBRARY_TEMPLATE
;
289 /* This variable is used in hostparm.ads to say whether the host is a VMS
292 const int __gnat_vmsp
= 1;
294 const int __gnat_vmsp
= 0;
298 #define GNAT_MAX_PATH_LEN MAX_PATH
301 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
303 #elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__)
304 #define GNAT_MAX_PATH_LEN PATH_MAX
308 #if defined (__MINGW32__)
312 #include <sys/param.h>
316 #include <sys/param.h>
320 #define GNAT_MAX_PATH_LEN MAXPATHLEN
322 #define GNAT_MAX_PATH_LEN 256
327 /* Used for Ada bindings */
328 const int __gnat_size_of_file_attributes
= sizeof (struct file_attributes
);
330 /* Reset the file attributes as if no system call had been performed */
331 void __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
);
333 /* The __gnat_max_path_len variable is used to export the maximum
334 length of a path name to Ada code. max_path_len is also provided
335 for compatibility with older GNAT versions, please do not use
338 int __gnat_max_path_len
= GNAT_MAX_PATH_LEN
;
339 int max_path_len
= GNAT_MAX_PATH_LEN
;
341 /* Control whether we can use ACL on Windows. */
343 int __gnat_use_acl
= 1;
345 /* The following macro HAVE_READDIR_R should be defined if the
346 system provides the routine readdir_r. */
347 #undef HAVE_READDIR_R
349 #if defined(VMS) && defined (__LONG_POINTERS)
351 /* Return a 32 bit pointer to an array of 32 bit pointers
352 given a 64 bit pointer to an array of 64 bit pointers */
354 typedef __char_ptr32
*__char_ptr_char_ptr32
__attribute__ ((mode (SI
)));
356 static __char_ptr_char_ptr32
357 to_ptr32 (char **ptr64
)
360 __char_ptr_char_ptr32 short_argv
;
362 for (argc
=0; ptr64
[argc
]; argc
++);
364 /* Reallocate argv with 32 bit pointers. */
365 short_argv
= (__char_ptr_char_ptr32
) decc$malloc
366 (sizeof (__char_ptr32
) * (argc
+ 1));
368 for (argc
=0; ptr64
[argc
]; argc
++)
369 short_argv
[argc
] = (__char_ptr32
) decc$
strdup (ptr64
[argc
]);
371 short_argv
[argc
] = (__char_ptr32
) 0;
375 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
377 #define MAYBE_TO_PTR32(argv) argv
380 const char ATTR_UNSET
= 127;
383 __gnat_reset_attributes
384 (struct file_attributes
* attr
)
386 attr
->exists
= ATTR_UNSET
;
388 attr
->writable
= ATTR_UNSET
;
389 attr
->readable
= ATTR_UNSET
;
390 attr
->executable
= ATTR_UNSET
;
392 attr
->regular
= ATTR_UNSET
;
393 attr
->symbolic_link
= ATTR_UNSET
;
394 attr
->directory
= ATTR_UNSET
;
396 attr
->timestamp
= (OS_Time
)-2;
397 attr
->file_length
= -1;
404 time_t res
= time (NULL
);
405 return (OS_Time
) res
;
408 /* Return the current local time as a string in the ISO 8601 format of
409 "YYYY-MM-DD HH:MM:SS.SS". The returned string is 22 + 1 (NULL) characters
413 __gnat_current_time_string
416 const char *format
= "%Y-%m-%d %H:%M:%S";
417 /* Format string necessary to describe the ISO 8601 format */
419 const time_t t_val
= time (NULL
);
421 strftime (result
, 22, format
, localtime (&t_val
));
422 /* Convert the local time into a string following the ISO format, copying
423 at most 22 characters into the result string. */
428 /* The sub-seconds are manually set to zero since type time_t lacks the
429 precision necessary for nanoseconds. */
443 time_t time
= (time_t) *p_time
;
446 /* On Windows systems, the time is sometimes rounded up to the nearest
447 even second, so if the number of seconds is odd, increment it. */
453 res
= localtime (&time
);
455 res
= gmtime (&time
);
460 *p_year
= res
->tm_year
;
461 *p_month
= res
->tm_mon
;
462 *p_day
= res
->tm_mday
;
463 *p_hours
= res
->tm_hour
;
464 *p_mins
= res
->tm_min
;
465 *p_secs
= res
->tm_sec
;
468 *p_year
= *p_month
= *p_day
= *p_hours
= *p_mins
= *p_secs
= 0;
471 /* Place the contents of the symbolic link named PATH in the buffer BUF,
472 which has size BUFSIZ. If PATH is a symbolic link, then return the number
473 of characters of its content in BUF. Otherwise, return -1.
474 For systems not supporting symbolic links, always return -1. */
477 __gnat_readlink (char *path ATTRIBUTE_UNUSED
,
478 char *buf ATTRIBUTE_UNUSED
,
479 size_t bufsiz ATTRIBUTE_UNUSED
)
481 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__) \
482 || defined (VMS) || defined(__vxworks) || defined (__nucleus__)
485 return readlink (path
, buf
, bufsiz
);
489 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH.
490 If NEWPATH exists it will NOT be overwritten.
491 For systems not supporting symbolic links, always return -1. */
494 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED
,
495 char *newpath ATTRIBUTE_UNUSED
)
497 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__) \
498 || defined (VMS) || defined(__vxworks) || defined (__nucleus__)
501 return symlink (oldpath
, newpath
);
505 /* Try to lock a file, return 1 if success. */
507 #if defined (__vxworks) || defined (__nucleus__) || defined (MSDOS) \
508 || defined (_WIN32) || defined (__EMX__) || defined (VMS)
510 /* Version that does not use link. */
513 __gnat_try_lock (char *dir
, char *file
)
517 TCHAR wfull_path
[GNAT_MAX_PATH_LEN
];
518 TCHAR wfile
[GNAT_MAX_PATH_LEN
];
519 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
521 S2WSC (wdir
, dir
, GNAT_MAX_PATH_LEN
);
522 S2WSC (wfile
, file
, GNAT_MAX_PATH_LEN
);
524 _stprintf (wfull_path
, _T("%s%c%s"), wdir
, _T(DIR_SEPARATOR
), wfile
);
525 fd
= _topen (wfull_path
, O_CREAT
| O_EXCL
, 0600);
529 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
530 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
542 /* Version using link(), more secure over NFS. */
543 /* See TN 6913-016 for discussion ??? */
546 __gnat_try_lock (char *dir
, char *file
)
550 GNAT_STRUCT_STAT stat_result
;
553 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
554 sprintf (temp_file
, "%s%cTMP-%ld-%ld",
555 dir
, DIR_SEPARATOR
, (long)getpid(), (long)getppid ());
557 /* Create the temporary file and write the process number. */
558 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
564 /* Link it with the new file. */
565 link (temp_file
, full_path
);
567 /* Count the references on the old one. If we have a count of two, then
568 the link did succeed. Remove the temporary file before returning. */
569 __gnat_stat (temp_file
, &stat_result
);
571 return stat_result
.st_nlink
== 2;
575 /* Return the maximum file name length. */
578 __gnat_get_maximum_file_name_length (void)
583 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
592 /* Return nonzero if file names are case sensitive. */
595 __gnat_get_file_names_case_sensitive (void)
597 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT)
605 __gnat_get_default_identifier_character_set (void)
607 #if defined (__EMX__) || defined (MSDOS)
614 /* Return the current working directory. */
617 __gnat_get_current_dir (char *dir
, int *length
)
619 #if defined (__MINGW32__)
620 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
622 _tgetcwd (wdir
, *length
);
624 WS2SC (dir
, wdir
, GNAT_MAX_PATH_LEN
);
627 /* Force Unix style, which is what GNAT uses internally. */
628 getcwd (dir
, *length
, 0);
630 getcwd (dir
, *length
);
633 *length
= strlen (dir
);
635 if (dir
[*length
- 1] != DIR_SEPARATOR
)
637 dir
[*length
] = DIR_SEPARATOR
;
643 /* Return the suffix for object files. */
646 __gnat_get_object_suffix_ptr (int *len
, const char **value
)
648 *value
= HOST_OBJECT_SUFFIX
;
653 *len
= strlen (*value
);
658 /* Return the suffix for executable files. */
661 __gnat_get_executable_suffix_ptr (int *len
, const char **value
)
663 *value
= HOST_EXECUTABLE_SUFFIX
;
667 *len
= strlen (*value
);
672 /* Return the suffix for debuggable files. Usually this is the same as the
673 executable extension. */
676 __gnat_get_debuggable_suffix_ptr (int *len
, const char **value
)
679 *value
= HOST_EXECUTABLE_SUFFIX
;
681 /* On DOS, the extensionless COFF file is what gdb likes. */
688 *len
= strlen (*value
);
693 /* Returns the OS filename and corresponding encoding. */
696 __gnat_os_filename (char *filename ATTRIBUTE_UNUSED
,
697 char *w_filename ATTRIBUTE_UNUSED
,
698 char *os_name
, int *o_length
,
699 char *encoding ATTRIBUTE_UNUSED
, int *e_length
)
701 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
702 WS2SC (os_name
, (TCHAR
*)w_filename
, (DWORD
)*o_length
);
703 *o_length
= strlen (os_name
);
704 strcpy (encoding
, "encoding=utf8");
705 *e_length
= strlen (encoding
);
707 strcpy (os_name
, filename
);
708 *o_length
= strlen (filename
);
716 __gnat_unlink (char *path
)
718 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
720 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
722 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
723 return _tunlink (wpath
);
726 return unlink (path
);
733 __gnat_rename (char *from
, char *to
)
735 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
737 TCHAR wfrom
[GNAT_MAX_PATH_LEN
], wto
[GNAT_MAX_PATH_LEN
];
739 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
);
740 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
);
741 return _trename (wfrom
, wto
);
744 return rename (from
, to
);
748 /* Changing directory. */
751 __gnat_chdir (char *path
)
753 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
755 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
757 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
758 return _tchdir (wpath
);
765 /* Removing a directory. */
768 __gnat_rmdir (char *path
)
770 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
772 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
774 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
775 return _trmdir (wpath
);
777 #elif defined (VTHREADS)
778 /* rmdir not available */
786 __gnat_fopen (char *path
, char *mode
, int encoding ATTRIBUTE_UNUSED
)
788 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
789 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
792 S2WS (wmode
, mode
, 10);
794 if (encoding
== Encoding_Unspecified
)
795 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
796 else if (encoding
== Encoding_UTF8
)
797 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
799 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
801 return _tfopen (wpath
, wmode
);
803 return decc$
fopen (path
, mode
);
805 return GNAT_FOPEN (path
, mode
);
810 __gnat_freopen (char *path
, char *mode
, FILE *stream
, int encoding ATTRIBUTE_UNUSED
)
812 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
813 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
816 S2WS (wmode
, mode
, 10);
818 if (encoding
== Encoding_Unspecified
)
819 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
820 else if (encoding
== Encoding_UTF8
)
821 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
823 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
825 return _tfreopen (wpath
, wmode
, stream
);
827 return decc$
freopen (path
, mode
, stream
);
829 return freopen (path
, mode
, stream
);
834 __gnat_open_read (char *path
, int fmode
)
837 int o_fmode
= O_BINARY
;
843 /* Optional arguments mbc,deq,fop increase read performance. */
844 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
845 "mbc=16", "deq=64", "fop=tef");
846 #elif defined (__vxworks)
847 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
848 #elif defined (__MINGW32__)
850 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
852 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
853 fd
= _topen (wpath
, O_RDONLY
| o_fmode
, 0444);
856 fd
= open (path
, O_RDONLY
| o_fmode
);
859 return fd
< 0 ? -1 : fd
;
862 #if defined (__EMX__) || defined (__MINGW32__)
863 #define PERM (S_IREAD | S_IWRITE)
865 /* Excerpt from DECC C RTL Reference Manual:
866 To create files with OpenVMS RMS default protections using the UNIX
867 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
868 and open with a file-protection mode argument of 0777 in a program
869 that never specifically calls umask. These default protections include
870 correctly establishing protections based on ACLs, previous versions of
874 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
878 __gnat_open_rw (char *path
, int fmode
)
881 int o_fmode
= O_BINARY
;
887 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
888 "mbc=16", "deq=64", "fop=tef");
889 #elif defined (__MINGW32__)
891 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
893 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
894 fd
= _topen (wpath
, O_RDWR
| o_fmode
, PERM
);
897 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
900 return fd
< 0 ? -1 : fd
;
904 __gnat_open_create (char *path
, int fmode
)
907 int o_fmode
= O_BINARY
;
913 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
914 "mbc=16", "deq=64", "fop=tef");
915 #elif defined (__MINGW32__)
917 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
919 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
920 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
923 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
926 return fd
< 0 ? -1 : fd
;
930 __gnat_create_output_file (char *path
)
934 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
,
935 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
936 "shr=del,get,put,upd");
937 #elif defined (__MINGW32__)
939 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
941 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
942 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
945 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
948 return fd
< 0 ? -1 : fd
;
952 __gnat_create_output_file_new (char *path
)
956 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
,
957 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
958 "shr=del,get,put,upd");
959 #elif defined (__MINGW32__)
961 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
963 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
964 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
967 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
970 return fd
< 0 ? -1 : fd
;
974 __gnat_open_append (char *path
, int fmode
)
977 int o_fmode
= O_BINARY
;
983 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
984 "mbc=16", "deq=64", "fop=tef");
985 #elif defined (__MINGW32__)
987 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
989 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
990 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
993 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
996 return fd
< 0 ? -1 : fd
;
999 /* Open a new file. Return error (-1) if the file already exists. */
1002 __gnat_open_new (char *path
, int fmode
)
1005 int o_fmode
= O_BINARY
;
1011 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1012 "mbc=16", "deq=64", "fop=tef");
1013 #elif defined (__MINGW32__)
1015 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1017 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1018 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1021 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1024 return fd
< 0 ? -1 : fd
;
1027 /* Open a new temp file. Return error (-1) if the file already exists.
1028 Special options for VMS allow the file to be shared between parent and child
1029 processes, however they really slow down output. Used in gnatchop. */
1032 __gnat_open_new_temp (char *path
, int fmode
)
1035 int o_fmode
= O_BINARY
;
1037 strcpy (path
, "GNAT-XXXXXX");
1039 #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \
1040 || defined (linux) || defined(__GLIBC__)) && !defined (__vxworks)
1041 return mkstemp (path
);
1042 #elif defined (__Lynx__)
1044 #elif defined (__nucleus__)
1047 if (mktemp (path
) == NULL
)
1055 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1056 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
1057 "mbc=16", "deq=64", "fop=tef");
1059 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1062 return fd
< 0 ? -1 : fd
;
1065 /****************************************************************
1066 ** Perform a call to GNAT_STAT or GNAT_FSTAT, and extract as much information
1067 ** as possible from it, storing the result in a cache for later reuse
1068 ****************************************************************/
1071 __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
)
1073 GNAT_STRUCT_STAT statbuf
;
1077 ret
= GNAT_FSTAT (fd
, &statbuf
);
1079 ret
= __gnat_stat (name
, &statbuf
);
1081 attr
->regular
= (!ret
&& S_ISREG (statbuf
.st_mode
));
1082 attr
->directory
= (!ret
&& S_ISDIR (statbuf
.st_mode
));
1085 attr
->file_length
= 0;
1087 /* st_size may be 32 bits, or 64 bits which is converted to long. We
1088 don't return a useful value for files larger than 2 gigabytes in
1090 attr
->file_length
= statbuf
.st_size
; /* all systems */
1093 /* on Windows requires extra system call, see comment in __gnat_file_exists_attr */
1094 attr
->exists
= !ret
;
1097 #if !defined (_WIN32) || defined (RTX)
1098 /* on Windows requires extra system call, see __gnat_is_readable_file_attr */
1099 attr
->readable
= (!ret
&& (statbuf
.st_mode
& S_IRUSR
));
1100 attr
->writable
= (!ret
&& (statbuf
.st_mode
& S_IWUSR
));
1101 attr
->executable
= (!ret
&& (statbuf
.st_mode
& S_IXUSR
));
1104 #if !defined (__EMX__) && !defined (MSDOS) && (!defined (_WIN32) || defined (RTX))
1105 /* on Windows requires extra system call, see __gnat_file_time_name_attr */
1107 attr
->timestamp
= (OS_Time
)-1;
1110 /* VMS has file versioning. */
1111 attr
->timestamp
= (OS_Time
)statbuf
.st_ctime
;
1113 attr
->timestamp
= (OS_Time
)statbuf
.st_mtime
;
1120 /****************************************************************
1121 ** Return the number of bytes in the specified file
1122 ****************************************************************/
1125 __gnat_file_length_attr (int fd
, char* name
, struct file_attributes
* attr
)
1127 if (attr
->file_length
== -1) {
1128 __gnat_stat_to_attr (fd
, name
, attr
);
1131 return attr
->file_length
;
1135 __gnat_file_length (int fd
)
1137 struct file_attributes attr
;
1138 __gnat_reset_attributes (&attr
);
1139 return __gnat_file_length_attr (fd
, NULL
, &attr
);
1143 __gnat_named_file_length (char *name
)
1145 struct file_attributes attr
;
1146 __gnat_reset_attributes (&attr
);
1147 return __gnat_file_length_attr (-1, name
, &attr
);
1150 /* Create a temporary filename and put it in string pointed to by
1154 __gnat_tmp_name (char *tmp_filename
)
1157 /* Variable used to create a series of unique names */
1158 static int counter
= 0;
1160 /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */
1161 strcpy (tmp_filename
, "c:\\WINDOWS\\Temp\\gnat-");
1162 sprintf (&tmp_filename
[strlen (tmp_filename
)], "%d\0", counter
++);
1164 #elif defined (__MINGW32__)
1168 /* tempnam tries to create a temporary file in directory pointed to by
1169 TMP environment variable, in c:\temp if TMP is not set, and in
1170 directory specified by P_tmpdir in stdio.h if c:\temp does not
1171 exist. The filename will be created with the prefix "gnat-". */
1173 pname
= (char *) tempnam ("c:\\temp", "gnat-");
1175 /* if pname is NULL, the file was not created properly, the disk is full
1176 or there is no more free temporary files */
1179 *tmp_filename
= '\0';
1181 /* If pname start with a back slash and not path information it means that
1182 the filename is valid for the current working directory. */
1184 else if (pname
[0] == '\\')
1186 strcpy (tmp_filename
, ".\\");
1187 strcat (tmp_filename
, pname
+1);
1190 strcpy (tmp_filename
, pname
);
1195 #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \
1196 || defined (__OpenBSD__) || defined(__GLIBC__)
1197 #define MAX_SAFE_PATH 1000
1198 char *tmpdir
= getenv ("TMPDIR");
1200 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
1201 a buffer overflow. */
1202 if (tmpdir
== NULL
|| strlen (tmpdir
) > MAX_SAFE_PATH
)
1203 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
1205 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
1207 close (mkstemp(tmp_filename
));
1209 tmpnam (tmp_filename
);
1213 /* Open directory and returns a DIR pointer. */
1215 DIR* __gnat_opendir (char *name
)
1218 /* Not supported in RTX */
1222 #elif defined (__MINGW32__)
1223 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1225 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1226 return (DIR*)_topendir (wname
);
1229 return opendir (name
);
1233 /* Read the next entry in a directory. The returned string points somewhere
1237 __gnat_readdir (DIR *dirp
, char *buffer
, int *len
)
1240 /* Not supported in RTX */
1244 #elif defined (__MINGW32__)
1245 struct _tdirent
*dirent
= _treaddir ((_TDIR
*)dirp
);
1249 WS2SC (buffer
, dirent
->d_name
, GNAT_MAX_PATH_LEN
);
1250 *len
= strlen (buffer
);
1257 #elif defined (HAVE_READDIR_R)
1258 /* If possible, try to use the thread-safe version. */
1259 if (readdir_r (dirp
, buffer
) != NULL
)
1261 *len
= strlen (((struct dirent
*) buffer
)->d_name
);
1262 return ((struct dirent
*) buffer
)->d_name
;
1268 struct dirent
*dirent
= (struct dirent
*) readdir (dirp
);
1272 strcpy (buffer
, dirent
->d_name
);
1273 *len
= strlen (buffer
);
1282 /* Close a directory entry. */
1284 int __gnat_closedir (DIR *dirp
)
1287 /* Not supported in RTX */
1291 #elif defined (__MINGW32__)
1292 return _tclosedir ((_TDIR
*)dirp
);
1295 return closedir (dirp
);
1299 /* Returns 1 if readdir is thread safe, 0 otherwise. */
1302 __gnat_readdir_is_thread_safe (void)
1304 #ifdef HAVE_READDIR_R
1311 #if defined (_WIN32) && !defined (RTX)
1312 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
1313 static const unsigned long long w32_epoch_offset
= 11644473600ULL;
1315 /* Returns the file modification timestamp using Win32 routines which are
1316 immune against daylight saving time change. It is in fact not possible to
1317 use fstat for this purpose as the DST modify the st_mtime field of the
1321 win32_filetime (HANDLE h
)
1326 unsigned long long ull_time
;
1329 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1330 since <Jan 1st 1601>. This function must return the number of seconds
1331 since <Jan 1st 1970>. */
1333 if (GetFileTime (h
, NULL
, NULL
, &t_write
.ft_time
))
1334 return (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1339 /* Return a GNAT time stamp given a file name. */
1342 __gnat_file_time_name_attr (char* name
, struct file_attributes
* attr
)
1344 if (attr
->timestamp
== (OS_Time
)-2) {
1345 #if defined (__EMX__) || defined (MSDOS)
1346 int fd
= open (name
, O_RDONLY
| O_BINARY
);
1347 time_t ret
= __gnat_file_time_fd (fd
);
1349 attr
->timestamp
= (OS_Time
)ret
;
1351 #elif defined (_WIN32) && !defined (RTX)
1353 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1354 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1356 HANDLE h
= CreateFile
1357 (wname
, GENERIC_READ
, FILE_SHARE_READ
, 0,
1358 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
, 0);
1360 if (h
!= INVALID_HANDLE_VALUE
) {
1361 ret
= win32_filetime (h
);
1364 attr
->timestamp
= (OS_Time
) ret
;
1366 __gnat_stat_to_attr (-1, name
, attr
);
1369 return attr
->timestamp
;
1373 __gnat_file_time_name (char *name
)
1375 struct file_attributes attr
;
1376 __gnat_reset_attributes (&attr
);
1377 return __gnat_file_time_name_attr (name
, &attr
);
1380 /* Return a GNAT time stamp given a file descriptor. */
1383 __gnat_file_time_fd_attr (int fd
, struct file_attributes
* attr
)
1385 if (attr
->timestamp
== (OS_Time
)-2) {
1386 /* The following workaround code is due to the fact that under EMX and
1387 DJGPP fstat attempts to convert time values to GMT rather than keep the
1388 actual OS timestamp of the file. By using the OS2/DOS functions directly
1389 the GNAT timestamp are independent of this behavior, which is desired to
1390 facilitate the distribution of GNAT compiled libraries. */
1392 #if defined (__EMX__) || defined (MSDOS)
1396 int ret
= DosQueryFileInfo (fd
, 1, (unsigned char *) &fs
,
1397 sizeof (FILESTATUS
));
1399 unsigned file_year
= fs
.fdateLastWrite
.year
;
1400 unsigned file_month
= fs
.fdateLastWrite
.month
;
1401 unsigned file_day
= fs
.fdateLastWrite
.day
;
1402 unsigned file_hour
= fs
.ftimeLastWrite
.hours
;
1403 unsigned file_min
= fs
.ftimeLastWrite
.minutes
;
1404 unsigned file_tsec
= fs
.ftimeLastWrite
.twosecs
;
1408 int ret
= getftime (fd
, &fs
);
1410 unsigned file_year
= fs
.ft_year
;
1411 unsigned file_month
= fs
.ft_month
;
1412 unsigned file_day
= fs
.ft_day
;
1413 unsigned file_hour
= fs
.ft_hour
;
1414 unsigned file_min
= fs
.ft_min
;
1415 unsigned file_tsec
= fs
.ft_tsec
;
1418 /* Calculate the seconds since epoch from the time components. First count
1419 the whole days passed. The value for years returned by the DOS and OS2
1420 functions count years from 1980, so to compensate for the UNIX epoch which
1421 begins in 1970 start with 10 years worth of days and add days for each
1422 four year period since then. */
1425 int cum_days
[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
1426 int days_passed
= 3652 + (file_year
/ 4) * 1461;
1427 int years_since_leap
= file_year
% 4;
1429 if (years_since_leap
== 1)
1431 else if (years_since_leap
== 2)
1433 else if (years_since_leap
== 3)
1434 days_passed
+= 1096;
1439 days_passed
+= cum_days
[file_month
- 1];
1440 if (years_since_leap
== 0 && file_year
!= 20 && file_month
> 2)
1443 days_passed
+= file_day
- 1;
1445 /* OK - have whole days. Multiply -- then add in other parts. */
1447 tot_secs
= days_passed
* 86400;
1448 tot_secs
+= file_hour
* 3600;
1449 tot_secs
+= file_min
* 60;
1450 tot_secs
+= file_tsec
* 2;
1451 attr
->timestamp
= (OS_Time
) tot_secs
;
1453 #elif defined (_WIN32) && !defined (RTX)
1454 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
1455 time_t ret
= win32_filetime (h
);
1456 attr
->timestamp
= (OS_Time
) ret
;
1459 __gnat_stat_to_attr (fd
, NULL
, attr
);
1463 return attr
->timestamp
;
1467 __gnat_file_time_fd (int fd
)
1469 struct file_attributes attr
;
1470 __gnat_reset_attributes (&attr
);
1471 return __gnat_file_time_fd_attr (fd
, &attr
);
1474 /* Set the file time stamp. */
1477 __gnat_set_file_time_name (char *name
, time_t time_stamp
)
1479 #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1481 /* Code to implement __gnat_set_file_time_name for these systems. */
1483 #elif defined (_WIN32) && !defined (RTX)
1487 unsigned long long ull_time
;
1489 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1491 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1493 HANDLE h
= CreateFile
1494 (wname
, GENERIC_WRITE
, FILE_SHARE_WRITE
, NULL
,
1495 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
,
1497 if (h
== INVALID_HANDLE_VALUE
)
1499 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1500 t_write
.ull_time
= ((unsigned long long)time_stamp
+ w32_epoch_offset
);
1501 /* Convert to 100 nanosecond units */
1502 t_write
.ull_time
*= 10000000ULL;
1504 SetFileTime(h
, NULL
, NULL
, &t_write
.ft_time
);
1514 unsigned long long backup
, create
, expire
, revise
;
1518 unsigned short value
;
1521 unsigned system
: 4;
1527 } Fat
= { 0, 0, 0, 0, 0, { 0 }};
1531 { ATR$S_CREDATE
, ATR$C_CREDATE
, &Fat
.create
},
1532 { ATR$S_REVDATE
, ATR$C_REVDATE
, &Fat
.revise
},
1533 { ATR$S_EXPDATE
, ATR$C_EXPDATE
, &Fat
.expire
},
1534 { ATR$S_BAKDATE
, ATR$C_BAKDATE
, &Fat
.backup
},
1535 { ATR$S_FPRO
, ATR$C_FPRO
, &Fat
.prot
},
1536 { ATR$S_UIC
, ATR$C_UIC
, &Fat
.uic
},
1541 struct dsc$descriptor_fib fibdsc
= {sizeof (fib
), (void *) &fib
};
1545 unsigned long long newtime
;
1546 unsigned long long revtime
;
1550 struct vstring file
;
1551 struct dsc$descriptor_s filedsc
1552 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) file
.string
};
1553 struct vstring device
;
1554 struct dsc$descriptor_s devicedsc
1555 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) device
.string
};
1556 struct vstring timev
;
1557 struct dsc$descriptor_s timedsc
1558 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) timev
.string
};
1559 struct vstring result
;
1560 struct dsc$descriptor_s resultdsc
1561 = {NAM$C_MAXRSS
, DSC$K_DTYPE_VT
, DSC$K_CLASS_VS
, (void *) result
.string
};
1563 /* Convert parameter name (a file spec) to host file form. Note that this
1564 is needed on VMS to prepare for subsequent calls to VMS RMS library
1565 routines. Note that it would not work to call __gnat_to_host_dir_spec
1566 as was done in a previous version, since this fails silently unless
1567 the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1568 (directory not found) condition is signalled. */
1569 tryfile
= (char *) __gnat_to_host_file_spec (name
);
1571 /* Allocate and initialize a FAB and NAM structures. */
1575 nam
.nam$l_esa
= file
.string
;
1576 nam
.nam$b_ess
= NAM$C_MAXRSS
;
1577 nam
.nam$l_rsa
= result
.string
;
1578 nam
.nam$b_rss
= NAM$C_MAXRSS
;
1579 fab
.fab$l_fna
= tryfile
;
1580 fab
.fab$b_fns
= strlen (tryfile
);
1581 fab
.fab$l_nam
= &nam
;
1583 /* Validate filespec syntax and device existence. */
1584 status
= SYS$
PARSE (&fab
, 0, 0);
1585 if ((status
& 1) != 1)
1586 LIB$
SIGNAL (status
);
1588 file
.string
[nam
.nam$b_esl
] = 0;
1590 /* Find matching filespec. */
1591 status
= SYS$
SEARCH (&fab
, 0, 0);
1592 if ((status
& 1) != 1)
1593 LIB$
SIGNAL (status
);
1595 file
.string
[nam
.nam$b_esl
] = 0;
1596 result
.string
[result
.length
=nam
.nam$b_rsl
] = 0;
1598 /* Get the device name and assign an IO channel. */
1599 strncpy (device
.string
, nam
.nam$l_dev
, nam
.nam$b_dev
);
1600 devicedsc
.dsc$w_length
= nam
.nam$b_dev
;
1602 status
= SYS$
ASSIGN (&devicedsc
, &chan
, 0, 0, 0);
1603 if ((status
& 1) != 1)
1604 LIB$
SIGNAL (status
);
1606 /* Initialize the FIB and fill in the directory id field. */
1607 memset (&fib
, 0, sizeof (fib
));
1608 fib
.fib$w_did
[0] = nam
.nam$w_did
[0];
1609 fib
.fib$w_did
[1] = nam
.nam$w_did
[1];
1610 fib
.fib$w_did
[2] = nam
.nam$w_did
[2];
1611 fib
.fib$l_acctl
= 0;
1613 strcpy (file
.string
, (strrchr (result
.string
, ']') + 1));
1614 filedsc
.dsc$w_length
= strlen (file
.string
);
1615 result
.string
[result
.length
= 0] = 0;
1617 /* Open and close the file to fill in the attributes. */
1619 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1620 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1621 if ((status
& 1) != 1)
1622 LIB$
SIGNAL (status
);
1623 if ((iosb
.status
& 1) != 1)
1624 LIB$
SIGNAL (iosb
.status
);
1626 result
.string
[result
.length
] = 0;
1627 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0, &fibdsc
, 0, 0, 0,
1629 if ((status
& 1) != 1)
1630 LIB$
SIGNAL (status
);
1631 if ((iosb
.status
& 1) != 1)
1632 LIB$
SIGNAL (iosb
.status
);
1637 /* Set creation time to requested time. */
1638 unix_time_to_vms (time_stamp
, newtime
);
1640 t
= time ((time_t) 0);
1642 /* Set revision time to now in local time. */
1643 unix_time_to_vms (t
, revtime
);
1646 /* Reopen the file, modify the times and then close. */
1647 fib
.fib$l_acctl
= FIB$M_WRITE
;
1649 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1650 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1651 if ((status
& 1) != 1)
1652 LIB$
SIGNAL (status
);
1653 if ((iosb
.status
& 1) != 1)
1654 LIB$
SIGNAL (iosb
.status
);
1656 Fat
.create
= newtime
;
1657 Fat
.revise
= revtime
;
1659 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0,
1660 &fibdsc
, 0, 0, 0, &atrlst
, 0);
1661 if ((status
& 1) != 1)
1662 LIB$
SIGNAL (status
);
1663 if ((iosb
.status
& 1) != 1)
1664 LIB$
SIGNAL (iosb
.status
);
1666 /* Deassign the channel and exit. */
1667 status
= SYS$
DASSGN (chan
);
1668 if ((status
& 1) != 1)
1669 LIB$
SIGNAL (status
);
1671 struct utimbuf utimbuf
;
1674 /* Set modification time to requested time. */
1675 utimbuf
.modtime
= time_stamp
;
1677 /* Set access time to now in local time. */
1678 t
= time ((time_t) 0);
1679 utimbuf
.actime
= mktime (localtime (&t
));
1681 utime (name
, &utimbuf
);
1685 /* Get the list of installed standard libraries from the
1686 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1690 __gnat_get_libraries_from_registry (void)
1692 char *result
= (char *) xmalloc (1);
1696 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) \
1700 DWORD name_size
, value_size
;
1707 /* First open the key. */
1708 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1710 if (res
== ERROR_SUCCESS
)
1711 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1712 KEY_READ
, ®_key
);
1714 if (res
== ERROR_SUCCESS
)
1715 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1717 if (res
== ERROR_SUCCESS
)
1718 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1720 /* If the key exists, read out all the values in it and concatenate them
1722 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1724 value_size
= name_size
= 256;
1725 res
= RegEnumValueA (reg_key
, index
, name
, &name_size
, 0,
1726 &type
, (LPBYTE
)value
, &value_size
);
1728 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1730 char *old_result
= result
;
1732 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1733 strcpy (result
, old_result
);
1734 strcat (result
, value
);
1735 strcat (result
, ";");
1740 /* Remove the trailing ";". */
1742 result
[strlen (result
) - 1] = 0;
1749 __gnat_stat (char *name
, GNAT_STRUCT_STAT
*statbuf
)
1752 /* Under Windows the directory name for the stat function must not be
1753 terminated by a directory separator except if just after a drive name
1754 or with UNC path without directory (only the name of the shared
1755 resource), for example: \\computer\share\ */
1757 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
1760 int dirsep_count
= 0;
1762 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
1763 name_len
= _tcslen (wname
);
1765 if (name_len
> GNAT_MAX_PATH_LEN
)
1768 last_char
= wname
[name_len
- 1];
1770 while (name_len
> 1 && (last_char
== _T('\\') || last_char
== _T('/')))
1772 wname
[name_len
- 1] = _T('\0');
1774 last_char
= wname
[name_len
- 1];
1777 /* Count back-slashes. */
1779 for (k
=0; k
<name_len
; k
++)
1780 if (wname
[k
] == _T('\\') || wname
[k
] == _T('/'))
1783 /* Only a drive letter followed by ':', we must add a directory separator
1784 for the stat routine to work properly. */
1785 if ((name_len
== 2 && wname
[1] == _T(':'))
1786 || (name_len
> 3 && wname
[0] == _T('\\') && wname
[1] == _T('\\')
1787 && dirsep_count
== 3))
1788 _tcscat (wname
, _T("\\"));
1790 return _tstat (wname
, (struct _stat
*)statbuf
);
1793 return GNAT_STAT (name
, statbuf
);
1797 /*************************************************************************
1798 ** Check whether a file exists
1799 *************************************************************************/
1802 __gnat_file_exists_attr (char* name
, struct file_attributes
* attr
)
1804 if (attr
->exists
== ATTR_UNSET
) {
1806 /* On Windows do not use __gnat_stat() because of a bug in Microsoft
1807 _stat() routine. When the system time-zone is set with a negative
1808 offset the _stat() routine fails on specific files like CON: */
1809 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
1810 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
1811 attr
->exists
= GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
;
1813 __gnat_stat_to_attr (-1, name
, attr
);
1817 return attr
->exists
;
1821 __gnat_file_exists (char *name
)
1823 struct file_attributes attr
;
1824 __gnat_reset_attributes (&attr
);
1825 return __gnat_file_exists_attr (name
, &attr
);
1828 /**********************************************************************
1829 ** Whether name is an absolute path
1830 **********************************************************************/
1833 __gnat_is_absolute_path (char *name
, int length
)
1836 /* On VxWorks systems, an absolute path can be represented (depending on
1837 the host platform) as either /dir/file, or device:/dir/file, or
1838 device:drive_letter:/dir/file. */
1845 for (index
= 0; index
< length
; index
++)
1847 if (name
[index
] == ':' &&
1848 ((name
[index
+ 1] == '/') ||
1849 (isalpha (name
[index
+ 1]) && index
+ 2 <= length
&&
1850 name
[index
+ 2] == '/')))
1853 else if (name
[index
] == '/')
1858 return (length
!= 0) &&
1859 (*name
== '/' || *name
== DIR_SEPARATOR
1860 #if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
1861 || (length
> 1 && ISALPHA (name
[0]) && name
[1] == ':')
1868 __gnat_is_regular_file_attr (char* name
, struct file_attributes
* attr
)
1870 if (attr
->regular
== ATTR_UNSET
) {
1871 __gnat_stat_to_attr (-1, name
, attr
);
1874 return attr
->regular
;
1878 __gnat_is_regular_file (char *name
)
1880 struct file_attributes attr
;
1881 __gnat_reset_attributes (&attr
);
1882 return __gnat_is_regular_file_attr (name
, &attr
);
1886 __gnat_is_directory_attr (char* name
, struct file_attributes
* attr
)
1888 if (attr
->directory
== ATTR_UNSET
) {
1889 __gnat_stat_to_attr (-1, name
, attr
);
1892 return attr
->directory
;
1896 __gnat_is_directory (char *name
)
1898 struct file_attributes attr
;
1899 __gnat_reset_attributes (&attr
);
1900 return __gnat_is_directory_attr (name
, &attr
);
1903 #if defined (_WIN32) && !defined (RTX)
1905 /* Returns the same constant as GetDriveType but takes a pathname as
1909 GetDriveTypeFromPath (TCHAR
*wfullpath
)
1911 TCHAR wdrv
[MAX_PATH
];
1912 TCHAR wpath
[MAX_PATH
];
1913 TCHAR wfilename
[MAX_PATH
];
1914 TCHAR wext
[MAX_PATH
];
1916 _tsplitpath (wfullpath
, wdrv
, wpath
, wfilename
, wext
);
1918 if (_tcslen (wdrv
) != 0)
1920 /* we have a drive specified. */
1921 _tcscat (wdrv
, _T("\\"));
1922 return GetDriveType (wdrv
);
1926 /* No drive specified. */
1928 /* Is this a relative path, if so get current drive type. */
1929 if (wpath
[0] != _T('\\') ||
1930 (_tcslen (wpath
) > 2 && wpath
[0] == _T('\\') && wpath
[1] != _T('\\')))
1931 return GetDriveType (NULL
);
1933 UINT result
= GetDriveType (wpath
);
1935 /* Cannot guess the drive type, is this \\.\ ? */
1937 if (result
== DRIVE_NO_ROOT_DIR
&&
1938 _tcslen (wpath
) >= 4 && wpath
[0] == _T('\\') && wpath
[1] == _T('\\')
1939 && wpath
[2] == _T('.') && wpath
[3] == _T('\\'))
1941 if (_tcslen (wpath
) == 4)
1942 _tcscat (wpath
, wfilename
);
1944 LPTSTR p
= &wpath
[4];
1945 LPTSTR b
= _tcschr (p
, _T('\\'));
1948 { /* logical drive \\.\c\dir\file */
1954 _tcscat (p
, _T(":\\"));
1956 return GetDriveType (p
);
1963 /* This MingW section contains code to work with ACL. */
1965 __gnat_check_OWNER_ACL
1967 DWORD CheckAccessDesired
,
1968 GENERIC_MAPPING CheckGenericMapping
)
1970 DWORD dwAccessDesired
, dwAccessAllowed
;
1971 PRIVILEGE_SET PrivilegeSet
;
1972 DWORD dwPrivSetSize
= sizeof (PRIVILEGE_SET
);
1973 BOOL fAccessGranted
= FALSE
;
1974 HANDLE hToken
= NULL
;
1976 SECURITY_DESCRIPTOR
* pSD
= NULL
;
1979 (wname
, OWNER_SECURITY_INFORMATION
|
1980 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
1983 if ((pSD
= (PSECURITY_DESCRIPTOR
) HeapAlloc
1984 (GetProcessHeap (), HEAP_ZERO_MEMORY
, nLength
)) == NULL
)
1987 /* Obtain the security descriptor. */
1989 if (!GetFileSecurity
1990 (wname
, OWNER_SECURITY_INFORMATION
|
1991 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
1992 pSD
, nLength
, &nLength
))
1995 if (!ImpersonateSelf (SecurityImpersonation
))
1998 if (!OpenThreadToken
1999 (GetCurrentThread(), TOKEN_DUPLICATE
| TOKEN_QUERY
, FALSE
, &hToken
))
2002 /* Undoes the effect of ImpersonateSelf. */
2006 /* We want to test for write permissions. */
2008 dwAccessDesired
= CheckAccessDesired
;
2010 MapGenericMask (&dwAccessDesired
, &CheckGenericMapping
);
2013 (pSD
, /* security descriptor to check */
2014 hToken
, /* impersonation token */
2015 dwAccessDesired
, /* requested access rights */
2016 &CheckGenericMapping
, /* pointer to GENERIC_MAPPING */
2017 &PrivilegeSet
, /* receives privileges used in check */
2018 &dwPrivSetSize
, /* size of PrivilegeSet buffer */
2019 &dwAccessAllowed
, /* receives mask of allowed access rights */
2023 CloseHandle (hToken
);
2024 HeapFree (GetProcessHeap (), 0, pSD
);
2025 return fAccessGranted
;
2029 CloseHandle (hToken
);
2030 HeapFree (GetProcessHeap (), 0, pSD
);
2035 __gnat_set_OWNER_ACL
2038 DWORD AccessPermissions
)
2040 PACL pOldDACL
= NULL
;
2041 PACL pNewDACL
= NULL
;
2042 PSECURITY_DESCRIPTOR pSD
= NULL
;
2044 TCHAR username
[100];
2047 /* Get current user, he will act as the owner */
2049 if (!GetUserName (username
, &unsize
))
2052 if (GetNamedSecurityInfo
2055 DACL_SECURITY_INFORMATION
,
2056 NULL
, NULL
, &pOldDACL
, NULL
, &pSD
) != ERROR_SUCCESS
)
2059 BuildExplicitAccessWithName
2060 (&ea
, username
, AccessPermissions
, AccessMode
, NO_INHERITANCE
);
2062 if (AccessMode
== SET_ACCESS
)
2064 /* SET_ACCESS, we want to set an explicte set of permissions, do not
2065 merge with current DACL. */
2066 if (SetEntriesInAcl (1, &ea
, NULL
, &pNewDACL
) != ERROR_SUCCESS
)
2070 if (SetEntriesInAcl (1, &ea
, pOldDACL
, &pNewDACL
) != ERROR_SUCCESS
)
2073 if (SetNamedSecurityInfo
2074 (wname
, SE_FILE_OBJECT
,
2075 DACL_SECURITY_INFORMATION
, NULL
, NULL
, pNewDACL
, NULL
) != ERROR_SUCCESS
)
2079 LocalFree (pNewDACL
);
2082 /* Check if it is possible to use ACL for wname, the file must not be on a
2086 __gnat_can_use_acl (TCHAR
*wname
)
2088 return __gnat_use_acl
&& GetDriveTypeFromPath (wname
) != DRIVE_REMOTE
;
2091 #endif /* defined (_WIN32) && !defined (RTX) */
2094 __gnat_is_readable_file_attr (char* name
, struct file_attributes
* attr
)
2096 if (attr
->readable
== ATTR_UNSET
) {
2097 #if defined (_WIN32) && !defined (RTX)
2098 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2099 GENERIC_MAPPING GenericMapping
;
2101 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2103 if (__gnat_can_use_acl (wname
))
2105 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2106 GenericMapping
.GenericRead
= GENERIC_READ
;
2107 attr
->readable
= __gnat_check_OWNER_ACL (wname
, FILE_READ_DATA
, GenericMapping
);
2110 attr
->readable
= GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
;
2112 __gnat_stat_to_attr (-1, name
, attr
);
2116 return attr
->readable
;
2120 __gnat_is_readable_file (char *name
)
2122 struct file_attributes attr
;
2123 __gnat_reset_attributes (&attr
);
2124 return __gnat_is_readable_file_attr (name
, &attr
);
2128 __gnat_is_writable_file_attr (char* name
, struct file_attributes
* attr
)
2130 if (attr
->writable
== ATTR_UNSET
) {
2131 #if defined (_WIN32) && !defined (RTX)
2132 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2133 GENERIC_MAPPING GenericMapping
;
2135 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2137 if (__gnat_can_use_acl (wname
))
2139 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2140 GenericMapping
.GenericWrite
= GENERIC_WRITE
;
2142 attr
->writable
= __gnat_check_OWNER_ACL
2143 (wname
, FILE_WRITE_DATA
| FILE_APPEND_DATA
, GenericMapping
)
2144 && !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2147 attr
->writable
= !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2150 __gnat_stat_to_attr (-1, name
, attr
);
2154 return attr
->writable
;
2158 __gnat_is_writable_file (char *name
)
2160 struct file_attributes attr
;
2161 __gnat_reset_attributes (&attr
);
2162 return __gnat_is_writable_file_attr (name
, &attr
);
2166 __gnat_is_executable_file_attr (char* name
, struct file_attributes
* attr
)
2168 if (attr
->executable
== ATTR_UNSET
) {
2169 #if defined (_WIN32) && !defined (RTX)
2170 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2171 GENERIC_MAPPING GenericMapping
;
2173 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2175 if (__gnat_can_use_acl (wname
))
2177 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2178 GenericMapping
.GenericExecute
= GENERIC_EXECUTE
;
2180 attr
->executable
= __gnat_check_OWNER_ACL (wname
, FILE_EXECUTE
, GenericMapping
);
2183 attr
->executable
= GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
2184 && _tcsstr (wname
, _T(".exe")) - wname
== (int) (_tcslen (wname
) - 4);
2186 __gnat_stat_to_attr (-1, name
, attr
);
2190 return attr
->executable
;
2194 __gnat_is_executable_file (char *name
)
2196 struct file_attributes attr
;
2197 __gnat_reset_attributes (&attr
);
2198 return __gnat_is_executable_file_attr (name
, &attr
);
2202 __gnat_set_writable (char *name
)
2204 #if defined (_WIN32) && !defined (RTX)
2205 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2207 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2209 if (__gnat_can_use_acl (wname
))
2210 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_WRITE
);
2213 (wname
, GetFileAttributes (wname
) & ~FILE_ATTRIBUTE_READONLY
);
2214 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2215 GNAT_STRUCT_STAT statbuf
;
2217 if (GNAT_STAT (name
, &statbuf
) == 0)
2219 statbuf
.st_mode
= statbuf
.st_mode
| S_IWUSR
;
2220 chmod (name
, statbuf
.st_mode
);
2226 __gnat_set_executable (char *name
)
2228 #if defined (_WIN32) && !defined (RTX)
2229 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2231 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2233 if (__gnat_can_use_acl (wname
))
2234 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_EXECUTE
);
2236 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2237 GNAT_STRUCT_STAT statbuf
;
2239 if (GNAT_STAT (name
, &statbuf
) == 0)
2241 statbuf
.st_mode
= statbuf
.st_mode
| S_IXUSR
;
2242 chmod (name
, statbuf
.st_mode
);
2248 __gnat_set_non_writable (char *name
)
2250 #if defined (_WIN32) && !defined (RTX)
2251 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2253 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2255 if (__gnat_can_use_acl (wname
))
2256 __gnat_set_OWNER_ACL
2257 (wname
, DENY_ACCESS
,
2258 FILE_WRITE_DATA
| FILE_APPEND_DATA
|
2259 FILE_WRITE_EA
| FILE_WRITE_ATTRIBUTES
);
2262 (wname
, GetFileAttributes (wname
) | FILE_ATTRIBUTE_READONLY
);
2263 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2264 GNAT_STRUCT_STAT statbuf
;
2266 if (GNAT_STAT (name
, &statbuf
) == 0)
2268 statbuf
.st_mode
= statbuf
.st_mode
& 07577;
2269 chmod (name
, statbuf
.st_mode
);
2275 __gnat_set_readable (char *name
)
2277 #if defined (_WIN32) && !defined (RTX)
2278 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2280 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2282 if (__gnat_can_use_acl (wname
))
2283 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_READ
);
2285 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2286 GNAT_STRUCT_STAT statbuf
;
2288 if (GNAT_STAT (name
, &statbuf
) == 0)
2290 chmod (name
, statbuf
.st_mode
| S_IREAD
);
2296 __gnat_set_non_readable (char *name
)
2298 #if defined (_WIN32) && !defined (RTX)
2299 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2301 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2303 if (__gnat_can_use_acl (wname
))
2304 __gnat_set_OWNER_ACL (wname
, DENY_ACCESS
, FILE_GENERIC_READ
);
2306 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2307 GNAT_STRUCT_STAT statbuf
;
2309 if (GNAT_STAT (name
, &statbuf
) == 0)
2311 chmod (name
, statbuf
.st_mode
& (~S_IREAD
));
2317 __gnat_is_symbolic_link_attr (char* name
, struct file_attributes
* attr
)
2319 if (attr
->symbolic_link
== ATTR_UNSET
) {
2320 #if defined (__vxworks) || defined (__nucleus__)
2321 attr
->symbolic_link
= 0;
2323 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
2325 GNAT_STRUCT_STAT statbuf
;
2326 ret
= GNAT_LSTAT (name
, &statbuf
);
2327 attr
->symbolic_link
= (!ret
&& S_ISLNK (statbuf
.st_mode
));
2329 attr
->symbolic_link
= 0;
2332 return attr
->symbolic_link
;
2336 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED
)
2338 struct file_attributes attr
;
2339 __gnat_reset_attributes (&attr
);
2340 return __gnat_is_symbolic_link_attr (name
, &attr
);
2344 #if defined (sun) && defined (__SVR4)
2345 /* Using fork on Solaris will duplicate all the threads. fork1, which
2346 duplicates only the active thread, must be used instead, or spawning
2347 subprocess from a program with tasking will lead into numerous problems. */
2352 __gnat_portable_spawn (char *args
[])
2355 int finished ATTRIBUTE_UNUSED
;
2356 int pid ATTRIBUTE_UNUSED
;
2358 #if defined (__vxworks) || defined(__nucleus__) || defined(RTX)
2361 #elif defined (MSDOS) || defined (_WIN32)
2362 /* args[0] must be quotes as it could contain a full pathname with spaces */
2363 char *args_0
= args
[0];
2364 args
[0] = (char *)xmalloc (strlen (args_0
) + 3);
2365 strcpy (args
[0], "\"");
2366 strcat (args
[0], args_0
);
2367 strcat (args
[0], "\"");
2369 status
= spawnvp (P_WAIT
, args_0
, (const char* const*)args
);
2371 /* restore previous value */
2373 args
[0] = (char *)args_0
;
2383 pid
= spawnvp (P_NOWAIT
, args
[0], args
);
2395 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2397 return -1; /* execv is in parent context on VMS. */
2405 finished
= waitpid (pid
, &status
, 0);
2407 if (finished
!= pid
|| WIFEXITED (status
) == 0)
2410 return WEXITSTATUS (status
);
2416 /* Create a copy of the given file descriptor.
2417 Return -1 if an error occurred. */
2420 __gnat_dup (int oldfd
)
2422 #if defined (__vxworks) && !defined (__RTP__)
2423 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2431 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
2432 Return -1 if an error occurred. */
2435 __gnat_dup2 (int oldfd
, int newfd
)
2437 #if defined (__vxworks) && !defined (__RTP__)
2438 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2442 return dup2 (oldfd
, newfd
);
2446 /* WIN32 code to implement a wait call that wait for any child process. */
2448 #if defined (_WIN32) && !defined (RTX)
2450 /* Synchronization code, to be thread safe. */
2454 /* For the Cert run times on native Windows we use dummy functions
2455 for locking and unlocking tasks since we do not support multiple
2456 threads on this configuration (Cert run time on native Windows). */
2458 void dummy (void) {}
2460 void (*Lock_Task
) () = &dummy
;
2461 void (*Unlock_Task
) () = &dummy
;
2465 #define Lock_Task system__soft_links__lock_task
2466 extern void (*Lock_Task
) (void);
2468 #define Unlock_Task system__soft_links__unlock_task
2469 extern void (*Unlock_Task
) (void);
2473 static HANDLE
*HANDLES_LIST
= NULL
;
2474 static int *PID_LIST
= NULL
, plist_length
= 0, plist_max_length
= 0;
2477 add_handle (HANDLE h
)
2480 /* -------------------- critical section -------------------- */
2483 if (plist_length
== plist_max_length
)
2485 plist_max_length
+= 1000;
2487 xrealloc (HANDLES_LIST
, sizeof (HANDLE
) * plist_max_length
);
2489 xrealloc (PID_LIST
, sizeof (int) * plist_max_length
);
2492 HANDLES_LIST
[plist_length
] = h
;
2493 PID_LIST
[plist_length
] = GetProcessId (h
);
2497 /* -------------------- critical section -------------------- */
2501 __gnat_win32_remove_handle (HANDLE h
, int pid
)
2505 /* -------------------- critical section -------------------- */
2508 for (j
= 0; j
< plist_length
; j
++)
2510 if ((HANDLES_LIST
[j
] == h
) || (PID_LIST
[j
] == pid
))
2514 HANDLES_LIST
[j
] = HANDLES_LIST
[plist_length
];
2515 PID_LIST
[j
] = PID_LIST
[plist_length
];
2521 /* -------------------- critical section -------------------- */
2525 win32_no_block_spawn (char *command
, char *args
[])
2529 PROCESS_INFORMATION PI
;
2530 SECURITY_ATTRIBUTES SA
;
2535 /* compute the total command line length */
2539 csize
+= strlen (args
[k
]) + 1;
2543 full_command
= (char *) xmalloc (csize
);
2546 SI
.cb
= sizeof (STARTUPINFO
);
2547 SI
.lpReserved
= NULL
;
2548 SI
.lpReserved2
= NULL
;
2549 SI
.lpDesktop
= NULL
;
2553 SI
.wShowWindow
= SW_HIDE
;
2555 /* Security attributes. */
2556 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
2557 SA
.bInheritHandle
= TRUE
;
2558 SA
.lpSecurityDescriptor
= NULL
;
2560 /* Prepare the command string. */
2561 strcpy (full_command
, command
);
2562 strcat (full_command
, " ");
2567 strcat (full_command
, args
[k
]);
2568 strcat (full_command
, " ");
2573 int wsize
= csize
* 2;
2574 TCHAR
*wcommand
= (TCHAR
*) xmalloc (wsize
);
2576 S2WSC (wcommand
, full_command
, wsize
);
2578 free (full_command
);
2580 result
= CreateProcess
2581 (NULL
, wcommand
, &SA
, NULL
, TRUE
,
2582 GetPriorityClass (GetCurrentProcess()), NULL
, NULL
, &SI
, &PI
);
2589 CloseHandle (PI
.hThread
);
2597 win32_wait (int *status
)
2599 DWORD exitcode
, pid
;
2606 if (plist_length
== 0)
2614 /* -------------------- critical section -------------------- */
2617 hl_len
= plist_length
;
2619 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * hl_len
);
2621 memmove (hl
, HANDLES_LIST
, sizeof (HANDLE
) * hl_len
);
2624 /* -------------------- critical section -------------------- */
2626 res
= WaitForMultipleObjects (hl_len
, hl
, FALSE
, INFINITE
);
2627 h
= hl
[res
- WAIT_OBJECT_0
];
2629 GetExitCodeProcess (h
, &exitcode
);
2630 pid
= GetProcessId (h
);
2631 __gnat_win32_remove_handle (h
, -1);
2635 *status
= (int) exitcode
;
2642 __gnat_portable_no_block_spawn (char *args
[])
2645 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2648 #elif defined (__EMX__) || defined (MSDOS)
2650 /* ??? For PC machines I (Franco) don't know the system calls to implement
2651 this routine. So I'll fake it as follows. This routine will behave
2652 exactly like the blocking portable_spawn and will systematically return
2653 a pid of 0 unless the spawned task did not complete successfully, in
2654 which case we return a pid of -1. To synchronize with this the
2655 portable_wait below systematically returns a pid of 0 and reports that
2656 the subprocess terminated successfully. */
2658 if (spawnvp (P_WAIT
, args
[0], args
) != 0)
2661 #elif defined (_WIN32)
2665 h
= win32_no_block_spawn (args
[0], args
);
2669 return GetProcessId (h
);
2681 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2683 return -1; /* execv is in parent context on VMS. */
2695 __gnat_portable_wait (int *process_status
)
2700 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2701 /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
2704 #elif defined (_WIN32)
2706 pid
= win32_wait (&status
);
2708 #elif defined (__EMX__) || defined (MSDOS)
2709 /* ??? See corresponding comment in portable_no_block_spawn. */
2713 pid
= waitpid (-1, &status
, 0);
2714 status
= status
& 0xffff;
2717 *process_status
= status
;
2722 __gnat_os_exit (int status
)
2727 /* Locate a regular file, give a Path value. */
2730 __gnat_locate_regular_file (char *file_name
, char *path_val
)
2733 char *file_path
= (char *) alloca (strlen (file_name
) + 1);
2736 /* Return immediately if file_name is empty */
2738 if (*file_name
== '\0')
2741 /* Remove quotes around file_name if present */
2747 strcpy (file_path
, ptr
);
2749 ptr
= file_path
+ strlen (file_path
) - 1;
2754 /* Handle absolute pathnames. */
2756 absolute
= __gnat_is_absolute_path (file_path
, strlen (file_name
));
2760 if (__gnat_is_regular_file (file_path
))
2761 return xstrdup (file_path
);
2766 /* If file_name include directory separator(s), try it first as
2767 a path name relative to the current directory */
2768 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
2773 if (__gnat_is_regular_file (file_name
))
2774 return xstrdup (file_name
);
2781 /* The result has to be smaller than path_val + file_name. */
2782 char *file_path
= (char *) alloca (strlen (path_val
) + strlen (file_name
) + 2);
2786 for (; *path_val
== PATH_SEPARATOR
; path_val
++)
2792 /* Skip the starting quote */
2794 if (*path_val
== '"')
2797 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
2798 *ptr
++ = *path_val
++;
2802 /* Skip the ending quote */
2807 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
2808 *++ptr
= DIR_SEPARATOR
;
2810 strcpy (++ptr
, file_name
);
2812 if (__gnat_is_regular_file (file_path
))
2813 return xstrdup (file_path
);
2820 /* Locate an executable given a Path argument. This routine is only used by
2821 gnatbl and should not be used otherwise. Use locate_exec_on_path
2825 __gnat_locate_exec (char *exec_name
, char *path_val
)
2828 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
2830 char *full_exec_name
2831 = (char *) alloca (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
2833 strcpy (full_exec_name
, exec_name
);
2834 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
2835 ptr
= __gnat_locate_regular_file (full_exec_name
, path_val
);
2838 return __gnat_locate_regular_file (exec_name
, path_val
);
2842 return __gnat_locate_regular_file (exec_name
, path_val
);
2845 /* Locate an executable using the Systems default PATH. */
2848 __gnat_locate_exec_on_path (char *exec_name
)
2852 #if defined (_WIN32) && !defined (RTX)
2853 TCHAR
*wpath_val
= _tgetenv (_T("PATH"));
2855 /* In Win32 systems we expand the PATH as for XP environment
2856 variables are not automatically expanded. We also prepend the
2857 ".;" to the path to match normal NT path search semantics */
2859 #define EXPAND_BUFFER_SIZE 32767
2861 wapath_val
= alloca (EXPAND_BUFFER_SIZE
);
2863 wapath_val
[0] = '.';
2864 wapath_val
[1] = ';';
2866 DWORD res
= ExpandEnvironmentStrings
2867 (wpath_val
, &wapath_val
[2], EXPAND_BUFFER_SIZE
- 2);
2869 if (!res
) wapath_val
[0] = _T('\0');
2871 apath_val
= alloca (EXPAND_BUFFER_SIZE
);
2873 WS2SC (apath_val
, wapath_val
, EXPAND_BUFFER_SIZE
);
2874 return __gnat_locate_exec (exec_name
, apath_val
);
2879 char *path_val
= "/VAXC$PATH";
2881 char *path_val
= getenv ("PATH");
2883 if (path_val
== NULL
) return NULL
;
2884 apath_val
= (char *) alloca (strlen (path_val
) + 1);
2885 strcpy (apath_val
, path_val
);
2886 return __gnat_locate_exec (exec_name
, apath_val
);
2892 /* These functions are used to translate to and from VMS and Unix syntax
2893 file, directory and path specifications. */
2896 #define MAXNAMES 256
2897 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2899 static char new_canonical_dirspec
[MAXPATH
];
2900 static char new_canonical_filespec
[MAXPATH
];
2901 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
2902 static unsigned new_canonical_filelist_index
;
2903 static unsigned new_canonical_filelist_in_use
;
2904 static unsigned new_canonical_filelist_allocated
;
2905 static char **new_canonical_filelist
;
2906 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
2907 static char new_host_dirspec
[MAXPATH
];
2908 static char new_host_filespec
[MAXPATH
];
2910 /* Routine is called repeatedly by decc$from_vms via
2911 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2915 wildcard_translate_unix (char *name
)
2918 char buff
[MAXPATH
];
2920 strncpy (buff
, name
, MAXPATH
);
2921 buff
[MAXPATH
- 1] = (char) 0;
2922 ver
= strrchr (buff
, '.');
2924 /* Chop off the version. */
2928 /* Dynamically extend the allocation by the increment. */
2929 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
2931 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
2932 new_canonical_filelist
= (char **) xrealloc
2933 (new_canonical_filelist
,
2934 new_canonical_filelist_allocated
* sizeof (char *));
2937 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
2942 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2943 full translation and copy the results into a list (_init), then return them
2944 one at a time (_next). If onlydirs set, only expand directory files. */
2947 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
2950 char buff
[MAXPATH
];
2952 len
= strlen (filespec
);
2953 strncpy (buff
, filespec
, MAXPATH
);
2955 /* Only look for directories */
2956 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
2957 strncat (buff
, "*.dir", MAXPATH
);
2959 buff
[MAXPATH
- 1] = (char) 0;
2961 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
2963 /* Remove the .dir extension. */
2969 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
2971 ext
= strstr (new_canonical_filelist
[i
], ".dir");
2977 return new_canonical_filelist_in_use
;
2980 /* Return the next filespec in the list. */
2983 __gnat_to_canonical_file_list_next ()
2985 return new_canonical_filelist
[new_canonical_filelist_index
++];
2988 /* Free storage used in the wildcard expansion. */
2991 __gnat_to_canonical_file_list_free ()
2995 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
2996 free (new_canonical_filelist
[i
]);
2998 free (new_canonical_filelist
);
3000 new_canonical_filelist_in_use
= 0;
3001 new_canonical_filelist_allocated
= 0;
3002 new_canonical_filelist_index
= 0;
3003 new_canonical_filelist
= 0;
3006 /* The functional equivalent of decc$translate_vms routine.
3007 Designed to produce the same output, but is protected against
3008 malformed paths (original version ACCVIOs in this case) and
3009 does not require VMS-specific DECC RTL */
3011 #define NAM$C_MAXRSS 1024
3014 __gnat_translate_vms (char *src
)
3016 static char retbuf
[NAM$C_MAXRSS
+1];
3017 char *srcendpos
, *pos1
, *pos2
, *retpos
;
3018 int disp
, path_present
= 0;
3020 if (!src
) return NULL
;
3022 srcendpos
= strchr (src
, '\0');
3025 /* Look for the node and/or device in front of the path */
3027 pos2
= strchr (pos1
, ':');
3029 if (pos2
&& (pos2
< srcendpos
) && (*(pos2
+ 1) == ':')) {
3030 /* There is a node name. "node_name::" becomes "node_name!" */
3032 strncpy (retbuf
, pos1
, disp
);
3033 retpos
[disp
] = '!';
3034 retpos
= retpos
+ disp
+ 1;
3036 pos2
= strchr (pos1
, ':');
3040 /* There is a device name. "dev_name:" becomes "/dev_name/" */
3043 strncpy (retpos
, pos1
, disp
);
3044 retpos
= retpos
+ disp
;
3049 /* No explicit device; we must look ahead and prepend /sys$disk/ if
3050 the path is absolute */
3051 if ((*pos1
== '[' || *pos1
== '<') && (pos1
< srcendpos
)
3052 && !strchr (".-]>", *(pos1
+ 1))) {
3053 strncpy (retpos
, "/sys$disk/", 10);
3057 /* Process the path part */
3058 while (*pos1
== '[' || *pos1
== '<') {
3061 if (*pos1
== ']' || *pos1
== '>') {
3062 /* Special case, [] translates to '.' */
3067 /* '[000000' means root dir. It can be present in the middle of
3068 the path due to expansion of logical devices, in which case
3070 if (!strncmp (pos1
, "000000", 6) && path_present
> 1 &&
3071 (*(pos1
+ 6) == ']' || *(pos1
+ 6) == '>' || *(pos1
+ 6) == '.')) {
3073 if (*pos1
== '.') pos1
++;
3075 else if (*pos1
== '.') {
3080 /* There is a qualified path */
3081 while (*pos1
&& *pos1
!= ']' && *pos1
!= '>') {
3084 /* '.' is used to separate directories. Replace it with '/' but
3085 only if there isn't already '/' just before */
3086 if (*(retpos
- 1) != '/') *(retpos
++) = '/';
3088 if (pos1
+ 1 < srcendpos
&& *pos1
== '.' && *(pos1
+ 1) == '.') {
3089 /* ellipsis refers to entire subtree; replace with '**' */
3090 *(retpos
++) = '*'; *(retpos
++) = '*'; *(retpos
++) = '/';
3095 /* When after '.' '[' '<' is equivalent to Unix ".." but there
3096 may be several in a row */
3097 if (*(pos1
- 1) == '.' || *(pos1
- 1) == '[' ||
3098 *(pos1
- 1) == '<') {
3099 while (*pos1
== '-') {
3101 *(retpos
++) = '.'; *(retpos
++) = '.'; *(retpos
++) = '/';
3106 /* otherwise fall through to default */
3108 *(retpos
++) = *(pos1
++);
3115 if (pos1
< srcendpos
) {
3116 /* Now add the actual file name, until the version suffix if any */
3117 if (path_present
) *(retpos
++) = '/';
3118 pos2
= strchr (pos1
, ';');
3119 disp
= pos2
? (pos2
- pos1
) : (srcendpos
- pos1
);
3120 strncpy (retpos
, pos1
, disp
);
3122 if (pos2
&& pos2
< srcendpos
) {
3123 /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
3125 disp
= srcendpos
- pos2
- 1;
3126 strncpy (retpos
, pos2
+ 1, disp
);
3137 /* Translate a VMS syntax directory specification in to Unix syntax. If
3138 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
3139 found, return input string. Also translate a dirname that contains no
3140 slashes, in case it's a logical name. */
3143 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
3147 strcpy (new_canonical_dirspec
, "");
3148 if (strlen (dirspec
))
3152 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
3154 strncpy (new_canonical_dirspec
,
3155 __gnat_translate_vms (dirspec
),
3158 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
3160 strncpy (new_canonical_dirspec
,
3161 __gnat_translate_vms (dirspec1
),
3166 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
3170 len
= strlen (new_canonical_dirspec
);
3171 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
3172 strncat (new_canonical_dirspec
, "/", MAXPATH
);
3174 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
3176 return new_canonical_dirspec
;
3180 /* Translate a VMS syntax file specification into Unix syntax.
3181 If no indicators of VMS syntax found, check if it's an uppercase
3182 alphanumeric_ name and if so try it out as an environment
3183 variable (logical name). If all else fails return the
3187 __gnat_to_canonical_file_spec (char *filespec
)
3191 strncpy (new_canonical_filespec
, "", MAXPATH
);
3193 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3195 char *tspec
= (char *) __gnat_translate_vms (filespec
);
3197 if (tspec
!= (char *) -1)
3198 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3200 else if ((strlen (filespec
) == strspn (filespec
,
3201 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
3202 && (filespec1
= getenv (filespec
)))
3204 char *tspec
= (char *) __gnat_translate_vms (filespec1
);
3206 if (tspec
!= (char *) -1)
3207 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3211 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
3214 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
3216 return new_canonical_filespec
;
3219 /* Translate a VMS syntax path specification into Unix syntax.
3220 If no indicators of VMS syntax found, return input string. */
3223 __gnat_to_canonical_path_spec (char *pathspec
)
3225 char *curr
, *next
, buff
[MAXPATH
];
3230 /* If there are /'s, assume it's a Unix path spec and return. */
3231 if (strchr (pathspec
, '/'))
3234 new_canonical_pathspec
[0] = 0;
3239 next
= strchr (curr
, ',');
3241 next
= strchr (curr
, 0);
3243 strncpy (buff
, curr
, next
- curr
);
3244 buff
[next
- curr
] = 0;
3246 /* Check for wildcards and expand if present. */
3247 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
3251 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
3252 for (i
= 0; i
< dirs
; i
++)
3256 next_dir
= __gnat_to_canonical_file_list_next ();
3257 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
3259 /* Don't append the separator after the last expansion. */
3261 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3264 __gnat_to_canonical_file_list_free ();
3267 strncat (new_canonical_pathspec
,
3268 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
3273 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3277 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
3279 return new_canonical_pathspec
;
3282 static char filename_buff
[MAXPATH
];
3285 translate_unix (char *name
, int type
)
3287 strncpy (filename_buff
, name
, MAXPATH
);
3288 filename_buff
[MAXPATH
- 1] = (char) 0;
3292 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
3296 to_host_path_spec (char *pathspec
)
3298 char *curr
, *next
, buff
[MAXPATH
];
3303 /* Can't very well test for colons, since that's the Unix separator! */
3304 if (strchr (pathspec
, ']') || strchr (pathspec
, ','))
3307 new_host_pathspec
[0] = 0;
3312 next
= strchr (curr
, ':');
3314 next
= strchr (curr
, 0);
3316 strncpy (buff
, curr
, next
- curr
);
3317 buff
[next
- curr
] = 0;
3319 strncat (new_host_pathspec
, __gnat_to_host_dir_spec (buff
, 0), MAXPATH
);
3322 strncat (new_host_pathspec
, ",", MAXPATH
);
3326 new_host_pathspec
[MAXPATH
- 1] = (char) 0;
3328 return new_host_pathspec
;
3331 /* Translate a Unix syntax directory specification into VMS syntax. The
3332 PREFIXFLAG has no effect, but is kept for symmetry with
3333 to_canonical_dir_spec. If indicators of VMS syntax found, return input
3337 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3339 int len
= strlen (dirspec
);
3341 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
3342 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3344 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
3345 return new_host_dirspec
;
3347 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
3349 new_host_dirspec
[len
- 1] = 0;
3353 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
3354 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
3355 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3357 return new_host_dirspec
;
3360 /* Translate a Unix syntax file specification into VMS syntax.
3361 If indicators of VMS syntax found, return input string. */
3364 __gnat_to_host_file_spec (char *filespec
)
3366 strncpy (new_host_filespec
, "", MAXPATH
);
3367 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3369 strncpy (new_host_filespec
, filespec
, MAXPATH
);
3373 decc$
to_vms (filespec
, translate_unix
, 1, 1);
3374 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
3377 new_host_filespec
[MAXPATH
- 1] = (char) 0;
3379 return new_host_filespec
;
3383 __gnat_adjust_os_resource_limits ()
3385 SYS$
ADJWSL (131072, 0);
3390 /* Dummy functions for Osint import for non-VMS systems. */
3393 __gnat_to_canonical_file_list_init
3394 (char *dirspec ATTRIBUTE_UNUSED
, int onlydirs ATTRIBUTE_UNUSED
)
3400 __gnat_to_canonical_file_list_next (void)
3402 static char *empty
= "";
3407 __gnat_to_canonical_file_list_free (void)
3412 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3418 __gnat_to_canonical_file_spec (char *filespec
)
3424 __gnat_to_canonical_path_spec (char *pathspec
)
3430 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3436 __gnat_to_host_file_spec (char *filespec
)
3442 __gnat_adjust_os_resource_limits (void)
3448 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
3449 to coordinate this with the EMX distribution. Consequently, we put the
3450 definition of dummy which is used for exception handling, here. */
3452 #if defined (__EMX__)
3456 #if defined (__mips_vxworks)
3460 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
3464 #if defined (IS_CROSS) \
3465 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3466 && defined (__SVR4)) \
3467 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3468 && ! (defined (linux) && defined (__ia64__)) \
3469 && ! (defined (linux) && defined (powerpc)) \
3470 && ! defined (__FreeBSD__) \
3471 && ! defined (__Lynx__) \
3472 && ! defined (__hpux__) \
3473 && ! defined (__APPLE__) \
3474 && ! defined (_AIX) \
3475 && ! (defined (__alpha__) && defined (__osf__)) \
3476 && ! defined (VMS) \
3477 && ! defined (__MINGW32__) \
3478 && ! (defined (__mips) && defined (__sgi)))
3480 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3481 just above for a list of native platforms that provide a non-dummy
3482 version of this procedure in libaddr2line.a. */
3485 convert_addresses (const char *file_name ATTRIBUTE_UNUSED
,
3486 void *addrs ATTRIBUTE_UNUSED
,
3487 int n_addr ATTRIBUTE_UNUSED
,
3488 void *buf ATTRIBUTE_UNUSED
,
3489 int *len ATTRIBUTE_UNUSED
)
3495 #if defined (_WIN32)
3496 int __gnat_argument_needs_quote
= 1;
3498 int __gnat_argument_needs_quote
= 0;
3501 /* This option is used to enable/disable object files handling from the
3502 binder file by the GNAT Project module. For example, this is disabled on
3503 Windows (prior to GCC 3.4) as it is already done by the mdll module.
3504 Stating with GCC 3.4 the shared libraries are not based on mdll
3505 anymore as it uses the GCC's -shared option */
3506 #if defined (_WIN32) \
3507 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3508 int __gnat_prj_add_obj_files
= 0;
3510 int __gnat_prj_add_obj_files
= 1;
3513 /* char used as prefix/suffix for environment variables */
3514 #if defined (_WIN32)
3515 char __gnat_environment_char
= '%';
3517 char __gnat_environment_char
= '$';
3520 /* This functions copy the file attributes from a source file to a
3523 mode = 0 : In this mode copy only the file time stamps (last access and
3524 last modification time stamps).
3526 mode = 1 : In this mode, time stamps and read/write/execute attributes are
3529 Returns 0 if operation was successful and -1 in case of error. */
3532 __gnat_copy_attribs (char *from
, char *to
, int mode
)
3534 #if defined (VMS) || defined (__vxworks) || defined (__nucleus__)
3537 #elif defined (_WIN32) && !defined (RTX)
3538 TCHAR wfrom
[GNAT_MAX_PATH_LEN
+ 2];
3539 TCHAR wto
[GNAT_MAX_PATH_LEN
+ 2];
3541 FILETIME fct
, flat
, flwt
;
3544 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
+ 2);
3545 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
+ 2);
3547 /* retrieve from times */
3550 (wfrom
, GENERIC_READ
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3552 if (hfrom
== INVALID_HANDLE_VALUE
)
3555 res
= GetFileTime (hfrom
, &fct
, &flat
, &flwt
);
3557 CloseHandle (hfrom
);
3562 /* retrieve from times */
3565 (wto
, GENERIC_WRITE
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3567 if (hto
== INVALID_HANDLE_VALUE
)
3570 res
= SetFileTime (hto
, NULL
, &flat
, &flwt
);
3577 /* Set file attributes in full mode. */
3581 DWORD attribs
= GetFileAttributes (wfrom
);
3583 if (attribs
== INVALID_FILE_ATTRIBUTES
)
3586 res
= SetFileAttributes (wto
, attribs
);
3594 GNAT_STRUCT_STAT fbuf
;
3595 struct utimbuf tbuf
;
3597 if (GNAT_STAT (from
, &fbuf
) == -1)
3602 tbuf
.actime
= fbuf
.st_atime
;
3603 tbuf
.modtime
= fbuf
.st_mtime
;
3605 if (utime (to
, &tbuf
) == -1)
3612 if (chmod (to
, fbuf
.st_mode
) == -1)
3623 __gnat_lseek (int fd
, long offset
, int whence
)
3625 return (int) lseek (fd
, offset
, whence
);
3628 /* This function returns the major version number of GCC being used. */
3630 get_gcc_version (void)
3635 return (int) (version_string
[0] - '0');
3640 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED
,
3641 int close_on_exec_p ATTRIBUTE_UNUSED
)
3643 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3644 int flags
= fcntl (fd
, F_GETFD
, 0);
3647 if (close_on_exec_p
)
3648 flags
|= FD_CLOEXEC
;
3650 flags
&= ~FD_CLOEXEC
;
3651 return fcntl (fd
, F_SETFD
, flags
| FD_CLOEXEC
);
3652 #elif defined(_WIN32)
3653 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
3654 if (h
== (HANDLE
) -1)
3656 if (close_on_exec_p
)
3657 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
, 0);
3658 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
,
3659 HANDLE_FLAG_INHERIT
);
3661 /* TODO: Unimplemented. */
3666 /* Indicates if platforms supports automatic initialization through the
3667 constructor mechanism */
3669 __gnat_binder_supports_auto_init (void)
3678 /* Indicates that Stand-Alone Libraries are automatically initialized through
3679 the constructor mechanism */
3681 __gnat_sals_init_using_constructors (void)
3683 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3692 /* In RTX mode, the procedure to get the time (as file time) is different
3693 in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3694 we introduce an intermediate procedure to link against the corresponding
3695 one in each situation. */
3697 extern void GetTimeAsFileTime(LPFILETIME pTime
);
3699 void GetTimeAsFileTime(LPFILETIME pTime
)
3702 RtGetRtssTimeAsFileTime (pTime
); /* RTSS interface */
3704 GetSystemTimeAsFileTime (pTime
); /* w32 interface */
3709 /* Add symbol that is required to link. It would otherwise be taken from
3710 libgcc.a and it would try to use the gcc constructors that are not
3711 supported by Microsoft linker. */
3713 extern void __main (void);
3715 void __main (void) {}
3719 #if defined (linux) || defined(__GLIBC__)
3720 /* pthread affinity support */
3722 int __gnat_pthread_setaffinity_np (pthread_t th
,
3724 const void *cpuset
);
3727 #include <pthread.h>
3729 __gnat_pthread_setaffinity_np (pthread_t th
,
3731 const cpu_set_t
*cpuset
)
3733 return pthread_setaffinity_np (th
, cpusetsize
, cpuset
);
3737 __gnat_pthread_setaffinity_np (pthread_t th ATTRIBUTE_UNUSED
,
3738 size_t cpusetsize ATTRIBUTE_UNUSED
,
3739 const void *cpuset ATTRIBUTE_UNUSED
)
3747 /* There is no function in the glibc to retrieve the LWP of the current
3748 thread. We need to do a system call in order to retrieve this
3750 #include <sys/syscall.h>
3751 void *__gnat_lwp_self (void)
3753 return (void *) syscall (__NR_gettid
);