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_open_append (char *path, int fmode)
 927 {
 928   int fd;
 929   int o_fmode = O_BINARY;
 930
 931   if (fmode)
 932     o_fmode = O_TEXT;
 933
 934 #if defined (VMS)
 935   fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM,
 936              "mbc=16", "deq=64", "fop=tef");
 937 #elif defined (__MINGW32__)
 938   {
 939     TCHAR wpath[GNAT_MAX_PATH_LEN];
 940
 941     S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
 942     fd = _topen (wpath, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
 943   }
 944 #else
 945   fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
 946 #endif
 947
 948   return fd < 0 ? -1 : fd;
 949 }
 950
 951 /*  Open a new file.  Return error (-1) if the file already exists.  */
 952
 953 int
 954 __gnat_open_new (char *path, int fmode)
 955 {
 956   int fd;
 957   int o_fmode = O_BINARY;
 958
 959   if (fmode)
 960     o_fmode = O_TEXT;
 961
 962 #if defined (VMS)
 963   fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
 964              "mbc=16", "deq=64", "fop=tef");
 965 #elif defined (__MINGW32__)
 966   {
 967     TCHAR wpath[GNAT_MAX_PATH_LEN];
 968
 969     S2WSC (wpath, path, GNAT_MAX_PATH_LEN);
 970     fd = _topen (wpath, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
 971   }
 972 #else
 973   fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
 974 #endif
 975
 976   return fd < 0 ? -1 : fd;
 977 }
 978
 979 /* Open a new temp file.  Return error (-1) if the file already exists.
 980    Special options for VMS allow the file to be shared between parent and child
 981    processes, however they really slow down output.  Used in gnatchop.  */
 982
 983 int
 984 __gnat_open_new_temp (char *path, int fmode)
 985 {
 986   int fd;
 987   int o_fmode = O_BINARY;
 988
 989   strcpy (path, "GNAT-XXXXXX");
 990
 991 #if (defined (__FreeBSD__) || defined (__NetBSD__) || defined (__OpenBSD__) \
 992   || defined (linux) || defined(__GLIBC__)) && !defined (__vxworks)
 993   return mkstemp (path);
 994 #elif defined (__Lynx__)
 995   mktemp (path);
 996 #elif defined (__nucleus__)
 997   return -1;
 998 #else
 999   if (mktemp (path) == NULL)
