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