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