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