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