gcc/ada/adaint.c

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