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