ghc/interpreter/machdep.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Machine dependent code
   4  * RISCOS specific code provided by Bryan Scatergood, JBS
   5  * Macintosh specific code provided by Hans Aberg (haberg@matematik.su.se)
   6  * HaskellScript code and recursive directory search provided by
   7  *  Daan Leijen (leijen@fwi.uva.nl)
   8  *
   9  * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
  10  * Yale Haskell Group, and the Oregon Graduate Institute of Science and
  11  * Technology, 1994-1999, All rights reserved.  It is distributed as
  12  * free software under the license in the file "License", which is
  13  * included in the distribution.
  14  *
  15  * $RCSfile: machdep.c,v $
  16  * $Revision: 1.27 $
  17  * $Date: 2000/04/05 16:57:18 $
  18  * ------------------------------------------------------------------------*/
  19
  20 #ifdef HAVE_SIGNAL_H
  21 # include <signal.h>
  22 #endif
  23 #ifdef HAVE_SYS_TYPES_H
  24 # include <sys/types.h>
  25 #else
  26 # ifdef HAVE_TYPES_H
  27 #  include <types.h>
  28 # endif
  29 #endif
  30 #if HAVE_SYS_PARAM_H
  31 # include <sys/param.h>
  32 #endif
  33 #ifdef HAVE_SYS_STAT_H
  34 # include <sys/stat.h>
  35 #else
  36 # ifdef HAVE_STAT_H
  37 #  include <stat.h>
  38 # endif
  39 #endif
  40 #ifdef HAVE_TIME_H
  41 # include <time.h>
  42 #endif
  43
  44 /* Windows/DOS include files */
  45 #ifdef HAVE_DOS_H
  46 # include <dos.h>
  47 #endif
  48 #if defined HAVE_CONIO_H
  49 # include <conio.h>
  50 #endif
  51 #ifdef HAVE_IO_H
  52 # include <io.h>
  53 #endif
  54 #ifdef HAVE_STD_H
  55 # include <std.h>
  56 #endif
  57 #ifdef HAVE_WINDOWS_H
  58 # include <windows.h>
  59 #endif
  60
  61 #if DOS
  62 #include <mem.h>
  63 extern unsigned _stklen = 8000;         /* Allocate an 8k stack segment    */
  64 #endif
  65
  66 #if RISCOS
  67 #include "swis.h"
  68 #include "os.h"
  69 #endif
  70
  71 /* Macintosh include files */
  72 #ifdef HAVE_CONSOLE_H
  73 # include <console.h>
  74 #endif
  75 #ifdef HAVE_PASCAL_H
  76 # include <pascal.h>
  77 #endif
  78 #ifdef HAVE_FILES_H
  79 # include <Files.h>
  80 #endif
  81 #ifdef HAVE_FCNTL_H
  82 # include <fcntl.h>
  83 #endif
  84 #ifdef HAVE_ERRNO_H
  85 # include <errno.h>
  86 #endif
  87 #ifdef HAVE_STDLIB_H
  88 # include <stdlib.h>
  89 #endif
  90 #ifdef HAVE_UNIX_H
  91 #include <unix.h>
  92 #endif
  93 #if SYMANTEC_C
  94 int allow_break_count = 0;
  95 #endif
  96
  97 /* --------------------------------------------------------------------------
  98  * Prototypes for registry reading
  99  * ------------------------------------------------------------------------*/
 100
 101 #if USE_REGISTRY
 102
 103 /* where have we hidden things in the registry? */
 104 #if HSCRIPT
 105 #define HScriptRoot ("SOFTWARE\\Haskell\\HaskellScript\\")
 106 #endif
 107
 108 #define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
 109 #define ProjectRoot ("SOFTWARE\\Haskell\\Projects\\")
 110
 111 static Bool   local createKey      ( HKEY, String, PHKEY, REGSAM );
 112 static Bool   local queryValue     ( HKEY, String, String, LPDWORD, LPBYTE, DWORD );
 113 static Bool   local setValue       ( HKEY, String, String, DWORD, LPBYTE, DWORD );
 114 static String local readRegString  ( HKEY, String, String, String );
 115 static Int    local readRegInt     ( String,Int );
 116 static Bool   local writeRegString ( String,String );
 117 static Bool   local writeRegInt    ( String,Int );
 118
 119 static String local readRegChildStrings ( HKEY, String, String, Char, String );
 120 #endif /* USE_REGISTRY */
 121
 122 /* --------------------------------------------------------------------------
 123  * Find information about a file:
 124  * ------------------------------------------------------------------------*/
 125
 126 #include "machdep_time.h"
 127
 128 static Bool local readable      ( String );
 129 static Void local getFileInfo   ( String, Time *, Long * );
 130
 131 static Void local getFileInfo(f,tm,sz)  /* find time stamp and size of file*/
 132 String f;
 133 Time   *tm;
 134 Long   *sz; {
 135 #if defined HAVE_SYS_STAT_H || defined HAVE_STAT_H || defined HAVE_UNIX_H
 136     struct stat scbuf;
 137     if (!stat(f,&scbuf)) {
 138         if (tm) *tm = scbuf.st_mtime;
 139         *sz = (Long)(scbuf.st_size);
 140     } else {
 141         if (tm) *tm = 0;
 142         *sz = 0;
 143     }
 144 #else                                   /* normally just use stat()        */
 145     os_regset r;                        /* RISCOS PRM p.850 and p.837      */
 146     r.r[0] = 17;                        /* Read catalogue, no path         */
 147     r.r[1] = (int)s;
 148     os_swi(OS_File, &r);
 149     if(r.r[0] == 1 && (r.r[2] & 0xFFF00000) == 0xFFF00000) {
 150         if (tm) tm->hi = r.r[2] & 0xFF; /* Load address (high byte)        */
 151         if (tm) tm->lo = r.r[3];        /* Execution address (low 4 bytes) */
 152     } else {                            /* Not found, or not time-stamped  */
 153         if (tm) tm->hi = tm->lo = 0;
 154     }
 155     *sz = (Long)(r.r[0] == 1 ? r.r[4] : 0);
 156 #endif
 157 }
 158
 159 Void getFileSize ( String f, Long* sz )
 160 {
 161    getFileInfo ( f, NULL, sz );
 162 }
 163
 164 #if defined HAVE_GETFINFO               /* Mac971031 */
 165 /* --------------------------------------------------------------------------
 166  * Define a MacOS version of access():
 167  *   If the file is not accessible, -1 is returned and errno is set to
 168  * the reason for the failure.
 169  *   If the file is accessible and the dummy is 0 (existence), 2 (write),
 170  * or 4 (read), the return is 0.
 171  *   If the file is accessible, and the dummy is 1 (executable), then if
 172  * the file is a program (of type 'APPL'), the return is 0, otherwise -1.
 173  *   Warnings: Use with caution. UNIX access do no translate to Macs.
 174  * Check of write access is not implemented (same as read).
 175  * ------------------------------------------------------------------------*/
 176
 177 int access(char *fileName, int dummy) {
 178         FInfo   fi;
 179         short   rc;
 180
 181         errno = getfinfo(fileName, 0, &fi);
 182         if (errno != 0)  return -1;             /* Check file accessible. */
 183
 184         /* Cases dummy = existence, read, write. */
 185         if (dummy == 0 || dummy & 0x6)  return 0;
 186
 187         /* Case dummy = executable. */
 188         if (dummy == 1) {
 189                 if (fi.fdType == 'APPL')  return 0;
 190                 errno = fi.fdType;
 191                 return -1;
 192         }
 193
 194         return 0;
 195 }
 196 #endif
 197
 198 static Bool local readable(f)           /* is f a regular, readable file   */
 199 String f; {
 200 #if DJGPP2 || defined HAVE_GETFINFO /* stat returns bogus mode bits on djgpp2 */
 201     return (0 == access(f,4));
 202 #elif defined HAVE_SYS_STAT_H || defined HAVE_STAT_H
 203     struct stat scbuf;
 204     /* fprintf(stderr, "readable: %s\n", f ); */
 205     return (  !stat(f,&scbuf)
 206            && (scbuf.st_mode & S_IREAD) /* readable     */
 207            && (scbuf.st_mode & S_IFREG) /* regular file */
 208            );
 209 #elif defined HAVE_OS_SWI /* RISCOS specific */
 210     os_regset r;                        /* RISCOS PRM p.850     -- JBS     */
 211     assert(dummy == 0);
 212     r.r[0] = 17; /* Read catalogue, no path */
 213     r.r[1] = (int)f;
 214     os_swi(OS_File, &r);
 215     return r.r[0] != 1; /* Does this check it's a regular file? ADR */
 216 #endif
 217 }
 218
 219
 220 /* --------------------------------------------------------------------------
 221  * Search for script files on the HUGS path:
 222  * ------------------------------------------------------------------------*/
 223
 224 static String local hugsdir       ( Void );
 225 #if HSCRIPT
 226 static String local hscriptDir    ( Void );
 227 #endif
 228 static int    local pathCmp       ( String, String );
 229 static String local normPath      ( String );
 230 static Void   local searchChr     ( Int );
 231 static Void   local searchStr     ( String );
 232 static Bool   local tryEndings    ( String );
 233
 234 #if (DOS_FILENAMES || __CYGWIN32__)
 235 # define SLASH                   '\\'
 236 # define isSLASH(c)              ((c)=='\\' || (c)=='/')
 237 # define PATHSEP                 ';'
 238 # define PATHSEP_STR             ";"
 239 # define DLL_ENDING              ".dll"
 240 #elif MAC_FILENAMES
 241 # define SLASH                   ':'
 242 # define isSLASH(c)              ((c)==SLASH)
 243 # define PATHSEP                 ';'
 244 # define PATHSEP_STR             ";"
 245 /* Mac PEF (Preferred Executable Format) file */
 246 # define DLL_ENDING              ".pef"
 247 #else
 248 # define SLASH                   '/'
 249 # define isSLASH(c)              ((c)==SLASH)
 250 # define PATHSEP                 ':'
 251 # define PATHSEP_STR             ":"
 252 # define DLL_ENDING              ".u_o"
 253 #endif
 254
 255 static String local hugsdir() {     /* directory containing lib/Prelude.hs */
 256 #if HSCRIPT
 257     /* In HaskellScript (Win32 only), we lookup InstallDir in the registry. */
 258     static char dir[FILENAME_MAX+1] = "";
 259     if (dir[0] == '\0') { /* not initialised yet */
 260         String s = readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"InstallDir",
 261                                  HUGSDIR);
 262         if (s) {
 263             strcpy(dir,s);
 264         }
 265     }
 266     return dir;
 267 #elif HAVE_GETMODULEFILENAME && !DOS && !__CYGWIN32__
 268     /* On Windows, we can find the binary we're running and it's
 269      * conventional to put the libraries in the same place.
 270      */
 271     static char dir[FILENAME_MAX+1] = "";
 272     if (dir[0] == '\0') { /* not initialised yet */
 273         String slash = 0;
 274         GetModuleFileName((HMODULE)0,dir,FILENAME_MAX+1);
 275         if (dir[0] == '\0') { /* GetModuleFileName must have failed */
 276             return HUGSDIR;
 277         }
 278         slash = strrchr(dir,SLASH);
 279         if (slash) { /* truncate after directory name */
 280             *slash = '\0';
 281         }
 282     }
 283     return dir;
 284 #else
 285     /* On Unix systems, we can't find the binary we're running and
 286      * the libraries may not be installed near the binary anyway.
 287      * This forces us to use a hardwired path which is set at
 288      * configuration time (--datadir=...).
 289      */
 290     return HUGSDIR;
 291 #endif
 292 }
 293
 294 #if HSCRIPT
 295 static String local hscriptDir() {  /* Directory containing hscript.dll    */
 296     static char dir[FILENAME_MAX+1] = "";
 297     if (dir[0] == '\0') { /* not initialised yet */
 298         String s = readRegString(HKEY_LOCAL_MACHINE,HScriptRoot,"InstallDir","");
 299         if (s) {
 300             strcpy(dir,s);
 301         }
 302     }
 303     return dir;
 304 }
 305 #endif
 306
 307 #if 0  /* apparently unused */
 308 static String local RealPath(s)         /* Find absolute pathname of file  */
 309 String s; {
 310 #if HAVE__FULLPATH  /* eg DOS */
 311     static char path[FILENAME_MAX+1];
 312     _fullpath(path,s,FILENAME_MAX+1);
 313 #elif HAVE_REALPATH /* eg Unix */
 314     static char path[MAXPATHLEN+1];
 315     realpath(s,path);
 316 #else
 317     static char path[FILENAME_MAX+1];
 318     strcpy(path,s);
 319 #endif
 320     return path;
 321 }
 322 #endif
 323
 324
 325 static int local pathCmp(p1,p2)       /* Compare paths after normalisation */
 326 String p1;
 327 String p2; {
 328 #if HAVE__FULLPATH  /* eg DOS */
 329     static char path1[FILENAME_MAX+1];
 330     static char path2[FILENAME_MAX+1];
 331     _fullpath(path1,p1,FILENAME_MAX+1);
 332     _fullpath(path2,p2,FILENAME_MAX+1);
 333 #elif HAVE_REALPATH /* eg Unix */
 334     static char path1[MAXPATHLEN+1];
 335     static char path2[MAXPATHLEN+1];
 336     realpath(p1,path1);
 337     realpath(p2,path2);
 338 #else
 339     static char path1[FILENAME_MAX+1];
 340     static char path2[FILENAME_MAX+1];
 341     strcpy(path1,p1);
 342     strcpy(path2,p2);
 343 #endif
 344 #if CASE_INSENSITIVE_FILENAMES
 345     strlwr(path1);
 346     strlwr(path2);
 347 #endif
 348     return filenamecmp(path1,path2);
 349 }
 350
 351 static String local normPath(s) /* Try, as much as possible, to normalize  */
 352 String s; {                     /* a pathname in some appropriate manner.  */
 353 #if PATH_CANONICALIZATION
 354     String path = RealPath(s);
 355 #if CASE_INSENSITIVE_FILENAMES
 356     strlwr(path);                       /* and convert to lowercase        */
 357 #endif
 358     return path;
 359 #else /* ! PATH_CANONICALIZATION */
 360     return s;
 361 #endif /* ! PATH_CANONICALIZATION */
 362 }
 363
 364 #if HSCRIPT
 365 static String endings[] = { "", ".u_hi", ".hs", ".lhs", ".hsx", ".hash", 0 };
 366 #else
 367 static String endings[] = { "", ".u_hi", ".hs", ".lhs", 0 };
 368 #endif
 369 static char   searchBuf[FILENAME_MAX+1];
 370 static Int    searchPos;
 371
 372 #define searchReset(n)          searchBuf[searchPos=(n)]='\0'
 373
 374 static Void local searchChr(c)  /* Add single character to search buffer   */
 375 Int c; {
 376     if (searchPos<FILENAME_MAX) {
 377         searchBuf[searchPos++] = (char)c;
 378         searchBuf[searchPos]   = '\0';
 379     }
 380 }
 381
 382 static Void local searchStr(s)  /* Add string to search buffer             */
 383 String s; {
 384     while (*s && searchPos<FILENAME_MAX)
 385         searchBuf[searchPos++] = *s++;
 386     searchBuf[searchPos] = '\0';
 387 }
 388
 389 static Bool local tryEndings(s) /* Try each of the listed endings          */
 390 String s; {
 391     Int i = 0;
 392     searchStr(s);
 393     for (; endings[i]; ++i) {
 394         Int save = searchPos;
 395         searchStr(endings[i]);
 396         if (readable(searchBuf))
 397             return TRUE;
 398         searchReset(save);
 399     }
 400     return FALSE;
 401 }
 402
 403
 404
 405 #if SEARCH_DIR
 406
 407 /* scandir, June 98 Daan Leijen
 408    searches the base directory and its direct subdirectories for a file
 409
 410    input: searchbuf contains SLASH terminated base directory
 411           argument s contains the (base) filename
 412    output: TRUE: searchBuf contains the full filename
 413            FALSE: searchBuf is garbage, file not found
 414 */
 415
 416
 417 #ifdef HAVE_WINDOWS_H
 418
 419 static Bool scanSubDirs(s)
 420 String s;
 421 {
 422     struct _finddata_t findInfo;
 423     long handle;
 424     int  save;
 425
 426     save = searchPos;
 427     /* is it in the current directory ? */
 428     if (tryEndings(s)) return TRUE;
 429
 430     searchReset(save);
 431     searchStr("*");
 432
 433     /* initiate the search */
 434     handle = _findfirst( searchBuf, &findInfo );
 435     if (handle==-1) { errno = 0; return FALSE; }
 436
 437     /* search all subdirectories */
 438     do {
 439         /* if we have a valid sub directory */
 440         if (((findInfo.attrib & _A_SUBDIR) == _A_SUBDIR) &&
 441             (findInfo.name[0] != '.')) {
 442             searchReset(save);
 443             searchStr(findInfo.name);
 444             searchChr(SLASH);
 445             if (tryEndings(s)) {
 446                 return TRUE;
 447             }
 448         }
 449     } while (_findnext( handle, &findInfo ) == 0);
 450
 451     _findclose( handle );
 452     return FALSE;
 453 }
 454
 455 #elif defined(HAVE_FTW_H)
 456
 457 #include <ftw.h>
 458
 459 static char baseFile[FILENAME_MAX+1];
 460 static char basePath[FILENAME_MAX+1];
 461 static int  basePathLen;
 462
 463 static int scanitem( const char* path,
 464                      const struct stat* statinfo,
 465                      int info )
 466 {
 467     if (info == FTW_D) { /* is it a directory */
 468         searchReset(0);
 469         searchStr(path);
 470         searchChr(SLASH);
 471         if (tryEndings(baseFile)) {
 472             return 1;
 473         }
 474     }
 475     return 0;
 476 }
 477
 478 static Bool scanSubDirs(s)
 479 String s;
 480 {
 481     int r;
 482     strcpy(baseFile,s);
 483     strcpy(basePath,searchBuf);
 484     basePathLen = strlen(basePath);
 485
 486     /* is it in the current directory ? */
 487     if (tryEndings(s)) return TRUE;
 488
 489     /* otherwise scan the subdirectories */
 490     r = ftw( basePath, scanitem, 2 );
 491     errno = 0;
 492     return (r > 0);
 493 }
 494
 495 #endif /* HAVE_WINDOWS_H || HAVE_FTW_H */
 496 #endif /* SEARCH_DIR */
 497
 498 String findPathname(along,nm)   /* Look for a file along specified path    */
 499 String along;                   /* Return NULL if file does not exist      */
 500 String nm; {
 501     /* AC, 1/21/99: modified to search hugsPath first, then projectPath */
 502     String s = findMPathname(along,nm,hugsPath);
 503 #if USE_REGISTRY
 504 #if 0
 505  ToDo:
 506     if (s==NULL) {
 507         s = findMPathname(along,nm,projectPath);
 508     }
 509 #endif /* 0 */
 510 #endif /* USE_REGISTRY */
 511     return s ? s : normPath(searchBuf);
 512 }
 513
 514 /* AC, 1/21/99: modified to pass in path to search explicitly */
 515 String findMPathname(along,nm,path)/* Look for a file along specified path   */
 516 String along;                   /* If nonzero, a path prefix from along is */
 517 String nm;                      /* used as the first prefix in the search. */
 518 String path; {
 519     String pathpt = path;
 520
 521     searchReset(0);
 522     if (along) {                /* Was a path for an existing file given?  */
 523         Int last = (-1);
 524         Int i    = 0;
 525         for (; along[i]; i++) {
 526             searchChr(along[i]);
 527             if (isSLASH(along[i]))
 528                 last = i;
 529         }
 530         searchReset(last+1);
 531     }
 532     if (tryEndings(nm))
 533         return normPath(searchBuf);
 534
 535     if (pathpt && *pathpt) {    /* Otherwise, we look along the HUGSPATH   */
 536         Bool more = TRUE;
 537         do {
 538             Bool recurse = FALSE;   /* DL: shall we recurse ? */
 539             searchReset(0);
 540             if (*pathpt) {
 541                 if (*pathpt!=PATHSEP) {
 542                     /* Pre-define one MPW-style "shell-variable" */
 543                     if (strncmp(pathpt,"{Hugs}",6)==0) {
 544                         searchStr(hugsdir());
 545                         pathpt += 6;
 546                     }
 547 #if HSCRIPT
 548                     /* And another - we ought to generalise this stuff */
 549                     else if (strncmp(pathpt,"{HScript}",9)==0) {
 550                         searchStr(hscriptDir());
 551                         pathpt += 9;
 552                     }
 553 #endif
 554                     do {
 555                         searchChr(*pathpt++);
 556                     } while (*pathpt && *pathpt!=PATHSEP);
 557                     recurse = (pathpt[-1] == SLASH);
 558                     if (!recurse) {
 559                         searchChr(SLASH);
 560                     }
 561                 }
 562                 if (*pathpt==PATHSEP)
 563                     pathpt++;
 564                 else
 565                     more = FALSE;
 566             } else {
 567                 more = FALSE;
 568             }
 569 #if SEARCH_DIR
 570             if (recurse ? scanSubDirs(nm) : tryEndings(nm)) {
 571                 return normPath(searchBuf);
 572             }
 573 #else
 574             if (tryEndings(nm)) {
 575                 return normPath(searchBuf);
 576             }
 577 #endif
 578         } while (more);
 579     }
 580
 581     searchReset(0);  /* As a last resort, look for file in the current dir */
 582     return (tryEndings(nm) ? normPath(searchBuf) : 0);
 583 }
 584
 585 /* --------------------------------------------------------------------------
 586  * New path handling stuff for the Combined System (tm)
 587  * ------------------------------------------------------------------------*/
 588
 589 char installDir[N_INSTALLDIR];
 590
 591 /* Sets installDir to $STGHUGSDIR, and ensures there is a trailing
 592    slash at the end.
 593 */
 594 void setInstallDir ( String argv_0 )
 595 {
 596    int   i;
 597    char* r = getenv("STGHUGSDIR");
 598    if (!r) {
 599       fprintf(stderr,
 600           "%s: installation error: environment variable STGHUGSDIR is not set.\n",
 601           argv_0 );
 602       fprintf(stderr,
 603           "%s: pls set it to be the directory where STGHugs98 is installed.\n\n",
 604           argv_0 );
 605       exit(2);
 606
 607    }
 608
 609    if (strlen(r) > N_INSTALLDIR-30 ) {
 610       fprintf(stderr,
 611           "%s: environment variable STGHUGSDIR is suspiciously long; pls remedy\n\n",
 612           argv_0 );
 613       exit(2);
 614    }
 615
 616    strcpy ( installDir, r );
 617    i = strlen(installDir);
 618    if (installDir[i-1] != SLASH) installDir[i++] = SLASH;
 619    installDir[i] = 0;
 620 }
 621
 622
 623 Bool findFilesForModule (
 624         String  modName,
 625         String* path,
 626         String* sExt,
 627         Bool* sAvail,  Time* sTime,  Long* sSize,
 628         Bool* oiAvail, Time* oiTime, Long* oSize, Long* iSize
 629      )
 630 {
 631    /* Let the module name given be M.
 632       For each path entry P,
 633         a  s(rc)       file will be P/M.hs or P/M.lhs
 634         an i(nterface) file will be P/M.hi
 635         an o(bject)    file will be P/M.o
 636       If there is a s file or (both i and o files)
 637         use P to fill in the path names.
 638       Otherwise, move on to the next path entry.
 639       If all path entries are exhausted, return False.
 640
 641       If in standalone, only look for (and succeed for) source modules.
 642       Caller free()s path.  sExt is statically allocated.
 643       srcExt is only set if a valid source file is found.
 644    */
 645    Int    nPath;
 646    Bool   literate;
 647    String peStart, peEnd;
 648    String augdPath;       /* .:hugsPath:installDir/GhcPrel:installDir/lib */
 649    Time   oTime,  iTime;
 650    Bool   oAvail, iAvail;
 651
 652    *path = *sExt = NULL;
 653    *sAvail = *oiAvail = oAvail = iAvail = FALSE;
 654    *sSize  = *oSize  = *iSize  = 0;
 655
 656    augdPath = malloc( 2*(10+3+strlen(installDir))
 657                       +strlen(hugsPath) +10/*paranoia*/);
 658    if (!augdPath)
 659       internal("moduleNameToFileNames: malloc failed(2)");
 660
 661    augdPath[0] = 0;
 662    strcat(augdPath, ".");
 663    strcat(augdPath, PATHSEP_STR);
 664
 665    strcat(augdPath, hugsPath);
 666    strcat(augdPath, PATHSEP_STR);
 667
 668    if (combined) {
 669       strcat(augdPath, installDir);
 670       strcat(augdPath, "GhcPrel");
 671       strcat(augdPath, PATHSEP_STR);
 672    }
 673
 674    strcat(augdPath, installDir);
 675    strcat(augdPath, "lib");
 676    strcat(augdPath, PATHSEP_STR);
 677
 678    /*   fprintf ( stderr, "augdpath = `%s'\n", augdPath ); */
 679
 680    peEnd = augdPath-1;
 681    while (1) {
 682       /* Advance peStart and peEnd very paranoically, giving up at
 683          the first sign of mutancy in the path string.
 684       */
 685       if (peEnd >= augdPath && !(*peEnd)) { free(augdPath); return FALSE; }
 686       peStart = peEnd+1;
 687       peEnd = peStart;
 688       while (*peEnd && *peEnd != PATHSEP) peEnd++;
 689
 690       /* Now peStart .. peEnd-1 bracket the next path element. */
 691       nPath = peEnd-peStart;
 692       if (nPath + strlen(modName) + 10 /*slush*/ > FILENAME_MAX) {
 693          ERRMSG(0) "Hugs path \"%s\" contains excessively long component",
 694                    hugsPath
 695          EEND;
 696          free(augdPath);
 697          return FALSE;
 698       }
 699
 700       strncpy(searchBuf, peStart, nPath);
 701       searchBuf[nPath] = 0;
 702       if (nPath > 0 && !isSLASH(searchBuf[nPath-1]))
 703          searchBuf[nPath++] = SLASH;
 704
 705       strcpy(searchBuf+nPath, modName);
 706       nPath += strlen(modName);
 707
 708       /* searchBuf now holds 'P/M'.  Try out the various endings. */
 709       *path = *sExt                         = NULL;
 710       *sAvail = *oiAvail = oAvail = iAvail  = FALSE;
 711       *sSize = *oSize = *iSize              = 0;
 712
 713       if (combined) {
 714          strcpy(searchBuf+nPath, DLL_ENDING);
 715          if (readable(searchBuf)) {
 716             oAvail = TRUE;
 717             getFileInfo(searchBuf, &oTime, oSize);
 718          }
 719          strcpy(searchBuf+nPath, HI_ENDING);
 720          if (readable(searchBuf)) {
 721             iAvail = TRUE;
 722             getFileInfo(searchBuf, &iTime, iSize);
 723          }
 724          if (oAvail && iAvail) {
 725             *oiAvail = TRUE;
 726             *oiTime = whicheverIsLater ( oTime, iTime );
 727          }
 728       }
 729
 730       strcpy(searchBuf+nPath, ".hs");
 731       if (readable(searchBuf)) {
 732          *sAvail = TRUE;
 733          literate = FALSE;
 734          getFileInfo(searchBuf, sTime, sSize);
 735          *sExt = ".hs";
 736       } else {
 737          strcpy(searchBuf+nPath, ".lhs");
 738          if (readable(searchBuf)) {
 739             *sAvail = TRUE;
 740             literate = TRUE;
 741             getFileInfo(searchBuf, sTime, sSize);
 742             *sExt = ".lhs";
 743          }
 744       }
 745
 746       /* Success? */
 747       if (*sAvail || *oiAvail) {
 748          nPath -= strlen(modName);
 749          *path = malloc(nPath+1);
 750          if (!(*path))
 751             internal("moduleNameToFileNames: malloc failed(1)");
 752          strncpy(*path, searchBuf, nPath);
 753          (*path)[nPath] = 0;
 754          free(augdPath);
 755          return TRUE;
 756       }
 757
 758    }
 759
 760 }
 761
 762
 763 /* If the primaryObjectName is (eg)
 764      /foo/bar/PrelSwamp.o
 765    and the extraFileName is (eg)
 766      swampy_cbits
 767    and DLL_ENDING is set to .o
 768    return
 769      /foo/bar/swampy_cbits.o
 770      and set *extraFileSize to its size, or -1 if not avail
 771 */
 772 String getExtraObjectInfo ( String primaryObjectName,
 773                             String extraFileName,
 774                             Int*   extraFileSize )
 775 {
 776    Time   xTime;
 777    Long   xSize;
 778    String xtra;
 779
 780    Int i = strlen(primaryObjectName)-1;
 781    while (i >= 0 && primaryObjectName[i] != SLASH) i--;
 782    if (i == -1) return extraFileName;
 783    i++;
 784    xtra = malloc ( i+3+strlen(extraFileName)+strlen(DLL_ENDING) );
 785    if (!xtra) internal("deriveExtraObjectName: malloc failed");
 786    strncpy ( xtra, primaryObjectName, i );
 787    xtra[i] = 0;
 788    strcat ( xtra, extraFileName );
 789    strcat ( xtra, DLL_ENDING );
 790
 791    *extraFileSize = -1;
 792    if (readable(xtra)) {
 793       getFileInfo ( xtra, &xTime, &xSize );
 794       *extraFileSize = xSize;
 795    }
 796    return xtra;
 797 }
 798
 799
 800 /* --------------------------------------------------------------------------
 801  * Substitute old value of path into empty entries in new path
 802  * eg substPath("a:b:c::d:e","x:y:z") = "a:b:c:x:y:z:d:e"
 803  * ------------------------------------------------------------------------*/
 804
 805 static String local substPath ( String,String );
 806
 807 static String local substPath(new,sub) /* substitute sub path into new path*/
 808 String new;
 809 String sub; {
 810     Bool   substituted = FALSE;            /*   only allow one replacement */
 811     Int    maxlen      = strlen(sub) + strlen(new);    /* safe upper bound */
 812     String r = (String) malloc(maxlen+1);  /* result string                */
 813     String t = r;                          /* pointer into r               */
 814     String next = new;                     /* next uncopied char in new    */
 815     String start = next;                   /* start of last path component */
 816     if (r == 0) {
 817         ERRMSG(0) "String storage space exhausted"
 818         EEND;
 819     }
 820     do {
 821         if (*next == PATHSEP || *next == '\0') {
 822             if (!substituted && next == start) {
 823                 String s = sub;
 824                 for(; *s != '\0'; ++s) {
 825                     *t++ = *s;
 826                 }
 827                 substituted = TRUE;
 828             }
 829             start = next+1;
 830         }
 831     } while ((*t++ = *next++) != '\0');
 832     return r;
 833 }
 834
 835
 836 /* --------------------------------------------------------------------------
 837  * Garbage collection notification:
 838  * ------------------------------------------------------------------------*/
 839
 840 Bool gcMessages = FALSE;                /* TRUE => print GC messages       */
 841
 842 Void gcStarted() {                      /* Notify garbage collector start  */
 843     if (gcMessages) {
 844         Printf("{{Gc");
 845         FlushStdout();
 846     }
 847 }
 848
 849 Void gcScanning() {                     /* Notify garbage collector scans  */
 850     if (gcMessages) {
 851         Putchar(':');
 852         FlushStdout();
 853     }
 854 }
 855
 856 Void gcRecovered(recovered)             /* Notify garbage collection done  */
 857 Int recovered; {
 858     if (gcMessages) {
 859         Printf("%d}}",recovered);
 860         FlushStdout();
 861     }
 862 }
 863
 864 Cell *CStackBase;                       /* Retain start of C control stack */
 865
 866 #if RISCOS                              /* Stack traversal for RISCOS      */
 867
 868 /* Warning: The following code is specific to the Acorn ARM under RISCOS
 869    (and C4).  We must explicitly walk back through the stack frames, since
 870    the stack is extended from the heap. (see PRM pp. 1757).  gcCStack must
 871    not be modified, since the offset '5' assumes that only v1 is used inside
 872    this function. Hence we do all the real work in gcARM.
 873 */
 874
 875 #define spreg 13 /* C3 has SP=R13 */
 876
 877 #define previousFrame(fp)       ((int *)((fp)[-3]))
 878 #define programCounter(fp)      ((int *)((*(fp)-12) & ~0xFC000003))
 879 #define isSubSPSP(w)            (((w)&dontCare) == doCare)
 880 #define doCare                  (0xE24DD000)  /* SUB r13,r13,#0 */
 881 #define dontCare                (~0x00100FFF) /* S and # bits   */
 882 #define immediateArg(x)         ( ((x)&0xFF) << (((x)&0xF00)>>7) )
 883
 884 static void gcARM(int *fp) {
 885     int si = *programCounter(fp);       /* Save instruction indicates how */
 886                                         /* many registers in this frame   */
 887     int *regs = fp - 4;
 888     if (si & (1<<0)) markWithoutMove(*regs--);
 889     if (si & (1<<1)) markWithoutMove(*regs--);
 890     if (si & (1<<2)) markWithoutMove(*regs--);
 891     if (si & (1<<3)) markWithoutMove(*regs--);
 892     if (si & (1<<4)) markWithoutMove(*regs--);
 893     if (si & (1<<5)) markWithoutMove(*regs--);
 894     if (si & (1<<6)) markWithoutMove(*regs--);
 895     if (si & (1<<7)) markWithoutMove(*regs--);
 896     if (si & (1<<8)) markWithoutMove(*regs--);
 897     if (si & (1<<9)) markWithoutMove(*regs--);
 898     if (previousFrame(fp)) {
 899         /* The non-register stack space is for the previous frame is above
 900            this fp, and not below the previous fp, because of the way stack
 901            extension works. It seems the only way of discovering its size is
 902            finding the SUB sp, sp, #? instruction by walking through the code
 903            following the entry point.
 904         */
 905         int *oldpc = programCounter(previousFrame(fp));
 906         int fsize = 0, i;
 907         for(i = 1; i < 6; ++i)
 908             if(isSubSPSP(oldpc[i])) fsize += immediateArg(oldpc[i]) / 4;
 909         for(i=1; i<=fsize; ++i)
 910             markWithoutMove(fp[i]);
 911     }
 912 }
 913
 914 void gcCStack() {
 915     int dummy;
 916     int *fp = 5 + &dummy;
 917     while (fp) {
 918         gcARM(fp);
 919         fp = previousFrame(fp);
 920     }
 921 }
 922
 923 #else                   /* Garbage collection for standard stack machines  */
 924
 925 Void gcCStack() {                       /* Garbage collect elements off    */
 926     Cell stackTop = NIL;                /* C stack                         */
 927     Cell *ptr = &stackTop;
 928 #if SIZEOF_VOID_P == 2
 929     if (((long)(ptr) - (long)(CStackBase))&1)
 930         fatal("gcCStack");
 931 #elif STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
 932     if (((long)(ptr) - (long)(CStackBase))&1)
 933         fatal("gcCStack");
 934 #else
 935     if (((long)(ptr) - (long)(CStackBase))&3)
 936         fatal("gcCStack");
 937 #endif
 938
 939 #define Blargh mark(*ptr);
 940 #if 0
 941                markWithoutMove((*ptr)/sizeof(Cell)); \
 942                markWithoutMove(( (void*)(*ptr)-(void*)heapTopFst)/sizeof(Cell));  \
 943                markWithoutMove(( (void*)(*ptr)-(void*)heapTopSnd)/sizeof(Cell))
 944 #endif
 945
 946 #define StackGrowsDown  { while (ptr<=CStackBase) { Blargh; ptr++; }; }
 947 #define StackGrowsUp    { while (ptr>=CStackBase) { Blargh; ptr--; }; }
 948 #define GuessDirection  if (ptr>CStackBase) StackGrowsUp else StackGrowsDown
 949
 950 #if STACK_DIRECTION > 0
 951     StackGrowsUp;
 952 #elif STACK_DIRECTION < 0
 953     StackGrowsDown;
 954 #else
 955     GuessDirection;
 956 #endif
 957
 958 #if SIZEOF_VOID_P==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
 959     ptr = (Cell *)((long)(&stackTop) + 2);
 960     StackGrowsDown;
 961 #endif
 962
 963 #undef  StackGrowsDown
 964 #undef  StackGrowsUp
 965 #undef  GuessDirection
 966 }
 967 #endif
 968
 969 /* --------------------------------------------------------------------------
 970  * Terminal dependent stuff:
 971  * ------------------------------------------------------------------------*/
 972
 973 #if (HAVE_TERMIO_H | HAVE_SGTTY_H | HAVE_TERMIOS_H)
 974
 975 /* grab the varargs prototype for ioctl */
 976 #if HAVE_SYS_IOCTL_H
 977 # include <sys/ioctl.h>
 978 #endif
 979
 980 /* The order of these three tests is very important because
 981  * some systems have more than one of the requisite header file
 982  * but only one of them seems to work.
 983  * Anyone changing the order of the tests should try enabling each of the
 984  * three branches in turn and write down which ones work as well as which
 985  * OS/compiler they're using.
 986  *
 987  * OS            Compiler      sgtty     termio  termios   notes
 988  * Linux 2.0.18  gcc 2.7.2     absent    works   works     1
 989  *
 990  * Notes:
 991  * 1) On Linux, termio.h just #includes termios.h and sgtty.h is
 992  *    implemented using termios.h.
 993  *    sgtty.h is in /usr/include/bsd which is not on my standard include
 994  *    path.  Adding it does no harm but you might as well use termios.
 995  *    --
 996  *    reid-alastair@cs.yale.edu
 997  */
 998 #if HAVE_TERMIOS_H
 999
