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