1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2011, 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 (__mips) && defined (__sgi)) || 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"
92 /* S_IREAD and S_IWRITE are not defined in VxWorks */
94 #define S_IREAD (S_IRUSR | S_IRGRP | S_IROTH)
98 #define S_IWRITE (S_IWUSR)
102 /* We don't have libiberty, so use malloc. */
103 #define xmalloc(S) malloc (S)
104 #define xrealloc(V,S) realloc (V,S)
111 #if defined (__MINGW32__)
119 /* Current code page to use, set in initialize.c. */
120 UINT CurrentCodePage
;
123 #include <sys/utime.h>
125 /* For isalpha-like tests in the compiler, we're expected to resort to
126 safe-ctype.h/ISALPHA. This isn't available for the runtime library
127 build, so we fallback on ctype.h/isalpha there. */
131 #define ISALPHA isalpha
134 #elif defined (__Lynx__)
136 /* Lynx utime.h only defines the entities of interest to us if
137 defined (VMOS_DEV), so ... */
146 /* wait.h processing */
149 #include <sys/wait.h>
151 #elif defined (__vxworks) && defined (__RTP__)
153 #elif defined (__Lynx__)
154 /* ??? We really need wait.h and it includes resource.h on Lynx. GCC
155 has a resource.h header as well, included instead of the lynx
156 version in our setup, causing lots of errors. We don't really need
157 the lynx contents of this file, so just workaround the issue by
158 preventing the inclusion of the GCC header from doing anything. */
159 #define GCC_RESOURCE_H
160 #include <sys/wait.h>
161 #elif defined (__nucleus__)
162 /* No wait() or waitpid() calls available */
165 #include <sys/wait.h>
171 /* Header files and definitions for __gnat_set_file_time_name. */
173 #define __NEW_STARLET 1
175 #include <vms/atrdef.h>
176 #include <vms/fibdef.h>
177 #include <vms/stsdef.h>
178 #include <vms/iodef.h>
180 #include <vms/descrip.h>
184 /* Use native 64-bit arithmetic. */
185 #define unix_time_to_vms(X,Y) \
186 { unsigned long long reftime, tmptime = (X); \
187 $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
188 SYS$BINTIM (&unixtime, &reftime); \
189 Y = tmptime * 10000000 + reftime; }
191 /* descrip.h doesn't have everything ... */
192 typedef struct fibdef
* __fibdef_ptr32
__attribute__ (( mode (SI
) ));
193 struct dsc$descriptor_fib
195 unsigned int fib$l_len
;
196 __fibdef_ptr32 fib$l_addr
;
199 /* I/O Status Block. */
202 unsigned short status
, count
;
206 static char *tryfile
;
208 /* Variable length string. */
212 char string
[NAM$C_MAXRSS
+1];
215 #define SYI$_ACTIVECPU_CNT 0x111e
216 extern int LIB$
GETSYI (int *, unsigned int *);
233 #define DIR_SEPARATOR '\\'
238 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
239 defined in the current system. On DOS-like systems these flags control
240 whether the file is opened/created in text-translation mode (CR/LF in
241 external file mapped to LF in internal file), but in Unix-like systems,
242 no text translation is required, so these flags have no effect. */
252 #ifndef HOST_EXECUTABLE_SUFFIX
253 #define HOST_EXECUTABLE_SUFFIX ""
256 #ifndef HOST_OBJECT_SUFFIX
257 #define HOST_OBJECT_SUFFIX ".o"
260 #ifndef PATH_SEPARATOR
261 #define PATH_SEPARATOR ':'
264 #ifndef DIR_SEPARATOR
265 #define DIR_SEPARATOR '/'
268 /* Check for cross-compilation */
269 #if defined (CROSS_COMPILE) || defined (CROSS_DIRECTORY_STRUCTURE)
271 int __gnat_is_cross_compiler
= 1;
274 int __gnat_is_cross_compiler
= 0;
277 char __gnat_dir_separator
= DIR_SEPARATOR
;
279 char __gnat_path_separator
= PATH_SEPARATOR
;
281 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
282 the base filenames that libraries specified with -lsomelib options
283 may have. This is used by GNATMAKE to check whether an executable
284 is up-to-date or not. The syntax is
286 library_template ::= { pattern ; } pattern NUL
287 pattern ::= [ prefix ] * [ postfix ]
289 These should only specify names of static libraries as it makes
290 no sense to determine at link time if dynamic-link libraries are
291 up to date or not. Any libraries that are not found are supposed
294 * if they are needed but not present, the link
297 * otherwise they are libraries in the system paths and so
298 they are considered part of the system and not checked
301 ??? This should be part of a GNAT host-specific compiler
302 file instead of being included in all user applications
303 as well. This is only a temporary work-around for 3.11b. */
305 #ifndef GNAT_LIBRARY_TEMPLATE
307 #define GNAT_LIBRARY_TEMPLATE "*.olb"
309 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
313 const char *__gnat_library_template
= GNAT_LIBRARY_TEMPLATE
;
315 /* This variable is used in hostparm.ads to say whether the host is a VMS
324 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
326 #elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__)
327 #define GNAT_MAX_PATH_LEN PATH_MAX
331 #if defined (__MINGW32__)
335 #include <sys/param.h>
339 #include <sys/param.h>
343 #define GNAT_MAX_PATH_LEN MAXPATHLEN
345 #define GNAT_MAX_PATH_LEN 256
350 /* Used for Ada bindings */
351 int __gnat_size_of_file_attributes
= sizeof (struct file_attributes
);
353 /* Reset the file attributes as if no system call had been performed */
354 void __gnat_stat_to_attr (int fd
, char* name
, struct file_attributes
* attr
);
356 /* The __gnat_max_path_len variable is used to export the maximum
357 length of a path name to Ada code. max_path_len is also provided
358 for compatibility with older GNAT versions, please do not use
361 int __gnat_max_path_len
= GNAT_MAX_PATH_LEN
;
362 int max_path_len
= GNAT_MAX_PATH_LEN
;
364 /* Control whether we can use ACL on Windows. */
366 int __gnat_use_acl
= 1;
368 /* The following macro HAVE_READDIR_R should be defined if the
369 system provides the routine readdir_r. */
370 #undef HAVE_READDIR_R
372 #if defined(VMS) && defined (__LONG_POINTERS)
374 /* Return a 32 bit pointer to an array of 32 bit pointers
375 given a 64 bit pointer to an array of 64 bit pointers */
377 typedef __char_ptr32
*__char_ptr_char_ptr32
__attribute__ ((mode (SI
)));
379 static __char_ptr_char_ptr32
380 to_ptr32 (char **ptr64
)
383 __char_ptr_char_ptr32 short_argv
;
385 for (argc
=0; ptr64
[argc
]; argc
++);
387 /* Reallocate argv with 32 bit pointers. */
388 short_argv
= (__char_ptr_char_ptr32
) decc$malloc
389 (sizeof (__char_ptr32
) * (argc
+ 1));
391 for (argc
=0; ptr64
[argc
]; argc
++)
392 short_argv
[argc
] = (__char_ptr32
) decc$
strdup (ptr64
[argc
]);
394 short_argv
[argc
] = (__char_ptr32
) 0;
398 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
400 #define MAYBE_TO_PTR32(argv) argv
403 static const char ATTR_UNSET
= 127;
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) \
2471 || (defined (__alpha__) && defined (_osf_)) || defined (__APPLE__)
2472 cores
= (int) sysconf (_SC_NPROCESSORS_ONLN
);
2474 #elif (defined (__mips) && defined (__sgi))
2475 cores
= (int) sysconf (_SC_NPROC_ONLN
);
2477 #elif defined (__hpux__)
2478 struct pst_dynamic psd
;
2479 if (pstat_getdynamic (&psd
, sizeof (psd
), 1, 0) != -1)
2480 cores
= (int) psd
.psd_proc_cnt
;
2482 #elif defined (_WIN32)
2483 SYSTEM_INFO sysinfo
;
2484 GetSystemInfo (&sysinfo
);
2485 cores
= (int) sysinfo
.dwNumberOfProcessors
;
2488 int code
= SYI$_ACTIVECPU_CNT
;
2492 status
= LIB$
GETSYI (&code
, &res
);
2493 if ((status
& 1) != 0)
2496 #elif defined (_WRS_CONFIG_SMP)
2497 unsigned int vxCpuConfiguredGet (void);
2499 cores
= vxCpuConfiguredGet ();
2506 /* WIN32 code to implement a wait call that wait for any child process. */
2508 #if defined (_WIN32) && !defined (RTX)
2510 /* Synchronization code, to be thread safe. */
2514 /* For the Cert run times on native Windows we use dummy functions
2515 for locking and unlocking tasks since we do not support multiple
2516 threads on this configuration (Cert run time on native Windows). */
2518 void dummy (void) {}
2520 void (*Lock_Task
) () = &dummy
;
2521 void (*Unlock_Task
) () = &dummy
;
2525 #define Lock_Task system__soft_links__lock_task
2526 extern void (*Lock_Task
) (void);
2528 #define Unlock_Task system__soft_links__unlock_task
2529 extern void (*Unlock_Task
) (void);
2533 static HANDLE
*HANDLES_LIST
= NULL
;
2534 static int *PID_LIST
= NULL
, plist_length
= 0, plist_max_length
= 0;
2537 add_handle (HANDLE h
, int pid
)
2540 /* -------------------- critical section -------------------- */
2543 if (plist_length
== plist_max_length
)
2545 plist_max_length
+= 1000;
2547 xrealloc (HANDLES_LIST
, sizeof (HANDLE
) * plist_max_length
);
2549 xrealloc (PID_LIST
, sizeof (int) * plist_max_length
);
2552 HANDLES_LIST
[plist_length
] = h
;
2553 PID_LIST
[plist_length
] = pid
;
2557 /* -------------------- critical section -------------------- */
2561 __gnat_win32_remove_handle (HANDLE h
, int pid
)
2565 /* -------------------- critical section -------------------- */
2568 for (j
= 0; j
< plist_length
; j
++)
2570 if ((HANDLES_LIST
[j
] == h
) || (PID_LIST
[j
] == pid
))
2574 HANDLES_LIST
[j
] = HANDLES_LIST
[plist_length
];
2575 PID_LIST
[j
] = PID_LIST
[plist_length
];
2581 /* -------------------- critical section -------------------- */
2585 win32_no_block_spawn (char *command
, char *args
[], HANDLE
*h
, int *pid
)
2589 PROCESS_INFORMATION PI
;
2590 SECURITY_ATTRIBUTES SA
;
2595 /* compute the total command line length */
2599 csize
+= strlen (args
[k
]) + 1;
2603 full_command
= (char *) xmalloc (csize
);
2606 SI
.cb
= sizeof (STARTUPINFO
);
2607 SI
.lpReserved
= NULL
;
2608 SI
.lpReserved2
= NULL
;
2609 SI
.lpDesktop
= NULL
;
2613 SI
.wShowWindow
= SW_HIDE
;
2615 /* Security attributes. */
2616 SA
.nLength
= sizeof (SECURITY_ATTRIBUTES
);
2617 SA
.bInheritHandle
= TRUE
;
2618 SA
.lpSecurityDescriptor
= NULL
;
2620 /* Prepare the command string. */
2621 strcpy (full_command
, command
);
2622 strcat (full_command
, " ");
2627 strcat (full_command
, args
[k
]);
2628 strcat (full_command
, " ");
2633 int wsize
= csize
* 2;
2634 TCHAR
*wcommand
= (TCHAR
*) xmalloc (wsize
);
2636 S2WSC (wcommand
, full_command
, wsize
);
2638 free (full_command
);
2640 result
= CreateProcess
2641 (NULL
, wcommand
, &SA
, NULL
, TRUE
,
2642 GetPriorityClass (GetCurrentProcess()), NULL
, NULL
, &SI
, &PI
);
2649 CloseHandle (PI
.hThread
);
2651 *pid
= PI
.dwProcessId
;
2661 win32_wait (int *status
)
2663 DWORD exitcode
, pid
;
2670 if (plist_length
== 0)
2678 /* -------------------- critical section -------------------- */
2681 hl_len
= plist_length
;
2683 hl
= (HANDLE
*) xmalloc (sizeof (HANDLE
) * hl_len
);
2685 memmove (hl
, HANDLES_LIST
, sizeof (HANDLE
) * hl_len
);
2688 /* -------------------- critical section -------------------- */
2690 res
= WaitForMultipleObjects (hl_len
, hl
, FALSE
, INFINITE
);
2691 h
= hl
[res
- WAIT_OBJECT_0
];
2693 GetExitCodeProcess (h
, &exitcode
);
2694 pid
= PID_LIST
[res
- WAIT_OBJECT_0
];
2695 __gnat_win32_remove_handle (h
, -1);
2699 *status
= (int) exitcode
;
2706 __gnat_portable_no_block_spawn (char *args
[])
2709 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2712 #elif defined (_WIN32)
2717 win32_no_block_spawn (args
[0], args
, &h
, &pid
);
2720 add_handle (h
, pid
);
2733 if (execv (args
[0], MAYBE_TO_PTR32 (args
)) != 0)
2735 return -1; /* execv is in parent context on VMS. */
2747 __gnat_portable_wait (int *process_status
)
2752 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2753 /* Not sure what to do here, so do nothing but return zero. */
2755 #elif defined (_WIN32)
2757 pid
= win32_wait (&status
);
2761 pid
= waitpid (-1, &status
, 0);
2762 status
= status
& 0xffff;
2765 *process_status
= status
;
2770 __gnat_os_exit (int status
)
2775 /* Locate file on path, that matches a predicate */
2778 __gnat_locate_file_with_predicate
2779 (char *file_name
, char *path_val
, int (*predicate
)(char*))
2782 char *file_path
= (char *) alloca (strlen (file_name
) + 1);
2785 /* Return immediately if file_name is empty */
2787 if (*file_name
== '\0')
2790 /* Remove quotes around file_name if present */
2796 strcpy (file_path
, ptr
);
2798 ptr
= file_path
+ strlen (file_path
) - 1;
2803 /* Handle absolute pathnames. */
2805 absolute
= __gnat_is_absolute_path (file_path
, strlen (file_name
));
2809 if (predicate (file_path
))
2810 return xstrdup (file_path
);
2815 /* If file_name include directory separator(s), try it first as
2816 a path name relative to the current directory */
2817 for (ptr
= file_name
; *ptr
&& *ptr
!= '/' && *ptr
!= DIR_SEPARATOR
; ptr
++)
2822 if (predicate (file_name
))
2823 return xstrdup (file_name
);
2830 /* The result has to be smaller than path_val + file_name. */
2832 (char *) alloca (strlen (path_val
) + strlen (file_name
) + 2);
2836 /* Skip the starting quote */
2838 if (*path_val
== '"')
2841 for (ptr
= file_path
; *path_val
&& *path_val
!= PATH_SEPARATOR
; )
2842 *ptr
++ = *path_val
++;
2844 /* If directory is empty, it is the current directory*/
2846 if (ptr
== file_path
)
2853 /* Skip the ending quote */
2858 if (*ptr
!= '/' && *ptr
!= DIR_SEPARATOR
)
2859 *++ptr
= DIR_SEPARATOR
;
2861 strcpy (++ptr
, file_name
);
2863 if (predicate (file_path
))
2864 return xstrdup (file_path
);
2869 /* Skip path separator */
2878 /* Locate an executable file, give a Path value. */
2881 __gnat_locate_executable_file (char *file_name
, char *path_val
)
2883 return __gnat_locate_file_with_predicate
2884 (file_name
, path_val
, &__gnat_is_executable_file
);
2887 /* Locate a regular file, give a Path value. */
2890 __gnat_locate_regular_file (char *file_name
, char *path_val
)
2892 return __gnat_locate_file_with_predicate
2893 (file_name
, path_val
, &__gnat_is_regular_file
);
2896 /* Locate an executable given a Path argument. This routine is only used by
2897 gnatbl and should not be used otherwise. Use locate_exec_on_path
2901 __gnat_locate_exec (char *exec_name
, char *path_val
)
2904 if (!strstr (exec_name
, HOST_EXECUTABLE_SUFFIX
))
2906 char *full_exec_name
=
2908 (strlen (exec_name
) + strlen (HOST_EXECUTABLE_SUFFIX
) + 1);
2910 strcpy (full_exec_name
, exec_name
);
2911 strcat (full_exec_name
, HOST_EXECUTABLE_SUFFIX
);
2912 ptr
= __gnat_locate_executable_file (full_exec_name
, path_val
);
2915 return __gnat_locate_executable_file (exec_name
, path_val
);
2919 return __gnat_locate_executable_file (exec_name
, path_val
);
2922 /* Locate an executable using the Systems default PATH. */
2925 __gnat_locate_exec_on_path (char *exec_name
)
2929 #if defined (_WIN32) && !defined (RTX)
2930 TCHAR
*wpath_val
= _tgetenv (_T("PATH"));
2932 /* In Win32 systems we expand the PATH as for XP environment
2933 variables are not automatically expanded. We also prepend the
2934 ".;" to the path to match normal NT path search semantics */
2936 #define EXPAND_BUFFER_SIZE 32767
2938 wapath_val
= alloca (EXPAND_BUFFER_SIZE
);
2940 wapath_val
[0] = '.';
2941 wapath_val
[1] = ';';
2943 DWORD res
= ExpandEnvironmentStrings
2944 (wpath_val
, &wapath_val
[2], EXPAND_BUFFER_SIZE
- 2);
2946 if (!res
) wapath_val
[0] = _T('\0');
2948 apath_val
= alloca (EXPAND_BUFFER_SIZE
);
2950 WS2SC (apath_val
, wapath_val
, EXPAND_BUFFER_SIZE
);
2951 return __gnat_locate_exec (exec_name
, apath_val
);
2956 char *path_val
= "/VAXC$PATH";
2958 char *path_val
= getenv ("PATH");
2960 if (path_val
== NULL
) return NULL
;
2961 apath_val
= (char *) alloca (strlen (path_val
) + 1);
2962 strcpy (apath_val
, path_val
);
2963 return __gnat_locate_exec (exec_name
, apath_val
);
2969 /* These functions are used to translate to and from VMS and Unix syntax
2970 file, directory and path specifications. */
2973 #define MAXNAMES 256
2974 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2976 static char new_canonical_dirspec
[MAXPATH
];
2977 static char new_canonical_filespec
[MAXPATH
];
2978 static char new_canonical_pathspec
[MAXNAMES
*MAXPATH
];
2979 static unsigned new_canonical_filelist_index
;
2980 static unsigned new_canonical_filelist_in_use
;
2981 static unsigned new_canonical_filelist_allocated
;
2982 static char **new_canonical_filelist
;
2983 static char new_host_pathspec
[MAXNAMES
*MAXPATH
];
2984 static char new_host_dirspec
[MAXPATH
];
2985 static char new_host_filespec
[MAXPATH
];
2987 /* Routine is called repeatedly by decc$from_vms via
2988 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2992 wildcard_translate_unix (char *name
)
2995 char buff
[MAXPATH
];
2997 strncpy (buff
, name
, MAXPATH
);
2998 buff
[MAXPATH
- 1] = (char) 0;
2999 ver
= strrchr (buff
, '.');
3001 /* Chop off the version. */
3005 /* Dynamically extend the allocation by the increment. */
3006 if (new_canonical_filelist_in_use
== new_canonical_filelist_allocated
)
3008 new_canonical_filelist_allocated
+= NEW_CANONICAL_FILELIST_INCREMENT
;
3009 new_canonical_filelist
= (char **) xrealloc
3010 (new_canonical_filelist
,
3011 new_canonical_filelist_allocated
* sizeof (char *));
3014 new_canonical_filelist
[new_canonical_filelist_in_use
++] = xstrdup (buff
);
3019 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
3020 full translation and copy the results into a list (_init), then return them
3021 one at a time (_next). If onlydirs set, only expand directory files. */
3024 __gnat_to_canonical_file_list_init (char *filespec
, int onlydirs
)
3027 char buff
[MAXPATH
];
3029 len
= strlen (filespec
);
3030 strncpy (buff
, filespec
, MAXPATH
);
3032 /* Only look for directories */
3033 if (onlydirs
&& !strstr (&buff
[len
-5], "*.dir"))
3034 strncat (buff
, "*.dir", MAXPATH
);
3036 buff
[MAXPATH
- 1] = (char) 0;
3038 decc$
from_vms (buff
, wildcard_translate_unix
, 1);
3040 /* Remove the .dir extension. */
3046 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3048 ext
= strstr (new_canonical_filelist
[i
], ".dir");
3054 return new_canonical_filelist_in_use
;
3057 /* Return the next filespec in the list. */
3060 __gnat_to_canonical_file_list_next ()
3062 return new_canonical_filelist
[new_canonical_filelist_index
++];
3065 /* Free storage used in the wildcard expansion. */
3068 __gnat_to_canonical_file_list_free ()
3072 for (i
= 0; i
< new_canonical_filelist_in_use
; i
++)
3073 free (new_canonical_filelist
[i
]);
3075 free (new_canonical_filelist
);
3077 new_canonical_filelist_in_use
= 0;
3078 new_canonical_filelist_allocated
= 0;
3079 new_canonical_filelist_index
= 0;
3080 new_canonical_filelist
= 0;
3083 /* The functional equivalent of decc$translate_vms routine.
3084 Designed to produce the same output, but is protected against
3085 malformed paths (original version ACCVIOs in this case) and
3086 does not require VMS-specific DECC RTL */
3088 #define NAM$C_MAXRSS 1024
3091 __gnat_translate_vms (char *src
)
3093 static char retbuf
[NAM$C_MAXRSS
+1];
3094 char *srcendpos
, *pos1
, *pos2
, *retpos
;
3095 int disp
, path_present
= 0;
3097 if (!src
) return NULL
;
3099 srcendpos
= strchr (src
, '\0');
3102 /* Look for the node and/or device in front of the path */
3104 pos2
= strchr (pos1
, ':');
3106 if (pos2
&& (pos2
< srcendpos
) && (*(pos2
+ 1) == ':')) {
3107 /* There is a node name. "node_name::" becomes "node_name!" */
3109 strncpy (retbuf
, pos1
, disp
);
3110 retpos
[disp
] = '!';
3111 retpos
= retpos
+ disp
+ 1;
3113 pos2
= strchr (pos1
, ':');
3117 /* There is a device name. "dev_name:" becomes "/dev_name/" */
3120 strncpy (retpos
, pos1
, disp
);
3121 retpos
= retpos
+ disp
;
3126 /* No explicit device; we must look ahead and prepend /sys$disk/ if
3127 the path is absolute */
3128 if ((*pos1
== '[' || *pos1
== '<') && (pos1
< srcendpos
)
3129 && !strchr (".-]>", *(pos1
+ 1))) {
3130 strncpy (retpos
, "/sys$disk/", 10);
3134 /* Process the path part */
3135 while (*pos1
== '[' || *pos1
== '<') {
3138 if (*pos1
== ']' || *pos1
== '>') {
3139 /* Special case, [] translates to '.' */
3144 /* '[000000' means root dir. It can be present in the middle of
3145 the path due to expansion of logical devices, in which case
3147 if (!strncmp (pos1
, "000000", 6) && path_present
> 1 &&
3148 (*(pos1
+ 6) == ']' || *(pos1
+ 6) == '>' || *(pos1
+ 6) == '.')) {
3150 if (*pos1
== '.') pos1
++;
3152 else if (*pos1
== '.') {
3157 /* There is a qualified path */
3158 while (*pos1
&& *pos1
!= ']' && *pos1
!= '>') {
3161 /* '.' is used to separate directories. Replace it with '/' but
3162 only if there isn't already '/' just before */
3163 if (*(retpos
- 1) != '/') *(retpos
++) = '/';
3165 if (pos1
+ 1 < srcendpos
&& *pos1
== '.' && *(pos1
+ 1) == '.') {
3166 /* ellipsis refers to entire subtree; replace with '**' */
3167 *(retpos
++) = '*'; *(retpos
++) = '*'; *(retpos
++) = '/';
3172 /* When after '.' '[' '<' is equivalent to Unix ".." but there
3173 may be several in a row */
3174 if (*(pos1
- 1) == '.' || *(pos1
- 1) == '[' ||
3175 *(pos1
- 1) == '<') {
3176 while (*pos1
== '-') {
3178 *(retpos
++) = '.'; *(retpos
++) = '.'; *(retpos
++) = '/';
3183 /* otherwise fall through to default */
3185 *(retpos
++) = *(pos1
++);
3192 if (pos1
< srcendpos
) {
3193 /* Now add the actual file name, until the version suffix if any */
3194 if (path_present
) *(retpos
++) = '/';
3195 pos2
= strchr (pos1
, ';');
3196 disp
= pos2
? (pos2
- pos1
) : (srcendpos
- pos1
);
3197 strncpy (retpos
, pos1
, disp
);
3199 if (pos2
&& pos2
< srcendpos
) {
3200 /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
3202 disp
= srcendpos
- pos2
- 1;
3203 strncpy (retpos
, pos2
+ 1, disp
);
3214 /* Translate a VMS syntax directory specification in to Unix syntax. If
3215 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
3216 found, return input string. Also translate a dirname that contains no
3217 slashes, in case it's a logical name. */
3220 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag
)
3224 strcpy (new_canonical_dirspec
, "");
3225 if (strlen (dirspec
))
3229 if (strchr (dirspec
, ']') || strchr (dirspec
, ':'))
3231 strncpy (new_canonical_dirspec
,
3232 __gnat_translate_vms (dirspec
),
3235 else if (!strchr (dirspec
, '/') && (dirspec1
= getenv (dirspec
)) != 0)
3237 strncpy (new_canonical_dirspec
,
3238 __gnat_translate_vms (dirspec1
),
3243 strncpy (new_canonical_dirspec
, dirspec
, MAXPATH
);
3247 len
= strlen (new_canonical_dirspec
);
3248 if (prefixflag
&& new_canonical_dirspec
[len
-1] != '/')
3249 strncat (new_canonical_dirspec
, "/", MAXPATH
);
3251 new_canonical_dirspec
[MAXPATH
- 1] = (char) 0;
3253 return new_canonical_dirspec
;
3257 /* Translate a VMS syntax file specification into Unix syntax.
3258 If no indicators of VMS syntax found, check if it's an uppercase
3259 alphanumeric_ name and if so try it out as an environment
3260 variable (logical name). If all else fails return the
3264 __gnat_to_canonical_file_spec (char *filespec
)
3268 strncpy (new_canonical_filespec
, "", MAXPATH
);
3270 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3272 char *tspec
= (char *) __gnat_translate_vms (filespec
);
3274 if (tspec
!= (char *) -1)
3275 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3277 else if ((strlen (filespec
) == strspn (filespec
,
3278 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
3279 && (filespec1
= getenv (filespec
)))
3281 char *tspec
= (char *) __gnat_translate_vms (filespec1
);
3283 if (tspec
!= (char *) -1)
3284 strncpy (new_canonical_filespec
, tspec
, MAXPATH
);
3288 strncpy (new_canonical_filespec
, filespec
, MAXPATH
);
3291 new_canonical_filespec
[MAXPATH
- 1] = (char) 0;
3293 return new_canonical_filespec
;
3296 /* Translate a VMS syntax path specification into Unix syntax.
3297 If no indicators of VMS syntax found, return input string. */
3300 __gnat_to_canonical_path_spec (char *pathspec
)
3302 char *curr
, *next
, buff
[MAXPATH
];
3307 /* If there are /'s, assume it's a Unix path spec and return. */
3308 if (strchr (pathspec
, '/'))
3311 new_canonical_pathspec
[0] = 0;
3316 next
= strchr (curr
, ',');
3318 next
= strchr (curr
, 0);
3320 strncpy (buff
, curr
, next
- curr
);
3321 buff
[next
- curr
] = 0;
3323 /* Check for wildcards and expand if present. */
3324 if (strchr (buff
, '*') || strchr (buff
, '%') || strstr (buff
, "..."))
3328 dirs
= __gnat_to_canonical_file_list_init (buff
, 1);
3329 for (i
= 0; i
< dirs
; i
++)
3333 next_dir
= __gnat_to_canonical_file_list_next ();
3334 strncat (new_canonical_pathspec
, next_dir
, MAXPATH
);
3336 /* Don't append the separator after the last expansion. */
3338 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3341 __gnat_to_canonical_file_list_free ();
3344 strncat (new_canonical_pathspec
,
3345 __gnat_to_canonical_dir_spec (buff
, 0), MAXPATH
);
3350 strncat (new_canonical_pathspec
, ":", MAXPATH
);
3354 new_canonical_pathspec
[MAXPATH
- 1] = (char) 0;
3356 return new_canonical_pathspec
;
3359 static char filename_buff
[MAXPATH
];
3362 translate_unix (char *name
, int type
)
3364 strncpy (filename_buff
, name
, MAXPATH
);
3365 filename_buff
[MAXPATH
- 1] = (char) 0;
3369 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
3373 to_host_path_spec (char *pathspec
)
3375 char *curr
, *next
, buff
[MAXPATH
];
3380 /* Can't very well test for colons, since that's the Unix separator! */
3381 if (strchr (pathspec
, ']') || strchr (pathspec
, ','))
3384 new_host_pathspec
[0] = 0;
3389 next
= strchr (curr
, ':');
3391 next
= strchr (curr
, 0);
3393 strncpy (buff
, curr
, next
- curr
);
3394 buff
[next
- curr
] = 0;
3396 strncat (new_host_pathspec
, __gnat_to_host_dir_spec (buff
, 0), MAXPATH
);
3399 strncat (new_host_pathspec
, ",", MAXPATH
);
3403 new_host_pathspec
[MAXPATH
- 1] = (char) 0;
3405 return new_host_pathspec
;
3408 /* Translate a Unix syntax directory specification into VMS syntax. The
3409 PREFIXFLAG has no effect, but is kept for symmetry with
3410 to_canonical_dir_spec. If indicators of VMS syntax found, return input
3414 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3416 int len
= strlen (dirspec
);
3418 strncpy (new_host_dirspec
, dirspec
, MAXPATH
);
3419 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3421 if (strchr (new_host_dirspec
, ']') || strchr (new_host_dirspec
, ':'))
3422 return new_host_dirspec
;
3424 while (len
> 1 && new_host_dirspec
[len
- 1] == '/')
3426 new_host_dirspec
[len
- 1] = 0;
3430 decc$
to_vms (new_host_dirspec
, translate_unix
, 1, 2);
3431 strncpy (new_host_dirspec
, filename_buff
, MAXPATH
);
3432 new_host_dirspec
[MAXPATH
- 1] = (char) 0;
3434 return new_host_dirspec
;
3437 /* Translate a Unix syntax file specification into VMS syntax.
3438 If indicators of VMS syntax found, return input string. */
3441 __gnat_to_host_file_spec (char *filespec
)
3443 strncpy (new_host_filespec
, "", MAXPATH
);
3444 if (strchr (filespec
, ']') || strchr (filespec
, ':'))
3446 strncpy (new_host_filespec
, filespec
, MAXPATH
);
3450 decc$
to_vms (filespec
, translate_unix
, 1, 1);
3451 strncpy (new_host_filespec
, filename_buff
, MAXPATH
);
3454 new_host_filespec
[MAXPATH
- 1] = (char) 0;
3456 return new_host_filespec
;
3460 __gnat_adjust_os_resource_limits ()
3462 SYS$
ADJWSL (131072, 0);
3467 /* Dummy functions for Osint import for non-VMS systems. */
3470 __gnat_to_canonical_file_list_init
3471 (char *dirspec ATTRIBUTE_UNUSED
, int onlydirs ATTRIBUTE_UNUSED
)
3477 __gnat_to_canonical_file_list_next (void)
3479 static char empty
[] = "";
3484 __gnat_to_canonical_file_list_free (void)
3489 __gnat_to_canonical_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3495 __gnat_to_canonical_file_spec (char *filespec
)
3501 __gnat_to_canonical_path_spec (char *pathspec
)
3507 __gnat_to_host_dir_spec (char *dirspec
, int prefixflag ATTRIBUTE_UNUSED
)
3513 __gnat_to_host_file_spec (char *filespec
)
3519 __gnat_adjust_os_resource_limits (void)
3525 #if defined (__mips_vxworks)
3529 CACHE_USER_FLUSH (0, ENTIRE_CACHE
);
3533 #if defined (IS_CROSS) \
3534 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3535 && defined (__SVR4)) \
3536 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3537 && ! (defined (linux) && defined (__ia64__)) \
3538 && ! (defined (linux) && defined (powerpc)) \
3539 && ! defined (__FreeBSD__) \
3540 && ! defined (__Lynx__) \
3541 && ! defined (__hpux__) \
3542 && ! defined (__APPLE__) \
3543 && ! defined (_AIX) \
3544 && ! (defined (__alpha__) && defined (__osf__)) \
3545 && ! defined (VMS) \
3546 && ! defined (__MINGW32__) \
3547 && ! (defined (__mips) && defined (__sgi)))
3549 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3550 just above for a list of native platforms that provide a non-dummy
3551 version of this procedure in libaddr2line.a. */
3554 convert_addresses (const char *file_name ATTRIBUTE_UNUSED
,
3555 void *addrs ATTRIBUTE_UNUSED
,
3556 int n_addr ATTRIBUTE_UNUSED
,
3557 void *buf ATTRIBUTE_UNUSED
,
3558 int *len ATTRIBUTE_UNUSED
)
3564 #if defined (_WIN32)
3565 int __gnat_argument_needs_quote
= 1;
3567 int __gnat_argument_needs_quote
= 0;
3570 /* This option is used to enable/disable object files handling from the
3571 binder file by the GNAT Project module. For example, this is disabled on
3572 Windows (prior to GCC 3.4) as it is already done by the mdll module.
3573 Stating with GCC 3.4 the shared libraries are not based on mdll
3574 anymore as it uses the GCC's -shared option */
3575 #if defined (_WIN32) \
3576 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3577 int __gnat_prj_add_obj_files
= 0;
3579 int __gnat_prj_add_obj_files
= 1;
3582 /* char used as prefix/suffix for environment variables */
3583 #if defined (_WIN32)
3584 char __gnat_environment_char
= '%';
3586 char __gnat_environment_char
= '$';
3589 /* This functions copy the file attributes from a source file to a
3592 mode = 0 : In this mode copy only the file time stamps (last access and
3593 last modification time stamps).
3595 mode = 1 : In this mode, time stamps and read/write/execute attributes are
3598 Returns 0 if operation was successful and -1 in case of error. */
3601 __gnat_copy_attribs (char *from
, char *to
, int mode
)
3603 #if defined (VMS) || (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \
3604 defined (__nucleus__)
3607 #elif defined (_WIN32) && !defined (RTX)
3608 TCHAR wfrom
[GNAT_MAX_PATH_LEN
+ 2];
3609 TCHAR wto
[GNAT_MAX_PATH_LEN
+ 2];
3611 FILETIME fct
, flat
, flwt
;
3614 S2WSC (wfrom
, from
, GNAT_MAX_PATH_LEN
+ 2);
3615 S2WSC (wto
, to
, GNAT_MAX_PATH_LEN
+ 2);
3617 /* retrieve from times */
3620 (wfrom
, GENERIC_READ
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3622 if (hfrom
== INVALID_HANDLE_VALUE
)
3625 res
= GetFileTime (hfrom
, &fct
, &flat
, &flwt
);
3627 CloseHandle (hfrom
);
3632 /* retrieve from times */
3635 (wto
, GENERIC_WRITE
, 0, NULL
, OPEN_EXISTING
, FILE_ATTRIBUTE_NORMAL
, NULL
);
3637 if (hto
== INVALID_HANDLE_VALUE
)
3640 res
= SetFileTime (hto
, NULL
, &flat
, &flwt
);
3647 /* Set file attributes in full mode. */
3651 DWORD attribs
= GetFileAttributes (wfrom
);
3653 if (attribs
== INVALID_FILE_ATTRIBUTES
)
3656 res
= SetFileAttributes (wto
, attribs
);
3664 GNAT_STRUCT_STAT fbuf
;
3665 struct utimbuf tbuf
;
3667 if (GNAT_STAT (from
, &fbuf
) == -1)
3672 tbuf
.actime
= fbuf
.st_atime
;
3673 tbuf
.modtime
= fbuf
.st_mtime
;
3675 if (utime (to
, &tbuf
) == -1)
3682 if (chmod (to
, fbuf
.st_mode
) == -1)
3693 __gnat_lseek (int fd
, long offset
, int whence
)
3695 return (int) lseek (fd
, offset
, whence
);
3698 /* This function returns the major version number of GCC being used. */
3700 get_gcc_version (void)
3705 return (int) (version_string
[0] - '0');
3710 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED
,
3711 int close_on_exec_p ATTRIBUTE_UNUSED
)
3713 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3714 int flags
= fcntl (fd
, F_GETFD
, 0);
3717 if (close_on_exec_p
)
3718 flags
|= FD_CLOEXEC
;
3720 flags
&= ~FD_CLOEXEC
;
3721 return fcntl (fd
, F_SETFD
, flags
| FD_CLOEXEC
);
3722 #elif defined(_WIN32)
3723 HANDLE h
= (HANDLE
) _get_osfhandle (fd
);
3724 if (h
== (HANDLE
) -1)
3726 if (close_on_exec_p
)
3727 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
, 0);
3728 return ! SetHandleInformation (h
, HANDLE_FLAG_INHERIT
,
3729 HANDLE_FLAG_INHERIT
);
3731 /* TODO: Unimplemented. */
3736 /* Indicates if platforms supports automatic initialization through the
3737 constructor mechanism */
3739 __gnat_binder_supports_auto_init (void)
3748 /* Indicates that Stand-Alone Libraries are automatically initialized through
3749 the constructor mechanism */
3751 __gnat_sals_init_using_constructors (void)
3753 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3762 /* In RTX mode, the procedure to get the time (as file time) is different
3763 in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3764 we introduce an intermediate procedure to link against the corresponding
3765 one in each situation. */
3767 extern void GetTimeAsFileTime(LPFILETIME pTime
);
3769 void GetTimeAsFileTime(LPFILETIME pTime
)
3772 RtGetRtssTimeAsFileTime (pTime
); /* RTSS interface */
3774 GetSystemTimeAsFileTime (pTime
); /* w32 interface */
3779 /* Add symbol that is required to link. It would otherwise be taken from
3780 libgcc.a and it would try to use the gcc constructors that are not
3781 supported by Microsoft linker. */
3783 extern void __main (void);
3785 void __main (void) {}
3790 /* There is no function in the glibc to retrieve the LWP of the current
3791 thread. We need to do a system call in order to retrieve this
3793 #include <sys/syscall.h>
3794 void *__gnat_lwp_self (void)
3796 return (void *) syscall (__NR_gettid
);
3801 /* glibc versions earlier than 2.7 do not define the routines to handle
3802 dynamically allocated CPU sets. For these targets, we use the static
3807 /* Dynamic cpu sets */
3809 cpu_set_t
*__gnat_cpu_alloc (size_t count
)
3811 return CPU_ALLOC (count
);
3814 size_t __gnat_cpu_alloc_size (size_t count
)
3816 return CPU_ALLOC_SIZE (count
);
3819 void __gnat_cpu_free (cpu_set_t
*set
)
3824 void __gnat_cpu_zero (size_t count
, cpu_set_t
*set
)
3826 CPU_ZERO_S (count
, set
);
3829 void __gnat_cpu_set (int cpu
, size_t count
, cpu_set_t
*set
)
3831 /* Ada handles CPU numbers starting from 1, while C identifies the first
3832 CPU by a 0, so we need to adjust. */
3833 CPU_SET_S (cpu
- 1, count
, set
);
3838 /* Static cpu sets */
3840 cpu_set_t
*__gnat_cpu_alloc (size_t count ATTRIBUTE_UNUSED
)
3842 return (cpu_set_t
*) xmalloc (sizeof (cpu_set_t
));
3845 size_t __gnat_cpu_alloc_size (size_t count ATTRIBUTE_UNUSED
)
3847 return sizeof (cpu_set_t
);
3850 void __gnat_cpu_free (cpu_set_t
*set
)
3855 void __gnat_cpu_zero (size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
3860 void __gnat_cpu_set (int cpu
, size_t count ATTRIBUTE_UNUSED
, cpu_set_t
*set
)
3862 /* Ada handles CPU numbers starting from 1, while C identifies the first
3863 CPU by a 0, so we need to adjust. */
3864 CPU_SET (cpu
- 1, set
);