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.5 $
  16  * $Date: 1999/04/27 10:06:55 $
  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  * Garbage collection notification:
 628  * ------------------------------------------------------------------------*/
 629
 630 Bool gcMessages = FALSE;                /* TRUE => print GC messages       */
 631
 632 Void gcStarted() {                      /* Notify garbage collector start  */
 633 #if HUGS_FOR_WINDOWS
 634     SaveCursor = SetCursor(GarbageCursor);
 635 #endif
 636     if (gcMessages) {
 637         Printf("{{Gc");
 638         FlushStdout();
 639     }
 640 }
 641
 642 Void gcScanning() {                     /* Notify garbage collector scans  */
 643     if (gcMessages) {
 644         Putchar(':');
 645         FlushStdout();
 646     }
 647 }
 648
 649 Void gcRecovered(recovered)             /* Notify garbage collection done  */
 650 Int recovered; {
 651     if (gcMessages) {
 652         Printf("%d}}",recovered);
 653         FlushStdout();
 654     }
 655 #if HUGS_FOR_WINDOWS
 656     SetCursor(SaveCursor);
 657 #endif
 658 }
 659
 660 Cell *CStackBase;                       /* Retain start of C control stack */
 661
 662 #if RISCOS                              /* Stack traversal for RISCOS      */
 663
 664 /* Warning: The following code is specific to the Acorn ARM under RISCOS
 665    (and C4).  We must explicitly walk back through the stack frames, since
 666    the stack is extended from the heap. (see PRM pp. 1757).  gcCStack must
 667    not be modified, since the offset '5' assumes that only v1 is used inside
 668    this function. Hence we do all the real work in gcARM.
 669 */
 670
 671 #define spreg 13 /* C3 has SP=R13 */
 672
 673 #define previousFrame(fp)       ((int *)((fp)[-3]))
 674 #define programCounter(fp)      ((int *)((*(fp)-12) & ~0xFC000003))
 675 #define isSubSPSP(w)            (((w)&dontCare) == doCare)
 676 #define doCare                  (0xE24DD000)  /* SUB r13,r13,#0 */
 677 #define dontCare                (~0x00100FFF) /* S and # bits   */
 678 #define immediateArg(x)         ( ((x)&0xFF) << (((x)&0xF00)>>7) )
 679
 680 static void gcARM(int *fp) {
 681     int si = *programCounter(fp);       /* Save instruction indicates how */
 682                                         /* many registers in this frame   */
 683     int *regs = fp - 4;
 684     if (si & (1<<0)) markWithoutMove(*regs--);
 685     if (si & (1<<1)) markWithoutMove(*regs--);
 686     if (si & (1<<2)) markWithoutMove(*regs--);
 687     if (si & (1<<3)) markWithoutMove(*regs--);
 688     if (si & (1<<4)) markWithoutMove(*regs--);
 689     if (si & (1<<5)) markWithoutMove(*regs--);
 690     if (si & (1<<6)) markWithoutMove(*regs--);
 691     if (si & (1<<7)) markWithoutMove(*regs--);
 692     if (si & (1<<8)) markWithoutMove(*regs--);
 693     if (si & (1<<9)) markWithoutMove(*regs--);
 694     if (previousFrame(fp)) {
 695         /* The non-register stack space is for the previous frame is above
 696            this fp, and not below the previous fp, because of the way stack
 697            extension works. It seems the only way of discovering its size is
 698            finding the SUB sp, sp, #? instruction by walking through the code
 699            following the entry point.
 700         */
 701         int *oldpc = programCounter(previousFrame(fp));
 702         int fsize = 0, i;
 703         for(i = 1; i < 6; ++i)
 704             if(isSubSPSP(oldpc[i])) fsize += immediateArg(oldpc[i]) / 4;
 705         for(i=1; i<=fsize; ++i)
 706             markWithoutMove(fp[i]);
 707     }
 708 }
 709
 710 void gcCStack() {
 711     int dummy;
 712     int *fp = 5 + &dummy;
 713     while (fp) {
 714         gcARM(fp);
 715         fp = previousFrame(fp);
 716     }
 717 }
 718
 719 #else                   /* Garbage collection for standard stack machines  */
 720
 721 Void gcCStack() {                       /* Garbage collect elements off    */
 722     Cell stackTop = NIL;                /* C stack                         */
 723     Cell *ptr = &stackTop;
 724 #if SIZEOF_INTP == 2
 725     if (((long)(ptr) - (long)(CStackBase))&1)
 726         fatal("gcCStack");
 727 #elif STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
 728     if (((long)(ptr) - (long)(CStackBase))&1)
 729         fatal("gcCStack");
 730 #else
 731     if (((long)(ptr) - (long)(CStackBase))&3)
 732         fatal("gcCStack");
 733 #endif
 734
 735 #define Blargh markWithoutMove(*ptr);
 736 #if 0
 737                markWithoutMove((*ptr)/sizeof(Cell)); \
 738                markWithoutMove(( (void*)(*ptr)-(void*)heapTopFst)/sizeof(Cell));  \
 739                markWithoutMove(( (void*)(*ptr)-(void*)heapTopSnd)/sizeof(Cell))
 740 #endif
 741
 742 #define StackGrowsDown  { while (ptr<=CStackBase) { Blargh; ptr++; }; }
 743 #define StackGrowsUp    { while (ptr>=CStackBase) { Blargh; ptr--; }; }
 744 #define GuessDirection  if (ptr>CStackBase) StackGrowsUp else StackGrowsDown
 745
 746 #if STACK_DIRECTION > 0
 747     StackGrowsUp;
 748 #elif STACK_DIRECTION < 0
 749     StackGrowsDown;
 750 #else
 751     GuessDirection;
 752 #endif
 753
 754 #if SIZEOF_INTP==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
 755     ptr = (Cell *)((long)(&stackTop) + 2);
 756     StackGrowsDown;
 757 #endif
 758
 759 #undef  StackGrowsDown
 760 #undef  StackGrowsUp
 761 #undef  GuessDirection
 762 }
 763 #endif
 764
 765 /* --------------------------------------------------------------------------
 766  * Terminal dependent stuff:
 767  * ------------------------------------------------------------------------*/
 768
 769 #if (HAVE_TERMIO_H | HAVE_SGTTY_H | HAVE_TERMIOS_H)
 770
 771 /* grab the varargs prototype for ioctl */
 772 #if HAVE_SYS_IOCTL_H
 773 # include <sys/ioctl.h>
 774 #endif
 775
 776 /* The order of these three tests is very important because
 777  * some systems have more than one of the requisite header file
 778  * but only one of them seems to work.
 779  * Anyone changing the order of the tests should try enabling each of the
 780  * three branches in turn and write down which ones work as well as which
 781  * OS/compiler they're using.
 782  *
 783  * OS            Compiler      sgtty     termio  termios   notes
 784  * Linux 2.0.18  gcc 2.7.2     absent    works   works     1
 785  *
 786  * Notes:
 787  * 1) On Linux, termio.h just #includes termios.h and sgtty.h is
 788  *    implemented using termios.h.
 789  *    sgtty.h is in /usr/include/bsd which is not on my standard include
 790  *    path.  Adding it does no harm but you might as well use termios.
 791  *    --
 792  *    reid-alastair@cs.yale.edu
 793  */
 794 #if HAVE_TERMIOS_H
 795
 796 #include <termios.h>
 797 typedef  struct termios  TermParams;
 798 #define  getTerminal(tp) tcgetattr(fileno(stdin), &tp)
 799 #define  setTerminal(tp) tcsetattr(fileno(stdin), TCSAFLUSH, &tp)
 800 #define  noEcho(tp)      tp.c_lflag    &= ~(ICANON | ECHO); \
 801                          tp.c_cc[VMIN]  = 1;                \
 802                          tp.c_cc[VTIME] = 0;
 803
 804 #elif HAVE_SGTTY_H
 805
 806 #include <sgtty.h>
 807 typedef  struct sgttyb   TermParams;
 808 #define  getTerminal(tp) ioctl(fileno(stdin),TIOCGETP,&tp)
 809 #define  setTerminal(tp) ioctl(fileno(stdin),TIOCSETP,&tp)
 810 #if HPUX
 811 #define  noEcho(tp)      tp.sg_flags |= RAW; tp.sg_flags &= (~ECHO);
 812 #else
 813 #define  noEcho(tp)      tp.sg_flags |= CBREAK; tp.sg_flags &= (~ECHO);
 814 #endif
 815
 816 #elif HAVE_TERMIO_H
 817
 818 #include <termio.h>
 819 typedef  struct termio   TermParams;
 820 #define  getTerminal(tp) ioctl(fileno(stdin),TCGETA,&tp)
 821 #define  setTerminal(tp) ioctl(fileno(stdin),TCSETAF,&tp)
 822 #define  noEcho(tp)      tp.c_lflag    &= ~(ICANON | ECHO); \
 823                          tp.c_cc[VMIN]  = 1;                \
 824                          tp.c_cc[VTIME] = 0;
 825
 826 #endif
 827
 828 static Bool messedWithTerminal = FALSE;
 829 static TermParams originalSettings;
 830
 831 Void normalTerminal() {                 /* restore terminal initial state  */
 832     if (messedWithTerminal)
 833         setTerminal(originalSettings);
 834 }
 835
 836 Void noechoTerminal() {                 /* set terminal into noecho mode   */
 837     TermParams settings;
 838
 839     if (!messedWithTerminal) {
 840         getTerminal(originalSettings);
 841         messedWithTerminal = TRUE;
 842     }
 843     getTerminal(settings);
 844     noEcho(settings);
 845     setTerminal(settings);
 846 }
 847
 848 Int getTerminalWidth() {                /* determine width of terminal     */
 849 #ifdef TIOCGWINSZ
 850 #ifdef _M_UNIX                          /* SCO Unix 3.2.4 defines TIOCGWINSZ*/
 851 #include <sys/stream.h>                 /* Required by sys/ptem.h          */
 852 #include <sys/ptem.h>                   /* Required to declare winsize     */
 853 #endif
 854     static struct winsize terminalSize;
 855     ioctl(fileno(stdout),TIOCGWINSZ,&terminalSize);
 856     return (terminalSize.ws_col==0)? 80 : terminalSize.ws_col;
 857 #else
 858     return 80;
 859 #endif
 860 }
 861
 862 Int readTerminalChar() {                /* read character from terminal    */
 863     return getchar();                   /* without echo, assuming that     */
 864 }                                       /* noechoTerminal() is active...   */
 865
 866 #elif SYMANTEC_C
 867
 868 Int readTerminalChar() {                /* read character from terminal    */
 869     return getchar();                   /* without echo, assuming that     */
 870 }                                       /* noechoTerminal() is active...   */
 871
 872 Int getTerminalWidth() {
 873     return console_options.ncols;
 874 }
 875
 876 Void normalTerminal() {
 877     csetmode(C_ECHO, stdin);
 878 }
 879
 880 Void noechoTerminal() {
 881     csetmode(C_NOECHO, stdin);
 882 }
 883
 884 #else /* no terminal driver - eg DOS, RISCOS */
 885
 886 static Bool terminalEchoReqd = TRUE;
 887
 888 Int getTerminalWidth() {
 889 #if RISCOS
 890     int dummy, width;
 891     (void) os_swi3r(OS_ReadModeVariable, -1, 1, 0, &dummy, &dummy, &width);
 892     return width+1;
 893 #else
 894     return 80;
 895 #endif
 896 }
 897
 898 Void normalTerminal() {                 /* restore terminal initial state  */
 899     terminalEchoReqd = TRUE;
 900 }
 901
 902 Void noechoTerminal() {                 /* turn terminal echo on/off       */
 903     terminalEchoReqd = FALSE;
 904 }
 905
 906 Int readTerminalChar() {                /* read character from terminal    */
 907     if (terminalEchoReqd) {
 908         return getchar();
 909     } else {
 910         Int c = getch();
 911         return c=='\r' ? '\n' : c;      /* slight paranoia about CR-LF    */
 912     }
 913 }
 914
 915 #endif /* no terminal driver */
 916
 917 /* --------------------------------------------------------------------------
 918  * Interrupt handling:
 919  * ------------------------------------------------------------------------*/
 920
 921 Bool    broken         = FALSE;
 922 static  Bool breakReqd = FALSE;
 923 static  sigProto(ignoreBreak);
 924 static  Void local installHandlers Args((Void));
 925
 926 Bool breakOn(reqd)                      /* set break trapping on if reqd,  */
 927 Bool reqd; {                            /* or off otherwise, returning old */
 928     Bool old  = breakReqd;
 929
 930     breakReqd = reqd;
 931     if (reqd) {
 932         if (broken) {                   /* repond to break signal received */
 933             broken = FALSE;             /* whilst break trap disabled      */
 934             sigRaise(breakHandler);
 935             /* not reached */
 936         }
 937 #if HANDLERS_CANT_LONGJMP
 938         ctrlbrk(ignoreBreak);
 939 #else
 940         ctrlbrk(breakHandler);
 941 #endif
 942     } else {
 943         ctrlbrk(ignoreBreak);
 944     }
 945     return old;
 946 }
 947
 948 static sigHandler(ignoreBreak) {        /* record but don't respond to break*/
 949     ctrlbrk(ignoreBreak);         /* reinstall signal handler               */
 950                                   /* redundant on BSD systems but essential */
 951                                   /* on POSIX and other systems             */
 952     broken = TRUE;
 953     interruptStgRts();
 954     sigResume;
 955 }
 956
 957 #if !DONT_PANIC
 958 static sigProto(panic);
 959 static sigHandler(panic) {              /* exit in a panic, on receipt of  */
 960     everybody(EXIT);                    /* an unexpected signal            */
 961     fprintf(stderr,"\nUnexpected signal\n");
 962     exit(1);
 963     sigResume;/*NOTREACHED*/
 964 }
 965 #endif /* !DONT_PANIC */
 966
 967 static Void local installHandlers() { /* Install handlers for all fatal    */
 968                                       /* signals except SIGINT and SIGBREAK*/
 969 #if !DONT_PANIC && !DOS
 970 # ifdef SIGABRT
 971     signal(SIGABRT,panic);
 972 # endif
 973 # ifdef SIGBUS
 974     signal(SIGBUS,panic);
 975 # endif
 976 # ifdef SIGFPE
 977     signal(SIGFPE,panic);
 978 # endif
 979 # ifdef SIGHUP
 980     signal(SIGHUP,panic);
 981 # endif
 982 # ifdef SIGILL
 983     signal(SIGILL,panic);
 984 # endif
 985 # ifdef SIGQUIT
 986     signal(SIGQUIT,panic);
 987 # endif
 988 # ifdef SIGSEGV
 989     signal(SIGSEGV,panic);
 990 # endif
 991 # ifdef SIGTERM
 992     signal(SIGTERM,panic);
 993 # endif
 994 #endif /* !DONT_PANIC && !DOS */
 995 }
 996
 997 /* --------------------------------------------------------------------------
 998  * Shell escapes:
 999  * ------------------------------------------------------------------------*/
