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.24 $
  17  * $Date: 2000/03/24 14:51:50 $
  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* iAvail, Time* iTime, Long* iSize,
 629         Bool* oAvail, Time* oTime, Long* oSize
 630      )
 631 {
 632    /* Let the module name given be M.
 633       For each path entry P,
 634         a  s(rc)       file will be P/M.hs or P/M.lhs
 635         an i(nterface) file will be P/M.hi
 636         an o(bject)    file will be P/M.o
 637       If there is a s file or (both i and o files)
 638         use P to fill in the path names.
 639       Otherwise, move on to the next path entry.
 640       If all path entries are exhausted, return False.
 641    */
 642    Int    nPath;
 643    Bool   literate;
 644    String peStart, peEnd;
 645    String augdPath;       /* .:hugsPath:installDir/GhcPrel:installDir/lib */
 646
 647    *path = *sExt = NULL;
 648    *sAvail = *iAvail = *oAvail = FALSE;
 649    *sSize  = *iSize  = *oSize  = 0;
 650
 651    augdPath = malloc( 2*(10+3+strlen(installDir))
 652                       +strlen(hugsPath) +10/*paranoia*/);
 653    if (!augdPath)
 654       internal("moduleNameToFileNames: malloc failed(2)");
 655
 656    augdPath[0] = 0;
 657    strcat(augdPath, ".");
 658    strcat(augdPath, PATHSEP_STR);
 659
 660    strcat(augdPath, hugsPath);
 661    strcat(augdPath, PATHSEP_STR);
 662
 663    if (combined) {
 664       strcat(augdPath, installDir);
 665       strcat(augdPath, "GhcPrel");
 666       strcat(augdPath, PATHSEP_STR);
 667    }
 668
 669    strcat(augdPath, installDir);
 670    strcat(augdPath, "lib");
 671    strcat(augdPath, PATHSEP_STR);
 672
 673    /*   fprintf ( stderr, "augdpath = `%s'\n", augdPath ); */
 674
 675    peEnd = augdPath-1;
 676    while (1) {
 677       /* Advance peStart and peEnd very paranoically, giving up at
 678          the first sign of mutancy in the path string.
 679       */
 680       if (peEnd >= augdPath && !(*peEnd)) { free(augdPath); return FALSE; }
 681       peStart = peEnd+1;
 682       peEnd = peStart;
 683       while (*peEnd && *peEnd != PATHSEP) peEnd++;
 684
 685       /* Now peStart .. peEnd-1 bracket the next path element. */
 686       nPath = peEnd-peStart;
 687       if (nPath + strlen(modName) + 10 /*slush*/ > FILENAME_MAX) {
 688          ERRMSG(0) "Hugs path \"%s\" contains excessively long component",
 689                    hugsPath
 690          EEND;
 691          free(augdPath);
 692          return FALSE;
 693       }
 694
 695       strncpy(searchBuf, peStart, nPath);
 696       searchBuf[nPath] = 0;
 697       if (nPath > 0 && !isSLASH(searchBuf[nPath-1]))
 698          searchBuf[nPath++] = SLASH;
 699
 700       strcpy(searchBuf+nPath, modName);
 701       nPath += strlen(modName);
 702
 703       /* searchBuf now holds 'P/M'.  Try out the various endings. */
 704       *path = *sExt = NULL;
 705       *sAvail = *iAvail = *oAvail = FALSE;
 706       *sSize  = *iSize  = *oSize  = 0;
 707
 708       strcpy(searchBuf+nPath, DLL_ENDING);
 709       if (readable(searchBuf)) {
 710          *oAvail = TRUE;
 711          getFileInfo(searchBuf, oTime, oSize);
 712       }
 713
 714       strcpy(searchBuf+nPath, ".u_hi");
 715       if (readable(searchBuf)) {
 716          *iAvail = TRUE;
 717          getFileInfo(searchBuf, iTime, iSize);
 718       }
 719
 720       strcpy(searchBuf+nPath, ".hs");
 721       if (readable(searchBuf)) {
 722          *sAvail = TRUE;
 723          literate = FALSE;
 724          getFileInfo(searchBuf, sTime, sSize);
 725          *sExt = ".hs";
 726       } else {
 727          strcpy(searchBuf+nPath, ".lhs");
 728          if (readable(searchBuf)) {
 729             *sAvail = TRUE;
 730             literate = TRUE;
 731             getFileInfo(searchBuf, sTime, sSize);
 732             *sExt = ".lhs";
 733          }
 734       }
 735
 736       /* Success? */
 737       if (*sAvail || (*oAvail && *iAvail)) {
 738          nPath -= strlen(modName);
 739          *path = malloc(nPath+1);
 740          if (!(*path))
 741             internal("moduleNameToFileNames: malloc failed(1)");
 742          strncpy(*path, searchBuf, nPath);
 743          (*path)[nPath] = 0;
 744          free(augdPath);
 745          return TRUE;
 746       }
 747
 748    }
 749
 750 }
 751
 752
 753 /* If the primaryObjectName is (eg)
 754      /foo/bar/PrelSwamp.o
 755    and the extraFileName is (eg)
 756      swampy_cbits
 757    and DLL_ENDING is set to .o
 758    return
 759      /foo/bar/swampy_cbits.o
 760      and set *extraFileSize to its size, or -1 if not avail
 761 */
 762 String getExtraObjectInfo ( String primaryObjectName,
 763                             String extraFileName,
 764                             Int*   extraFileSize )
 765 {
 766    Time   xTime;
 767    Long   xSize;
 768    String xtra;
 769
 770    Int i = strlen(primaryObjectName)-1;
 771    while (i >= 0 && primaryObjectName[i] != SLASH) i--;
 772    if (i == -1) return extraFileName;
 773    i++;
 774    xtra = malloc ( i+3+strlen(extraFileName)+strlen(DLL_ENDING) );
 775    if (!xtra) internal("deriveExtraObjectName: malloc failed");
 776    strncpy ( xtra, primaryObjectName, i );
 777    xtra[i] = 0;
 778    strcat ( xtra, extraFileName );
 779    strcat ( xtra, DLL_ENDING );
 780
 781    *extraFileSize = -1;
 782    if (readable(xtra)) {
 783       getFileInfo ( xtra, &xTime, &xSize );
 784       *extraFileSize = xSize;
 785    }
 786    return xtra;
 787 }
 788
 789
 790 /* --------------------------------------------------------------------------
 791  * Substitute old value of path into empty entries in new path
 792  * eg substPath("a:b:c::d:e","x:y:z") = "a:b:c:x:y:z:d:e"
 793  * ------------------------------------------------------------------------*/
 794
 795 static String local substPath ( String,String );
 796
 797 static String local substPath(new,sub) /* substitute sub path into new path*/
 798 String new;
 799 String sub; {
 800     Bool   substituted = FALSE;            /*   only allow one replacement */
 801     Int    maxlen      = strlen(sub) + strlen(new);    /* safe upper bound */
 802     String r = (String) malloc(maxlen+1);  /* result string                */
 803     String t = r;                          /* pointer into r               */
 804     String next = new;                     /* next uncopied char in new    */
 805     String start = next;                   /* start of last path component */
 806     if (r == 0) {
 807         ERRMSG(0) "String storage space exhausted"
 808         EEND;
 809     }
 810     do {
 811         if (*next == PATHSEP || *next == '\0') {
 812             if (!substituted && next == start) {
 813                 String s = sub;
 814                 for(; *s != '\0'; ++s) {
 815                     *t++ = *s;
 816                 }
 817                 substituted = TRUE;
 818             }
 819             start = next+1;
 820         }
 821     } while ((*t++ = *next++) != '\0');
 822     return r;
 823 }
 824
 825
 826 /* --------------------------------------------------------------------------
 827  * Garbage collection notification:
 828  * ------------------------------------------------------------------------*/
 829
 830 Bool gcMessages = FALSE;                /* TRUE => print GC messages       */
 831
 832 Void gcStarted() {                      /* Notify garbage collector start  */
 833     if (gcMessages) {
 834         Printf("{{Gc");
 835         FlushStdout();
 836     }
 837 }
 838
 839 Void gcScanning() {                     /* Notify garbage collector scans  */
 840     if (gcMessages) {
 841         Putchar(':');
 842         FlushStdout();
 843     }
 844 }
 845
 846 Void gcRecovered(recovered)             /* Notify garbage collection done  */
 847 Int recovered; {
 848     if (gcMessages) {
 849         Printf("%d}}",recovered);
 850         FlushStdout();
 851     }
 852 }
 853
 854 Cell *CStackBase;                       /* Retain start of C control stack */
 855
 856 #if RISCOS                              /* Stack traversal for RISCOS      */
 857
 858 /* Warning: The following code is specific to the Acorn ARM under RISCOS
 859    (and C4).  We must explicitly walk back through the stack frames, since
 860    the stack is extended from the heap. (see PRM pp. 1757).  gcCStack must
 861    not be modified, since the offset '5' assumes that only v1 is used inside
 862    this function. Hence we do all the real work in gcARM.
 863 */
 864
 865 #define spreg 13 /* C3 has SP=R13 */
 866
 867 #define previousFrame(fp)       ((int *)((fp)[-3]))
 868 #define programCounter(fp)      ((int *)((*(fp)-12) & ~0xFC000003))
 869 #define isSubSPSP(w)            (((w)&dontCare) == doCare)
 870 #define doCare                  (0xE24DD000)  /* SUB r13,r13,#0 */
 871 #define dontCare                (~0x00100FFF) /* S and # bits   */
 872 #define immediateArg(x)         ( ((x)&0xFF) << (((x)&0xF00)>>7) )
 873
 874 static void gcARM(int *fp) {
 875     int si = *programCounter(fp);       /* Save instruction indicates how */
 876                                         /* many registers in this frame   */
 877     int *regs = fp - 4;
 878     if (si & (1<<0)) markWithoutMove(*regs--);
 879     if (si & (1<<1)) markWithoutMove(*regs--);
 880     if (si & (1<<2)) markWithoutMove(*regs--);
 881     if (si & (1<<3)) markWithoutMove(*regs--);
 882     if (si & (1<<4)) markWithoutMove(*regs--);
 883     if (si & (1<<5)) markWithoutMove(*regs--);
 884     if (si & (1<<6)) markWithoutMove(*regs--);
 885     if (si & (1<<7)) markWithoutMove(*regs--);
 886     if (si & (1<<8)) markWithoutMove(*regs--);
 887     if (si & (1<<9)) markWithoutMove(*regs--);
 888     if (previousFrame(fp)) {
 889         /* The non-register stack space is for the previous frame is above
 890            this fp, and not below the previous fp, because of the way stack
 891            extension works. It seems the only way of discovering its size is
 892            finding the SUB sp, sp, #? instruction by walking through the code
 893            following the entry point.
 894         */
 895         int *oldpc = programCounter(previousFrame(fp));
 896         int fsize = 0, i;
 897         for(i = 1; i < 6; ++i)
 898             if(isSubSPSP(oldpc[i])) fsize += immediateArg(oldpc[i]) / 4;
 899         for(i=1; i<=fsize; ++i)
 900             markWithoutMove(fp[i]);
 901     }
 902 }
 903
 904 void gcCStack() {
 905     int dummy;
 906     int *fp = 5 + &dummy;
 907     while (fp) {
 908         gcARM(fp);
 909         fp = previousFrame(fp);
 910     }
 911 }
 912
 913 #else                   /* Garbage collection for standard stack machines  */
 914
 915 Void gcCStack() {                       /* Garbage collect elements off    */
 916     Cell stackTop = NIL;                /* C stack                         */
 917     Cell *ptr = &stackTop;
 918 #if SIZEOF_VOID_P == 2
 919     if (((long)(ptr) - (long)(CStackBase))&1)
 920         fatal("gcCStack");
 921 #elif STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
 922     if (((long)(ptr) - (long)(CStackBase))&1)
 923         fatal("gcCStack");
 924 #else
 925     if (((long)(ptr) - (long)(CStackBase))&3)
 926         fatal("gcCStack");
 927 #endif
 928
 929 #define Blargh markWithoutMove(*ptr);
 930 #if 0
 931                markWithoutMove((*ptr)/sizeof(Cell)); \
 932                markWithoutMove(( (void*)(*ptr)-(void*)heapTopFst)/sizeof(Cell));  \
 933                markWithoutMove(( (void*)(*ptr)-(void*)heapTopSnd)/sizeof(Cell))
 934 #endif
 935
 936 #define StackGrowsDown  { while (ptr<=CStackBase) { Blargh; ptr++; }; }
 937 #define StackGrowsUp    { while (ptr>=CStackBase) { Blargh; ptr--; }; }
 938 #define GuessDirection  if (ptr>CStackBase) StackGrowsUp else StackGrowsDown
 939
 940 #if STACK_DIRECTION > 0
 941     StackGrowsUp;
 942 #elif STACK_DIRECTION < 0
 943     StackGrowsDown;
 944 #else
 945     GuessDirection;
 946 #endif
 947
 948 #if SIZEOF_VOID_P==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
 949     ptr = (Cell *)((long)(&stackTop) + 2);
 950     StackGrowsDown;
 951 #endif
 952
 953 #undef  StackGrowsDown
 954 #undef  StackGrowsUp
 955 #undef  GuessDirection
 956 }
 957 #endif
 958
 959 /* --------------------------------------------------------------------------
 960  * Terminal dependent stuff:
 961  * ------------------------------------------------------------------------*/
 962
 963 #if (HAVE_TERMIO_H | HAVE_SGTTY_H | HAVE_TERMIOS_H)
 964
 965 /* grab the varargs prototype for ioctl */
 966 #if HAVE_SYS_IOCTL_H
 967 # include <sys/ioctl.h>
 968 #endif
 969
 970 /* The order of these three tests is very important because
 971  * some systems have more than one of the requisite header file
 972  * but only one of them seems to work.
 973  * Anyone changing the order of the tests should try enabling each of the
 974  * three branches in turn and write down which ones work as well as which
 975  * OS/compiler they're using.
 976  *
 977  * OS            Compiler      sgtty     termio  termios   notes
 978  * Linux 2.0.18  gcc 2.7.2     absent    works   works     1
 979  *
 980  * Notes:
 981  * 1) On Linux, termio.h just #includes termios.h and sgtty.h is
 982  *    implemented using termios.h.
 983  *    sgtty.h is in /usr/include/bsd which is not on my standard include
 984  *    path.  Adding it does no harm but you might as well use termios.
 985  *    --
 986  *    reid-alastair@cs.yale.edu
 987  */
 988 #if HAVE_TERMIOS_H
 989
 990 #include <termios.h>
 991 typedef  struct termios  TermParams;
 992 #define  getTerminal(tp) tcgetattr(fileno(stdin), &tp)
 993 #define  setTerminal(tp) tcsetattr(fileno(stdin), TCSAFLUSH, &tp)
 994 #define  noEcho(tp)      tp.c_lflag    &= ~(ICANON | ECHO); \
 995                          tp.c_cc[VMIN]  = 1;                \
 996                          tp.c_cc[VTIME] = 0;
 997
 998 #elif HAVE_SGTTY_H
 999
