gcc/ada/adaint.c

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