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