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