1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2012, 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. */
43 /* No need to redefine exit here. */
46 /* We want to use the POSIX variants of include files. */
50 #if defined (__mips_vxworks)
52 #endif /* __mips_vxworks */
54 /* If SMP, access vxCpuConfiguredGet */
55 #ifdef _WRS_CONFIG_SMP
57 #endif /* _WRS_CONFIG_SMP */
59 /* We need to know the VxWorks version because some file operations
60 (such as chmod) are only available on VxWorks 6. */
65 #if defined (__APPLE__)
69 #if defined (__hpux__)
70 #include <sys/param.h>
71 #include <sys/pstat.h>
76 #define HOST_EXECUTABLE_SUFFIX ".exe"
77 #define HOST_OBJECT_SUFFIX ".obj"
91 /* S_IREAD and S_IWRITE are not defined in VxWorks */
93 #define S_IREAD (S_IRUSR | S_IRGRP | S_IROTH)
97 #define S_IWRITE (S_IWUSR)
101 /* We don't have libiberty, so use malloc. */
102 #define xmalloc(S) malloc (S)
103 #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 *);
232 #define DIR_SEPARATOR '\\'
237 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
238 defined in the current system. On DOS-like systems these flags control
239 whether the file is opened/created in text-translation mode (CR/LF in
240 external file mapped to LF in internal file), but in Unix-like systems,
241 no text translation is required, so these flags have no effect. */
251 #ifndef HOST_EXECUTABLE_SUFFIX
252 #define HOST_EXECUTABLE_SUFFIX ""
255 #ifndef HOST_OBJECT_SUFFIX
256 #define HOST_OBJECT_SUFFIX ".o"
259 #ifndef PATH_SEPARATOR
260 #define PATH_SEPARATOR ':'
263 #ifndef DIR_SEPARATOR
264 #define DIR_SEPARATOR '/'
267 /* Check for cross-compilation */
268 #if defined (CROSS_COMPILE) || defined (CROSS_DIRECTORY_STRUCTURE)
270 int __gnat_is_cross_compiler
= 1;
273 int __gnat_is_cross_compiler
= 0;
276 char __gnat_dir_separator
= DIR_SEPARATOR
;
278 char __gnat_path_separator
= PATH_SEPARATOR
;
280 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
281 the base filenames that libraries specified with -lsomelib options
282 may have. This is used by GNATMAKE to check whether an executable
283 is up-to-date or not. The syntax is
285 library_template ::= { pattern ; } pattern NUL
286 pattern ::= [ prefix ] * [ postfix ]
288 These should only specify names of static libraries as it makes
289 no sense to determine at link time if dynamic-link libraries are
290 up to date or not. Any libraries that are not found are supposed
293 * if they are needed but not present, the link
296 * otherwise they are libraries in the system paths and so
297 they are considered part of the system and not checked
300 ??? This should be part of a GNAT host-specific compiler
301 file instead of being included in all user applications
302 as well. This is only a temporary work-around for 3.11b. */
304 #ifndef GNAT_LIBRARY_TEMPLATE
306 #define GNAT_LIBRARY_TEMPLATE "*.olb"
308 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
312 const char *__gnat_library_template
= GNAT_LIBRARY_TEMPLATE
;
314 /* This variable is used in hostparm.ads to say whether the host is a VMS
323 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
325 #elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__)
326 #define GNAT_MAX_PATH_LEN PATH_MAX
330 #if defined (__MINGW32__)
334 #include <sys/param.h>
338 #include <sys/param.h>
342 #define GNAT_MAX_PATH_LEN MAXPATHLEN
344 #define GNAT_MAX_PATH_LEN 256
349 /* Used for Ada bindings */
350 int __gnat_size_of_file_attributes
= sizeof (struct file_attributes
);
352 void __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
);
354 /* The __gnat_max_path_len variable is used to export the maximum
355 length of a path name to Ada code. max_path_len is also provided
356 for compatibility with older GNAT versions, please do not use
359 int __gnat_max_path_len
= GNAT_MAX_PATH_LEN
;
360 int max_path_len
= GNAT_MAX_PATH_LEN
;
362 /* Control whether we can use ACL on Windows. */
364 int __gnat_use_acl
= 1;
366 /* The following macro HAVE_READDIR_R should be defined if the
367 system provides the routine readdir_r. */
368 #undef HAVE_READDIR_R
370 #if defined(VMS) && defined (__LONG_POINTERS)
372 /* Return a 32 bit pointer to an array of 32 bit pointers
373 given a 64 bit pointer to an array of 64 bit pointers */
375 typedef __char_ptr32
*__char_ptr_char_ptr32
__attribute__ ((mode (SI
)));
377 static __char_ptr_char_ptr32
378 to_ptr32 (char **ptr64
)
381 __char_ptr_char_ptr32 short_argv
;
383 for (argc
=0; ptr64
[argc
]; argc
++);
385 /* Reallocate argv with 32 bit pointers. */
386 short_argv
= (__char_ptr_char_ptr32
) decc$malloc
387 (sizeof (__char_ptr32
) * (argc
+ 1));
389 for (argc
=0; ptr64
[argc
]; argc
++)
390 short_argv
[argc
] = (__char_ptr32
) decc$
strdup (ptr64
[argc
]);
392 short_argv
[argc
] = (__char_ptr32
) 0;
396 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
398 #define MAYBE_TO_PTR32(argv) argv
401 static const char ATTR_UNSET
= 127;
403 /* Reset the file attributes as if no system call had been performed */
406 __gnat_reset_attributes
407 (struct file_attributes
* attr
)
409 attr
->exists
= ATTR_UNSET
;
411 attr
->writable
= ATTR_UNSET
;
412 attr
->readable
= ATTR_UNSET
;
413 attr
->executable
= ATTR_UNSET
;
415 attr
->regular
= ATTR_UNSET
;
416 attr
->symbolic_link
= ATTR_UNSET
;
417 attr
->directory
= ATTR_UNSET
;
419 attr
->timestamp
= (OS_Time
)-2;
420 attr
->file_length
= -1;
427 time_t res
= time (NULL
);
428 return (OS_Time
) res
;
431 /* Return the current local time as a string in the ISO 8601 format of
432 "YYYY-MM-DD HH:MM:SS.SS". The returned string is 22 + 1 (NULL) characters
436 __gnat_current_time_string
439 const char *format
= "%Y-%m-%d %H:%M:%S";
440 /* Format string necessary to describe the ISO 8601 format */
442 const time_t t_val
= time (NULL
);
444 strftime (result
, 22, format
, localtime (&t_val
));
445 /* Convert the local time into a string following the ISO format, copying
446 at most 22 characters into the result string. */
451 /* The sub-seconds are manually set to zero since type time_t lacks the
452 precision necessary for nanoseconds. */
466 time_t time
= (time_t) *p_time
;
469 /* On Windows systems, the time is sometimes rounded up to the nearest
470 even second, so if the number of seconds is odd, increment it. */
476 res
= localtime (&time
);
478 res
= gmtime (&time
);
483 *p_year
= res
->tm_year
;
484 *p_month
= res
->tm_mon
;
485 *p_day
= res
->tm_mday
;
486 *p_hours
= res
->tm_hour
;
487 *p_mins
= res
->tm_min
;
488 *p_secs
= res
->tm_sec
;
491 *p_year
= *p_month
= *p_day
= *p_hours
= *p_mins
= *p_secs
= 0;
494 /* Place the contents of the symbolic link named PATH in the buffer BUF,
495 which has size BUFSIZ. If PATH is a symbolic link, then return the number
496 of characters of its content in BUF. Otherwise, return -1.
497 For systems not supporting symbolic links, always return -1. */
500 __gnat_readlink (char *path ATTRIBUTE_UNUSED
,
501 char *buf ATTRIBUTE_UNUSED
,
502 size_t bufsiz ATTRIBUTE_UNUSED
)
504 #if defined (_WIN32) || defined (VMS) \
505 || defined(__vxworks) || defined (__nucleus__)
508 return readlink (path
, buf
, bufsiz
);
512 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH.
513 If NEWPATH exists it will NOT be overwritten.
514 For systems not supporting symbolic links, always return -1. */
517 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED
,
518 char *newpath ATTRIBUTE_UNUSED
)
520 #if defined (_WIN32) || defined (VMS) \
521 || defined(__vxworks) || defined (__nucleus__)
524 return symlink (oldpath
, newpath
);
528 /* Try to lock a file, return 1 if success. */
530 #if defined (__vxworks) || defined (__nucleus__) \
531 || defined (_WIN32) || defined (VMS)
533 /* Version that does not use link. */
536 __gnat_try_lock (char *dir
, char *file
)
540 TCHAR wfull_path
[GNAT_MAX_PATH_LEN
];
541 TCHAR wfile
[GNAT_MAX_PATH_LEN
];
542 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
544 S2WSC (wdir
, dir
, GNAT_MAX_PATH_LEN
);
545 S2WSC (wfile
, file
, GNAT_MAX_PATH_LEN
);
547 _stprintf (wfull_path
, _T("%s%c%s"), wdir
, _T(DIR_SEPARATOR
), wfile
);
548 fd
= _topen (wfull_path
, O_CREAT
| O_EXCL
, 0600);
552 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
553 fd
= open (full_path
, O_CREAT
| O_EXCL
, 0600);
565 /* Version using link(), more secure over NFS. */
566 /* See TN 6913-016 for discussion ??? */
569 __gnat_try_lock (char *dir
, char *file
)
573 GNAT_STRUCT_STAT stat_result
;
576 sprintf (full_path
, "%s%c%s", dir
, DIR_SEPARATOR
, file
);
577 sprintf (temp_file
, "%s%cTMP-%ld-%ld",
578 dir
, DIR_SEPARATOR
, (long)getpid(), (long)getppid ());
580 /* Create the temporary file and write the process number. */
581 fd
= open (temp_file
, O_CREAT
| O_WRONLY
, 0600);
587 /* Link it with the new file. */
588 link (temp_file
, full_path
);
590 /* Count the references on the old one. If we have a count of two, then
591 the link did succeed. Remove the temporary file before returning. */
592 __gnat_stat (temp_file
, &stat_result
);
594 return stat_result
.st_nlink
== 2;
598 /* Return the maximum file name length. */
601 __gnat_get_maximum_file_name_length (void)
604 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
613 /* Return nonzero if file names are case sensitive. */
615 static int file_names_case_sensitive_cache
= -1;
618 __gnat_get_file_names_case_sensitive (void)
620 if (file_names_case_sensitive_cache
== -1)
622 const char *sensitive
= getenv ("GNAT_FILE_NAME_CASE_SENSITIVE");
624 if (sensitive
!= NULL
625 && (sensitive
[0] == '0' || sensitive
[0] == '1')
626 && sensitive
[1] == '\0')
627 file_names_case_sensitive_cache
= sensitive
[0] - '0';
629 #if defined (VMS) || defined (WINNT) || defined (__APPLE__)
630 file_names_case_sensitive_cache
= 0;
632 file_names_case_sensitive_cache
= 1;
635 return file_names_case_sensitive_cache
;
638 /* Return nonzero if environment variables are case sensitive. */
641 __gnat_get_env_vars_case_sensitive (void)
643 #if defined (VMS) || defined (WINNT)
651 __gnat_get_default_identifier_character_set (void)
656 /* Return the current working directory. */
659 __gnat_get_current_dir (char *dir
, int *length
)
661 #if defined (__MINGW32__)
662 TCHAR wdir
[GNAT_MAX_PATH_LEN
];
664 _tgetcwd (wdir
, *length
);
666 WS2SC (dir
, wdir
, GNAT_MAX_PATH_LEN
);
669 /* Force Unix style, which is what GNAT uses internally. */
670 getcwd (dir
, *length
, 0);
672 getcwd (dir
, *length
);
675 *length
= strlen (dir
);
677 if (dir
[*length
- 1] != DIR_SEPARATOR
)
679 dir
[*length
] = DIR_SEPARATOR
;
685 /* Return the suffix for object files. */
688 __gnat_get_object_suffix_ptr (int *len
, const char **value
)
690 *value
= HOST_OBJECT_SUFFIX
;
695 *len
= strlen (*value
);
700 /* Return the suffix for executable files. */
703 __gnat_get_executable_suffix_ptr (int *len
, const char **value
)
705 *value
= HOST_EXECUTABLE_SUFFIX
;
709 *len
= strlen (*value
);
714 /* Return the suffix for debuggable files. Usually this is the same as the
715 executable extension. */
718 __gnat_get_debuggable_suffix_ptr (int *len
, const char **value
)
720 *value
= HOST_EXECUTABLE_SUFFIX
;
725 *len
= strlen (*value
);
730 /* Returns the OS filename and corresponding encoding. */
733 __gnat_os_filename (char *filename ATTRIBUTE_UNUSED
,
734 char *w_filename ATTRIBUTE_UNUSED
,
735 char *os_name
, int *o_length
,
736 char *encoding ATTRIBUTE_UNUSED
, int *e_length
)
738 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
739 WS2SC (os_name
, (TCHAR
*)w_filename
, (DWORD
)*o_length
);
740 *o_length
= strlen (os_name
);
741 strcpy (encoding
, "encoding=utf8");
742 *e_length
= strlen (encoding
);
744 strcpy (os_name
, filename
);
745 *o_length
= strlen (filename
);
753 __gnat_unlink (char *path
)
755 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
757 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
759 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
760 return _tunlink (wpath
);
763 return unlink (path
);
770 __gnat_rename (char *from
, char *to
)
772 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
774 TCHAR wfrom
[GNAT_MAX_PATH_LEN
], wto
[GNAT_MAX_PATH_LEN
];
776 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
);
777 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
);
778 return _trename (wfrom
, wto
);
781 return rename (from
, to
);
785 /* Changing directory. */
788 __gnat_chdir (char *path
)
790 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
792 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
794 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
795 return _tchdir (wpath
);
802 /* Removing a directory. */
805 __gnat_rmdir (char *path
)
807 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
809 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
811 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
812 return _trmdir (wpath
);
814 #elif defined (VTHREADS)
815 /* rmdir not available */
823 __gnat_fopen (char *path
, char *mode
, int encoding ATTRIBUTE_UNUSED
)
825 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
826 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
829 S2WS (wmode
, mode
, 10);
831 if (encoding
== Encoding_Unspecified
)
832 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
833 else if (encoding
== Encoding_UTF8
)
834 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
836 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
838 return _tfopen (wpath
, wmode
);
840 return decc$
fopen (path
, mode
);
842 return GNAT_FOPEN (path
, mode
);
847 __gnat_freopen (char *path
,
850 int encoding ATTRIBUTE_UNUSED
)
852 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
853 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
856 S2WS (wmode
, mode
, 10);
858 if (encoding
== Encoding_Unspecified
)
859 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
860 else if (encoding
== Encoding_UTF8
)
861 S2WSU (wpath
, path
, GNAT_MAX_PATH_LEN
);
863 S2WS (wpath
, path
, GNAT_MAX_PATH_LEN
);
865 return _tfreopen (wpath
, wmode
, stream
);
867 return decc$
freopen (path
, mode
, stream
);
869 return freopen (path
, mode
, stream
);
874 __gnat_open_read (char *path
, int fmode
)
877 int o_fmode
= O_BINARY
;
883 /* Optional arguments mbc,deq,fop increase read performance. */
884 fd
= open (path
, O_RDONLY
| o_fmode
, 0444,
885 "mbc=16", "deq=64", "fop=tef");
886 #elif defined (__vxworks)
887 fd
= open (path
, O_RDONLY
| o_fmode
, 0444);
888 #elif defined (__MINGW32__)
890 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
892 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
893 fd
= _topen (wpath
, O_RDONLY
| o_fmode
, 0444);
896 fd
= open (path
, O_RDONLY
| o_fmode
);
899 return fd
< 0 ? -1 : fd
;
902 #if defined (__MINGW32__)
903 #define PERM (S_IREAD | S_IWRITE)
905 /* Excerpt from DECC C RTL Reference Manual:
906 To create files with OpenVMS RMS default protections using the UNIX
907 system-call functions umask, mkdir, creat, and open, call mkdir, creat,
908 and open with a file-protection mode argument of 0777 in a program
909 that never specifically calls umask. These default protections include
910 correctly establishing protections based on ACLs, previous versions of
914 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
918 __gnat_open_rw (char *path
, int fmode
)
921 int o_fmode
= O_BINARY
;
927 fd
= open (path
, O_RDWR
| o_fmode
, PERM
,
928 "mbc=16", "deq=64", "fop=tef");
929 #elif defined (__MINGW32__)
931 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
933 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
934 fd
= _topen (wpath
, O_RDWR
| o_fmode
, PERM
);
937 fd
= open (path
, O_RDWR
| o_fmode
, PERM
);
940 return fd
< 0 ? -1 : fd
;
944 __gnat_open_create (char *path
, int fmode
)
947 int o_fmode
= O_BINARY
;
953 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
,
954 "mbc=16", "deq=64", "fop=tef");
955 #elif defined (__MINGW32__)
957 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
959 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
960 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
963 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| o_fmode
, PERM
);
966 return fd
< 0 ? -1 : fd
;
970 __gnat_create_output_file (char *path
)
974 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
,
975 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
976 "shr=del,get,put,upd");
977 #elif defined (__MINGW32__)
979 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
981 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
982 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
985 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
, PERM
);
988 return fd
< 0 ? -1 : fd
;
992 __gnat_create_output_file_new (char *path
)
996 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
,
997 "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
998 "shr=del,get,put,upd");
999 #elif defined (__MINGW32__)
1001 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1003 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1004 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
1007 fd
= open (path
, O_WRONLY
| O_CREAT
| O_TRUNC
| O_TEXT
| O_EXCL
, PERM
);
1010 return fd
< 0 ? -1 : fd
;
1014 __gnat_open_append (char *path
, int fmode
)
1017 int o_fmode
= O_BINARY
;
1023 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
,
1024 "mbc=16", "deq=64", "fop=tef");
1025 #elif defined (__MINGW32__)
1027 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1029 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1030 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
1033 fd
= open (path
, O_WRONLY
| O_CREAT
| O_APPEND
| o_fmode
, PERM
);
1036 return fd
< 0 ? -1 : fd
;
1039 /* Open a new file. Return error (-1) if the file already exists. */
1042 __gnat_open_new (char *path
, int fmode
)
1045 int o_fmode
= O_BINARY
;
1051 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1052 "mbc=16", "deq=64", "fop=tef");
1053 #elif defined (__MINGW32__)
1055 TCHAR wpath
[GNAT_MAX_PATH_LEN
];
1057 S2WSC (wpath
, path
, GNAT_MAX_PATH_LEN
);
1058 fd
= _topen (wpath
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1061 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1064 return fd
< 0 ? -1 : fd
;
1067 /* Open a new temp file. Return error (-1) if the file already exists.
1068 Special options for VMS allow the file to be shared between parent and child
1069 processes, however they really slow down output. Used in gnatchop. */
1072 __gnat_open_new_temp (char *path
, int fmode
)
1075 int o_fmode
= O_BINARY
;
1077 strcpy (path
, "GNAT-XXXXXX");
1079 #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \
1080 || defined (linux) || defined(__GLIBC__)) && !defined (__vxworks)
1081 return mkstemp (path
);
1082 #elif defined (__Lynx__)
1084 #elif defined (__nucleus__)
1087 if (mktemp (path
) == NULL
)
1095 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
,
1096 "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
1097 "mbc=16", "deq=64", "fop=tef");
1099 fd
= open (path
, O_WRONLY
| O_CREAT
| O_EXCL
| o_fmode
, PERM
);
1102 return fd
< 0 ? -1 : fd
;
1105 /****************************************************************
1106 ** Perform a call to GNAT_STAT or GNAT_FSTAT, and extract as much information
1107 ** as possible from it, storing the result in a cache for later reuse
1108 ****************************************************************/
1111 __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
)
1113 GNAT_STRUCT_STAT statbuf
;
1117 ret
= GNAT_FSTAT (fd
, &statbuf
);
1119 ret
= __gnat_stat (name
, &statbuf
);
1121 attr
->regular
= (!ret
&& S_ISREG (statbuf
.st_mode
));
1122 attr
->directory
= (!ret
&& S_ISDIR (statbuf
.st_mode
));
1125 attr
->file_length
= 0;
1127 /* st_size may be 32 bits, or 64 bits which is converted to long. We
1128 don't return a useful value for files larger than 2 gigabytes in
1130 attr
->file_length
= statbuf
.st_size
; /* all systems */
1132 attr
->exists
= !ret
;
1134 #if !defined (_WIN32) || defined (RTX)
1135 /* on Windows requires extra system call, see __gnat_is_readable_file_attr */
1136 attr
->readable
= (!ret
&& (statbuf
.st_mode
& S_IRUSR
));
1137 attr
->writable
= (!ret
&& (statbuf
.st_mode
& S_IWUSR
));
1138 attr
->executable
= (!ret
&& (statbuf
.st_mode
& S_IXUSR
));
1142 attr
->timestamp
= (OS_Time
)-1;
1145 /* VMS has file versioning. */
1146 attr
->timestamp
= (OS_Time
)statbuf
.st_ctime
;
1148 attr
->timestamp
= (OS_Time
)statbuf
.st_mtime
;
1153 /****************************************************************
1154 ** Return the number of bytes in the specified file
1155 ****************************************************************/
1158 __gnat_file_length_attr (int fd
, char* name
, struct file_attributes
* attr
)
1160 if (attr
->file_length
== -1) {
1161 __gnat_stat_to_attr (fd
, name
, attr
);
1164 return attr
->file_length
;
1168 __gnat_file_length (int fd
)
1170 struct file_attributes attr
;
1171 __gnat_reset_attributes (&attr
);
1172 return __gnat_file_length_attr (fd
, NULL
, &attr
);
1176 __gnat_named_file_length (char *name
)
1178 struct file_attributes attr
;
1179 __gnat_reset_attributes (&attr
);
1180 return __gnat_file_length_attr (-1, name
, &attr
);
1183 /* Create a temporary filename and put it in string pointed to by
1187 __gnat_tmp_name (char *tmp_filename
)
1190 /* Variable used to create a series of unique names */
1191 static int counter
= 0;
1193 /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */
1194 strcpy (tmp_filename
, "c:\\WINDOWS\\Temp\\gnat-");
1195 sprintf (&tmp_filename
[strlen (tmp_filename
)], "%d\0", counter
++);
1197 #elif defined (__MINGW32__)
1202 /* tempnam tries to create a temporary file in directory pointed to by
1203 TMP environment variable, in c:\temp if TMP is not set, and in
1204 directory specified by P_tmpdir in stdio.h if c:\temp does not
1205 exist. The filename will be created with the prefix "gnat-". */
1207 sprintf (prefix
, "gnat-%d-", (int)getpid());
1208 pname
= (char *) _tempnam ("c:\\temp", prefix
);
1210 /* if pname is NULL, the file was not created properly, the disk is full
1211 or there is no more free temporary files */
1214 *tmp_filename
= '\0';
1216 /* If pname start with a back slash and not path information it means that
1217 the filename is valid for the current working directory. */
1219 else if (pname
[0] == '\\')
1221 strcpy (tmp_filename
, ".\\");
1222 strcat (tmp_filename
, pname
+1);
1225 strcpy (tmp_filename
, pname
);
1230 #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \
1231 || defined (__OpenBSD__) || defined(__GLIBC__)
1232 #define MAX_SAFE_PATH 1000
1233 char *tmpdir
= getenv ("TMPDIR");
1235 /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
1236 a buffer overflow. */
1237 if (tmpdir
== NULL
|| strlen (tmpdir
) > MAX_SAFE_PATH
)
1238 strcpy (tmp_filename
, "/tmp/gnat-XXXXXX");
1240 sprintf (tmp_filename
, "%s/gnat-XXXXXX", tmpdir
);
1242 close (mkstemp(tmp_filename
));
1243 #elif defined (__vxworks) && !(defined (__RTP__) || defined (VTHREADS))
1247 static ushort_t seed
= 0; /* used to generate unique name */
1249 /* generate unique name */
1250 strcpy (tmp_filename
, "tmp");
1252 /* fill up the name buffer from the last position */
1254 pos
= tmp_filename
+ strlen (tmp_filename
) + index
;
1258 for (t
= seed
; 0 <= --index
; t
>>= 3)
1259 *--pos
= '0' + (t
& 07);
1261 tmpnam (tmp_filename
);
1265 /* Open directory and returns a DIR pointer. */
1267 DIR* __gnat_opendir (char *name
)
1270 /* Not supported in RTX */
1274 #elif defined (__MINGW32__)
1275 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1277 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1278 return (DIR*)_topendir (wname
);
1281 return opendir (name
);
1285 /* Read the next entry in a directory. The returned string points somewhere
1289 __gnat_readdir (DIR *dirp
, char *buffer
, int *len
)
1292 /* Not supported in RTX */
1296 #elif defined (__MINGW32__)
1297 struct _tdirent
*dirent
= _treaddir ((_TDIR
*)dirp
);
1301 WS2SC (buffer
, dirent
->d_name
, GNAT_MAX_PATH_LEN
);
1302 *len
= strlen (buffer
);
1309 #elif defined (HAVE_READDIR_R)
1310 /* If possible, try to use the thread-safe version. */
1311 if (readdir_r (dirp
, buffer
) != NULL
)
1313 *len
= strlen (((struct dirent
*) buffer
)->d_name
);
1314 return ((struct dirent
*) buffer
)->d_name
;
1320 struct dirent
*dirent
= (struct dirent
*) readdir (dirp
);
1324 strcpy (buffer
, dirent
->d_name
);
1325 *len
= strlen (buffer
);
1334 /* Close a directory entry. */
1336 int __gnat_closedir (DIR *dirp
)
1339 /* Not supported in RTX */
1343 #elif defined (__MINGW32__)
1344 return _tclosedir ((_TDIR
*)dirp
);
1347 return closedir (dirp
);
1351 /* Returns 1 if readdir is thread safe, 0 otherwise. */
1354 __gnat_readdir_is_thread_safe (void)
1356 #ifdef HAVE_READDIR_R
1363 #if defined (_WIN32) && !defined (RTX)
1364 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
1365 static const unsigned long long w32_epoch_offset
= 11644473600ULL;
1367 /* Returns the file modification timestamp using Win32 routines which are
1368 immune against daylight saving time change. It is in fact not possible to
1369 use fstat for this purpose as the DST modify the st_mtime field of the
1373 win32_filetime (HANDLE h
)
1378 unsigned long long ull_time
;
1381 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1382 since <Jan 1st 1601>. This function must return the number of seconds
1383 since <Jan 1st 1970>. */
1385 if (GetFileTime (h
, NULL
, NULL
, &t_write
.ft_time
))
1386 return (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1390 /* As above but starting from a FILETIME. */
1392 f2t (const FILETIME
*ft
, time_t *t
)
1397 unsigned long long ull_time
;
1400 t_write
.ft_time
= *ft
;
1401 *t
= (time_t) (t_write
.ull_time
/ 10000000ULL - w32_epoch_offset
);
1405 /* Return a GNAT time stamp given a file name. */
1408 __gnat_file_time_name_attr (char* name
, struct file_attributes
* attr
)
1410 if (attr
->timestamp
== (OS_Time
)-2) {
1411 #if defined (_WIN32) && !defined (RTX)
1413 WIN32_FILE_ATTRIBUTE_DATA fad
;
1415 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1416 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1418 if ((res
= GetFileAttributesEx (wname
, GetFileExInfoStandard
, &fad
)))
1419 f2t (&fad
.ftLastWriteTime
, &ret
);
1420 attr
->timestamp
= (OS_Time
) ret
;
1422 __gnat_stat_to_attr (-1, name
, attr
);
1425 return attr
->timestamp
;
1429 __gnat_file_time_name (char *name
)
1431 struct file_attributes attr
;
1432 __gnat_reset_attributes (&attr
);
1433 return __gnat_file_time_name_attr (name
, &attr
);
1436 /* Return a GNAT time stamp given a file descriptor. */
1439 __gnat_file_time_fd_attr (int fd
, struct file_attributes
* attr
)
1441 if (attr
->timestamp
== (OS_Time
)-2) {
1442 #if defined (_WIN32) && !defined (RTX)
1443 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
1444 time_t ret
= win32_filetime (h
);
1445 attr
->timestamp
= (OS_Time
) ret
;
1448 __gnat_stat_to_attr (fd
, NULL
, attr
);
1452 return attr
->timestamp
;
1456 __gnat_file_time_fd (int fd
)
1458 struct file_attributes attr
;
1459 __gnat_reset_attributes (&attr
);
1460 return __gnat_file_time_fd_attr (fd
, &attr
);
1463 /* Set the file time stamp. */
1466 __gnat_set_file_time_name (char *name
, time_t time_stamp
)
1468 #if defined (__vxworks)
1470 /* Code to implement __gnat_set_file_time_name for these systems. */
1472 #elif defined (_WIN32) && !defined (RTX)
1476 unsigned long long ull_time
;
1478 TCHAR wname
[GNAT_MAX_PATH_LEN
];
1480 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
);
1482 HANDLE h
= CreateFile
1483 (wname
, GENERIC_WRITE
, FILE_SHARE_WRITE
, NULL
,
1484 OPEN_EXISTING
, FILE_FLAG_BACKUP_SEMANTICS
,
1486 if (h
== INVALID_HANDLE_VALUE
)
1488 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1489 t_write
.ull_time
= ((unsigned long long)time_stamp
+ w32_epoch_offset
);
1490 /* Convert to 100 nanosecond units */
1491 t_write
.ull_time
*= 10000000ULL;
1493 SetFileTime(h
, NULL
, NULL
, &t_write
.ft_time
);
1503 unsigned long long backup
, create
, expire
, revise
;
1507 unsigned short value
;
1510 unsigned system
: 4;
1516 } Fat
= { 0, 0, 0, 0, 0, { 0 }};
1520 { ATR$S_CREDATE
, ATR$C_CREDATE
, &Fat
.create
},
1521 { ATR$S_REVDATE
, ATR$C_REVDATE
, &Fat
.revise
},
1522 { ATR$S_EXPDATE
, ATR$C_EXPDATE
, &Fat
.expire
},
1523 { ATR$S_BAKDATE
, ATR$C_BAKDATE
, &Fat
.backup
},
1524 { ATR$S_FPRO
, ATR$C_FPRO
, &Fat
.prot
},
1525 { ATR$S_UIC
, ATR$C_UIC
, &Fat
.uic
},
1530 struct dsc$descriptor_fib fibdsc
= {sizeof (fib
), (void *) &fib
};
1534 unsigned long long newtime
;
1535 unsigned long long revtime
;
1539 struct vstring file
;
1540 struct dsc$descriptor_s filedsc
1541 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) file
.string
};
1542 struct vstring device
;
1543 struct dsc$descriptor_s devicedsc
1544 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) device
.string
};
1545 struct vstring timev
;
1546 struct dsc$descriptor_s timedsc
1547 = {NAM$C_MAXRSS
, DSC$K_DTYPE_T
, DSC$K_CLASS_S
, (void *) timev
.string
};
1548 struct vstring result
;
1549 struct dsc$descriptor_s resultdsc
1550 = {NAM$C_MAXRSS
, DSC$K_DTYPE_VT
, DSC$K_CLASS_VS
, (void *) result
.string
};
1552 /* Convert parameter name (a file spec) to host file form. Note that this
1553 is needed on VMS to prepare for subsequent calls to VMS RMS library
1554 routines. Note that it would not work to call __gnat_to_host_dir_spec
1555 as was done in a previous version, since this fails silently unless
1556 the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1557 (directory not found) condition is signalled. */
1558 tryfile
= (char *) __gnat_to_host_file_spec (name
);
1560 /* Allocate and initialize a FAB and NAM structures. */
1564 nam
.nam$l_esa
= file
.string
;
1565 nam
.nam$b_ess
= NAM$C_MAXRSS
;
1566 nam
.nam$l_rsa
= result
.string
;
1567 nam
.nam$b_rss
= NAM$C_MAXRSS
;
1568 fab
.fab$l_fna
= tryfile
;
1569 fab
.fab$b_fns
= strlen (tryfile
);
1570 fab
.fab$l_nam
= &nam
;
1572 /* Validate filespec syntax and device existence. */
1573 status
= SYS$
PARSE (&fab
, 0, 0);
1574 if ((status
& 1) != 1)
1575 LIB$
SIGNAL (status
);
1577 file
.string
[nam
.nam$b_esl
] = 0;
1579 /* Find matching filespec. */
1580 status
= SYS$
SEARCH (&fab
, 0, 0);
1581 if ((status
& 1) != 1)
1582 LIB$
SIGNAL (status
);
1584 file
.string
[nam
.nam$b_esl
] = 0;
1585 result
.string
[result
.length
=nam
.nam$b_rsl
] = 0;
1587 /* Get the device name and assign an IO channel. */
1588 strncpy (device
.string
, nam
.nam$l_dev
, nam
.nam$b_dev
);
1589 devicedsc
.dsc$w_length
= nam
.nam$b_dev
;
1591 status
= SYS$
ASSIGN (&devicedsc
, &chan
, 0, 0, 0);
1592 if ((status
& 1) != 1)
1593 LIB$
SIGNAL (status
);
1595 /* Initialize the FIB and fill in the directory id field. */
1596 memset (&fib
, 0, sizeof (fib
));
1597 fib
.fib$w_did
[0] = nam
.nam$w_did
[0];
1598 fib
.fib$w_did
[1] = nam
.nam$w_did
[1];
1599 fib
.fib$w_did
[2] = nam
.nam$w_did
[2];
1600 fib
.fib$l_acctl
= 0;
1602 strcpy (file
.string
, (strrchr (result
.string
, ']') + 1));
1603 filedsc
.dsc$w_length
= strlen (file
.string
);
1604 result
.string
[result
.length
= 0] = 0;
1606 /* Open and close the file to fill in the attributes. */
1608 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1609 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1610 if ((status
& 1) != 1)
1611 LIB$
SIGNAL (status
);
1612 if ((iosb
.status
& 1) != 1)
1613 LIB$
SIGNAL (iosb
.status
);
1615 result
.string
[result
.length
] = 0;
1616 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0, &fibdsc
, 0, 0, 0,
1618 if ((status
& 1) != 1)
1619 LIB$
SIGNAL (status
);
1620 if ((iosb
.status
& 1) != 1)
1621 LIB$
SIGNAL (iosb
.status
);
1626 /* Set creation time to requested time. */
1627 unix_time_to_vms (time_stamp
, newtime
);
1629 t
= time ((time_t) 0);
1631 /* Set revision time to now in local time. */
1632 unix_time_to_vms (t
, revtime
);
1635 /* Reopen the file, modify the times and then close. */
1636 fib
.fib$l_acctl
= FIB$M_WRITE
;
1638 = SYS$
QIOW (0, chan
, IO$_ACCESS
|IO$M_ACCESS
, &iosb
, 0, 0,
1639 &fibdsc
, &filedsc
, &result
.length
, &resultdsc
, &atrlst
, 0);
1640 if ((status
& 1) != 1)
1641 LIB$
SIGNAL (status
);
1642 if ((iosb
.status
& 1) != 1)
1643 LIB$
SIGNAL (iosb
.status
);
1645 Fat
.create
= newtime
;
1646 Fat
.revise
= revtime
;
1648 status
= SYS$
QIOW (0, chan
, IO$_DEACCESS
, &iosb
, 0, 0,
1649 &fibdsc
, 0, 0, 0, &atrlst
, 0);
1650 if ((status
& 1) != 1)
1651 LIB$
SIGNAL (status
);
1652 if ((iosb
.status
& 1) != 1)
1653 LIB$
SIGNAL (iosb
.status
);
1655 /* Deassign the channel and exit. */
1656 status
= SYS$
DASSGN (chan
);
1657 if ((status
& 1) != 1)
1658 LIB$
SIGNAL (status
);
1660 struct utimbuf utimbuf
;
1663 /* Set modification time to requested time. */
1664 utimbuf
.modtime
= time_stamp
;
1666 /* Set access time to now in local time. */
1667 t
= time ((time_t) 0);
1668 utimbuf
.actime
= mktime (localtime (&t
));
1670 utime (name
, &utimbuf
);
1674 /* Get the list of installed standard libraries from the
1675 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1679 __gnat_get_libraries_from_registry (void)
1681 char *result
= (char *) xmalloc (1);
1685 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) \
1689 DWORD name_size
, value_size
;
1696 /* First open the key. */
1697 res
= RegOpenKeyExA (HKEY_LOCAL_MACHINE
, "SOFTWARE", 0, KEY_READ
, ®_key
);
1699 if (res
== ERROR_SUCCESS
)
1700 res
= RegOpenKeyExA (reg_key
, "Ada Core Technologies", 0,
1701 KEY_READ
, ®_key
);
1703 if (res
== ERROR_SUCCESS
)
1704 res
= RegOpenKeyExA (reg_key
, "GNAT", 0, KEY_READ
, ®_key
);
1706 if (res
== ERROR_SUCCESS
)
1707 res
= RegOpenKeyExA (reg_key
, "Standard Libraries", 0, KEY_READ
, ®_key
);
1709 /* If the key exists, read out all the values in it and concatenate them
1711 for (index
= 0; res
== ERROR_SUCCESS
; index
++)
1713 value_size
= name_size
= 256;
1714 res
= RegEnumValueA (reg_key
, index
, name
, &name_size
, 0,
1715 &type
, (LPBYTE
)value
, &value_size
);
1717 if (res
== ERROR_SUCCESS
&& type
== REG_SZ
)
1719 char *old_result
= result
;
1721 result
= (char *) xmalloc (strlen (old_result
) + value_size
+ 2);
1722 strcpy (result
, old_result
);
1723 strcat (result
, value
);
1724 strcat (result
, ";");
1729 /* Remove the trailing ";". */
1731 result
[strlen (result
) - 1] = 0;
1738 __gnat_stat (char *name
, GNAT_STRUCT_STAT
*statbuf
)
1741 WIN32_FILE_ATTRIBUTE_DATA fad
;
1742 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
1747 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
1748 name_len
= _tcslen (wname
);
1750 if (name_len
> GNAT_MAX_PATH_LEN
)
1753 ZeroMemory (statbuf
, sizeof(GNAT_STRUCT_STAT
));
1755 res
= GetFileAttributesEx (wname
, GetFileExInfoStandard
, &fad
);
1758 error
= GetLastError();
1760 /* Check file existence using GetFileAttributes() which does not fail on
1761 special Windows files like con:, aux:, nul: etc... */
1763 if (GetFileAttributes(wname
) != INVALID_FILE_ATTRIBUTES
) {
1764 /* Just pretend that it is a regular and readable file */
1765 statbuf
->st_mode
= S_IFREG
| S_IREAD
| S_IWRITE
;
1770 case ERROR_ACCESS_DENIED
:
1771 case ERROR_SHARING_VIOLATION
:
1772 case ERROR_LOCK_VIOLATION
:
1773 case ERROR_SHARING_BUFFER_EXCEEDED
:
1775 case ERROR_BUFFER_OVERFLOW
:
1776 return ENAMETOOLONG
;
1777 case ERROR_NOT_ENOUGH_MEMORY
:
1784 f2t (&fad
.ftCreationTime
, &statbuf
->st_ctime
);
1785 f2t (&fad
.ftLastWriteTime
, &statbuf
->st_mtime
);
1786 f2t (&fad
.ftLastAccessTime
, &statbuf
->st_atime
);
1788 statbuf
->st_size
= (off_t
)fad
.nFileSizeLow
;
1790 /* We do not have the S_IEXEC attribute, but this is not used on GNAT. */
1791 statbuf
->st_mode
= S_IREAD
;
1793 if (fad
.dwFileAttributes
& FILE_ATTRIBUTE_DIRECTORY
)
1794 statbuf
->st_mode
|= S_IFDIR
;
1796 statbuf
->st_mode
|= S_IFREG
;
1798 if (!(fad
.dwFileAttributes
& FILE_ATTRIBUTE_READONLY
))
1799 statbuf
->st_mode
|= S_IWRITE
;
1804 return GNAT_STAT (name
, statbuf
);
1808 /*************************************************************************
1809 ** Check whether a file exists
1810 *************************************************************************/
1813 __gnat_file_exists_attr (char* name
, struct file_attributes
* attr
)
1815 if (attr
->exists
== ATTR_UNSET
) {
1816 __gnat_stat_to_attr (-1, name
, attr
);
1819 return attr
->exists
;
1823 __gnat_file_exists (char *name
)
1825 struct file_attributes attr
;
1826 __gnat_reset_attributes (&attr
);
1827 return __gnat_file_exists_attr (name
, &attr
);
1830 /**********************************************************************
1831 ** Whether name is an absolute path
1832 **********************************************************************/
1835 __gnat_is_absolute_path (char *name
, int length
)
1838 /* On VxWorks systems, an absolute path can be represented (depending on
1839 the host platform) as either /dir/file, or device:/dir/file, or
1840 device:drive_letter:/dir/file. */
1847 for (index
= 0; index
< length
; index
++)
1849 if (name
[index
] == ':' &&
1850 ((name
[index
+ 1] == '/') ||
1851 (isalpha (name
[index
+ 1]) && index
+ 2 <= length
&&
1852 name
[index
+ 2] == '/')))
1855 else if (name
[index
] == '/')
1860 return (length
!= 0) &&
1861 (*name
== '/' || *name
== DIR_SEPARATOR
1863 || (length
> 1 && ISALPHA (name
[0]) && name
[1] == ':')
1870 __gnat_is_regular_file_attr (char* name
, struct file_attributes
* attr
)
1872 if (attr
->regular
== ATTR_UNSET
) {
1873 __gnat_stat_to_attr (-1, name
, attr
);
1876 return attr
->regular
;
1880 __gnat_is_regular_file (char *name
)
1882 struct file_attributes attr
;
1883 __gnat_reset_attributes (&attr
);
1884 return __gnat_is_regular_file_attr (name
, &attr
);
1888 __gnat_is_directory_attr (char* name
, struct file_attributes
* attr
)
1890 if (attr
->directory
== ATTR_UNSET
) {
1891 __gnat_stat_to_attr (-1, name
, attr
);
1894 return attr
->directory
;
1898 __gnat_is_directory (char *name
)
1900 struct file_attributes attr
;
1901 __gnat_reset_attributes (&attr
);
1902 return __gnat_is_directory_attr (name
, &attr
);
1905 #if defined (_WIN32) && !defined (RTX)
1907 /* Returns the same constant as GetDriveType but takes a pathname as
1911 GetDriveTypeFromPath (TCHAR
*wfullpath
)
1913 TCHAR wdrv
[MAX_PATH
];
1914 TCHAR wpath
[MAX_PATH
];
1915 TCHAR wfilename
[MAX_PATH
];
1916 TCHAR wext
[MAX_PATH
];
1918 _tsplitpath (wfullpath
, wdrv
, wpath
, wfilename
, wext
);
1920 if (_tcslen (wdrv
) != 0)
1922 /* we have a drive specified. */
1923 _tcscat (wdrv
, _T("\\"));
1924 return GetDriveType (wdrv
);
1928 /* No drive specified. */
1930 /* Is this a relative path, if so get current drive type. */
1931 if (wpath
[0] != _T('\\') ||
1932 (_tcslen (wpath
) > 2 && wpath
[0] == _T('\\') && wpath
[1] != _T('\\')))
1933 return GetDriveType (NULL
);
1935 UINT result
= GetDriveType (wpath
);
1937 /* Cannot guess the drive type, is this \\.\ ? */
1939 if (result
== DRIVE_NO_ROOT_DIR
&&
1940 _tcslen (wpath
) >= 4 && wpath
[0] == _T('\\') && wpath
[1] == _T('\\')
1941 && wpath
[2] == _T('.') && wpath
[3] == _T('\\'))
1943 if (_tcslen (wpath
) == 4)
1944 _tcscat (wpath
, wfilename
);
1946 LPTSTR p
= &wpath
[4];
1947 LPTSTR b
= _tcschr (p
, _T('\\'));
1950 { /* logical drive \\.\c\dir\file */
1956 _tcscat (p
, _T(":\\"));
1958 return GetDriveType (p
);
1965 /* This MingW section contains code to work with ACL. */
1967 __gnat_check_OWNER_ACL
1969 DWORD CheckAccessDesired
,
1970 GENERIC_MAPPING CheckGenericMapping
)
1972 DWORD dwAccessDesired
, dwAccessAllowed
;
1973 PRIVILEGE_SET PrivilegeSet
;
1974 DWORD dwPrivSetSize
= sizeof (PRIVILEGE_SET
);
1975 BOOL fAccessGranted
= FALSE
;
1976 HANDLE hToken
= NULL
;
1978 SECURITY_DESCRIPTOR
* pSD
= NULL
;
1981 (wname
, OWNER_SECURITY_INFORMATION
|
1982 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
1985 if ((pSD
= (PSECURITY_DESCRIPTOR
) HeapAlloc
1986 (GetProcessHeap (), HEAP_ZERO_MEMORY
, nLength
)) == NULL
)
1989 /* Obtain the security descriptor. */
1991 if (!GetFileSecurity
1992 (wname
, OWNER_SECURITY_INFORMATION
|
1993 GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION
,
1994 pSD
, nLength
, &nLength
))
1997 if (!ImpersonateSelf (SecurityImpersonation
))
2000 if (!OpenThreadToken
2001 (GetCurrentThread(), TOKEN_DUPLICATE
| TOKEN_QUERY
, FALSE
, &hToken
))
2004 /* Undoes the effect of ImpersonateSelf. */
2008 /* We want to test for write permissions. */
2010 dwAccessDesired
= CheckAccessDesired
;
2012 MapGenericMask (&dwAccessDesired
, &CheckGenericMapping
);
2015 (pSD
, /* security descriptor to check */
2016 hToken
, /* impersonation token */
2017 dwAccessDesired
, /* requested access rights */
2018 &CheckGenericMapping
, /* pointer to GENERIC_MAPPING */
2019 &PrivilegeSet
, /* receives privileges used in check */
2020 &dwPrivSetSize
, /* size of PrivilegeSet buffer */
2021 &dwAccessAllowed
, /* receives mask of allowed access rights */
2025 CloseHandle (hToken
);
2026 HeapFree (GetProcessHeap (), 0, pSD
);
2027 return fAccessGranted
;
2031 CloseHandle (hToken
);
2032 HeapFree (GetProcessHeap (), 0, pSD
);
2037 __gnat_set_OWNER_ACL
2040 DWORD AccessPermissions
)
2042 PACL pOldDACL
= NULL
;
2043 PACL pNewDACL
= NULL
;
2044 PSECURITY_DESCRIPTOR pSD
= NULL
;
2046 TCHAR username
[100];
2049 /* Get current user, he will act as the owner */
2051 if (!GetUserName (username
, &unsize
))
2054 if (GetNamedSecurityInfo
2057 DACL_SECURITY_INFORMATION
,
2058 NULL
, NULL
, &pOldDACL
, NULL
, &pSD
) != ERROR_SUCCESS
)
2061 BuildExplicitAccessWithName
2062 (&ea
, username
, AccessPermissions
, AccessMode
, NO_INHERITANCE
);
2064 if (AccessMode
== SET_ACCESS
)
2066 /* SET_ACCESS, we want to set an explicte set of permissions, do not
2067 merge with current DACL. */
2068 if (SetEntriesInAcl (1, &ea
, NULL
, &pNewDACL
) != ERROR_SUCCESS
)
2072 if (SetEntriesInAcl (1, &ea
, pOldDACL
, &pNewDACL
) != ERROR_SUCCESS
)
2075 if (SetNamedSecurityInfo
2076 (wname
, SE_FILE_OBJECT
,
2077 DACL_SECURITY_INFORMATION
, NULL
, NULL
, pNewDACL
, NULL
) != ERROR_SUCCESS
)
2081 LocalFree (pNewDACL
);
2084 /* Check if it is possible to use ACL for wname, the file must not be on a
2088 __gnat_can_use_acl (TCHAR
*wname
)
2090 return __gnat_use_acl
&& GetDriveTypeFromPath (wname
) != DRIVE_REMOTE
;
2093 #endif /* defined (_WIN32) && !defined (RTX) */
2096 __gnat_is_readable_file_attr (char* name
, struct file_attributes
* attr
)
2098 if (attr
->readable
== ATTR_UNSET
) {
2099 #if defined (_WIN32) && !defined (RTX)
2100 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2101 GENERIC_MAPPING GenericMapping
;
2103 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2105 if (__gnat_can_use_acl (wname
))
2107 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2108 GenericMapping
.GenericRead
= GENERIC_READ
;
2110 __gnat_check_OWNER_ACL (wname
, FILE_READ_DATA
, GenericMapping
);
2113 attr
->readable
= GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
;
2115 __gnat_stat_to_attr (-1, name
, attr
);
2119 return attr
->readable
;
2123 __gnat_is_readable_file (char *name
)
2125 struct file_attributes attr
;
2126 __gnat_reset_attributes (&attr
);
2127 return __gnat_is_readable_file_attr (name
, &attr
);
2131 __gnat_is_writable_file_attr (char* name
, struct file_attributes
* attr
)
2133 if (attr
->writable
== ATTR_UNSET
) {
2134 #if defined (_WIN32) && !defined (RTX)
2135 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2136 GENERIC_MAPPING GenericMapping
;
2138 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2140 if (__gnat_can_use_acl (wname
))
2142 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2143 GenericMapping
.GenericWrite
= GENERIC_WRITE
;
2145 attr
->writable
= __gnat_check_OWNER_ACL
2146 (wname
, FILE_WRITE_DATA
| FILE_APPEND_DATA
, GenericMapping
)
2147 && !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2150 attr
->writable
= !(GetFileAttributes (wname
) & FILE_ATTRIBUTE_READONLY
);
2153 __gnat_stat_to_attr (-1, name
, attr
);
2157 return attr
->writable
;
2161 __gnat_is_writable_file (char *name
)
2163 struct file_attributes attr
;
2164 __gnat_reset_attributes (&attr
);
2165 return __gnat_is_writable_file_attr (name
, &attr
);
2169 __gnat_is_executable_file_attr (char* name
, struct file_attributes
* attr
)
2171 if (attr
->executable
== ATTR_UNSET
) {
2172 #if defined (_WIN32) && !defined (RTX)
2173 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2174 GENERIC_MAPPING GenericMapping
;
2176 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2178 if (__gnat_can_use_acl (wname
))
2180 ZeroMemory (&GenericMapping
, sizeof (GENERIC_MAPPING
));
2181 GenericMapping
.GenericExecute
= GENERIC_EXECUTE
;
2184 __gnat_check_OWNER_ACL (wname
, FILE_EXECUTE
, GenericMapping
);
2188 TCHAR
*l
, *last
= _tcsstr(wname
, _T(".exe"));
2190 /* look for last .exe */
2192 while ((l
= _tcsstr(last
+1, _T(".exe")))) last
= l
;
2194 attr
->executable
= GetFileAttributes (wname
) != INVALID_FILE_ATTRIBUTES
2195 && (last
- wname
) == (int) (_tcslen (wname
) - 4);
2198 __gnat_stat_to_attr (-1, name
, attr
);
2202 return attr
->executable
;
2206 __gnat_is_executable_file (char *name
)
2208 struct file_attributes attr
;
2209 __gnat_reset_attributes (&attr
);
2210 return __gnat_is_executable_file_attr (name
, &attr
);
2214 __gnat_set_writable (char *name
)
2216 #if defined (_WIN32) && !defined (RTX)
2217 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2219 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2221 if (__gnat_can_use_acl (wname
))
2222 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_WRITE
);
2225 (wname
, GetFileAttributes (wname
) & ~FILE_ATTRIBUTE_READONLY
);
2226 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2227 ! defined(__nucleus__)
2228 GNAT_STRUCT_STAT statbuf
;
2230 if (GNAT_STAT (name
, &statbuf
) == 0)
2232 statbuf
.st_mode
= statbuf
.st_mode
| S_IWUSR
;
2233 chmod (name
, statbuf
.st_mode
);
2239 __gnat_set_executable (char *name
)
2241 #if defined (_WIN32) && !defined (RTX)
2242 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2244 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2246 if (__gnat_can_use_acl (wname
))
2247 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_EXECUTE
);
2249 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2250 ! defined(__nucleus__)
2251 GNAT_STRUCT_STAT statbuf
;
2253 if (GNAT_STAT (name
, &statbuf
) == 0)
2255 statbuf
.st_mode
= statbuf
.st_mode
| S_IXUSR
;
2256 chmod (name
, statbuf
.st_mode
);
2262 __gnat_set_non_writable (char *name
)
2264 #if defined (_WIN32) && !defined (RTX)
2265 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2267 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2269 if (__gnat_can_use_acl (wname
))
2270 __gnat_set_OWNER_ACL
2271 (wname
, DENY_ACCESS
,
2272 FILE_WRITE_DATA
| FILE_APPEND_DATA
|
2273 FILE_WRITE_EA
| FILE_WRITE_ATTRIBUTES
);
2276 (wname
, GetFileAttributes (wname
) | FILE_ATTRIBUTE_READONLY
);
2277 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2278 ! defined(__nucleus__)
2279 GNAT_STRUCT_STAT statbuf
;
2281 if (GNAT_STAT (name
, &statbuf
) == 0)
2283 statbuf
.st_mode
= statbuf
.st_mode
& 07577;
2284 chmod (name
, statbuf
.st_mode
);
2290 __gnat_set_readable (char *name
)
2292 #if defined (_WIN32) && !defined (RTX)
2293 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2295 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2297 if (__gnat_can_use_acl (wname
))
2298 __gnat_set_OWNER_ACL (wname
, GRANT_ACCESS
, FILE_GENERIC_READ
);
2300 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2301 ! defined(__nucleus__)
2302 GNAT_STRUCT_STAT statbuf
;
2304 if (GNAT_STAT (name
, &statbuf
) == 0)
2306 chmod (name
, statbuf
.st_mode
| S_IREAD
);
2312 __gnat_set_non_readable (char *name
)
2314 #if defined (_WIN32) && !defined (RTX)
2315 TCHAR wname
[GNAT_MAX_PATH_LEN
+ 2];
2317 S2WSC (wname
, name
, GNAT_MAX_PATH_LEN
+ 2);
2319 if (__gnat_can_use_acl (wname
))
2320 __gnat_set_OWNER_ACL (wname
, DENY_ACCESS
, FILE_GENERIC_READ
);
2322 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2323 ! defined(__nucleus__)
2324 GNAT_STRUCT_STAT statbuf
;
2326 if (GNAT_STAT (name
, &statbuf
) == 0)
2328 chmod (name
, statbuf
.st_mode
& (~S_IREAD
));
2334 __gnat_is_symbolic_link_attr (char* name ATTRIBUTE_UNUSED
,
2335 struct file_attributes
* attr
)
2337 if (attr
->symbolic_link
== ATTR_UNSET
) {
2338 #if defined (__vxworks) || defined (__nucleus__)
2339 attr
->symbolic_link
= 0;
2341 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
2343 GNAT_STRUCT_STAT statbuf
;
2344 ret
= GNAT_LSTAT (name
, &statbuf
);
2345 attr
->symbolic_link
= (!ret
&& S_ISLNK (statbuf
.st_mode
));
2347 attr
->symbolic_link
= 0;
2350 return attr
->symbolic_link
;
2354 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED
)
2356 struct file_attributes attr
;
2357 __gnat_reset_attributes (&attr
);
2358 return __gnat_is_symbolic_link_attr (name
, &attr
);
2362 #if defined (sun) && defined (__SVR4)
2363 /* Using fork on Solaris will duplicate all the threads. fork1, which
2364 duplicates only the active thread, must be used instead, or spawning
2365 subprocess from a program with tasking will lead into numerous problems. */
2370 __gnat_portable_spawn (char *args
[])
2373 int finished ATTRIBUTE_UNUSED
;
2374 int pid ATTRIBUTE_UNUSED
;
2376 #if defined (__vxworks) || defined(__nucleus__) || defined(RTX)
2379 #elif defined (_WIN32)
2380 /* args[0] must be quotes as it could contain a full pathname with spaces */
2381 char *args_0
= args
[0];
2382 args
[0] = (char *)xmalloc (strlen (args_0
) + 3);
2383 strcpy (args
[0], "\"");
2384 strcat (args
[0], args_0
);
2385 strcat (args
[0], "\"");
2387 status
= spawnvp (P_WAIT
, args_0
, (const char* const*)args
);
2389 /* restore previous value */
2391 args
[0] = (char *)args_0
;
2407 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2409 return -1; /* execv is in parent context on VMS. */
2416 finished
= waitpid (pid
, &status
, 0);
2418 if (finished
!= pid
|| WIFEXITED (status
) == 0)
2421 return WEXITSTATUS (status
);
2427 /* Create a copy of the given file descriptor.
2428 Return -1 if an error occurred. */
2431 __gnat_dup (int oldfd
)
2433 #if defined (__vxworks) && !defined (__RTP__)
2434 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2442 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
2443 Return -1 if an error occurred. */
2446 __gnat_dup2 (int oldfd
, int newfd
)
2448 #if defined (__vxworks) && !defined (__RTP__)
2449 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2452 #elif defined (_WIN32)
2453 /* Special case when oldfd and newfd are identical and are the standard
2454 input, output or error as this makes Windows XP hangs. Note that we
2455 do that only for standard file descriptors that are known to be valid. */
2456 if (oldfd
== newfd
&& newfd
>= 0 && newfd
<= 2)
2459 return dup2 (oldfd
, newfd
);
2461 return dup2 (oldfd
, newfd
);
2466 __gnat_number_of_cpus (void)
2470 #if defined (linux) || defined (sun) || defined (AIX) || defined (__APPLE__)
2471 cores
= (int) sysconf (_SC_NPROCESSORS_ONLN
);
2473 #elif defined (__hpux__)
2474 struct pst_dynamic psd
;
2475 if (pstat_getdynamic (&psd
, sizeof (psd
), 1, 0) != -1)
2476 cores
= (int) psd
.psd_proc_cnt
;
2478 #elif defined (_WIN32)
2479 SYSTEM_INFO sysinfo
;
2480 GetSystemInfo (&sysinfo
);
2481 cores
= (int) sysinfo
.dwNumberOfProcessors
;
2484 int code
= SYI$_ACTIVECPU_CNT
;
2488 status
= LIB$
GETSYI (&code
, &res
);
2489 if ((status
& 1) != 0)
2492 #elif defined (_WRS_CONFIG_SMP)
2493 unsigned int vxCpuConfiguredGet (void);
2495 cores
= vxCpuConfiguredGet ();
2502 /* WIN32 code to implement a wait call that wait for any child process. */
2504 #if defined (_WIN32) && !defined (RTX)
2506 /* Synchronization code, to be thread safe. */
2510 /* For the Cert run times on native Windows we use dummy functions
2511 for locking and unlocking tasks since we do not support multiple
2512 threads on this configuration (Cert run time on native Windows). */
2514 void dummy (void) {}
2516 void (*Lock_Task
) () = &dummy
;
2517 void (*Unlock_Task
) () = &dummy
;
2521 #define Lock_Task system__soft_links__lock_task
2522 extern void (*Lock_Task
) (void);
2524 #define Unlock_Task system__soft_links__unlock_task
2525 extern void (*Unlock_Task
) (void);
2529 static HANDLE
*HANDLES_LIST
= NULL
;
2530 static int *PID_LIST
= NULL
, plist_length
= 0, plist_max_length
= 0;
2533 add_handle (HANDLE h
, int pid
)
2536 /* -------------------- critical section -------------------- */
2539 if (plist_length
== plist_max_length
)
2541 plist_max_length
+= 1000;
2543 xrealloc (HANDLES_LIST
, sizeof (HANDLE
) * plist_max_length
);
2545 xrealloc (PID_LIST
, sizeof (int) * plist_max_length
);
2548 HANDLES_LIST
[plist_length
] = h
;
2549 PID_LIST
[plist_length
] = pid
;
2553 /* -------------------- critical section -------------------- */
2557 __gnat_win32_remove_handle (HANDLE h
, int pid
)
2561 /* -------------------- critical section -------------------- */
2564 for (j
= 0; j
< plist_length
; j
++)
2566 if ((HANDLES_LIST
[j
] == h
) || (PID_LIST
[j
] == pid
))
2570 HANDLES_LIST
[j
] = HANDLES_LIST
[plist_length
];
2571 PID_LIST
[j
] = PID_LIST
[plist_length
];
2577 /* -------------------- critical section -------------------- */
2581 win32_no_block_spawn (char *command
, char *args
[], HANDLE
*h
, int *pid
)
2585 PROCESS_INFORMATION PI
;
2586 SECURITY_ATTRIBUTES SA
;
2591 /* compute the total command line length */
2595 csize
+= strlen (args
[k
]) + 1;
2599 full_command
= (char *) xmalloc (csize
);
2602 SI
.cb
= sizeof (STARTUPINFO
);
2603 SI
.lpReserved
= NULL
;
2604 SI
.lpReserved2
= NULL
;
2605 SI
.lpDesktop
= NULL
;
2609 SI
.wShowWindow
= SW_HIDE
;
2611 /* Security attributes. */
2612 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
2613 SA
.bInheritHandle
= TRUE
;
2614 SA
.lpSecurityDescriptor
= NULL
;
2616 /* Prepare the command string. */
2617 strcpy (full_command
, command
);
2618 strcat (full_command
, " ");
2623 strcat (full_command
, args
[k
]);
2624 strcat (full_command
, " ");
2629 int wsize
= csize
* 2;
2630 TCHAR
*wcommand
= (TCHAR
*) xmalloc (wsize
);
2632 S2WSC (wcommand
, full_command
, wsize
);
2634 free (full_command
);
2636 result
= CreateProcess
2637 (NULL
, wcommand
, &SA
, NULL
, TRUE
,
2638 GetPriorityClass (GetCurrentProcess()), NULL
, NULL
, &SI
, &PI
);
2645 CloseHandle (PI
.hThread
);
2647 *pid
= PI
.dwProcessId
;
2657 win32_wait (int *status
)
2659 DWORD exitcode
, pid
;
2666 if (plist_length
== 0)
2674 /* -------------------- critical section -------------------- */
2677 hl_len
= plist_length
;
2679 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * hl_len
);
2681 memmove (hl
, HANDLES_LIST
, sizeof (HANDLE
) * hl_len
);
2684 /* -------------------- critical section -------------------- */
2686 res
= WaitForMultipleObjects (hl_len
, hl
, FALSE
, INFINITE
);
2687 h
= hl
[res
- WAIT_OBJECT_0
];
2689 GetExitCodeProcess (h
, &exitcode
);
2690 pid
= PID_LIST
[res
- WAIT_OBJECT_0
];
2691 __gnat_win32_remove_handle (h
, -1);
2695 *status
= (int) exitcode
;
2702 __gnat_portable_no_block_spawn (char *args
[])
2705 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2708 #elif defined (_WIN32)
2713 win32_no_block_spawn (args
[0], args
, &h
, &pid
);
2716 add_handle (h
, pid
);
2729 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2731 return -1; /* execv is in parent context on VMS. */
2743 __gnat_portable_wait (int *process_status
)
2748 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2749 /* Not sure what to do here, so do nothing but return zero. */
2751 #elif defined (_WIN32)
2753 pid
= win32_wait (&status
);
2757 pid
= waitpid (-1, &status
, 0);
2758 status
= status
& 0xffff;
2761 *process_status
= status
;
2766 __gnat_os_exit (int status
)
2771 /* Locate file on path, that matches a predicate */
2774 __gnat_locate_file_with_predicate
2775 (char *file_name
, char *path_val
, int (*predicate
)(char*))
2778 char *file_path
= (char *) alloca (strlen (file_name
) + 1);
2781 /* Return immediately if file_name is empty */
2783 if (*file_name
== '\0')
2786 /* Remove quotes around file_name if present */
2792 strcpy (file_path
, ptr
);
2794 ptr
= file_path
+ strlen (file_path
) - 1;
2799 /* Handle absolute pathnames. */
2801 absolute
= __gnat_is_absolute_path (file_path
, strlen (file_name
));
2805 if (predicate (file_path
))
2806 return xstrdup (file_path
);
2811 /* If file_name include directory separator(s), try it first as
2812 a path name relative to the current directory */
2813 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
2818 if (predicate (file_name
))
2819 return xstrdup (file_name
);
2826 /* The result has to be smaller than path_val + file_name. */
2828 (char *) alloca (strlen (path_val
) + strlen (file_name
) + 2);
2832 /* Skip the starting quote */
2834 if (*path_val
== '"')
2837 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
2838 *ptr
++ = *path_val
++;
2840 /* If directory is empty, it is the current directory*/
2842 if (ptr
== file_path
)
2849 /* Skip the ending quote */
2854 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
2855 *++ptr
= DIR_SEPARATOR
;
2857 strcpy (++ptr
, file_name
);
2859 if (predicate (file_path
))
2860 return xstrdup (file_path
);
2865 /* Skip path separator */
2874 /* Locate an executable file, give a Path value. */
2877 __gnat_locate_executable_file (char *file_name
, char *path_val
)
2879 return __gnat_locate_file_with_predicate
2880 (file_name
, path_val
, &__gnat_is_executable_file
);
2883 /* Locate a regular file, give a Path value. */
2886 __gnat_locate_regular_file (char *file_name
, char *path_val
)
2888 return __gnat_locate_file_with_predicate
2889 (file_name
, path_val
, &__gnat_is_regular_file
);
2892 /* Locate an executable given a Path argument. This routine is only used by
2893 gnatbl and should not be used otherwise. Use locate_exec_on_path
2897 __gnat_locate_exec (char *exec_name
, char *path_val
)
2900 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
2902 char *full_exec_name
=
2904 (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
2906 strcpy (full_exec_name
, exec_name
);
2907 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
2908 ptr
= __gnat_locate_executable_file (full_exec_name
, path_val
);
2911 return __gnat_locate_executable_file (exec_name
, path_val
);
2915 return __gnat_locate_executable_file (exec_name
, path_val
);
2918 /* Locate an executable using the Systems default PATH. */
2921 __gnat_locate_exec_on_path (char *exec_name
)
2925 #if defined (_WIN32) && !defined (RTX)
2926 TCHAR
*wpath_val
= _tgetenv (_T("PATH"));
2928 /* In Win32 systems we expand the PATH as for XP environment
2929 variables are not automatically expanded. We also prepend the
2930 ".;" to the path to match normal NT path search semantics */
2932 #define EXPAND_BUFFER_SIZE 32767
2934 wapath_val
= alloca (EXPAND_BUFFER_SIZE
);
2936 wapath_val
[0] = '.';
2937 wapath_val
[1] = ';';
2939 DWORD res
= ExpandEnvironmentStrings
2940 (wpath_val
, &wapath_val
[2], EXPAND_BUFFER_SIZE
- 2);
2942 if (!res
) wapath_val
[0] = _T('\0');
2944 apath_val
= alloca (EXPAND_BUFFER_SIZE
);
2946 WS2SC (apath_val
, wapath_val
, EXPAND_BUFFER_SIZE
);
2947 return __gnat_locate_exec (exec_name
, apath_val
);
2952 char *path_val
= "/VAXC$PATH";
2954 char *path_val
= getenv ("PATH");
2956 if (path_val
== NULL
) return NULL
;
2957 apath_val
= (char *) alloca (strlen (path_val
) + 1);
2958 strcpy (apath_val
, path_val
);
2959 return __gnat_locate_exec (exec_name
, apath_val
);
2965 /* These functions are used to translate to and from VMS and Unix syntax
2966 file, directory and path specifications. */
2969 #define MAXNAMES 256
2970 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2972 static char new_canonical_dirspec
[MAXPATH
];
2973 static char new_canonical_filespec
[MAXPATH
];
2974 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
2975 static unsigned new_canonical_filelist_index
;
2976 static unsigned new_canonical_filelist_in_use
;
2977 static unsigned new_canonical_filelist_allocated
;
2978 static char **new_canonical_filelist
;
2979 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
2980 static char new_host_dirspec
[MAXPATH
];
2981 static char new_host_filespec
[MAXPATH
];
2983 /* Routine is called repeatedly by decc$from_vms via
2984 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2988 wildcard_translate_unix (char *name
)
2991 char buff
[MAXPATH
];
2993 strncpy (buff
, name
, MAXPATH
);
2994 buff
[MAXPATH
- 1] = (char) 0;
2995 ver
= strrchr (buff
, '.');
2997 /* Chop off the version. */
3001 /* Dynamically extend the allocation by the increment. */
3002 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
3004 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
3005 new_canonical_filelist
= (char **) xrealloc
3006 (new_canonical_filelist
,
3007 new_canonical_filelist_allocated
* sizeof (char *));
3010 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
3015 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
3016 full translation and copy the results into a list (_init), then return them
3017 one at a time (_next). If onlydirs set, only expand directory files. */
3020 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
3023 char buff
[MAXPATH
];
3025 len
= strlen (filespec
);
3026 strncpy (buff
, filespec
, MAXPATH
);
3028 /* Only look for directories */
3029 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
3030 strncat (buff
, "*.dir", MAXPATH
);
3032 buff
[MAXPATH
- 1] = (char) 0;
3034 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
3036 /* Remove the .dir extension. */
3042 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3044 ext
= strstr (new_canonical_filelist
[i
], ".dir");
3050 return new_canonical_filelist_in_use
;
3053 /* Return the next filespec in the list. */
3056 __gnat_to_canonical_file_list_next ()
3058 return new_canonical_filelist
[new_canonical_filelist_index
++];
3061 /* Free storage used in the wildcard expansion. */
3064 __gnat_to_canonical_file_list_free ()
3068 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3069 free (new_canonical_filelist
[i
]);
3071 free (new_canonical_filelist
);
3073 new_canonical_filelist_in_use
= 0;
3074 new_canonical_filelist_allocated
= 0;
3075 new_canonical_filelist_index
= 0;
3076 new_canonical_filelist
= 0;
3079 /* The functional equivalent of decc$translate_vms routine.
3080 Designed to produce the same output, but is protected against
3081 malformed paths (original version ACCVIOs in this case) and
3082 does not require VMS-specific DECC RTL */
3084 #define NAM$C_MAXRSS 1024
3087 __gnat_translate_vms (char *src
)
3089 static char retbuf
[NAM$C_MAXRSS
+ 1];
3090 char *srcendpos
, *pos1
, *pos2
, *retpos
;
3091 int disp
, path_present
= 0;
3096 srcendpos
= strchr (src
, '\0');
3099 /* Look for the node and/or device in front of the path */
3101 pos2
= strchr (pos1
, ':');
3103 if (pos2
&& (pos2
< srcendpos
) && (*(pos2
+ 1) == ':'))
3105 /* There is a node name. "node_name::" becomes "node_name!" */
3107 strncpy (retbuf
, pos1
, disp
);
3108 retpos
[disp
] = '!';
3109 retpos
= retpos
+ disp
+ 1;
3111 pos2
= strchr (pos1
, ':');
3116 /* There is a device name. "dev_name:" becomes "/dev_name/" */
3119 strncpy (retpos
, pos1
, disp
);
3120 retpos
= retpos
+ disp
;
3125 /* No explicit device; we must look ahead and prepend /sys$disk/ if
3126 the path is absolute */
3127 if ((*pos1
== '[' || *pos1
== '<') && (pos1
< srcendpos
)
3128 && !strchr (".-]>", *(pos1
+ 1)))
3130 strncpy (retpos
, "/sys$disk/", 10);
3134 /* Process the path part */
3135 while (*pos1
== '[' || *pos1
== '<')
3139 if (*pos1
== ']' || *pos1
== '>')
3141 /* Special case, [] translates to '.' */
3147 /* '[000000' means root dir. It can be present in the middle of
3148 the path due to expansion of logical devices, in which case
3150 if (!strncmp (pos1
, "000000", 6) && path_present
> 1 &&
3151 (*(pos1
+ 6) == ']' || *(pos1
+ 6) == '>' || *(pos1
+ 6) == '.'))
3154 if (*pos1
== '.') pos1
++;
3156 else if (*pos1
== '.')
3162 /* There is a qualified path */
3163 while (*pos1
&& *pos1
!= ']' && *pos1
!= '>')
3168 /* '.' is used to separate directories. Replace it with '/' but
3169 only if there isn't already '/' just before */
3170 if (*(retpos
- 1) != '/')
3173 if (pos1
+ 1 < srcendpos
&& *pos1
== '.' && *(pos1
+ 1) == '.')
3175 /* ellipsis refers to entire subtree; replace with '**' */
3183 /* When after '.' '[' '<' is equivalent to Unix ".." but there
3184 may be several in a row */
3185 if (*(pos1
- 1) == '.' || *(pos1
- 1) == '[' ||
3188 while (*pos1
== '-')
3198 /* otherwise fall through to default */
3200 *(retpos
++) = *(pos1
++);
3207 if (pos1
< srcendpos
)
3209 /* Now add the actual file name, until the version suffix if any */
3212 pos2
= strchr (pos1
, ';');
3213 disp
= pos2
? (pos2
- pos1
) : (srcendpos
- pos1
);
3214 strncpy (retpos
, pos1
, disp
);
3216 if (pos2
&& pos2
< srcendpos
)
3218 /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
3220 disp
= srcendpos
- pos2
- 1;
3221 strncpy (retpos
, pos2
+ 1, disp
);
3231 /* Translate a VMS syntax directory specification in to Unix syntax. If
3232 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
3233 found, return input string. Also translate a dirname that contains no
3234 slashes, in case it's a logical name. */
3237 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
3241 strcpy (new_canonical_dirspec
, "");
3242 if (strlen (dirspec
))
3246 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
3248 strncpy (new_canonical_dirspec
,
3249 __gnat_translate_vms (dirspec
),
3252 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
3254 strncpy (new_canonical_dirspec
,
3255 __gnat_translate_vms (dirspec1
),
3260 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
3264 len
= strlen (new_canonical_dirspec
);
3265 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
3266 strncat (new_canonical_dirspec
, "/", MAXPATH
);
3268 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
3270 return new_canonical_dirspec
;
3274 /* Translate a VMS syntax file specification into Unix syntax.
3275 If no indicators of VMS syntax found, check if it's an uppercase
3276 alphanumeric_ name and if so try it out as an environment
3277 variable (logical name). If all else fails return the
3281 __gnat_to_canonical_file_spec (char *filespec
)
3285 strncpy (new_canonical_filespec
, "", MAXPATH
);
3287 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3289 char *tspec
= (char *) __gnat_translate_vms (filespec
);
3291 if (tspec
!= (char *) -1)
3292 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3294 else if ((strlen (filespec
) == strspn (filespec
,
3295 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
3296 && (filespec1
= getenv (filespec
)))
3298 char *tspec
= (char *) __gnat_translate_vms (filespec1
);
3300 if (tspec
!= (char *) -1)
3301 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3305 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
3308 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
3310 return new_canonical_filespec
;
3313 /* Translate a VMS syntax path specification into Unix syntax.
3314 If no indicators of VMS syntax found, return input string. */
3317 __gnat_to_canonical_path_spec (char *pathspec
)
3319 char *curr
, *next
, buff
[MAXPATH
];
3324 /* If there are /'s, assume it's a Unix path spec and return. */
3325 if (strchr (pathspec
, '/'))
3328 new_canonical_pathspec
[0] = 0;
3333 next
= strchr (curr
, ',');
3335 next
= strchr (curr
, 0);
3337 strncpy (buff
, curr
, next
- curr
);
3338 buff
[next
- curr
] = 0;
3340 /* Check for wildcards and expand if present. */
3341 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
3345 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
3346 for (i
= 0; i
< dirs
; i
++)
3350 next_dir
= __gnat_to_canonical_file_list_next ();
3351 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
3353 /* Don't append the separator after the last expansion. */
3355 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3358 __gnat_to_canonical_file_list_free ();
3361 strncat (new_canonical_pathspec
,
3362 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
3367 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3371 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
3373 return new_canonical_pathspec
;
3376 static char filename_buff
[MAXPATH
];
3379 translate_unix (char *name
, int type ATTRIBUTE_UNUSED
)
3381 strncpy (filename_buff
, name
, MAXPATH
);
3382 filename_buff
[MAXPATH
- 1] = (char) 0;
3386 /* Translate a Unix syntax directory specification into VMS syntax. The
3387 PREFIXFLAG has no effect, but is kept for symmetry with
3388 to_canonical_dir_spec. If indicators of VMS syntax found, return input
3392 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3394 int len
= strlen (dirspec
);
3396 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
3397 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3399 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
3400 return new_host_dirspec
;
3402 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
3404 new_host_dirspec
[len
- 1] = 0;
3408 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
3409 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
3410 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3412 return new_host_dirspec
;
3415 /* Translate a Unix syntax file specification into VMS syntax.
3416 If indicators of VMS syntax found, return input string. */
3419 __gnat_to_host_file_spec (char *filespec
)
3421 strncpy (new_host_filespec
, "", MAXPATH
);
3422 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3424 strncpy (new_host_filespec
, filespec
, MAXPATH
);
3428 decc$
to_vms (filespec
, translate_unix
, 1, 1);
3429 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
3432 new_host_filespec
[MAXPATH
- 1] = (char) 0;
3434 return new_host_filespec
;
3438 __gnat_adjust_os_resource_limits ()
3440 SYS$
ADJWSL (131072, 0);
3445 /* Dummy functions for Osint import for non-VMS systems. */
3448 __gnat_to_canonical_file_list_init
3449 (char *dirspec ATTRIBUTE_UNUSED
, int onlydirs ATTRIBUTE_UNUSED
)
3455 __gnat_to_canonical_file_list_next (void)
3457 static char empty
[] = "";
3462 __gnat_to_canonical_file_list_free (void)
3467 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3473 __gnat_to_canonical_file_spec (char *filespec
)
3479 __gnat_to_canonical_path_spec (char *pathspec
)
3485 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3491 __gnat_to_host_file_spec (char *filespec
)
3497 __gnat_adjust_os_resource_limits (void)
3503 #if defined (__mips_vxworks)
3507 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
3511 #if defined (IS_CROSS) \
3512 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3513 && defined (__SVR4)) \
3514 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3515 && ! (defined (linux) && defined (__ia64__)) \
3516 && ! (defined (linux) && defined (powerpc)) \
3517 && ! defined (__FreeBSD__) \
3518 && ! defined (__Lynx__) \
3519 && ! defined (__hpux__) \
3520 && ! defined (__APPLE__) \
3521 && ! defined (_AIX) \
3522 && ! defined (VMS) \
3523 && ! defined (__MINGW32__))
3525 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3526 just above for a list of native platforms that provide a non-dummy
3527 version of this procedure in libaddr2line.a. */
3530 convert_addresses (const char *file_name ATTRIBUTE_UNUSED
,
3531 void *addrs ATTRIBUTE_UNUSED
,
3532 int n_addr ATTRIBUTE_UNUSED
,
3533 void *buf ATTRIBUTE_UNUSED
,
3534 int *len ATTRIBUTE_UNUSED
)
3540 #if defined (_WIN32)
3541 int __gnat_argument_needs_quote
= 1;
3543 int __gnat_argument_needs_quote
= 0;
3546 /* This option is used to enable/disable object files handling from the
3547 binder file by the GNAT Project module. For example, this is disabled on
3548 Windows (prior to GCC 3.4) as it is already done by the mdll module.
3549 Stating with GCC 3.4 the shared libraries are not based on mdll
3550 anymore as it uses the GCC's -shared option */
3551 #if defined (_WIN32) \
3552 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3553 int __gnat_prj_add_obj_files
= 0;
3555 int __gnat_prj_add_obj_files
= 1;
3558 /* char used as prefix/suffix for environment variables */
3559 #if defined (_WIN32)
3560 char __gnat_environment_char
= '%';
3562 char __gnat_environment_char
= '$';
3565 /* This functions copy the file attributes from a source file to a
3568 mode = 0 : In this mode copy only the file time stamps (last access and
3569 last modification time stamps).
3571 mode = 1 : In this mode, time stamps and read/write/execute attributes are
3574 Returns 0 if operation was successful and -1 in case of error. */
3577 __gnat_copy_attribs (char *from ATTRIBUTE_UNUSED
, char *to ATTRIBUTE_UNUSED
,
3578 int mode ATTRIBUTE_UNUSED
)
3580 #if defined (VMS) || (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \
3581 defined (__nucleus__)
3584 #elif defined (_WIN32) && !defined (RTX)
3585 TCHAR wfrom
[GNAT_MAX_PATH_LEN
+ 2];
3586 TCHAR wto
[GNAT_MAX_PATH_LEN
+ 2];
3588 FILETIME fct
, flat
, flwt
;
3591 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
+ 2);
3592 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
+ 2);
3594 /* retrieve from times */
3597 (wfrom
, GENERIC_READ
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3599 if (hfrom
== INVALID_HANDLE_VALUE
)
3602 res
= GetFileTime (hfrom
, &fct
, &flat
, &flwt
);
3604 CloseHandle (hfrom
);
3609 /* retrieve from times */
3612 (wto
, GENERIC_WRITE
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3614 if (hto
== INVALID_HANDLE_VALUE
)
3617 res
= SetFileTime (hto
, NULL
, &flat
, &flwt
);
3624 /* Set file attributes in full mode. */
3628 DWORD attribs
= GetFileAttributes (wfrom
);
3630 if (attribs
== INVALID_FILE_ATTRIBUTES
)
3633 res
= SetFileAttributes (wto
, attribs
);
3641 GNAT_STRUCT_STAT fbuf
;
3642 struct utimbuf tbuf
;
3644 if (GNAT_STAT (from
, &fbuf
) == -1)
3649 tbuf
.actime
= fbuf
.st_atime
;
3650 tbuf
.modtime
= fbuf
.st_mtime
;
3652 if (utime (to
, &tbuf
) == -1)
3659 if (chmod (to
, fbuf
.st_mode
) == -1)
3670 __gnat_lseek (int fd
, long offset
, int whence
)
3672 return (int) lseek (fd
, offset
, whence
);
3675 /* This function returns the major version number of GCC being used. */
3677 get_gcc_version (void)
3682 return (int) (version_string
[0] - '0');
3687 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED
,
3688 int close_on_exec_p ATTRIBUTE_UNUSED
)
3690 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3691 int flags
= fcntl (fd
, F_GETFD
, 0);
3694 if (close_on_exec_p
)
3695 flags
|= FD_CLOEXEC
;
3697 flags
&= ~FD_CLOEXEC
;
3698 return fcntl (fd
, F_SETFD
, flags
| FD_CLOEXEC
);
3699 #elif defined(_WIN32)
3700 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
3701 if (h
== (HANDLE
) -1)
3703 if (close_on_exec_p
)
3704 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
, 0);
3705 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
,
3706 HANDLE_FLAG_INHERIT
);
3708 /* TODO: Unimplemented. */
3713 /* Indicates if platforms supports automatic initialization through the
3714 constructor mechanism */
3716 __gnat_binder_supports_auto_init (void)
3725 /* Indicates that Stand-Alone Libraries are automatically initialized through
3726 the constructor mechanism */
3728 __gnat_sals_init_using_constructors (void)
3730 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3739 /* In RTX mode, the procedure to get the time (as file time) is different
3740 in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3741 we introduce an intermediate procedure to link against the corresponding
3742 one in each situation. */
3744 extern void GetTimeAsFileTime(LPFILETIME pTime
);
3746 void GetTimeAsFileTime(LPFILETIME pTime
)
3749 RtGetRtssTimeAsFileTime (pTime
); /* RTSS interface */
3751 GetSystemTimeAsFileTime (pTime
); /* w32 interface */
3756 /* Add symbol that is required to link. It would otherwise be taken from
3757 libgcc.a and it would try to use the gcc constructors that are not
3758 supported by Microsoft linker. */
3760 extern void __main (void);
3762 void __main (void) {}
3767 /* There is no function in the glibc to retrieve the LWP of the current
3768 thread. We need to do a system call in order to retrieve this
3770 #include <sys/syscall.h>
3771 void *__gnat_lwp_self (void)
3773 return (void *) syscall (__NR_gettid
);
3778 /* glibc versions earlier than 2.7 do not define the routines to handle
3779 dynamically allocated CPU sets. For these targets, we use the static
3784 /* Dynamic cpu sets */
3786 cpu_set_t
*__gnat_cpu_alloc (size_t count
)
3788 return CPU_ALLOC (count
);
3791 size_t __gnat_cpu_alloc_size (size_t count
)
3793 return CPU_ALLOC_SIZE (count
);
3796 void __gnat_cpu_free (cpu_set_t
*set
)
3801 void __gnat_cpu_zero (size_t count
, cpu_set_t
*set
)
3803 CPU_ZERO_S (count
, set
);
3806 void __gnat_cpu_set (int cpu
, size_t count
, cpu_set_t
*set
)
3808 /* Ada handles CPU numbers starting from 1, while C identifies the first
3809 CPU by a 0, so we need to adjust. */
3810 CPU_SET_S (cpu
- 1, count
, set
);
3815 /* Static cpu sets */
3817 cpu_set_t
*__gnat_cpu_alloc (size_t count ATTRIBUTE_UNUSED
)
3819 return (cpu_set_t
*) xmalloc (sizeof (cpu_set_t
));
3822 size_t __gnat_cpu_alloc_size (size_t count ATTRIBUTE_UNUSED
)
3824 return sizeof (cpu_set_t
);
3827 void __gnat_cpu_free (cpu_set_t
*set
)
3832 void __gnat_cpu_zero (size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
3837 void __gnat_cpu_set (int cpu
, size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
3839 /* Ada handles CPU numbers starting from 1, while C identifies the first
3840 CPU by a 0, so we need to adjust. */
3841 CPU_SET (cpu
- 1, set
);