1000     return -1;
1001 #endif
1002
1003   if (fmode)
1004     o_fmode = O_TEXT;
1005
1006 #if defined (VMS)
1007   fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
1008              "rfm=stmlf", "ctx=rec", "rat=none", "shr=del,get,put,upd",
1009              "mbc=16", "deq=64", "fop=tef");
1010 #else
1011   fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
1012 #endif
1013
1014   return fd < 0 ? -1 : fd;
1015 }
1016
1017 /* Return the number of bytes in the specified file.  */
1018
1019 long
1020 __gnat_file_length (int fd)
1021 {
1022   int ret;
1023   GNAT_STRUCT_STAT statbuf;
1024
1025   ret = GNAT_FSTAT (fd, &statbuf);
1026   if (ret || !S_ISREG (statbuf.st_mode))
1027     return 0;
1028
1029   /* st_size may be 32 bits, or 64 bits which is converted to long. We
1030      don't return a useful value for files larger than 2 gigabytes in
1031      either case. */
1032
1033   return (statbuf.st_size);
1034 }
1035
1036 /* Return the number of bytes in the specified named file.  */
1037
1038 long
1039 __gnat_named_file_length (char *name)
1040 {
1041   int ret;
1042   GNAT_STRUCT_STAT statbuf;
1043
1044   ret = __gnat_stat (name, &statbuf);
1045   if (ret || !S_ISREG (statbuf.st_mode))
1046     return 0;
1047
1048   /* st_size may be 32 bits, or 64 bits which is converted to long. We
1049      don't return a useful value for files larger than 2 gigabytes in
1050      either case. */
1051
1052   return (statbuf.st_size);
1053 }
1054
1055 /* Create a temporary filename and put it in string pointed to by
1056    TMP_FILENAME.  */
1057
1058 void
1059 __gnat_tmp_name (char *tmp_filename)
1060 {
1061 #ifdef RTX
1062   /* Variable used to create a series of unique names */
1063   static int counter = 0;
1064
1065   /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */
1066   strcpy (tmp_filename, "c:\\WINDOWS\\Temp\\gnat-");
1067   sprintf (&tmp_filename[strlen (tmp_filename)], "%d\0", counter++);
1068
1069 #elif defined (__MINGW32__)
1070   {
1071     char *pname;
1072
1073     /* tempnam tries to create a temporary file in directory pointed to by
1074        TMP environment variable, in c:\temp if TMP is not set, and in
1075        directory specified by P_tmpdir in stdio.h if c:\temp does not
1076        exist. The filename will be created with the prefix "gnat-".  */
1077
1078     pname = (char *) tempnam ("c:\\temp", "gnat-");
1079
1080     /* if pname is NULL, the file was not created properly, the disk is full
1081        or there is no more free temporary files */
1082
1083     if (pname == NULL)
1084       *tmp_filename = '\0';
1085
1086     /* If pname start with a back slash and not path information it means that
1087        the filename is valid for the current working directory.  */
1088
1089     else if (pname[0] == '\\')
1090       {
1091         strcpy (tmp_filename, ".\\");
1092         strcat (tmp_filename, pname+1);
1093       }
1094     else
1095       strcpy (tmp_filename, pname);
1096
1097     free (pname);
1098   }
1099
1100 #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \
1101   || defined (__OpenBSD__) || defined(__GLIBC__)
1102 #define MAX_SAFE_PATH 1000
1103   char *tmpdir = getenv ("TMPDIR");
1104
1105   /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
1106      a buffer overflow.  */
1107   if (tmpdir == NULL || strlen (tmpdir) > MAX_SAFE_PATH)
1108     strcpy (tmp_filename, "/tmp/gnat-XXXXXX");
1109   else
1110     sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
1111
1112   close (mkstemp(tmp_filename));
1113 #else
1114   tmpnam (tmp_filename);
1115 #endif
1116 }
1117
1118 /*  Open directory and returns a DIR pointer.  */
1119
1120 DIR* __gnat_opendir (char *name)
1121 {
1122 #if defined (RTX)
1123   /* Not supported in RTX */
1124
1125   return NULL;
1126
1127 #elif defined (__MINGW32__)
1128   TCHAR wname[GNAT_MAX_PATH_LEN];
1129
1130   S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1131   return (DIR*)_topendir (wname);
1132
1133 #else
1134   return opendir (name);
1135 #endif
1136 }
1137
1138 /* Read the next entry in a directory.  The returned string points somewhere
1139    in the buffer.  */
1140
1141 char *
1142 __gnat_readdir (DIR *dirp, char *buffer, int *len)
1143 {
1144 #if defined (RTX)
1145   /* Not supported in RTX */
1146
1147   return NULL;
1148
1149 #elif defined (__MINGW32__)
1150   struct _tdirent *dirent = _treaddir ((_TDIR*)dirp);
1151
1152   if (dirent != NULL)
1153     {
1154       WS2SC (buffer, dirent->d_name, GNAT_MAX_PATH_LEN);
1155       *len = strlen (buffer);
1156
1157       return buffer;
1158     }
1159   else
1160     return NULL;
1161
1162 #elif defined (HAVE_READDIR_R)
1163   /* If possible, try to use the thread-safe version.  */
1164   if (readdir_r (dirp, buffer) != NULL)
1165     {
1166       *len = strlen (((struct dirent*) buffer)->d_name);
1167       return ((struct dirent*) buffer)->d_name;
1168     }
1169   else
1170     return NULL;
1171
1172 #else
1173   struct dirent *dirent = (struct dirent *) readdir (dirp);
1174
1175   if (dirent != NULL)
1176     {
1177       strcpy (buffer, dirent->d_name);
1178       *len = strlen (buffer);
1179       return buffer;
1180     }
1181   else
1182     return NULL;
1183
1184 #endif
1185 }
1186
1187 /* Close a directory entry.  */
1188
1189 int __gnat_closedir (DIR *dirp)
1190 {
1191 #if defined (RTX)
1192   /* Not supported in RTX */
1193
1194   return 0;
1195
1196 #elif defined (__MINGW32__)
1197   return _tclosedir ((_TDIR*)dirp);
1198
1199 #else
1200   return closedir (dirp);
1201 #endif
1202 }
1203
1204 /* Returns 1 if readdir is thread safe, 0 otherwise.  */
1205
1206 int
1207 __gnat_readdir_is_thread_safe (void)
1208 {
1209 #ifdef HAVE_READDIR_R
1210   return 1;
1211 #else
1212   return 0;
1213 #endif
1214 }
1215
1216 #if defined (_WIN32) && !defined (RTX)
1217 /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>.  */
1218 static const unsigned long long w32_epoch_offset = 11644473600ULL;
1219
1220 /* Returns the file modification timestamp using Win32 routines which are
1221    immune against daylight saving time change. It is in fact not possible to
1222    use fstat for this purpose as the DST modify the st_mtime field of the
1223    stat structure.  */
1224
1225 static time_t
1226 win32_filetime (HANDLE h)
1227 {
1228   union
1229   {
1230     FILETIME ft_time;
1231     unsigned long long ull_time;
1232   } t_write;
1233
1234   /* GetFileTime returns FILETIME data which are the number of 100 nanosecs
1235      since <Jan 1st 1601>. This function must return the number of seconds
1236      since <Jan 1st 1970>.  */
1237
1238   if (GetFileTime (h, NULL, NULL, &t_write.ft_time))
1239     return (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset);
1240   return (time_t) 0;
1241 }
1242 #endif
1243
1244 /* Return a GNAT time stamp given a file name.  */
1245
1246 OS_Time
1247 __gnat_file_time_name (char *name)
1248 {
1249
1250 #if defined (__EMX__) || defined (MSDOS)
1251   int fd = open (name, O_RDONLY | O_BINARY);
1252   time_t ret = __gnat_file_time_fd (fd);
1253   close (fd);
1254   return (OS_Time)ret;
1255
1256 #elif defined (_WIN32) && !defined (RTX)
1257   time_t ret = -1;
1258   TCHAR wname[GNAT_MAX_PATH_LEN];
1259
1260   S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1261
1262   HANDLE h = CreateFile
1263     (wname, GENERIC_READ, FILE_SHARE_READ, 0,
1264      OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
1265
1266   if (h != INVALID_HANDLE_VALUE)
1267     {
1268       ret = win32_filetime (h);
1269       CloseHandle (h);
1270     }
1271   return (OS_Time) ret;
1272 #else
1273   GNAT_STRUCT_STAT statbuf;
1274   if (__gnat_stat (name, &statbuf) != 0) {
1275      return (OS_Time)-1;
1276   } else {
1277 #ifdef VMS
1278      /* VMS has file versioning.  */
1279      return (OS_Time)statbuf.st_ctime;
1280 #else
1281      return (OS_Time)statbuf.st_mtime;
1282 #endif
1283   }
1284 #endif
1285 }
1286
1287 /* Return a GNAT time stamp given a file descriptor.  */
1288
1289 OS_Time
1290 __gnat_file_time_fd (int fd)
1291 {
1292   /* The following workaround code is due to the fact that under EMX and
1293      DJGPP fstat attempts to convert time values to GMT rather than keep the
1294      actual OS timestamp of the file. By using the OS2/DOS functions directly
1295      the GNAT timestamp are independent of this behavior, which is desired to
1296      facilitate the distribution of GNAT compiled libraries.  */
1297
1298 #if defined (__EMX__) || defined (MSDOS)
1299 #ifdef __EMX__
1300
1301   FILESTATUS fs;
1302   int ret = DosQueryFileInfo (fd, 1, (unsigned char *) &fs,
1303                                 sizeof (FILESTATUS));
1304
1305   unsigned file_year  = fs.fdateLastWrite.year;
1306   unsigned file_month = fs.fdateLastWrite.month;
1307   unsigned file_day   = fs.fdateLastWrite.day;
1308   unsigned file_hour  = fs.ftimeLastWrite.hours;
1309   unsigned file_min   = fs.ftimeLastWrite.minutes;
1310   unsigned file_tsec  = fs.ftimeLastWrite.twosecs;
1311
1312 #else
1313   struct ftime fs;
1314   int ret = getftime (fd, &fs);
1315
1316   unsigned file_year  = fs.ft_year;
1317   unsigned file_month = fs.ft_month;
1318   unsigned file_day   = fs.ft_day;
1319   unsigned file_hour  = fs.ft_hour;
1320   unsigned file_min   = fs.ft_min;
1321   unsigned file_tsec  = fs.ft_tsec;
1322 #endif
1323
1324   /* Calculate the seconds since epoch from the time components. First count
1325      the whole days passed.  The value for years returned by the DOS and OS2
1326      functions count years from 1980, so to compensate for the UNIX epoch which
1327      begins in 1970 start with 10 years worth of days and add days for each
1328      four year period since then.  */
1329
1330   time_t tot_secs;
1331   int cum_days[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
1332   int days_passed = 3652 + (file_year / 4) * 1461;
1333   int years_since_leap = file_year % 4;
1334
1335   if (years_since_leap == 1)
1336     days_passed += 366;
1337   else if (years_since_leap == 2)
1338     days_passed += 731;
1339   else if (years_since_leap == 3)
1340     days_passed += 1096;
1341
1342   if (file_year > 20)
1343     days_passed -= 1;
1344
1345   days_passed += cum_days[file_month - 1];
1346   if (years_since_leap == 0 && file_year != 20 && file_month > 2)
1347     days_passed++;
1348
1349   days_passed += file_day - 1;
1350
1351   /* OK - have whole days.  Multiply -- then add in other parts.  */
1352
1353   tot_secs  = days_passed * 86400;
1354   tot_secs += file_hour * 3600;
1355   tot_secs += file_min * 60;
1356   tot_secs += file_tsec * 2;
1357   return (OS_Time) tot_secs;
1358
1359 #elif defined (_WIN32) && !defined (RTX)
1360   HANDLE h = (HANDLE) _get_osfhandle (fd);
1361   time_t ret = win32_filetime (h);
1362   return (OS_Time) ret;
1363
1364 #else
1365   GNAT_STRUCT_STAT statbuf;
1366
1367   if (GNAT_FSTAT (fd, &statbuf) != 0) {
1368      return (OS_Time) -1;
1369   } else {
1370 #ifdef VMS
1371      /* VMS has file versioning.  */
1372      return (OS_Time) statbuf.st_ctime;
1373 #else
1374      return (OS_Time) statbuf.st_mtime;
1375 #endif
1376   }
1377 #endif
1378 }
1379
1380 /* Set the file time stamp.  */
1381
1382 void
1383 __gnat_set_file_time_name (char *name, time_t time_stamp)
1384 {
1385 #if defined (__EMX__) || defined (MSDOS) || defined (__vxworks)
1386
1387 /* Code to implement __gnat_set_file_time_name for these systems.  */
1388
1389 #elif defined (_WIN32) && !defined (RTX)
1390   union
1391   {
1392     FILETIME ft_time;
1393     unsigned long long ull_time;
1394   } t_write;
1395   TCHAR wname[GNAT_MAX_PATH_LEN];
1396
1397   S2WSC (wname, name, GNAT_MAX_PATH_LEN);
1398
1399   HANDLE h  = CreateFile
1400     (wname, GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
1401      OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS,
1402      NULL);
1403   if (h == INVALID_HANDLE_VALUE)
1404     return;
1405   /* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
1406   t_write.ull_time = ((unsigned long long)time_stamp + w32_epoch_offset);
1407   /*  Convert to 100 nanosecond units  */
1408   t_write.ull_time *= 10000000ULL;
1409
1410   SetFileTime(h, NULL, NULL, &t_write.ft_time);
1411   CloseHandle (h);
1412   return;
1413
1414 #elif defined (VMS)
1415   struct FAB fab;
1416   struct NAM nam;
1417
1418   struct
1419     {
1420       unsigned long long backup, create, expire, revise;
1421       unsigned int uic;
1422       union
1423         {
1424           unsigned short value;
1425           struct
1426             {
1427               unsigned system : 4;
1428               unsigned owner  : 4;
1429               unsigned group  : 4;
1430               unsigned world  : 4;
1431             } bits;
1432         } prot;
1433     } Fat = { 0, 0, 0, 0, 0, { 0 }};
1434
1435   ATRDEF atrlst[]
1436     = {
1437       { ATR$S_CREDATE,  ATR$C_CREDATE,  &Fat.create },
1438       { ATR$S_REVDATE,  ATR$C_REVDATE,  &Fat.revise },
1439       { ATR$S_EXPDATE,  ATR$C_EXPDATE,  &Fat.expire },
1440       { ATR$S_BAKDATE,  ATR$C_BAKDATE,  &Fat.backup },
1441       { ATR$S_FPRO,     ATR$C_FPRO,     &Fat.prot },
1442       { ATR$S_UIC,      ATR$C_UIC,      &Fat.uic },
1443       { 0, 0, 0}
1444     };
1445
1446   FIBDEF fib;
1447   struct dsc$descriptor_fib fibdsc = {sizeof (fib), (void *) &fib};
1448
1449   struct IOSB iosb;
1450
1451   unsigned long long newtime;
1452   unsigned long long revtime;
1453   long status;
1454   short chan;
1455
1456   struct vstring file;
1457   struct dsc$descriptor_s filedsc
1458     = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) file.string};
1459   struct vstring device;
1460   struct dsc$descriptor_s devicedsc
1461     = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) device.string};
1462   struct vstring timev;
1463   struct dsc$descriptor_s timedsc
1464     = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) timev.string};
1465   struct vstring result;
1466   struct dsc$descriptor_s resultdsc
1467     = {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string};
1468
1469   /* Convert parameter name (a file spec) to host file form. Note that this
1470      is needed on VMS to prepare for subsequent calls to VMS RMS library
1471      routines. Note that it would not work to call __gnat_to_host_dir_spec
1472      as was done in a previous version, since this fails silently unless
1473      the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
1474      (directory not found) condition is signalled.  */
1475   tryfile = (char *) __gnat_to_host_file_spec (name);
1476
1477   /* Allocate and initialize a FAB and NAM structures.  */
1478   fab = cc$rms_fab;
1479   nam = cc$rms_nam;
1480
1481   nam.nam$l_esa = file.string;
1482   nam.nam$b_ess = NAM$C_MAXRSS;
1483   nam.nam$l_rsa = result.string;
1484   nam.nam$b_rss = NAM$C_MAXRSS;
1485   fab.fab$l_fna = tryfile;
1486   fab.fab$b_fns = strlen (tryfile);
1487   fab.fab$l_nam = &nam;
1488
1489   /* Validate filespec syntax and device existence.  */
1490   status = SYS$PARSE (&fab, 0, 0);
1491   if ((status & 1) != 1)
1492     LIB$SIGNAL (status);
1493
1494   file.string[nam.nam$b_esl] = 0;
1495
1496   /* Find matching filespec.  */
1497   status = SYS$SEARCH (&fab, 0, 0);
1498   if ((status & 1) != 1)
1499     LIB$SIGNAL (status);
1500
1501   file.string[nam.nam$b_esl] = 0;
1502   result.string[result.length=nam.nam$b_rsl] = 0;
1503
1504   /* Get the device name and assign an IO channel.  */
1505   strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev);
1506   devicedsc.dsc$w_length  = nam.nam$b_dev;
1507   chan = 0;
1508   status = SYS$ASSIGN (&devicedsc, &chan, 0, 0, 0);
1509   if ((status & 1) != 1)
1510     LIB$SIGNAL (status);
1511
1512   /* Initialize the FIB and fill in the directory id field.  */
1513   memset (&fib, 0, sizeof (fib));
1514   fib.fib$w_did[0]  = nam.nam$w_did[0];
1515   fib.fib$w_did[1]  = nam.nam$w_did[1];
1516   fib.fib$w_did[2]  = nam.nam$w_did[2];
1517   fib.fib$l_acctl = 0;
1518   fib.fib$l_wcc = 0;
1519   strcpy (file.string, (strrchr (result.string, ']') + 1));
1520   filedsc.dsc$w_length = strlen (file.string);
1521   result.string[result.length = 0] = 0;
1522
1523   /* Open and close the file to fill in the attributes.  */
1524   status
1525     = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1526                 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1527   if ((status & 1) != 1)
1528     LIB$SIGNAL (status);
1529   if ((iosb.status & 1) != 1)
1530     LIB$SIGNAL (iosb.status);
1531
1532   result.string[result.length] = 0;
1533   status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, &fibdsc, 0, 0, 0,
1534                      &atrlst, 0);
1535   if ((status & 1) != 1)
1536     LIB$SIGNAL (status);
1537   if ((iosb.status & 1) != 1)
1538     LIB$SIGNAL (iosb.status);
1539
1540   {
1541     time_t t;
1542
1543     /* Set creation time to requested time.  */
1544     unix_time_to_vms (time_stamp, newtime);
1545
1546     t = time ((time_t) 0);
1547
1548     /* Set revision time to now in local time.  */
1549     unix_time_to_vms (t, revtime);
1550   }
1551
1552   /* Reopen the file, modify the times and then close.  */
1553   fib.fib$l_acctl = FIB$M_WRITE;
1554   status
1555     = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
1556                 &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
1557   if ((status & 1) != 1)
1558     LIB$SIGNAL (status);
1559   if ((iosb.status & 1) != 1)
1560     LIB$SIGNAL (iosb.status);
1561
1562   Fat.create = newtime;
1563   Fat.revise = revtime;
1564
1565   status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0,
1566                      &fibdsc, 0, 0, 0, &atrlst, 0);
1567   if ((status & 1) != 1)
1568     LIB$SIGNAL (status);
1569   if ((iosb.status & 1) != 1)
1570     LIB$SIGNAL (iosb.status);
1571
1572   /* Deassign the channel and exit.  */
1573   status = SYS$DASSGN (chan);
1574   if ((status & 1) != 1)
1575     LIB$SIGNAL (status);
1576 #else
1577   struct utimbuf utimbuf;
1578   time_t t;
1579
1580   /* Set modification time to requested time.  */
1581   utimbuf.modtime = time_stamp;
1582
1583   /* Set access time to now in local time.  */
1584   t = time ((time_t) 0);
1585   utimbuf.actime = mktime (localtime (&t));
1586
1587   utime (name, &utimbuf);
1588 #endif
1589 }
1590
1591 /* Get the list of installed standard libraries from the
1592    HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\GNAT\Standard Libraries
1593    key.  */
1594
1595 char *
1596 __gnat_get_libraries_from_registry (void)
1597 {
1598   char *result = (char *) xmalloc (1);
1599
1600   result[0] = '\0';
1601
1602 #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) \
1603   && ! defined (RTX)
1604
1605   HKEY reg_key;
1606   DWORD name_size, value_size;
1607   char name[256];
1608   char value[256];
1609   DWORD type;
1610   DWORD index;
1611   LONG res;
1612
1613   /* First open the key.  */
1614   res = RegOpenKeyExA (HKEY_LOCAL_MACHINE, "SOFTWARE", 0, KEY_READ, &reg_key);
1615
1616   if (res == ERROR_SUCCESS)
1617     res = RegOpenKeyExA (reg_key, "Ada Core Technologies", 0,
1618                          KEY_READ, &reg_key);
1619
1620   if (res == ERROR_SUCCESS)
1621     res = RegOpenKeyExA (reg_key, "GNAT", 0, KEY_READ, &reg_key);
1622
1623   if (res == ERROR_SUCCESS)
1624     res = RegOpenKeyExA (reg_key, "Standard Libraries", 0, KEY_READ, &reg_key);
1625
1626   /* If the key exists, read out all the values in it and concatenate them
1627      into a path.  */
1628   for (index = 0; res == ERROR_SUCCESS; index++)
1629     {
1630       value_size = name_size = 256;
1631       res = RegEnumValueA (reg_key, index, name, &name_size, 0,
1632                            &type, (LPBYTE)value, &value_size);
1633
1634       if (res == ERROR_SUCCESS && type == REG_SZ)
1635         {
1636           char *old_result = result;
1637
1638           result = (char *) xmalloc (strlen (old_result) + value_size + 2);
1639           strcpy (result, old_result);
1640           strcat (result, value);
1641           strcat (result, ";");
1642           free (old_result);
1643         }
1644     }
1645
1646   /* Remove the trailing ";".  */
1647   if (result[0] != 0)
1648     result[strlen (result) - 1] = 0;
1649
1650 #endif
1651   return result;
1652 }
1653
1654 int
1655 __gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf)
1656 {
1657 #ifdef __MINGW32__
1658   /* Under Windows the directory name for the stat function must not be
1659      terminated by a directory separator except if just after a drive name
1660      or with UNC path without directory (only the name of the shared
1661      resource), for example: \\computer\share\  */
1662
1663   TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1664   int name_len, k;
1665   TCHAR last_char;
1666   int dirsep_count = 0;
1667
1668   S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
1669   name_len = _tcslen (wname);
1670
1671   if (name_len > GNAT_MAX_PATH_LEN)
1672     return -1;
1673
1674   last_char = wname[name_len - 1];
1675
1676   while (name_len > 1 && (last_char == _T('\\') || last_char == _T('/')))
1677     {
1678       wname[name_len - 1] = _T('\0');
1679       name_len--;
1680       last_char = wname[name_len - 1];
1681     }
1682
1683   /* Count back-slashes.  */
1684
1685   for (k=0; k<name_len; k++)
1686     if (wname[k] == _T('\\') || wname[k] == _T('/'))
1687       dirsep_count++;
1688
1689   /* Only a drive letter followed by ':', we must add a directory separator
1690      for the stat routine to work properly.  */
1691   if ((name_len == 2 && wname[1] == _T(':'))
1692       || (name_len > 3 && wname[0] == _T('\\') && wname[1] == _T('\\')
1693           && dirsep_count == 3))
1694     _tcscat (wname, _T("\\"));
1695
1696   return _tstat (wname, (struct _stat *)statbuf);
1697
1698 #else
1699   return GNAT_STAT (name, statbuf);
1700 #endif
1701 }
1702
1703 int
1704 __gnat_file_exists (char *name)
1705 {
1706 #ifdef __MINGW32__
1707   /*  On Windows do not use __gnat_stat() because a bug in Microsoft
1708   _stat() routine. When the system time-zone is set with a negative
1709   offset the _stat() routine fails on specific files like CON:  */
1710   TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1711
1712   S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
1713   return GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES;
1714 #else
1715   GNAT_STRUCT_STAT statbuf;
1716
1717   return !__gnat_stat (name, &statbuf);
1718 #endif
1719 }
1720
1721 int
1722 __gnat_is_absolute_path (char *name, int length)
1723 {
1724 #ifdef __vxworks
1725   /* On VxWorks systems, an absolute path can be represented (depending on
1726      the host platform) as either /dir/file, or device:/dir/file, or
1727      device:drive_letter:/dir/file. */
1728
1729   int index;
1730
1731   if (name[0] == '/')
1732     return 1;
1733
1734   for (index = 0; index < length; index++)
1735     {
1736       if (name[index] == ':' &&
1737           ((name[index + 1] == '/') ||
1738            (isalpha (name[index + 1]) && index + 2 <= length &&
1739             name[index + 2] == '/')))
1740         return 1;
1741
1742       else if (name[index] == '/')
1743         return 0;
1744     }
1745   return 0;
1746 #else
1747   return (length != 0) &&
1748      (*name == '/' || *name == DIR_SEPARATOR
1749 #if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
1750       || (length > 1 && ISALPHA (name[0]) && name[1] == ':')
1751 #endif
1752           );
1753 #endif
1754 }
1755
1756 int
1757 __gnat_is_regular_file (char *name)
1758 {
1759   int ret;
1760   GNAT_STRUCT_STAT statbuf;
1761
1762   ret = __gnat_stat (name, &statbuf);
1763   return (!ret && S_ISREG (statbuf.st_mode));
1764 }
1765
1766 int
1767 __gnat_is_directory (char *name)
1768 {
1769   int ret;
1770   GNAT_STRUCT_STAT statbuf;
1771
1772   ret = __gnat_stat (name, &statbuf);
1773   return (!ret && S_ISDIR (statbuf.st_mode));
1774 }
1775
1776 #if defined (_WIN32) && !defined (RTX)
1777
1778 /* Returns the same constant as GetDriveType but takes a pathname as
1779    argument. */
1780
1781 static UINT
1782 GetDriveTypeFromPath (TCHAR *wfullpath)
1783 {
1784   TCHAR wdrv[MAX_PATH];
1785   TCHAR wpath[MAX_PATH];
1786   TCHAR wfilename[MAX_PATH];
1787   TCHAR wext[MAX_PATH];
1788
1789   _tsplitpath (wfullpath, wdrv, wpath, wfilename, wext);
1790
1791   if (_tcslen (wdrv) != 0)
1792     {
1793       /* we have a drive specified. */
1794       _tcscat (wdrv, _T("\\"));
1795       return GetDriveType (wdrv);
1796     }
1797   else
1798     {
1799       /* No drive specified. */
1800
1801       /* Is this a relative path, if so get current drive type. */
1802       if (wpath[0] != _T('\\') ||
1803           (_tcslen (wpath) > 2 && wpath[0] == _T('\\') && wpath[1] != _T('\\')))
1804         return GetDriveType (NULL);
1805
1806       UINT result = GetDriveType (wpath);
1807
1808       /* Cannot guess the drive type, is this \\.\ ? */
1809
1810       if (result == DRIVE_NO_ROOT_DIR &&
1811          _tcslen (wpath) >= 4 && wpath[0] == _T('\\') && wpath[1] == _T('\\')
1812           && wpath[2] == _T('.') && wpath[3] == _T('\\'))
1813         {
1814           if (_tcslen (wpath) == 4)
1815             _tcscat (wpath, wfilename);
1816
1817           LPTSTR p = &wpath[4];
1818           LPTSTR b = _tcschr (p, _T('\\'));
1819
1820           if (b != NULL)
1821             { /* logical drive \\.\c\dir\file */
1822               *b++ = _T(':');
1823               *b++ = _T('\\');
1824               *b = _T('\0');
1825             }
1826           else
1827             _tcscat (p, _T(":\\"));
1828
1829           return GetDriveType (p);
1830         }
1831
1832       return result;
1833     }
1834 }
1835
1836 /*  This MingW section contains code to work with ACL. */
1837 static int
1838 __gnat_check_OWNER_ACL
1839 (TCHAR *wname,
1840  DWORD CheckAccessDesired,
1841  GENERIC_MAPPING CheckGenericMapping)
1842 {
1843   DWORD dwAccessDesired, dwAccessAllowed;
1844   PRIVILEGE_SET PrivilegeSet;
1845   DWORD dwPrivSetSize = sizeof (PRIVILEGE_SET);
1846   BOOL fAccessGranted = FALSE;
1847   HANDLE hToken = NULL;
1848   DWORD nLength = 0;
1849   SECURITY_DESCRIPTOR* pSD = NULL;
1850
1851   GetFileSecurity
1852     (wname, OWNER_SECURITY_INFORMATION |
1853      GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION,
1854      NULL, 0, &nLength);
1855
1856   if ((pSD = (PSECURITY_DESCRIPTOR) HeapAlloc
1857        (GetProcessHeap (), HEAP_ZERO_MEMORY, nLength)) == NULL)
1858     return 0;
1859
1860   /* Obtain the security descriptor. */
1861
1862   if (!GetFileSecurity
1863       (wname, OWNER_SECURITY_INFORMATION |
1864        GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION,
1865        pSD, nLength, &nLength))
1866     goto error;
1867
1868   if (!ImpersonateSelf (SecurityImpersonation))
1869     goto error;
1870
1871   if (!OpenThreadToken
1872       (GetCurrentThread(), TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken))
1873     goto error;
1874
1875   /*  Undoes the effect of ImpersonateSelf. */
1876
1877   RevertToSelf ();
1878
1879   /*  We want to test for write permissions. */
1880
1881   dwAccessDesired = CheckAccessDesired;
1882
1883   MapGenericMask (&dwAccessDesired, &CheckGenericMapping);
1884
1885   if (!AccessCheck
1886       (pSD ,                 /* security descriptor to check */
1887        hToken,               /* impersonation token */
1888        dwAccessDesired,      /* requested access rights */
1889        &CheckGenericMapping, /* pointer to GENERIC_MAPPING */
1890        &PrivilegeSet,        /* receives privileges used in check */
1891        &dwPrivSetSize,       /* size of PrivilegeSet buffer */
1892        &dwAccessAllowed,     /* receives mask of allowed access rights */
1893        &fAccessGranted))
1894     goto error;
1895
1896   CloseHandle (hToken);
1897   HeapFree (GetProcessHeap (), 0, pSD);
1898   return fAccessGranted;
1899
1900  error:
1901   if (hToken)
1902     CloseHandle (hToken);
1903   HeapFree (GetProcessHeap (), 0, pSD);
1904   return 0;
1905 }
1906
1907 static void
1908 __gnat_set_OWNER_ACL
1909 (TCHAR *wname,
1910  DWORD AccessMode,
1911  DWORD AccessPermissions)
1912 {
1913   PACL pOldDACL = NULL;
1914   PACL pNewDACL = NULL;
1915   PSECURITY_DESCRIPTOR pSD = NULL;
1916   EXPLICIT_ACCESS ea;
1917   TCHAR username [100];
1918   DWORD unsize = 100;
1919
1920   /*  Get current user, he will act as the owner */
1921
1922   if (!GetUserName (username, &unsize))
1923     return;
1924
1925   if (GetNamedSecurityInfo
1926       (wname,
1927        SE_FILE_OBJECT,
1928        DACL_SECURITY_INFORMATION,
1929        NULL, NULL, &pOldDACL, NULL, &pSD) != ERROR_SUCCESS)
1930     return;
1931
1932   BuildExplicitAccessWithName
1933     (&ea, username, AccessPermissions, AccessMode, NO_INHERITANCE);
1934
1935   if (AccessMode == SET_ACCESS)
1936     {
1937       /*  SET_ACCESS, we want to set an explicte set of permissions, do not
1938           merge with current DACL.  */
1939       if (SetEntriesInAcl (1, &ea, NULL, &pNewDACL) != ERROR_SUCCESS)
1940         return;
1941     }
1942   else
1943     if (SetEntriesInAcl (1, &ea, pOldDACL, &pNewDACL) != ERROR_SUCCESS)
1944       return;
1945
1946   if (SetNamedSecurityInfo
1947       (wname, SE_FILE_OBJECT,
1948        DACL_SECURITY_INFORMATION, NULL, NULL, pNewDACL, NULL) != ERROR_SUCCESS)
1949     return;
1950
1951   LocalFree (pSD);
1952   LocalFree (pNewDACL);
1953 }
1954
1955 /* Check if it is possible to use ACL for wname, the file must not be on a
1956    network drive. */
1957
1958 static int
1959 __gnat_can_use_acl (TCHAR *wname)
1960 {
1961   return __gnat_use_acl && GetDriveTypeFromPath (wname) != DRIVE_REMOTE;
1962 }
1963
1964 #endif /* defined (_WIN32) && !defined (RTX) */
1965
1966 int
1967 __gnat_is_readable_file (char *name)
1968 {
1969 #if defined (_WIN32) && !defined (RTX)
1970   TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1971   GENERIC_MAPPING GenericMapping;
1972
1973   S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
1974
1975   if (__gnat_can_use_acl (wname))
1976     {
1977       ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
1978       GenericMapping.GenericRead = GENERIC_READ;
1979
1980       return __gnat_check_OWNER_ACL (wname, FILE_READ_DATA, GenericMapping);
1981     }
1982   else
1983     return GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES;
1984
1985 #else
1986   int ret;
1987   int mode;
1988   GNAT_STRUCT_STAT statbuf;
1989
1990   ret = GNAT_STAT (name, &statbuf);
1991   mode = statbuf.st_mode & S_IRUSR;
1992   return (!ret && mode);
1993 #endif
1994 }
1995
1996 int
1997 __gnat_is_writable_file (char *name)
1998 {
1999 #if defined (_WIN32) && !defined (RTX)
2000   TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2001   GENERIC_MAPPING GenericMapping;
2002
2003   S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2004
2005   if (__gnat_can_use_acl (wname))
2006     {
2007       ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
2008       GenericMapping.GenericWrite = GENERIC_WRITE;
2009
2010       return __gnat_check_OWNER_ACL
2011         (wname, FILE_WRITE_DATA | FILE_APPEND_DATA, GenericMapping)
2012         && !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY);
2013     }
2014   else
2015     return !(GetFileAttributes (wname) & FILE_ATTRIBUTE_READONLY);
2016
2017 #else
2018   int ret;
2019   int mode;
2020   GNAT_STRUCT_STAT statbuf;
2021
2022   ret = GNAT_STAT (name, &statbuf);
2023   mode = statbuf.st_mode & S_IWUSR;
2024   return (!ret && mode);
2025 #endif
2026 }
2027
2028 int
2029 __gnat_is_executable_file (char *name)
2030 {
2031 #if defined (_WIN32) && !defined (RTX)
2032   TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2033   GENERIC_MAPPING GenericMapping;
2034
2035   S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2036
2037   if (__gnat_can_use_acl (wname))
2038     {
2039       ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
2040       GenericMapping.GenericExecute = GENERIC_EXECUTE;
2041
2042       return __gnat_check_OWNER_ACL (wname, FILE_EXECUTE, GenericMapping);
2043     }
2044   else
2045     return GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES
2046       && _tcsstr (wname, _T(".exe")) - wname == (int) (_tcslen (wname) - 4);
2047 #else
2048   int ret;
2049   int mode;
2050   GNAT_STRUCT_STAT statbuf;
2051
2052   ret = GNAT_STAT (name, &statbuf);
2053   mode = statbuf.st_mode & S_IXUSR;
2054   return (!ret && mode);
2055 #endif
2056 }
2057
2058 void
2059 __gnat_set_writable (char *name)
2060 {
2061 #if defined (_WIN32) && !defined (RTX)
2062   TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2063
2064   S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2065
2066   if (__gnat_can_use_acl (wname))
2067     __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_WRITE);
2068
2069   SetFileAttributes
2070     (wname, GetFileAttributes (wname) & ~FILE_ATTRIBUTE_READONLY);
2071 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2072   GNAT_STRUCT_STAT statbuf;
2073
2074   if (GNAT_STAT (name, &statbuf) == 0)
2075     {
2076       statbuf.st_mode = statbuf.st_mode | S_IWUSR;
2077       chmod (name, statbuf.st_mode);
2078     }
2079 #endif
2080 }
2081
2082 void
2083 __gnat_set_executable (char *name)
2084 {
2085 #if defined (_WIN32) && !defined (RTX)
2086   TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2087
2088   S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2089
2090   if (__gnat_can_use_acl (wname))
2091     __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_EXECUTE);
2092
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_IXUSR;
2099       chmod (name, statbuf.st_mode);
2100     }
2101 #endif
2102 }
2103
2104 void
2105 __gnat_set_non_writable (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
2114       (wname, DENY_ACCESS,
2115        FILE_WRITE_DATA | FILE_APPEND_DATA |
2116        FILE_WRITE_EA | FILE_WRITE_ATTRIBUTES);
2117
2118   SetFileAttributes
2119     (wname, GetFileAttributes (wname) | FILE_ATTRIBUTE_READONLY);
2120 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2121   GNAT_STRUCT_STAT statbuf;
2122
2123   if (GNAT_STAT (name, &statbuf) == 0)
2124     {
2125       statbuf.st_mode = statbuf.st_mode & 07577;
2126       chmod (name, statbuf.st_mode);
2127     }
2128 #endif
2129 }
2130
2131 void
2132 __gnat_set_readable (char *name)
2133 {
2134 #if defined (_WIN32) && !defined (RTX)
2135   TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2136
2137   S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2138
2139   if (__gnat_can_use_acl (wname))
2140     __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_READ);
2141
2142 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2143   GNAT_STRUCT_STAT statbuf;
2144
2145   if (GNAT_STAT (name, &statbuf) == 0)
2146     {
2147       chmod (name, statbuf.st_mode | S_IREAD);
2148     }
2149 #endif
2150 }
2151
2152 void
2153 __gnat_set_non_readable (char *name)
2154 {
2155 #if defined (_WIN32) && !defined (RTX)
2156   TCHAR wname [GNAT_MAX_PATH_LEN + 2];
2157
2158   S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
2159
2160   if (__gnat_can_use_acl (wname))
2161     __gnat_set_OWNER_ACL (wname, DENY_ACCESS, FILE_GENERIC_READ);
2162
2163 #elif ! defined (__vxworks) && ! defined(__nucleus__)
2164   GNAT_STRUCT_STAT statbuf;
2165
2166   if (GNAT_STAT (name, &statbuf) == 0)
2167     {
2168       chmod (name, statbuf.st_mode & (~S_IREAD));
2169     }
2170 #endif
2171 }
2172
2173 int
2174 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED)
2175 {
2176 #if defined (__vxworks) || defined (__nucleus__)
2177   return 0;
2178
2179 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
2180   int ret;
2181   GNAT_STRUCT_STAT statbuf;
2182
2183   ret = GNAT_LSTAT (name, &statbuf);
2184   return (!ret && S_ISLNK (statbuf.st_mode));
2185
2186 #else
2187   return 0;
2188 #endif
2189 }
2190
2191 #if defined (sun) && defined (__SVR4)
2192 /* Using fork on Solaris will duplicate all the threads. fork1, which
2193    duplicates only the active thread, must be used instead, or spawning
2194    subprocess from a program with tasking will lead into numerous problems.  */
2195 #define fork fork1
2196 #endif
2197
2198 int
2199 __gnat_portable_spawn (char *args[])
2200 {
2201   int status = 0;
2202   int finished ATTRIBUTE_UNUSED;
2203   int pid ATTRIBUTE_UNUSED;
2204
2205 #if defined (__vxworks) || defined(__nucleus__) || defined(RTX)
2206   return -1;
2207
2208 #elif defined (MSDOS) || defined (_WIN32)
2209   /* args[0] must be quotes as it could contain a full pathname with spaces */
2210   char *args_0 = args[0];
2211   args[0] = (char *)xmalloc (strlen (args_0) + 3);
2212   strcpy (args[0], "\"");
2213   strcat (args[0], args_0);
2214   strcat (args[0], "\"");
2215
2216   status = spawnvp (P_WAIT, args_0, (const char* const*)args);
2217
2218   /* restore previous value */
2219   free (args[0]);
2220   args[0] = (char *)args_0;
2221
2222   if (status < 0)
2223     return -1;
2224   else
2225     return status;
2226
2227 #else
2228
2229 #ifdef __EMX__
2230   pid = spawnvp (P_NOWAIT, args[0], args);
2231   if (pid == -1)
2232     return -1;
2233
2234 #else
2235   pid = fork ();
2236   if (pid < 0)
2237     return -1;
2238
2239   if (pid == 0)
2240     {
2241       /* The child. */
2242       if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
2243 #if defined (VMS)
2244         return -1; /* execv is in parent context on VMS.  */
2245 #else
2246         _exit (1);
2247 #endif
2248     }
2249 #endif
2250
2251   /* The parent.  */
2252   finished = waitpid (pid, &status, 0);
2253
2254   if (finished != pid || WIFEXITED (status) == 0)
2255     return -1;
2256
2257   return WEXITSTATUS (status);
2258 #endif
2259
2260   return 0;
2261 }
2262
2263 /* Create a copy of the given file descriptor.
2264    Return -1 if an error occurred.  */
2265
2266 int
2267 __gnat_dup (int oldfd)
2268 {
2269 #if defined (__vxworks) && !defined (__RTP__)
2270   /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2271      RTPs. */
2272   return -1;
2273 #else
2274   return dup (oldfd);
2275 #endif
2276 }
2277
2278 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
2279    Return -1 if an error occurred.  */
2280
2281 int
2282 __gnat_dup2 (int oldfd, int newfd)
2283 {
2284 #if defined (__vxworks) && !defined (__RTP__)
2285   /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2286      RTPs.  */
2287   return -1;
2288 #else
2289   return dup2 (oldfd, newfd);
2290 #endif
2291 }
2292
2293 /* WIN32 code to implement a wait call that wait for any child process.  */
2294
2295 #if defined (_WIN32) && !defined (RTX)
2296
2297 /* Synchronization code, to be thread safe.  */
2298
2299 #ifdef CERT
2300
2301 /* For the Cert run times on native Windows we use dummy functions
2302    for locking and unlocking tasks since we do not support multiple
2303    threads on this configuration (Cert run time on native Windows). */
2304
2305 void dummy (void) {}
2306
2307 void (*Lock_Task) ()   = &dummy;
2308 void (*Unlock_Task) () = &dummy;
2309
2310 #else
2311
2312 #define Lock_Task system__soft_links__lock_task
2313 extern void (*Lock_Task) (void);
2314
2315 #define Unlock_Task system__soft_links__unlock_task
2316 extern void (*Unlock_Task) (void);
2317
2318 #endif
2319
2320 static HANDLE *HANDLES_LIST = NULL;
2321 static int *PID_LIST = NULL, plist_length = 0, plist_max_length = 0;
2322
2323 static void
2324 add_handle (HANDLE h)
2325 {
2326
2327   /* -------------------- critical section -------------------- */
2328   (*Lock_Task) ();
2329
2330   if (plist_length == plist_max_length)
2331     {
2332       plist_max_length += 1000;
2333       HANDLES_LIST =
2334         xrealloc (HANDLES_LIST, sizeof (HANDLE) * plist_max_length);
2335       PID_LIST =
2336         xrealloc (PID_LIST, sizeof (int) * plist_max_length);
2337     }
2338
2339   HANDLES_LIST[plist_length] = h;
2340   PID_LIST[plist_length] = GetProcessId (h);
2341   ++plist_length;
2342
2343   (*Unlock_Task) ();
2344   /* -------------------- critical section -------------------- */
2345 }
2346
2347 void
2348 __gnat_win32_remove_handle (HANDLE h, int pid)
2349 {
2350   int j;
2351
2352   /* -------------------- critical section -------------------- */
2353   (*Lock_Task) ();
2354
2355   for (j = 0; j < plist_length; j++)
2356     {
2357       if ((HANDLES_LIST[j] == h) || (PID_LIST[j] == pid))
2358         {
2359           CloseHandle (h);
2360           --plist_length;
2361           HANDLES_LIST[j] = HANDLES_LIST[plist_length];
2362           PID_LIST[j] = PID_LIST[plist_length];
2363           break;
2364         }
2365     }
2366
2367   (*Unlock_Task) ();
2368   /* -------------------- critical section -------------------- */
2369 }
2370
2371 static HANDLE
2372 win32_no_block_spawn (char *command, char *args[])
2373 {
2374   BOOL result;
2375   STARTUPINFO SI;
2376   PROCESS_INFORMATION PI;
2377   SECURITY_ATTRIBUTES SA;
2378   int csize = 1;
2379   char *full_command;
2380   int k;
2381
2382   /* compute the total command line length */
2383   k = 0;
2384   while (args[k])
2385     {
2386       csize += strlen (args[k]) + 1;
2387       k++;
2388     }
2389
2390   full_command = (char *) xmalloc (csize);
2391
2392   /* Startup info. */
2393   SI.cb          = sizeof (STARTUPINFO);
2394   SI.lpReserved  = NULL;
2395   SI.lpReserved2 = NULL;
2396   SI.lpDesktop   = NULL;
2397   SI.cbReserved2 = 0;
2398   SI.lpTitle     = NULL;
2399   SI.dwFlags     = 0;
2400   SI.wShowWindow = SW_HIDE;
2401
2402   /* Security attributes. */
2403   SA.nLength = sizeof (SECURITY_ATTRIBUTES);
2404   SA.bInheritHandle = TRUE;
2405   SA.lpSecurityDescriptor = NULL;
2406
2407   /* Prepare the command string. */
2408   strcpy (full_command, command);
2409   strcat (full_command, " ");
2410
2411   k = 1;
2412   while (args[k])
2413     {
2414       strcat (full_command, args[k]);
2415       strcat (full_command, " ");
2416       k++;
2417     }
2418
2419   {
2420     int wsize = csize * 2;
2421     TCHAR *wcommand = (TCHAR *) xmalloc (wsize);
2422
2423     S2WSC (wcommand, full_command, wsize);
2424
2425     free (full_command);
2426
2427     result = CreateProcess
2428       (NULL, wcommand, &SA, NULL, TRUE,
2429        GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
2430
2431     free (wcommand);
2432   }
2433
2434   if (result == TRUE)
2435     {
2436       CloseHandle (PI.hThread);
2437       return PI.hProcess;
2438     }
2439   else
2440     return NULL;
2441 }
2442
2443 static int
2444 win32_wait (int *status)
2445 {
2446   DWORD exitcode, pid;
2447   HANDLE *hl;
2448   HANDLE h;
2449   DWORD res;
2450   int k;
2451   int hl_len;
2452
2453   if (plist_length == 0)
2454     {
2455       errno = ECHILD;
2456       return -1;
2457     }
2458
2459   k = 0;
2460
2461   /* -------------------- critical section -------------------- */
2462   (*Lock_Task) ();
2463
2464   hl_len = plist_length;
2465
2466   hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len);
2467
2468   memmove (hl, HANDLES_LIST, sizeof (HANDLE) * hl_len);
2469
2470   (*Unlock_Task) ();
2471   /* -------------------- critical section -------------------- */
2472
2473   res = WaitForMultipleObjects (hl_len, hl, FALSE, INFINITE);
2474   h = hl[res - WAIT_OBJECT_0];
2475
2476   GetExitCodeProcess (h, &exitcode);
2477   pid = GetProcessId (h);
2478   __gnat_win32_remove_handle (h, -1);
2479
2480   free (hl);
2481
2482   *status = (int) exitcode;
2483   return (int) pid;
2484 }
2485
2486 #endif
2487
2488 int
2489 __gnat_portable_no_block_spawn (char *args[])
2490 {
2491
2492 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2493   return -1;
2494
2495 #elif defined (__EMX__) || defined (MSDOS)
2496
2497   /* ??? For PC machines I (Franco) don't know the system calls to implement
2498      this routine. So I'll fake it as follows. This routine will behave
2499      exactly like the blocking portable_spawn and will systematically return
2500      a pid of 0 unless the spawned task did not complete successfully, in
2501      which case we return a pid of -1.  To synchronize with this the
2502      portable_wait below systematically returns a pid of 0 and reports that
2503      the subprocess terminated successfully. */
2504
2505   if (spawnvp (P_WAIT, args[0], args) != 0)
2506     return -1;
2507
2508 #elif defined (_WIN32)
2509
2510   HANDLE h = NULL;
2511
2512   h = win32_no_block_spawn (args[0], args);
2513   if (h != NULL)
2514     {
2515       add_handle (h);
2516       return GetProcessId (h);
2517     }
2518   else
2519     return -1;
2520
2521 #else
2522
2523   int pid = fork ();
2524
2525   if (pid == 0)
2526     {
2527       /* The child.  */
2528       if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
2529 #if defined (VMS)
2530         return -1; /* execv is in parent context on VMS. */
2531 #else
2532         _exit (1);
2533 #endif
2534     }
2535
2536   return pid;
2537
2538   #endif
2539 }
2540
2541 int
2542 __gnat_portable_wait (int *process_status)
2543 {
2544   int status = 0;
2545   int pid = 0;
2546
2547 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2548   /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
2549      return zero.  */
2550
2551 #elif defined (_WIN32)
2552
2553   pid = win32_wait (&status);
2554
2555 #elif defined (__EMX__) || defined (MSDOS)
2556   /* ??? See corresponding comment in portable_no_block_spawn.  */
2557
2558 #else
2559
2560   pid = waitpid (-1, &status, 0);
2561   status = status & 0xffff;
2562 #endif
2563
2564   *process_status = status;
2565   return pid;
2566 }
2567
2568 void
2569 __gnat_os_exit (int status)
2570 {
2571   exit (status);
2572 }
2573
2574 /* Locate a regular file, give a Path value.  */
2575
2576 char *
2577 __gnat_locate_regular_file (char *file_name, char *path_val)
2578 {
2579   char *ptr;
2580   char *file_path = (char *) alloca (strlen (file_name) + 1);
2581   int absolute;
2582
2583   /* Return immediately if file_name is empty */
2584
2585   if (*file_name == '\0')
2586     return 0;
2587
2588   /* Remove quotes around file_name if present */
2589
2590   ptr = file_name;
2591   if (*ptr == '"')
2592     ptr++;
2593
2594   strcpy (file_path, ptr);
2595
2596   ptr = file_path + strlen (file_path) - 1;
2597
2598   if (*ptr == '"')
2599     *ptr = '\0';
2600
2601   /* Handle absolute pathnames.  */
2602
2603   absolute = __gnat_is_absolute_path (file_path, strlen (file_name));
2604
2605   if (absolute)
2606     {
2607      if (__gnat_is_regular_file (file_path))
2608        return xstrdup (file_path);
2609
2610       return 0;
2611     }
2612
2613   /* If file_name include directory separator(s), try it first as
2614      a path name relative to the current directory */
2615   for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
2616     ;
2617
2618   if (*ptr != 0)
2619     {
2620       if (__gnat_is_regular_file (file_name))
2621         return xstrdup (file_name);
2622     }
2623
2624   if (path_val == 0)
2625     return 0;
2626
2627   {
2628     /* The result has to be smaller than path_val + file_name.  */
2629     char *file_path = (char *) alloca (strlen (path_val) + strlen (file_name) + 2);
2630
2631     for (;;)
2632       {
2633         for (; *path_val == PATH_SEPARATOR; path_val++)
2634           ;
2635
2636       if (*path_val == 0)
2637         return 0;
2638
2639       /* Skip the starting quote */
2640
2641       if (*path_val == '"')
2642         path_val++;
2643
2644       for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
2645         *ptr++ = *path_val++;
2646
2647       ptr--;
2648
2649       /* Skip the ending quote */
2650
2651       if (*ptr == '"')
2652         ptr--;
2653
2654       if (*ptr != '/' && *ptr != DIR_SEPARATOR)
2655         *++ptr = DIR_SEPARATOR;
2656
2657       strcpy (++ptr, file_name);
2658
2659       if (__gnat_is_regular_file (file_path))
2660         return xstrdup (file_path);
2661       }
2662   }
2663
2664   return 0;
2665 }
2666
2667 /* Locate an executable given a Path argument. This routine is only used by
2668    gnatbl and should not be used otherwise.  Use locate_exec_on_path
2669    instead.  */
2670
2671 char *
2672 __gnat_locate_exec (char *exec_name, char *path_val)
2673 {
2674   char *ptr;
2675   if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
2676     {
2677       char *full_exec_name
2678         = (char *) alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
2679
2680       strcpy (full_exec_name, exec_name);
2681       strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
2682       ptr = __gnat_locate_regular_file (full_exec_name, path_val);
2683
2684       if (ptr == 0)
2685          return __gnat_locate_regular_file (exec_name, path_val);
2686       return ptr;
2687     }
2688   else
2689     return __gnat_locate_regular_file (exec_name, path_val);
2690 }
2691
2692 /* Locate an executable using the Systems default PATH.  */
2693
2694 char *
2695 __gnat_locate_exec_on_path (char *exec_name)
2696 {
2697   char *apath_val;
2698
2699 #if defined (_WIN32) && !defined (RTX)
2700   TCHAR *wpath_val = _tgetenv (_T("PATH"));
2701   TCHAR *wapath_val;
2702   /* In Win32 systems we expand the PATH as for XP environment
2703      variables are not automatically expanded. We also prepend the
2704      ".;" to the path to match normal NT path search semantics */
2705
2706   #define EXPAND_BUFFER_SIZE 32767
2707
2708   wapath_val = alloca (EXPAND_BUFFER_SIZE);
2709
2710   wapath_val [0] = '.';
2711   wapath_val [1] = ';';
2712
2713   DWORD res = ExpandEnvironmentStrings
2714     (wpath_val, &wapath_val[2], EXPAND_BUFFER_SIZE - 2);
2715
2716   if (!res) wapath_val [0] = _T('\0');
2717
2718   apath_val = alloca (EXPAND_BUFFER_SIZE);
2719
2720   WS2SC (apath_val, wapath_val, EXPAND_BUFFER_SIZE);
2721   return __gnat_locate_exec (exec_name, apath_val);
2722
2723 #else
2724
2725 #ifdef VMS
2726   char *path_val = "/VAXC$PATH";
2727 #else
2728   char *path_val = getenv ("PATH");
2729 #endif
2730   if (path_val == NULL) return NULL;
2731   apath_val = (char *) alloca (strlen (path_val) + 1);
2732   strcpy (apath_val, path_val);
2733   return __gnat_locate_exec (exec_name, apath_val);
2734 #endif
2735 }
2736
2737 #ifdef VMS
2738
2739 /* These functions are used to translate to and from VMS and Unix syntax
2740    file, directory and path specifications.  */
2741
2742 #define MAXPATH  256
2743 #define MAXNAMES 256
2744 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2745
2746 static char new_canonical_dirspec [MAXPATH];
2747 static char new_canonical_filespec [MAXPATH];
2748 static char new_canonical_pathspec [MAXNAMES*MAXPATH];
2749 static unsigned new_canonical_filelist_index;
2750 static unsigned new_canonical_filelist_in_use;
2751 static unsigned new_canonical_filelist_allocated;
2752 static char **new_canonical_filelist;
2753 static char new_host_pathspec [MAXNAMES*MAXPATH];
2754 static char new_host_dirspec [MAXPATH];
2755 static char new_host_filespec [MAXPATH];
2756
2757 /* Routine is called repeatedly by decc$from_vms via
2758    __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2759    runs out. */
2760
2761 static int
2762 wildcard_translate_unix (char *name)
2763 {
2764   char *ver;
2765   char buff [MAXPATH];
2766
2767   strncpy (buff, name, MAXPATH);
2768   buff [MAXPATH - 1] = (char) 0;
2769   ver = strrchr (buff, '.');
2770
2771   /* Chop off the version.  */
2772   if (ver)
2773     *ver = 0;
2774
2775   /* Dynamically extend the allocation by the increment.  */
2776   if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
2777     {
2778       new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
2779       new_canonical_filelist = (char **) xrealloc
2780         (new_canonical_filelist,
2781          new_canonical_filelist_allocated * sizeof (char *));
2782     }
2783
2784   new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
2785
2786   return 1;
2787 }
2788
2789 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2790    full translation and copy the results into a list (_init), then return them
2791    one at a time (_next). If onlydirs set, only expand directory files.  */
2792
2793 int
2794 __gnat_to_canonical_file_list_init (char *filespec, int onlydirs)
2795 {
2796   int len;
2797   char buff [MAXPATH];
2798
2799   len = strlen (filespec);
2800   strncpy (buff, filespec, MAXPATH);
2801
2802   /* Only look for directories */
2803   if (onlydirs && !strstr (&buff [len-5], "*.dir"))
2804     strncat (buff, "*.dir", MAXPATH);
2805
2806   buff [MAXPATH - 1] = (char) 0;
2807
2808   decc$from_vms (buff, wildcard_translate_unix, 1);
2809
2810   /* Remove the .dir extension.  */
2811   if (onlydirs)
2812     {
2813       int i;
2814       char *ext;
2815
2816       for (i = 0; i < new_canonical_filelist_in_use; i++)
2817         {
2818           ext = strstr (new_canonical_filelist[i], ".dir");
2819           if (ext)
2820             *ext = 0;
2821         }
2822     }
2823
2824   return new_canonical_filelist_in_use;
2825 }
2826
2827 /* Return the next filespec in the list.  */
2828
2829 char *
2830 __gnat_to_canonical_file_list_next ()
2831 {
2832   return new_canonical_filelist[new_canonical_filelist_index++];
2833 }
2834
2835 /* Free storage used in the wildcard expansion.  */
2836
2837 void
2838 __gnat_to_canonical_file_list_free ()
2839 {
2840   int i;
2841
2842    for (i = 0; i < new_canonical_filelist_in_use; i++)
2843      free (new_canonical_filelist[i]);
2844
2845   free (new_canonical_filelist);
2846
2847   new_canonical_filelist_in_use = 0;
2848   new_canonical_filelist_allocated = 0;
2849   new_canonical_filelist_index = 0;
2850   new_canonical_filelist = 0;
2851 }
2852
2853 /* The functional equivalent of decc$translate_vms routine.
2854    Designed to produce the same output, but is protected against
2855    malformed paths (original version ACCVIOs in this case) and
2856    does not require VMS-specific DECC RTL */
2857
2858 #define NAM$C_MAXRSS 1024
2859
2860 char *
2861 __gnat_translate_vms (char *src)
2862 {
2863   static char retbuf [NAM$C_MAXRSS+1];
2864   char *srcendpos, *pos1, *pos2, *retpos;
2865   int disp, path_present = 0;
2866
2867   if (!src) return NULL;
2868
2869   srcendpos = strchr (src, '\0');
2870   retpos = retbuf;
2871
2872   /* Look for the node and/or device in front of the path */
2873   pos1 = src;
2874   pos2 = strchr (pos1, ':');
2875
2876   if (pos2 && (pos2 < srcendpos) && (*(pos2 + 1) == ':')) {
2877     /* There is a node name. "node_name::" becomes "node_name!" */
2878     disp = pos2 - pos1;
2879     strncpy (retbuf, pos1, disp);
2880     retpos [disp] = '!';
2881     retpos = retpos + disp + 1;
2882     pos1 = pos2 + 2;
2883     pos2 = strchr (pos1, ':');
2884   }
2885
2886   if (pos2) {
2887     /* There is a device name. "dev_name:" becomes "/dev_name/" */
2888     *(retpos++) = '/';
2889     disp = pos2 - pos1;
2890     strncpy (retpos, pos1, disp);
2891     retpos = retpos + disp;
2892     pos1 = pos2 + 1;
2893     *(retpos++) = '/';
2894   }
2895   else
2896     /* No explicit device; we must look ahead and prepend /sys$disk/ if
2897        the path is absolute */
2898     if ((*pos1 == '[' || *pos1 == '<') && (pos1 < srcendpos)
2899         && !strchr (".-]>", *(pos1 + 1))) {
2900       strncpy (retpos, "/sys$disk/", 10);
2901       retpos += 10;
2902     }
2903
2904   /* Process the path part */
2905   while (*pos1 == '[' || *pos1 == '<') {
2906     path_present++;
2907     pos1++;
2908     if (*pos1 == ']' || *pos1 == '>') {
2909       /* Special case, [] translates to '.' */
2910       *(retpos++) = '.';
2911       pos1++;
2912     }
2913     else {
2914       /* '[000000' means root dir. It can be present in the middle of
2915          the path due to expansion of logical devices, in which case
2916          we skip it */
2917       if (!strncmp (pos1, "000000", 6) && path_present > 1 &&
2918          (*(pos1 + 6) == ']' || *(pos1 + 6) == '>' || *(pos1 + 6) == '.')) {
2919           pos1 += 6;
2920           if (*pos1 == '.') pos1++;
2921         }
2922       else if (*pos1 == '.') {
2923         /* Relative path */
2924         *(retpos++) = '.';
2925       }
2926
2927       /* There is a qualified path */
2928       while (*pos1 && *pos1 != ']' && *pos1 != '>') {
2929         switch (*pos1) {
2930           case '.':
2931             /* '.' is used to separate directories. Replace it with '/' but
2932                only if there isn't already '/' just before */
2933             if (*(retpos - 1) != '/') *(retpos++) = '/';
2934             pos1++;
2935             if (pos1 + 1 < srcendpos && *pos1 == '.' && *(pos1 + 1) == '.') {
2936               /* ellipsis refers to entire subtree; replace with '**' */
2937               *(retpos++) = '*'; *(retpos++) = '*'; *(retpos++) = '/';
2938               pos1 += 2;
2939             }
2940             break;
2941           case '-' :
2942             /* When after '.' '[' '<' is equivalent to Unix ".." but there
2943             may be several in a row */
2944             if (*(pos1 - 1) == '.' || *(pos1 - 1) == '[' ||
2945                 *(pos1 - 1) == '<') {
2946               while (*pos1 == '-') {
2947                 pos1++;
2948                 *(retpos++) = '.'; *(retpos++) = '.'; *(retpos++) = '/';
2949               }
2950               retpos--;
2951               break;
2952             }
2953             /* otherwise fall through to default */
2954           default:
2955             *(retpos++) = *(pos1++);
2956         }
2957       }
2958       pos1++;
2959     }
2960   }
2961
2962   if (pos1 < srcendpos) {
2963     /* Now add the actual file name, until the version suffix if any */
2964     if (path_present) *(retpos++) = '/';
2965     pos2 = strchr (pos1, ';');
2966     disp = pos2? (pos2 - pos1) : (srcendpos - pos1);
2967     strncpy (retpos, pos1, disp);
2968     retpos += disp;
2969     if (pos2 && pos2 < srcendpos) {
2970       /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
2971       *retpos++ = '.';
2972       disp = srcendpos - pos2 - 1;
2973       strncpy (retpos, pos2 + 1, disp);
2974       retpos += disp;
2975     }
2976   }
2977
2978   *retpos = '\0';
2979
2980   return retbuf;
2981
2982 }
2983
2984 /* Translate a VMS syntax directory specification in to Unix syntax.  If
2985    PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2986    found, return input string. Also translate a dirname that contains no
2987    slashes, in case it's a logical name.  */
2988
2989 char *
2990 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag)
2991 {
2992   int len;
2993
2994   strcpy (new_canonical_dirspec, "");
2995   if (strlen (dirspec))
2996     {
2997       char *dirspec1;
2998
2999       if (strchr (dirspec, ']') || strchr (dirspec, ':'))
3000         {
3001           strncpy (new_canonical_dirspec,
3002                    __gnat_translate_vms (dirspec),
3003                    MAXPATH);
3004         }
3005       else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
3006         {
3007           strncpy (new_canonical_dirspec,
3008                   __gnat_translate_vms (dirspec1),
3009                   MAXPATH);
3010         }
3011       else
3012         {
3013           strncpy (new_canonical_dirspec, dirspec, MAXPATH);
3014         }
3015     }
3016
3017   len = strlen (new_canonical_dirspec);
3018   if (prefixflag && new_canonical_dirspec [len-1] != '/')
3019     strncat (new_canonical_dirspec, "/", MAXPATH);
3020
3021   new_canonical_dirspec [MAXPATH - 1] = (char) 0;
3022
3023   return new_canonical_dirspec;
3024
3025 }
3026
3027 /* Translate a VMS syntax file specification into Unix syntax.
3028    If no indicators of VMS syntax found, check if it's an uppercase
3029    alphanumeric_ name and if so try it out as an environment
3030    variable (logical name). If all else fails return the
3031    input string.  */
3032
3033 char *
3034 __gnat_to_canonical_file_spec (char *filespec)
3035 {
3036   char *filespec1;
3037
3038   strncpy (new_canonical_filespec, "", MAXPATH);
3039
3040   if (strchr (filespec, ']') || strchr (filespec, ':'))
3041     {
3042       char *tspec = (char *) __gnat_translate_vms (filespec);
3043
3044       if (tspec != (char *) -1)
3045         strncpy (new_canonical_filespec, tspec, MAXPATH);
3046     }
3047   else if ((strlen (filespec) == strspn (filespec,
3048             "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
3049         && (filespec1 = getenv (filespec)))
3050     {
3051       char *tspec = (char *) __gnat_translate_vms (filespec1);
3052
3053       if (tspec != (char *) -1)
3054         strncpy (new_canonical_filespec, tspec, MAXPATH);
3055     }
3056   else
3057     {
3058       strncpy (new_canonical_filespec, filespec, MAXPATH);
3059     }
3060
3061   new_canonical_filespec [MAXPATH - 1] = (char) 0;
3062
3063   return new_canonical_filespec;
3064 }
3065
3066 /* Translate a VMS syntax path specification into Unix syntax.
3067    If no indicators of VMS syntax found, return input string.  */
3068
3069 char *
3070 __gnat_to_canonical_path_spec (char *pathspec)
3071 {
3072   char *curr, *next, buff [MAXPATH];
3073
3074   if (pathspec == 0)
3075     return pathspec;
3076
3077   /* If there are /'s, assume it's a Unix path spec and return.  */
3078   if (strchr (pathspec, '/'))
3079     return pathspec;
3080
3081   new_canonical_pathspec[0] = 0;
3082   curr = pathspec;
3083
3084   for (;;)
3085     {
3086       next = strchr (curr, ',');
3087       if (next == 0)
3088         next = strchr (curr, 0);
3089
3090       strncpy (buff, curr, next - curr);
3091       buff[next - curr] = 0;
3092
3093       /* Check for wildcards and expand if present.  */
3094       if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
3095         {
3096           int i, dirs;
3097
3098           dirs = __gnat_to_canonical_file_list_init (buff, 1);
3099           for (i = 0; i < dirs; i++)
3100             {
3101               char *next_dir;
3102
3103               next_dir = __gnat_to_canonical_file_list_next ();
3104               strncat (new_canonical_pathspec, next_dir, MAXPATH);
3105
3106               /* Don't append the separator after the last expansion.  */
3107               if (i+1 < dirs)
3108                 strncat (new_canonical_pathspec, ":", MAXPATH);
3109             }
3110
3111           __gnat_to_canonical_file_list_free ();
3112         }
3113       else
3114         strncat (new_canonical_pathspec,
3115                 __gnat_to_canonical_dir_spec (buff, 0), MAXPATH);
3116
3117       if (*next == 0)
3118         break;
3119
3120       strncat (new_canonical_pathspec, ":", MAXPATH);
3121       curr = next + 1;
3122     }
3123
3124   new_canonical_pathspec [MAXPATH - 1] = (char) 0;
3125
3126   return new_canonical_pathspec;
3127 }
3128
3129 static char filename_buff [MAXPATH];
3130
3131 static int
3132 translate_unix (char *name, int type)
3133 {
3134   strncpy (filename_buff, name, MAXPATH);
3135   filename_buff [MAXPATH - 1] = (char) 0;
3136   return 0;
3137 }
3138
3139 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
3140    directories.  */
3141
3142 static char *
3143 to_host_path_spec (char *pathspec)
3144 {
3145   char *curr, *next, buff [MAXPATH];
3146
3147   if (pathspec == 0)
3148     return pathspec;
3149
3150   /* Can't very well test for colons, since that's the Unix separator!  */
3151   if (strchr (pathspec, ']') || strchr (pathspec, ','))
3152     return pathspec;
3153
3154   new_host_pathspec[0] = 0;
3155   curr = pathspec;
3156
3157   for (;;)
3158     {
3159       next = strchr (curr, ':');
3160       if (next == 0)
3161         next = strchr (curr, 0);
3162
3163       strncpy (buff, curr, next - curr);
3164       buff[next - curr] = 0;
3165
3166       strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH);
3167       if (*next == 0)
3168         break;
3169       strncat (new_host_pathspec, ",", MAXPATH);
3170       curr = next + 1;
3171     }
3172
3173   new_host_pathspec [MAXPATH - 1] = (char) 0;
3174
3175   return new_host_pathspec;
3176 }
3177
3178 /* Translate a Unix syntax directory specification into VMS syntax.  The
3179    PREFIXFLAG has no effect, but is kept for symmetry with
3180    to_canonical_dir_spec.  If indicators of VMS syntax found, return input
3181    string. */
3182
3183 char *
3184 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3185 {
3186   int len = strlen (dirspec);
3187
3188   strncpy (new_host_dirspec, dirspec, MAXPATH);
3189   new_host_dirspec [MAXPATH - 1] = (char) 0;
3190
3191   if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
3192     return new_host_dirspec;
3193
3194   while (len > 1 && new_host_dirspec[len - 1] == '/')
3195     {
3196       new_host_dirspec[len - 1] = 0;
3197       len--;
3198     }
3199
3200   decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
3201   strncpy (new_host_dirspec, filename_buff, MAXPATH);
3202   new_host_dirspec [MAXPATH - 1] = (char) 0;
3203
3204   return new_host_dirspec;
3205 }
3206
3207 /* Translate a Unix syntax file specification into VMS syntax.
3208    If indicators of VMS syntax found, return input string.  */
3209
3210 char *
3211 __gnat_to_host_file_spec (char *filespec)
3212 {
3213   strncpy (new_host_filespec, "", MAXPATH);
3214   if (strchr (filespec, ']') || strchr (filespec, ':'))
3215     {
3216       strncpy (new_host_filespec, filespec, MAXPATH);
3217     }
3218   else
3219     {
3220       decc$to_vms (filespec, translate_unix, 1, 1);
3221       strncpy (new_host_filespec, filename_buff, MAXPATH);
3222     }
3223
3224   new_host_filespec [MAXPATH - 1] = (char) 0;
3225
3226   return new_host_filespec;
3227 }
3228
3229 void
3230 __gnat_adjust_os_resource_limits ()
3231 {
3232   SYS$ADJWSL (131072, 0);
3233 }
3234
3235 #else /* VMS */
3236
3237 /* Dummy functions for Osint import for non-VMS systems.  */
3238
3239 int
3240 __gnat_to_canonical_file_list_init
3241   (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED)
3242 {
3243   return 0;
3244 }
3245
3246 char *
3247 __gnat_to_canonical_file_list_next (void)
3248 {
3249   static char *empty = "";
3250   return empty;
3251 }
3252
3253 void
3254 __gnat_to_canonical_file_list_free (void)
3255 {
3256 }
3257
3258 char *
3259 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3260 {
3261   return dirspec;
3262 }
3263
3264 char *
3265 __gnat_to_canonical_file_spec (char *filespec)
3266 {
3267   return filespec;
3268 }
3269
3270 char *
3271 __gnat_to_canonical_path_spec (char *pathspec)
3272 {
3273   return pathspec;
3274 }
3275
3276 char *
3277 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3278 {
3279   return dirspec;
3280 }
3281
3282 char *
3283 __gnat_to_host_file_spec (char *filespec)
3284 {
3285   return filespec;
3286 }
3287
3288 void
3289 __gnat_adjust_os_resource_limits (void)
3290 {
3291 }
3292
3293 #endif
3294
3295 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
3296    to coordinate this with the EMX distribution. Consequently, we put the
3297    definition of dummy which is used for exception handling, here.  */
3298
3299 #if defined (__EMX__)
3300 void __dummy () {}
3301 #endif
3302
3303 #if defined (__mips_vxworks)
3304 int
3305 _flush_cache()
3306 {
3307    CACHE_USER_FLUSH (0, ENTIRE_CACHE);
3308 }
3309 #endif
3310
3311 #if defined (IS_CROSS)  \
3312   || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3313       && defined (__SVR4)) \
3314       && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3315       && ! (defined (linux) && defined (__ia64__)) \
3316       && ! (defined (linux) && defined (powerpc)) \
3317       && ! defined (__FreeBSD__) \
3318       && ! defined (__Lynx__) \
3319       && ! defined (__hpux__) \
3320       && ! defined (__APPLE__) \
3321       && ! defined (_AIX) \
3322       && ! (defined (__alpha__)  && defined (__osf__)) \
3323       && ! defined (VMS) \
3324       && ! defined (__MINGW32__) \
3325       && ! (defined (__mips) && defined (__sgi)))
3326
3327 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3328    just above for a list of native platforms that provide a non-dummy
3329    version of this procedure in libaddr2line.a.  */
3330
3331 void
3332 convert_addresses (const char *file_name ATTRIBUTE_UNUSED,
3333                    void *addrs ATTRIBUTE_UNUSED,
3334                    int n_addr ATTRIBUTE_UNUSED,
3335                    void *buf ATTRIBUTE_UNUSED,
3336                    int *len ATTRIBUTE_UNUSED)
3337 {
3338   *len = 0;
3339 }
3340 #endif
3341
3342 #if defined (_WIN32)
3343 int __gnat_argument_needs_quote = 1;
3344 #else
3345 int __gnat_argument_needs_quote = 0;
3346 #endif
3347
3348 /* This option is used to enable/disable object files handling from the
3349    binder file by the GNAT Project module. For example, this is disabled on
3350    Windows (prior to GCC 3.4) as it is already done by the mdll module.
3351    Stating with GCC 3.4 the shared libraries are not based on mdll
3352    anymore as it uses the GCC's -shared option  */
3353 #if defined (_WIN32) \
3354     && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3355 int __gnat_prj_add_obj_files = 0;
3356 #else
3357 int __gnat_prj_add_obj_files = 1;
3358 #endif
3359
3360 /* char used as prefix/suffix for environment variables */
3361 #if defined (_WIN32)
3362 char __gnat_environment_char = '%';
3363 #else
3364 char __gnat_environment_char = '$';
3365 #endif
3366
3367 /* This functions copy the file attributes from a source file to a
3368    destination file.
3369
3370    mode = 0  : In this mode copy only the file time stamps (last access and
3371                last modification time stamps).
3372
3373    mode = 1  : In this mode, time stamps and read/write/execute attributes are
3374                copied.
3375
3376    Returns 0 if operation was successful and -1 in case of error. */
3377
3378 int
3379 __gnat_copy_attribs (char *from, char *to, int mode)
3380 {
3381 #if defined (VMS) || defined (__vxworks) || defined (__nucleus__)
3382   return -1;
3383
3384 #elif defined (_WIN32) && !defined (RTX)
3385   TCHAR wfrom [GNAT_MAX_PATH_LEN + 2];
3386   TCHAR wto [GNAT_MAX_PATH_LEN + 2];
3387   BOOL res;
3388   FILETIME fct, flat, flwt;
3389   HANDLE hfrom, hto;
3390
3391   S2WSC (wfrom, from, GNAT_MAX_PATH_LEN + 2);
3392   S2WSC (wto, to, GNAT_MAX_PATH_LEN + 2);
3393
3394   /* retrieve from times */
3395
3396   hfrom = CreateFile
3397     (wfrom, GENERIC_READ, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
3398
3399   if (hfrom == INVALID_HANDLE_VALUE)
3400     return -1;
3401
3402   res = GetFileTime (hfrom, &fct, &flat, &flwt);
3403
3404   CloseHandle (hfrom);
3405
3406   if (res == 0)
3407     return -1;
3408
3409   /* retrieve from times */
3410
3411   hto = CreateFile
3412     (wto, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
3413
3414   if (hto == INVALID_HANDLE_VALUE)
3415     return -1;
3416
3417   res = SetFileTime (hto, NULL, &flat, &flwt);
3418
3419   CloseHandle (hto);
3420
3421   if (res == 0)
3422     return -1;
3423
3424   /* Set file attributes in full mode. */
3425
3426   if (mode == 1)
3427     {
3428       DWORD attribs = GetFileAttributes (wfrom);
3429
3430       if (attribs == INVALID_FILE_ATTRIBUTES)
3431         return -1;
3432
3433       res = SetFileAttributes (wto, attribs);
3434       if (res == 0)
3435         return -1;
3436     }
3437
3438   return 0;
3439
3440 #else
3441   GNAT_STRUCT_STAT fbuf;
3442   struct utimbuf tbuf;
3443
3444   if (GNAT_STAT (from, &fbuf) == -1)
3445     {
3446       return -1;
3447     }
3448
3449   tbuf.actime = fbuf.st_atime;
3450   tbuf.modtime = fbuf.st_mtime;
3451
3452   if (utime (to, &tbuf) == -1)
3453     {
3454       return -1;
3455     }
3456
3457   if (mode == 1)
3458     {
3459       if (chmod (to, fbuf.st_mode) == -1)
3460         {
3461           return -1;
3462         }
3463     }
3464
3465   return 0;
3466 #endif
3467 }
3468
3469 int
3470 __gnat_lseek (int fd, long offset, int whence)
3471 {
3472   return (int) lseek (fd, offset, whence);
3473 }
3474
3475 /* This function returns the major version number of GCC being used.  */
3476 int
3477 get_gcc_version (void)
3478 {
3479 #ifdef IN_RTS
3480   return __GNUC__;
3481 #else
3482   return (int) (version_string[0] - '0');
3483 #endif
3484 }
3485
3486 int
3487 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED,
3488                           int close_on_exec_p ATTRIBUTE_UNUSED)
3489 {
3490 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3491   int flags = fcntl (fd, F_GETFD, 0);
3492   if (flags < 0)
3493     return flags;
3494   if (close_on_exec_p)
3495     flags |= FD_CLOEXEC;
3496   else
3497     flags &= ~FD_CLOEXEC;
3498   return fcntl (fd, F_SETFD, flags | FD_CLOEXEC);
3499 #elif defined(_WIN32)
3500   HANDLE h = (HANDLE) _get_osfhandle (fd);
3501   if (h == (HANDLE) -1)
3502     return -1;
3503   if (close_on_exec_p)
3504     return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT, 0);
3505   return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT,
3506     HANDLE_FLAG_INHERIT);
3507 #else
3508   /* TODO: Unimplemented. */
3509   return -1;
3510 #endif
3511 }
3512
3513 /* Indicates if platforms supports automatic initialization through the
3514    constructor mechanism */
3515 int
3516 __gnat_binder_supports_auto_init (void)
3517 {
3518 #ifdef VMS
3519    return 0;
3520 #else
3521    return 1;
3522 #endif
3523 }
3524
3525 /* Indicates that Stand-Alone Libraries are automatically initialized through
3526    the constructor mechanism */
3527 int
3528 __gnat_sals_init_using_constructors (void)
3529 {
3530 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3531    return 0;
3532 #else
3533    return 1;
3534 #endif
3535 }
3536
3537 #ifdef RTX
3538
3539 /* In RTX mode, the procedure to get the time (as file time) is different
3540    in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3541    we introduce an intermediate procedure to link against the corresponding
3542    one in each situation. */
3543
3544 extern void GetTimeAsFileTime(LPFILETIME pTime);
3545
3546 void GetTimeAsFileTime(LPFILETIME pTime)
3547 {
3548 #ifdef RTSS
3549   RtGetRtssTimeAsFileTime (pTime); /* RTSS interface */
3550 #else
3551   GetSystemTimeAsFileTime (pTime); /* w32 interface */
3552 #endif
3553 }
3554
3555 #ifdef RTSS
3556 /* Add symbol that is required to link. It would otherwise be taken from
3557    libgcc.a and it would try to use the gcc constructors that are not
3558    supported by Microsoft linker. */
3559
3560 extern void __main (void);
3561
3562 void __main (void) {}
3563 #endif
3564 #endif
3565
3566 #if defined (linux) || defined(__GLIBC__)
3567 /* pthread affinity support */
3568
3569 int __gnat_pthread_setaffinity_np (pthread_t th,
3570                                    size_t cpusetsize,
3571                                    const void *cpuset);
3572
3573 #ifdef CPU_SETSIZE
3574 #include <pthread.h>
3575 int
3576 __gnat_pthread_setaffinity_np (pthread_t th,
3577                                size_t cpusetsize,
3578                                const cpu_set_t *cpuset)
3579 {
3580   return pthread_setaffinity_np (th, cpusetsize, cpuset);
3581 }
3582 #else
3583 int
3584 __gnat_pthread_setaffinity_np (pthread_t th ATTRIBUTE_UNUSED,
3585                                size_t cpusetsize ATTRIBUTE_UNUSED,
3586                                const void *cpuset ATTRIBUTE_UNUSED)
3587 {
3588   return 0;
3589 }
3590 #endif
3591 #endif
3592
3593 #if defined (linux)
3594 /* There is no function in the glibc to retrieve the LWP of the current
3595    thread. We need to do a system call in order to retrieve this
3596    information. */
3597 #include <sys/syscall.h>
3598 void *__gnat_lwp_self (void)
3599 {
3600    return (void *) syscall (__NR_gettid);
3601 }
3602 #endif