gcc/ada/adaint.c

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