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