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