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 static CRITICAL_SECTION plist_cs;
2105
2106 void
2107 __gnat_plist_init (void)
2108 {
2109   InitializeCriticalSection (&plist_cs);
2110 }
2111
2112 static void
2113 plist_enter (void)
2114 {
2115   EnterCriticalSection (&plist_cs);
2116 }
2117
2118 static void
2119 plist_leave (void)
2120 {
2121   LeaveCriticalSection (&plist_cs);
2122 }
2123
2124 typedef struct _process_list
2125 {
2126   HANDLE h;
2127   struct _process_list *next;
2128 } Process_List;
2129
2130 static Process_List *PLIST = NULL;
2131
2132 static int plist_length = 0;
2133
2134 static void
2135 add_handle (HANDLE h)
2136 {
2137   Process_List *pl;
2138
2139   pl = (Process_List *) xmalloc (sizeof (Process_List));
2140
2141   plist_enter();
2142
2143   /* -------------------- critical section -------------------- */
2144   pl->h = h;
2145   pl->next = PLIST;
2146   PLIST = pl;
2147   ++plist_length;
2148   /* -------------------- critical section -------------------- */
2149
2150   plist_leave();
2151 }
2152
2153 static void
2154 remove_handle (HANDLE h)
2155 {
2156   Process_List *pl;
2157   Process_List *prev = NULL;
2158
2159   plist_enter();
2160
2161   /* -------------------- critical section -------------------- */
2162   pl = PLIST;
2163   while (pl)
2164     {
2165       if (pl->h == h)
2166         {
2167           if (pl == PLIST)
2168             PLIST = pl->next;
2169           else
2170             prev->next = pl->next;
2171           free (pl);
2172           break;
2173         }
2174       else
2175         {
2176           prev = pl;
2177           pl = pl->next;
2178         }
2179     }
2180
2181   --plist_length;
2182   /* -------------------- critical section -------------------- */
2183
2184   plist_leave();
2185 }
2186
2187 static int
2188 win32_no_block_spawn (char *command, char *args[])
2189 {
2190   BOOL result;
2191   STARTUPINFO SI;
2192   PROCESS_INFORMATION PI;
2193   SECURITY_ATTRIBUTES SA;
2194   int csize = 1;
2195   char *full_command;
2196   int k;
2197
2198   /* compute the total command line length */
2199   k = 0;
2200   while (args[k])
2201     {
2202       csize += strlen (args[k]) + 1;
2203       k++;
2204     }
2205
2206   full_command = (char *) xmalloc (csize);
2207
2208   /* Startup info. */
2209   SI.cb          = sizeof (STARTUPINFO);
2210   SI.lpReserved  = NULL;
2211   SI.lpReserved2 = NULL;
2212   SI.lpDesktop   = NULL;
2213   SI.cbReserved2 = 0;
2214   SI.lpTitle     = NULL;
2215   SI.dwFlags     = 0;
2216   SI.wShowWindow = SW_HIDE;
2217
2218   /* Security attributes. */
2219   SA.nLength = sizeof (SECURITY_ATTRIBUTES);
2220   SA.bInheritHandle = TRUE;
2221   SA.lpSecurityDescriptor = NULL;
2222
2223   /* Prepare the command string. */
2224   strcpy (full_command, command);
2225   strcat (full_command, " ");
2226
2227   k = 1;
2228   while (args[k])
2229     {
2230       strcat (full_command, args[k]);
2231       strcat (full_command, " ");
2232       k++;
2233     }
2234
2235   {
2236     int wsize = csize * 2;
2237     TCHAR *wcommand = (TCHAR *) xmalloc (wsize);
2238
2239     S2WSU (wcommand, full_command, wsize);
2240
2241     free (full_command);
2242
2243     result = CreateProcess
2244       (NULL, wcommand, &SA, NULL, TRUE,
2245        GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
2246
2247     free (wcommand);
2248   }
2249
2250   if (result == TRUE)
2251     {
2252       add_handle (PI.hProcess);
2253       CloseHandle (PI.hThread);
2254       return (int) PI.hProcess;
2255     }
2256   else
2257     return -1;
2258 }
2259
2260 static int
2261 win32_wait (int *status)
2262 {
2263   DWORD exitcode;
2264   HANDLE *hl;
2265   HANDLE h;
2266   DWORD res;
2267   int k;
2268   Process_List *pl;
2269
2270   if (plist_length == 0)
2271     {
2272       errno = ECHILD;
2273       return -1;
2274     }
2275
2276   hl = (HANDLE *) xmalloc (sizeof (HANDLE) * plist_length);
2277
2278   k = 0;
2279   plist_enter();
2280
2281   /* -------------------- critical section -------------------- */
2282   pl = PLIST;
2283   while (pl)
2284     {
2285       hl[k++] = pl->h;
2286       pl = pl->next;
2287     }
2288   /* -------------------- critical section -------------------- */
2289
2290   plist_leave();
2291
2292   res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE);
2293   h = hl[res - WAIT_OBJECT_0];
2294   free (hl);
2295
2296   remove_handle (h);
2297
2298   GetExitCodeProcess (h, &exitcode);
2299   CloseHandle (h);
2300
2301   *status = (int) exitcode;
2302   return (int) h;
2303 }
2304
2305 #endif
2306
2307 int
2308 __gnat_portable_no_block_spawn (char *args[])
2309 {
2310   int pid = 0;
2311
2312 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2313   return -1;
2314
2315 #elif defined (__EMX__) || defined (MSDOS)
2316
2317   /* ??? For PC machines I (Franco) don't know the system calls to implement
2318      this routine. So I'll fake it as follows. This routine will behave
2319      exactly like the blocking portable_spawn and will systematically return
2320      a pid of 0 unless the spawned task did not complete successfully, in
2321      which case we return a pid of -1.  To synchronize with this the
2322      portable_wait below systematically returns a pid of 0 and reports that
2323      the subprocess terminated successfully. */
2324
2325   if (spawnvp (P_WAIT, args[0], args) != 0)
2326     return -1;
2327
2328 #elif defined (_WIN32)
2329
2330   pid = win32_no_block_spawn (args[0], args);
2331   return pid;
2332
2333 #else
2334   pid = fork ();
2335
2336   if (pid == 0)
2337     {
2338       /* The child.  */
2339       if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
2340 #if defined (VMS)
2341         return -1; /* execv is in parent context on VMS. */
2342 #else
2343         _exit (1);
2344 #endif
2345     }
2346
2347 #endif
2348
2349   return pid;
2350 }
2351
2352 int
2353 __gnat_portable_wait (int *process_status)
2354 {
2355   int status = 0;
2356   int pid = 0;
2357
2358 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2359   /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
2360      return zero.  */
2361
2362 #elif defined (_WIN32)
2363
2364   pid = win32_wait (&status);
2365
2366 #elif defined (__EMX__) || defined (MSDOS)
2367   /* ??? See corresponding comment in portable_no_block_spawn.  */
2368
2369 #else
2370
2371   pid = waitpid (-1, &status, 0);
2372   status = status & 0xffff;
2373 #endif
2374
2375   *process_status = status;
2376   return pid;
2377 }
2378
2379 void
2380 __gnat_os_exit (int status)
2381 {
2382   exit (status);
2383 }
2384
2385 /* Locate a regular file, give a Path value.  */
2386
2387 char *
2388 __gnat_locate_regular_file (char *file_name, char *path_val)
2389 {
2390   char *ptr;
2391   char *file_path = (char *) alloca (strlen (file_name) + 1);
2392   int absolute;
2393
2394   /* Return immediately if file_name is empty */
2395
2396   if (*file_name == '\0')
2397     return 0;
2398
2399   /* Remove quotes around file_name if present */
2400
2401   ptr = file_name;
2402   if (*ptr == '"')
2403     ptr++;
2404
2405   strcpy (file_path, ptr);
2406
2407   ptr = file_path + strlen (file_path) - 1;
2408
2409   if (*ptr == '"')
2410     *ptr = '\0';
2411
2412   /* Handle absolute pathnames.  */
2413
2414   absolute = __gnat_is_absolute_path (file_path, strlen (file_name));
2415
2416   if (absolute)
2417     {
2418      if (__gnat_is_regular_file (file_path))
2419        return xstrdup (file_path);
2420
2421       return 0;
2422     }
2423
2424   /* If file_name include directory separator(s), try it first as
2425      a path name relative to the current directory */
2426   for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
2427     ;
2428
2429   if (*ptr != 0)
2430     {
2431       if (__gnat_is_regular_file (file_name))
2432         return xstrdup (file_name);
2433     }
2434
2435   if (path_val == 0)
2436     return 0;
2437
2438   {
2439     /* The result has to be smaller than path_val + file_name.  */
2440     char *file_path = (char *) alloca (strlen (path_val) + strlen (file_name) + 2);
2441
2442     for (;;)
2443       {
2444         for (; *path_val == PATH_SEPARATOR; path_val++)
2445           ;
2446
2447       if (*path_val == 0)
2448         return 0;
2449
2450       /* Skip the starting quote */
2451
2452       if (*path_val == '"')
2453         path_val++;
2454
2455       for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
2456         *ptr++ = *path_val++;
2457
2458       ptr--;
2459
2460       /* Skip the ending quote */
2461
2462       if (*ptr == '"')
2463         ptr--;
2464
2465       if (*ptr != '/' && *ptr != DIR_SEPARATOR)
2466         *++ptr = DIR_SEPARATOR;
2467
2468       strcpy (++ptr, file_name);
2469
2470       if (__gnat_is_regular_file (file_path))
2471         return xstrdup (file_path);
2472       }
2473   }
2474
2475   return 0;
2476 }
2477
2478 /* Locate an executable given a Path argument. This routine is only used by
2479    gnatbl and should not be used otherwise.  Use locate_exec_on_path
2480    instead.  */
2481
2482 char *
2483 __gnat_locate_exec (char *exec_name, char *path_val)
2484 {
2485   char *ptr;
2486   if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
2487     {
2488       char *full_exec_name
2489         = (char *) alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
2490
2491       strcpy (full_exec_name, exec_name);
2492       strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
2493       ptr = __gnat_locate_regular_file (full_exec_name, path_val);
2494
2495       if (ptr == 0)
2496          return __gnat_locate_regular_file (exec_name, path_val);
2497       return ptr;
2498     }
2499   else
2500     return __gnat_locate_regular_file (exec_name, path_val);
2501 }
2502
2503 /* Locate an executable using the Systems default PATH.  */
2504
2505 char *
2506 __gnat_locate_exec_on_path (char *exec_name)
2507 {
2508   char *apath_val;
2509
2510 #if defined (_WIN32) && !defined (RTX)
2511   TCHAR *wpath_val = _tgetenv (_T("PATH"));
2512   TCHAR *wapath_val;
2513   /* In Win32 systems we expand the PATH as for XP environment
2514      variables are not automatically expanded. We also prepend the
2515      ".;" to the path to match normal NT path search semantics */
2516
2517   #define EXPAND_BUFFER_SIZE 32767
2518
2519   wapath_val = alloca (EXPAND_BUFFER_SIZE);
2520
2521   wapath_val [0] = '.';
2522   wapath_val [1] = ';';
2523
2524   DWORD res = ExpandEnvironmentStrings
2525     (wpath_val, &wapath_val[2], EXPAND_BUFFER_SIZE - 2);
2526
2527   if (!res) wapath_val [0] = _T('\0');
2528
2529   apath_val = alloca (EXPAND_BUFFER_SIZE);
2530
2531   WS2SU (apath_val, wapath_val, EXPAND_BUFFER_SIZE);
2532   return __gnat_locate_exec (exec_name, apath_val);
2533
2534 #else
2535
2536 #ifdef VMS
2537   char *path_val = "/VAXC$PATH";
2538 #else
2539   char *path_val = getenv ("PATH");
2540 #endif
2541   if (path_val == NULL) return NULL;
2542   apath_val = (char *) alloca (strlen (path_val) + 1);
2543   strcpy (apath_val, path_val);
2544   return __gnat_locate_exec (exec_name, apath_val);
2545 #endif
2546 }
2547
2548 #ifdef VMS
2549
2550 /* These functions are used to translate to and from VMS and Unix syntax
2551    file, directory and path specifications.  */
2552
2553 #define MAXPATH  256
2554 #define MAXNAMES 256
2555 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2556
2557 static char new_canonical_dirspec [MAXPATH];
2558 static char new_canonical_filespec [MAXPATH];
2559 static char new_canonical_pathspec [MAXNAMES*MAXPATH];
2560 static unsigned new_canonical_filelist_index;
2561 static unsigned new_canonical_filelist_in_use;
2562 static unsigned new_canonical_filelist_allocated;
2563 static char **new_canonical_filelist;
2564 static char new_host_pathspec [MAXNAMES*MAXPATH];
2565 static char new_host_dirspec [MAXPATH];
2566 static char new_host_filespec [MAXPATH];
2567
2568 /* Routine is called repeatedly by decc$from_vms via
2569    __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2570    runs out. */
2571
2572 static int
2573 wildcard_translate_unix (char *name)
2574 {
2575   char *ver;
2576   char buff [MAXPATH];
2577
2578   strncpy (buff, name, MAXPATH);
2579   buff [MAXPATH - 1] = (char) 0;
2580   ver = strrchr (buff, '.');
2581
2582   /* Chop off the version.  */
2583   if (ver)
2584     *ver = 0;
2585
2586   /* Dynamically extend the allocation by the increment.  */
2587   if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
2588     {
2589       new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
2590       new_canonical_filelist = (char **) xrealloc
2591         (new_canonical_filelist,
2592          new_canonical_filelist_allocated * sizeof (char *));
2593     }
2594
2595   new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
2596
2597   return 1;
2598 }
2599
2600 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2601    full translation and copy the results into a list (_init), then return them
2602    one at a time (_next). If onlydirs set, only expand directory files.  */
2603
2604 int
2605 __gnat_to_canonical_file_list_init (char *filespec, int onlydirs)
2606 {
2607   int len;
2608   char buff [MAXPATH];
2609
2610   len = strlen (filespec);
2611   strncpy (buff, filespec, MAXPATH);
2612
2613   /* Only look for directories */
2614   if (onlydirs && !strstr (&buff [len-5], "*.dir"))
2615     strncat (buff, "*.dir", MAXPATH);
2616
2617   buff [MAXPATH - 1] = (char) 0;
2618
2619   decc$from_vms (buff, wildcard_translate_unix, 1);
2620
2621   /* Remove the .dir extension.  */
2622   if (onlydirs)
2623     {
2624       int i;
2625       char *ext;
2626
2627       for (i = 0; i < new_canonical_filelist_in_use; i++)
2628         {
2629           ext = strstr (new_canonical_filelist[i], ".dir");
2630           if (ext)
2631             *ext = 0;
2632         }
2633     }
2634
2635   return new_canonical_filelist_in_use;
2636 }
2637
2638 /* Return the next filespec in the list.  */
2639
2640 char *
2641 __gnat_to_canonical_file_list_next ()
2642 {
2643   return new_canonical_filelist[new_canonical_filelist_index++];
2644 }
2645
2646 /* Free storage used in the wildcard expansion.  */
2647
2648 void
2649 __gnat_to_canonical_file_list_free ()
2650 {
2651   int i;
2652
2653    for (i = 0; i < new_canonical_filelist_in_use; i++)
2654      free (new_canonical_filelist[i]);
2655
2656   free (new_canonical_filelist);
2657
2658   new_canonical_filelist_in_use = 0;
2659   new_canonical_filelist_allocated = 0;
2660   new_canonical_filelist_index = 0;
2661   new_canonical_filelist = 0;
2662 }
2663
2664 /* The functional equivalent of decc$translate_vms routine.
2665    Designed to produce the same output, but is protected against
2666    malformed paths (original version ACCVIOs in this case) and
2667    does not require VMS-specific DECC RTL */
2668
2669 #define NAM$C_MAXRSS 1024
2670
2671 char *
2672 __gnat_translate_vms (char *src)
2673 {
2674   static char retbuf [NAM$C_MAXRSS+1];
2675   char *srcendpos, *pos1, *pos2, *retpos;
2676   int disp, path_present = 0;
2677
2678   if (!src) return NULL;
2679
2680   srcendpos = strchr (src, '\0');
2681   retpos = retbuf;
2682
2683   /* Look for the node and/or device in front of the path */
2684   pos1 = src;
2685   pos2 = strchr (pos1, ':');
2686
2687   if (pos2 && (pos2 < srcendpos) && (*(pos2 + 1) == ':')) {
2688     /* There is a node name. "node_name::" becomes "node_name!" */
2689     disp = pos2 - pos1;
2690     strncpy (retbuf, pos1, disp);
2691     retpos [disp] = '!';
2692     retpos = retpos + disp + 1;
2693     pos1 = pos2 + 2;
2694     pos2 = strchr (pos1, ':');
2695   }
2696
2697   if (pos2) {
2698     /* There is a device name. "dev_name:" becomes "/dev_name/" */
2699     *(retpos++) = '/';
2700     disp = pos2 - pos1;
2701     strncpy (retpos, pos1, disp);
2702     retpos = retpos + disp;
2703     pos1 = pos2 + 1;
2704     *(retpos++) = '/';
2705   }
2706   else
2707     /* No explicit device; we must look ahead and prepend /sys$disk/ if
2708        the path is absolute */
2709     if ((*pos1 == '[' || *pos1 == '<') && (pos1 < srcendpos)
2710         && !strchr (".-]>", *(pos1 + 1))) {
2711       strncpy (retpos, "/sys$disk/", 10);
2712       retpos += 10;
2713     }
2714
2715   /* Process the path part */
2716   while (*pos1 == '[' || *pos1 == '<') {
2717     path_present++;
2718     pos1++;
2719     if (*pos1 == ']' || *pos1 == '>') {
2720       /* Special case, [] translates to '.' */
2721       *(retpos++) = '.';
2722       pos1++;
2723     }
2724     else {
2725       /* '[000000' means root dir. It can be present in the middle of
2726          the path due to expansion of logical devices, in which case
2727          we skip it */
2728       if (!strncmp (pos1, "000000", 6) && path_present > 1 &&
2729          (*(pos1 + 6) == ']' || *(pos1 + 6) == '>' || *(pos1 + 6) == '.')) {
2730           pos1 += 6;
2731           if (*pos1 == '.') pos1++;
2732         }
2733       else if (*pos1 == '.') {
2734         /* Relative path */
2735         *(retpos++) = '.';
2736       }
2737
2738       /* There is a qualified path */
2739       while (*pos1 && *pos1 != ']' && *pos1 != '>') {
2740         switch (*pos1) {
2741           case '.':
2742             /* '.' is used to separate directories. Replace it with '/' but
2743                only if there isn't already '/' just before */
2744             if (*(retpos - 1) != '/') *(retpos++) = '/';
2745             pos1++;
2746             if (pos1 + 1 < srcendpos && *pos1 == '.' && *(pos1 + 1) == '.') {
2747               /* ellipsis refers to entire subtree; replace with '**' */
2748               *(retpos++) = '*'; *(retpos++) = '*'; *(retpos++) = '/';
2749               pos1 += 2;
2750             }
2751             break;
2752           case '-' :
2753             /* When after '.' '[' '<' is equivalent to Unix ".." but there
2754             may be several in a row */
2755             if (*(pos1 - 1) == '.' || *(pos1 - 1) == '[' ||
2756                 *(pos1 - 1) == '<') {
2757               while (*pos1 == '-') {
2758                 pos1++;
2759                 *(retpos++) = '.'; *(retpos++) = '.'; *(retpos++) = '/';
2760               }
2761               retpos--;
2762               break;
2763             }
2764             /* otherwise fall through to default */
2765           default:
2766             *(retpos++) = *(pos1++);
2767         }
2768       }
2769       pos1++;
2770     }
2771   }
2772
2773   if (pos1 < srcendpos) {
2774     /* Now add the actual file name, until the version suffix if any */
2775     if (path_present) *(retpos++) = '/';
2776     pos2 = strchr (pos1, ';');
2777     disp = pos2? (pos2 - pos1) : (srcendpos - pos1);
2778     strncpy (retpos, pos1, disp);
2779     retpos += disp;
2780     if (pos2 && pos2 < srcendpos) {
2781       /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
2782       *retpos++ = '.';
2783       disp = srcendpos - pos2 - 1;
2784       strncpy (retpos, pos2 + 1, disp);
2785       retpos += disp;
2786     }
2787   }
2788
2789   *retpos = '\0';
2790
2791   return retbuf;
2792
2793 }
2794
2795 /* Translate a VMS syntax directory specification in to Unix syntax.  If
2796    PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2797    found, return input string. Also translate a dirname that contains no
2798    slashes, in case it's a logical name.  */
2799
2800 char *
2801 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag)
2802 {
2803   int len;
2804
2805   strcpy (new_canonical_dirspec, "");
2806   if (strlen (dirspec))
2807     {
2808       char *dirspec1;
2809
2810       if (strchr (dirspec, ']') || strchr (dirspec, ':'))
2811         {
2812           strncpy (new_canonical_dirspec,
2813                    __gnat_translate_vms (dirspec),
2814                    MAXPATH);
2815         }
2816       else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
2817         {
2818           strncpy (new_canonical_dirspec,
2819                   __gnat_translate_vms (dirspec1),
2820                   MAXPATH);
2821         }
2822       else
2823         {
2824           strncpy (new_canonical_dirspec, dirspec, MAXPATH);
2825         }
2826     }
2827
2828   len = strlen (new_canonical_dirspec);
2829   if (prefixflag && new_canonical_dirspec [len-1] != '/')
2830     strncat (new_canonical_dirspec, "/", MAXPATH);
2831
2832   new_canonical_dirspec [MAXPATH - 1] = (char) 0;
2833
2834   return new_canonical_dirspec;
2835
2836 }
2837
2838 /* Translate a VMS syntax file specification into Unix syntax.
2839    If no indicators of VMS syntax found, check if it's an uppercase
2840    alphanumeric_ name and if so try it out as an environment
2841    variable (logical name). If all else fails return the
2842    input string.  */
2843
2844 char *
2845 __gnat_to_canonical_file_spec (char *filespec)
2846 {
2847   char *filespec1;
2848
2849   strncpy (new_canonical_filespec, "", MAXPATH);
2850
2851   if (strchr (filespec, ']') || strchr (filespec, ':'))
2852     {
2853       char *tspec = (char *) __gnat_translate_vms (filespec);
2854
2855       if (tspec != (char *) -1)
2856         strncpy (new_canonical_filespec, tspec, MAXPATH);
2857     }
2858   else if ((strlen (filespec) == strspn (filespec,
2859             "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
2860         && (filespec1 = getenv (filespec)))
2861     {
2862       char *tspec = (char *) __gnat_translate_vms (filespec1);
2863
2864       if (tspec != (char *) -1)
2865         strncpy (new_canonical_filespec, tspec, MAXPATH);
2866     }
2867   else
2868     {
2869       strncpy (new_canonical_filespec, filespec, MAXPATH);
2870     }
2871
2872   new_canonical_filespec [MAXPATH - 1] = (char) 0;
2873
2874   return new_canonical_filespec;
2875 }
2876
2877 /* Translate a VMS syntax path specification into Unix syntax.
2878    If no indicators of VMS syntax found, return input string.  */
2879
2880 char *
2881 __gnat_to_canonical_path_spec (char *pathspec)
2882 {
2883   char *curr, *next, buff [MAXPATH];
2884
2885   if (pathspec == 0)
2886     return pathspec;
2887
2888   /* If there are /'s, assume it's a Unix path spec and return.  */
2889   if (strchr (pathspec, '/'))
2890     return pathspec;
2891
2892   new_canonical_pathspec[0] = 0;
2893   curr = pathspec;
2894
2895   for (;;)
2896     {
2897       next = strchr (curr, ',');
2898       if (next == 0)
2899         next = strchr (curr, 0);
2900
2901       strncpy (buff, curr, next - curr);
2902       buff[next - curr] = 0;
2903
2904       /* Check for wildcards and expand if present.  */
2905       if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
2906         {
2907           int i, dirs;
2908
2909           dirs = __gnat_to_canonical_file_list_init (buff, 1);
2910           for (i = 0; i < dirs; i++)
2911             {
2912               char *next_dir;
2913
2914               next_dir = __gnat_to_canonical_file_list_next ();
2915               strncat (new_canonical_pathspec, next_dir, MAXPATH);
2916
2917               /* Don't append the separator after the last expansion.  */
2918               if (i+1 < dirs)
2919                 strncat (new_canonical_pathspec, ":", MAXPATH);
2920             }
2921
2922           __gnat_to_canonical_file_list_free ();
2923         }
2924       else
2925         strncat (new_canonical_pathspec,
2926                 __gnat_to_canonical_dir_spec (buff, 0), MAXPATH);
2927
2928       if (*next == 0)
2929         break;
2930
2931       strncat (new_canonical_pathspec, ":", MAXPATH);
2932       curr = next + 1;
2933     }
2934
2935   new_canonical_pathspec [MAXPATH - 1] = (char) 0;
2936
2937   return new_canonical_pathspec;
2938 }
2939
2940 static char filename_buff [MAXPATH];
2941
2942 static int
2943 translate_unix (char *name, int type)
2944 {
2945   strncpy (filename_buff, name, MAXPATH);
2946   filename_buff [MAXPATH - 1] = (char) 0;
2947   return 0;
2948 }
2949
2950 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
2951    directories.  */
2952
2953 static char *
2954 to_host_path_spec (char *pathspec)
2955 {
2956   char *curr, *next, buff [MAXPATH];
2957
2958   if (pathspec == 0)
2959     return pathspec;
2960
2961   /* Can't very well test for colons, since that's the Unix separator!  */
2962   if (strchr (pathspec, ']') || strchr (pathspec, ','))
2963     return pathspec;
2964
2965   new_host_pathspec[0] = 0;
2966   curr = pathspec;
2967
2968   for (;;)
2969     {
2970       next = strchr (curr, ':');
2971       if (next == 0)
2972         next = strchr (curr, 0);
2973
2974       strncpy (buff, curr, next - curr);
2975       buff[next - curr] = 0;
2976
2977       strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH);
2978       if (*next == 0)
2979         break;
2980       strncat (new_host_pathspec, ",", MAXPATH);
2981       curr = next + 1;
2982     }
2983
2984   new_host_pathspec [MAXPATH - 1] = (char) 0;
2985
2986   return new_host_pathspec;
2987 }
2988
2989 /* Translate a Unix syntax directory specification into VMS syntax.  The
2990    PREFIXFLAG has no effect, but is kept for symmetry with
2991    to_canonical_dir_spec.  If indicators of VMS syntax found, return input
2992    string. */
2993
2994 char *
2995 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2996 {
2997   int len = strlen (dirspec);
2998
2999   strncpy (new_host_dirspec, dirspec, MAXPATH);
3000   new_host_dirspec [MAXPATH - 1] = (char) 0;
3001
3002   if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
3003     return new_host_dirspec;
3004
3005   while (len > 1 && new_host_dirspec[len - 1] == '/')
3006     {
3007       new_host_dirspec[len - 1] = 0;
3008       len--;
3009     }
3010
3011   decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
3012   strncpy (new_host_dirspec, filename_buff, MAXPATH);
3013   new_host_dirspec [MAXPATH - 1] = (char) 0;
3014
3015   return new_host_dirspec;
3016 }
3017
3018 /* Translate a Unix syntax file specification into VMS syntax.
3019    If indicators of VMS syntax found, return input string.  */
3020
3021 char *
3022 __gnat_to_host_file_spec (char *filespec)
3023 {
3024   strncpy (new_host_filespec, "", MAXPATH);
3025   if (strchr (filespec, ']') || strchr (filespec, ':'))
3026     {
3027       strncpy (new_host_filespec, filespec, MAXPATH);
3028     }
3029   else
3030     {
3031       decc$to_vms (filespec, translate_unix, 1, 1);
3032       strncpy (new_host_filespec, filename_buff, MAXPATH);
3033     }
3034
3035   new_host_filespec [MAXPATH - 1] = (char) 0;
3036
3037   return new_host_filespec;
3038 }
3039
3040 void
3041 __gnat_adjust_os_resource_limits ()
3042 {
3043   SYS$ADJWSL (131072, 0);
3044 }
3045
3046 #else /* VMS */
3047
3048 /* Dummy functions for Osint import for non-VMS systems.  */
3049
3050 int
3051 __gnat_to_canonical_file_list_init
3052   (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED)
3053 {
3054   return 0;
3055 }
3056
3057 char *
3058 __gnat_to_canonical_file_list_next (void)
3059 {
3060   return (char *) "";
3061 }
3062
3063 void
3064 __gnat_to_canonical_file_list_free (void)
3065 {
3066 }
3067
3068 char *
3069 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3070 {
3071   return dirspec;
3072 }
3073
3074 char *
3075 __gnat_to_canonical_file_spec (char *filespec)
3076 {
3077   return filespec;
3078 }
3079
3080 char *
3081 __gnat_to_canonical_path_spec (char *pathspec)
3082 {
3083   return pathspec;
3084 }
3085
3086 char *
3087 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3088 {
3089   return dirspec;
3090 }
3091
3092 char *
3093 __gnat_to_host_file_spec (char *filespec)
3094 {
3095   return filespec;
3096 }
3097
3098 void
3099 __gnat_adjust_os_resource_limits (void)
3100 {
3101 }
3102
3103 #endif
3104
3105 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
3106    to coordinate this with the EMX distribution. Consequently, we put the
3107    definition of dummy which is used for exception handling, here.  */
3108
3109 #if defined (__EMX__)
3110 void __dummy () {}
3111 #endif
3112
3113 #if defined (__mips_vxworks)
3114 int
3115 _flush_cache()
3116 {
3117    CACHE_USER_FLUSH (0, ENTIRE_CACHE);
3118 }
3119 #endif
3120
3121 #if defined (CROSS_DIRECTORY_STRUCTURE)  \
3122   || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3123       && defined (__SVR4)) \
3124       && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3125       && ! (defined (linux) && defined (__ia64__)) \
3126       && ! (defined (linux) && defined (powerpc)) \
3127       && ! defined (__FreeBSD__) \
3128       && ! defined (__hpux__) \
3129       && ! defined (__APPLE__) \
3130       && ! defined (_AIX) \
3131       && ! (defined (__alpha__)  && defined (__osf__)) \
3132       && ! defined (VMS) \
3133       && ! defined (__MINGW32__) \
3134       && ! (defined (__mips) && defined (__sgi)))
3135
3136 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3137    just above for a list of native platforms that provide a non-dummy
3138    version of this procedure in libaddr2line.a.  */
3139
3140 void
3141 convert_addresses (const char *file_name ATTRIBUTE_UNUSED,
3142                    void *addrs ATTRIBUTE_UNUSED,
3143                    int n_addr ATTRIBUTE_UNUSED,
3144                    void *buf ATTRIBUTE_UNUSED,
3145                    int *len ATTRIBUTE_UNUSED)
3146 {
3147   *len = 0;
3148 }
3149 #endif
3150
3151 #if defined (_WIN32)
3152 int __gnat_argument_needs_quote = 1;
3153 #else
3154 int __gnat_argument_needs_quote = 0;
3155 #endif
3156
3157 /* This option is used to enable/disable object files handling from the
3158    binder file by the GNAT Project module. For example, this is disabled on
3159    Windows (prior to GCC 3.4) as it is already done by the mdll module.
3160    Stating with GCC 3.4 the shared libraries are not based on mdll
3161    anymore as it uses the GCC's -shared option  */
3162 #if defined (_WIN32) \
3163     && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3164 int __gnat_prj_add_obj_files = 0;
3165 #else
3166 int __gnat_prj_add_obj_files = 1;
3167 #endif
3168
3169 /* char used as prefix/suffix for environment variables */
3170 #if defined (_WIN32)
3171 char __gnat_environment_char = '%';
3172 #else
3173 char __gnat_environment_char = '$';
3174 #endif
3175
3176 /* This functions copy the file attributes from a source file to a
3177    destination file.
3178
3179    mode = 0  : In this mode copy only the file time stamps (last access and
3180                last modification time stamps).
3181
3182    mode = 1  : In this mode, time stamps and read/write/execute attributes are
3183                copied.
3184
3185    Returns 0 if operation was successful and -1 in case of error. */
3186
3187 int
3188 __gnat_copy_attribs (char *from, char *to, int mode)
3189 {
3190 #if defined (VMS) || defined (__vxworks) || defined (__nucleus__)
3191   return -1;
3192 #else
3193   struct stat fbuf;
3194   struct utimbuf tbuf;
3195
3196   if (stat (from, &fbuf) == -1)
3197     {
3198       return -1;
3199     }
3200
3201   tbuf.actime = fbuf.st_atime;
3202   tbuf.modtime = fbuf.st_mtime;
3203
3204   if (utime (to, &tbuf) == -1)
3205     {
3206       return -1;
3207     }
3208
3209   if (mode == 1)
3210     {
3211       if (chmod (to, fbuf.st_mode) == -1)
3212         {
3213           return -1;
3214         }
3215     }
3216
3217   return 0;
3218 #endif
3219 }
3220
3221 int
3222 __gnat_lseek (int fd, long offset, int whence)
3223 {
3224   return (int) lseek (fd, offset, whence);
3225 }
3226
3227 /* This function returns the major version number of GCC being used.  */
3228 int
3229 get_gcc_version (void)
3230 {
3231 #ifdef IN_RTS
3232   return __GNUC__;
3233 #else
3234   return (int) (version_string[0] - '0');
3235 #endif
3236 }
3237
3238 int
3239 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED,
3240                           int close_on_exec_p ATTRIBUTE_UNUSED)
3241 {
3242 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3243   int flags = fcntl (fd, F_GETFD, 0);
3244   if (flags < 0)
3245     return flags;
3246   if (close_on_exec_p)
3247     flags |= FD_CLOEXEC;
3248   else
3249     flags &= ~FD_CLOEXEC;
3250   return fcntl (fd, F_SETFD, flags | FD_CLOEXEC);
3251 #elif defined(_WIN32)
3252   HANDLE h = (HANDLE) _get_osfhandle (fd);
3253   if (h == (HANDLE) -1)
3254     return -1;
3255   if (close_on_exec_p)
3256     return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT, 0);
3257   return ! SetHandleInformation (h, HANDLE_FLAG_INHERIT,
3258     HANDLE_FLAG_INHERIT);
3259 #else
3260   /* TODO: Unimplemented. */
3261   return -1;
3262 #endif
3263 }
3264
3265 /* Indicates if platforms supports automatic initialization through the
3266    constructor mechanism */
3267 int
3268 __gnat_binder_supports_auto_init ()
3269 {
3270 #ifdef VMS
3271    return 0;
3272 #else
3273    return 1;
3274 #endif
3275 }
3276
3277 /* Indicates that Stand-Alone Libraries are automatically initialized through
3278    the constructor mechanism */
3279 int
3280 __gnat_sals_init_using_constructors ()
3281 {
3282 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3283    return 0;
3284 #else
3285    return 1;
3286 #endif
3287 }
3288
3289 #ifdef RTX
3290
3291 /* In RTX mode, the procedure to get the time (as file time) is different
3292    in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3293    we introduce an intermediate procedure to link against the corresponding
3294    one in each situation. */
3295
3296 extern void GetTimeAsFileTime(LPFILETIME pTime);
3297
3298 void GetTimeAsFileTime(LPFILETIME pTime)
3299 {
3300 #ifdef RTSS
3301   RtGetRtssTimeAsFileTime (pTime); /* RTSS interface */
3302 #else
3303   GetSystemTimeAsFileTime (pTime); /* w32 interface */
3304 #endif
3305 }
3306
3307 #ifdef RTSS
3308 /* Add symbol that is required to link. It would otherwise be taken from
3309    libgcc.a and it would try to use the gcc constructors that are not
3310    supported by Microsoft linker. */
3311
3312 extern void __main (void);
3313
3314 void __main (void) {}
3315 #endif
3316 #endif
3317
3318 #if defined (linux) || defined(__GLIBC__)
3319 /* pthread affinity support */
3320
3321 int __gnat_pthread_setaffinity_np (pthread_t th,
3322                                    size_t cpusetsize,
3323                                    const void *cpuset);
3324
3325 #ifdef CPU_SETSIZE
3326 #include <pthread.h>
3327 int
3328 __gnat_pthread_setaffinity_np (pthread_t th,
3329                                size_t cpusetsize,
3330                                const cpu_set_t *cpuset)
3331 {
3332   return pthread_setaffinity_np (th, cpusetsize, cpuset);
3333 }
3334 #else
3335 int
3336 __gnat_pthread_setaffinity_np (pthread_t th ATTRIBUTE_UNUSED,
3337                                size_t cpusetsize ATTRIBUTE_UNUSED,
3338                                const void *cpuset ATTRIBUTE_UNUSED)
3339 {
3340   return 0;
3341 }
3342 #endif
3343 #endif