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