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