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