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