1000
1001 static Bool local startEdit(line,nm)    /* Start editor on file name at    */
1002 Int    line;                            /* given line.  Both name and line */
1003 String nm; {                            /* or just line may be zero        */
1004     static char editorCmd[FILENAME_MAX+1];
1005
1006 #if !SYMANTEC_C
1007     if (hugsEdit && *hugsEdit) {        /* Check that editor configured    */
1008 #else
1009     /* On a Mac, files have creator information, telling which program
1010        to launch to, so an editor named to the empty string "" is often
1011        desirable. */
1012     if (hugsEdit) {        /* Check that editor configured    */
1013 #endif
1014         Int n     = FILENAME_MAX;
1015         String he = hugsEdit;
1016         String ec = editorCmd;
1017         String rd = NULL;               /* Set to nonnull to redo ...      */
1018
1019         for (; n>0 && *he && *he!=' '; n--)
1020             *ec++ = *he++;              /* Copy editor name to buffer      */
1021                                         /* assuming filename ends at space */
1022
1023         if (nm && line && n>1 && *he){  /* Name, line, and enough space    */
1024             rd = ec;                    /* save, in case we don't find name*/
1025             while (n>0 && *he) {
1026                 if (*he=='%') {
1027                     if (*++he=='d' && n>10) {
1028                         sprintf(ec,"%d",line);
1029                         he++;
1030                     }
1031                     else if (*he=='s' && (size_t)n>strlen(nm)) {
1032                         strcpy(ec,nm);
1033                         rd = NULL;
1034                         he++;
1035                     }
1036                     else if (*he=='%' && n>1) {
1037                         strcpy(ec,"%");
1038                         he++;
1039                     }
1040                     else                /* Ignore % char if not followed   */
1041                         *ec = '\0';     /* by one of d, s, or %,           */
1042                     for (; *ec && n>0; n--)
1043                         ec++;
1044                 }   /* ignore % followed by anything other than d, s, or % */
1045                 else {                  /* Copy other characters across    */
1046                     *ec++ = *he++;
1047                     n--;
1048                 }
1049             }
1050         }
1051         else
1052             line = 0;
1053
1054         if (rd) {                       /* If file name was not included   */
1055             ec   = rd;
1056             line = 0;
1057         }
1058
1059         if (nm && line==0 && n>1) {     /* Name, but no line ...           */
1060             *ec++ = ' ';
1061             for (; n>0 && *nm; n--)     /* ... just copy file name         */
1062                 *ec++ = *nm++;
1063         }
1064
1065         *ec = '\0';                     /* Add terminating null byte       */
1066     }
1067     else {
1068         ERRMSG(0) "Hugs is not configured to use an editor"
1069         EEND;
1070     }
1071
1072 #if HAVE_WINEXEC
1073     WinExec(editorCmd, SW_SHOW);
1074     return FALSE;
1075 #else
1076     if (shellEsc(editorCmd))
1077         Printf("Warning: Editor terminated abnormally\n");
1078     return TRUE;
1079 #endif
1080 }
1081
1082 Int shellEsc(s)                         /* run a shell command (or shell)  */
1083 String s; {
1084 #if HAVE_MACSYSTEM
1085     return macsystem(s);
1086 #else
1087 #if HAVE_BIN_SH
1088     if (s[0]=='\0') {
1089         s = fromEnv("SHELL","/bin/sh");
1090     }
1091 #endif
1092     return system(s);
1093 #endif
1094 }
1095
1096 #if RISCOS                              /* RISCOS also needs a chdir()     */
1097 int chdir(char *s) {                    /* RISCOS PRM p. 885    -- JBS     */
1098     return os_swi2(OS_FSControl + XOS_Bit, 0, (int)s) != NULL;
1099 }
1100 #elif defined HAVE_PBHSETVOLSYNC        /* Macintosh */
1101 int chdir(const char *s) {
1102     char* str;
1103     WDPBRec wd;
1104     wd.ioCompletion = 0;
1105     str = (char*)malloc(strlen(s) + 1);
1106     if (str == 0) return -1;
1107     strcpy(str, s);
1108     wd.ioNamePtr = C2PStr(str);
1109     wd.ioVRefNum = 0;
1110     wd.ioWDDirID = 0;
1111     errno = PBHSetVolSync(&wd);
1112     free(str);
1113     if (errno == 0) {
1114         return 0;
1115     } else {
1116         return -1;
1117     }
1118 }
1119 #endif
1120
1121
1122 /*---------------------------------------------------------------------------
1123  * Printf-related operations:
1124  *-------------------------------------------------------------------------*/
1125
1126 #if !defined(HAVE_VSNPRINTF)
1127 int vsnprintf(buffer, count, fmt, ap)
1128 char*       buffer;
1129 int         count;
1130 const char* fmt;
1131 va_list     ap; {
1132 #if defined(HAVE__VSNPRINTF)
1133     return _vsnprintf(buffer, count, fmt, ap);
1134 #else
1135     return 0;
1136 #endif
1137 }
1138 #endif /* HAVE_VSNPRINTF */
1139
1140 #if !defined(HAVE_SNPRINTF)
1141 int snprintf(char* buffer, int count, const char* fmt, ...) {
1142 #if defined(HAVE__VSNPRINTF)
1143     int r;
1144     va_list ap;                    /* pointer into argument list           */
1145     va_start(ap, fmt);             /* make ap point to first arg after fmt */
1146     r = vsnprintf(buffer, count, fmt, ap);
1147     va_end(ap);                    /* clean up                             */
1148     return r;
1149 #else
1150     return 0;
1151 #endif
1152 }
1153 #endif /* HAVE_SNPRINTF */
1154
1155 /* --------------------------------------------------------------------------
1156  * Read/write values from/to the registry
1157  *
1158  * All reads are from either HUGS_CURRENT_USER\\hugs_ROOT\\key or
1159  * HUGS_LOCAL_MACHINE\\hugs_ROOT\\key.  (Machine entry is only used if
1160  * user entry doesn't exist).
1161  *
1162  * All writes are to HUGS_CURRENT_USER\\HugsRoot\\key
1163  * ------------------------------------------------------------------------*/
1164
1165 #if USE_REGISTRY
1166
1167 #define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
1168
1169 static Bool   local createKey      Args((HKEY, PHKEY, REGSAM));
1170 static Bool   local queryValue     Args((HKEY, String, LPDWORD, LPBYTE, DWORD));
1171 static Bool   local setValue       Args((HKEY, String, DWORD, LPBYTE, DWORD));
1172
1173 static Bool local createKey(hKey, phRootKey, samDesired)
1174 HKEY    hKey;
1175 PHKEY   phRootKey;
1176 REGSAM  samDesired; {
1177     DWORD  dwDisp;
1178     return RegCreateKeyEx(hKey, HugsRoot,
1179                           0, "", REG_OPTION_NON_VOLATILE,
1180                           samDesired, NULL, phRootKey, &dwDisp)
1181            == ERROR_SUCCESS;
1182 }
1183
1184 static Bool local queryValue(hKey, regPath, var, type, buf, bufSize)
1185 HKEY    hKey;
1186 String  regPath;
1187 String  var;
1188 LPDWORD type;
1189 LPBYTE  buf;
1190 DWORD   bufSize; {
1191     HKEY hRootKey;
1192
1193     if (!createKey(hKey, regPath, &hRootKey, KEY_READ)) {
1194         return FALSE;
1195     } else {
1196         LONG res = RegQueryValueEx(hRootKey, var, NULL, type, buf, &bufSize);
1197         RegCloseKey(hRootKey);
1198         return (res == ERROR_SUCCESS);
1199     }
1200 }
1201
1202 static Bool local setValue(hKey, regPath, var, type, buf, bufSize)
1203 HKEY   hKey;
1204 String regPath;
1205 String var;
1206 DWORD  type;
1207 LPBYTE buf;
1208 DWORD  bufSize; {
1209     HKEY hRootKey;
1210
1211     if (!createKey(hKey, regPath, &hRootKey, KEY_WRITE)) {
1212         return FALSE;
1213     } else {
1214         LONG res = RegSetValueEx(hRootKey, var, 0, type, buf, bufSize);
1215         RegCloseKey(hRootKey);
1216         return (res == ERROR_SUCCESS);
1217     }
1218 }
1219
1220 static String local readRegString(key,regPath,var,def) /* read String from registry */
1221 HKEY   key;
1222 String regPath;
1223 String var;
1224 String def; {
1225     static char  buf[300];
1226     DWORD type;
1227     if (queryValue(key, regPath,var, &type, buf, sizeof(buf))
1228         && type == REG_SZ) {
1229         return (String)buf;
1230     } else {
1231         return def;
1232     }
1233 }
1234
1235 static Int local readRegInt(var, def)            /* read Int from registry */
1236 String var;
1237 Int    def; {
1238     DWORD buf;
1239     DWORD type;
1240
1241     if (queryValue(HKEY_CURRENT_USER, HugsRoot, var, &type,
1242                    (LPBYTE)&buf, sizeof(buf))
1243         && type == REG_DWORD) {
1244         return (Int)buf;
1245     } else if (queryValue(HKEY_LOCAL_MACHINE, HugsRoot, var, &type,
1246                           (LPBYTE)&buf, sizeof(buf))
1247                && type == REG_DWORD) {
1248         return (Int)buf;
1249     } else {
1250         return def;
1251     }
1252 }
1253
1254 static Bool local writeRegString(var,val)      /* write String to registry */
1255 String var;
1256 String val; {
1257     if (NULL == val) {
1258         val = "";
1259     }
1260     return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1261                     REG_SZ, (LPBYTE)val, lstrlen(val)+1);
1262 }
1263
1264 static Bool local writeRegInt(var,val)         /* write String to registry */
1265 String var;
1266 Int    val; {
1267     return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1268                     REG_DWORD, (LPBYTE)&val, sizeof(val));
1269 }
1270
1271 #endif /* USE_REGISTRY */
1272
1273 /* --------------------------------------------------------------------------
1274  * Machine dependent control:
1275  * ------------------------------------------------------------------------*/
1276
1277 Void machdep(what)                      /* Handle machine specific         */
1278 Int what; {                             /* initialisation etc..            */
1279     switch (what) {
1280         case MARK    : break;
1281         case INSTALL : installHandlers();
1282                        break;
1283         case RESET   :
1284         case BREAK   :
1285         case EXIT    : normalTerminal();
1286 #if HUGS_FOR_WINDOWS
1287                        if (what==EXIT)
1288                            DestroyWindow(hWndMain);
1289                        else
1290                            SetCursor(LoadCursor(NULL,IDC_ARROW));
1291 #endif
1292                        break;
1293     }
1294 }
1295
1296 /*-------------------------------------------------------------------------*/