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