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