1000 #include <sgtty.h>
1001 typedef  struct sgttyb   TermParams;
1002 #define  getTerminal(tp) ioctl(fileno(stdin),TIOCGETP,&tp)
1003 #define  setTerminal(tp) ioctl(fileno(stdin),TIOCSETP,&tp)
1004 #if HPUX
1005 #define  noEcho(tp)      tp.sg_flags |= RAW; tp.sg_flags &= (~ECHO);
1006 #else
1007 #define  noEcho(tp)      tp.sg_flags |= CBREAK; tp.sg_flags &= (~ECHO);
1008 #endif
1009
1010 #elif HAVE_TERMIO_H
1011
1012 #include <termio.h>
1013 typedef  struct termio   TermParams;
1014 #define  getTerminal(tp) ioctl(fileno(stdin),TCGETA,&tp)
1015 #define  setTerminal(tp) ioctl(fileno(stdin),TCSETAF,&tp)
1016 #define  noEcho(tp)      tp.c_lflag    &= ~(ICANON | ECHO); \
1017                          tp.c_cc[VMIN]  = 1;                \
1018                          tp.c_cc[VTIME] = 0;
1019
1020 #endif
1021
1022 static Bool messedWithTerminal = FALSE;
1023 static TermParams originalSettings;
1024
1025 Void normalTerminal() {                 /* restore terminal initial state  */
1026     if (messedWithTerminal)
1027         setTerminal(originalSettings);
1028 }
1029
1030 Void noechoTerminal() {                 /* set terminal into noecho mode   */
1031     TermParams settings;
1032
1033     if (!messedWithTerminal) {
1034         getTerminal(originalSettings);
1035         messedWithTerminal = TRUE;
1036     }
1037     getTerminal(settings);
1038     noEcho(settings);
1039     setTerminal(settings);
1040 }
1041
1042 Int getTerminalWidth() {                /* determine width of terminal     */
1043 #ifdef TIOCGWINSZ
1044 #ifdef _M_UNIX                          /* SCO Unix 3.2.4 defines TIOCGWINSZ*/
1045 #include <sys/stream.h>                 /* Required by sys/ptem.h          */
1046 #include <sys/ptem.h>                   /* Required to declare winsize     */
1047 #endif
1048     static struct winsize terminalSize;
1049     ioctl(fileno(stdout),TIOCGWINSZ,&terminalSize);
1050     return (terminalSize.ws_col==0)? 80 : terminalSize.ws_col;
1051 #else
1052     return 80;
1053 #endif
1054 }
1055
1056 Int readTerminalChar() {                /* read character from terminal    */
1057     return getchar();                   /* without echo, assuming that     */
1058 }                                       /* noechoTerminal() is active...   */
1059
1060 #elif SYMANTEC_C
1061
1062 Int readTerminalChar() {                /* read character from terminal    */
1063     return getchar();                   /* without echo, assuming that     */
1064 }                                       /* noechoTerminal() is active...   */
1065
1066 Int getTerminalWidth() {
1067     return console_options.ncols;
1068 }
1069
1070 Void normalTerminal() {
1071     csetmode(C_ECHO, stdin);
1072 }
1073
1074 Void noechoTerminal() {
1075     csetmode(C_NOECHO, stdin);
1076 }
1077
1078 #else /* no terminal driver - eg DOS, RISCOS */
1079
1080 static Bool terminalEchoReqd = TRUE;
1081
1082 Int getTerminalWidth() {
1083 #if RISCOS
1084     int dummy, width;
1085     (void) os_swi3r(OS_ReadModeVariable, -1, 1, 0, &dummy, &dummy, &width);
1086     return width+1;
1087 #else
1088     return 80;
1089 #endif
1090 }
1091
1092 Void normalTerminal() {                 /* restore terminal initial state  */
1093     terminalEchoReqd = TRUE;
1094 }
1095
1096 Void noechoTerminal() {                 /* turn terminal echo on/off       */
1097     terminalEchoReqd = FALSE;
1098 }
1099
1100 Int readTerminalChar() {                /* read character from terminal    */
1101     if (terminalEchoReqd) {
1102         return getchar();
1103     } else {
1104 #if IS_WIN32 && !__BORLANDC__
1105         /* When reading a character from the console/terminal, we want
1106          * to operate in 'raw' mode (to use old UNIX tty parlance) and have
1107          * it return when a character is available and _not_ wait until
1108          * the next time the user hits carriage return. On Windows platforms,
1109          * this _can_ be done by reading directly from the console, using
1110          * getch().  However, this doesn't sit well with programming
1111          * environments such as Emacs which allow you to create sub-processes
1112          * running Hugs, and then communicate with the running interpreter
1113          * through its standard input and output handles. If you use getch()
1114          * in that setting, you end up trying to read the (unused) console
1115          * of the editor itself, through which not a lot of characters is
1116          * bound to come out, since the editor communicates input to Hugs
1117          * via the standard input handle.
1118          *
1119          * To avoid this rather unfortunate situation, we use the Win32
1120          * console API and re-jig the input properties of the standard
1121          * input handle before trying to read a character using stdio's
1122          * getchar().
1123          *
1124          * The 'cost' of this solution is that it is Win32 specific and
1125          * won't work with Windows 3.1 + it is kind of ugly and verbose
1126          * to have to futz around with the console properties on a
1127          * per-char basis. Both of these disadvantages aren't in my
1128          * opinion fatal.
1129          *
1130          * -- sof 5/99
1131          */
1132         Int c;
1133         DWORD mo;
1134         HANDLE hIn;
1135
1136         /* I don't quite understand why, but if the FILE*'s underlying file
1137            descriptor is in text mode, we seem to lose the first carriage
1138            return.
1139          */
1140         setmode(fileno(stdin), _O_BINARY);
1141         hIn = GetStdHandle(STD_INPUT_HANDLE);
1142         GetConsoleMode(hIn, &mo);
1143         SetConsoleMode(hIn, mo & ~(ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT));
1144         /*
1145          * On Win9x, the first time you change the mode (as above) a
1146          * raw '\n' is inserted.  Since enter maps to a raw '\r', and we
1147          * map this (below) to '\n', we can just ignore all *raw* '\n's.
1148          */
1149         do {
1150           c = getc(stdin);
1151         } while (c == '\n');
1152
1153         /* Same as it ever was - revert back state of stdin. */
1154         SetConsoleMode(hIn, mo);
1155         setmode(fileno(stdin), _O_TEXT);
1156 #else
1157         Int c = getch();
1158 #endif
1159         return c=='\r' ? '\n' : c;      /* slight paranoia about CR-LF    */
1160     }
1161 }
1162
1163 #endif /* no terminal driver */
1164
1165 /* --------------------------------------------------------------------------
1166  * Interrupt handling:
1167  * ------------------------------------------------------------------------*/
1168
1169 static Void installHandlers ( void ) { /* Install handlers for all fatal   */
1170                                       /* signals except SIGINT and SIGBREAK*/
1171 #if IS_WIN32
1172     /* SetConsoleCtrlHandler(consoleHandler,TRUE); */
1173 #endif
1174 #if !DONT_PANIC && !DOS
1175 # ifdef SIGABRT
1176     signal(SIGABRT,panic);
1177 # endif
1178 # ifdef SIGBUS
1179     signal(SIGBUS,panic);
1180 # endif
1181 # ifdef SIGFPE
1182     signal(SIGFPE,panic);
1183 # endif
1184 # ifdef SIGHUP
1185     signal(SIGHUP,panic);
1186 # endif
1187 # ifdef SIGILL
1188     signal(SIGILL,panic);
1189 # endif
1190 # ifdef SIGQUIT
1191     signal(SIGQUIT,panic);
1192 # endif
1193 # ifdef SIGSEGV
1194     signal(SIGSEGV,panic);
1195 # endif
1196 # ifdef SIGTERM
1197     signal(SIGTERM,panic);
1198 # endif
1199 #endif /* !DONT_PANIC && !DOS */
1200 }
1201
1202 /* --------------------------------------------------------------------------
1203  * Shell escapes:
1204  * ------------------------------------------------------------------------*/
1205
1206 static Bool local startEdit(line,nm)    /* Start editor on file name at    */
1207 Int    line;                            /* given line.  Both name and line */
1208 String nm; {                            /* or just line may be zero        */
1209     static char editorCmd[FILENAME_MAX+1];
1210
1211 #if !SYMANTEC_C
1212     if (hugsEdit && *hugsEdit) {        /* Check that editor configured    */
1213 #else
1214     /* On a Mac, files have creator information, telling which program
1215        to launch to, so an editor named to the empty string "" is often
1216        desirable. */
1217     if (hugsEdit) {        /* Check that editor configured    */
1218 #endif
1219         Int n     = FILENAME_MAX;
1220         String he = hugsEdit;
1221         String ec = editorCmd;
1222         String rd = NULL;               /* Set to nonnull to redo ...      */
1223
1224         for (; n>0 && *he && *he!=' ' && *he!='%'; n--)
1225             *ec++ = *he++;              /* Copy editor name to buffer      */
1226                                         /* assuming filename ends at space */
1227
1228         if (nm && line && n>1 && *he){  /* Name, line, and enough space    */
1229             rd = ec;                    /* save, in case we don't find name*/
1230             while (n>0 && *he) {
1231                 if (*he=='%') {
1232                     if (*++he=='d' && n>10) {
1233                         sprintf(ec,"%d",line);
1234                         he++;
1235                     }
1236                     else if (*he=='s' && (size_t)n>strlen(nm)) {
1237                         strcpy(ec,nm);
1238                         rd = NULL;
1239                         he++;
1240                     }
1241                     else if (*he=='%' && n>1) {
1242                         strcpy(ec,"%");
1243                         he++;
1244                     }
1245                     else                /* Ignore % char if not followed   */
1246                         *ec = '\0';     /* by one of d, s, or %,           */
1247                     for (; *ec && n>0; n--)
1248                         ec++;
1249                 }   /* ignore % followed by anything other than d, s, or % */
1250                 else {                  /* Copy other characters across    */
1251                     *ec++ = *he++;
1252                     n--;
1253                 }
1254             }
1255         }
1256         else
1257             line = 0;
1258
1259         if (rd) {                       /* If file name was not included   */
1260             ec   = rd;
1261             line = 0;
1262         }
1263
1264         if (nm && line==0 && n>1) {     /* Name, but no line ...           */
1265             *ec++ = ' ';
1266             for (; n>0 && *nm; n--)     /* ... just copy file name         */
1267                 *ec++ = *nm++;
1268         }
1269
1270         *ec = '\0';                     /* Add terminating null byte       */
1271     }
1272     else {
1273         ERRMSG(0) "Hugs is not configured to use an editor"
1274         EEND;
1275     }
1276
1277 #if HAVE_WINEXEC
1278     WinExec(editorCmd, SW_SHOW);
1279     return FALSE;
1280 #else
1281     if (shellEsc(editorCmd))
1282         Printf("Warning: Editor terminated abnormally\n");
1283     return TRUE;
1284 #endif
1285 }
1286
1287 Int shellEsc(s)                         /* run a shell command (or shell)  */
1288 String s; {
1289 #if HAVE_MACSYSTEM
1290     return macsystem(s);
1291 #else
1292 #if HAVE_BIN_SH
1293     if (s[0]=='\0') {
1294         s = fromEnv("SHELL","/bin/sh");
1295     }
1296 #endif
1297     return system(s);
1298 #endif
1299 }
1300
1301 #if RISCOS                              /* RISCOS also needs a chdir()     */
1302 int chdir(char *s) {                    /* RISCOS PRM p. 885    -- JBS     */
1303     return os_swi2(OS_FSControl + XOS_Bit, 0, (int)s) != NULL;
1304 }
1305 #elif defined HAVE_PBHSETVOLSYNC        /* Macintosh */
1306 int chdir(const char *s) {
1307     char* str;
1308     WDPBRec wd;
1309     wd.ioCompletion = 0;
1310     str = (char*)malloc(strlen(s) + 1);
1311     if (str == 0) return -1;
1312     strcpy(str, s);
1313     wd.ioNamePtr = C2PStr(str);
1314     wd.ioVRefNum = 0;
1315     wd.ioWDDirID = 0;
1316     errno = PBHSetVolSync(&wd);
1317     free(str);
1318     if (errno == 0) {
1319         return 0;
1320     } else {
1321         return -1;
1322     }
1323 }
1324 #endif
1325
1326
1327 /*---------------------------------------------------------------------------
1328  * Printf-related operations:
1329  *-------------------------------------------------------------------------*/
1330
1331 #if !defined(HAVE_VSNPRINTF)
1332 int vsnprintf(buffer, count, fmt, ap)
1333 char*       buffer;
1334 int         count;
1335 const char* fmt;
1336 va_list     ap; {
1337 #if defined(HAVE__VSNPRINTF)
1338     return _vsnprintf(buffer, count, fmt, ap);
1339 #else
1340     return 0;
1341 #endif
1342 }
1343 #endif /* HAVE_VSNPRINTF */
1344
1345 #if !defined(HAVE_SNPRINTF)
1346 int snprintf(char* buffer, int count, const char* fmt, ...) {
1347 #if defined(HAVE__VSNPRINTF)
1348     int r;
1349     va_list ap;                    /* pointer into argument list           */
1350     va_start(ap, fmt);             /* make ap point to first arg after fmt */
1351     r = vsnprintf(buffer, count, fmt, ap);
1352     va_end(ap);                    /* clean up                             */
1353     return r;
1354 #else
1355     return 0;
1356 #endif
1357 }
1358 #endif /* HAVE_SNPRINTF */
1359
1360 /* --------------------------------------------------------------------------
1361  * Read/write values from/to the registry
1362  *
1363  * All reads are from either HUGS_CURRENT_USER\\hugs_ROOT\\key or
1364  * HUGS_LOCAL_MACHINE\\hugs_ROOT\\key.  (Machine entry is only used if
1365  * user entry doesn't exist).
1366  *
1367  * All writes are to HUGS_CURRENT_USER\\HugsRoot\\key
1368  * ------------------------------------------------------------------------*/
1369
1370 #if USE_REGISTRY
1371
1372 #define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
1373
1374 static Bool   local createKey      ( HKEY, PHKEY, REGSAM );
1375 static Bool   local queryValue     ( HKEY, String, LPDWORD, LPBYTE, DWORD );
1376 static Bool   local setValue       ( HKEY, String, DWORD, LPBYTE, DWORD );
1377
1378 static Bool local createKey(hKey, phRootKey, samDesired)
1379 HKEY    hKey;
1380 PHKEY   phRootKey;
1381 REGSAM  samDesired; {
1382     DWORD  dwDisp;
1383     return RegCreateKeyEx(hKey, HugsRoot,
1384                           0, "", REG_OPTION_NON_VOLATILE,
1385                           samDesired, NULL, phRootKey, &dwDisp)
1386            == ERROR_SUCCESS;
1387 }
1388
1389 static Bool local queryValue(hKey, regPath, var, type, buf, bufSize)
1390 HKEY    hKey;
1391 String  regPath;
1392 String  var;
1393 LPDWORD type;
1394 LPBYTE  buf;
1395 DWORD   bufSize; {
1396     HKEY hRootKey;
1397
1398     if (!createKey(hKey, regPath, &hRootKey, KEY_READ)) {
1399         return FALSE;
1400     } else {
1401         LONG res = RegQueryValueEx(hRootKey, var, NULL, type, buf, &bufSize);
1402         RegCloseKey(hRootKey);
1403         return (res == ERROR_SUCCESS);
1404     }
1405 }
1406
1407 static Bool local setValue(hKey, regPath, var, type, buf, bufSize)
1408 HKEY   hKey;
1409 String regPath;
1410 String var;
1411 DWORD  type;
1412 LPBYTE buf;
1413 DWORD  bufSize; {
1414     HKEY hRootKey;
1415
1416     if (!createKey(hKey, regPath, &hRootKey, KEY_WRITE)) {
1417         return FALSE;
1418     } else {
1419         LONG res = RegSetValueEx(hRootKey, var, 0, type, buf, bufSize);
1420         RegCloseKey(hRootKey);
1421         return (res == ERROR_SUCCESS);
1422     }
1423 }
1424
1425 static String local readRegString(key,regPath,var,def) /* read String from registry */
1426 HKEY   key;
1427 String regPath;
1428 String var;
1429 String def; {
1430     static char  buf[300];
1431     DWORD type;
1432     if (queryValue(key, regPath,var, &type, buf, sizeof(buf))
1433         && type == REG_SZ) {
1434         return (String)buf;
1435     } else {
1436         return def;
1437     }
1438 }
1439
1440 static Int local readRegInt(var, def)            /* read Int from registry */
1441 String var;
1442 Int    def; {
1443     DWORD buf;
1444     DWORD type;
1445
1446     if (queryValue(HKEY_CURRENT_USER, HugsRoot, var, &type,
1447                    (LPBYTE)&buf, sizeof(buf))
1448         && type == REG_DWORD) {
1449         return (Int)buf;
1450     } else if (queryValue(HKEY_LOCAL_MACHINE, HugsRoot, var, &type,
1451                           (LPBYTE)&buf, sizeof(buf))
1452                && type == REG_DWORD) {
1453         return (Int)buf;
1454     } else {
1455         return def;
1456     }
1457 }
1458
1459 static Bool local writeRegString(var,val)      /* write String to registry */
1460 String var;
1461 String val; {
1462     if (NULL == val) {
1463         val = "";
1464     }
1465     return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1466                     REG_SZ, (LPBYTE)val, lstrlen(val)+1);
1467 }
1468
1469 static Bool local writeRegInt(var,val)         /* write String to registry */
1470 String var;
1471 Int    val; {
1472     return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1473                     REG_DWORD, (LPBYTE)&val, sizeof(val));
1474 }
1475
1476 #endif /* USE_REGISTRY */
1477
1478 /* --------------------------------------------------------------------------
1479  * Things to do with the argv/argc and the env
1480  * ------------------------------------------------------------------------*/
1481
1482 int nh_argc ( void )
1483 {
1484   return prog_argc;
1485 }
1486
1487 int nh_argvb ( int argno, int offset )
1488 {
1489   return (int)(prog_argv[argno][offset]);
1490 }
1491
1492 /* --------------------------------------------------------------------------
1493  * Machine dependent control:
1494  * ------------------------------------------------------------------------*/
1495
1496 Void machdep(what)                      /* Handle machine specific         */
1497 Int what; {                             /* initialisation etc..            */
1498     switch (what) {
1499         case MARK    : break;
1500         case POSTPREL: break;
1501         case PREPREL : installHandlers();
1502                        break;
1503         case RESET   :
1504         case BREAK   :
1505         case EXIT    : normalTerminal();
1506                        break;
1507     }
1508 }
1509
1510 /*-------------------------------------------------------------------------*/