projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
[multiple changes]
[gcc.git] / gcc / ada / adaint.c
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * A D A I N T *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2011, Free Software Foundation, Inc. *
10 * *
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. *
17 * *
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. *
21 * *
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/>. *
26 * *
27 * GNAT was originally developed by the GNAT team at New York University. *
28 * Extensive contributions were provided by Ada Core Technologies Inc. *
29 * *
30 ****************************************************************************/
31
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. */
36
37 #ifdef __cplusplus
38 extern "C" {
39 #endif
40
41 #ifdef __vxworks
42
43 /* No need to redefine exit here. */
44 #undef exit
45
46 /* We want to use the POSIX variants of include files. */
47 #define POSIX
48 #include "vxWorks.h"
49
50 #if defined (__mips_vxworks)
51 #include "cacheLib.h"
52 #endif /* __mips_vxworks */
53
54 /* If SMP, access vxCpuConfiguredGet */
55 #ifdef _WRS_CONFIG_SMP
56 #include <vxCpuLib.h>
57 #endif /* _WRS_CONFIG_SMP */
58
59 /* We need to know the VxWorks version because some file operations
60 (such as chmod) are only available on VxWorks 6. */
61 #include "version.h"
62
63 #endif /* VxWorks */
64
65 #if (defined (__mips) && defined (__sgi)) || defined (__APPLE__)
66 #include <unistd.h>
67 #endif
68
69 #if defined (__hpux__)
70 #include <sys/param.h>
71 #include <sys/pstat.h>
72 #endif
73
74 #ifdef VMS
75 #define _POSIX_EXIT 1
76 #define HOST_EXECUTABLE_SUFFIX ".exe"
77 #define HOST_OBJECT_SUFFIX ".obj"
78 #endif
79
80 #ifdef IN_RTS
81 #include "tconfig.h"
82 #include "tsystem.h"
83
84 #include <sys/stat.h>
85 #include <fcntl.h>
86 #include <time.h>
87 #ifdef VMS
88 #include <unixio.h>
89 #endif
90
91 #ifdef __vxworks
92 /* S_IREAD and S_IWRITE are not defined in VxWorks */
93 #ifndef S_IREAD
94 #define S_IREAD (S_IRUSR | S_IRGRP | S_IROTH)
95 #endif
96
97 #ifndef S_IWRITE
98 #define S_IWRITE (S_IWUSR)
99 #endif
100 #endif
101
102 /* We don't have libiberty, so use malloc. */
103 #define xmalloc(S) malloc (S)
104 #define xrealloc(V,S) realloc (V,S)
105 #else
106 #include "config.h"
107 #include "system.h"
108 #include "version.h"
109 #endif
110
111 #if defined (__MINGW32__)
112
113 #if defined (RTX)
114 #include <windows.h>
115 #include <Rtapi.h>
116 #else
117 #include "mingw32.h"
118
119 /* Current code page to use, set in initialize.c. */
120 UINT CurrentCodePage;
121 #endif
122
123 #include <sys/utime.h>
124
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. */
128
129 #ifdef IN_RTS
130 #include <ctype.h>
131 #define ISALPHA isalpha
132 #endif
133
134 #elif defined (__Lynx__)
135
136 /* Lynx utime.h only defines the entities of interest to us if
137 defined (VMOS_DEV), so ... */
138 #define VMOS_DEV
139 #include <utime.h>
140 #undef VMOS_DEV
141
142 #elif !defined (VMS)
143 #include <utime.h>
144 #endif
145
146 /* wait.h processing */
147 #ifdef __MINGW32__
148 #if OLD_MINGW
149 #include <sys/wait.h>
150 #endif
151 #elif defined (__vxworks) && defined (__RTP__)
152 #include <wait.h>
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 */
163 #else
164 /* Default case */
165 #include <sys/wait.h>
166 #endif
167
168 #if defined (_WIN32)
169 #elif defined (VMS)
170
171 /* Header files and definitions for __gnat_set_file_time_name. */
172
173 #define __NEW_STARLET 1
174 #include <vms/rms.h>
175 #include <vms/atrdef.h>
176 #include <vms/fibdef.h>
177 #include <vms/stsdef.h>
178 #include <vms/iodef.h>
179 #include <errno.h>
180 #include <vms/descrip.h>
181 #include <string.h>
182 #include <unixlib.h>
183
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; }
190
191 /* descrip.h doesn't have everything ... */
192 typedef struct fibdef* __fibdef_ptr32 __attribute__ (( mode (SI) ));
193 struct dsc$descriptor_fib
194 {
195 unsigned int fib$l_len;
196 __fibdef_ptr32 fib$l_addr;
197 };
198
199 /* I/O Status Block. */
200 struct IOSB
201 {
202 unsigned short status, count;
203 unsigned int devdep;
204 };
205
206 static char *tryfile;
207
208 /* Variable length string. */
209 struct vstring
210 {
211 short length;
212 char string[NAM$C_MAXRSS+1];
213 };
214
215 #define SYI$_ACTIVECPU_CNT 0x111e
216 extern int LIB$GETSYI (int *, unsigned int *);
217
218 #else
219 #include <utime.h>
220 #endif
221
222 #if defined (_WIN32)
223 #include <process.h>
224 #endif
225
226 #if defined (_WIN32)
227
228 #include <dir.h>
229 #include <windows.h>
230 #include <accctrl.h>
231 #include <aclapi.h>
232 #undef DIR_SEPARATOR
233 #define DIR_SEPARATOR '\\'
234 #endif
235
236 #include "adaint.h"
237
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. */
243
244 #ifndef O_BINARY
245 #define O_BINARY 0
246 #endif
247
248 #ifndef O_TEXT
249 #define O_TEXT 0
250 #endif
251
252 #ifndef HOST_EXECUTABLE_SUFFIX
253 #define HOST_EXECUTABLE_SUFFIX ""
254 #endif
255
256 #ifndef HOST_OBJECT_SUFFIX
257 #define HOST_OBJECT_SUFFIX ".o"
258 #endif
259
260 #ifndef PATH_SEPARATOR
261 #define PATH_SEPARATOR ':'
262 #endif
263
264 #ifndef DIR_SEPARATOR
265 #define DIR_SEPARATOR '/'
266 #endif
267
268 /* Check for cross-compilation */
269 #if defined (CROSS_COMPILE) || defined (CROSS_DIRECTORY_STRUCTURE)
270 #define IS_CROSS 1
271 int __gnat_is_cross_compiler = 1;
272 #else
273 #undef IS_CROSS
274 int __gnat_is_cross_compiler = 0;
275 #endif
276
277 char __gnat_dir_separator = DIR_SEPARATOR;
278
279 char __gnat_path_separator = PATH_SEPARATOR;
280
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
285
286 library_template ::= { pattern ; } pattern NUL
287 pattern ::= [ prefix ] * [ postfix ]
288
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
292 to be up-to-date:
293
294 * if they are needed but not present, the link
295 will fail,
296
297 * otherwise they are libraries in the system paths and so
298 they are considered part of the system and not checked
299 for that reason.
300
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. */
304
305 #ifndef GNAT_LIBRARY_TEMPLATE
306 #if defined (VMS)
307 #define GNAT_LIBRARY_TEMPLATE "*.olb"
308 #else
309 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
310 #endif
311 #endif
312
313 const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE;
314
315 /* This variable is used in hostparm.ads to say whether the host is a VMS
316 system. */
317 #ifdef VMS
318 int __gnat_vmsp = 1;
319 #else
320 int __gnat_vmsp = 0;
321 #endif
322
323 #if defined (VMS)
324 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
325
326 #elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__)
327 #define GNAT_MAX_PATH_LEN PATH_MAX
328
329 #else
330
331 #if defined (__MINGW32__)
332 #include "mingw32.h"
333
334 #if OLD_MINGW
335 #include <sys/param.h>
336 #endif
337
338 #else
339 #include <sys/param.h>
340 #endif
341
342 #ifdef MAXPATHLEN
343 #define GNAT_MAX_PATH_LEN MAXPATHLEN
344 #else
345 #define GNAT_MAX_PATH_LEN 256
346 #endif
347
348 #endif
349
350 /* Used for Ada bindings */
351 int __gnat_size_of_file_attributes = sizeof (struct file_attributes);
352
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);
355
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
359 it. */
360
361 int __gnat_max_path_len = GNAT_MAX_PATH_LEN;
362 int max_path_len = GNAT_MAX_PATH_LEN;
363
364 /* Control whether we can use ACL on Windows. */
365
366 int __gnat_use_acl = 1;
367
368 /* The following macro HAVE_READDIR_R should be defined if the
369 system provides the routine readdir_r. */
370 #undef HAVE_READDIR_R
371 \f
372 #if defined(VMS) && defined (__LONG_POINTERS)
373
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 */
376
377 typedef __char_ptr32 *__char_ptr_char_ptr32 __attribute__ ((mode (SI)));
378
379 static __char_ptr_char_ptr32
380 to_ptr32 (char **ptr64)
381 {
382 int argc;
383 __char_ptr_char_ptr32 short_argv;
384
385 for (argc=0; ptr64[argc]; argc++);
386
387 /* Reallocate argv with 32 bit pointers. */
388 short_argv = (__char_ptr_char_ptr32) decc$malloc
389 (sizeof (__char_ptr32) * (argc + 1));
390
391 for (argc=0; ptr64[argc]; argc++)
392 short_argv[argc] = (__char_ptr32) decc$strdup (ptr64[argc]);
393
394 short_argv[argc] = (__char_ptr32) 0;
395 return short_argv;
396
397 }
398 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
399 #else
400 #define MAYBE_TO_PTR32(argv) argv
401 #endif
402
403 static const char ATTR_UNSET = 127;
404
405 void
406 __gnat_reset_attributes
407 (struct file_attributes* attr)
408 {
409 attr->exists = ATTR_UNSET;
410
411 attr->writable = ATTR_UNSET;
412 attr->readable = ATTR_UNSET;
413 attr->executable = ATTR_UNSET;
414
415 attr->regular = ATTR_UNSET;
416 attr->symbolic_link = ATTR_UNSET;
417 attr->directory = ATTR_UNSET;
418
419 attr->timestamp = (OS_Time)-2;
420 attr->file_length = -1;
421 }
422
423 OS_Time
424 __gnat_current_time
425 (void)
426 {
427 time_t res = time (NULL);
428 return (OS_Time) res;
429 }
430
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
433 long. */
434
435 void
436 __gnat_current_time_string
437 (char *result)
438 {
439 const char *format = "%Y-%m-%d %H:%M:%S";
440 /* Format string necessary to describe the ISO 8601 format */
441
442 const time_t t_val = time (NULL);
443
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. */
447
448 result [19] = '.';
449 result [20] = '0';
450 result [21] = '0';
451 /* The sub-seconds are manually set to zero since type time_t lacks the
452 precision necessary for nanoseconds. */
453 }
454
455 void
456 __gnat_to_gm_time
457 (OS_Time *p_time,
458 int *p_year,
459 int *p_month,
460 int *p_day,
461 int *p_hours,
462 int *p_mins,
463 int *p_secs)
464 {
465 struct tm *res;
466 time_t time = (time_t) *p_time;
467
468 #ifdef _WIN32
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. */
471 if (time & 1)
472 time++;
473 #endif
474
475 #ifdef VMS
476 res = localtime (&time);
477 #else
478 res = gmtime (&time);
479 #endif
480
481 if (res)
482 {
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;
489 }
490 else
491 *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0;
492 }
493
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. */
498
499 int
500 __gnat_readlink (char *path ATTRIBUTE_UNUSED,
501 char *buf ATTRIBUTE_UNUSED,
502 size_t bufsiz ATTRIBUTE_UNUSED)
503 {
504 #if defined (_WIN32) || defined (VMS) \
505 || defined(__vxworks) || defined (__nucleus__)
506 return -1;
507 #else
508 return readlink (path, buf, bufsiz);
509 #endif
510 }
511
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. */
515
516 int
517 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED,
518 char *newpath ATTRIBUTE_UNUSED)
519 {
520 #if defined (_WIN32) || defined (VMS) \
521 || defined(__vxworks) || defined (__nucleus__)
522 return -1;
523 #else
524 return symlink (oldpath, newpath);
525 #endif
526 }
527
528 /* Try to lock a file, return 1 if success. */
529
530 #if defined (__vxworks) || defined (__nucleus__) \
531 || defined (_WIN32) || defined (VMS)
532
533 /* Version that does not use link. */
534
535 int
536 __gnat_try_lock (char *dir, char *file)
537 {
538 int fd;
539 #ifdef __MINGW32__
540 TCHAR wfull_path[GNAT_MAX_PATH_LEN];
541 TCHAR wfile[GNAT_MAX_PATH_LEN];
542 TCHAR wdir[GNAT_MAX_PATH_LEN];
543
544 S2WSC (wdir, dir, GNAT_MAX_PATH_LEN);
545 S2WSC (wfile, file, GNAT_MAX_PATH_LEN);
546
547 _stprintf (wfull_path, _T("%s%c%s"), wdir, _T(DIR_SEPARATOR), wfile);
548 fd = _topen (wfull_path, O_CREAT | O_EXCL, 0600);
549 #else
550 char full_path[256];
551
552 sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
553 fd = open (full_path, O_CREAT | O_EXCL, 0600);
554 #endif
555
556 if (fd < 0)
557 return 0;
558
559 close (fd);
560 return 1;
561 }
562
563 #else
564
565 /* Version using link(), more secure over NFS. */
566 /* See TN 6913-016 for discussion ??? */
567
568 int
569 __gnat_try_lock (char *dir, char *file)
570 {
571 char full_path[256];
572 char temp_file[256];
573 GNAT_STRUCT_STAT stat_result;
574 int fd;
575
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 ());
579
580 /* Create the temporary file and write the process number. */
581 fd = open (temp_file, O_CREAT | O_WRONLY, 0600);
582 if (fd < 0)
583 return 0;
584
585 close (fd);
586
587 /* Link it with the new file. */
588 link (temp_file, full_path);
589
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);
593 unlink (temp_file);
594 return stat_result.st_nlink == 2;
595 }
596 #endif
597
598 /* Return the maximum file name length. */
599
600 int
601 __gnat_get_maximum_file_name_length (void)
602 {
603 #if defined (VMS)
604 if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
605 return -1;
606 else
607 return 39;
608 #else
609 return -1;
610 #endif
611 }
612
613 /* Return nonzero if file names are case sensitive. */
614
615 static int file_names_case_sensitive_cache = -1;
616
617 int
618 __gnat_get_file_names_case_sensitive (void)
619 {
620 if (file_names_case_sensitive_cache == -1)
621 {
622 const char *sensitive = getenv ("GNAT_FILE_NAME_CASE_SENSITIVE");
623
624 if (sensitive != NULL
625 && (sensitive[0] == '0' || sensitive[0] == '1')
626 && sensitive[1] == '\0')
627 file_names_case_sensitive_cache = sensitive[0] - '0';
628 else
629 #if defined (VMS) || defined (WINNT) || defined (__APPLE__)
630 file_names_case_sensitive_cache = 0;
631 #else
632 file_names_case_sensitive_cache = 1;
633 #endif
634 }
635 return file_names_case_sensitive_cache;
636 }
637
638 /* Return nonzero if environment variables are case sensitive. */
639
640 int
641 __gnat_get_env_vars_case_sensitive (void)
642 {
643 #if defined (VMS) || defined (WINNT)
644 return 0;
645 #else
646 return 1;
647 #endif
648 }
649
650 char
651 __gnat_get_default_identifier_character_set (void)
652 {
653 return '1';
654 }
655
656 /* Return the current working directory. */
657
658 void
659 __gnat_get_current_dir (char *dir, int *length)
660 {
661 #if defined (__MINGW32__)
662 TCHAR wdir[GNAT_MAX_PATH_LEN];
663
664 _tgetcwd (wdir, *length);
665
666 WS2SC (dir, wdir, GNAT_MAX_PATH_LEN);
667
668 #elif defined (VMS)
669 /* Force Unix style, which is what GNAT uses internally. */
670 getcwd (dir, *length, 0);
671 #else
672 getcwd (dir, *length);
673 #endif
674
675 *length = strlen (dir);
676
677 if (dir [*length - 1] != DIR_SEPARATOR)
678 {
679 dir [*length] = DIR_SEPARATOR;
680 ++(*length);
681 }
682 dir[*length] = '\0';
683 }
684
685 /* Return the suffix for object files. */
686
687 void
688 __gnat_get_object_suffix_ptr (int *len, const char **value)
689 {
690 *value = HOST_OBJECT_SUFFIX;
691
692 if (*value == 0)
693 *len = 0;
694 else
695 *len = strlen (*value);
696
697 return;
698 }
699
700 /* Return the suffix for executable files. */
701
702 void
703 __gnat_get_executable_suffix_ptr (int *len, const char **value)
704 {
705 *value = HOST_EXECUTABLE_SUFFIX;
706 if (!*value)
707 *len = 0;
708 else
709 *len = strlen (*value);
710
711 return;
712 }
713
714 /* Return the suffix for debuggable files. Usually this is the same as the
715 executable extension. */
716
717 void
718 __gnat_get_debuggable_suffix_ptr (int *len, const char **value)
719 {
720 *value = HOST_EXECUTABLE_SUFFIX;
721
722 if (*value == 0)
723 *len = 0;
724 else
725 *len = strlen (*value);
726
727 return;
728 }
729
730 /* Returns the OS filename and corresponding encoding. */
731
732 void
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)
737 {
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);
743 #else
744 strcpy (os_name, filename);
745 *o_length = strlen (filename);
746 *e_length = 0;
747 #endif
748 }
749
750 /* Delete a file. */
751
752 int
753 __gnat_unlink (char *path)
754 {
755 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
756 {
757 TCHAR wpath[GNAT_MAX_PATH_LEN];
758
759 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
760 return _tunlink (wpath);
761 }
762 #else
763 return unlink (path);
764 #endif
765 }
766
767 /* Rename a file. */
768
769 int
770 __gnat_rename (char *from, char *to)
771 {
772 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
773 {
774 TCHAR wfrom[GNAT_MAX_PATH_LEN], wto[GNAT_MAX_PATH_LEN];
775
776 S2WSC (wfrom, from, GNAT_MAX_PATH_LEN);
777 S2WSC (wto, to, GNAT_MAX_PATH_LEN);
778 return _trename (wfrom, wto);
779 }
780 #else
781 return rename (from, to);
782 #endif
783 }
784
785 /* Changing directory. */
786
787 int
788 __gnat_chdir (char *path)
789 {
790 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
791 {
792 TCHAR wpath[GNAT_MAX_PATH_LEN];
793
794 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
795 return _tchdir (wpath);
796 }
797 #else
798 return chdir (path);
799 #endif
800 }
801
802 /* Removing a directory. */
803
804 int
805 __gnat_rmdir (char *path)
806 {
807 #if defined (__MINGW32__) && ! defined (__vxworks) && ! defined (IS_CROSS)
808 {
809 TCHAR wpath[GNAT_MAX_PATH_LEN];
810
811 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
812 return _trmdir (wpath);
813 }
814 #elif defined (VTHREADS)
815 /* rmdir not available */
816 return -1;
817 #else
818 return rmdir (path);
819 #endif
820 }
821
822 FILE *
823 __gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED)
824 {
825 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
826 TCHAR wpath[GNAT_MAX_PATH_LEN];
827 TCHAR wmode[10];
828
829 S2WS (wmode, mode, 10);
830
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);
835 else
836 S2WS (wpath, path, GNAT_MAX_PATH_LEN);
837
838 return _tfopen (wpath, wmode);
839 #elif defined (VMS)
840 return decc$fopen (path, mode);
841 #else
842 return GNAT_FOPEN (path, mode);
843 #endif
844 }
845
846 FILE *
847 __gnat_freopen (char *path,
848 char *mode,
849 FILE *stream,
850 int encoding ATTRIBUTE_UNUSED)
851 {
852 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
853 TCHAR wpath[GNAT_MAX_PATH_LEN];
854 TCHAR wmode[10];
855
856 S2WS (wmode, mode, 10);
857
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);
862 else
863 S2WS (wpath, path, GNAT_MAX_PATH_LEN);
864
865 return _tfreopen (wpath, wmode, stream);
866 #elif defined (VMS)
867 return decc$freopen (path, mode, stream);
868 #else
869 return freopen (path, mode, stream);
870 #endif
871 }
872
873 int
874 __gnat_open_read (char *path, int fmode)
875 {
876 int fd;
877 int o_fmode = O_BINARY;
878
879 if (fmode)
880 o_fmode = O_TEXT;
881
882 #if defined (VMS)
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__)
889 {
890 TCHAR wpath[GNAT_MAX_PATH_LEN];
891
892 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
893 fd = _topen (wpath, O_RDONLY | o_fmode, 0444);
894 }
895 #else
896 fd = open (path, O_RDONLY | o_fmode);
897 #endif
898
899 return fd < 0 ? -1 : fd;
900 }
901
902 #if defined (__MINGW32__)
903 #define PERM (S_IREAD | S_IWRITE)
904 #elif defined (VMS)
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
911 files, and so on. */
912 #define PERM 0777
913 #else
914 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
915 #endif
916
917 int
918 __gnat_open_rw (char *path, int fmode)
919 {
920 int fd;
921 int o_fmode = O_BINARY;
922
923 if (fmode)
924 o_fmode = O_TEXT;
925
926 #if defined (VMS)
927 fd = open (path, O_RDWR | o_fmode, PERM,
928 "mbc=16", "deq=64", "fop=tef");
929 #elif defined (__MINGW32__)
930 {
931 TCHAR wpath[GNAT_MAX_PATH_LEN];
932
933 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
934 fd = _topen (wpath, O_RDWR | o_fmode, PERM);
935 }
936 #else
937 fd = open (path, O_RDWR | o_fmode, PERM);
938 #endif
939
940 return fd < 0 ? -1 : fd;
941 }
942
943 int
944 __gnat_open_create (char *path, int fmode)
945 {
946 int fd;
947 int o_fmode = O_BINARY;
948
949 if (fmode)
950 o_fmode = O_TEXT;
951
952 #if defined (VMS)
953 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM,
954 "mbc=16", "deq=64", "fop=tef");
955 #elif defined (__MINGW32__)
956 {
957 TCHAR wpath[GNAT_MAX_PATH_LEN];
958
959 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
960 fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
961 }
962 #else
963 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
964 #endif
965
966 return fd < 0 ? -1 : fd;
967 }
968
969 int
970 __gnat_create_output_file (char *path)
971 {
972 int fd;
973 #if defined (VMS)
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__)
978 {
979 TCHAR wpath[GNAT_MAX_PATH_LEN];
980
981 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
982 fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
983 }
984 #else
985 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
986 #endif
987
988 return fd < 0 ? -1 : fd;
989 }
990
991 int
992 __gnat_create_output_file_new (char *path)
993 {
994 int fd;
995 #if defined (VMS)
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__)
1000 {
1001 TCHAR wpath[GNAT_MAX_PATH_LEN];
1002
1003 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
1004 fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM);
1005 }
1006 #else
1007 fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM);
1008 #endif
1009
1010 return fd < 0 ? -1 : fd;
1011 }
1012
1013 int
1014 __gnat_open_append (char *path, int fmode)
1015 {
1016 int fd;
1017 int o_fmode = O_BINARY;
1018
1019 if (fmode)
1020 o_fmode = O_TEXT;
1021
1022 #if defined (VMS)
1023 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM,
1024 "mbc=16", "deq=64", "fop=tef");
1025 #elif defined (__MINGW32__)
1026 {
1027 TCHAR wpath[GNAT_MAX_PATH_LEN];
1028
1029 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
1030 fd = _topen (wpath, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
1031 }
1032 #else
1033 fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
1034 #endif
1035
1036 return fd < 0 ? -1 : fd;
1037 }
1038
1039 /* Open a new file. Return error (-1) if the file already exists. */
1040
1041 int
1042 __gnat_open_new (char *path, int fmode)
1043 {
1044 int fd;
1045 int o_fmode = O_BINARY;
1046
1047 if (fmode)
1048 o_fmode = O_TEXT;
1049
1050 #if defined (VMS)
1051 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
1052 "mbc=16", "deq=64", "fop=tef");
1053 #elif defined (__MINGW32__)
1054 {
1055 TCHAR wpath[GNAT_MAX_PATH_LEN];
1056
1057 S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
1058 fd = _topen (wpath, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
1059 }
1060 #else
1061 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
1062 #endif
1063
1064 return fd < 0 ? -1 : fd;
1065 }
1066
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. */
1070
1071 int
1072 __gnat_open_new_temp (char *path, int fmode)
1073 {
1074 int fd;
1075 int o_fmode = O_BINARY;
1076
1077 strcpy (path, "GNAT-XXXXXX");
1078
1079 #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \
1080 || defined (linux) || defined(__GLIBC__)) && !defined (__vxworks)
1081 return mkstemp (path);
1082 #elif defined (__Lynx__)
1083 mktemp (path);
1084 #elif defined (__nucleus__)
1085 return -1;
1086 #else
1087 if (mktemp (path) == NULL)
1088 return -1;
1089 #endif
1090
1091 if (fmode)
1092 o_fmode = O_TEXT;
1093
1094 #if defined (VMS)
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");
1098 #else
1099 fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
1100 #endif
1101
1102 return fd < 0 ? -1 : fd;
1103 }
1104
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 ****************************************************************/
1109
1110 void
1111 __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr)
1112 {
1113 GNAT_STRUCT_STAT statbuf;
1114 int ret;
1115
1116 if (fd != -1)
1117 ret = GNAT_FSTAT (fd, &statbuf);
1118 else
1119 ret = __gnat_stat (name, &statbuf);
1120
1121 attr->regular = (!ret && S_ISREG (statbuf.st_mode));
1122 attr->directory = (!ret && S_ISDIR (statbuf.st_mode));
1123
1124 if (!attr->regular)
1125 attr->file_length = 0;
1126 else
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
1129 either case. */
1130 attr->file_length = statbuf.st_size; /* all systems */
1131
1132 attr->exists = !ret;
1133
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));
1139 #endif
1140
1141 if (ret != 0) {
1142 attr->timestamp = (OS_Time)-1;
1143 } else {
1144 #ifdef VMS
1145 /* VMS has file versioning. */
1146 attr->timestamp = (OS_Time)statbuf.st_ctime;
1147 #else
1148 attr->timestamp = (OS_Time)statbuf.st_mtime;
1149 #endif
1150 }
1151 }
1152
1153 /****************************************************************
1154 ** Return the number of bytes in the specified file
1155 ****************************************************************/
1156
1157 long
1158 __gnat_file_length_attr (int fd, char* name, struct file_attributes* attr)
1159 {
1160 if (attr->file_length == -1) {
1161 __gnat_stat_to_attr (fd, name, attr);
1162 }
1163
1164 return attr->file_length;
1165 }
1166
1167 long
1168 __gnat_file_length (int fd)
1169 {
1170 struct file_attributes attr;
1171 __gnat_reset_attributes (&attr);
1172 return __gnat_file_length_attr (fd, NULL, &attr);
1173 }
1174
1175 long
1176 __gnat_named_file_length (char *name)
1177 {
1178 struct file_attributes attr;
1179 __gnat_reset_attributes (&attr);
1180 return __gnat_file_length_attr (-1, name, &attr);
1181 }
1182
1183 /* Create a temporary filename and put it in string pointed to by
1184 TMP_FILENAME. */
1185
1186 void
1187 __gnat_tmp_name (char *tmp_filename)
1188 {
1189 #ifdef RTX
1190 /* Variable used to create a series of unique names */
1191 static int counter = 0;
1192
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++);
1196
1197 #elif defined (__MINGW32__)
1198 {
1199 char *pname;
1200 char prefix[25];
1201
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-". */
1206
1207 sprintf (prefix, "gnat-%d-", (int)getpid());
1208 pname = (char *) _tempnam ("c:\\temp", prefix);
1209
1210 /* if pname is NULL, the file was not created properly, the disk is full
1211 or there is no more free temporary files */
1212
1213 if (pname == NULL)
1214 *tmp_filename = '\0';
1215
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. */
1218
1219 else if (pname[0] == '\\')
1220 {
1221 strcpy (tmp_filename, ".\\");
1222 strcat (tmp_filename, pname+1);
1223 }
1224 else
1225 strcpy (tmp_filename, pname);
1226
1227 free (pname);
1228 }
1229
1230 #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \
1231 || defined (__OpenBSD__) || defined(__GLIBC__)
1232 #define MAX_SAFE_PATH 1000
1233 char *tmpdir = getenv ("TMPDIR");
1234
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");
1239 else
1240 sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
1241
1242 close (mkstemp(tmp_filename));
1243 #else
1244 tmpnam (tmp_filename);
1245 #endif
1246 }
1247
1248 /* Open directory and returns a DIR pointer. */
1249
1250 DIR* __gnat_opendir (char *name)
1251 {
1252 #if defined (RTX)
1253 /* Not supported in RTX */
1254
1255 return NULL;
1256
1257 #elif defined (__MINGW32__)
1258 TCHAR wname[GNAT_MAX_PATH_LEN];
1259
1260 S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1261 return (DIR*)_topendir (wname);
1262
1263 #else
1264 return opendir (name);
1265 #endif
1266 }
1267
1268 /* Read the next entry in a directory. The returned string points somewhere
1269 in the buffer. */
1270
1271 char *
1272 __gnat_readdir (DIR *dirp, char *buffer, int *len)
1273 {
1274 #if defined (RTX)
1275 /* Not supported in RTX */
1276
1277 return NULL;
1278
1279 #elif defined (__MINGW32__)
1280 struct _tdirent *dirent = _treaddir ((_TDIR*)dirp);
1281
1282 if (dirent != NULL)
1283 {
1284 WS2SC (buffer, dirent->d_name, GNAT_MAX_PATH_LEN);
1285 *len = strlen (buffer);
1286
1287 return buffer;
1288 }
1289 else
1290 return NULL;
1291
1292 #elif defined (HAVE_READDIR_R)
1293 /* If possible, try to use the thread-safe version. */
1294 if (readdir_r (dirp, buffer) != NULL)
1295 {
1296 *len = strlen (((struct dirent*) buffer)->d_name);
1297 return ((struct dirent*) buffer)->d_name;
1298 }
1299 else
1300 return NULL;
1301
1302 #else
1303 struct dirent *dirent = (struct dirent *) readdir (dirp);
1304
1305 if (dirent != NULL)
1306 {
1307 strcpy (buffer, dirent->d_name);
1308 *len = strlen (buffer);
1309 return buffer;
1310 }
1311 else
1312 return NULL;
1313
1314 #endif
1315 }
1316
1317 /* Close a directory entry. */
1318
1319 int __gnat_closedir (DIR *dirp)
1320 {
1321 #if defined (RTX)
1322 /* Not supported in RTX */
1323
1324 return 0;
1325
1326 #elif defined (__MINGW32__)
1327 return _tclosedir ((_TDIR*)dirp);
1328
1329 #else
1330 return closedir (dirp);
1331 #endif
1332 }
1333
1334 /* Returns 1 if readdir is thread safe, 0 otherwise. */
1335
1336 int
1337 __gnat_readdir_is_thread_safe (void)
1338 {
1339 #ifdef HAVE_READDIR_R
1340 return 1;
1341 #else
1342 return 0;
1343 #endif
1344 }
1345
1346 #if defined (_WIN32) && !defined (RTX)
1347 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */
1348 static const unsigned long long w32_epoch_offset = 11644473600ULL;
1349
1350 /* Returns the file modification timestamp using Win32 routines which are
1351 immune against daylight saving time change. It is in fact not possible to
1352 use fstat for this purpose as the DST modify the st_mtime field of the
1353 stat structure. */
1354
1355 static time_t
1356 win32_filetime (HANDLE h)
1357 {
1358 union
1359 {
1360 FILETIME ft_time;
1361 unsigned long long ull_time;
1362 } t_write;
1363
1364 /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1365 since <Jan 1st 1601>. This function must return the number of seconds
1366 since <Jan 1st 1970>. */
1367
1368 if (GetFileTime (h, NULL, NULL, &t_write.ft_time))
1369 return (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset);
1370 return (time_t) 0;
1371 }
1372
1373 /* As above but starting from a FILETIME. */
1374 static void
1375 f2t (const FILETIME *ft, time_t *t)
1376 {
1377 union
1378 {
1379 FILETIME ft_time;
1380 unsigned long long ull_time;
1381 } t_write;
1382
1383 t_write.ft_time = *ft;
1384 *t = (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset);
1385 }
1386 #endif
1387
1388 /* Return a GNAT time stamp given a file name. */
1389
1390 OS_Time
1391 __gnat_file_time_name_attr (char* name, struct file_attributes* attr)
1392 {
1393 if (attr->timestamp == (OS_Time)-2) {
1394 #if defined (_WIN32) && !defined (RTX)
1395 BOOL res;
1396 WIN32_FILE_ATTRIBUTE_DATA fad;
1397 time_t ret = -1;
1398 TCHAR wname[GNAT_MAX_PATH_LEN];
1399 S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1400
1401 if ((res = GetFileAttributesEx (wname, GetFileExInfoStandard, &fad)))
1402 f2t (&fad.ftLastWriteTime, &ret);
1403 attr->timestamp = (OS_Time) ret;
1404 #else
1405 __gnat_stat_to_attr (-1, name, attr);
1406 #endif
1407 }
1408 return attr->timestamp;
1409 }
1410
1411 OS_Time
1412 __gnat_file_time_name (char *name)
1413 {
1414 struct file_attributes attr;
1415 __gnat_reset_attributes (&attr);
1416 return __gnat_file_time_name_attr (name, &attr);
1417 }
1418
1419 /* Return a GNAT time stamp given a file descriptor. */
1420
1421 OS_Time
1422 __gnat_file_time_fd_attr (int fd, struct file_attributes* attr)
1423 {
1424 if (attr->timestamp == (OS_Time)-2) {
1425 #if defined (_WIN32) && !defined (RTX)
1426 HANDLE h = (HANDLE) _get_osfhandle (fd);
1427 time_t ret = win32_filetime (h);
1428 attr->timestamp = (OS_Time) ret;
1429
1430 #else
1431 __gnat_stat_to_attr (fd, NULL, attr);
1432 #endif
1433 }
1434
1435 return attr->timestamp;
1436 }
1437
1438 OS_Time
1439 __gnat_file_time_fd (int fd)
1440 {
1441 struct file_attributes attr;
1442 __gnat_reset_attributes (&attr);
1443 return __gnat_file_time_fd_attr (fd, &attr);
1444 }
1445
1446 /* Set the file time stamp. */
1447
1448 void
1449 __gnat_set_file_time_name (char *name, time_t time_stamp)
1450 {
1451 #if defined (__vxworks)
1452
1453 /* Code to implement __gnat_set_file_time_name for these systems. */
1454
1455 #elif defined (_WIN32) && !defined (RTX)
1456 union
1457 {
1458 FILETIME ft_time;
1459 unsigned long long ull_time;
1460 } t_write;
1461 TCHAR wname[GNAT_MAX_PATH_LEN];
1462
1463 S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1464
1465 HANDLE h = CreateFile
1466 (wname, GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
1467 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS,
1468 NULL);
1469 if (h == INVALID_HANDLE_VALUE)
1470 return;
1471 /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1472 t_write.ull_time = ((unsigned long long)time_stamp + w32_epoch_offset);
1473 /* Convert to 100 nanosecond units */
1474 t_write.ull_time *= 10000000ULL;
1475
1476 SetFileTime(h, NULL, NULL, &t_write.ft_time);
1477 CloseHandle (h);
1478 return;
1479
1480 #elif defined (VMS)
1481 struct FAB fab;
1482 struct NAM nam;
1483
1484 struct
1485 {
1486 unsigned long long backup, create, expire, revise;
1487 unsigned int uic;
1488 union
1489 {
1490 unsigned short value;
1491 struct
1492 {
1493 unsigned system : 4;
1494 unsigned owner : 4;
1495 unsigned group : 4;
1496 unsigned world : 4;
1497 } bits;
1498 } prot;
1499 } Fat = { 0, 0, 0, 0, 0, { 0 }};
1500
1501 ATRDEF atrlst[]
1502 = {
1503 { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create },
1504 { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise },
1505 { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire },
1506 { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup },
1507 { ATR$S_FPRO, ATR$C_FPRO, &Fat.prot },
1508 { ATR$S_UIC, ATR$C_UIC, &Fat.uic },
1509 { 0, 0, 0}
1510 };
1511
1512 FIBDEF fib;
1513 struct dsc$descriptor_fib fibdsc = {sizeof (fib), (void *) &fib};
1514
1515 struct IOSB iosb;
1516
1517 unsigned long long newtime;
1518 unsigned long long revtime;
1519 long status;
1520 short chan;
1521
1522 struct vstring file;
1523 struct dsc$descriptor_s filedsc
1524 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) file.string};
1525 struct vstring device;
1526 struct dsc$descriptor_s devicedsc
1527 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) device.string};
1528 struct vstring timev;
1529 struct dsc$descriptor_s timedsc
1530 = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) timev.string};
1531 struct vstring result;
1532 struct dsc$descriptor_s resultdsc
1533 = {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string};
1534
1535 /* Convert parameter name (a file spec) to host file form. Note that this
1536 is needed on VMS to prepare for subsequent calls to VMS RMS library
1537 routines. Note that it would not work to call __gnat_to_host_dir_spec
1538 as was done in a previous version, since this fails silently unless
1539 the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1540 (directory not found) condition is signalled. */
1541 tryfile = (char *) __gnat_to_host_file_spec (name);
1542
1543 /* Allocate and initialize a FAB and NAM structures. */
1544 fab = cc$rms_fab;
1545 nam = cc$rms_nam;
1546
1547 nam.nam$l_esa = file.string;
1548 nam.nam$b_ess = NAM$C_MAXRSS;
1549 nam.nam$l_rsa = result.string;
1550 nam.nam$b_rss = NAM$C_MAXRSS;
1551 fab.fab$l_fna = tryfile;
1552 fab.fab$b_fns = strlen (tryfile);
1553 fab.fab$l_nam = &nam;
1554
1555 /* Validate filespec syntax and device existence. */
1556 status = SYS$PARSE (&fab, 0, 0);
1557 if ((status & 1) != 1)
1558 LIB$SIGNAL (status);
1559
1560 file.string[nam.nam$b_esl] = 0;
1561
1562 /* Find matching filespec. */
1563 status = SYS$SEARCH (&fab, 0, 0);
1564 if ((status & 1) != 1)
1565 LIB$SIGNAL (status);
1566
1567 file.string[nam.nam$b_esl] = 0;
1568 result.string[result.length=nam.nam$b_rsl] = 0;
1569
1570 /* Get the device name and assign an IO channel. */
1571 strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev);
1572 devicedsc.dsc$w_length = nam.nam$b_dev;
1573 chan = 0;
1574 status = SYS$ASSIGN (&devicedsc, &chan, 0, 0, 0);
1575 if ((status & 1) != 1)
1576 LIB$SIGNAL (status);
1577
1578 /* Initialize the FIB and fill in the directory id field. */
1579 memset (&fib, 0, sizeof (fib));
1580 fib.fib$w_did[0] = nam.nam$w_did[0];
1581 fib.fib$w_did[1] = nam.nam$w_did[1];
1582 fib.fib$w_did[2] = nam.nam$w_did[2];
1583 fib.fib$l_acctl = 0;
1584 fib.fib$l_wcc = 0;
1585 strcpy (file.string, (strrchr (result.string, ']') + 1));
1586 filedsc.dsc$w_length = strlen (file.string);
1587 result.string[result.length = 0] = 0;
1588
1589 /* Open and close the file to fill in the attributes. */
1590 status
1591 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1592 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1593 if ((status & 1) != 1)
1594 LIB$SIGNAL (status);
1595 if ((iosb.status & 1) != 1)
1596 LIB$SIGNAL (iosb.status);
1597
1598 result.string[result.length] = 0;
1599 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, &fibdsc, 0, 0, 0,
1600 &atrlst, 0);
1601 if ((status & 1) != 1)
1602 LIB$SIGNAL (status);
1603 if ((iosb.status & 1) != 1)
1604 LIB$SIGNAL (iosb.status);
1605
1606 {
1607 time_t t;
1608
1609 /* Set creation time to requested time. */
1610 unix_time_to_vms (time_stamp, newtime);
1611
1612 t = time ((time_t) 0);
1613
1614 /* Set revision time to now in local time. */
1615 unix_time_to_vms (t, revtime);
1616 }
1617
1618 /* Reopen the file, modify the times and then close. */
1619 fib.fib$l_acctl = FIB$M_WRITE;
1620 status
1621 = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1622 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1623 if ((status & 1) != 1)
1624 LIB$SIGNAL (status);
1625 if ((iosb.status & 1) != 1)
1626 LIB$SIGNAL (iosb.status);
1627
1628 Fat.create = newtime;
1629 Fat.revise = revtime;
1630
1631 status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0,
1632 &fibdsc, 0, 0, 0, &atrlst, 0);
1633 if ((status & 1) != 1)
1634 LIB$SIGNAL (status);
1635 if ((iosb.status & 1) != 1)
1636 LIB$SIGNAL (iosb.status);
1637
1638 /* Deassign the channel and exit. */
1639 status = SYS$DASSGN (chan);
1640 if ((status & 1) != 1)
1641 LIB$SIGNAL (status);
1642 #else
1643 struct utimbuf utimbuf;
1644 time_t t;
1645
1646 /* Set modification time to requested time. */
1647 utimbuf.modtime = time_stamp;
1648
1649 /* Set access time to now in local time. */
1650 t = time ((time_t) 0);
1651 utimbuf.actime = mktime (localtime (&t));
1652
1653 utime (name, &utimbuf);
1654 #endif
1655 }
1656
1657 /* Get the list of installed standard libraries from the
1658 HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1659 key. */
1660
1661 char *
1662 __gnat_get_libraries_from_registry (void)
1663 {
1664 char *result = (char *) xmalloc (1);
1665
1666 result[0] = '\0';
1667
1668 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) \
1669 && ! defined (RTX)
1670
1671 HKEY reg_key;
1672 DWORD name_size, value_size;
1673 char name[256];
1674 char value[256];
1675 DWORD type;
1676 DWORD index;
1677 LONG res;
1678
1679 /* First open the key. */
1680 res = RegOpenKeyExA (HKEY_LOCAL_MACHINE, "SOFTWARE", 0, KEY_READ, &reg_key);
1681
1682 if (res == ERROR_SUCCESS)
1683 res = RegOpenKeyExA (reg_key, "Ada Core Technologies", 0,
1684 KEY_READ, &reg_key);
1685
1686 if (res == ERROR_SUCCESS)
1687 res = RegOpenKeyExA (reg_key, "GNAT", 0, KEY_READ, &reg_key);
1688
1689 if (res == ERROR_SUCCESS)
1690 res = RegOpenKeyExA (reg_key, "Standard Libraries", 0, KEY_READ, &reg_key);
1691
1692 /* If the key exists, read out all the values in it and concatenate them
1693 into a path. */
1694 for (index = 0; res == ERROR_SUCCESS; index++)
1695 {
1696 value_size = name_size = 256;
1697 res = RegEnumValueA (reg_key, index, name, &name_size, 0,
1698 &type, (LPBYTE)value, &value_size);
1699
1700 if (res == ERROR_SUCCESS && type == REG_SZ)
1701 {
1702 char *old_result = result;
1703
1704 result = (char *) xmalloc (strlen (old_result) + value_size + 2);
1705 strcpy (result, old_result);
1706 strcat (result, value);
1707 strcat (result, ";");
1708 free (old_result);
1709 }
1710 }
1711
1712 /* Remove the trailing ";". */
1713 if (result[0] != 0)
1714 result[strlen (result) - 1] = 0;
1715
1716 #endif
1717 return result;
1718 }
1719
1720 int
1721 __gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf)
1722 {
1723 #ifdef __MINGW32__
1724 WIN32_FILE_ATTRIBUTE_DATA fad;
1725 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1726 int name_len;
1727 BOOL res;
1728 DWORD error;
1729
1730 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
1731 name_len = _tcslen (wname);
1732
1733 if (name_len > GNAT_MAX_PATH_LEN)
1734 return -1;
1735
1736 ZeroMemory (statbuf, sizeof(GNAT_STRUCT_STAT));
1737
1738 res = GetFileAttributesEx (wname, GetFileExInfoStandard, &fad);
1739
1740 if (res == FALSE) {
1741 error = GetLastError();
1742
1743 /* Check file existence using GetFileAttributes() which does not fail on
1744 special Windows files like con:, aux:, nul: etc... */
1745
1746 if (GetFileAttributes(wname) != INVALID_FILE_ATTRIBUTES) {
1747 /* Just pretend that it is a regular and readable file */
1748 statbuf->st_mode = S_IFREG | S_IREAD | S_IWRITE;
1749 return 0;
1750 }
1751
1752 switch (error) {
1753 case ERROR_ACCESS_DENIED:
1754 case ERROR_SHARING_VIOLATION:
1755 case ERROR_LOCK_VIOLATION:
1756 case ERROR_SHARING_BUFFER_EXCEEDED:
1757 return EACCES;
1758 case ERROR_BUFFER_OVERFLOW:
1759 return ENAMETOOLONG;
1760 case ERROR_NOT_ENOUGH_MEMORY:
1761 return ENOMEM;
1762 default:
1763 return ENOENT;
1764 }
1765 }
1766
1767 f2t (&fad.ftCreationTime, &statbuf->st_ctime);
1768 f2t (&fad.ftLastWriteTime, &statbuf->st_mtime);
1769 f2t (&fad.ftLastAccessTime, &statbuf->st_atime);
1770
1771 statbuf->st_size = (off_t)fad.nFileSizeLow;
1772
1773 /* We do not have the S_IEXEC attribute, but this is not used on GNAT. */
1774 statbuf->st_mode = S_IREAD;
1775
1776 if (fad.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY)
1777 statbuf->st_mode |= S_IFDIR;
1778 else
1779 statbuf->st_mode |= S_IFREG;
1780
1781 if (!(fad.dwFileAttributes & FILE_ATTRIBUTE_READONLY))
1782 statbuf->st_mode |= S_IWRITE;
1783
1784 return 0;
1785
1786 #else
1787 return GNAT_STAT (name, statbuf);
1788 #endif
1789 }
1790
1791 /*************************************************************************
1792 ** Check whether a file exists
1793 *************************************************************************/
1794
1795 int
1796 __gnat_file_exists_attr (char* name, struct file_attributes* attr)
1797 {
1798 if (attr->exists == ATTR_UNSET) {
1799 __gnat_stat_to_attr (-1, name, attr);
1800 }
1801
1802 return attr->exists;
1803 }
1804
1805 int
1806 __gnat_file_exists (char *name)
1807 {
1808 struct file_attributes attr;
1809 __gnat_reset_attributes (&attr);
1810 return __gnat_file_exists_attr (name, &attr);
1811 }
1812
1813 /**********************************************************************
1814 ** Whether name is an absolute path
1815 **********************************************************************/
1816
1817 int
1818 __gnat_is_absolute_path (char *name, int length)
1819 {
1820 #ifdef __vxworks
1821 /* On VxWorks systems, an absolute path can be represented (depending on
1822 the host platform) as either /dir/file, or device:/dir/file, or
1823 device:drive_letter:/dir/file. */
1824
1825 int index;
1826
1827 if (name[0] == '/')
1828 return 1;
1829
1830 for (index = 0; index < length; index++)
1831 {
1832 if (name[index] == ':' &&
1833 ((name[index + 1] == '/') ||
1834 (isalpha (name[index + 1]) && index + 2 <= length &&
1835 name[index + 2] == '/')))
1836 return 1;
1837
1838 else if (name[index] == '/')
1839 return 0;
1840 }
1841 return 0;
1842 #else
1843 return (length != 0) &&
1844 (*name == '/' || *name == DIR_SEPARATOR
1845 #if defined (WINNT)
1846 || (length > 1 && ISALPHA (name[0]) && name[1] == ':')
1847 #endif
1848 );
1849 #endif
1850 }
1851
1852 int
1853 __gnat_is_regular_file_attr (char* name, struct file_attributes* attr)
1854 {
1855 if (attr->regular == ATTR_UNSET) {
1856 __gnat_stat_to_attr (-1, name, attr);
1857 }
1858
1859 return attr->regular;
1860 }
1861
1862 int
1863 __gnat_is_regular_file (char *name)
1864 {
1865 struct file_attributes attr;
1866 __gnat_reset_attributes (&attr);
1867 return __gnat_is_regular_file_attr (name, &attr);
1868 }
1869
1870 int
1871 __gnat_is_directory_attr (char* name, struct file_attributes* attr)
1872 {
1873 if (attr->directory == ATTR_UNSET) {
1874 __gnat_stat_to_attr (-1, name, attr);
1875 }
1876
1877 return attr->directory;
1878 }
1879
1880 int
1881 __gnat_is_directory (char *name)
1882 {
1883 struct file_attributes attr;
1884 __gnat_reset_attributes (&attr);
1885 return __gnat_is_directory_attr (name, &attr);
1886 }
1887
1888 #if defined (_WIN32) && !defined (RTX)
1889
1890 /* Returns the same constant as GetDriveType but takes a pathname as
1891 argument. */
1892
1893 static UINT
1894 GetDriveTypeFromPath (TCHAR *wfullpath)
1895 {
1896 TCHAR wdrv[MAX_PATH];
1897 TCHAR wpath[MAX_PATH];
1898 TCHAR wfilename[MAX_PATH];
1899 TCHAR wext[MAX_PATH];
1900
1901 _tsplitpath (wfullpath, wdrv, wpath, wfilename, wext);
1902
1903 if (_tcslen (wdrv) != 0)
1904 {
1905 /* we have a drive specified. */
1906 _tcscat (wdrv, _T("\\"));
1907 return GetDriveType (wdrv);
1908 }
1909 else
1910 {
1911 /* No drive specified. */
1912
1913 /* Is this a relative path, if so get current drive type. */
1914 if (wpath[0] != _T('\\') ||
1915 (_tcslen (wpath) > 2 && wpath[0] == _T('\\') && wpath[1] != _T('\\')))
1916 return GetDriveType (NULL);
1917
1918 UINT result = GetDriveType (wpath);
1919
1920 /* Cannot guess the drive type, is this \\.\ ? */
1921
1922 if (result == DRIVE_NO_ROOT_DIR &&
1923 _tcslen (wpath) >= 4 && wpath[0] == _T('\\') && wpath[1] == _T('\\')
1924 && wpath[2] == _T('.') && wpath[3] == _T('\\'))
1925 {
1926 if (_tcslen (wpath) == 4)
1927 _tcscat (wpath, wfilename);
1928
1929 LPTSTR p = &wpath[4];
1930 LPTSTR b = _tcschr (p, _T('\\'));
1931
1932 if (b != NULL)
1933 { /* logical drive \\.\c\dir\file */
1934 *b++ = _T(':');
1935 *b++ = _T('\\');
1936 *b = _T('\0');
1937 }
1938 else
1939 _tcscat (p, _T(":\\"));
1940
1941 return GetDriveType (p);
1942 }
1943
1944 return result;
1945 }
1946 }
1947
1948 /* This MingW section contains code to work with ACL. */
1949 static int
1950 __gnat_check_OWNER_ACL
1951 (TCHAR *wname,
1952 DWORD CheckAccessDesired,
1953 GENERIC_MAPPING CheckGenericMapping)
1954 {
1955 DWORD dwAccessDesired, dwAccessAllowed;
1956 PRIVILEGE_SET PrivilegeSet;
1957 DWORD dwPrivSetSize = sizeof (PRIVILEGE_SET);
1958 BOOL fAccessGranted = FALSE;
1959 HANDLE hToken = NULL;
1960 DWORD nLength = 0;
1961 SECURITY_DESCRIPTOR* pSD = NULL;
1962
1963 GetFileSecurity
1964 (wname, OWNER_SECURITY_INFORMATION |
1965 GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION,
1966 NULL, 0, &nLength);
1967
1968 if ((pSD = (PSECURITY_DESCRIPTOR) HeapAlloc
1969 (GetProcessHeap (), HEAP_ZERO_MEMORY, nLength)) == NULL)
1970 return 0;
1971
1972 /* Obtain the security descriptor. */
1973
1974 if (!GetFileSecurity
1975 (wname, OWNER_SECURITY_INFORMATION |
1976 GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION,
1977 pSD, nLength, &nLength))
1978 goto error;
1979
1980 if (!ImpersonateSelf (SecurityImpersonation))
1981 goto error;
1982
1983 if (!OpenThreadToken
1984 (GetCurrentThread(), TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken))
1985 goto error;
1986
1987 /* Undoes the effect of ImpersonateSelf. */
1988
1989 RevertToSelf ();
1990
1991 /* We want to test for write permissions. */
1992
1993 dwAccessDesired = CheckAccessDesired;
1994
1995 MapGenericMask (&dwAccessDesired, &CheckGenericMapping);
1996
1997 if (!AccessCheck
1998 (pSD , /* security descriptor to check */
1999 hToken, /* impersonation token */
2000 dwAccessDesired, /* requested access rights */
2001 &CheckGenericMapping, /* pointer to GENERIC_MAPPING */
2002 &PrivilegeSet, /* receives privileges used in check */
2003 &dwPrivSetSize, /* size of PrivilegeSet buffer */
2004 &dwAccessAllowed, /* receives mask of allowed access rights */
2005 &fAccessGranted))
2006 goto error;
2007
2008 CloseHandle (hToken);
2009 HeapFree (GetProcessHeap (), 0, pSD);
2010 return fAccessGranted;
2011
2012 error:
2013 if (hToken)
2014 CloseHandle (hToken);
2015 HeapFree (GetProcessHeap (), 0, pSD);
2016 return 0;
2017 }
2018
2019 static void
2020 __gnat_set_OWNER_ACL
2021 (TCHAR *wname,
2022 DWORD AccessMode,
2023 DWORD AccessPermissions)
2024 {
2025 PACL pOldDACL = NULL;
2026 PACL pNewDACL = NULL;
2027 PSECURITY_DESCRIPTOR pSD = NULL;
2028 EXPLICIT_ACCESS ea;
2029 TCHAR username [100];
2030 DWORD unsize = 100;
2031
2032 /* Get current user, he will act as the owner */
2033
2034 if (!GetUserName (username, &unsize))
2035 return;
2036
2037 if (GetNamedSecurityInfo
2038 (wname,
2039 SE_FILE_OBJECT,
2040 DACL_SECURITY_INFORMATION,
2041 NULL, NULL, &pOldDACL, NULL, &pSD) != ERROR_SUCCESS)
2042 return;
2043
2044 BuildExplicitAccessWithName
2045 (&ea, username, AccessPermissions, AccessMode, NO_INHERITANCE);
2046
2047 if (AccessMode == SET_ACCESS)
2048 {
2049 /* SET_ACCESS, we want to set an explicte set of permissions, do not
2050 merge with current DACL. */
2051 if (SetEntriesInAcl (1, &ea, NULL, &pNewDACL) != ERROR_SUCCESS)
2052 return;
2053 }
2054 else
2055 if (SetEntriesInAcl (1, &ea, pOldDACL, &pNewDACL) != ERROR_SUCCESS)
2056 return;
2057
2058 if (SetNamedSecurityInfo
2059 (wname, SE_FILE_OBJECT,
2060 DACL_SECURITY_INFORMATION, NULL, NULL, pNewDACL, NULL) != ERROR_SUCCESS)
2061 return;
2062
2063 LocalFree (pSD);
2064 LocalFree (pNewDACL);
2065 }
2066
2067 /* Check if it is possible to use ACL for wname, the file must not be on a
2068 network drive. */
2069
2070 static int
2071 __gnat_can_use_acl (TCHAR *wname)
2072 {
2073 return __gnat_use_acl && GetDriveTypeFromPath (wname) != DRIVE_REMOTE;
2074 }
2075
2076 #endif /* defined (_WIN32) && !defined (RTX) */
2077
2078 int
2079 __gnat_is_readable_file_attr (char* name, struct file_attributes* attr)
2080 {
2081 if (attr->readable == ATTR_UNSET) {
2082 #if defined (_WIN32) && !defined (RTX)
2083 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2084 GENERIC_MAPPING GenericMapping;
2085
2086 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2087
2088 if (__gnat_can_use_acl (wname))
2089 {
2090 ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
2091 GenericMapping.GenericRead = GENERIC_READ;
2092 attr->readable =
2093 __gnat_check_OWNER_ACL (wname, FILE_READ_DATA, GenericMapping);
2094 }
2095 else
2096 attr->readable = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES;
2097 #else
2098 __gnat_stat_to_attr (-1, name, attr);
2099 #endif
2100 }
2101
2102 return attr->readable;
2103 }
2104
2105 int
2106 __gnat_is_readable_file (char *name)
2107 {
2108 struct file_attributes attr;
2109 __gnat_reset_attributes (&attr);
2110 return __gnat_is_readable_file_attr (name, &attr);
2111 }
2112
2113 int
2114 __gnat_is_writable_file_attr (char* name, struct file_attributes* attr)
2115 {
2116 if (attr->writable == ATTR_UNSET) {
2117 #if defined (_WIN32) && !defined (RTX)
2118 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2119 GENERIC_MAPPING GenericMapping;
2120
2121 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2122
2123 if (__gnat_can_use_acl (wname))
2124 {
2125 ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
2126 GenericMapping.GenericWrite = GENERIC_WRITE;
2127
2128 attr->writable = __gnat_check_OWNER_ACL
2129 (wname, FILE_WRITE_DATA | FILE_APPEND_DATA, GenericMapping)
2130 && !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY);
2131 }
2132 else
2133 attr->writable = !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY);
2134
2135 #else
2136 __gnat_stat_to_attr (-1, name, attr);
2137 #endif
2138 }
2139
2140 return attr->writable;
2141 }
2142
2143 int
2144 __gnat_is_writable_file (char *name)
2145 {
2146 struct file_attributes attr;
2147 __gnat_reset_attributes (&attr);
2148 return __gnat_is_writable_file_attr (name, &attr);
2149 }
2150
2151 int
2152 __gnat_is_executable_file_attr (char* name, struct file_attributes* attr)
2153 {
2154 if (attr->executable == ATTR_UNSET) {
2155 #if defined (_WIN32) && !defined (RTX)
2156 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2157 GENERIC_MAPPING GenericMapping;
2158
2159 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2160
2161 if (__gnat_can_use_acl (wname))
2162 {
2163 ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
2164 GenericMapping.GenericExecute = GENERIC_EXECUTE;
2165
2166 attr->executable =
2167 __gnat_check_OWNER_ACL (wname, FILE_EXECUTE, GenericMapping);
2168 }
2169 else
2170 {
2171 TCHAR *l, *last = _tcsstr(wname, _T(".exe"));
2172
2173 /* look for last .exe */
2174 if (last)
2175 while (l = _tcsstr(last+1, _T(".exe"))) last = l;
2176
2177 attr->executable = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES
2178 && last - wname == (int) (_tcslen (wname) - 4);
2179 }
2180 #else
2181 __gnat_stat_to_attr (-1, name, attr);
2182 #endif
2183 }
2184
2185 return attr->executable;
2186 }
2187
2188 int
2189 __gnat_is_executable_file (char *name)
2190 {
2191 struct file_attributes attr;
2192 __gnat_reset_attributes (&attr);
2193 return __gnat_is_executable_file_attr (name, &attr);
2194 }
2195
2196 void
2197 __gnat_set_writable (char *name)
2198 {
2199 #if defined (_WIN32) && !defined (RTX)
2200 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2201
2202 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2203
2204 if (__gnat_can_use_acl (wname))
2205 __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_WRITE);
2206
2207 SetFileAttributes
2208 (wname, GetFileAttributes (wname) & ~FILE_ATTRIBUTE_READONLY);
2209 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2210 ! defined(__nucleus__)
2211 GNAT_STRUCT_STAT statbuf;
2212
2213 if (GNAT_STAT (name, &statbuf) == 0)
2214 {
2215 statbuf.st_mode = statbuf.st_mode | S_IWUSR;
2216 chmod (name, statbuf.st_mode);
2217 }
2218 #endif
2219 }
2220
2221 void
2222 __gnat_set_executable (char *name)
2223 {
2224 #if defined (_WIN32) && !defined (RTX)
2225 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2226
2227 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2228
2229 if (__gnat_can_use_acl (wname))
2230 __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_EXECUTE);
2231
2232 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2233 ! defined(__nucleus__)
2234 GNAT_STRUCT_STAT statbuf;
2235
2236 if (GNAT_STAT (name, &statbuf) == 0)
2237 {
2238 statbuf.st_mode = statbuf.st_mode | S_IXUSR;
2239 chmod (name, statbuf.st_mode);
2240 }
2241 #endif
2242 }
2243
2244 void
2245 __gnat_set_non_writable (char *name)
2246 {
2247 #if defined (_WIN32) && !defined (RTX)
2248 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2249
2250 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2251
2252 if (__gnat_can_use_acl (wname))
2253 __gnat_set_OWNER_ACL
2254 (wname, DENY_ACCESS,
2255 FILE_WRITE_DATA | FILE_APPEND_DATA |
2256 FILE_WRITE_EA | FILE_WRITE_ATTRIBUTES);
2257
2258 SetFileAttributes
2259 (wname, GetFileAttributes (wname) | FILE_ATTRIBUTE_READONLY);
2260 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2261 ! defined(__nucleus__)
2262 GNAT_STRUCT_STAT statbuf;
2263
2264 if (GNAT_STAT (name, &statbuf) == 0)
2265 {
2266 statbuf.st_mode = statbuf.st_mode & 07577;
2267 chmod (name, statbuf.st_mode);
2268 }
2269 #endif
2270 }
2271
2272 void
2273 __gnat_set_readable (char *name)
2274 {
2275 #if defined (_WIN32) && !defined (RTX)
2276 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2277
2278 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2279
2280 if (__gnat_can_use_acl (wname))
2281 __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_READ);
2282
2283 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2284 ! defined(__nucleus__)
2285 GNAT_STRUCT_STAT statbuf;
2286
2287 if (GNAT_STAT (name, &statbuf) == 0)
2288 {
2289 chmod (name, statbuf.st_mode | S_IREAD);
2290 }
2291 #endif
2292 }
2293
2294 void
2295 __gnat_set_non_readable (char *name)
2296 {
2297 #if defined (_WIN32) && !defined (RTX)
2298 TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2299
2300 S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2301
2302 if (__gnat_can_use_acl (wname))
2303 __gnat_set_OWNER_ACL (wname, DENY_ACCESS, FILE_GENERIC_READ);
2304
2305 #elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \
2306 ! defined(__nucleus__)
2307 GNAT_STRUCT_STAT statbuf;
2308
2309 if (GNAT_STAT (name, &statbuf) == 0)
2310 {
2311 chmod (name, statbuf.st_mode & (~S_IREAD));
2312 }
2313 #endif
2314 }
2315
2316 int
2317 __gnat_is_symbolic_link_attr (char* name ATTRIBUTE_UNUSED,
2318 struct file_attributes* attr)
2319 {
2320 if (attr->symbolic_link == ATTR_UNSET) {
2321 #if defined (__vxworks) || defined (__nucleus__)
2322 attr->symbolic_link = 0;
2323
2324 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
2325 int ret;
2326 GNAT_STRUCT_STAT statbuf;
2327 ret = GNAT_LSTAT (name, &statbuf);
2328 attr->symbolic_link = (!ret && S_ISLNK (statbuf.st_mode));
2329 #else
2330 attr->symbolic_link = 0;
2331 #endif
2332 }
2333 return attr->symbolic_link;
2334 }
2335
2336 int
2337 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED)
2338 {
2339 struct file_attributes attr;
2340 __gnat_reset_attributes (&attr);
2341 return __gnat_is_symbolic_link_attr (name, &attr);
2342
2343 }
2344
2345 #if defined (sun) && defined (__SVR4)
2346 /* Using fork on Solaris will duplicate all the threads. fork1, which
2347 duplicates only the active thread, must be used instead, or spawning
2348 subprocess from a program with tasking will lead into numerous problems. */
2349 #define fork fork1
2350 #endif
2351
2352 int
2353 __gnat_portable_spawn (char *args[])
2354 {
2355 int status = 0;
2356 int finished ATTRIBUTE_UNUSED;
2357 int pid ATTRIBUTE_UNUSED;
2358
2359 #if defined (__vxworks) || defined(__nucleus__) || defined(RTX)
2360 return -1;
2361
2362 #elif defined (_WIN32)
2363 /* args[0] must be quotes as it could contain a full pathname with spaces */
2364 char *args_0 = args[0];
2365 args[0] = (char *)xmalloc (strlen (args_0) + 3);
2366 strcpy (args[0], "\"");
2367 strcat (args[0], args_0);
2368 strcat (args[0], "\"");
2369
2370 status = spawnvp (P_WAIT, args_0, (const char* const*)args);
2371
2372 /* restore previous value */
2373 free (args[0]);
2374 args[0] = (char *)args_0;
2375
2376 if (status < 0)
2377 return -1;
2378 else
2379 return status;
2380
2381 #else
2382
2383 pid = fork ();
2384 if (pid < 0)
2385 return -1;
2386
2387 if (pid == 0)
2388 {
2389 /* The child. */
2390 if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
2391 #if defined (VMS)
2392 return -1; /* execv is in parent context on VMS. */
2393 #else
2394 _exit (1);
2395 #endif
2396 }
2397
2398 /* The parent. */
2399 finished = waitpid (pid, &status, 0);
2400
2401 if (finished != pid || WIFEXITED (status) == 0)
2402 return -1;
2403
2404 return WEXITSTATUS (status);
2405 #endif
2406
2407 return 0;
2408 }
2409
2410 /* Create a copy of the given file descriptor.
2411 Return -1 if an error occurred. */
2412
2413 int
2414 __gnat_dup (int oldfd)
2415 {
2416 #if defined (__vxworks) && !defined (__RTP__)
2417 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2418 RTPs. */
2419 return -1;
2420 #else
2421 return dup (oldfd);
2422 #endif
2423 }
2424
2425 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
2426 Return -1 if an error occurred. */
2427
2428 int
2429 __gnat_dup2 (int oldfd, int newfd)
2430 {
2431 #if defined (__vxworks) && !defined (__RTP__)
2432 /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2433 RTPs. */
2434 return -1;
2435 #else
2436 return dup2 (oldfd, newfd);
2437 #endif
2438 }
2439
2440 int
2441 __gnat_number_of_cpus (void)
2442 {
2443 int cores = 1;
2444
2445 #if defined (linux) || defined (sun) || defined (AIX) \
2446 || (defined (__alpha__) && defined (_osf_)) || defined (__APPLE__)
2447 cores = (int) sysconf (_SC_NPROCESSORS_ONLN);
2448
2449 #elif (defined (__mips) && defined (__sgi))
2450 cores = (int) sysconf (_SC_NPROC_ONLN);
2451
2452 #elif defined (__hpux__)
2453 struct pst_dynamic psd;
2454 if (pstat_getdynamic (&psd, sizeof (psd), 1, 0) != -1)
2455 cores = (int) psd.psd_proc_cnt;
2456
2457 #elif defined (_WIN32)
2458 SYSTEM_INFO sysinfo;
2459 GetSystemInfo (&sysinfo);
2460 cores = (int) sysinfo.dwNumberOfProcessors;
2461
2462 #elif defined (VMS)
2463 int code = SYI$_ACTIVECPU_CNT;
2464 unsigned int res;
2465 int status;
2466
2467 status = LIB$GETSYI (&code, &res);
2468 if ((status & 1) != 0)
2469 cores = res;
2470
2471 #elif defined (_WRS_CONFIG_SMP)
2472 unsigned int vxCpuConfiguredGet (void);
2473
2474 cores = vxCpuConfiguredGet ();
2475
2476 #endif
2477
2478 return cores;
2479 }
2480
2481 /* WIN32 code to implement a wait call that wait for any child process. */
2482
2483 #if defined (_WIN32) && !defined (RTX)
2484
2485 /* Synchronization code, to be thread safe. */
2486
2487 #ifdef CERT
2488
2489 /* For the Cert run times on native Windows we use dummy functions
2490 for locking and unlocking tasks since we do not support multiple
2491 threads on this configuration (Cert run time on native Windows). */
2492
2493 void dummy (void) {}
2494
2495 void (*Lock_Task) () = &dummy;
2496 void (*Unlock_Task) () = &dummy;
2497
2498 #else
2499
2500 #define Lock_Task system__soft_links__lock_task
2501 extern void (*Lock_Task) (void);
2502
2503 #define Unlock_Task system__soft_links__unlock_task
2504 extern void (*Unlock_Task) (void);
2505
2506 #endif
2507
2508 static HANDLE *HANDLES_LIST = NULL;
2509 static int *PID_LIST = NULL, plist_length = 0, plist_max_length = 0;
2510
2511 static void
2512 add_handle (HANDLE h, int pid)
2513 {
2514
2515 /* -------------------- critical section -------------------- */
2516 (*Lock_Task) ();
2517
2518 if (plist_length == plist_max_length)
2519 {
2520 plist_max_length += 1000;
2521 HANDLES_LIST =
2522 xrealloc (HANDLES_LIST, sizeof (HANDLE) * plist_max_length);
2523 PID_LIST =
2524 xrealloc (PID_LIST, sizeof (int) * plist_max_length);
2525 }
2526
2527 HANDLES_LIST[plist_length] = h;
2528 PID_LIST[plist_length] = pid;
2529 ++plist_length;
2530
2531 (*Unlock_Task) ();
2532 /* -------------------- critical section -------------------- */
2533 }
2534
2535 void
2536 __gnat_win32_remove_handle (HANDLE h, int pid)
2537 {
2538 int j;
2539
2540 /* -------------------- critical section -------------------- */
2541 (*Lock_Task) ();
2542
2543 for (j = 0; j < plist_length; j++)
2544 {
2545 if ((HANDLES_LIST[j] == h) || (PID_LIST[j] == pid))
2546 {
2547 CloseHandle (h);
2548 --plist_length;
2549 HANDLES_LIST[j] = HANDLES_LIST[plist_length];
2550 PID_LIST[j] = PID_LIST[plist_length];
2551 break;
2552 }
2553 }
2554
2555 (*Unlock_Task) ();
2556 /* -------------------- critical section -------------------- */
2557 }
2558
2559 static void
2560 win32_no_block_spawn (char *command, char *args[], HANDLE *h, int *pid)
2561 {
2562 BOOL result;
2563 STARTUPINFO SI;
2564 PROCESS_INFORMATION PI;
2565 SECURITY_ATTRIBUTES SA;
2566 int csize = 1;
2567 char *full_command;
2568 int k;
2569
2570 /* compute the total command line length */
2571 k = 0;
2572 while (args[k])
2573 {
2574 csize += strlen (args[k]) + 1;
2575 k++;
2576 }
2577
2578 full_command = (char *) xmalloc (csize);
2579
2580 /* Startup info. */
2581 SI.cb = sizeof (STARTUPINFO);
2582 SI.lpReserved = NULL;
2583 SI.lpReserved2 = NULL;
2584 SI.lpDesktop = NULL;
2585 SI.cbReserved2 = 0;
2586 SI.lpTitle = NULL;
2587 SI.dwFlags = 0;
2588 SI.wShowWindow = SW_HIDE;
2589
2590 /* Security attributes. */
2591 SA.nLength = sizeof (SECURITY_ATTRIBUTES);
2592 SA.bInheritHandle = TRUE;
2593 SA.lpSecurityDescriptor = NULL;
2594
2595 /* Prepare the command string. */
2596 strcpy (full_command, command);
2597 strcat (full_command, " ");
2598
2599 k = 1;
2600 while (args[k])
2601 {
2602 strcat (full_command, args[k]);
2603 strcat (full_command, " ");
2604 k++;
2605 }
2606
2607 {
2608 int wsize = csize * 2;
2609 TCHAR *wcommand = (TCHAR *) xmalloc (wsize);
2610
2611 S2WSC (wcommand, full_command, wsize);
2612
2613 free (full_command);
2614
2615 result = CreateProcess
2616 (NULL, wcommand, &SA, NULL, TRUE,
2617 GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
2618
2619 free (wcommand);
2620 }
2621
2622 if (result == TRUE)
2623 {
2624 CloseHandle (PI.hThread);
2625 *h = PI.hProcess;
2626 *pid = PI.dwProcessId;
2627 }
2628 else
2629 {
2630 *h = NULL;
2631 *pid = 0;
2632 }
2633 }
2634
2635 static int
2636 win32_wait (int *status)
2637 {
2638 DWORD exitcode, pid;
2639 HANDLE *hl;
2640 HANDLE h;
2641 DWORD res;
2642 int k;
2643 int hl_len;
2644
2645 if (plist_length == 0)
2646 {
2647 errno = ECHILD;
2648 return -1;
2649 }
2650
2651 k = 0;
2652
2653 /* -------------------- critical section -------------------- */
2654 (*Lock_Task) ();
2655
2656 hl_len = plist_length;
2657
2658 hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len);
2659
2660 memmove (hl, HANDLES_LIST, sizeof (HANDLE) * hl_len);
2661
2662 (*Unlock_Task) ();
2663 /* -------------------- critical section -------------------- */
2664
2665 res = WaitForMultipleObjects (hl_len, hl, FALSE, INFINITE);
2666 h = hl[res - WAIT_OBJECT_0];
2667
2668 GetExitCodeProcess (h, &exitcode);
2669 pid = PID_LIST [res - WAIT_OBJECT_0];
2670 __gnat_win32_remove_handle (h, -1);
2671
2672 free (hl);
2673
2674 *status = (int) exitcode;
2675 return (int) pid;
2676 }
2677
2678 #endif
2679
2680 int
2681 __gnat_portable_no_block_spawn (char *args[])
2682 {
2683
2684 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2685 return -1;
2686
2687 #elif defined (_WIN32)
2688
2689 HANDLE h = NULL;
2690 int pid;
2691
2692 win32_no_block_spawn (args[0], args, &h, &pid);
2693 if (h != NULL)
2694 {
2695 add_handle (h, pid);
2696 return pid;
2697 }
2698 else
2699 return -1;
2700
2701 #else
2702
2703 int pid = fork ();
2704
2705 if (pid == 0)
2706 {
2707 /* The child. */
2708 if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
2709 #if defined (VMS)
2710 return -1; /* execv is in parent context on VMS. */
2711 #else
2712 _exit (1);
2713 #endif
2714 }
2715
2716 return pid;
2717
2718 #endif
2719 }
2720
2721 int
2722 __gnat_portable_wait (int *process_status)
2723 {
2724 int status = 0;
2725 int pid = 0;
2726
2727 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2728 /* Not sure what to do here, so do nothing but return zero. */
2729
2730 #elif defined (_WIN32)
2731
2732 pid = win32_wait (&status);
2733
2734 #else
2735
2736 pid = waitpid (-1, &status, 0);
2737 status = status & 0xffff;
2738 #endif
2739
2740 *process_status = status;
2741 return pid;
2742 }
2743
2744 void
2745 __gnat_os_exit (int status)
2746 {
2747 exit (status);
2748 }
2749
2750 /* Locate file on path, that matches a predicate */
2751
2752 char *
2753 __gnat_locate_file_with_predicate
2754 (char *file_name, char *path_val, int (*predicate)(char*))
2755 {
2756 char *ptr;
2757 char *file_path = (char *) alloca (strlen (file_name) + 1);
2758 int absolute;
2759
2760 /* Return immediately if file_name is empty */
2761
2762 if (*file_name == '\0')
2763 return 0;
2764
2765 /* Remove quotes around file_name if present */
2766
2767 ptr = file_name;
2768 if (*ptr == '"')
2769 ptr++;
2770
2771 strcpy (file_path, ptr);
2772
2773 ptr = file_path + strlen (file_path) - 1;
2774
2775 if (*ptr == '"')
2776 *ptr = '\0';
2777
2778 /* Handle absolute pathnames. */
2779
2780 absolute = __gnat_is_absolute_path (file_path, strlen (file_name));
2781
2782 if (absolute)
2783 {
2784 if (predicate (file_path))
2785 return xstrdup (file_path);
2786
2787 return 0;
2788 }
2789
2790 /* If file_name include directory separator(s), try it first as
2791 a path name relative to the current directory */
2792 for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
2793 ;
2794
2795 if (*ptr != 0)
2796 {
2797 if (predicate (file_name))
2798 return xstrdup (file_name);
2799 }
2800
2801 if (path_val == 0)
2802 return 0;
2803
2804 {
2805 /* The result has to be smaller than path_val + file_name. */
2806 char *file_path =
2807 (char *) alloca (strlen (path_val) + strlen (file_name) + 2);
2808
2809 for (;;)
2810 {
2811 /* Skip the starting quote */
2812
2813 if (*path_val == '"')
2814 path_val++;
2815
2816 for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
2817 *ptr++ = *path_val++;
2818
2819 /* If directory is empty, it is the current directory*/
2820
2821 if (ptr == file_path)
2822 {
2823 *ptr = '.';
2824 }
2825 else
2826 ptr--;
2827
2828 /* Skip the ending quote */
2829
2830 if (*ptr == '"')
2831 ptr--;
2832
2833 if (*ptr != '/' && *ptr != DIR_SEPARATOR)
2834 *++ptr = DIR_SEPARATOR;
2835
2836 strcpy (++ptr, file_name);
2837
2838 if (predicate (file_path))
2839 return xstrdup (file_path);
2840
2841 if (*path_val == 0)
2842 return 0;
2843
2844 /* Skip path separator */
2845
2846 path_val++;
2847 }
2848 }
2849
2850 return 0;
2851 }
2852
2853 /* Locate an executable file, give a Path value. */
2854
2855 char *
2856 __gnat_locate_executable_file (char *file_name, char *path_val)
2857 {
2858 return __gnat_locate_file_with_predicate
2859 (file_name, path_val, &__gnat_is_executable_file);
2860 }
2861
2862 /* Locate a regular file, give a Path value. */
2863
2864 char *
2865 __gnat_locate_regular_file (char *file_name, char *path_val)
2866 {
2867 return __gnat_locate_file_with_predicate
2868 (file_name, path_val, &__gnat_is_regular_file);
2869 }
2870
2871 /* Locate an executable given a Path argument. This routine is only used by
2872 gnatbl and should not be used otherwise. Use locate_exec_on_path
2873 instead. */
2874
2875 char *
2876 __gnat_locate_exec (char *exec_name, char *path_val)
2877 {
2878 char *ptr;
2879 if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
2880 {
2881 char *full_exec_name =
2882 (char *) alloca
2883 (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
2884
2885 strcpy (full_exec_name, exec_name);
2886 strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
2887 ptr = __gnat_locate_executable_file (full_exec_name, path_val);
2888
2889 if (ptr == 0)
2890 return __gnat_locate_executable_file (exec_name, path_val);
2891 return ptr;
2892 }
2893 else
2894 return __gnat_locate_executable_file (exec_name, path_val);
2895 }
2896
2897 /* Locate an executable using the Systems default PATH. */
2898
2899 char *
2900 __gnat_locate_exec_on_path (char *exec_name)
2901 {
2902 char *apath_val;
2903
2904 #if defined (_WIN32) && !defined (RTX)
2905 TCHAR *wpath_val = _tgetenv (_T("PATH"));
2906 TCHAR *wapath_val;
2907 /* In Win32 systems we expand the PATH as for XP environment
2908 variables are not automatically expanded. We also prepend the
2909 ".;" to the path to match normal NT path search semantics */
2910
2911 #define EXPAND_BUFFER_SIZE 32767
2912
2913 wapath_val = alloca (EXPAND_BUFFER_SIZE);
2914
2915 wapath_val [0] = '.';
2916 wapath_val [1] = ';';
2917
2918 DWORD res = ExpandEnvironmentStrings
2919 (wpath_val, &wapath_val[2], EXPAND_BUFFER_SIZE - 2);
2920
2921 if (!res) wapath_val [0] = _T('\0');
2922
2923 apath_val = alloca (EXPAND_BUFFER_SIZE);
2924
2925 WS2SC (apath_val, wapath_val, EXPAND_BUFFER_SIZE);
2926 return __gnat_locate_exec (exec_name, apath_val);
2927
2928 #else
2929
2930 #ifdef VMS
2931 char *path_val = "/VAXC$PATH";
2932 #else
2933 char *path_val = getenv ("PATH");
2934 #endif
2935 if (path_val == NULL) return NULL;
2936 apath_val = (char *) alloca (strlen (path_val) + 1);
2937 strcpy (apath_val, path_val);
2938 return __gnat_locate_exec (exec_name, apath_val);
2939 #endif
2940 }
2941
2942 #ifdef VMS
2943
2944 /* These functions are used to translate to and from VMS and Unix syntax
2945 file, directory and path specifications. */
2946
2947 #define MAXPATH 256
2948 #define MAXNAMES 256
2949 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2950
2951 static char new_canonical_dirspec [MAXPATH];
2952 static char new_canonical_filespec [MAXPATH];
2953 static char new_canonical_pathspec [MAXNAMES*MAXPATH];
2954 static unsigned new_canonical_filelist_index;
2955 static unsigned new_canonical_filelist_in_use;
2956 static unsigned new_canonical_filelist_allocated;
2957 static char **new_canonical_filelist;
2958 static char new_host_pathspec [MAXNAMES*MAXPATH];
2959 static char new_host_dirspec [MAXPATH];
2960 static char new_host_filespec [MAXPATH];
2961
2962 /* Routine is called repeatedly by decc$from_vms via
2963 __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2964 runs out. */
2965
2966 static int
2967 wildcard_translate_unix (char *name)
2968 {
2969 char *ver;
2970 char buff [MAXPATH];
2971
2972 strncpy (buff, name, MAXPATH);
2973 buff [MAXPATH - 1] = (char) 0;
2974 ver = strrchr (buff, '.');
2975
2976 /* Chop off the version. */
2977 if (ver)
2978 *ver = 0;
2979
2980 /* Dynamically extend the allocation by the increment. */
2981 if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
2982 {
2983 new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
2984 new_canonical_filelist = (char **) xrealloc
2985 (new_canonical_filelist,
2986 new_canonical_filelist_allocated * sizeof (char *));
2987 }
2988
2989 new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
2990
2991 return 1;
2992 }
2993
2994 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2995 full translation and copy the results into a list (_init), then return them
2996 one at a time (_next). If onlydirs set, only expand directory files. */
2997
2998 int
2999 __gnat_to_canonical_file_list_init (char *filespec, int onlydirs)
3000 {
3001 int len;
3002 char buff [MAXPATH];
3003
3004 len = strlen (filespec);
3005 strncpy (buff, filespec, MAXPATH);
3006
3007 /* Only look for directories */
3008 if (onlydirs && !strstr (&buff [len-5], "*.dir"))
3009 strncat (buff, "*.dir", MAXPATH);
3010
3011 buff [MAXPATH - 1] = (char) 0;
3012
3013 decc$from_vms (buff, wildcard_translate_unix, 1);
3014
3015 /* Remove the .dir extension. */
3016 if (onlydirs)
3017 {
3018 int i;
3019 char *ext;
3020
3021 for (i = 0; i < new_canonical_filelist_in_use; i++)
3022 {
3023 ext = strstr (new_canonical_filelist[i], ".dir");
3024 if (ext)
3025 *ext = 0;
3026 }
3027 }
3028
3029 return new_canonical_filelist_in_use;
3030 }
3031
3032 /* Return the next filespec in the list. */
3033
3034 char *
3035 __gnat_to_canonical_file_list_next ()
3036 {
3037 return new_canonical_filelist[new_canonical_filelist_index++];
3038 }
3039
3040 /* Free storage used in the wildcard expansion. */
3041
3042 void
3043 __gnat_to_canonical_file_list_free ()
3044 {
3045 int i;
3046
3047 for (i = 0; i < new_canonical_filelist_in_use; i++)
3048 free (new_canonical_filelist[i]);
3049
3050 free (new_canonical_filelist);
3051
3052 new_canonical_filelist_in_use = 0;
3053 new_canonical_filelist_allocated = 0;
3054 new_canonical_filelist_index = 0;
3055 new_canonical_filelist = 0;
3056 }
3057
3058 /* The functional equivalent of decc$translate_vms routine.
3059 Designed to produce the same output, but is protected against
3060 malformed paths (original version ACCVIOs in this case) and
3061 does not require VMS-specific DECC RTL */
3062
3063 #define NAM$C_MAXRSS 1024
3064
3065 char *
3066 __gnat_translate_vms (char *src)
3067 {
3068 static char retbuf [NAM$C_MAXRSS+1];
3069 char *srcendpos, *pos1, *pos2, *retpos;
3070 int disp, path_present = 0;
3071
3072 if (!src) return NULL;
3073
3074 srcendpos = strchr (src, '\0');
3075 retpos = retbuf;
3076
3077 /* Look for the node and/or device in front of the path */
3078 pos1 = src;
3079 pos2 = strchr (pos1, ':');
3080
3081 if (pos2 && (pos2 < srcendpos) && (*(pos2 + 1) == ':')) {
3082 /* There is a node name. "node_name::" becomes "node_name!" */
3083 disp = pos2 - pos1;
3084 strncpy (retbuf, pos1, disp);
3085 retpos [disp] = '!';
3086 retpos = retpos + disp + 1;
3087 pos1 = pos2 + 2;
3088 pos2 = strchr (pos1, ':');
3089 }
3090
3091 if (pos2) {
3092 /* There is a device name. "dev_name:" becomes "/dev_name/" */
3093 *(retpos++) = '/';
3094 disp = pos2 - pos1;
3095 strncpy (retpos, pos1, disp);
3096 retpos = retpos + disp;
3097 pos1 = pos2 + 1;
3098 *(retpos++) = '/';
3099 }
3100 else
3101 /* No explicit device; we must look ahead and prepend /sys$disk/ if
3102 the path is absolute */
3103 if ((*pos1 == '[' || *pos1 == '<') && (pos1 < srcendpos)
3104 && !strchr (".-]>", *(pos1 + 1))) {
3105 strncpy (retpos, "/sys$disk/", 10);
3106 retpos += 10;
3107 }
3108
3109 /* Process the path part */
3110 while (*pos1 == '[' || *pos1 == '<') {
3111 path_present++;
3112 pos1++;
3113 if (*pos1 == ']' || *pos1 == '>') {
3114 /* Special case, [] translates to '.' */
3115 *(retpos++) = '.';
3116 pos1++;
3117 }
3118 else {
3119 /* '[000000' means root dir. It can be present in the middle of
3120 the path due to expansion of logical devices, in which case
3121 we skip it */
3122 if (!strncmp (pos1, "000000", 6) && path_present > 1 &&
3123 (*(pos1 + 6) == ']' || *(pos1 + 6) == '>' || *(pos1 + 6) == '.')) {
3124 pos1 += 6;
3125 if (*pos1 == '.') pos1++;
3126 }
3127 else if (*pos1 == '.') {
3128 /* Relative path */
3129 *(retpos++) = '.';
3130 }
3131
3132 /* There is a qualified path */
3133 while (*pos1 && *pos1 != ']' && *pos1 != '>') {
3134 switch (*pos1) {
3135 case '.':
3136 /* '.' is used to separate directories. Replace it with '/' but
3137 only if there isn't already '/' just before */
3138 if (*(retpos - 1) != '/') *(retpos++) = '/';
3139 pos1++;
3140 if (pos1 + 1 < srcendpos && *pos1 == '.' && *(pos1 + 1) == '.') {
3141 /* ellipsis refers to entire subtree; replace with '**' */
3142 *(retpos++) = '*'; *(retpos++) = '*'; *(retpos++) = '/';
3143 pos1 += 2;
3144 }
3145 break;
3146 case '-' :
3147 /* When after '.' '[' '<' is equivalent to Unix ".." but there
3148 may be several in a row */
3149 if (*(pos1 - 1) == '.' || *(pos1 - 1) == '[' ||
3150 *(pos1 - 1) == '<') {
3151 while (*pos1 == '-') {
3152 pos1++;
3153 *(retpos++) = '.'; *(retpos++) = '.'; *(retpos++) = '/';
3154 }
3155 retpos--;
3156 break;
3157 }
3158 /* otherwise fall through to default */
3159 default:
3160 *(retpos++) = *(pos1++);
3161 }
3162 }
3163 pos1++;
3164 }
3165 }
3166
3167 if (pos1 < srcendpos) {
3168 /* Now add the actual file name, until the version suffix if any */
3169 if (path_present) *(retpos++) = '/';
3170 pos2 = strchr (pos1, ';');
3171 disp = pos2? (pos2 - pos1) : (srcendpos - pos1);
3172 strncpy (retpos, pos1, disp);
3173 retpos += disp;
3174 if (pos2 && pos2 < srcendpos) {
3175 /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
3176 *retpos++ = '.';
3177 disp = srcendpos - pos2 - 1;
3178 strncpy (retpos, pos2 + 1, disp);
3179 retpos += disp;
3180 }
3181 }
3182
3183 *retpos = '\0';
3184
3185 return retbuf;
3186
3187 }
3188
3189 /* Translate a VMS syntax directory specification in to Unix syntax. If
3190 PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
3191 found, return input string. Also translate a dirname that contains no
3192 slashes, in case it's a logical name. */
3193
3194 char *
3195 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag)
3196 {
3197 int len;
3198
3199 strcpy (new_canonical_dirspec, "");
3200 if (strlen (dirspec))
3201 {
3202 char *dirspec1;
3203
3204 if (strchr (dirspec, ']') || strchr (dirspec, ':'))
3205 {
3206 strncpy (new_canonical_dirspec,
3207 __gnat_translate_vms (dirspec),
3208 MAXPATH);
3209 }
3210 else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
3211 {
3212 strncpy (new_canonical_dirspec,
3213 __gnat_translate_vms (dirspec1),
3214 MAXPATH);
3215 }
3216 else
3217 {
3218 strncpy (new_canonical_dirspec, dirspec, MAXPATH);
3219 }
3220 }
3221
3222 len = strlen (new_canonical_dirspec);
3223 if (prefixflag && new_canonical_dirspec [len-1] != '/')
3224 strncat (new_canonical_dirspec, "/", MAXPATH);
3225
3226 new_canonical_dirspec [MAXPATH - 1] = (char) 0;
3227
3228 return new_canonical_dirspec;
3229
3230 }
3231
3232 /* Translate a VMS syntax file specification into Unix syntax.
3233 If no indicators of VMS syntax found, check if it's an uppercase
3234 alphanumeric_ name and if so try it out as an environment
3235 variable (logical name). If all else fails return the
3236 input string. */
3237
3238 char *
3239 __gnat_to_canonical_file_spec (char *filespec)
3240 {
3241 char *filespec1;
3242
3243 strncpy (new_canonical_filespec, "", MAXPATH);
3244
3245 if (strchr (filespec, ']') || strchr (filespec, ':'))
3246 {
3247 char *tspec = (char *) __gnat_translate_vms (filespec);
3248
3249 if (tspec != (char *) -1)
3250 strncpy (new_canonical_filespec, tspec, MAXPATH);
3251 }
3252 else if ((strlen (filespec) == strspn (filespec,
3253 "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
3254 && (filespec1 = getenv (filespec)))
3255 {
3256 char *tspec = (char *) __gnat_translate_vms (filespec1);
3257
3258 if (tspec != (char *) -1)
3259 strncpy (new_canonical_filespec, tspec, MAXPATH);
3260 }
3261 else
3262 {
3263 strncpy (new_canonical_filespec, filespec, MAXPATH);
3264 }
3265
3266 new_canonical_filespec [MAXPATH - 1] = (char) 0;
3267
3268 return new_canonical_filespec;
3269 }
3270
3271 /* Translate a VMS syntax path specification into Unix syntax.
3272 If no indicators of VMS syntax found, return input string. */
3273
3274 char *
3275 __gnat_to_canonical_path_spec (char *pathspec)
3276 {
3277 char *curr, *next, buff [MAXPATH];
3278
3279 if (pathspec == 0)
3280 return pathspec;
3281
3282 /* If there are /'s, assume it's a Unix path spec and return. */
3283 if (strchr (pathspec, '/'))
3284 return pathspec;
3285
3286 new_canonical_pathspec[0] = 0;
3287 curr = pathspec;
3288
3289 for (;;)
3290 {
3291 next = strchr (curr, ',');
3292 if (next == 0)
3293 next = strchr (curr, 0);
3294
3295 strncpy (buff, curr, next - curr);
3296 buff[next - curr] = 0;
3297
3298 /* Check for wildcards and expand if present. */
3299 if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
3300 {
3301 int i, dirs;
3302
3303 dirs = __gnat_to_canonical_file_list_init (buff, 1);
3304 for (i = 0; i < dirs; i++)
3305 {
3306 char *next_dir;
3307
3308 next_dir = __gnat_to_canonical_file_list_next ();
3309 strncat (new_canonical_pathspec, next_dir, MAXPATH);
3310
3311 /* Don't append the separator after the last expansion. */
3312 if (i+1 < dirs)
3313 strncat (new_canonical_pathspec, ":", MAXPATH);
3314 }
3315
3316 __gnat_to_canonical_file_list_free ();
3317 }
3318 else
3319 strncat (new_canonical_pathspec,
3320 __gnat_to_canonical_dir_spec (buff, 0), MAXPATH);
3321
3322 if (*next == 0)
3323 break;
3324
3325 strncat (new_canonical_pathspec, ":", MAXPATH);
3326 curr = next + 1;
3327 }
3328
3329 new_canonical_pathspec [MAXPATH - 1] = (char) 0;
3330
3331 return new_canonical_pathspec;
3332 }
3333
3334 static char filename_buff [MAXPATH];
3335
3336 static int
3337 translate_unix (char *name, int type)
3338 {
3339 strncpy (filename_buff, name, MAXPATH);
3340 filename_buff [MAXPATH - 1] = (char) 0;
3341 return 0;
3342 }
3343
3344 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
3345 directories. */
3346
3347 static char *
3348 to_host_path_spec (char *pathspec)
3349 {
3350 char *curr, *next, buff [MAXPATH];
3351
3352 if (pathspec == 0)
3353 return pathspec;
3354
3355 /* Can't very well test for colons, since that's the Unix separator! */
3356 if (strchr (pathspec, ']') || strchr (pathspec, ','))
3357 return pathspec;
3358
3359 new_host_pathspec[0] = 0;
3360 curr = pathspec;
3361
3362 for (;;)
3363 {
3364 next = strchr (curr, ':');
3365 if (next == 0)
3366 next = strchr (curr, 0);
3367
3368 strncpy (buff, curr, next - curr);
3369 buff[next - curr] = 0;
3370
3371 strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH);
3372 if (*next == 0)
3373 break;
3374 strncat (new_host_pathspec, ",", MAXPATH);
3375 curr = next + 1;
3376 }
3377
3378 new_host_pathspec [MAXPATH - 1] = (char) 0;
3379
3380 return new_host_pathspec;
3381 }
3382
3383 /* Translate a Unix syntax directory specification into VMS syntax. The
3384 PREFIXFLAG has no effect, but is kept for symmetry with
3385 to_canonical_dir_spec. If indicators of VMS syntax found, return input
3386 string. */
3387
3388 char *
3389 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3390 {
3391 int len = strlen (dirspec);
3392
3393 strncpy (new_host_dirspec, dirspec, MAXPATH);
3394 new_host_dirspec [MAXPATH - 1] = (char) 0;
3395
3396 if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
3397 return new_host_dirspec;
3398
3399 while (len > 1 && new_host_dirspec[len - 1] == '/')
3400 {
3401 new_host_dirspec[len - 1] = 0;
3402 len--;
3403 }
3404
3405 decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
3406 strncpy (new_host_dirspec, filename_buff, MAXPATH);
3407 new_host_dirspec [MAXPATH - 1] = (char) 0;
3408
3409 return new_host_dirspec;
3410 }
3411
3412 /* Translate a Unix syntax file specification into VMS syntax.
3413 If indicators of VMS syntax found, return input string. */
3414
3415 char *
3416 __gnat_to_host_file_spec (char *filespec)
3417 {
3418 strncpy (new_host_filespec, "", MAXPATH);
3419 if (strchr (filespec, ']') || strchr (filespec, ':'))
3420 {
3421 strncpy (new_host_filespec, filespec, MAXPATH);
3422 }
3423 else
3424 {
3425 decc$to_vms (filespec, translate_unix, 1, 1);
3426 strncpy (new_host_filespec, filename_buff, MAXPATH);
3427 }
3428
3429 new_host_filespec [MAXPATH - 1] = (char) 0;
3430
3431 return new_host_filespec;
3432 }
3433
3434 void
3435 __gnat_adjust_os_resource_limits ()
3436 {
3437 SYS$ADJWSL (131072, 0);
3438 }
3439
3440 #else /* VMS */
3441
3442 /* Dummy functions for Osint import for non-VMS systems. */
3443
3444 int
3445 __gnat_to_canonical_file_list_init
3446 (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED)
3447 {
3448 return 0;
3449 }
3450
3451 char *
3452 __gnat_to_canonical_file_list_next (void)
3453 {
3454 static char empty[] = "";
3455 return empty;
3456 }
3457
3458 void
3459 __gnat_to_canonical_file_list_free (void)
3460 {
3461 }
3462
3463 char *
3464 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3465 {
3466 return dirspec;
3467 }
3468
3469 char *
3470 __gnat_to_canonical_file_spec (char *filespec)
3471 {
3472 return filespec;
3473 }
3474
3475 char *
3476 __gnat_to_canonical_path_spec (char *pathspec)
3477 {
3478 return pathspec;
3479 }
3480
3481 char *
3482 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3483 {
3484 return dirspec;
3485 }
3486
3487 char *
3488 __gnat_to_host_file_spec (char *filespec)
3489 {
3490 return filespec;
3491 }
3492
3493 void
3494 __gnat_adjust_os_resource_limits (void)
3495 {
3496 }
3497
3498 #endif
3499
3500 #if defined (__mips_vxworks)
3501 int
3502 _flush_cache()
3503 {
3504 CACHE_USER_FLUSH (0, ENTIRE_CACHE);
3505 }
3506 #endif
3507
3508 #if defined (IS_CROSS) \
3509 || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3510 && defined (__SVR4)) \
3511 && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3512 && ! (defined (linux) && defined (__ia64__)) \
3513 && ! (defined (linux) && defined (powerpc)) \
3514 && ! defined (__FreeBSD__) \
3515 && ! defined (__Lynx__) \
3516 && ! defined (__hpux__) \
3517 && ! defined (__APPLE__) \
3518 && ! defined (_AIX) \
3519 && ! (defined (__alpha__) && defined (__osf__)) \
3520 && ! defined (VMS) \
3521 && ! defined (__MINGW32__) \
3522 && ! (defined (__mips) && defined (__sgi)))
3523
3524 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3525 just above for a list of native platforms that provide a non-dummy
3526 version of this procedure in libaddr2line.a. */
3527
3528 void
3529 convert_addresses (const char *file_name ATTRIBUTE_UNUSED,
3530 void *addrs ATTRIBUTE_UNUSED,
3531 int n_addr ATTRIBUTE_UNUSED,
3532 void *buf ATTRIBUTE_UNUSED,
3533 int *len ATTRIBUTE_UNUSED)
3534 {
3535 *len = 0;
3536 }
3537 #endif
3538
3539 #if defined (_WIN32)
3540 int __gnat_argument_needs_quote = 1;
3541 #else
3542 int __gnat_argument_needs_quote = 0;
3543 #endif
3544
3545 /* This option is used to enable/disable object files handling from the
3546 binder file by the GNAT Project module. For example, this is disabled on
3547 Windows (prior to GCC 3.4) as it is already done by the mdll module.
3548 Stating with GCC 3.4 the shared libraries are not based on mdll
3549 anymore as it uses the GCC's -shared option */
3550 #if defined (_WIN32) \
3551 && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3552 int __gnat_prj_add_obj_files = 0;
3553 #else
3554 int __gnat_prj_add_obj_files = 1;
3555 #endif
3556
3557 /* char used as prefix/suffix for environment variables */
3558 #if defined (_WIN32)
3559 char __gnat_environment_char = '%';
3560 #else
3561 char __gnat_environment_char = '$';
3562 #endif
3563
3564 /* This functions copy the file attributes from a source file to a
3565 destination file.
3566
3567 mode = 0 : In this mode copy only the file time stamps (last access and
3568 last modification time stamps).
3569
3570 mode = 1 : In this mode, time stamps and read/write/execute attributes are
3571 copied.
3572
3573 Returns 0 if operation was successful and -1 in case of error. */
3574
3575 int
3576 __gnat_copy_attribs (char *from, char *to, int mode)
3577 {
3578 #if defined (VMS) || (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \
3579 defined (__nucleus__)
3580 return -1;
3581
3582 #elif defined (_WIN32) && !defined (RTX)
3583 TCHAR wfrom [GNAT_MAX_PATH_LEN + 2];
3584 TCHAR wto [GNAT_MAX_PATH_LEN + 2];
3585 BOOL res;
3586 FILETIME fct, flat, flwt;
3587 HANDLE hfrom, hto;
3588
3589 S2WSC (wfrom, from, GNAT_MAX_PATH_LEN + 2);
3590 S2WSC (wto, to, GNAT_MAX_PATH_LEN + 2);
3591
3592 /* retrieve from times */
3593
3594 hfrom = CreateFile
3595 (wfrom, GENERIC_READ, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
3596
3597 if (hfrom == INVALID_HANDLE_VALUE)
3598 return -1;
3599
3600 res = GetFileTime (hfrom, &fct, &flat, &flwt);
3601
3602 CloseHandle (hfrom);
3603
3604 if (res == 0)
3605 return -1;
3606
3607 /* retrieve from times */
3608
3609 hto = CreateFile
3610 (wto, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
3611
3612 if (hto == INVALID_HANDLE_VALUE)
3613 return -1;
3614
3615 res = SetFileTime (hto, NULL, &flat, &flwt);
3616
3617 CloseHandle (hto);
3618
3619 if (res == 0)
3620 return -1;
3621
3622 /* Set file attributes in full mode. */
3623
3624 if (mode == 1)
3625 {
3626 DWORD attribs = GetFileAttributes (wfrom);
3627
3628 if (attribs == INVALID_FILE_ATTRIBUTES)
3629 return -1;
3630
3631 res = SetFileAttributes (wto, attribs);
3632 if (res == 0)
3633 return -1;
3634 }
3635
3636 return 0;
3637
3638 #else
3639 GNAT_STRUCT_STAT fbuf;
3640 struct utimbuf tbuf;
3641
3642 if (GNAT_STAT (from, &fbuf) == -1)
3643 {
3644 return -1;
3645 }
3646
3647 tbuf.actime = fbuf.st_atime;
3648 tbuf.modtime = fbuf.st_mtime;
3649
3650 if (utime (to, &tbuf) == -1)
3651 {
3652 return -1;
3653 }
3654
3655 if (mode == 1)
3656 {
3657 if (chmod (to, fbuf.st_mode) == -1)
3658 {
3659 return -1;
3660 }
3661 }
3662
3663 return 0;
3664 #endif
3665 }
3666
3667 int
3668 __gnat_lseek (int fd, long offset, int whence)
3669 {
3670 return (int) lseek (fd, offset, whence);
3671 }
3672
3673 /* This function returns the major version number of GCC being used. */
3674 int
3675 get_gcc_version (void)
3676 {
3677 #ifdef IN_RTS
3678 return __GNUC__;
3679 #else
3680 return (int) (version_string[0] - '0');
3681 #endif
3682 }
3683
3684 int
3685 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED,
3686 int close_on_exec_p ATTRIBUTE_UNUSED)
3687 {
3688 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3689 int flags = fcntl (fd, F_GETFD, 0);
3690 if (flags < 0)
3691 return flags;
3692 if (close_on_exec_p)
3693 flags |= FD_CLOEXEC;
3694 else
3695 flags &= ~FD_CLOEXEC;
3696 return fcntl (fd, F_SETFD, flags | FD_CLOEXEC);
3697 #elif defined(_WIN32)
3698 HANDLE h = (HANDLE) _get_osfhandle (fd);
3699 if (h == (HANDLE) -1)
3700 return -1;
3701 if (close_on_exec_p)
3702 return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT, 0);
3703 return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT,
3704 HANDLE_FLAG_INHERIT);
3705 #else
3706 /* TODO: Unimplemented. */
3707 return -1;
3708 #endif
3709 }
3710
3711 /* Indicates if platforms supports automatic initialization through the
3712 constructor mechanism */
3713 int
3714 __gnat_binder_supports_auto_init (void)
3715 {
3716 #ifdef VMS
3717 return 0;
3718 #else
3719 return 1;
3720 #endif
3721 }
3722
3723 /* Indicates that Stand-Alone Libraries are automatically initialized through
3724 the constructor mechanism */
3725 int
3726 __gnat_sals_init_using_constructors (void)
3727 {
3728 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3729 return 0;
3730 #else
3731 return 1;
3732 #endif
3733 }
3734
3735 #ifdef RTX
3736
3737 /* In RTX mode, the procedure to get the time (as file time) is different
3738 in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3739 we introduce an intermediate procedure to link against the corresponding
3740 one in each situation. */
3741
3742 extern void GetTimeAsFileTime(LPFILETIME pTime);
3743
3744 void GetTimeAsFileTime(LPFILETIME pTime)
3745 {
3746 #ifdef RTSS
3747 RtGetRtssTimeAsFileTime (pTime); /* RTSS interface */
3748 #else
3749 GetSystemTimeAsFileTime (pTime); /* w32 interface */
3750 #endif
3751 }
3752
3753 #ifdef RTSS
3754 /* Add symbol that is required to link. It would otherwise be taken from
3755 libgcc.a and it would try to use the gcc constructors that are not
3756 supported by Microsoft linker. */
3757
3758 extern void __main (void);
3759
3760 void __main (void) {}
3761 #endif
3762 #endif
3763
3764 #if defined (linux)
3765 /* There is no function in the glibc to retrieve the LWP of the current
3766 thread. We need to do a system call in order to retrieve this
3767 information. */
3768 #include <sys/syscall.h>
3769 void *__gnat_lwp_self (void)
3770 {
3771 return (void *) syscall (__NR_gettid);
3772 }
3773
3774 #include <sched.h>
3775
3776 void __gnat_cpu_zero (cpu_set_t *set)
3777 {
3778 CPU_ZERO (set);
3779 }
3780
3781 void __gnat_cpu_set (int cpu, cpu_set_t *set)
3782 {
3783 /* Ada handles CPU numbers starting from 1, while C identifies the first
3784 CPU by a 0, so we need to adjust. */
3785 CPU_SET (cpu - 1, set);
3786 }
3787 #endif
3788
3789 #ifdef __cplusplus
3790 }
3791 #endif