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 (char *name,
1691  DWORD CheckAccessDesired,
1692  GENERIC_MAPPING CheckGenericMapping)
1693 {
1694   TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1695   DWORD dwAccessDesired, dwAccessAllowed;
1696   PRIVILEGE_SET PrivilegeSet;
1697   DWORD dwPrivSetSize = sizeof (PRIVILEGE_SET);
1698   BOOL fAccessGranted = FALSE;
1699   HANDLE hToken;
1700   DWORD nLength;
1701   SECURITY_DESCRIPTOR* pSD = NULL;
1702
1703   S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
1704
1705   GetFileSecurity
1706     (wname, OWNER_SECURITY_INFORMATION |
1707      GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION,
1708      NULL, 0, &nLength);
1709
1710   if ((pSD = (PSECURITY_DESCRIPTOR) HeapAlloc
1711        (GetProcessHeap (), HEAP_ZERO_MEMORY, nLength)) == NULL)
1712     return 0;
1713
1714   /* Obtain the security descriptor. */
1715
1716   if (!GetFileSecurity
1717       (wname, OWNER_SECURITY_INFORMATION |
1718        GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION,
1719        pSD, nLength, &nLength))
1720     return 0;
1721
1722   if (!ImpersonateSelf (SecurityImpersonation))
1723     return 0;
1724
1725   if (!OpenThreadToken
1726       (GetCurrentThread(), TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken))
1727     return 0;
1728
1729   /*  Undoes the effect of ImpersonateSelf. */
1730
1731   RevertToSelf ();
1732
1733   /*  We want to test for write permissions. */
1734
1735   dwAccessDesired = CheckAccessDesired;
1736
1737   MapGenericMask (&dwAccessDesired, &CheckGenericMapping);
1738
1739   if (!AccessCheck
1740       (pSD ,                 /* security descriptor to check */
1741        hToken,               /* impersonation token */
1742        dwAccessDesired,      /* requested access rights */
1743        &CheckGenericMapping, /* pointer to GENERIC_MAPPING */
1744        &PrivilegeSet,        /* receives privileges used in check */
1745        &dwPrivSetSize,       /* size of PrivilegeSet buffer */
1746        &dwAccessAllowed,     /* receives mask of allowed access rights */
1747        &fAccessGranted))
1748     return 0;
1749
1750   return fAccessGranted;
1751 }
1752
1753 static void
1754 __gnat_set_OWNER_ACL
1755 (char *name,
1756  DWORD AccessMode,
1757  DWORD AccessPermissions)
1758 {
1759   ACL* pOldDACL = NULL;
1760   ACL* pNewDACL = NULL;
1761   SECURITY_DESCRIPTOR* pSD = NULL;
1762   EXPLICIT_ACCESS ea;
1763   TCHAR username [100];
1764   DWORD unsize = 100;
1765
1766   TCHAR wname [GNAT_MAX_PATH_LEN + 2];
1767
1768   S2WSU (wname, name, GNAT_MAX_PATH_LEN + 2);
1769
1770   HANDLE file = CreateFile
1771     (wname, READ_CONTROL | WRITE_DAC, 0, NULL,
1772      OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1773
1774   if (file == INVALID_HANDLE_VALUE)
1775     return;
1776
1777   /*  Get current user, he will act as the owner */
1778
1779   if (!GetUserName (username, &unsize))
1780     return;
1781
1782   if (GetSecurityInfo
1783       (file,
1784        SE_FILE_OBJECT,
1785        DACL_SECURITY_INFORMATION,
1786        NULL, NULL, &pOldDACL, NULL, &pSD) != ERROR_SUCCESS)
1787     return;
1788
1789   ZeroMemory (&ea, sizeof (EXPLICIT_ACCESS));
1790
1791   ea.grfAccessMode = AccessMode;
1792   ea.grfAccessPermissions = AccessPermissions;
1793   ea.grfInheritance = CONTAINER_INHERIT_ACE | OBJECT_INHERIT_ACE;
1794   ea.Trustee.TrusteeForm = TRUSTEE_IS_NAME;
1795   ea.Trustee.TrusteeType = TRUSTEE_IS_USER;
1796   ea.Trustee.ptstrName = username;
1797
1798   if (AccessMode == SET_ACCESS)
1799     {
1800       /*  SET_ACCESS, we want to set an explicte set of permissions, do not
1801           merge with current DACL.  */
1802       if (SetEntriesInAcl (1, &ea, NULL, &pNewDACL) != ERROR_SUCCESS)
1803         return;
1804     }
1805   else
1806     if (SetEntriesInAcl (1, &ea, pOldDACL, &pNewDACL) != ERROR_SUCCESS)
1807       return;
1808
1809   if (SetSecurityInfo
1810       (file, SE_FILE_OBJECT,
1811        DACL_SECURITY_INFORMATION, NULL, NULL, pNewDACL, NULL) != ERROR_SUCCESS)
1812     return;
1813
1814   LocalFree (pSD);
1815   LocalFree (pNewDACL);
1816   CloseHandle (file);
1817 }
1818 #endif /* defined (_WIN32) && !defined (RTX) */
1819
1820 int
1821 __gnat_is_readable_file (char *name)
1822 {
1823 #if defined (_WIN32) && !defined (RTX)
1824   GENERIC_MAPPING GenericMapping;
1825   ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
1826   GenericMapping.GenericRead = GENERIC_READ;
1827
1828   return __gnat_check_OWNER_ACL (name, FILE_READ_DATA, GenericMapping);
1829 #else
1830   int ret;
1831   int mode;
1832   struct stat statbuf;
1833
1834   ret = __gnat_stat (name, &statbuf);
1835   mode = statbuf.st_mode & S_IRUSR;
1836   return (!ret && mode);
1837 #endif
1838 }
1839
1840 int
1841 __gnat_is_writable_file (char *name)
1842 {
1843 #if defined (_WIN32) && !defined (RTX)
1844   GENERIC_MAPPING GenericMapping;
1845   ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
1846   GenericMapping.GenericWrite = GENERIC_WRITE;
1847
1848   return __gnat_check_OWNER_ACL
1849     (name, FILE_WRITE_DATA | FILE_APPEND_DATA, GenericMapping);
1850 #else
1851   int ret;
1852   int mode;
1853   struct stat statbuf;
1854
1855   ret = __gnat_stat (name, &statbuf);
1856   mode = statbuf.st_mode & S_IWUSR;
1857   return (!ret && mode);
1858 #endif
1859 }
1860
1861 int
1862 __gnat_is_executable_file (char *name)
1863 {
1864 #if defined (_WIN32) && !defined (RTX)
1865   GENERIC_MAPPING GenericMapping;
1866   ZeroMemory (&GenericMapping, sizeof (GENERIC_MAPPING));
1867   GenericMapping.GenericExecute = GENERIC_EXECUTE;
1868
1869   return __gnat_check_OWNER_ACL (name, FILE_EXECUTE, GenericMapping);
1870 #else
1871   int ret;
1872   int mode;
1873   struct stat statbuf;
1874
1875   ret = __gnat_stat (name, &statbuf);
1876   mode = statbuf.st_mode & S_IXUSR;
1877   return (!ret && mode);
1878 #endif
1879 }
1880
1881 void
1882 __gnat_set_writable (char *name)
1883 {
1884 #if defined (_WIN32) && !defined (RTX)
1885   __gnat_set_OWNER_ACL (name, GRANT_ACCESS, GENERIC_WRITE);
1886 #elif ! defined (__vxworks) && ! defined(__nucleus__)
1887   struct stat statbuf;
1888
1889   if (stat (name, &statbuf) == 0)
1890   {
1891     statbuf.st_mode = statbuf.st_mode | S_IWUSR;
1892     chmod (name, statbuf.st_mode);
1893   }
1894 #endif
1895 }
1896
1897 void
1898 __gnat_set_executable (char *name)
1899 {
1900 #if defined (_WIN32) && !defined (RTX)
1901   __gnat_set_OWNER_ACL (name, GRANT_ACCESS, GENERIC_EXECUTE);
1902 #elif ! defined (__vxworks) && ! defined(__nucleus__)
1903   struct stat statbuf;
1904
1905   if (stat (name, &statbuf) == 0)
1906   {
1907     statbuf.st_mode = statbuf.st_mode | S_IXUSR;
1908     chmod (name, statbuf.st_mode);
1909   }
1910 #endif
1911 }
1912
1913 void
1914 __gnat_set_readonly (char *name)
1915 {
1916 #if defined (_WIN32) && !defined (RTX)
1917   __gnat_set_OWNER_ACL (name, SET_ACCESS, GENERIC_READ);
1918 #elif ! defined (__vxworks) && ! defined(__nucleus__)
1919   struct stat statbuf;
1920
1921   if (stat (name, &statbuf) == 0)
1922   {
1923     statbuf.st_mode = statbuf.st_mode & 07577;
1924     chmod (name, statbuf.st_mode);
1925   }
1926 #endif
1927 }
1928
1929 int
1930 __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED)
1931 {
1932 #if defined (__vxworks) || defined (__nucleus__)
1933   return 0;
1934
1935 #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
1936   int ret;
1937   struct stat statbuf;
1938
1939   ret = lstat (name, &statbuf);
1940   return (!ret && S_ISLNK (statbuf.st_mode));
1941
1942 #else
1943   return 0;
1944 #endif
1945 }
1946
1947 #if defined (sun) && defined (__SVR4)
1948 /* Using fork on Solaris will duplicate all the threads. fork1, which
1949    duplicates only the active thread, must be used instead, or spawning
1950    subprocess from a program with tasking will lead into numerous problems.  */
1951 #define fork fork1
1952 #endif
1953
1954 int
1955 __gnat_portable_spawn (char *args[])
1956 {
1957   int status = 0;
1958   int finished ATTRIBUTE_UNUSED;
1959   int pid ATTRIBUTE_UNUSED;
1960
1961 #if defined (__vxworks) || defined(__nucleus__) || defined(RTX)
1962   return -1;
1963
1964 #elif defined (MSDOS) || defined (_WIN32)
1965   /* args[0] must be quotes as it could contain a full pathname with spaces */
1966   char *args_0 = args[0];
1967   args[0] = (char *)xmalloc (strlen (args_0) + 3);
1968   strcpy (args[0], "\"");
1969   strcat (args[0], args_0);
1970   strcat (args[0], "\"");
1971
1972   status = spawnvp (P_WAIT, args_0, (const char* const*)args);
1973
1974   /* restore previous value */
1975   free (args[0]);
1976   args[0] = (char *)args_0;
1977
1978   if (status < 0)
1979     return -1;
1980   else
1981     return status;
1982
1983 #else
1984
1985 #ifdef __EMX__
1986   pid = spawnvp (P_NOWAIT, args[0], args);
1987   if (pid == -1)
1988     return -1;
1989
1990 #else
1991   pid = fork ();
1992   if (pid < 0)
1993     return -1;
1994
1995   if (pid == 0)
1996     {
1997       /* The child. */
1998       if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
1999 #if defined (VMS)
2000         return -1; /* execv is in parent context on VMS.  */
2001 #else
2002         _exit (1);
2003 #endif
2004     }
2005 #endif
2006
2007   /* The parent.  */
2008   finished = waitpid (pid, &status, 0);
2009
2010   if (finished != pid || WIFEXITED (status) == 0)
2011     return -1;
2012
2013   return WEXITSTATUS (status);
2014 #endif
2015
2016   return 0;
2017 }
2018
2019 /* Create a copy of the given file descriptor.
2020    Return -1 if an error occurred.  */
2021
2022 int
2023 __gnat_dup (int oldfd)
2024 {
2025 #if defined (__vxworks) && !defined (__RTP__)
2026   /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2027      RTPs. */
2028   return -1;
2029 #else
2030   return dup (oldfd);
2031 #endif
2032 }
2033
2034 /* Make newfd be the copy of oldfd, closing newfd first if necessary.
2035    Return -1 if an error occurred.  */
2036
2037 int
2038 __gnat_dup2 (int oldfd, int newfd)
2039 {
2040 #if defined (__vxworks) && !defined (__RTP__)
2041   /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using
2042      RTPs.  */
2043   return -1;
2044 #else
2045   return dup2 (oldfd, newfd);
2046 #endif
2047 }
2048
2049 /* WIN32 code to implement a wait call that wait for any child process.  */
2050
2051 #if defined (_WIN32) && !defined (RTX)
2052
2053 /* Synchronization code, to be thread safe.  */
2054
2055 static CRITICAL_SECTION plist_cs;
2056
2057 void
2058 __gnat_plist_init (void)
2059 {
2060   InitializeCriticalSection (&plist_cs);
2061 }
2062
2063 static void
2064 plist_enter (void)
2065 {
2066   EnterCriticalSection (&plist_cs);
2067 }
2068
2069 static void
2070 plist_leave (void)
2071 {
2072   LeaveCriticalSection (&plist_cs);
2073 }
2074
2075 typedef struct _process_list
2076 {
2077   HANDLE h;
2078   struct _process_list *next;
2079 } Process_List;
2080
2081 static Process_List *PLIST = NULL;
2082
2083 static int plist_length = 0;
2084
2085 static void
2086 add_handle (HANDLE h)
2087 {
2088   Process_List *pl;
2089
2090   pl = (Process_List *) xmalloc (sizeof (Process_List));
2091
2092   plist_enter();
2093
2094   /* -------------------- critical section -------------------- */
2095   pl->h = h;
2096   pl->next = PLIST;
2097   PLIST = pl;
2098   ++plist_length;
2099   /* -------------------- critical section -------------------- */
2100
2101   plist_leave();
2102 }
2103
2104 static void
2105 remove_handle (HANDLE h)
2106 {
2107   Process_List *pl;
2108   Process_List *prev = NULL;
2109
2110   plist_enter();
2111
2112   /* -------------------- critical section -------------------- */
2113   pl = PLIST;
2114   while (pl)
2115     {
2116       if (pl->h == h)
2117         {
2118           if (pl == PLIST)
2119             PLIST = pl->next;
2120           else
2121             prev->next = pl->next;
2122           free (pl);
2123           break;
2124         }
2125       else
2126         {
2127           prev = pl;
2128           pl = pl->next;
2129         }
2130     }
2131
2132   --plist_length;
2133   /* -------------------- critical section -------------------- */
2134
2135   plist_leave();
2136 }
2137
2138 static int
2139 win32_no_block_spawn (char *command, char *args[])
2140 {
2141   BOOL result;
2142   STARTUPINFO SI;
2143   PROCESS_INFORMATION PI;
2144   SECURITY_ATTRIBUTES SA;
2145   int csize = 1;
2146   char *full_command;
2147   int k;
2148
2149   /* compute the total command line length */
2150   k = 0;
2151   while (args[k])
2152     {
2153       csize += strlen (args[k]) + 1;
2154       k++;
2155     }
2156
2157   full_command = (char *) xmalloc (csize);
2158
2159   /* Startup info. */
2160   SI.cb          = sizeof (STARTUPINFO);
2161   SI.lpReserved  = NULL;
2162   SI.lpReserved2 = NULL;
2163   SI.lpDesktop   = NULL;
2164   SI.cbReserved2 = 0;
2165   SI.lpTitle     = NULL;
2166   SI.dwFlags     = 0;
2167   SI.wShowWindow = SW_HIDE;
2168
2169   /* Security attributes. */
2170   SA.nLength = sizeof (SECURITY_ATTRIBUTES);
2171   SA.bInheritHandle = TRUE;
2172   SA.lpSecurityDescriptor = NULL;
2173
2174   /* Prepare the command string. */
2175   strcpy (full_command, command);
2176   strcat (full_command, " ");
2177
2178   k = 1;
2179   while (args[k])
2180     {
2181       strcat (full_command, args[k]);
2182       strcat (full_command, " ");
2183       k++;
2184     }
2185
2186   {
2187     int wsize = csize * 2;
2188     TCHAR *wcommand = (TCHAR *) xmalloc (wsize);
2189
2190     S2WSU (wcommand, full_command, wsize);
2191
2192     free (full_command);
2193
2194     result = CreateProcess
2195       (NULL, wcommand, &SA, NULL, TRUE,
2196        GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
2197
2198     free (wcommand);
2199   }
2200
2201   if (result == TRUE)
2202     {
2203       add_handle (PI.hProcess);
2204       CloseHandle (PI.hThread);
2205       return (int) PI.hProcess;
2206     }
2207   else
2208     return -1;
2209 }
2210
2211 static int
2212 win32_wait (int *status)
2213 {
2214   DWORD exitcode;
2215   HANDLE *hl;
2216   HANDLE h;
2217   DWORD res;
2218   int k;
2219   Process_List *pl;
2220
2221   if (plist_length == 0)
2222     {
2223       errno = ECHILD;
2224       return -1;
2225     }
2226
2227   hl = (HANDLE *) xmalloc (sizeof (HANDLE) * plist_length);
2228
2229   k = 0;
2230   plist_enter();
2231
2232   /* -------------------- critical section -------------------- */
2233   pl = PLIST;
2234   while (pl)
2235     {
2236       hl[k++] = pl->h;
2237       pl = pl->next;
2238     }
2239   /* -------------------- critical section -------------------- */
2240
2241   plist_leave();
2242
2243   res = WaitForMultipleObjects (plist_length, hl, FALSE, INFINITE);
2244   h = hl[res - WAIT_OBJECT_0];
2245   free (hl);
2246
2247   remove_handle (h);
2248
2249   GetExitCodeProcess (h, &exitcode);
2250   CloseHandle (h);
2251
2252   *status = (int) exitcode;
2253   return (int) h;
2254 }
2255
2256 #endif
2257
2258 int
2259 __gnat_portable_no_block_spawn (char *args[])
2260 {
2261   int pid = 0;
2262
2263 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2264   return -1;
2265
2266 #elif defined (__EMX__) || defined (MSDOS)
2267
2268   /* ??? For PC machines I (Franco) don't know the system calls to implement
2269      this routine. So I'll fake it as follows. This routine will behave
2270      exactly like the blocking portable_spawn and will systematically return
2271      a pid of 0 unless the spawned task did not complete successfully, in
2272      which case we return a pid of -1.  To synchronize with this the
2273      portable_wait below systematically returns a pid of 0 and reports that
2274      the subprocess terminated successfully. */
2275
2276   if (spawnvp (P_WAIT, args[0], args) != 0)
2277     return -1;
2278
2279 #elif defined (_WIN32)
2280
2281   pid = win32_no_block_spawn (args[0], args);
2282   return pid;
2283
2284 #else
2285   pid = fork ();
2286
2287   if (pid == 0)
2288     {
2289       /* The child.  */
2290       if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
2291 #if defined (VMS)
2292         return -1; /* execv is in parent context on VMS. */
2293 #else
2294         _exit (1);
2295 #endif
2296     }
2297
2298 #endif
2299
2300   return pid;
2301 }
2302
2303 int
2304 __gnat_portable_wait (int *process_status)
2305 {
2306   int status = 0;
2307   int pid = 0;
2308
2309 #if defined (__vxworks) || defined (__nucleus__) || defined (RTX)
2310   /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but
2311      return zero.  */
2312
2313 #elif defined (_WIN32)
2314
2315   pid = win32_wait (&status);
2316
2317 #elif defined (__EMX__) || defined (MSDOS)
2318   /* ??? See corresponding comment in portable_no_block_spawn.  */
2319
2320 #else
2321
2322   pid = waitpid (-1, &status, 0);
2323   status = status & 0xffff;
2324 #endif
2325
2326   *process_status = status;
2327   return pid;
2328 }
2329
2330 void
2331 __gnat_os_exit (int status)
2332 {
2333   exit (status);
2334 }
2335
2336 /* Locate a regular file, give a Path value.  */
2337
2338 char *
2339 __gnat_locate_regular_file (char *file_name, char *path_val)
2340 {
2341   char *ptr;
2342   char *file_path = (char *) alloca (strlen (file_name) + 1);
2343   int absolute;
2344
2345   /* Return immediately if file_name is empty */
2346
2347   if (*file_name == '\0')
2348     return 0;
2349
2350   /* Remove quotes around file_name if present */
2351
2352   ptr = file_name;
2353   if (*ptr == '"')
2354     ptr++;
2355
2356   strcpy (file_path, ptr);
2357
2358   ptr = file_path + strlen (file_path) - 1;
2359
2360   if (*ptr == '"')
2361     *ptr = '\0';
2362
2363   /* Handle absolute pathnames.  */
2364
2365   absolute = __gnat_is_absolute_path (file_path, strlen (file_name));
2366
2367   if (absolute)
2368     {
2369      if (__gnat_is_regular_file (file_path))
2370        return xstrdup (file_path);
2371
2372       return 0;
2373     }
2374
2375   /* If file_name include directory separator(s), try it first as
2376      a path name relative to the current directory */
2377   for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
2378     ;
2379
2380   if (*ptr != 0)
2381     {
2382       if (__gnat_is_regular_file (file_name))
2383         return xstrdup (file_name);
2384     }
2385
2386   if (path_val == 0)
2387     return 0;
2388
2389   {
2390     /* The result has to be smaller than path_val + file_name.  */
2391     char *file_path = (char *) alloca (strlen (path_val) + strlen (file_name) + 2);
2392
2393     for (;;)
2394       {
2395         for (; *path_val == PATH_SEPARATOR; path_val++)
2396           ;
2397
2398       if (*path_val == 0)
2399         return 0;
2400
2401       /* Skip the starting quote */
2402
2403       if (*path_val == '"')
2404         path_val++;
2405
2406       for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; )
2407         *ptr++ = *path_val++;
2408
2409       ptr--;
2410
2411       /* Skip the ending quote */
2412
2413       if (*ptr == '"')
2414         ptr--;
2415
2416       if (*ptr != '/' && *ptr != DIR_SEPARATOR)
2417         *++ptr = DIR_SEPARATOR;
2418
2419       strcpy (++ptr, file_name);
2420
2421       if (__gnat_is_regular_file (file_path))
2422         return xstrdup (file_path);
2423       }
2424   }
2425
2426   return 0;
2427 }
2428
2429 /* Locate an executable given a Path argument. This routine is only used by
2430    gnatbl and should not be used otherwise.  Use locate_exec_on_path
2431    instead.  */
2432
2433 char *
2434 __gnat_locate_exec (char *exec_name, char *path_val)
2435 {
2436   char *ptr;
2437   if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
2438     {
2439       char *full_exec_name
2440         = (char *) alloca (strlen (exec_name) + strlen (HOST_EXECUTABLE_SUFFIX) + 1);
2441
2442       strcpy (full_exec_name, exec_name);
2443       strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
2444       ptr = __gnat_locate_regular_file (full_exec_name, path_val);
2445
2446       if (ptr == 0)
2447          return __gnat_locate_regular_file (exec_name, path_val);
2448       return ptr;
2449     }
2450   else
2451     return __gnat_locate_regular_file (exec_name, path_val);
2452 }
2453
2454 /* Locate an executable using the Systems default PATH.  */
2455
2456 char *
2457 __gnat_locate_exec_on_path (char *exec_name)
2458 {
2459   char *apath_val;
2460
2461 #if defined (_WIN32) && !defined (RTX)
2462   TCHAR *wpath_val = _tgetenv (_T("PATH"));
2463   TCHAR *wapath_val;
2464   /* In Win32 systems we expand the PATH as for XP environment
2465      variables are not automatically expanded. We also prepend the
2466      ".;" to the path to match normal NT path search semantics */
2467
2468   #define EXPAND_BUFFER_SIZE 32767
2469
2470   wapath_val = alloca (EXPAND_BUFFER_SIZE);
2471
2472   wapath_val [0] = '.';
2473   wapath_val [1] = ';';
2474
2475   DWORD res = ExpandEnvironmentStrings
2476     (wpath_val, &wapath_val[2], EXPAND_BUFFER_SIZE - 2);
2477
2478   if (!res) wapath_val [0] = _T('\0');
2479
2480   apath_val = alloca (EXPAND_BUFFER_SIZE);
2481
2482   WS2SU (apath_val, wapath_val, EXPAND_BUFFER_SIZE);
2483   return __gnat_locate_exec (exec_name, apath_val);
2484
2485 #else
2486
2487 #ifdef VMS
2488   char *path_val = "/VAXC$PATH";
2489 #else
2490   char *path_val = getenv ("PATH");
2491 #endif
2492   if (path_val == NULL) return NULL;
2493   apath_val = (char *) alloca (strlen (path_val) + 1);
2494   strcpy (apath_val, path_val);
2495   return __gnat_locate_exec (exec_name, apath_val);
2496 #endif
2497 }
2498
2499 #ifdef VMS
2500
2501 /* These functions are used to translate to and from VMS and Unix syntax
2502    file, directory and path specifications.  */
2503
2504 #define MAXPATH  256
2505 #define MAXNAMES 256
2506 #define NEW_CANONICAL_FILELIST_INCREMENT 64
2507
2508 static char new_canonical_dirspec [MAXPATH];
2509 static char new_canonical_filespec [MAXPATH];
2510 static char new_canonical_pathspec [MAXNAMES*MAXPATH];
2511 static unsigned new_canonical_filelist_index;
2512 static unsigned new_canonical_filelist_in_use;
2513 static unsigned new_canonical_filelist_allocated;
2514 static char **new_canonical_filelist;
2515 static char new_host_pathspec [MAXNAMES*MAXPATH];
2516 static char new_host_dirspec [MAXPATH];
2517 static char new_host_filespec [MAXPATH];
2518
2519 /* Routine is called repeatedly by decc$from_vms via
2520    __gnat_to_canonical_file_list_init until it returns 0 or the expansion
2521    runs out. */
2522
2523 static int
2524 wildcard_translate_unix (char *name)
2525 {
2526   char *ver;
2527   char buff [MAXPATH];
2528
2529   strncpy (buff, name, MAXPATH);
2530   buff [MAXPATH - 1] = (char) 0;
2531   ver = strrchr (buff, '.');
2532
2533   /* Chop off the version.  */
2534   if (ver)
2535     *ver = 0;
2536
2537   /* Dynamically extend the allocation by the increment.  */
2538   if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
2539     {
2540       new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
2541       new_canonical_filelist = (char **) xrealloc
2542         (new_canonical_filelist,
2543          new_canonical_filelist_allocated * sizeof (char *));
2544     }
2545
2546   new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
2547
2548   return 1;
2549 }
2550
2551 /* Translate a wildcard VMS file spec into a list of Unix file specs. First do
2552    full translation and copy the results into a list (_init), then return them
2553    one at a time (_next). If onlydirs set, only expand directory files.  */
2554
2555 int
2556 __gnat_to_canonical_file_list_init (char *filespec, int onlydirs)
2557 {
2558   int len;
2559   char buff [MAXPATH];
2560
2561   len = strlen (filespec);
2562   strncpy (buff, filespec, MAXPATH);
2563
2564   /* Only look for directories */
2565   if (onlydirs && !strstr (&buff [len-5], "*.dir"))
2566     strncat (buff, "*.dir", MAXPATH);
2567
2568   buff [MAXPATH - 1] = (char) 0;
2569
2570   decc$from_vms (buff, wildcard_translate_unix, 1);
2571
2572   /* Remove the .dir extension.  */
2573   if (onlydirs)
2574     {
2575       int i;
2576       char *ext;
2577
2578       for (i = 0; i < new_canonical_filelist_in_use; i++)
2579         {
2580           ext = strstr (new_canonical_filelist[i], ".dir");
2581           if (ext)
2582             *ext = 0;
2583         }
2584     }
2585
2586   return new_canonical_filelist_in_use;
2587 }
2588
2589 /* Return the next filespec in the list.  */
2590
2591 char *
2592 __gnat_to_canonical_file_list_next ()
2593 {
2594   return new_canonical_filelist[new_canonical_filelist_index++];
2595 }
2596
2597 /* Free storage used in the wildcard expansion.  */
2598
2599 void
2600 __gnat_to_canonical_file_list_free ()
2601 {
2602   int i;
2603
2604    for (i = 0; i < new_canonical_filelist_in_use; i++)
2605      free (new_canonical_filelist[i]);
2606
2607   free (new_canonical_filelist);
2608
2609   new_canonical_filelist_in_use = 0;
2610   new_canonical_filelist_allocated = 0;
2611   new_canonical_filelist_index = 0;
2612   new_canonical_filelist = 0;
2613 }
2614
2615 /* The functional equivalent of decc$translate_vms routine.
2616    Designed to produce the same output, but is protected against
2617    malformed paths (original version ACCVIOs in this case) and
2618    does not require VMS-specific DECC RTL */
2619
2620 #define NAM$C_MAXRSS 1024
2621
2622 char *
2623 __gnat_translate_vms (char *src)
2624 {
2625   static char retbuf [NAM$C_MAXRSS+1];
2626   char *srcendpos, *pos1, *pos2, *retpos;
2627   int disp, path_present = 0;
2628
2629   if (!src) return NULL;
2630
2631   srcendpos = strchr (src, '\0');
2632   retpos = retbuf;
2633
2634   /* Look for the node and/or device in front of the path */
2635   pos1 = src;
2636   pos2 = strchr (pos1, ':');
2637
2638   if (pos2 && (pos2 < srcendpos) && (*(pos2 + 1) == ':')) {
2639     /* There is a node name. "node_name::" becomes "node_name!" */
2640     disp = pos2 - pos1;
2641     strncpy (retbuf, pos1, disp);
2642     retpos [disp] = '!';
2643     retpos = retpos + disp + 1;
2644     pos1 = pos2 + 2;
2645     pos2 = strchr (pos1, ':');
2646   }
2647
2648   if (pos2) {
2649     /* There is a device name. "dev_name:" becomes "/dev_name/" */
2650     *(retpos++) = '/';
2651     disp = pos2 - pos1;
2652     strncpy (retpos, pos1, disp);
2653     retpos = retpos + disp;
2654     pos1 = pos2 + 1;
2655     *(retpos++) = '/';
2656   }
2657   else
2658     /* No explicit device; we must look ahead and prepend /sys$disk/ if
2659        the path is absolute */
2660     if ((*pos1 == '[' || *pos1 == '<') && (pos1 < srcendpos)
2661         && !strchr (".-]>", *(pos1 + 1))) {
2662       strncpy (retpos, "/sys$disk/", 10);
2663       retpos += 10;
2664     }
2665
2666   /* Process the path part */
2667   while (*pos1 == '[' || *pos1 == '<') {
2668     path_present++;
2669     pos1++;
2670     if (*pos1 == ']' || *pos1 == '>') {
2671       /* Special case, [] translates to '.' */
2672       *(retpos++) = '.';
2673       pos1++;
2674     }
2675     else {
2676       /* '[000000' means root dir. It can be present in the middle of
2677          the path due to expansion of logical devices, in which case
2678          we skip it */
2679       if (!strncmp (pos1, "000000", 6) && path_present > 1 &&
2680          (*(pos1 + 6) == ']' || *(pos1 + 6) == '>' || *(pos1 + 6) == '.')) {
2681           pos1 += 6;
2682           if (*pos1 == '.') pos1++;
2683         }
2684       else if (*pos1 == '.') {
2685         /* Relative path */
2686         *(retpos++) = '.';
2687       }
2688
2689       /* There is a qualified path */
2690       while (*pos1 && *pos1 != ']' && *pos1 != '>') {
2691         switch (*pos1) {
2692           case '.':
2693             /* '.' is used to separate directories. Replace it with '/' but
2694                only if there isn't already '/' just before */
2695             if (*(retpos - 1) != '/') *(retpos++) = '/';
2696             pos1++;
2697             if (pos1 + 1 < srcendpos && *pos1 == '.' && *(pos1 + 1) == '.') {
2698               /* ellipsis refers to entire subtree; replace with '**' */
2699               *(retpos++) = '*'; *(retpos++) = '*'; *(retpos++) = '/';
2700               pos1 += 2;
2701             }
2702             break;
2703           case '-' :
2704             /* When after '.' '[' '<' is equivalent to Unix ".." but there
2705             may be several in a row */
2706             if (*(pos1 - 1) == '.' || *(pos1 - 1) == '[' ||
2707                 *(pos1 - 1) == '<') {
2708               while (*pos1 == '-') {
2709                 pos1++;
2710                 *(retpos++) = '.'; *(retpos++) = '.'; *(retpos++) = '/';
2711               }
2712               retpos--;
2713               break;
2714             }
2715             /* otherwise fall through to default */
2716           default:
2717             *(retpos++) = *(pos1++);
2718         }
2719       }
2720       pos1++;
2721     }
2722   }
2723
2724   if (pos1 < srcendpos) {
2725     /* Now add the actual file name, until the version suffix if any */
2726     if (path_present) *(retpos++) = '/';
2727     pos2 = strchr (pos1, ';');
2728     disp = pos2? (pos2 - pos1) : (srcendpos - pos1);
2729     strncpy (retpos, pos1, disp);
2730     retpos += disp;
2731     if (pos2 && pos2 < srcendpos) {
2732       /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
2733       *retpos++ = '.';
2734       disp = srcendpos - pos2 - 1;
2735       strncpy (retpos, pos2 + 1, disp);
2736       retpos += disp;
2737     }
2738   }
2739
2740   *retpos = '\0';
2741
2742   return retbuf;
2743
2744 }
2745
2746 /* Translate a VMS syntax directory specification in to Unix syntax.  If
2747    PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
2748    found, return input string. Also translate a dirname that contains no
2749    slashes, in case it's a logical name.  */
2750
2751 char *
2752 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag)
2753 {
2754   int len;
2755
2756   strcpy (new_canonical_dirspec, "");
2757   if (strlen (dirspec))
2758     {
2759       char *dirspec1;
2760
2761       if (strchr (dirspec, ']') || strchr (dirspec, ':'))
2762         {
2763           strncpy (new_canonical_dirspec,
2764                    __gnat_translate_vms (dirspec),
2765                    MAXPATH);
2766         }
2767       else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
2768         {
2769           strncpy (new_canonical_dirspec,
2770                   __gnat_translate_vms (dirspec1),
2771                   MAXPATH);
2772         }
2773       else
2774         {
2775           strncpy (new_canonical_dirspec, dirspec, MAXPATH);
2776         }
2777     }
2778
2779   len = strlen (new_canonical_dirspec);
2780   if (prefixflag && new_canonical_dirspec [len-1] != '/')
2781     strncat (new_canonical_dirspec, "/", MAXPATH);
2782
2783   new_canonical_dirspec [MAXPATH - 1] = (char) 0;
2784
2785   return new_canonical_dirspec;
2786
2787 }
2788
2789 /* Translate a VMS syntax file specification into Unix syntax.
2790    If no indicators of VMS syntax found, check if it's an uppercase
2791    alphanumeric_ name and if so try it out as an environment
2792    variable (logical name). If all else fails return the
2793    input string.  */
2794
2795 char *
2796 __gnat_to_canonical_file_spec (char *filespec)
2797 {
2798   char *filespec1;
2799
2800   strncpy (new_canonical_filespec, "", MAXPATH);
2801
2802   if (strchr (filespec, ']') || strchr (filespec, ':'))
2803     {
2804       char *tspec = (char *) __gnat_translate_vms (filespec);
2805
2806       if (tspec != (char *) -1)
2807         strncpy (new_canonical_filespec, tspec, MAXPATH);
2808     }
2809   else if ((strlen (filespec) == strspn (filespec,
2810             "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
2811         && (filespec1 = getenv (filespec)))
2812     {
2813       char *tspec = (char *) __gnat_translate_vms (filespec1);
2814
2815       if (tspec != (char *) -1)
2816         strncpy (new_canonical_filespec, tspec, MAXPATH);
2817     }
2818   else
2819     {
2820       strncpy (new_canonical_filespec, filespec, MAXPATH);
2821     }
2822
2823   new_canonical_filespec [MAXPATH - 1] = (char) 0;
2824
2825   return new_canonical_filespec;
2826 }
2827
2828 /* Translate a VMS syntax path specification into Unix syntax.
2829    If no indicators of VMS syntax found, return input string.  */
2830
2831 char *
2832 __gnat_to_canonical_path_spec (char *pathspec)
2833 {
2834   char *curr, *next, buff [MAXPATH];
2835
2836   if (pathspec == 0)
2837     return pathspec;
2838
2839   /* If there are /'s, assume it's a Unix path spec and return.  */
2840   if (strchr (pathspec, '/'))
2841     return pathspec;
2842
2843   new_canonical_pathspec[0] = 0;
2844   curr = pathspec;
2845
2846   for (;;)
2847     {
2848       next = strchr (curr, ',');
2849       if (next == 0)
2850         next = strchr (curr, 0);
2851
2852       strncpy (buff, curr, next - curr);
2853       buff[next - curr] = 0;
2854
2855       /* Check for wildcards and expand if present.  */
2856       if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
2857         {
2858           int i, dirs;
2859
2860           dirs = __gnat_to_canonical_file_list_init (buff, 1);
2861           for (i = 0; i < dirs; i++)
2862             {
2863               char *next_dir;
2864
2865               next_dir = __gnat_to_canonical_file_list_next ();
2866               strncat (new_canonical_pathspec, next_dir, MAXPATH);
2867
2868               /* Don't append the separator after the last expansion.  */
2869               if (i+1 < dirs)
2870                 strncat (new_canonical_pathspec, ":", MAXPATH);
2871             }
2872
2873           __gnat_to_canonical_file_list_free ();
2874         }
2875       else
2876         strncat (new_canonical_pathspec,
2877                 __gnat_to_canonical_dir_spec (buff, 0), MAXPATH);
2878
2879       if (*next == 0)
2880         break;
2881
2882       strncat (new_canonical_pathspec, ":", MAXPATH);
2883       curr = next + 1;
2884     }
2885
2886   new_canonical_pathspec [MAXPATH - 1] = (char) 0;
2887
2888   return new_canonical_pathspec;
2889 }
2890
2891 static char filename_buff [MAXPATH];
2892
2893 static int
2894 translate_unix (char *name, int type)
2895 {
2896   strncpy (filename_buff, name, MAXPATH);
2897   filename_buff [MAXPATH - 1] = (char) 0;
2898   return 0;
2899 }
2900
2901 /* Translate a Unix syntax path spec into a VMS style (comma separated list of
2902    directories.  */
2903
2904 static char *
2905 to_host_path_spec (char *pathspec)
2906 {
2907   char *curr, *next, buff [MAXPATH];
2908
2909   if (pathspec == 0)
2910     return pathspec;
2911
2912   /* Can't very well test for colons, since that's the Unix separator!  */
2913   if (strchr (pathspec, ']') || strchr (pathspec, ','))
2914     return pathspec;
2915
2916   new_host_pathspec[0] = 0;
2917   curr = pathspec;
2918
2919   for (;;)
2920     {
2921       next = strchr (curr, ':');
2922       if (next == 0)
2923         next = strchr (curr, 0);
2924
2925       strncpy (buff, curr, next - curr);
2926       buff[next - curr] = 0;
2927
2928       strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH);
2929       if (*next == 0)
2930         break;
2931       strncat (new_host_pathspec, ",", MAXPATH);
2932       curr = next + 1;
2933     }
2934
2935   new_host_pathspec [MAXPATH - 1] = (char) 0;
2936
2937   return new_host_pathspec;
2938 }
2939
2940 /* Translate a Unix syntax directory specification into VMS syntax.  The
2941    PREFIXFLAG has no effect, but is kept for symmetry with
2942    to_canonical_dir_spec.  If indicators of VMS syntax found, return input
2943    string. */
2944
2945 char *
2946 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
2947 {
2948   int len = strlen (dirspec);
2949
2950   strncpy (new_host_dirspec, dirspec, MAXPATH);
2951   new_host_dirspec [MAXPATH - 1] = (char) 0;
2952
2953   if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
2954     return new_host_dirspec;
2955
2956   while (len > 1 && new_host_dirspec[len - 1] == '/')
2957     {
2958       new_host_dirspec[len - 1] = 0;
2959       len--;
2960     }
2961
2962   decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
2963   strncpy (new_host_dirspec, filename_buff, MAXPATH);
2964   new_host_dirspec [MAXPATH - 1] = (char) 0;
2965
2966   return new_host_dirspec;
2967 }
2968
2969 /* Translate a Unix syntax file specification into VMS syntax.
2970    If indicators of VMS syntax found, return input string.  */
2971
2972 char *
2973 __gnat_to_host_file_spec (char *filespec)
2974 {
2975   strncpy (new_host_filespec, "", MAXPATH);
2976   if (strchr (filespec, ']') || strchr (filespec, ':'))
2977     {
2978       strncpy (new_host_filespec, filespec, MAXPATH);
2979     }
2980   else
2981     {
2982       decc$to_vms (filespec, translate_unix, 1, 1);
2983       strncpy (new_host_filespec, filename_buff, MAXPATH);
2984     }
2985
2986   new_host_filespec [MAXPATH - 1] = (char) 0;
2987
2988   return new_host_filespec;
2989 }
2990
2991 void
2992 __gnat_adjust_os_resource_limits ()
2993 {
2994   SYS$ADJWSL (131072, 0);
2995 }
2996
2997 #else /* VMS */
2998
2999 /* Dummy functions for Osint import for non-VMS systems.  */
3000
3001 int
3002 __gnat_to_canonical_file_list_init
3003   (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED)
3004 {
3005   return 0;
3006 }
3007
3008 char *
3009 __gnat_to_canonical_file_list_next (void)
3010 {
3011   return (char *) "";
3012 }
3013
3014 void
3015 __gnat_to_canonical_file_list_free (void)
3016 {
3017 }
3018
3019 char *
3020 __gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3021 {
3022   return dirspec;
3023 }
3024
3025 char *
3026 __gnat_to_canonical_file_spec (char *filespec)
3027 {
3028   return filespec;
3029 }
3030
3031 char *
3032 __gnat_to_canonical_path_spec (char *pathspec)
3033 {
3034   return pathspec;
3035 }
3036
3037 char *
3038 __gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
3039 {
3040   return dirspec;
3041 }
3042
3043 char *
3044 __gnat_to_host_file_spec (char *filespec)
3045 {
3046   return filespec;
3047 }
3048
3049 void
3050 __gnat_adjust_os_resource_limits (void)
3051 {
3052 }
3053
3054 #endif
3055
3056 /* For EMX, we cannot include dummy in libgcc, since it is too difficult
3057    to coordinate this with the EMX distribution. Consequently, we put the
3058    definition of dummy which is used for exception handling, here.  */
3059
3060 #if defined (__EMX__)
3061 void __dummy () {}
3062 #endif
3063
3064 #if defined (__mips_vxworks)
3065 int
3066 _flush_cache()
3067 {
3068    CACHE_USER_FLUSH (0, ENTIRE_CACHE);
3069 }
3070 #endif
3071
3072 #if defined (CROSS_DIRECTORY_STRUCTURE)  \
3073   || (! ((defined (sparc) || defined (i386)) && defined (sun) \
3074       && defined (__SVR4)) \
3075       && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
3076       && ! (defined (linux) && defined (__ia64__)) \
3077       && ! (defined (linux) && defined (powerpc)) \
3078       && ! defined (__FreeBSD__) \
3079       && ! defined (__hpux__) \
3080       && ! defined (__APPLE__) \
3081       && ! defined (_AIX) \
3082       && ! (defined (__alpha__)  && defined (__osf__)) \
3083       && ! defined (VMS) \
3084       && ! defined (__MINGW32__) \
3085       && ! (defined (__mips) && defined (__sgi)))
3086
3087 /* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
3088    just above for a list of native platforms that provide a non-dummy
3089    version of this procedure in libaddr2line.a.  */
3090
3091 void
3092 convert_addresses (const char *file_name ATTRIBUTE_UNUSED,
3093                    void *addrs ATTRIBUTE_UNUSED,
3094                    int n_addr ATTRIBUTE_UNUSED,
3095                    void *buf ATTRIBUTE_UNUSED,
3096                    int *len ATTRIBUTE_UNUSED)
3097 {
3098   *len = 0;
3099 }
3100 #endif
3101
3102 #if defined (_WIN32)
3103 int __gnat_argument_needs_quote = 1;
3104 #else
3105 int __gnat_argument_needs_quote = 0;
3106 #endif
3107
3108 /* This option is used to enable/disable object files handling from the
3109    binder file by the GNAT Project module. For example, this is disabled on
3110    Windows (prior to GCC 3.4) as it is already done by the mdll module.
3111    Stating with GCC 3.4 the shared libraries are not based on mdll
3112    anymore as it uses the GCC's -shared option  */
3113 #if defined (_WIN32) \
3114     && ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
3115 int __gnat_prj_add_obj_files = 0;
3116 #else
3117 int __gnat_prj_add_obj_files = 1;
3118 #endif
3119
3120 /* char used as prefix/suffix for environment variables */
3121 #if defined (_WIN32)
3122 char __gnat_environment_char = '%';
3123 #else
3124 char __gnat_environment_char = '$';
3125 #endif
3126
3127 /* This functions copy the file attributes from a source file to a
3128    destination file.
3129
3130    mode = 0  : In this mode copy only the file time stamps (last access and
3131                last modification time stamps).
3132
3133    mode = 1  : In this mode, time stamps and read/write/execute attributes are
3134                copied.
3135
3136    Returns 0 if operation was successful and -1 in case of error. */
3137
3138 int
3139 __gnat_copy_attribs (char *from, char *to, int mode)
3140 {
3141 #if defined (VMS) || defined (__vxworks) || defined (__nucleus__)
3142   return -1;
3143 #else
3144   struct stat fbuf;
3145   struct utimbuf tbuf;
3146
3147   if (stat (from, &fbuf) == -1)
3148     {
3149       return -1;
3150     }
3151
3152   tbuf.actime = fbuf.st_atime;
3153   tbuf.modtime = fbuf.st_mtime;
3154
3155   if (utime (to, &tbuf) == -1)
3156     {
3157       return -1;
3158     }
3159
3160   if (mode == 1)
3161     {
3162       if (chmod (to, fbuf.st_mode) == -1)
3163         {
3164           return -1;
3165         }
3166     }
3167
3168   return 0;
3169 #endif
3170 }
3171
3172 int
3173 __gnat_lseek (int fd, long offset, int whence)
3174 {
3175   return (int) lseek (fd, offset, whence);
3176 }
3177
3178 /* This function returns the major version number of GCC being used.  */
3179 int
3180 get_gcc_version (void)
3181 {
3182 #ifdef IN_RTS
3183   return __GNUC__;
3184 #else
3185   return (int) (version_string[0] - '0');
3186 #endif
3187 }
3188
3189 int
3190 __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED,
3191                         int close_on_exec_p ATTRIBUTE_UNUSED)
3192 {
3193 #if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
3194   int flags = fcntl (fd, F_GETFD, 0);
3195   if (flags < 0)
3196     return flags;
3197   if (close_on_exec_p)
3198     flags |= FD_CLOEXEC;
3199   else
3200     flags &= ~FD_CLOEXEC;
3201   return fcntl (fd, F_SETFD, flags | FD_CLOEXEC);
3202 #else
3203   return -1;
3204   /* For the Windows case, we should use SetHandleInformation to remove
3205      the HANDLE_INHERIT property from fd. This is not implemented yet,
3206      but for our purposes (support of GNAT.Expect) this does not matter,
3207      as by default handles are *not* inherited. */
3208 #endif
3209 }
3210
3211 /* Indicates if platforms supports automatic initialization through the
3212    constructor mechanism */
3213 int
3214 __gnat_binder_supports_auto_init ()
3215 {
3216 #ifdef VMS
3217    return 0;
3218 #else
3219    return 1;
3220 #endif
3221 }
3222
3223 /* Indicates that Stand-Alone Libraries are automatically initialized through
3224    the constructor mechanism */
3225 int
3226 __gnat_sals_init_using_constructors ()
3227 {
3228 #if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
3229    return 0;
3230 #else
3231    return 1;
3232 #endif
3233 }
3234
3235 #ifdef RTX
3236
3237 /* In RTX mode, the procedure to get the time (as file time) is different
3238    in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file,
3239    we introduce an intermediate procedure to link against the corresponding
3240    one in each situation. */
3241
3242 extern void GetTimeAsFileTime(LPFILETIME pTime);
3243
3244 void GetTimeAsFileTime(LPFILETIME pTime)
3245 {
3246 #ifdef RTSS
3247   RtGetRtssTimeAsFileTime (pTime); /* RTSS interface */
3248 #else
3249   GetSystemTimeAsFileTime (pTime); /* w32 interface */
3250 #endif
3251 }
3252
3253 #ifdef RTSS
3254 /* Add symbol that is required to link. It would otherwise be taken from
3255    libgcc.a and it would try to use the gcc constructors that are not
3256    supported by Microsoft linker. */
3257
3258 extern void __main (void);
3259
3260 void __main (void) {}
3261 #endif
3262 #endif
3263
3264 #if defined (linux) || defined(__GLIBC__)
3265 /* pthread affinity support */
3266
3267 int __gnat_pthread_setaffinity_np (pthread_t th,
3268                                    size_t cpusetsize,
3269                                    const void *cpuset);
3270
3271 #ifdef CPU_SETSIZE
3272 #include <pthread.h>
3273 int
3274 __gnat_pthread_setaffinity_np (pthread_t th,
3275                                size_t cpusetsize,
3276                                const cpu_set_t *cpuset)
3277 {
3278   return pthread_setaffinity_np (th, cpusetsize, cpuset);
3279 }
3280 #else
3281 int
3282 __gnat_pthread_setaffinity_np (pthread_t th ATTRIBUTE_UNUSED,
3283                                size_t cpusetsize ATTRIBUTE_UNUSED,
3284                                const void *cpuset ATTRIBUTE_UNUSED)
3285 {
3286   return 0;
3287 }
3288 #endif
3289 #endif