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