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