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 #else
2453   return dup2 (oldfd, newfd);
2454 #endif
2455 }
2456
2457 int
2458 __gnat_number_of_cpus (void)
2459 {
2460   int cores = 1;
2461
2462 #if defined (linux) || defined (sun) || defined (AIX) \
2463     || (defined (__alpha__)  && defined (_osf_)) || defined (__APPLE__)
2464   cores = (int) sysconf (_SC_NPROCESSORS_ONLN);
2465
2466 #elif (defined (__mips) && defined (__sgi))
2467   cores = (int) sysconf (_SC_NPROC_ONLN);
2468
2469 #elif defined (__hpux__)
2470   struct pst_dynamic psd;
2471   if (pstat_getdynamic (&psd, sizeof (psd), 1, 0) != -1)
2472     cores = (int) psd.psd_proc_cnt;
2473
2474 #elif defined (_WIN32)
2475   SYSTEM_INFO sysinfo;
2476   GetSystemInfo (&sysinfo);
2477   cores = (int) sysinfo.dwNumberOfProcessors;
2478
2479 #elif defined (VMS)
2480   int code = SYI$_ACTIVECPU_CNT;
2481   unsigned int res;
2482   int status;
2483
2484   status = LIB$GETSYI (&code, &res);
2485   if ((status & 1) != 0)
2486     cores = res;
2487
2488 #elif defined (_WRS_CONFIG_SMP)
2489   unsigned int vxCpuConfiguredGet (void);
2490
2491   cores = vxCpuConfiguredGet ();
2492
2493 #endif
2494
2495   return cores;
2496 }
2497
2498 /* WIN32 code to implement a wait call that wait for any child process.  */
2499
2500 #if defined (_WIN32) && !defined (RTX)
2501
2502 /* Synchronization code, to be thread safe.  */
2503
2504 #ifdef CERT
2505
2506 /* For the Cert run times on native Windows we use dummy functions
2507    for locking and unlocking tasks since we do not support multiple
2508    threads on this configuration (Cert run time on native Windows). */
2509
2510 void dummy (void) {}
2511
2512 void (*Lock_Task) ()   = &dummy;
2513 void (*Unlock_Task) () = &dummy;
2514
2515 #else
2516
2517 #define Lock_Task system__soft_links__lock_task
2518 extern void (*Lock_Task) (void);
2519
2520 #define Unlock_Task system__soft_links__unlock_task
2521 extern void (*Unlock_Task) (void);
2522
2523 #endif
2524
2525 static HANDLE *HANDLES_LIST = NULL;
2526 static int *PID_LIST = NULL, plist_length = 0, plist_max_length = 0;
2527
2528 static void
2529 add_handle (HANDLE h, int pid)
2530 {
2531
2532   /* -------------------- critical section -------------------- */
2533   (*Lock_Task) ();
2534
2535   if (plist_length == plist_max_length)
2536     {
2537       plist_max_length += 1000;
2538       HANDLES_LIST =
2539         xrealloc (HANDLES_LIST, sizeof (HANDLE) * plist_max_length);
2540       PID_LIST =
2541         xrealloc (PID_LIST, sizeof (int) * plist_max_length);
2542     }
2543
2544   HANDLES_LIST[plist_length] = h;
2545   PID_LIST[plist_length] = pid;
2546   ++plist_length;
2547
2548   (*Unlock_Task) ();
2549   /* -------------------- critical section -------------------- */
2550 }
2551
2552 void
2553 __gnat_win32_remove_handle (HANDLE h, int pid)
2554 {
2555   int j;
2556
2557   /* -------------------- critical section -------------------- */
2558   (*Lock_Task) ();
2559
2560   for (j = 0; j < plist_length; j++)
2561     {
2562       if ((HANDLES_LIST[j] == h) || (PID_LIST[j] == pid))
2563         {
2564           CloseHandle (h);
2565           --plist_length;
2566           HANDLES_LIST[j] = HANDLES_LIST[plist_length];
2567           PID_LIST[j] = PID_LIST[plist_length];
2568           break;
2569         }
2570     }
2571
2572   (*Unlock_Task) ();
2573   /* -------------------- critical section -------------------- */
2574 }
2575
2576 static void
2577 win32_no_block_spawn (char *command, char *args[], HANDLE *h, int *pid)
2578 {
2579   BOOL result;
2580   STARTUPINFO SI;
2581   PROCESS_INFORMATION PI;
2582   SECURITY_ATTRIBUTES SA;
2583   int csize = 1;
2584   char *full_command;
2585   int k;
2586
2587   /* compute the total command line length */
2588   k = 0;
2589   while (args[k])
2590     {
2591       csize += strlen (args[k]) + 1;
2592       k++;
2593     }
2594
2595   full_command = (char *) xmalloc (csize);
2596
2597   /* Startup info. */
2598   SI.cb          = sizeof (STARTUPINFO);
2599   SI.lpReserved  = NULL;
2600   SI.lpReserved2 = NULL;
2601   SI.lpDesktop   = NULL;
2602   SI.cbReserved2 = 0;
2603   SI.lpTitle     = NULL;
2604   SI.dwFlags     = 0;
2605   SI.wShowWindow = SW_HIDE;
2606
2607   /* Security attributes. */
2608   SA.nLength = sizeof (SECURITY_ATTRIBUTES);
2609   SA.bInheritHandle = TRUE;
2610   SA.lpSecurityDescriptor = NULL;
2611
2612   /* Prepare the command string. */
2613   strcpy (full_command, command);
2614   strcat (full_command, " ");
2615
2616   k = 1;
2617   while (args[k])
2618     {
2619       strcat (full_command, args[k]);
2620       strcat (full_command, " ");
2621       k++;
2622     }
2623
2624   {
2625     int wsize = csize * 2;
2626     TCHAR *wcommand = (TCHAR *) xmalloc (wsize);
2627
2628     S2WSC (wcommand, full_command, wsize);
2629
2630     free (full_command);
2631
2632     result = CreateProcess
2633       (NULL, wcommand, &SA, NULL, TRUE,
2634        GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
2635
2636     free (wcommand);
2637   }
2638
2639   if (result == TRUE)
2640     {
2641       CloseHandle (PI.hThread);
2642       *h = PI.hProcess;
2643       *pid = PI.dwProcessId;
2644     }
2645   else
2646     {
2647       *h = NULL;
2648       *pid = 0;
2649     }
2650 }
2651
2652 static int
2653 win32_wait (int *status)
2654 {
2655   DWORD exitcode, pid;
2656   HANDLE *hl;
2657   HANDLE h;
2658   DWORD res;
2659   int k;
2660   int hl_len;
2661
2662   if (plist_length == 0)
2663     {
2664       errno = ECHILD;
2665       return -1;
2666     }
2667
2668   k = 0;
2669
2670   /* -------------------- critical section -------------------- */
2671   (*Lock_Task) ();
2672
2673   hl_len = plist_length;
2674
2675   hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len);
2676
2677   memmove (hl, HANDLES_LIST, sizeof (HANDLE) * hl_len);
2678
2679   (*Unlock_Task) ();
2680   /* -------------------- critical section -------------------- */
2681
2682   res = WaitForMultipleObjects (hl_len, hl, FALSE, INFINITE);
2683   h = hl[res - WAIT_OBJECT_0];
2684
2685   GetExitCodeProcess (h, &exitcode);
2686   pid = PID_LIST [res - WAIT_OBJECT_0];
2687   __gnat_win32_remove_handle (h, -1);
2688
2689   free (hl);
2690
2691   *status = (int) exitcode;
2692   return (int) pid;
2693 }
2694
2695 #endif
2696
2697 int
2698 __gnat_portable_no_block_spawn (char *args[])
2699 {
2700
2701 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2702   return -1;
2703
2704 #elif defined (_WIN32)
2705
2706   HANDLE h = NULL;
2707   int pid;
2708
2709   win32_no_block_spawn (args[0], args, &h, &pid);
2710   if (h != NULL)
2711     {
2712       add_handle (h, pid);
2713       return pid;
2714     }
2715   else
2716     return -1;
2717
2718 #else
2719
2720   int pid = fork ();
2721
2722   if (pid == 0)
2723     {
2724       /* The child.  */
2725       if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
2726 #if defined (VMS)
2727         return -1; /* execv is in parent context on VMS. */
2728 #else
2729         _exit (1);
2730 #endif
2731     }
2732
2733   return pid;
2734
2735   #endif
2736 }
2737
2738 int
2739 __gnat_portable_wait (int *process_status)
2740 {
2741   int status = 0;
2742   int pid = 0;
2743
2744 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2745   /* Not sure what to do here, so do nothing but return zero.  */
2746
2747 #elif defined (_WIN32)
2748
2749   pid = win32_wait (&status);
2750
2751 #else
2752
2753   pid = waitpid (-1, &status, 0);
2754   status = status & 0xffff;
2755 #endif
2756
2757   *process_status = status;
2758   return pid;
2759 }
2760
2761 void
2762 __gnat_os_exit (int status)
2763 {
2764   exit (status);
2765 }
2766
2767 /* Locate file on path, that matches a predicate */
2768
2769 char *
2770 __gnat_locate_file_with_predicate
2771    (char *file_name, char *path_val, int (*predicate)(char*))
2772 {
2773   char *ptr;
2774   char *file_path = (char *) alloca (strlen (file_name) + 1);
2775   int absolute;
2776
2777   /* Return immediately if file_name is empty */
2778
2779   if (*file_name == '\0')
2780     return 0;
2781
2782   /* Remove quotes around file_name if present */
2783
2784   ptr = file_name;
2785   if (*ptr == '"')
2786     ptr++;
2787
2788   strcpy (file_path, ptr);
2789
2790   ptr = file_path + strlen (file_path) - 1;
2791
2792   if (*ptr == '"')
2793     *ptr = '\0';
2794
2795   /* Handle absolute pathnames.  */
2796
2797   absolute = __gnat_is_absolute_path (file_path, strlen (file_name));
2798
2799   if (absolute)
2800     {
2801      if (predicate (file_path))
2802        return xstrdup (file_path);
2803
2804       return 0;
2805     }
2806
2807   /* If file_name include directory separator(s), try it first as
2808      a path name relative to the current directory */
2809   for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
2810     ;
2811
2812   if (*ptr != 0)
2813     {
2814       if (predicate (file_name))
2815         return xstrdup (file_name);
2816     }
2817
2818   if (path_val == 0)
2819     return 0;
2820
2821   {
2822     /* The result has to be smaller than path_val + file_name.  */
2823     char *file_path =
2824       (char *) alloca (strlen (path_val) + strlen (file_name) + 2);
2825
2826     for (;;)
2827       {
2828       /* Skip the starting quote */
2829
2830       if (*path_val == '"')
2831         path_val++;
2832
2833       for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
2834         *ptr++ = *path_val++;
2835
2836       /* If directory is empty, it is the current directory*/
2837
2838       if (ptr == file_path)
2839         {
2840          *ptr = '.';
2841         }
2842       else
2843         ptr--;
2844
2845       /* Skip the ending quote */
2846
2847       if (*ptr == '"')
2848         ptr--;
2849
2850       if (*ptr != '/' && *ptr != DIR_SEPARATOR)
2851         *++ptr = DIR_SEPARATOR;
2852
2853       strcpy (++ptr, file_name);
2854
2855       if (predicate (file_path))
2856         return xstrdup (file_path);
2857
2858       if (*path_val == 0)
2859         return 0;
2860
2861       /* Skip path separator */
2862
2863       path_val++;
2864       }
2865   }
2866
2867   return 0;
2868 }
2869
2870 /* Locate an executable file, give a Path value.  */
2871
2872 char *
2873 __gnat_locate_executable_file (char *file_name, char *path_val)
2874 {
2875    return __gnat_locate_file_with_predicate
2876       (file_name, path_val, &__gnat_is_executable_file);
2877 }
2878
2879 /* Locate a regular file, give a Path value.  */
2880
2881 char *
2882 __gnat_locate_regular_file (char *file_name, char *path_val)
2883 {
2884    return __gnat_locate_file_with_predicate
2885       (file_name, path_val, &__gnat_is_regular_file);
2886 }
2887
2888 /* Locate an executable given a Path argument. This routine is only used by
2889    gnatbl and should not be used otherwise.  Use locate_exec_on_path
2890    instead.  */
2891
2892 char *
2893 __gnat_locate_exec (char *exec_name, char *path_val)
2894 {
2895   char *ptr;
2896   if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
2897     {
2898       char *full_exec_name =
2899         (char *) alloca
2900           (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
2901
2902       strcpy (full_exec_name, exec_name);
2903       strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
2904       ptr = __gnat_locate_executable_file (full_exec_name, path_val);
2905
2906       if (ptr == 0)
2907          return __gnat_locate_executable_file (exec_name, path_val);
2908       return ptr;
2909     }
2910   else
2911     return __gnat_locate_executable_file (exec_name, path_val);
2912 }
2913
2914 /* Locate an executable using the Systems default PATH.  */
2915
2916 char *
2917 __gnat_locate_exec_on_path (char *exec_name)
2918 {
2919   char *apath_val;
2920
2921 #if defined (_WIN32) && !defined (RTX)
2922   TCHAR *wpath_val = _tgetenv (_T("PATH"));
2923   TCHAR *wapath_val;
2924   /* In Win32 systems we expand the PATH as for XP environment
2925      variables are not automatically expanded. We also prepend the
2926      ".;" to the path to match normal NT path search semantics */
2927
2928   #define EXPAND_BUFFER_SIZE 32767
2929
2930   wapath_val = alloca (EXPAND_BUFFER_SIZE);
2931
2932   wapath_val [0] = '.';
2933   wapath_val [1] = ';';
2934
2935   DWORD res = ExpandEnvironmentStrings
2936     (wpath_val, &wapath_val[2], EXPAND_BUFFER_SIZE - 2);
2937
2938   if (!res) wapath_val [0] = _T('\0');
2939
2940   apath_val = alloca (EXPAND_BUFFER_SIZE);
2941
2942   WS2SC (apath_val, wapath_val, EXPAND_BUFFER_SIZE);
2943   return __gnat_locate_exec (exec_name, apath_val);
2944
2945 #else
2946
2947 #ifdef VMS
2948   char *path_val = "/VAXC$PATH";
2949 #else
2950   char *path_val = getenv ("PATH");
2951 #endif
2952   if (path_val == NULL) return NULL;
2953   apath_val = (char *) alloca (strlen (path_val) + 1);
2954   strcpy (apath_val, path_val);
2955   return __gnat_locate_exec (exec_name, apath_val);
2956 #endif
2957 }
2958
2959 #ifdef VMS
2960
2961 /* These functions are used to translate to and from VMS and Unix syntax
2962    file, directory and path specifications.  */
2963
2964 #define MAXPATH  256
2965 #define MAXNAMES 256
2966 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2967
2968 static char new_canonical_dirspec [MAXPATH];
2969 static char new_canonical_filespec [MAXPATH];
2970 static char new_canonical_pathspec [MAXNAMES*MAXPATH];
2971 static unsigned new_canonical_filelist_index;
2972 static unsigned new_canonical_filelist_in_use;
2973 static unsigned new_canonical_filelist_allocated;
2974 static char **new_canonical_filelist;
2975 static char new_host_pathspec [MAXNAMES*MAXPATH];
2976 static char new_host_dirspec [MAXPATH];
2977 static char new_host_filespec [MAXPATH];
2978
2979 /* Routine is called repeatedly by decc$from_vms via
2980    __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2981    runs out. */
2982
2983 static int
2984 wildcard_translate_unix (char *name)
2985 {
2986   char *ver;
2987   char buff [MAXPATH];
2988
2989   strncpy (buff, name, MAXPATH);
2990   buff [MAXPATH - 1] = (char) 0;
2991   ver = strrchr (buff, '.');
2992
2993   /* Chop off the version.  */
2994   if (ver)
2995     *ver = 0;
2996
2997   /* Dynamically extend the allocation by the increment.  */
2998   if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
2999     {
3000       new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
3001       new_canonical_filelist = (char **) xrealloc
3002         (new_canonical_filelist,
3003          new_canonical_filelist_allocated * sizeof (char *));
3004     }
3005
3006   new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
3007
3008   return 1;
3009 }
3010
3011 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
3012    full translation and copy the results into a list (_init), then return them
3013    one at a time (_next). If onlydirs set, only expand directory files.  */
3014
3015 int
3016 __gnat_to_canonical_file_list_init (char *filespec, int onlydirs)
3017 {
3018   int len;
3019   char buff [MAXPATH];
3020
3021   len = strlen (filespec);
3022   strncpy (buff, filespec, MAXPATH);
3023
3024   /* Only look for directories */
3025   if (onlydirs && !strstr (&buff [len-5], "*.dir"))
3026     strncat (buff, "*.dir", MAXPATH);
3027
3028   buff [MAXPATH - 1] = (char) 0;
3029
3030   decc$from_vms (buff, wildcard_translate_unix, 1);
3031
3032   /* Remove the .dir extension.  */
3033   if (onlydirs)
3034     {
3035       int i;
3036       char *ext;
3037
3038       for (i = 0; i < new_canonical_filelist_in_use; i++)
3039         {
3040           ext = strstr (new_canonical_filelist[i], ".dir");
3041           if (ext)
3042             *ext = 0;
3043         }
3044     }
3045
3046   return new_canonical_filelist_in_use;
3047 }
3048
3049 /* Return the next filespec in the list.  */
3050
3051 char *
3052 __gnat_to_canonical_file_list_next ()
3053 {
3054   return new_canonical_filelist[new_canonical_filelist_index++];
3055 }
3056
3057 /* Free storage used in the wildcard expansion.  */
3058
3059 void
3060 __gnat_to_canonical_file_list_free ()
3061 {
3062   int i;
3063
3064    for (i = 0; i < new_canonical_filelist_in_use; i++)
3065      free (new_canonical_filelist[i]);
3066
3067   free (new_canonical_filelist);
3068
3069   new_canonical_filelist_in_use = 0;
3070   new_canonical_filelist_allocated = 0;
3071   new_canonical_filelist_index = 0;
3072   new_canonical_filelist = 0;
3073 }
3074
3075 /* The functional equivalent of decc$translate_vms routine.
3076    Designed to produce the same output, but is protected against
3077    malformed paths (original version ACCVIOs in this case) and
3078    does not require VMS-specific DECC RTL */
3079
3080 #define NAM$C_MAXRSS 1024
3081
3082 char *
3083 __gnat_translate_vms (char *src)
3084 {
3085   static char retbuf [NAM$C_MAXRSS+1];
3086   char *srcendpos, *pos1, *pos2, *retpos;
3087   int disp, path_present = 0;
3088
3089   if (!src) return NULL;
3090
3091   srcendpos = strchr (src, '\0');
3092   retpos = retbuf;
3093
3094   /* Look for the node and/or device in front of the path */
3095   pos1 = src;
3096   pos2 = strchr (pos1, ':');
3097
3098   if (pos2 && (pos2 < srcendpos) && (*(pos2 + 1) == ':')) {
3099     /* There is a node name. "node_name::" becomes "node_name!" */
3100     disp = pos2 - pos1;
3101     strncpy (retbuf, pos1, disp);
3102     retpos [disp] = '!';
3103     retpos = retpos + disp + 1;
3104     pos1 = pos2 + 2;
3105     pos2 = strchr (pos1, ':');
3106   }
3107
3108   if (pos2) {
3109     /* There is a device name. "dev_name:" becomes "/dev_name/" */
3110     *(retpos++) = '/';
3111     disp = pos2 - pos1;
3112     strncpy (retpos, pos1, disp);
3113     retpos = retpos + disp;
3114     pos1 = pos2 + 1;
3115     *(retpos++) = '/';
3116   }
3117   else
3118     /* No explicit device; we must look ahead and prepend /sys$disk/ if
3119        the path is absolute */
3120     if ((*pos1 == '[' || *pos1 == '<') && (pos1 < srcendpos)
3121         && !strchr (".-]>", *(pos1 + 1))) {
3122       strncpy (retpos, "/sys$disk/", 10);
3123       retpos += 10;
3124     }
3125
3126   /* Process the path part */
3127   while (*pos1 == '[' || *pos1 == '<') {
3128     path_present++;
3129     pos1++;
3130     if (*pos1 == ']' || *pos1 == '>') {
3131       /* Special case, [] translates to '.' */
3132       *(retpos++) = '.';
3133       pos1++;
3134     }
3135     else {
3136       /* '[000000' means root dir. It can be present in the middle of
3137          the path due to expansion of logical devices, in which case
3138          we skip it */
3139       if (!strncmp (pos1, "000000", 6) && path_present > 1 &&
3140          (*(pos1 + 6) == ']' || *(pos1 + 6) == '>' || *(pos1 + 6) == '.')) {
3141           pos1 += 6;
3142           if (*pos1 == '.') pos1++;
3143         }
3144       else if (*pos1 == '.') {
3145         /* Relative path */
3146         *(retpos++) = '.';
3147       }
3148
3149       /* There is a qualified path */
3150       while (*pos1 && *pos1 != ']' && *pos1 != '>') {
3151         switch (*pos1) {
3152           case '.':
3153             /* '.' is used to separate directories. Replace it with '/' but
3154                only if there isn't already '/' just before */
3155             if (*(retpos - 1) != '/') *(retpos++) = '/';
3156             pos1++;
3157             if (pos1 + 1 < srcendpos && *pos1 == '.' && *(pos1 + 1) == '.') {
3158               /* ellipsis refers to entire subtree; replace with '**' */
3159               *(retpos++) = '*'; *(retpos++) = '*'; *(retpos++) = '/';
3160               pos1 += 2;
3161             }
3162             break;
3163           case '-' :
3164             /* When after '.' '[' '<' is equivalent to Unix ".." but there
3165             may be several in a row */
3166             if (*(pos1 - 1) == '.' || *(pos1 - 1) == '[' ||
3167                 *(pos1 - 1) == '<') {
3168               while (*pos1 == '-') {
3169                 pos1++;
3170                 *(retpos++) = '.'; *(retpos++) = '.'; *(retpos++) = '/';
3171               }
3172               retpos--;
3173               break;
3174             }
3175             /* otherwise fall through to default */
3176           default:
3177             *(retpos++) = *(pos1++);
3178         }
3179       }
3180       pos1++;
3181     }
3182   }
3183
3184   if (pos1 < srcendpos) {
3185     /* Now add the actual file name, until the version suffix if any */
3186     if (path_present) *(retpos++) = '/';
3187     pos2 = strchr (pos1, ';');
3188     disp = pos2? (pos2 - pos1) : (srcendpos - pos1);
3189     strncpy (retpos, pos1, disp);
3190     retpos += disp;
3191     if (pos2 && pos2 < srcendpos) {
3192       /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
3193       *retpos++ = '.';
3194       disp = srcendpos - pos2 - 1;
3195       strncpy (retpos, pos2 + 1, disp);
3196       retpos += disp;
3197     }
3198   }
3199
3200   *retpos = '\0';
3201
3202   return retbuf;
3203
3204 }
3205
3206 /* Translate a VMS syntax directory specification in to Unix syntax.  If
3207    PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
3208    found, return input string. Also translate a dirname that contains no
3209    slashes, in case it's a logical name.  */
3210
3211 char *
3212 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag)
3213 {
3214   int len;
3215
3216   strcpy (new_canonical_dirspec, "");
3217   if (strlen (dirspec))
3218     {
3219       char *dirspec1;
3220
3221       if (strchr (dirspec, ']') || strchr (dirspec, ':'))
3222         {
3223           strncpy (new_canonical_dirspec,
3224                    __gnat_translate_vms (dirspec),
3225                    MAXPATH);
3226         }
3227       else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
3228         {
3229           strncpy (new_canonical_dirspec,
3230                   __gnat_translate_vms (dirspec1),
3231                   MAXPATH);
3232         }
3233       else
3234         {
3235           strncpy (new_canonical_dirspec, dirspec, MAXPATH);
3236         }
3237     }
3238
3239   len = strlen (new_canonical_dirspec);
3240   if (prefixflag && new_canonical_dirspec [len-1] != '/')
3241     strncat (new_canonical_dirspec, "/", MAXPATH);
3242
3243   new_canonical_dirspec [MAXPATH - 1] = (char) 0;
3244
3245   return new_canonical_dirspec;
3246
3247 }
3248
3249 /* Translate a VMS syntax file specification into Unix syntax.
3250    If no indicators of VMS syntax found, check if it's an uppercase
3251    alphanumeric_ name and if so try it out as an environment
3252    variable (logical name). If all else fails return the
3253    input string.  */
3254
3255 char *
3256 __gnat_to_canonical_file_spec (char *filespec)
3257 {
3258   char *filespec1;
3259
3260   strncpy (new_canonical_filespec, "", MAXPATH);
3261
3262   if (strchr (filespec, ']') || strchr (filespec, ':'))
3263     {
3264       char *tspec = (char *) __gnat_translate_vms (filespec);
3265
3266       if (tspec != (char *) -1)
3267         strncpy (new_canonical_filespec, tspec, MAXPATH);
3268     }
3269   else if ((strlen (filespec) == strspn (filespec,
3270             "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
3271         && (filespec1 = getenv (filespec)))
3272     {
3273       char *tspec = (char *) __gnat_translate_vms (filespec1);
3274
3275       if (tspec != (char *) -1)
3276         strncpy (new_canonical_filespec, tspec, MAXPATH);
3277     }
3278   else
3279     {
3280       strncpy (new_canonical_filespec, filespec, MAXPATH);
3281     }
3282
3283   new_canonical_filespec [MAXPATH - 1] = (char) 0;
3284
3285   return new_canonical_filespec;
3286 }
3287
3288 /* Translate a VMS syntax path specification into Unix syntax.
3289    If no indicators of VMS syntax found, return input string.  */
3290
3291 char *
3292 __gnat_to_canonical_path_spec (char *pathspec)
3293 {
3294   char *curr, *next, buff [MAXPATH];
3295
3296   if (pathspec == 0)
3297     return pathspec;
3298
3299   /* If there are /'s, assume it's a Unix path spec and return.  */
3300   if (strchr (pathspec, '/'))
3301     return pathspec;
3302
3303   new_canonical_pathspec[0] = 0;
3304   curr = pathspec;
3305
3306   for (;;)
3307     {
3308       next = strchr (curr, ',');
3309       if (next == 0)
3310         next = strchr (curr, 0);
3311
3312       strncpy (buff, curr, next - curr);
3313       buff[next - curr] = 0;
3314
3315       /* Check for wildcards and expand if present.  */
3316       if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
3317         {
3318           int i, dirs;
3319
3320           dirs = __gnat_to_canonical_file_list_init (buff, 1);
3321           for (i = 0; i < dirs; i++)
3322             {
3323               char *next_dir;
3324
3325               next_dir = __gnat_to_canonical_file_list_next ();
3326               strncat (new_canonical_pathspec, next_dir, MAXPATH);
3327
3328               /* Don't append the separator after the last expansion.  */
3329               if (i+1 < dirs)
3330                 strncat (new_canonical_pathspec, ":", MAXPATH);
3331             }
3332
3333           __gnat_to_canonical_file_list_free ();
3334         }
3335       else
3336         strncat (new_canonical_pathspec,
3337                 __gnat_to_canonical_dir_spec (buff, 0), MAXPATH);
3338
3339       if (*next == 0)
3340         break;
3341
3342       strncat (new_canonical_pathspec, ":", MAXPATH);
3343       curr = next + 1;
3344     }
3345
3346   new_canonical_pathspec [MAXPATH - 1] = (char) 0;
3347
3348   return new_canonical_pathspec;
3349 }
3350
3351 static char filename_buff [MAXPATH];
3352
3353 static int
3354 translate_unix (char *name, int type)
3355 {
3356   strncpy (filename_buff, name, MAXPATH);
3357   filename_buff [MAXPATH - 1] = (char) 0;
3358   return 0;
3359 }
3360
3361 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
3362    directories.  */
3363
3364 static char *
3365 to_host_path_spec (char *pathspec)
3366 {
3367   char *curr, *next, buff [MAXPATH];
3368
3369   if (pathspec == 0)
3370     return pathspec;
3371
3372   /* Can't very well test for colons, since that's the Unix separator!  */
3373   if (strchr (pathspec, ']') || strchr (pathspec, ','))
3374     return pathspec;
3375
3376   new_host_pathspec[0] = 0;
3377   curr = pathspec;
3378
3379   for (;;)
3380     {
3381       next = strchr (curr, ':');
3382       if (next == 0)
3383         next = strchr (curr, 0);
3384
3385       strncpy (buff, curr, next - curr);
3386       buff[next - curr] = 0;
3387
3388       strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH);
3389       if (*next == 0)
3390         break;
3391       strncat (new_host_pathspec, ",", MAXPATH);
3392       curr = next + 1;
3393     }
3394
3395   new_host_pathspec [MAXPATH - 1] = (char) 0;
3396
3397   return new_host_pathspec;
3398 }
3399
3400 /* Translate a Unix syntax directory specification into VMS syntax.  The
3401    PREFIXFLAG has no effect, but is kept for symmetry with
3402    to_canonical_dir_spec.  If indicators of VMS syntax found, return input
3403    string. */
3404
3405 char *
3406 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3407 {
3408   int len = strlen (dirspec);
3409
3410   strncpy (new_host_dirspec, dirspec, MAXPATH);
3411   new_host_dirspec [MAXPATH - 1] = (char) 0;
3412
3413   if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
3414     return new_host_dirspec;
3415
3416   while (len > 1 && new_host_dirspec[len - 1] == '/')
3417     {
3418       new_host_dirspec[len - 1] = 0;
3419       len--;
3420     }
3421
3422   decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
3423   strncpy (new_host_dirspec, filename_buff, MAXPATH);
3424   new_host_dirspec [MAXPATH - 1] = (char) 0;
3425
3426   return new_host_dirspec;
3427 }
3428
3429 /* Translate a Unix syntax file specification into VMS syntax.
3430    If indicators of VMS syntax found, return input string.  */
3431
3432 char *
3433 __gnat_to_host_file_spec (char *filespec)
3434 {
3435   strncpy (new_host_filespec, "", MAXPATH);
3436   if (strchr (filespec, ']') || strchr (filespec, ':'))
3437     {
3438       strncpy (new_host_filespec, filespec, MAXPATH);
3439     }
3440   else
3441     {
3442       decc$to_vms (filespec, translate_unix, 1, 1);
3443       strncpy (new_host_filespec, filename_buff, MAXPATH);
3444     }
3445
3446   new_host_filespec [MAXPATH - 1] = (char) 0;
3447
3448   return new_host_filespec;
3449 }
3450
3451 void
3452 __gnat_adjust_os_resource_limits ()
3453 {
3454   SYS$ADJWSL (131072, 0);
3455 }
3456
3457 #else /* VMS */
3458
3459 /* Dummy functions for Osint import for non-VMS systems.  */
3460
3461 int
3462 __gnat_to_canonical_file_list_init
3463   (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED)
3464 {
3465   return 0;
3466 }
3467
3468 char *
3469 __gnat_to_canonical_file_list_next (void)
3470 {
3471   static char empty[] = "";
3472   return empty;
3473 }
3474
3475 void
3476 __gnat_to_canonical_file_list_free (void)
3477 {
3478 }
3479
3480 char *
3481 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3482 {
3483   return dirspec;
3484 }
3485
3486 char *
3487 __gnat_to_canonical_file_spec (char *filespec)
3488 {
3489   return filespec;
3490 }
3491
3492 char *
3493 __gnat_to_canonical_path_spec (char *pathspec)
3494 {
3495   return pathspec;
3496 }
3497
3498 char *
3499 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3500 {
3501   return dirspec;
3502 }
3503
3504 char *
3505 __gnat_to_host_file_spec (char *filespec)
3506 {
3507   return filespec;
3508 }
3509
3510 void
3511 __gnat_adjust_os_resource_limits (void)
3512 {
3513 }
3514
3515 #endif
3516
3517 #if defined (__mips_vxworks)
3518 int
3519 _flush_cache()
3520 {
3521    CACHE_USER_FLUSH (0, ENTIRE_CACHE);
3522 }
3523 #endif
3524
3525 #if defined (IS_CROSS)  \
3526   || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3527       && defined (__SVR4)) \
3528       && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3529       && ! (defined (linux) && defined (__ia64__)) \
3530       && ! (defined (linux) && defined (powerpc)) \
3531       && ! defined (__FreeBSD__) \
3532       && ! defined (__Lynx__) \
3533       && ! defined (__hpux__) \
3534       && ! defined (__APPLE__) \
3535       && ! defined (_AIX) \
3536       && ! (defined (__alpha__)  && defined (__osf__)) \
3537       && ! defined (VMS) \
3538       && ! defined (__MINGW32__) \
3539       && ! (defined (__mips) && defined (__sgi)))
3540
3541 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3542    just above for a list of native platforms that provide a non-dummy
3543    version of this procedure in libaddr2line.a.  */
3544
3545 void
3546 convert_addresses (const char *file_name ATTRIBUTE_UNUSED,
3547                    void *addrs ATTRIBUTE_UNUSED,
3548                    int n_addr ATTRIBUTE_UNUSED,
3549                    void *buf ATTRIBUTE_UNUSED,
3550                    int *len ATTRIBUTE_UNUSED)
3551 {
3552   *len = 0;
3553 }
3554 #endif
3555
3556 #if defined (_WIN32)
3557 int __gnat_argument_needs_quote = 1;
3558 #else
3559 int __gnat_argument_needs_quote = 0;
3560 #endif
3561
3562 /* This option is used to enable/disable object files handling from the
3563    binder file by the GNAT Project module. For example, this is disabled on
3564    Windows (prior to GCC 3.4) as it is already done by the mdll module.
3565    Stating with GCC 3.4 the shared libraries are not based on mdll
3566    anymore as it uses the GCC's -shared option  */
3567 #if defined (_WIN32) \
3568     && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3569 int __gnat_prj_add_obj_files = 0;
3570 #else
3571 int __gnat_prj_add_obj_files = 1;
3572 #endif
3573
3574 /* char used as prefix/suffix for environment variables */
3575 #if defined (_WIN32)
3576 char __gnat_environment_char = '%';
3577 #else
3578 char __gnat_environment_char = '$';
3579 #endif
3580
3581 /* This functions copy the file attributes from a source file to a
3582    destination file.
3583
3584    mode = 0  : In this mode copy only the file time stamps (last access and
3585                last modification time stamps).
3586
3587    mode = 1  : In this mode, time stamps and read/write/execute attributes are
3588                copied.
3589
3590    Returns 0 if operation was successful and -1 in case of error. */
3591
3592 int
3593 __gnat_copy_attribs (char *from, char *to, int mode)
3594 {
3595 #if defined (VMS) || (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \
3596   defined (__nucleus__)
3597   return -1;
3598
3599 #elif defined (_WIN32) && !defined (RTX)
3600   TCHAR wfrom [GNAT_MAX_PATH_LEN + 2];
3601   TCHAR wto [GNAT_MAX_PATH_LEN + 2];
3602   BOOL res;
3603   FILETIME fct, flat, flwt;
3604   HANDLE hfrom, hto;
3605
3606   S2WSC (wfrom, from, GNAT_MAX_PATH_LEN + 2);
3607   S2WSC (wto, to, GNAT_MAX_PATH_LEN + 2);
3608
3609   /* retrieve from times */
3610
3611   hfrom = CreateFile
3612     (wfrom, GENERIC_READ, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
3613
3614   if (hfrom == INVALID_HANDLE_VALUE)
3615     return -1;
3616
3617   res = GetFileTime (hfrom, &fct, &flat, &flwt);
3618
3619   CloseHandle (hfrom);
3620
3621   if (res == 0)
3622     return -1;
3623
3624   /* retrieve from times */
3625
3626   hto = CreateFile
3627     (wto, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
3628
3629   if (hto == INVALID_HANDLE_VALUE)
3630     return -1;
3631
3632   res = SetFileTime (hto, NULL, &flat, &flwt);
3633
3634   CloseHandle (hto);
3635
3636   if (res == 0)
3637     return -1;
3638
3639   /* Set file attributes in full mode. */
3640
3641   if (mode == 1)
3642     {
3643       DWORD attribs = GetFileAttributes (wfrom);
3644
3645       if (attribs == INVALID_FILE_ATTRIBUTES)
3646         return -1;
3647
3648       res = SetFileAttributes (wto, attribs);
3649       if (res == 0)
3650         return -1;
3651     }
3652
3653   return 0;
3654
3655 #else
3656   GNAT_STRUCT_STAT fbuf;
3657   struct utimbuf tbuf;
3658
3659   if (GNAT_STAT (from, &fbuf) == -1)
3660     {
3661       return -1;
3662     }
3663
3664   tbuf.actime = fbuf.st_atime;
3665   tbuf.modtime = fbuf.st_mtime;
3666
3667   if (utime (to, &tbuf) == -1)
3668     {
3669       return -1;
3670     }
3671
3672   if (mode == 1)
3673     {
3674       if (chmod (to, fbuf.st_mode) == -1)
3675         {
3676           return -1;
3677         }
3678     }
3679
3680   return 0;
3681 #endif
3682 }
3683
3684 int
3685 __gnat_lseek (int fd, long offset, int whence)
3686 {
3687   return (int) lseek (fd, offset, whence);
3688 }
3689
3690 /* This function returns the major version number of GCC being used.  */
3691 int
3692 get_gcc_version (void)
3693 {
3694 #ifdef IN_RTS
3695   return __GNUC__;
3696 #else
3697   return (int) (version_string[0] - '0');
3698 #endif
3699 }
3700
3701 int
3702 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED,
3703                           int close_on_exec_p ATTRIBUTE_UNUSED)
3704 {
3705 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3706   int flags = fcntl (fd, F_GETFD, 0);
3707   if (flags < 0)
3708     return flags;
3709   if (close_on_exec_p)
3710     flags |= FD_CLOEXEC;
3711   else
3712     flags &= ~FD_CLOEXEC;
3713   return fcntl (fd, F_SETFD, flags | FD_CLOEXEC);
3714 #elif defined(_WIN32)
3715   HANDLE h = (HANDLE) _get_osfhandle (fd);
3716   if (h == (HANDLE) -1)
3717     return -1;
3718   if (close_on_exec_p)
3719     return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT, 0);
3720   return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT,
3721     HANDLE_FLAG_INHERIT);
3722 #else
3723   /* TODO: Unimplemented. */
3724   return -1;
3725 #endif
3726 }
3727
3728 /* Indicates if platforms supports automatic initialization through the
3729    constructor mechanism */
3730 int
3731 __gnat_binder_supports_auto_init (void)
3732 {
3733 #ifdef VMS
3734    return 0;
3735 #else
3736    return 1;
3737 #endif
3738 }
3739
3740 /* Indicates that Stand-Alone Libraries are automatically initialized through
3741    the constructor mechanism */
3742 int
3743 __gnat_sals_init_using_constructors (void)
3744 {
3745 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3746    return 0;
3747 #else
3748    return 1;
3749 #endif
3750 }
3751
3752 #ifdef RTX
3753
3754 /* In RTX mode, the procedure to get the time (as file time) is different
3755    in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3756    we introduce an intermediate procedure to link against the corresponding
3757    one in each situation. */
3758
3759 extern void GetTimeAsFileTime(LPFILETIME pTime);
3760
3761 void GetTimeAsFileTime(LPFILETIME pTime)
3762 {
3763 #ifdef RTSS
3764   RtGetRtssTimeAsFileTime (pTime); /* RTSS interface */
3765 #else
3766   GetSystemTimeAsFileTime (pTime); /* w32 interface */
3767 #endif
3768 }
3769
3770 #ifdef RTSS
3771 /* Add symbol that is required to link. It would otherwise be taken from
3772    libgcc.a and it would try to use the gcc constructors that are not
3773    supported by Microsoft linker. */
3774
3775 extern void __main (void);
3776
3777 void __main (void) {}
3778 #endif
3779 #endif
3780
3781 #if defined (linux)
3782 /* There is no function in the glibc to retrieve the LWP of the current
3783    thread. We need to do a system call in order to retrieve this
3784    information. */
3785 #include <sys/syscall.h>
3786 void *__gnat_lwp_self (void)
3787 {
3788    return (void *) syscall (__NR_gettid);
3789 }
3790
3791 #include <sched.h>
3792
3793 /* glibc versions earlier than 2.7 do not define the routines to handle
3794    dynamically allocated CPU sets. For these targets, we use the static
3795    versions. */
3796
3797 #ifdef CPU_ALLOC
3798
3799 /* Dynamic cpu sets */
3800
3801 cpu_set_t *__gnat_cpu_alloc (size_t count)
3802 {
3803   return CPU_ALLOC (count);
3804 }
3805
3806 size_t __gnat_cpu_alloc_size (size_t count)
3807 {
3808   return CPU_ALLOC_SIZE (count);
3809 }
3810
3811 void __gnat_cpu_free (cpu_set_t *set)
3812 {
3813   CPU_FREE (set);
3814 }
3815
3816 void __gnat_cpu_zero (size_t count, cpu_set_t *set)
3817 {
3818   CPU_ZERO_S (count, set);
3819 }
3820
3821 void __gnat_cpu_set (int cpu, size_t count, cpu_set_t *set)
3822 {
3823   /* Ada handles CPU numbers starting from 1, while C identifies the first
3824      CPU by a 0, so we need to adjust. */
3825   CPU_SET_S (cpu - 1, count, set);
3826 }
3827
3828 #else
3829
3830 /* Static cpu sets */
3831
3832 cpu_set_t *__gnat_cpu_alloc (size_t count ATTRIBUTE_UNUSED)
3833 {
3834   return (cpu_set_t *) xmalloc (sizeof (cpu_set_t));
3835 }
3836
3837 size_t __gnat_cpu_alloc_size (size_t count ATTRIBUTE_UNUSED)
3838 {
3839   return sizeof (cpu_set_t);
3840 }
3841
3842 void __gnat_cpu_free (cpu_set_t *set)
3843 {
3844   free (set);
3845 }
3846
3847 void __gnat_cpu_zero (size_t count ATTRIBUTE_UNUSED, cpu_set_t *set)
3848 {
3849   CPU_ZERO (set);
3850 }
3851
3852 void __gnat_cpu_set (int cpu, size_t count ATTRIBUTE_UNUSED, cpu_set_t *set)
3853 {
3854   /* Ada handles CPU numbers starting from 1, while C identifies the first
3855      CPU by a 0, so we need to adjust. */
3856   CPU_SET (cpu - 1, set);
3857 }
3858 #endif
3859 #endif
3860
3861 #ifdef __cplusplus
3862 }
3863 #endif