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