OSDN Git Service

9952bc849f752e6060e14643ac53347e8e3e4f10
[pf3gnuchains/gcc-fork.git] / gcc / ada / adaint.c
1 /****************************************************************************
2  *                                                                          *
3  *                         GNAT COMPILER COMPONENTS                         *
4  *                                                                          *
5  *                               A D A I N T                                *
6  *                                                                          *
7  *                          C Implementation File                           *
8  *                                                                          *
9  *          Copyright (C) 1992-2006, Free Software Foundation, Inc.         *
10  *                                                                          *
11  * GNAT is free software;  you can  redistribute it  and/or modify it under *
12  * terms of the  GNU General Public License as published  by the Free Soft- *
13  * ware  Foundation;  either version 2,  or (at your option) any later ver- *
14  * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
15  * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
16  * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
17  * for  more details.  You should have  received  a copy of the GNU General *
18  * Public License  distributed with GNAT;  see file COPYING.  If not, write *
19  * to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, *
20  * Boston, MA 02110-1301, USA.                                              *
21  *                                                                          *
22  * As a  special  exception,  if you  link  this file  with other  files to *
23  * produce an executable,  this file does not by itself cause the resulting *
24  * executable to be covered by the GNU General Public License. This except- *
25  * ion does not  however invalidate  any other reasons  why the  executable *
26  * file might be covered by the  GNU Public License.                        *
27  *                                                                          *
28  * GNAT was originally developed  by the GNAT team at  New York University. *
29  * Extensive contributions were provided by Ada Core Technologies Inc.      *
30  *                                                                          *
31  ****************************************************************************/
32
33 /* This file contains those routines named by Import pragmas in
34    packages in the GNAT hierarchy (especially GNAT.OS_Lib) and in
35    package Osint.  Many of the subprograms in OS_Lib import standard
36    library calls directly. This file contains all other routines.  */
37
38 #ifdef __vxworks
39
40 /* No need to redefine exit here.  */
41 #undef exit
42
43 /* We want to use the POSIX variants of include files.  */
44 #define POSIX
45 #include "vxWorks.h"
46
47 #if defined (__mips_vxworks)
48 #include "cacheLib.h"
49 #endif /* __mips_vxworks */
50
51 #endif /* VxWorks */
52
53 #ifdef VMS
54 #define _POSIX_EXIT 1
55 #define HOST_EXECUTABLE_SUFFIX ".exe"
56 #define HOST_OBJECT_SUFFIX ".obj"
57 #endif
58
59 #ifdef IN_RTS
60 #include "tconfig.h"
61 #include "tsystem.h"
62
63 #include <sys/stat.h>
64 #include <fcntl.h>
65 #include <time.h>
66 #ifdef VMS
67 #include <unixio.h>
68 #endif
69
70 /* We don't have libiberty, so use malloc.  */
71 #define xmalloc(S) malloc (S)
72 #define xrealloc(V,S) realloc (V,S)
73 #else
74 #include "config.h"
75 #include "system.h"
76 #include "version.h"
77 #endif
78
79 #ifdef __MINGW32__
80 #include "mingw32.h"
81 #include <sys/utime.h>
82 #include <ctype.h>
83 #else
84 #ifndef VMS
85 #include <utime.h>
86 #endif
87 #endif
88
89 #ifdef __MINGW32__
90 #if OLD_MINGW
91 #include <sys/wait.h>
92 #endif
93 #elif defined (__vxworks) && defined (__RTP__)
94 #include <wait.h>
95 #else
96 #include <sys/wait.h>
97 #endif
98
99 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
100 #elif defined (VMS)
101
102 /* Header files and definitions for __gnat_set_file_time_name.  */
103
104 #include <vms/rms.h>
105 #include <vms/atrdef.h>
106 #include <vms/fibdef.h>
107 #include <vms/stsdef.h>
108 #include <vms/iodef.h>
109 #include <errno.h>
110 #include <vms/descrip.h>
111 #include <string.h>
112 #include <unixlib.h>
113
114 /* Use native 64-bit arithmetic.  */
115 #define unix_time_to_vms(X,Y) \
116   { unsigned long long reftime, tmptime = (X); \
117     $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
118     SYS$BINTIM (&unixtime, &reftime); \
119     Y = tmptime * 10000000 + reftime; }
120
121 /* descrip.h doesn't have everything ... */
122 struct dsc$descriptor_fib
123 {
124   unsigned long fib$l_len;
125   struct fibdef *fib$l_addr;
126 };
127
128 /* I/O Status Block.  */
129 struct IOSB
130 {
131   unsigned short status, count;
132   unsigned long devdep;
133 };
134
135 static char *tryfile;
136
137 /* Variable length string.  */
138 struct vstring
139 {
140   short length;
141   char string[NAM$C_MAXRSS+1];
142 };
143
144 #else
145 #include <utime.h>
146 #endif
147
148 #if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
149 #include <process.h>
150 #endif
151
152 #if defined (_WIN32)
153 #include <dir.h>
154 #include <windows.h>
155 #undef DIR_SEPARATOR
156 #define DIR_SEPARATOR '\\'
157 #endif
158
159 #include "adaint.h"
160
161 /* Define symbols O_BINARY and O_TEXT as harmless zeroes if they are not
162    defined in the current system. On DOS-like systems these flags control
163    whether the file is opened/created in text-translation mode (CR/LF in
164    external file mapped to LF in internal file), but in Unix-like systems,
165    no text translation is required, so these flags have no effect.  */
166
167 #if defined (__EMX__)
168 #include <os2.h>
169 #endif
170
171 #if defined (MSDOS)
172 #include <dos.h>
173 #endif
174
175 #ifndef O_BINARY
176 #define O_BINARY 0
177 #endif
178
179 #ifndef O_TEXT
180 #define O_TEXT 0
181 #endif
182
183 #ifndef HOST_EXECUTABLE_SUFFIX
184 #define HOST_EXECUTABLE_SUFFIX ""
185 #endif
186
187 #ifndef HOST_OBJECT_SUFFIX
188 #define HOST_OBJECT_SUFFIX ".o"
189 #endif
190
191 #ifndef PATH_SEPARATOR
192 #define PATH_SEPARATOR ':'
193 #endif
194
195 #ifndef DIR_SEPARATOR
196 #define DIR_SEPARATOR '/'
197 #endif
198
199 /* Check for cross-compilation */
200 #ifdef CROSS_DIRECTORY_STRUCTURE
201 int __gnat_is_cross_compiler = 1;
202 #else
203 int __gnat_is_cross_compiler = 0;
204 #endif
205
206 char __gnat_dir_separator = DIR_SEPARATOR;
207
208 char __gnat_path_separator = PATH_SEPARATOR;
209
210 /* The GNAT_LIBRARY_TEMPLATE contains a list of expressions that define
211    the base filenames that libraries specified with -lsomelib options
212    may have. This is used by GNATMAKE to check whether an executable
213    is up-to-date or not. The syntax is
214
215      library_template ::= { pattern ; } pattern NUL
216      pattern          ::= [ prefix ] * [ postfix ]
217
218    These should only specify names of static libraries as it makes
219    no sense to determine at link time if dynamic-link libraries are
220    up to date or not. Any libraries that are not found are supposed
221    to be up-to-date:
222
223      * if they are needed but not present, the link
224        will fail,
225
226      * otherwise they are libraries in the system paths and so
227        they are considered part of the system and not checked
228        for that reason.
229
230    ??? This should be part of a GNAT host-specific compiler
231        file instead of being included in all user applications
232        as well. This is only a temporary work-around for 3.11b.  */
233
234 #ifndef GNAT_LIBRARY_TEMPLATE
235 #if defined (__EMX__)
236 #define GNAT_LIBRARY_TEMPLATE "*.a"
237 #elif defined (VMS)
238 #define GNAT_LIBRARY_TEMPLATE "*.olb"
239 #else
240 #define GNAT_LIBRARY_TEMPLATE "lib*.a"
241 #endif
242 #endif
243
244 const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE;
245
246 /* This variable is used in hostparm.ads to say whether the host is a VMS
247    system.  */
248 #ifdef VMS
249 const int __gnat_vmsp = 1;
250 #else
251 const int __gnat_vmsp = 0;
252 #endif
253
254 #ifdef __EMX__
255 #define GNAT_MAX_PATH_LEN MAX_PATH
256
257 #elif defined (VMS)
258 #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
259
260 #elif defined (__vxworks) || defined (__OPENNT)
261 #define GNAT_MAX_PATH_LEN PATH_MAX
262
263 #else
264
265 #if defined (__MINGW32__)
266 #include "mingw32.h"
267
268 #if OLD_MINGW
269 #include <sys/param.h>
270 #endif
271
272 #else
273 #include <sys/param.h>
274 #endif
275
276 #ifdef MAXPATHLEN
277 #define GNAT_MAX_PATH_LEN MAXPATHLEN
278 #else
279 #define GNAT_MAX_PATH_LEN 256
280 #endif
281
282 #endif
283
284 /* The __gnat_max_path_len variable is used to export the maximum
285    length of a path name to Ada code. max_path_len is also provided
286    for compatibility with older GNAT versions, please do not use
287    it. */
288
289 int __gnat_max_path_len = GNAT_MAX_PATH_LEN;
290 int max_path_len = GNAT_MAX_PATH_LEN;
291
292 /* The following macro HAVE_READDIR_R should be defined if the
293    system provides the routine readdir_r.  */
294 #undef HAVE_READDIR_R
295 \f
296 #if defined(VMS) && defined (__LONG_POINTERS)
297
298 /* Return a 32 bit pointer to an array of 32 bit pointers
299    given a 64 bit pointer to an array of 64 bit pointers */
300
301 typedef __char_ptr32 *__char_ptr_char_ptr32 __attribute__ ((mode (SI)));
302
303 static __char_ptr_char_ptr32
304 to_ptr32 (char **ptr64)
305 {
306   int argc;
307   __char_ptr_char_ptr32 short_argv;
308
309   for (argc=0; ptr64[argc]; argc++);
310
311   /* Reallocate argv with 32 bit pointers. */
312   short_argv = (__char_ptr_char_ptr32) decc$malloc
313     (sizeof (__char_ptr32) * (argc + 1));
314
315   for (argc=0; ptr64[argc]; argc++)
316     short_argv[argc] = (__char_ptr32) decc$strdup (ptr64[argc]);
317
318   short_argv[argc] = (__char_ptr32) 0;
319   return short_argv;
320
321 }
322 #define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
323 #else
324 #define MAYBE_TO_PTR32(argv) argv
325 #endif
326
327 OS_Time
328 __gnat_current_time
329   (void)
330 {
331   time_t res = time (NULL);
332   return (OS_Time) res;
333 }
334
335 void
336 __gnat_to_gm_time
337   (OS_Time *p_time,
338    int *p_year,
339    int *p_month,
340    int *p_day,
341    int *p_hours,
342    int *p_mins,
343    int *p_secs)
344 {
345   struct tm *res;
346   time_t time = (time_t) *p_time;
347
348 #ifdef _WIN32
349   /* On Windows systems, the time is sometimes rounded up to the nearest
350      even second, so if the number of seconds is odd, increment it.  */
351   if (time & 1)
352     time++;
353 #endif
354
355 #ifdef VMS
356   res = localtime (&time);
357 #else
358   res = gmtime (&time);
359 #endif
360
361   if (res)
362     {
363       *p_year = res->tm_year;
364       *p_month = res->tm_mon;
365       *p_day = res->tm_mday;
366       *p_hours = res->tm_hour;
367       *p_mins = res->tm_min;
368       *p_secs = res->tm_sec;
369     }
370   else
371     *p_year = *p_month = *p_day = *p_hours = *p_mins = *p_secs = 0;
372 }
373
374 /* Place the contents of the symbolic link named PATH in the buffer BUF,
375    which has size BUFSIZ.  If PATH is a symbolic link, then return the number
376    of characters of its content in BUF.  Otherwise, return -1.  For Windows,
377    OS/2 and vxworks, always return -1.  */
378
379 int
380 __gnat_readlink (char *path ATTRIBUTE_UNUSED,
381                  char *buf ATTRIBUTE_UNUSED,
382                  size_t bufsiz ATTRIBUTE_UNUSED)
383 {
384 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
385   return -1;
386 #elif defined (__INTERIX) || defined (VMS)
387   return -1;
388 #elif defined (__vxworks)
389   return -1;
390 #else
391   return readlink (path, buf, bufsiz);
392 #endif
393 }
394
395 /* Creates a symbolic link named NEWPATH which contains the string OLDPATH.  If
396    NEWPATH exists it will NOT be overwritten.  For Windows, OS/2, VxWorks,
397    Interix and VMS, always return -1. */
398
399 int
400 __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED,
401                 char *newpath ATTRIBUTE_UNUSED)
402 {
403 #if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
404   return -1;
405 #elif defined (__INTERIX) || defined (VMS)
406   return -1;
407 #elif defined (__vxworks)
408   return -1;
409 #else
410   return symlink (oldpath, newpath);
411 #endif
412 }
413
414 /* Try to lock a file, return 1 if success.  */
415
416 #if defined (__vxworks) || defined (MSDOS) || defined (_WIN32)
417
418 /* Version that does not use link. */
419
420 int
421 __gnat_try_lock (char *dir, char *file)
422 {
423   int fd;
424 #ifdef __MINGW32__
425   TCHAR wfull_path[GNAT_MAX_PATH_LEN];
426   TCHAR wfile[GNAT_MAX_PATH_LEN];
427   TCHAR wdir[GNAT_MAX_PATH_LEN];
428
429   S2WSU (wdir, dir, GNAT_MAX_PATH_LEN);
430   S2WSU (wfile, file, GNAT_MAX_PATH_LEN);
431
432   _stprintf (wfull_path, _T("%s%c%s"), wdir, _T(DIR_SEPARATOR), wfile);
433   fd = _topen (wfull_path, O_CREAT | O_EXCL, 0600);
434 #else
435   char full_path[256];
436
437   sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
438   fd = open (full_path, O_CREAT | O_EXCL, 0600);
439 #endif
440
441   if (fd < 0)
442     return 0;
443
444   close (fd);
445   return 1;
446 }
447
448 #elif defined (__EMX__) || defined (VMS)
449
450 /* More cases that do not use link; identical code, to solve too long
451    line problem ??? */
452
453 int
454 __gnat_try_lock (char *dir, char *file)
455 {
456   char full_path[256];
457   int fd;
458
459   sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
460   fd = open (full_path, O_CREAT | O_EXCL, 0600);
461
462   if (fd < 0)
463     return 0;
464
465   close (fd);
466   return 1;
467 }
468
469 #else
470
471 /* Version using link(), more secure over NFS.  */
472 /* See TN 6913-016 for discussion ??? */
473
474 int
475 __gnat_try_lock (char *dir, char *file)
476 {
477   char full_path[256];
478   char temp_file[256];
479   struct stat stat_result;
480   int fd;
481
482   sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
483   sprintf (temp_file, "%s%cTMP-%ld-%ld",
484            dir, DIR_SEPARATOR, (long)getpid(), (long)getppid ());
485
486   /* Create the temporary file and write the process number.  */
487   fd = open (temp_file, O_CREAT | O_WRONLY, 0600);
488   if (fd < 0)
489     return 0;
490
491   close (fd);
492
493   /* Link it with the new file.  */
494   link (temp_file, full_path);
495
496   /* Count the references on the old one. If we have a count of two, then
497      the link did succeed. Remove the temporary file before returning.  */
498   __gnat_stat (temp_file, &stat_result);
499   unlink (temp_file);
500   return stat_result.st_nlink == 2;
501 }
502 #endif
503
504 /* Return the maximum file name length.  */
505
506 int
507 __gnat_get_maximum_file_name_length (void)
508 {
509 #if defined (MSDOS)
510   return 8;
511 #elif defined (VMS)
512   if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
513     return -1;
514   else
515     return 39;
516 #else
517   return -1;
518 #endif
519 }
520
521 /* Return nonzero if file names are case sensitive.  */
522
523 int
524 __gnat_get_file_names_case_sensitive (void)
525 {
526 #if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT)
527   return 0;
528 #else
529   return 1;
530 #endif
531 }
532
533 char
534 __gnat_get_default_identifier_character_set (void)
535 {
536 #if defined (__EMX__) || defined (MSDOS)
537   return 'p';
538 #else
539   return '1';
540 #endif
541 }
542
543 /* Return the current working directory.  */
544
545 void
546 __gnat_get_current_dir (char *dir, int *length)
547 {
548 #if defined (__MINGW32__)
549   TCHAR wdir[GNAT_MAX_PATH_LEN];
550
551   _tgetcwd (wdir, *length);
552
553   WS2SU (dir, wdir, GNAT_MAX_PATH_LEN);
554
555 #elif defined (VMS)
556    /* Force Unix style, which is what GNAT uses internally.  */
557    getcwd (dir, *length, 0);
558 #else
559    getcwd (dir, *length);
560 #endif
561
562    *length = strlen (dir);
563
564    if (dir [*length - 1] != DIR_SEPARATOR)
565      {
566        dir [*length] = DIR_SEPARATOR;
567        ++(*length);
568      }
569    dir[*length] = '\0';
570 }
571
572 /* Return the suffix for object files.  */
573
574 void
575 __gnat_get_object_suffix_ptr (int *len, const char **value)
576 {
577   *value = HOST_OBJECT_SUFFIX;
578
579   if (*value == 0)
580     *len = 0;
581   else
582     *len = strlen (*value);
583
584   return;
585 }
586
587 /* Return the suffix for executable files.  */
588
589 void
590 __gnat_get_executable_suffix_ptr (int *len, const char **value)
591 {
592   *value = HOST_EXECUTABLE_SUFFIX;
593   if (!*value)
594     *len = 0;
595   else
596     *len = strlen (*value);
597
598   return;
599 }
600
601 /* Return the suffix for debuggable files. Usually this is the same as the
602    executable extension.  */
603
604 void
605 __gnat_get_debuggable_suffix_ptr (int *len, const char **value)
606 {
607 #ifndef MSDOS
608   *value = HOST_EXECUTABLE_SUFFIX;
609 #else
610   /* On DOS, the extensionless COFF file is what gdb likes.  */
611   *value = "";
612 #endif
613
614   if (*value == 0)
615     *len = 0;
616   else
617     *len = strlen (*value);
618
619   return;
620 }
621
622 FILE *
623 __gnat_fopen (char *path, char *mode, int encoding)
624 {
625 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE)
626   TCHAR wpath[GNAT_MAX_PATH_LEN];
627   TCHAR wmode[10];
628
629   S2WS (wmode, mode, 10);
630
631   if (encoding == Encoding_UTF8)
632     S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
633   else
634     S2WS (wpath, path, GNAT_MAX_PATH_LEN);
635
636   return _tfopen (wpath, wmode);
637 #elif defined (VMS)
638   return decc$fopen (path, mode);
639 #else
640   return fopen (path, mode);
641 #endif
642 }
643
644 FILE *
645 __gnat_freopen (char *path, char *mode, FILE *stream, int encoding)
646 {
647 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE)
648   TCHAR wpath[GNAT_MAX_PATH_LEN];
649   TCHAR wmode[10];
650
651   S2WS (wmode, mode, 10);
652
653   if (encoding == Encoding_UTF8)
654     S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
655   else
656     S2WS (wpath, path, GNAT_MAX_PATH_LEN);
657
658   return _tfreopen (wpath, wmode, stream);
659 #elif defined (VMS)
660   return decc$freopen (path, mode, stream);
661 #else
662   return freopen (path, mode, stream);
663 #endif
664 }
665
666 int
667 __gnat_open_read (char *path, int fmode)
668 {
669   int fd;
670   int o_fmode = O_BINARY;
671
672   if (fmode)
673     o_fmode = O_TEXT;
674
675 #if defined (VMS)
676   /* Optional arguments mbc,deq,fop increase read performance.  */
677   fd = open (path, O_RDONLY | o_fmode, 0444,
678              "mbc=16", "deq=64", "fop=tef");
679 #elif defined (__vxworks)
680   fd = open (path, O_RDONLY | o_fmode, 0444);
681 #elif defined (__MINGW32__)
682  {
683    TCHAR wpath[GNAT_MAX_PATH_LEN];
684
685    S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
686    fd = _topen (wpath, O_RDONLY | o_fmode, 0444);
687  }
688 #else
689   fd = open (path, O_RDONLY | o_fmode);
690 #endif
691
692   return fd < 0 ? -1 : fd;
693 }
694
695 #if defined (__EMX__) || defined (__MINGW32__)
696 #define PERM (S_IREAD | S_IWRITE)
697 #elif defined (VMS)
698 /* Excerpt from DECC C RTL Reference Manual:
699    To create files with OpenVMS RMS default protections using the UNIX
700    system-call functions umask, mkdir, creat, and open, call mkdir, creat,
701    and open with a file-protection mode argument of 0777 in a program
702    that never specifically calls umask. These default protections include
703    correctly establishing protections based on ACLs, previous versions of
704    files, and so on. */
705 #define PERM 0777
706 #else
707 #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
708 #endif
709
710 int
711 __gnat_open_rw (char *path, int fmode)
712 {
713   int fd;
714   int o_fmode = O_BINARY;
715
716   if (fmode)
717     o_fmode = O_TEXT;
718
719 #if defined (VMS)
720   fd = open (path, O_RDWR | o_fmode, PERM,
721              "mbc=16", "deq=64", "fop=tef");
722 #elif defined (__MINGW32__)
723   {
724     TCHAR wpath[GNAT_MAX_PATH_LEN];
725
726     S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
727     fd = _topen (wpath, O_RDWR | o_fmode, PERM);
728   }
729 #else
730   fd = open (path, O_RDWR | o_fmode, PERM);
731 #endif
732
733   return fd < 0 ? -1 : fd;
734 }
735
736 int
737 __gnat_open_create (char *path, int fmode)
738 {
739   int fd;
740   int o_fmode = O_BINARY;
741
742   if (fmode)
743     o_fmode = O_TEXT;
744
745 #if defined (VMS)
746   fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM,
747              "mbc=16", "deq=64", "fop=tef");
748 #elif defined (__MINGW32__)
749   {
750     TCHAR wpath[GNAT_MAX_PATH_LEN];
751
752     S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
753     fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
754   }
755 #else
756   fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
757 #endif
758
759   return fd < 0 ? -1 : fd;
760 }
761
762 int
763 __gnat_create_output_file (char *path)
764 {
765   int fd;
766 #if defined (VMS)
767   fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM,
768              "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
769              "shr=del,get,put,upd");
770 #elif defined (__MINGW32__)
771   {
772     TCHAR wpath[GNAT_MAX_PATH_LEN];
773
774     S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
775     fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
776   }
777 #else
778   fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
779 #endif
780
781   return fd < 0 ? -1 : fd;
782 }
783
784 int
785 __gnat_open_append (char *path, int fmode)
786 {
787   int fd;
788   int o_fmode = O_BINARY;
789
790   if (fmode)
791     o_fmode = O_TEXT;
792
793 #if defined (VMS)
794   fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM,
795              "mbc=16", "deq=64", "fop=tef");
796 #elif defined (__MINGW32__)
797   {
798     TCHAR wpath[GNAT_MAX_PATH_LEN];
799
800     S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
801     fd = _topen (wpath, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
802   }
803 #else
804   fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
805 #endif
806
807   return fd < 0 ? -1 : fd;
808 }
809
810 /*  Open a new file.  Return error (-1) if the file already exists.  */
811
812 int
813 __gnat_open_new (char *path, int fmode)
814 {
815   int fd;
816   int o_fmode = O_BINARY;
817
818   if (fmode)
819     o_fmode = O_TEXT;
820
821 #if defined (VMS)
822   fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
823              "mbc=16", "deq=64", "fop=tef");
824 #elif defined (__MINGW32__)
825   {
826     TCHAR wpath[GNAT_MAX_PATH_LEN];
827
828     S2WSU (wpath, path, GNAT_MAX_PATH_LEN);
829     fd = _topen (wpath, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
830   }
831 #else
832   fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
833 #endif
834
835   return fd < 0 ? -1 : fd;
836 }
837
838 /* Open a new temp file.  Return error (-1) if the file already exists.
839    Special options for VMS allow the file to be shared between parent and child
840    processes, however they really slow down output.  Used in gnatchop.  */
841
842 int
843 __gnat_open_new_temp (char *path, int fmode)
844 {
845   int fd;
846   int o_fmode = O_BINARY;
847
848   strcpy (path, "GNAT-XXXXXX");
849
850 #if (defined (__FreeBSD__) || defined (linux)) && !defined (__vxworks)
851   return mkstemp (path);
852 #elif defined (__Lynx__)
853   mktemp (path);
854 #else
855   if (mktemp (path) == NULL)
856     return -1;
857 #endif
858
859   if (fmode)
860     o_fmode = O_TEXT;
861
862 #if defined (VMS)
863   fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
864              "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
865              "mbc=16", "deq=64", "fop=tef");
866 #else
867   fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
868 #endif
869
870   return fd < 0 ? -1 : fd;
871 }
872
873 /* Return the number of bytes in the specified file.  */
874
875 long
876 __gnat_file_length (int fd)
877 {
878   int ret;
879   struct stat statbuf;
880
881   ret = fstat (fd, &statbuf);
882   if (ret || !S_ISREG (statbuf.st_mode))
883     return 0;
884
885   return (statbuf.st_size);
886 }
887
888 /* Return the number of bytes in the specified named file.  */
889
890 long
891 __gnat_named_file_length (char *name)
892 {
893   int ret;
894   struct stat statbuf;
895
896   ret = __gnat_stat (name, &statbuf);
897   if (ret || !S_ISREG (statbuf.st_mode))
898     return 0;
899
900   return (statbuf.st_size);
901 }
902
903 /* Create a temporary filename and put it in string pointed to by
904    TMP_FILENAME.  */
905
906 void
907 __gnat_tmp_name (char *tmp_filename)
908 {
909 #ifdef __MINGW32__
910   {
911     char *pname;
912
913     /* tempnam tries to create a temporary file in directory pointed to by
914        TMP environment variable, in c:\temp if TMP is not set, and in
915        directory specified by P_tmpdir in stdio.h if c:\temp does not
916        exist. The filename will be created with the prefix "gnat-".  */
917
918     pname = (char *) tempnam ("c:\\temp", "gnat-");
919
920     /* if pname is NULL, the file was not created properly, the disk is full
921        or there is no more free temporary files */
922
923     if (pname == NULL)
924       *tmp_filename = '\0';
925
926     /* If pname start with a back slash and not path information it means that
927        the filename is valid for the current working directory.  */
928
929     else if (pname[0] == '\\')
930       {
931         strcpy (tmp_filename, ".\\");
932         strcat (tmp_filename, pname+1);
933       }
934     else
935       strcpy (tmp_filename, pname);
936
937     free (pname);
938   }
939
940 #elif defined (linux) || defined (__FreeBSD__)
941 #define MAX_SAFE_PATH 1000
942   char *tmpdir = getenv ("TMPDIR");
943
944   /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
945      a buffer overflow.  */
946   if (tmpdir == NULL || strlen (tmpdir) > MAX_SAFE_PATH)
947     strcpy (tmp_filename, "/tmp/gnat-XXXXXX");
948   else
949     sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
950
951   close (mkstemp(tmp_filename));
952 #else
953   tmpnam (tmp_filename);
954 #endif
955 }
956
957 /*  Open directory and returns a DIR pointer.  */
958
959 DIR* __gnat_opendir (char *name)
960 {
961 #ifdef __MINGW32__
962   TCHAR wname[GNAT_MAX_PATH_LEN];
963
964   S2WSU (wname, name, GNAT_MAX_PATH_LEN);
965   return (DIR*)_topendir (wname);
966
967 #else
968   return opendir (name);
969 #endif
970 }
971
972 /* Read the next entry in a directory.  The returned string points somewhere
973    in the buffer.  */
974
975 char *
976 __gnat_readdir (DIR *dirp, char *buffer, int *len)
977 {
978 #if defined (__MINGW32__)
979   struct _tdirent *dirent = _treaddir ((_TDIR*)dirp);
980
981   if (dirent != NULL)
982     {
983       WS2SU (buffer, dirent->d_name, GNAT_MAX_PATH_LEN);
984       *len = strlen (buffer);
985
986       return buffer;
987     }
988   else
989     return NULL;
990
991 #elif defined (HAVE_READDIR_R)
992   /* If possible, try to use the thread-safe version.  */
993   if (readdir_r (dirp, buffer) != NULL)
994     *len = strlen (((struct dirent*) buffer)->d_name);
995     return ((struct dirent*) buffer)->d_name;
996   else
997     return NULL;
998
999 #else
1000   struct dirent *dirent = (struct dirent *) readdir (dirp);
1001
1002   if (dirent != NULL)
1003     {
1004       strcpy (buffer, dirent->d_name);
1005       *len = strlen (buffer);
1006       return buffer;
1007     }
1008   else
1009     return NULL;
1010
1011 #endif
1012 }
1013
1014 /* Close a directory entry.  */
1015
1016 int __gnat_closedir (DIR *dirp)
1017 {
1018 #ifdef __MINGW32__
1019   return _tclosedir ((_TDIR*)dirp);
1020
1021 #else
1022   return closedir (dirp);
1023 #endif
1024 }
1025
1026 /* Returns 1 if readdir is thread safe, 0 otherwise.  */
1027
1028 int
1029 __gnat_readdir_is_thread_safe (void)
1030 {
1031 #ifdef HAVE_READDIR_R
1032   return 1;
1033 #else
1034   return 0;
1035 #endif
1036 }
1037
1038 #ifdef _WIN32
1039 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>.  */
1040 static const unsigned long long w32_epoch_offset = 11644473600ULL;
1041
1042 /* Returns the file modification timestamp using Win32 routines which are
1043    immune against daylight saving time change. It is in fact not possible to
1044    use fstat for this purpose as the DST modify the st_mtime field of the
1045    stat structure.  */
1046
1047 static time_t
1048 win32_filetime (HANDLE h)
1049 {
1050   union
1051   {
1052     FILETIME ft_time;
1053     unsigned long long ull_time;
1054   } t_write;
1055
1056   /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1057      since <Jan 1st 1601>. This function must return the number of seconds
1058      since <Jan 1st 1970>.  */
1059
1060   if (GetFileTime (h, NULL, NULL, &t_write.ft_time))
1061     return (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset);
1062   return (time_t) 0;
1063 }
1064 #endif
1065
1066 /* Return a GNAT time stamp given a file name.  */
1067
1068 OS_Time
1069 __gnat_file_time_name (char *name)
1070 {
1071
1072 #if defined (__EMX__) || defined (MSDOS)
1073   int fd = open (name, O_RDONLY | O_BINARY);
1074   time_t ret = __gnat_file_time_fd (fd);
1075   close (fd);
1076   return (OS_Time)ret;
1077
1078 #elif defined (_WIN32)
1079   time_t ret = -1;
1080   TCHAR wname[GNAT_MAX_PATH_LEN];
1081
1082   S2WSU (wname, name, GNAT_MAX_PATH_LEN);
1083
1084   HANDLE h = CreateFile
1085     (wname, GENERIC_READ, FILE_SHARE_READ, 0,
1086      OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
1087
1088   if (h != INVALID_HANDLE_VALUE)
1089     {
1090       ret = win32_filetime (h);
1091       CloseHandle (h);
1092     }
1093   return (OS_Time) ret;
1094 #else
1095   struct stat statbuf;
1096   if (__gnat_stat (name, &statbuf) != 0) {
1097      return (OS_Time)-1;
1098   } else {
1099 #ifdef VMS
1100      /* VMS has file versioning.  */
1101      return (OS_Time)statbuf.st_ctime;
1102 #else
1103      return (OS_Time)statbuf.st_mtime;
1104 #endif
1105   }
1106 #endif
1107 }
1108
1109 /* Return a GNAT time stamp given a file descriptor.  */
1110
1111 OS_Time
1112 __gnat_file_time_fd (int fd)
1113 {
1114   /* The following workaround code is due to the fact that under EMX and
1115      DJGPP fstat attempts to convert time values to GMT rather than keep the
1116      actual OS timestamp of the file. By using the OS2/DOS functions directly
1117      the GNAT timestamp are independent of this behavior, which is desired to
1118      facilitate the distribution of GNAT compiled libraries.  */
1119
1120 #if defined (__EMX__) || defined (MSDOS)
1121 #ifdef __EMX__
1122
1123   FILESTATUS fs;
1124   int ret = DosQueryFileInfo (fd, 1, (unsigned char *) &fs,
1125                                 sizeof (FILESTATUS));
1126
1127   unsigned file_year  = fs.fdateLastWrite.year;
1128   unsigned file_month = fs.fdateLastWrite.month;
1129   unsigned file_day   = fs.fdateLastWrite.day;
1130   unsigned file_hour  = fs.ftimeLastWrite.hours;
1131   unsigned file_min   = fs.ftimeLastWrite.minutes;
1132   unsigned file_tsec  = fs.ftimeLastWrite.twosecs;
1133
1134 #else
1135   struct ftime fs;
1136   int ret = getftime (fd, &fs);
1137
1138   unsigned file_year  = fs.ft_year;
1139   unsigned file_month = fs.ft_month;
1140   unsigned file_day   = fs.ft_day;
1141   unsigned file_hour  = fs.ft_hour;
1142   unsigned file_min   = fs.ft_min;
1143   unsigned file_tsec  = fs.ft_tsec;
1144 #endif
1145
1146   /* Calculate the seconds since epoch from the time components. First count
1147      the whole days passed.  The value for years returned by the DOS and OS2
1148      functions count years from 1980, so to compensate for the UNIX epoch which
1149      begins in 1970 start with 10 years worth of days and add days for each
1150      four year period since then.  */
1151
1152   time_t tot_secs;
1153   int cum_days[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
1154   int days_passed = 3652 + (file_year / 4) * 1461;
1155   int years_since_leap = file_year % 4;
1156
1157   if (years_since_leap == 1)
1158     days_passed += 366;
1159   else if (years_since_leap == 2)
1160     days_passed += 731;
1161   else if (years_since_leap == 3)
1162     days_passed += 1096;
1163
1164   if (file_year > 20)
1165     days_passed -= 1;
1166
1167   days_passed += cum_days[file_month - 1];
1168   if (years_since_leap == 0 && file_year != 20 && file_month > 2)
1169     days_passed++;
1170
1171   days_passed += file_day - 1;
1172
1173   /* OK - have whole days.  Multiply -- then add in other parts.  */
1174
1175   tot_secs  = days_passed * 86400;
1176   tot_secs += file_hour * 3600;
1177   tot_secs += file_min * 60;
1178   tot_secs += file_tsec * 2;
1179   return (OS_Time) tot_secs;
1180
1181 #elif defined (_WIN32)
1182   HANDLE h = (HANDLE) _get_osfhandle (fd);
1183   time_t ret = win32_filetime (h);
1184   return (OS_Time) ret;
1185
1186 #else
1187   struct stat statbuf;
1188
1189   if (fstat (fd, &statbuf) != 0) {
1190      return (OS_Time) -1;
1191   } else {
1192 #ifdef VMS
1193      /* VMS has file versioning.  */
1194      return (OS_Time) statbuf.st_ctime;
1195 #else
1196      return (OS_Time) statbuf.st_mtime;
1197 #endif
1198   }
1199 #endif
1200 }
1201
1202 /* Set the file time stamp.  */
1203
1204 void
1205 __gnat_set_file_time_name (char *name, time_t time_stamp)
1206 {
1207 #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1208
1209 /* Code to implement __gnat_set_file_time_name for these systems.  */
1210
1211 #elif defined (_WIN32)
1212   union
1213   {
1214     FILETIME ft_time;
1215     unsigned long long ull_time;
1216   } t_write;
1217   TCHAR wname[GNAT_MAX_PATH_LEN];
1218
1219   S2WSU (wname, name, GNAT_MAX_PATH_LEN);
1220
1221   HANDLE h  = CreateFile
1222     (wname, GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
1223      OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS,
1224      NULL);
1225   if (h == INVALID_HANDLE_VALUE)
1226     return;
1227   /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1228   t_write.ull_time = ((unsigned long long)time_stamp + w32_epoch_offset);
1229   /*  Convert to 100 nanosecond units  */
1230   t_write.ull_time *= 10000000ULL;
1231
1232   SetFileTime(h, NULL, NULL, &t_write.ft_time);
1233   CloseHandle (h);
1234   return;
1235
1236 #elif defined (VMS)
1237   struct FAB fab;
1238   struct NAM nam;
1239
1240   struct
1241     {
1242       unsigned long long backup, create, expire, revise;
1243       unsigned long uic;
1244       union
1245         {
1246           unsigned short value;
1247           struct
1248             {
1249               unsigned system : 4;
1250               unsigned owner  : 4;
1251               unsigned group  : 4;
1252               unsigned world  : 4;
1253             } bits;
1254         } prot;
1255     } Fat = { 0, 0, 0, 0, 0, { 0 }};
1256
1257   ATRDEF atrlst[]
1258     = {
1259       { ATR$S_CREDATE,  ATR$C_CREDATE,  &Fat.create },
1260       { ATR$S_REVDATE,  ATR$C_REVDATE,  &Fat.revise },
1261       { ATR$S_EXPDATE,  ATR$C_EXPDATE,  &Fat.expire },
1262       { ATR$S_BAKDATE,  ATR$C_BAKDATE,  &Fat.backup },
1263       { ATR$S_FPRO,     ATR$C_FPRO,     &Fat.prot },
1264       { ATR$S_UIC,      ATR$C_UIC,      &Fat.uic },
1265       { 0, 0, 0}
1266     };
1267
1268   FIBDEF fib;
1269   struct dsc$descriptor_fib fibdsc = {sizeof (fib), (void *) &fib};
1270
1271   struct IOSB iosb;
1272
1273   unsigned long long newtime;
1274   unsigned long long revtime;
1275   long status;
1276   short chan;
1277
1278   struct vstring file;
1279   struct dsc$descriptor_s filedsc
1280     = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) file.string};
1281   struct vstring device;
1282   struct dsc$descriptor_s devicedsc
1283     = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) device.string};
1284   struct vstring timev;
1285   struct dsc$descriptor_s timedsc
1286     = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) timev.string};
1287   struct vstring result;
1288   struct dsc$descriptor_s resultdsc
1289     = {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string};
1290
1291   /* Convert parameter name (a file spec) to host file form. Note that this
1292      is needed on VMS to prepare for subsequent calls to VMS RMS library
1293      routines. Note that it would not work to call __gnat_to_host_dir_spec
1294      as was done in a previous version, since this fails silently unless
1295      the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1296      (directory not found) condition is signalled.  */
1297   tryfile = (char *) __gnat_to_host_file_spec (name);
1298
1299   /* Allocate and initialize a FAB and NAM structures.  */
1300   fab = cc$rms_fab;
1301   nam = cc$rms_nam;
1302
1303   nam.nam$l_esa = file.string;
1304   nam.nam$b_ess = NAM$C_MAXRSS;
1305   nam.nam$l_rsa = result.string;
1306   nam.nam$b_rss = NAM$C_MAXRSS;
1307   fab.fab$l_fna = tryfile;
1308   fab.fab$b_fns = strlen (tryfile);
1309   fab.fab$l_nam = &nam;
1310
1311   /* Validate filespec syntax and device existence.  */
1312   status = SYS$PARSE (&fab, 0, 0);
1313   if ((status & 1) != 1)
1314     LIB$SIGNAL (status);
1315
1316   file.string[nam.nam$b_esl] = 0;
1317
1318   /* Find matching filespec.  */
1319   status = SYS$SEARCH (&fab, 0, 0);
1320   if ((status & 1) != 1)
1321     LIB$SIGNAL (status);
1322
1323   file.string[nam.nam$b_esl] = 0;
1324   result.string[result.length=nam.nam$b_rsl] = 0;
1325
1326   /* Get the device name and assign an IO channel.  */
1327   strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev);
1328   devicedsc.dsc$w_length  = nam.nam$b_dev;
1329   chan = 0;
1330   status = SYS$ASSIGN (&devicedsc, &chan, 0, 0, 0);
1331   if ((status & 1) != 1)
1332     LIB$SIGNAL (status);
1333
1334   /* Initialize the FIB and fill in the directory id field.  */
1335   memset (&fib, 0, sizeof (fib));
1336   fib.fib$w_did[0]  = nam.nam$w_did[0];
1337   fib.fib$w_did[1]  = nam.nam$w_did[1];
1338   fib.fib$w_did[2]  = nam.nam$w_did[2];
1339   fib.fib$l_acctl = 0;
1340   fib.fib$l_wcc = 0;
1341   strcpy (file.string, (strrchr (result.string, ']') + 1));
1342   filedsc.dsc$w_length = strlen (file.string);
1343   result.string[result.length = 0] = 0;
1344
1345   /* Open and close the file to fill in the attributes.  */
1346   status
1347     = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1348                 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1349   if ((status & 1) != 1)
1350     LIB$SIGNAL (status);
1351   if ((iosb.status & 1) != 1)
1352     LIB$SIGNAL (iosb.status);
1353
1354   result.string[result.length] = 0;
1355   status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, &fibdsc, 0, 0, 0,
1356                      &atrlst, 0);
1357   if ((status & 1) != 1)
1358     LIB$SIGNAL (status);
1359   if ((iosb.status & 1) != 1)
1360     LIB$SIGNAL (iosb.status);
1361
1362   {
1363     time_t t;
1364
1365     /* Set creation time to requested time.  */
1366     unix_time_to_vms (time_stamp, newtime);
1367
1368     t = time ((time_t) 0);
1369
1370     /* Set revision time to now in local time.  */
1371     unix_time_to_vms (t, revtime);
1372   }
1373
1374   /* Reopen the file, modify the times and then close.  */
1375   fib.fib$l_acctl = FIB$M_WRITE;
1376   status
1377     = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1378                 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1379   if ((status & 1) != 1)
1380     LIB$SIGNAL (status);
1381   if ((iosb.status & 1) != 1)
1382     LIB$SIGNAL (iosb.status);
1383
1384   Fat.create = newtime;
1385   Fat.revise = revtime;
1386
1387   status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0,
1388                      &fibdsc, 0, 0, 0, &atrlst, 0);
1389   if ((status & 1) != 1)
1390     LIB$SIGNAL (status);
1391   if ((iosb.status & 1) != 1)
1392     LIB$SIGNAL (iosb.status);
1393
1394   /* Deassign the channel and exit.  */
1395   status = SYS$DASSGN (chan);
1396   if ((status & 1) != 1)
1397     LIB$SIGNAL (status);
1398 #else
1399   struct utimbuf utimbuf;
1400   time_t t;
1401
1402   /* Set modification time to requested time.  */
1403   utimbuf.modtime = time_stamp;
1404
1405   /* Set access time to now in local time.  */
1406   t = time ((time_t) 0);
1407   utimbuf.actime = mktime (localtime (&t));
1408
1409   utime (name, &utimbuf);
1410 #endif
1411 }
1412
1413 #ifdef _WIN32
1414 #include <windows.h>
1415 #endif
1416
1417 /* Get the list of installed standard libraries from the
1418    HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1419    key.  */
1420
1421 char *
1422 __gnat_get_libraries_from_registry (void)
1423 {
1424   char *result = (char *) "";
1425
1426 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_DIRECTORY_STRUCTURE)
1427
1428   HKEY reg_key;
1429   DWORD name_size, value_size;
1430   char name[256];
1431   char value[256];
1432   DWORD type;
1433   DWORD index;
1434   LONG res;
1435
1436   /* First open the key.  */
1437   res = RegOpenKeyExA (HKEY_LOCAL_MACHINE, "SOFTWARE", 0, KEY_READ, &reg_key);
1438
1439   if (res == ERROR_SUCCESS)
1440     res = RegOpenKeyExA (reg_key, "Ada Core Technologies", 0,
1441                          KEY_READ, &reg_key);
1442
1443   if (res == ERROR_SUCCESS)
1444     res = RegOpenKeyExA (reg_key, "GNAT", 0, KEY_READ, &reg_key);
1445
1446   if (res == ERROR_SUCCESS)
1447     res = RegOpenKeyExA (reg_key, "Standard Libraries", 0, KEY_READ, &reg_key);
1448
1449   /* If the key exists, read out all the values in it and concatenate them
1450      into a path.  */
1451   for (index = 0; res == ERROR_SUCCESS; index++)
1452     {
1453       value_size = name_size = 256;
1454       res = RegEnumValueA (reg_key, index, (TCHAR*)name, &name_size, 0,
1455                            &type, (LPBYTE)value, &value_size);
1456
1457       if (res == ERROR_SUCCESS && type == REG_SZ)
1458         {
1459           char *old_result = result;
1460
1461           result = (char *) xmalloc (strlen (old_result) + value_size + 2);
1462           strcpy (result, old_result);
1463           strcat (result, value);
1464           strcat (result, ";");
1465         }
1466     }
1467
1468   /* Remove the trailing ";".  */
1469   if (result[0] != 0)
1470     result[strlen (result) - 1] = 0;
1471
1472 #endif
1473   return result;
1474 }
1475
1476 int
1477 __gnat_stat (char *name, struct stat *statbuf)
1478 {
1479 #ifdef __MINGW32__
1480   /* Under Windows the directory name for the stat function must not be
1481      terminated by a directory separator except if just after a drive name.  */
1482   TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1483   int name_len;
1484   TCHAR last_char;
1485
1486   S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
1487   name_len = _tcslen (wname);
1488
1489   if (name_len > GNAT_MAX_PATH_LEN)
1490     return -1;
1491
1492   last_char = wname[name_len - 1];
1493
1494   while (name_len > 1 && (last_char == _T('\\') || last_char == _T('/')))
1495     {
1496       wname[name_len - 1] = _T('\0');
1497       name_len--;
1498       last_char = wname[name_len - 1];
1499     }
1500
1501   /* Only a drive letter followed by ':', we must add a directory separator
1502      for the stat routine to work properly.  */
1503   if (name_len == 2 && wname[1] == _T(':'))
1504     _tcscat (wname, _T("\\"));
1505
1506   return _tstat (wname, statbuf);
1507
1508 #else
1509   return stat (name, statbuf);
1510 #endif
1511 }
1512
1513 int
1514 __gnat_file_exists (char *name)
1515 {
1516   struct stat statbuf;
1517
1518   return !__gnat_stat (name, &statbuf);
1519 }
1520
1521 int
1522 __gnat_is_absolute_path (char *name, int length)
1523 {
1524   return (length != 0) &&
1525      (*name == '/' || *name == DIR_SEPARATOR
1526 #if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
1527       || (length > 1 && isalpha (name[0]) && name[1] == ':')
1528 #endif
1529           );
1530 }
1531
1532 int
1533 __gnat_is_regular_file (char *name)
1534 {
1535   int ret;
1536   struct stat statbuf;
1537
1538   ret = __gnat_stat (name, &statbuf);
1539   return (!ret && S_ISREG (statbuf.st_mode));
1540 }
1541
1542 int
1543 __gnat_is_directory (char *name)
1544 {
1545   int ret;
1546   struct stat statbuf;
1547
1548   ret = __gnat_stat (name, &statbuf);
1549   return (!ret && S_ISDIR (statbuf.st_mode));
1550 }
1551
1552 int
1553 __gnat_is_readable_file (char *name)
1554 {
1555   int ret;
1556   int mode;
1557   struct stat statbuf;
1558
1559   ret = __gnat_stat (name, &statbuf);
1560   mode = statbuf.st_mode & S_IRUSR;
1561   return (!ret && mode);
1562 }
1563
1564 int
1565 __gnat_is_writable_file (char *name)
1566 {
1567   int ret;
1568   int mode;
1569   struct stat statbuf;
1570
1571   ret = __gnat_stat (name, &statbuf);
1572   mode = statbuf.st_mode & S_IWUSR;
1573   return (!ret && mode);
1574 }
1575
1576 void
1577 __gnat_set_writable (char *name)
1578 {
1579 #ifndef __vxworks
1580   struct stat statbuf;
1581
1582   if (stat (name, &statbuf) == 0)
1583   {
1584     statbuf.st_mode = statbuf.st_mode | S_IWUSR;
1585     chmod (name, statbuf.st_mode);
1586   }
1587 #endif
1588 }
1589
1590 void
1591 __gnat_set_executable (char *name)
1592 {
1593 #ifndef __vxworks
1594   struct stat statbuf;
1595
1596   if (stat (name, &statbuf) == 0)
1597   {
1598     statbuf.st_mode = statbuf.st_mode | S_IXUSR;
1599     chmod (name, statbuf.st_mode);
1600   }
1601 #endif
1602 }
1603
1604 void
1605 __gnat_set_readonly (char *name)
1606 {
1607 #ifndef __vxworks
1608   struct stat statbuf;
1609
1610   if (stat (name, &statbuf) == 0)
1611   {
1612     statbuf.st_mode = statbuf.st_mode & 07577;
1613     chmod (name, statbuf.st_mode);
1614   }
1615 #endif
1616 }
1617
1618 int
1619 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED)
1620 {
1621 #if defined (__vxworks)
1622   return 0;
1623
1624 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
1625   int ret;
1626   struct stat statbuf;
1627
1628   ret = lstat (name, &statbuf);
1629   return (!ret && S_ISLNK (statbuf.st_mode));
1630
1631 #else
1632   return 0;
1633 #endif
1634 }
1635
1636 #if defined (sun) && defined (__SVR4)
1637 /* Using fork on Solaris will duplicate all the threads. fork1, which
1638    duplicates only the active thread, must be used instead, or spawning
1639    subprocess from a program with tasking will lead into numerous problems.  */
1640 #define fork fork1
1641 #endif
1642
1643 int
1644 __gnat_portable_spawn (char *args[])
1645 {
1646   int status = 0;
1647   int finished ATTRIBUTE_UNUSED;
1648   int pid ATTRIBUTE_UNUSED;
1649
1650 #if defined (MSDOS) || defined (_WIN32)
1651   /* args[0] must be quotes as it could contain a full pathname with spaces */
1652   char *args_0 = args[0];
1653   args[0] = (char *)xmalloc (strlen (args_0) + 3);
1654   strcpy (args[0], "\"");
1655   strcat (args[0], args_0);
1656   strcat (args[0], "\"");
1657
1658   status = spawnvp (P_WAIT, args_0, (const char* const*)args);
1659
1660   /* restore previous value */
1661   free (args[0]);
1662   args[0] = (char *)args_0;
1663
1664   if (status < 0)
1665     return -1;
1666   else
1667     return status;
1668
1669 #elif defined (__vxworks)
1670   return -1;
1671 #else
1672
1673 #ifdef __EMX__
1674   pid = spawnvp (P_NOWAIT, args[0], args);
1675   if (pid == -1)
1676     return -1;
1677
1678 #else
1679   pid = fork ();
1680   if (pid < 0)
1681     return -1;
1682
1683   if (pid == 0)
1684     {
1685       /* The child. */
1686       if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
1687 #if defined (VMS)
1688         return -1; /* execv is in parent context on VMS.  */
1689 #else
1690         _exit (1);
1691 #endif
1692     }
1693 #endif
1694
1695   /* The parent.  */
1696   finished = waitpid (pid, &status, 0);
1697
1698   if (finished != pid || WIFEXITED (status) == 0)
1699     return -1;
1700
1701   return WEXITSTATUS (status);
1702 #endif
1703
1704   return 0;
1705 }
1706
1707 /* Create a copy of the given file descriptor.
1708    Return -1 if an error occurred.  */
1709
1710 int
1711 __gnat_dup (int oldfd)
1712 {
1713 #if defined (__vxworks) && !defined (__RTP__)
1714   /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
1715      RTPs. */
1716   return -1;
1717 #else
1718   return dup (oldfd);
1719 #endif
1720 }
1721
1722 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
1723    Return -1 if an error occurred.  */
1724
1725 int
1726 __gnat_dup2 (int oldfd, int newfd)
1727 {
1728 #if defined (__vxworks) && !defined (__RTP__)
1729   /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
1730      RTPs.  */
1731   return -1;
1732 #else
1733   return dup2 (oldfd, newfd);
1734 #endif
1735 }
1736
1737 /* WIN32 code to implement a wait call that wait for any child process.  */
1738
1739 #ifdef _WIN32
1740
1741 /* Synchronization code, to be thread safe.  */
1742
1743 static CRITICAL_SECTION plist_cs;
1744
1745 void
1746 __gnat_plist_init (void)
1747 {
1748   InitializeCriticalSection (&plist_cs);
1749 }
1750
1751 static void
1752 plist_enter (void)
1753 {
1754   EnterCriticalSection (&plist_cs);
1755 }
1756
1757 static void
1758 plist_leave (void)
1759 {
1760   LeaveCriticalSection (&plist_cs);
1761 }
1762
1763 typedef struct _process_list
1764 {
1765   HANDLE h;
1766   struct _process_list *next;
1767 } Process_List;
1768
1769 static Process_List *PLIST = NULL;
1770
1771 static int plist_length = 0;
1772
1773 static void
1774 add_handle (HANDLE h)
1775 {
1776   Process_List *pl;
1777
1778   pl = (Process_List *) xmalloc (sizeof (Process_List));
1779
1780   plist_enter();
1781
1782   /* -------------------- critical section -------------------- */
1783   pl->h = h;
1784   pl->next = PLIST;
1785   PLIST = pl;
1786   ++plist_length;
1787   /* -------------------- critical section -------------------- */
1788
1789   plist_leave();
1790 }
1791
1792 static void
1793 remove_handle (HANDLE h)
1794 {
1795   Process_List *pl;
1796   Process_List *prev = NULL;
1797
1798   plist_enter();
1799
1800   /* -------------------- critical section -------------------- */
1801   pl = PLIST;
1802   while (pl)
1803     {
1804       if (pl->h == h)
1805         {
1806           if (pl == PLIST)
1807             PLIST = pl->next;
1808           else
1809             prev->next = pl->next;
1810           free (pl);
1811           break;
1812         }
1813       else
1814         {
1815           prev = pl;
1816           pl = pl->next;
1817         }
1818     }
1819
1820   --plist_length;
1821   /* -------------------- critical section -------------------- */
1822
1823   plist_leave();
1824 }
1825
1826 static int
1827 win32_no_block_spawn (char *command, char *args[])
1828 {
1829   BOOL result;
1830   STARTUPINFO SI;
1831   PROCESS_INFORMATION PI;
1832   SECURITY_ATTRIBUTES SA;
1833   int csize = 1;
1834   char *full_command;
1835   int k;
1836
1837   /* compute the total command line length */
1838   k = 0;
1839   while (args[k])
1840     {
1841       csize += strlen (args[k]) + 1;
1842       k++;
1843     }
1844
1845   full_command = (char *) xmalloc (csize);
1846
1847   /* Startup info. */
1848   SI.cb          = sizeof (STARTUPINFO);
1849   SI.lpReserved  = NULL;
1850   SI.lpReserved2 = NULL;
1851   SI.lpDesktop   = NULL;
1852   SI.cbReserved2 = 0;
1853   SI.lpTitle     = NULL;
1854   SI.dwFlags     = 0;
1855   SI.wShowWindow = SW_HIDE;
1856
1857   /* Security attributes. */
1858   SA.nLength = sizeof (SECURITY_ATTRIBUTES);
1859   SA.bInheritHandle = TRUE;
1860   SA.lpSecurityDescriptor = NULL;
1861
1862   /* Prepare the command string. */
1863   strcpy (full_command, command);
1864   strcat (full_command, " ");
1865
1866   k = 1;
1867   while (args[k])
1868     {
1869       strcat (full_command, args[k]);
1870       strcat (full_command, " ");
1871       k++;
1872     }
1873
1874   {
1875     int wsize = csize * 2;
1876     TCHAR *wcommand = (TCHAR *) xmalloc (wsize);
1877
1878     S2WSU (wcommand, full_command, wsize);
1879
1880     free (full_command);
1881
1882     result = CreateProcess
1883       (NULL, wcommand, &SA, NULL, TRUE,
1884        GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
1885
1886     free (wcommand);
1887   }
1888
1889   if (result == TRUE)
1890     {
1891       add_handle (PI.hProcess);
1892       CloseHandle (PI.hThread);
1893       return (int) PI.hProcess;
1894     }
1895   else
1896     return -1;
1897 }
1898
1899 static int
1900 win32_wait (int *status)
1901 {
1902   DWORD exitcode;
1903   HANDLE *hl;
1904   HANDLE h;
1905   DWORD res;
1906   int k;
1907   Process_List *pl;
1908
1909   if (plist_length == 0)
1910     {
1911       errno = ECHILD;
1912       return -1;
1913     }
1914
1915   hl = (HANDLE *) xmalloc (sizeof (HANDLE) * plist_length);
1916
1917   k = 0;
1918   plist_enter();
1919
1920   /* -------------------- critical section -------------------- */
1921   pl = PLIST;
1922   while (pl)
1923     {
1924       hl[k++] = pl->h;
1925       pl = pl->next;
1926     }
1927   /* -------------------- critical section -------------------- */
1928
1929   plist_leave();
1930
1931   res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE);
1932   h = hl[res - WAIT_OBJECT_0];
1933   free (hl);
1934
1935   remove_handle (h);
1936
1937   GetExitCodeProcess (h, &exitcode);
1938   CloseHandle (h);
1939
1940   *status = (int) exitcode;
1941   return (int) h;
1942 }
1943
1944 #endif
1945
1946 int
1947 __gnat_portable_no_block_spawn (char *args[])
1948 {
1949   int pid = 0;
1950
1951 #if defined (__EMX__) || defined (MSDOS)
1952
1953   /* ??? For PC machines I (Franco) don't know the system calls to implement
1954      this routine. So I'll fake it as follows. This routine will behave
1955      exactly like the blocking portable_spawn and will systematically return
1956      a pid of 0 unless the spawned task did not complete successfully, in
1957      which case we return a pid of -1.  To synchronize with this the
1958      portable_wait below systematically returns a pid of 0 and reports that
1959      the subprocess terminated successfully. */
1960
1961   if (spawnvp (P_WAIT, args[0], args) != 0)
1962     return -1;
1963
1964 #elif defined (_WIN32)
1965
1966   pid = win32_no_block_spawn (args[0], args);
1967   return pid;
1968
1969 #elif defined (__vxworks)
1970   return -1;
1971
1972 #else
1973   pid = fork ();
1974
1975   if (pid == 0)
1976     {
1977       /* The child.  */
1978       if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
1979 #if defined (VMS)
1980         return -1; /* execv is in parent context on VMS. */
1981 #else
1982         _exit (1);
1983 #endif
1984     }
1985
1986 #endif
1987
1988   return pid;
1989 }
1990
1991 int
1992 __gnat_portable_wait (int *process_status)
1993 {
1994   int status = 0;
1995   int pid = 0;
1996
1997 #if defined (_WIN32)
1998
1999   pid = win32_wait (&status);
2000
2001 #elif defined (__EMX__) || defined (MSDOS)
2002   /* ??? See corresponding comment in portable_no_block_spawn.  */
2003
2004 #elif defined (__vxworks)
2005   /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
2006      return zero.  */
2007 #else
2008
2009   pid = waitpid (-1, &status, 0);
2010   status = status & 0xffff;
2011 #endif
2012
2013   *process_status = status;
2014   return pid;
2015 }
2016
2017 void
2018 __gnat_os_exit (int status)
2019 {
2020   exit (status);
2021 }
2022
2023 /* Locate a regular file, give a Path value.  */
2024
2025 char *
2026 __gnat_locate_regular_file (char *file_name, char *path_val)
2027 {
2028   char *ptr;
2029   char *file_path = alloca (strlen (file_name) + 1);
2030   int absolute;
2031
2032   /* Return immediately if file_name is empty */
2033
2034   if (*file_name == '\0')
2035     return 0;
2036
2037   /* Remove quotes around file_name if present */
2038
2039   ptr = file_name;
2040   if (*ptr == '"')
2041     ptr++;
2042
2043   strcpy (file_path, ptr);
2044
2045   ptr = file_path + strlen (file_path) - 1;
2046
2047   if (*ptr == '"')
2048     *ptr = '\0';
2049
2050   /* Handle absolute pathnames.  */
2051
2052   absolute = __gnat_is_absolute_path (file_path, strlen (file_name));
2053
2054   if (absolute)
2055     {
2056      if (__gnat_is_regular_file (file_path))
2057        return xstrdup (file_path);
2058
2059       return 0;
2060     }
2061
2062   /* If file_name include directory separator(s), try it first as
2063      a path name relative to the current directory */
2064   for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
2065     ;
2066
2067   if (*ptr != 0)
2068     {
2069       if (__gnat_is_regular_file (file_name))
2070         return xstrdup (file_name);
2071     }
2072
2073   if (path_val == 0)
2074     return 0;
2075
2076   {
2077     /* The result has to be smaller than path_val + file_name.  */
2078     char *file_path = alloca (strlen (path_val) + strlen (file_name) + 2);
2079
2080     for (;;)
2081       {
2082         for (; *path_val == PATH_SEPARATOR; path_val++)
2083           ;
2084
2085       if (*path_val == 0)
2086         return 0;
2087
2088       /* Skip the starting quote */
2089
2090       if (*path_val == '"')
2091         path_val++;
2092
2093       for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
2094         *ptr++ = *path_val++;
2095
2096       ptr--;
2097
2098       /* Skip the ending quote */
2099
2100       if (*ptr == '"')
2101         ptr--;
2102
2103       if (*ptr != '/' && *ptr != DIR_SEPARATOR)
2104         *++ptr = DIR_SEPARATOR;
2105
2106       strcpy (++ptr, file_name);
2107
2108       if (__gnat_is_regular_file (file_path))
2109         return xstrdup (file_path);
2110       }
2111   }
2112
2113   return 0;
2114 }
2115
2116 /* Locate an executable given a Path argument. This routine is only used by
2117    gnatbl and should not be used otherwise.  Use locate_exec_on_path
2118    instead.  */
2119
2120 char *
2121 __gnat_locate_exec (char *exec_name, char *path_val)
2122 {
2123   char *ptr;
2124   if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
2125     {
2126       char *full_exec_name
2127         = alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
2128
2129       strcpy (full_exec_name, exec_name);
2130       strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
2131       ptr = __gnat_locate_regular_file (full_exec_name, path_val);
2132
2133       if (ptr == 0)
2134          return __gnat_locate_regular_file (exec_name, path_val);
2135       return ptr;
2136     }
2137   else
2138     return __gnat_locate_regular_file (exec_name, path_val);
2139 }
2140
2141 /* Locate an executable using the Systems default PATH.  */
2142
2143 char *
2144 __gnat_locate_exec_on_path (char *exec_name)
2145 {
2146   char *apath_val;
2147
2148 #ifdef _WIN32
2149   TCHAR *wpath_val = _tgetenv (_T("PATH"));
2150   TCHAR *wapath_val;
2151   /* In Win32 systems we expand the PATH as for XP environment
2152      variables are not automatically expanded. We also prepend the
2153      ".;" to the path to match normal NT path search semantics */
2154
2155   #define EXPAND_BUFFER_SIZE 32767
2156
2157   wapath_val = alloca (EXPAND_BUFFER_SIZE);
2158
2159   wapath_val [0] = '.';
2160   wapath_val [1] = ';';
2161
2162   DWORD res = ExpandEnvironmentStrings
2163     (wpath_val, &wapath_val[2], EXPAND_BUFFER_SIZE - 2);
2164
2165   if (!res) wapath_val [0] = _T('\0');
2166
2167   apath_val = alloca (EXPAND_BUFFER_SIZE);
2168
2169   WS2SU (apath_val, wapath_val, EXPAND_BUFFER_SIZE);
2170   return __gnat_locate_exec (exec_name, apath_val);
2171
2172 #else
2173
2174 #ifdef VMS
2175   char *path_val = "/VAXC$PATH";
2176 #else
2177   char *path_val = getenv ("PATH");
2178 #endif
2179   if (path_val == NULL) return NULL;
2180   apath_val = alloca (strlen (path_val) + 1);
2181   strcpy (apath_val, path_val);
2182   return __gnat_locate_exec (exec_name, apath_val);
2183 #endif
2184 }
2185
2186 #ifdef VMS
2187
2188 /* These functions are used to translate to and from VMS and Unix syntax
2189    file, directory and path specifications.  */
2190
2191 #define MAXPATH  256
2192 #define MAXNAMES 256
2193 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2194
2195 static char new_canonical_dirspec [MAXPATH];
2196 static char new_canonical_filespec [MAXPATH];
2197 static char new_canonical_pathspec [MAXNAMES*MAXPATH];
2198 static unsigned new_canonical_filelist_index;
2199 static unsigned new_canonical_filelist_in_use;
2200 static unsigned new_canonical_filelist_allocated;
2201 static char **new_canonical_filelist;
2202 static char new_host_pathspec [MAXNAMES*MAXPATH];
2203 static char new_host_dirspec [MAXPATH];
2204 static char new_host_filespec [MAXPATH];
2205
2206 /* Routine is called repeatedly by decc$from_vms via
2207    __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2208    runs out. */
2209
2210 static int
2211 wildcard_translate_unix (char *name)
2212 {
2213   char *ver;
2214   char buff [MAXPATH];
2215
2216   strncpy (buff, name, MAXPATH);
2217   buff [MAXPATH - 1] = (char) 0;
2218   ver = strrchr (buff, '.');
2219
2220   /* Chop off the version.  */
2221   if (ver)
2222     *ver = 0;
2223
2224   /* Dynamically extend the allocation by the increment.  */
2225   if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
2226     {
2227       new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
2228       new_canonical_filelist = (char **) xrealloc
2229         (new_canonical_filelist,
2230          new_canonical_filelist_allocated * sizeof (char *));
2231     }
2232
2233   new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
2234
2235   return 1;
2236 }
2237
2238 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2239    full translation and copy the results into a list (_init), then return them
2240    one at a time (_next). If onlydirs set, only expand directory files.  */
2241
2242 int
2243 __gnat_to_canonical_file_list_init (char *filespec, int onlydirs)
2244 {
2245   int len;
2246   char buff [MAXPATH];
2247
2248   len = strlen (filespec);
2249   strncpy (buff, filespec, MAXPATH);
2250
2251   /* Only look for directories */
2252   if (onlydirs && !strstr (&buff [len-5], "*.dir"))
2253     strncat (buff, "*.dir", MAXPATH);
2254
2255   buff [MAXPATH - 1] = (char) 0;
2256
2257   decc$from_vms (buff, wildcard_translate_unix, 1);
2258
2259   /* Remove the .dir extension.  */
2260   if (onlydirs)
2261     {
2262       int i;
2263       char *ext;
2264
2265       for (i = 0; i < new_canonical_filelist_in_use; i++)
2266         {
2267           ext = strstr (new_canonical_filelist[i], ".dir");
2268           if (ext)
2269             *ext = 0;
2270         }
2271     }
2272
2273   return new_canonical_filelist_in_use;
2274 }
2275
2276 /* Return the next filespec in the list.  */
2277
2278 char *
2279 __gnat_to_canonical_file_list_next ()
2280 {
2281   return new_canonical_filelist[new_canonical_filelist_index++];
2282 }
2283
2284 /* Free storage used in the wildcard expansion.  */
2285
2286 void
2287 __gnat_to_canonical_file_list_free ()
2288 {
2289   int i;
2290
2291    for (i = 0; i < new_canonical_filelist_in_use; i++)
2292      free (new_canonical_filelist[i]);
2293
2294   free (new_canonical_filelist);
2295
2296   new_canonical_filelist_in_use = 0;
2297   new_canonical_filelist_allocated = 0;
2298   new_canonical_filelist_index = 0;
2299   new_canonical_filelist = 0;
2300 }
2301
2302 /* Translate a VMS syntax directory specification in to Unix syntax.  If
2303    PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2304    found, return input string. Also translate a dirname that contains no
2305    slashes, in case it's a logical name.  */
2306
2307 char *
2308 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag)
2309 {
2310   int len;
2311
2312   strcpy (new_canonical_dirspec, "");
2313   if (strlen (dirspec))
2314     {
2315       char *dirspec1;
2316
2317       if (strchr (dirspec, ']') || strchr (dirspec, ':'))
2318         {
2319           strncpy (new_canonical_dirspec,
2320                    (char *) decc$translate_vms (dirspec),
2321                    MAXPATH);
2322         }
2323       else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
2324         {
2325           strncpy (new_canonical_dirspec,
2326                   (char *) decc$translate_vms (dirspec1),
2327                   MAXPATH);
2328         }
2329       else
2330         {
2331           strncpy (new_canonical_dirspec, dirspec, MAXPATH);
2332         }
2333     }
2334
2335   len = strlen (new_canonical_dirspec);
2336   if (prefixflag && new_canonical_dirspec [len-1] != '/')
2337     strncat (new_canonical_dirspec, "/", MAXPATH);
2338
2339   new_canonical_dirspec [MAXPATH - 1] = (char) 0;
2340
2341   return new_canonical_dirspec;
2342
2343 }
2344
2345 /* Translate a VMS syntax file specification into Unix syntax.
2346    If no indicators of VMS syntax found, check if it's an uppercase
2347    alphanumeric_ name and if so try it out as an environment
2348    variable (logical name). If all else fails return the
2349    input string.  */
2350
2351 char *
2352 __gnat_to_canonical_file_spec (char *filespec)
2353 {
2354   char *filespec1;
2355
2356   strncpy (new_canonical_filespec, "", MAXPATH);
2357
2358   if (strchr (filespec, ']') || strchr (filespec, ':'))
2359     {
2360       char *tspec = (char *) decc$translate_vms (filespec);
2361
2362       if (tspec != (char *) -1)
2363         strncpy (new_canonical_filespec, tspec, MAXPATH);
2364     }
2365   else if ((strlen (filespec) == strspn (filespec,
2366             "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
2367         && (filespec1 = getenv (filespec)))
2368     {
2369       char *tspec = (char *) decc$translate_vms (filespec1);
2370
2371       if (tspec != (char *) -1)
2372         strncpy (new_canonical_filespec, tspec, MAXPATH);
2373     }
2374   else
2375     {
2376       strncpy (new_canonical_filespec, filespec, MAXPATH);
2377     }
2378
2379   new_canonical_filespec [MAXPATH - 1] = (char) 0;
2380
2381   return new_canonical_filespec;
2382 }
2383
2384 /* Translate a VMS syntax path specification into Unix syntax.
2385    If no indicators of VMS syntax found, return input string.  */
2386
2387 char *
2388 __gnat_to_canonical_path_spec (char *pathspec)
2389 {
2390   char *curr, *next, buff [MAXPATH];
2391
2392   if (pathspec == 0)
2393     return pathspec;
2394
2395   /* If there are /'s, assume it's a Unix path spec and return.  */
2396   if (strchr (pathspec, '/'))
2397     return pathspec;
2398
2399   new_canonical_pathspec[0] = 0;
2400   curr = pathspec;
2401
2402   for (;;)
2403     {
2404       next = strchr (curr, ',');
2405       if (next == 0)
2406         next = strchr (curr, 0);
2407
2408       strncpy (buff, curr, next - curr);
2409       buff[next - curr] = 0;
2410
2411       /* Check for wildcards and expand if present.  */
2412       if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
2413         {
2414           int i, dirs;
2415
2416           dirs = __gnat_to_canonical_file_list_init (buff, 1);
2417           for (i = 0; i < dirs; i++)
2418             {
2419               char *next_dir;
2420
2421               next_dir = __gnat_to_canonical_file_list_next ();
2422               strncat (new_canonical_pathspec, next_dir, MAXPATH);
2423
2424               /* Don't append the separator after the last expansion.  */
2425               if (i+1 < dirs)
2426                 strncat (new_canonical_pathspec, ":", MAXPATH);
2427             }
2428
2429           __gnat_to_canonical_file_list_free ();
2430         }
2431       else
2432         strncat (new_canonical_pathspec,
2433                 __gnat_to_canonical_dir_spec (buff, 0), MAXPATH);
2434
2435       if (*next == 0)
2436         break;
2437
2438       strncat (new_canonical_pathspec, ":", MAXPATH);
2439       curr = next + 1;
2440     }
2441
2442   new_canonical_pathspec [MAXPATH - 1] = (char) 0;
2443
2444   return new_canonical_pathspec;
2445 }
2446
2447 static char filename_buff [MAXPATH];
2448
2449 static int
2450 translate_unix (char *name, int type)
2451 {
2452   strncpy (filename_buff, name, MAXPATH);
2453   filename_buff [MAXPATH - 1] = (char) 0;
2454   return 0;
2455 }
2456
2457 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
2458    directories.  */
2459
2460 static char *
2461 to_host_path_spec (char *pathspec)
2462 {
2463   char *curr, *next, buff [MAXPATH];
2464
2465   if (pathspec == 0)
2466     return pathspec;
2467
2468   /* Can't very well test for colons, since that's the Unix separator!  */
2469   if (strchr (pathspec, ']') || strchr (pathspec, ','))
2470     return pathspec;
2471
2472   new_host_pathspec[0] = 0;
2473   curr = pathspec;
2474
2475   for (;;)
2476     {
2477       next = strchr (curr, ':');
2478       if (next == 0)
2479         next = strchr (curr, 0);
2480
2481       strncpy (buff, curr, next - curr);
2482       buff[next - curr] = 0;
2483
2484       strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH);
2485       if (*next == 0)
2486         break;
2487       strncat (new_host_pathspec, ",", MAXPATH);
2488       curr = next + 1;
2489     }
2490
2491   new_host_pathspec [MAXPATH - 1] = (char) 0;
2492
2493   return new_host_pathspec;
2494 }
2495
2496 /* Translate a Unix syntax directory specification into VMS syntax.  The
2497    PREFIXFLAG has no effect, but is kept for symmetry with
2498    to_canonical_dir_spec.  If indicators of VMS syntax found, return input
2499    string. */
2500
2501 char *
2502 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2503 {
2504   int len = strlen (dirspec);
2505
2506   strncpy (new_host_dirspec, dirspec, MAXPATH);
2507   new_host_dirspec [MAXPATH - 1] = (char) 0;
2508
2509   if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
2510     return new_host_dirspec;
2511
2512   while (len > 1 && new_host_dirspec[len - 1] == '/')
2513     {
2514       new_host_dirspec[len - 1] = 0;
2515       len--;
2516     }
2517
2518   decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
2519   strncpy (new_host_dirspec, filename_buff, MAXPATH);
2520   new_host_dirspec [MAXPATH - 1] = (char) 0;
2521
2522   return new_host_dirspec;
2523 }
2524
2525 /* Translate a Unix syntax file specification into VMS syntax.
2526    If indicators of VMS syntax found, return input string.  */
2527
2528 char *
2529 __gnat_to_host_file_spec (char *filespec)
2530 {
2531   strncpy (new_host_filespec, "", MAXPATH);
2532   if (strchr (filespec, ']') || strchr (filespec, ':'))
2533     {
2534       strncpy (new_host_filespec, filespec, MAXPATH);
2535     }
2536   else
2537     {
2538       decc$to_vms (filespec, translate_unix, 1, 1);
2539       strncpy (new_host_filespec, filename_buff, MAXPATH);
2540     }
2541
2542   new_host_filespec [MAXPATH - 1] = (char) 0;
2543
2544   return new_host_filespec;
2545 }
2546
2547 void
2548 __gnat_adjust_os_resource_limits ()
2549 {
2550   SYS$ADJWSL (131072, 0);
2551 }
2552
2553 #else /* VMS */
2554
2555 /* Dummy functions for Osint import for non-VMS systems.  */
2556
2557 int
2558 __gnat_to_canonical_file_list_init
2559   (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED)
2560 {
2561   return 0;
2562 }
2563
2564 char *
2565 __gnat_to_canonical_file_list_next (void)
2566 {
2567   return (char *) "";
2568 }
2569
2570 void
2571 __gnat_to_canonical_file_list_free (void)
2572 {
2573 }
2574
2575 char *
2576 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2577 {
2578   return dirspec;
2579 }
2580
2581 char *
2582 __gnat_to_canonical_file_spec (char *filespec)
2583 {
2584   return filespec;
2585 }
2586
2587 char *
2588 __gnat_to_canonical_path_spec (char *pathspec)
2589 {
2590   return pathspec;
2591 }
2592
2593 char *
2594 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2595 {
2596   return dirspec;
2597 }
2598
2599 char *
2600 __gnat_to_host_file_spec (char *filespec)
2601 {
2602   return filespec;
2603 }
2604
2605 void
2606 __gnat_adjust_os_resource_limits (void)
2607 {
2608 }
2609
2610 #endif
2611
2612 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
2613    to coordinate this with the EMX distribution. Consequently, we put the
2614    definition of dummy which is used for exception handling, here.  */
2615
2616 #if defined (__EMX__)
2617 void __dummy () {}
2618 #endif
2619
2620 #if defined (__mips_vxworks)
2621 int
2622 _flush_cache()
2623 {
2624    CACHE_USER_FLUSH (0, ENTIRE_CACHE);
2625 }
2626 #endif
2627
2628 #if defined (CROSS_DIRECTORY_STRUCTURE)  \
2629   || (! ((defined (sparc) || defined (i386)) && defined (sun) \
2630       && defined (__SVR4)) \
2631       && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
2632       && ! (defined (linux) && defined (__ia64__)) \
2633       && ! defined (__FreeBSD__) \
2634       && ! defined (__hpux__) \
2635       && ! defined (__APPLE__) \
2636       && ! defined (_AIX) \
2637       && ! (defined (__alpha__)  && defined (__osf__)) \
2638       && ! defined (VMS) \
2639       && ! defined (__MINGW32__) \
2640       && ! (defined (__mips) && defined (__sgi)))
2641
2642 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
2643    just above for a list of native platforms that provide a non-dummy
2644    version of this procedure in libaddr2line.a.  */
2645
2646 void
2647 convert_addresses (const char *file_name ATTRIBUTE_UNUSED,
2648                    void *addrs ATTRIBUTE_UNUSED,
2649                    int n_addr ATTRIBUTE_UNUSED,
2650                    void *buf ATTRIBUTE_UNUSED,
2651                    int *len ATTRIBUTE_UNUSED)
2652 {
2653   *len = 0;
2654 }
2655 #endif
2656
2657 #if defined (_WIN32)
2658 int __gnat_argument_needs_quote = 1;
2659 #else
2660 int __gnat_argument_needs_quote = 0;
2661 #endif
2662
2663 /* This option is used to enable/disable object files handling from the
2664    binder file by the GNAT Project module. For example, this is disabled on
2665    Windows (prior to GCC 3.4) as it is already done by the mdll module.
2666    Stating with GCC 3.4 the shared libraries are not based on mdll
2667    anymore as it uses the GCC's -shared option  */
2668 #if defined (_WIN32) \
2669     && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
2670 int __gnat_prj_add_obj_files = 0;
2671 #else
2672 int __gnat_prj_add_obj_files = 1;
2673 #endif
2674
2675 /* char used as prefix/suffix for environment variables */
2676 #if defined (_WIN32)
2677 char __gnat_environment_char = '%';
2678 #else
2679 char __gnat_environment_char = '$';
2680 #endif
2681
2682 /* This functions copy the file attributes from a source file to a
2683    destination file.
2684
2685    mode = 0  : In this mode copy only the file time stamps (last access and
2686                last modification time stamps).
2687
2688    mode = 1  : In this mode, time stamps and read/write/execute attributes are
2689                copied.
2690
2691    Returns 0 if operation was successful and -1 in case of error. */
2692
2693 int
2694 __gnat_copy_attribs (char *from, char *to, int mode)
2695 {
2696 #if defined (VMS) || defined (__vxworks)
2697   return -1;
2698 #else
2699   struct stat fbuf;
2700   struct utimbuf tbuf;
2701
2702   if (stat (from, &fbuf) == -1)
2703     {
2704       return -1;
2705     }
2706
2707   tbuf.actime = fbuf.st_atime;
2708   tbuf.modtime = fbuf.st_mtime;
2709
2710   if (utime (to, &tbuf) == -1)
2711     {
2712       return -1;
2713     }
2714
2715   if (mode == 1)
2716     {
2717       if (chmod (to, fbuf.st_mode) == -1)
2718         {
2719           return -1;
2720         }
2721     }
2722
2723   return 0;
2724 #endif
2725 }
2726
2727 int
2728 __gnat_lseek (int fd, long offset, int whence)
2729 {
2730   return (int) lseek (fd, offset, whence);
2731 }
2732
2733 /* This function returns the major version number of GCC being used.  */
2734 int
2735 get_gcc_version (void)
2736 {
2737 #ifdef IN_RTS
2738   return __GNUC__;
2739 #else
2740   return (int) (version_string[0] - '0');
2741 #endif
2742 }
2743
2744 int
2745 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED,
2746                         int close_on_exec_p ATTRIBUTE_UNUSED)
2747 {
2748 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
2749   int flags = fcntl (fd, F_GETFD, 0);
2750   if (flags < 0)
2751     return flags;
2752   if (close_on_exec_p)
2753     flags |= FD_CLOEXEC;
2754   else
2755     flags &= ~FD_CLOEXEC;
2756   return fcntl (fd, F_SETFD, flags | FD_CLOEXEC);
2757 #else
2758   return -1;
2759   /* For the Windows case, we should use SetHandleInformation to remove
2760      the HANDLE_INHERIT property from fd. This is not implemented yet,
2761      but for our purposes (support of GNAT.Expect) this does not matter,
2762      as by default handles are *not* inherited. */
2763 #endif
2764 }
2765
2766 /* Indicates if platforms supports automatic initialization through the
2767    constructor mechanism */
2768 int
2769 __gnat_binder_supports_auto_init ()
2770 {
2771 #ifdef VMS
2772    return 0;
2773 #else
2774    return 1;
2775 #endif
2776 }
2777
2778 /* Indicates that Stand-Alone Libraries are automatically initialized through
2779    the constructor mechanism */
2780 int
2781 __gnat_sals_init_using_constructors ()
2782 {
2783 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
2784    return 0;
2785 #else
2786    return 1;
2787 #endif
2788 }