1000 #include <termios.h>
1001 typedef  struct termios  TermParams;
1002 #define  getTerminal(tp) tcgetattr(fileno(stdin), &tp)
1003 #define  setTerminal(tp) tcsetattr(fileno(stdin), TCSAFLUSH, &tp)
1004 #define  noEcho(tp)      tp.c_lflag    &= ~(ICANON | ECHO); \
1005                          tp.c_cc[VMIN]  = 1;                \
1006                          tp.c_cc[VTIME] = 0;
1007
1008 #elif HAVE_SGTTY_H
1009
1010 #include <sgtty.h>
1011 typedef  struct sgttyb   TermParams;
1012 #define  getTerminal(tp) ioctl(fileno(stdin),TIOCGETP,&tp)
1013 #define  setTerminal(tp) ioctl(fileno(stdin),TIOCSETP,&tp)
1014 #if HPUX
1015 #define  noEcho(tp)      tp.sg_flags |= RAW; tp.sg_flags &= (~ECHO);
1016 #else
1017 #define  noEcho(tp)      tp.sg_flags |= CBREAK; tp.sg_flags &= (~ECHO);
1018 #endif
1019
1020 #elif HAVE_TERMIO_H
1021
1022 #include <termio.h>
1023 typedef  struct termio   TermParams;
1024 #define  getTerminal(tp) ioctl(fileno(stdin),TCGETA,&tp)
1025 #define  setTerminal(tp) ioctl(fileno(stdin),TCSETAF,&tp)
1026 #define  noEcho(tp)      tp.c_lflag    &= ~(ICANON | ECHO); \
1027                          tp.c_cc[VMIN]  = 1;                \
1028                          tp.c_cc[VTIME] = 0;
1029
1030 #endif
1031
1032 static Bool messedWithTerminal = FALSE;
1033 static TermParams originalSettings;
1034
1035 Void normalTerminal() {                 /* restore terminal initial state  */
1036     if (messedWithTerminal)
1037         setTerminal(originalSettings);
1038 }
1039
1040 Void noechoTerminal() {                 /* set terminal into noecho mode   */
1041     TermParams settings;
1042
1043     if (!messedWithTerminal) {
1044         getTerminal(originalSettings);
1045         messedWithTerminal = TRUE;
1046     }
1047     getTerminal(settings);
1048     noEcho(settings);
1049     setTerminal(settings);
1050 }
1051
1052 Int getTerminalWidth() {                /* determine width of terminal     */
1053 #ifdef TIOCGWINSZ
1054 #ifdef _M_UNIX                          /* SCO Unix 3.2.4 defines TIOCGWINSZ*/
1055 #include <sys/stream.h>                 /* Required by sys/ptem.h          */
1056 #include <sys/ptem.h>                   /* Required to declare winsize     */
1057 #endif
1058     static struct winsize terminalSize;
1059     ioctl(fileno(stdout),TIOCGWINSZ,&terminalSize);
1060     return (terminalSize.ws_col==0)? 80 : terminalSize.ws_col;
1061 #else
1062     return 80;
1063 #endif
1064 }
1065
1066 Int readTerminalChar() {                /* read character from terminal    */
1067     return getchar();                   /* without echo, assuming that     */
1068 }                                       /* noechoTerminal() is active...   */
1069
1070 #elif SYMANTEC_C
1071
1072 Int readTerminalChar() {                /* read character from terminal    */
1073     return getchar();                   /* without echo, assuming that     */
1074 }                                       /* noechoTerminal() is active...   */
1075
1076 Int getTerminalWidth() {
1077     return console_options.ncols;
1078 }
1079
1080 Void normalTerminal() {
1081     csetmode(C_ECHO, stdin);
1082 }
1083
1084 Void noechoTerminal() {
1085     csetmode(C_NOECHO, stdin);
1086 }
1087
1088 #else /* no terminal driver - eg DOS, RISCOS */
1089
1090 static Bool terminalEchoReqd = TRUE;
1091
1092 Int getTerminalWidth() {
1093 #if RISCOS
1094     int dummy, width;
1095     (void) os_swi3r(OS_ReadModeVariable, -1, 1, 0, &dummy, &dummy, &width);
1096     return width+1;
1097 #else
1098     return 80;
1099 #endif
1100 }
1101
1102 Void normalTerminal() {                 /* restore terminal initial state  */
1103     terminalEchoReqd = TRUE;
1104 }
1105
1106 Void noechoTerminal() {                 /* turn terminal echo on/off       */
1107     terminalEchoReqd = FALSE;
1108 }
1109
1110 Int readTerminalChar() {                /* read character from terminal    */
1111     if (terminalEchoReqd) {
1112         return getchar();
1113     } else {
1114 #if IS_WIN32 && !__BORLANDC__
1115         /* When reading a character from the console/terminal, we want
1116          * to operate in 'raw' mode (to use old UNIX tty parlance) and have
1117          * it return when a character is available and _not_ wait until
1118          * the next time the user hits carriage return. On Windows platforms,
1119          * this _can_ be done by reading directly from the console, using
1120          * getch().  However, this doesn't sit well with programming
1121          * environments such as Emacs which allow you to create sub-processes
1122          * running Hugs, and then communicate with the running interpreter
1123          * through its standard input and output handles. If you use getch()
1124          * in that setting, you end up trying to read the (unused) console
1125          * of the editor itself, through which not a lot of characters is
1126          * bound to come out, since the editor communicates input to Hugs
1127          * via the standard input handle.
1128          *
1129          * To avoid this rather unfortunate situation, we use the Win32
1130          * console API and re-jig the input properties of the standard
1131          * input handle before trying to read a character using stdio's
1132          * getchar().
1133          *
1134          * The 'cost' of this solution is that it is Win32 specific and
1135          * won't work with Windows 3.1 + it is kind of ugly and verbose
1136          * to have to futz around with the console properties on a
1137          * per-char basis. Both of these disadvantages aren't in my
1138          * opinion fatal.
1139          *
1140          * -- sof 5/99
1141          */
1142         Int c;
1143         DWORD mo;
1144         HANDLE hIn;
1145
1146         /* I don't quite understand why, but if the FILE*'s underlying file
1147            descriptor is in text mode, we seem to lose the first carriage
1148            return.
1149          */
1150         setmode(fileno(stdin), _O_BINARY);
1151         hIn = GetStdHandle(STD_INPUT_HANDLE);
1152         GetConsoleMode(hIn, &mo);
1153         SetConsoleMode(hIn, mo & ~(ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT));
1154         /*
1155          * On Win9x, the first time you change the mode (as above) a
1156          * raw '\n' is inserted.  Since enter maps to a raw '\r', and we
1157          * map this (below) to '\n', we can just ignore all *raw* '\n's.
1158          */
1159         do {
1160           c = getc(stdin);
1161         } while (c == '\n');
1162
1163         /* Same as it ever was - revert back state of stdin. */
1164         SetConsoleMode(hIn, mo);
1165         setmode(fileno(stdin), _O_TEXT);
1166 #else
1167         Int c = getch();
1168 #endif
1169         return c=='\r' ? '\n' : c;      /* slight paranoia about CR-LF    */
1170     }
1171 }
1172
1173 #endif /* no terminal driver */
1174
1175 /* --------------------------------------------------------------------------
1176  * Interrupt handling:
1177  * ------------------------------------------------------------------------*/
1178
1179 static Void installHandlers ( void ) { /* Install handlers for all fatal   */
1180                                       /* signals except SIGINT and SIGBREAK*/
1181 #if IS_WIN32
1182     /* SetConsoleCtrlHandler(consoleHandler,TRUE); */
1183 #endif
1184 #if !DONT_PANIC && !DOS
1185 # ifdef SIGABRT
1186     signal(SIGABRT,panic);
1187 # endif
1188 # ifdef SIGBUS
1189     signal(SIGBUS,panic);
1190 # endif
1191 # ifdef SIGFPE
1192     signal(SIGFPE,panic);
1193 # endif
1194 # ifdef SIGHUP
1195     signal(SIGHUP,panic);
1196 # endif
1197 # ifdef SIGILL
1198     signal(SIGILL,panic);
1199 # endif
1200 # ifdef SIGQUIT
1201     signal(SIGQUIT,panic);
1202 # endif
1203 # ifdef SIGSEGV
1204     signal(SIGSEGV,panic);
1205 # endif
1206 # ifdef SIGTERM
1207     signal(SIGTERM,panic);
1208 # endif
1209 #endif /* !DONT_PANIC && !DOS */
1210 }
1211
1212 /* --------------------------------------------------------------------------
1213  * Shell escapes:
1214  * ------------------------------------------------------------------------*/
1215
1216 static Bool local startEdit(line,nm)    /* Start editor on file name at    */
1217 Int    line;                            /* given line.  Both name and line */
1218 String nm; {                            /* or just line may be zero        */
1219     static char editorCmd[FILENAME_MAX+1];
1220
1221 #if !SYMANTEC_C
1222     if (hugsEdit && *hugsEdit) {        /* Check that editor configured    */
1223 #else
1224     /* On a Mac, files have creator information, telling which program
1225        to launch to, so an editor named to the empty string "" is often
1226        desirable. */
1227     if (hugsEdit) {        /* Check that editor configured    */
1228 #endif
1229         Int n     = FILENAME_MAX;
1230         String he = hugsEdit;
1231         String ec = editorCmd;
1232         String rd = NULL;               /* Set to nonnull to redo ...      */
1233
1234         for (; n>0 && *he && *he!=' ' && *he!='%'; n--)
1235             *ec++ = *he++;              /* Copy editor name to buffer      */
1236                                         /* assuming filename ends at space */
1237
1238         if (nm && line && n>1 && *he){  /* Name, line, and enough space    */
1239             rd = ec;                    /* save, in case we don't find name*/
1240             while (n>0 && *he) {
1241                 if (*he=='%') {
1242                     if (*++he=='d' && n>10) {
1243                         sprintf(ec,"%d",line);
1244                         he++;
1245                     }
1246                     else if (*he=='s' && (size_t)n>strlen(nm)) {
1247                         strcpy(ec,nm);
1248                         rd = NULL;
1249                         he++;
1250                     }
1251                     else if (*he=='%' && n>1) {
1252                         strcpy(ec,"%");
1253                         he++;
1254                     }
1255                     else                /* Ignore % char if not followed   */
1256                         *ec = '\0';     /* by one of d, s, or %,           */
1257                     for (; *ec && n>0; n--)
1258                         ec++;
1259                 }   /* ignore % followed by anything other than d, s, or % */
1260                 else {                  /* Copy other characters across    */
1261                     *ec++ = *he++;
1262                     n--;
1263                 }
1264             }
1265         }
1266         else
1267             line = 0;
1268
1269         if (rd) {                       /* If file name was not included   */
1270             ec   = rd;
1271             line = 0;
1272         }
1273
1274         if (nm && line==0 && n>1) {     /* Name, but no line ...           */
1275             *ec++ = ' ';
1276             for (; n>0 && *nm; n--)     /* ... just copy file name         */
1277                 *ec++ = *nm++;
1278         }
1279
1280         *ec = '\0';                     /* Add terminating null byte       */
1281     }
1282     else {
1283         ERRMSG(0) "Hugs is not configured to use an editor"
1284         EEND;
1285     }
1286
1287 #if HAVE_WINEXEC
1288     WinExec(editorCmd, SW_SHOW);
1289     return FALSE;
1290 #else
1291     if (shellEsc(editorCmd))
1292         Printf("Warning: Editor terminated abnormally\n");
1293     return TRUE;
1294 #endif
1295 }
1296
1297 Int shellEsc(s)                         /* run a shell command (or shell)  */
1298 String s; {
1299 #if HAVE_MACSYSTEM
1300     return macsystem(s);
1301 #else
1302 #if HAVE_BIN_SH
1303     if (s[0]=='\0') {
1304         s = fromEnv("SHELL","/bin/sh");
1305     }
1306 #endif
1307     return system(s);
1308 #endif
1309 }
1310
1311 #if RISCOS                              /* RISCOS also needs a chdir()     */
1312 int chdir(char *s) {                    /* RISCOS PRM p. 885    -- JBS     */
1313     return os_swi2(OS_FSControl + XOS_Bit, 0, (int)s) != NULL;
1314 }
1315 #elif defined HAVE_PBHSETVOLSYNC        /* Macintosh */
1316 int chdir(const char *s) {
1317     char* str;
1318     WDPBRec wd;
1319     wd.ioCompletion = 0;
1320     str = (char*)malloc(strlen(s) + 1);
1321     if (str == 0) return -1;
1322     strcpy(str, s);
1323     wd.ioNamePtr = C2PStr(str);
1324     wd.ioVRefNum = 0;
1325     wd.ioWDDirID = 0;
1326     errno = PBHSetVolSync(&wd);
1327     free(str);
1328     if (errno == 0) {
1329         return 0;
1330     } else {
1331         return -1;
1332     }
1333 }
1334 #endif
1335
1336
1337 /*---------------------------------------------------------------------------
1338  * Printf-related operations:
1339  *-------------------------------------------------------------------------*/
1340
1341 #if !defined(HAVE_VSNPRINTF)
1342 int vsnprintf(buffer, count, fmt, ap)
1343 char*       buffer;
1344 int         count;
1345 const char* fmt;
1346 va_list     ap; {
1347 #if defined(HAVE__VSNPRINTF)
1348     return _vsnprintf(buffer, count, fmt, ap);
1349 #else
1350     return 0;
1351 #endif
1352 }
1353 #endif /* HAVE_VSNPRINTF */
1354
1355 #if !defined(HAVE_SNPRINTF)
1356 int snprintf(char* buffer, int count, const char* fmt, ...) {
1357 #if defined(HAVE__VSNPRINTF)
1358     int r;
1359     va_list ap;                    /* pointer into argument list           */
1360     va_start(ap, fmt);             /* make ap point to first arg after fmt */
1361     r = vsnprintf(buffer, count, fmt, ap);
1362     va_end(ap);                    /* clean up                             */
1363     return r;
1364 #else
1365     return 0;
1366 #endif
1367 }
1368 #endif /* HAVE_SNPRINTF */
1369
1370 /* --------------------------------------------------------------------------
1371  * Read/write values from/to the registry
1372  *
1373  * All reads are from either HUGS_CURRENT_USER\\hugs_ROOT\\key or
1374  * HUGS_LOCAL_MACHINE\\hugs_ROOT\\key.  (Machine entry is only used if
1375  * user entry doesn't exist).
1376  *
1377  * All writes are to HUGS_CURRENT_USER\\HugsRoot\\key
1378  * ------------------------------------------------------------------------*/
1379
1380 #if USE_REGISTRY
1381
1382 #define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
1383
1384 static Bool   local createKey      ( HKEY, PHKEY, REGSAM );
1385 static Bool   local queryValue     ( HKEY, String, LPDWORD, LPBYTE, DWORD );
1386 static Bool   local setValue       ( HKEY, String, DWORD, LPBYTE, DWORD );
1387
1388 static Bool local createKey(hKey, phRootKey, samDesired)
1389 HKEY    hKey;
1390 PHKEY   phRootKey;
1391 REGSAM  samDesired; {
1392     DWORD  dwDisp;
1393     return RegCreateKeyEx(hKey, HugsRoot,
1394                           0, "", REG_OPTION_NON_VOLATILE,
1395                           samDesired, NULL, phRootKey, &dwDisp)
1396            == ERROR_SUCCESS;
1397 }
1398
1399 static Bool local queryValue(hKey, regPath, var, type, buf, bufSize)
1400 HKEY    hKey;
1401 String  regPath;
1402 String  var;
1403 LPDWORD type;
1404 LPBYTE  buf;
1405 DWORD   bufSize; {
1406     HKEY hRootKey;
1407
1408     if (!createKey(hKey, regPath, &hRootKey, KEY_READ)) {
1409         return FALSE;
1410     } else {
1411         LONG res = RegQueryValueEx(hRootKey, var, NULL, type, buf, &bufSize);
1412         RegCloseKey(hRootKey);
1413         return (res == ERROR_SUCCESS);
1414     }
1415 }
1416
1417 static Bool local setValue(hKey, regPath, var, type, buf, bufSize)
1418 HKEY   hKey;
1419 String regPath;
1420 String var;
1421 DWORD  type;
1422 LPBYTE buf;
1423 DWORD  bufSize; {
1424     HKEY hRootKey;
1425
1426     if (!createKey(hKey, regPath, &hRootKey, KEY_WRITE)) {
1427         return FALSE;
1428     } else {
1429         LONG res = RegSetValueEx(hRootKey, var, 0, type, buf, bufSize);
1430         RegCloseKey(hRootKey);
1431         return (res == ERROR_SUCCESS);
1432     }
1433 }
1434
1435 static String local readRegString(key,regPath,var,def) /* read String from registry */
1436 HKEY   key;
1437 String regPath;
1438 String var;
1439 String def; {
1440     static char  buf[300];
1441     DWORD type;
1442     if (queryValue(key, regPath,var, &type, buf, sizeof(buf))
1443         && type == REG_SZ) {
1444         return (String)buf;
1445     } else {
1446         return def;
1447     }
1448 }
1449
1450 static Int local readRegInt(var, def)            /* read Int from registry */
1451 String var;
1452 Int    def; {
1453     DWORD buf;
1454     DWORD type;
1455
1456     if (queryValue(HKEY_CURRENT_USER, HugsRoot, var, &type,
1457                    (LPBYTE)&buf, sizeof(buf))
1458         && type == REG_DWORD) {
1459         return (Int)buf;
1460     } else if (queryValue(HKEY_LOCAL_MACHINE, HugsRoot, var, &type,
1461                           (LPBYTE)&buf, sizeof(buf))
1462                && type == REG_DWORD) {
1463         return (Int)buf;
1464     } else {
1465         return def;
1466     }
1467 }
1468
1469 static Bool local writeRegString(var,val)      /* write String to registry */
1470 String var;
1471 String val; {
1472     if (NULL == val) {
1473         val = "";
1474     }
1475     return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1476                     REG_SZ, (LPBYTE)val, lstrlen(val)+1);
1477 }
1478
1479 static Bool local writeRegInt(var,val)         /* write String to registry */
1480 String var;
1481 Int    val; {
1482     return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1483                     REG_DWORD, (LPBYTE)&val, sizeof(val));
1484 }
1485
1486 #endif /* USE_REGISTRY */
1487
1488 /* --------------------------------------------------------------------------
1489  * Things to do with the argv/argc and the env
1490  * ------------------------------------------------------------------------*/
1491
1492 int nh_argc ( void )
1493 {
1494   return prog_argc;
1495 }
1496
1497 int nh_argvb ( int argno, int offset )
1498 {
1499   return (int)(prog_argv[argno][offset]);
1500 }
1501
1502 /* --------------------------------------------------------------------------
1503  * Machine dependent control:
1504  * ------------------------------------------------------------------------*/
1505
1506 Void machdep(what)                      /* Handle machine specific         */
1507 Int what; {                             /* initialisation etc..            */
1508     switch (what) {
1509         case MARK    : break;
1510         case POSTPREL: break;
1511         case PREPREL : installHandlers();
1512                        break;
1513         case RESET   :
1514         case BREAK   :
1515         case EXIT    : normalTerminal();
1516                        break;
1517     }
1518 }
1519
1520 /*-------------------------------------------------------------------------*/