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