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