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