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.3 $
  16  * $Date: 1999/02/03 17:08:32 $
  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
 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
 328 static int local pathCmp(p1,p2)       /* Compare paths after normalisation */
 329 String p1;
 330 String p2; {
 331 #if HAVE__FULLPATH  /* eg DOS */
 332     static char path1[FILENAME_MAX+1];
 333     static char path2[FILENAME_MAX+1];
 334     _fullpath(path1,p1,FILENAME_MAX+1);
 335     _fullpath(path2,p2,FILENAME_MAX+1);
 336 #elif HAVE_REALPATH /* eg Unix */
 337     static char path1[MAXPATHLEN+1];
 338     static char path2[MAXPATHLEN+1];
 339     realpath(p1,path1);
 340     realpath(p2,path2);
 341 #else
 342     static char path1[FILENAME_MAX+1];
 343     static char path2[FILENAME_MAX+1];
 344     strcpy(path1,p1);
 345     strcpy(path2,p2);
 346 #endif
 347 #if CASE_INSENSITIVE_FILENAMES
 348     strlwr(path1);
 349     strlwr(path2);
 350 #endif
 351     return filenamecmp(path1,path2);
 352 }
 353
 354 static String local normPath(s) /* Try, as much as possible, to normalize  */
 355 String s; {                     /* a pathname in some appropriate manner.  */
 356 #if PATH_CANONICALIZATION
 357     String path = RealPath(s);
 358 #if CASE_INSENSITIVE_FILENAMES
 359     strlwr(path);                       /* and convert to lowercase        */
 360 #endif
 361     return path;
 362 #else /* ! PATH_CANONICALIZATION */
 363     return s;
 364 #endif /* ! PATH_CANONICALIZATION */
 365 }
 366
 367 #if HSCRIPT
 368 static String endings[] = { "", ".hs", ".lhs", ".hsx", ".hash", 0 };
 369 #else
 370 static String endings[] = { "", ".hs", ".lhs", 0 };
 371 #endif
 372 static char   searchBuf[FILENAME_MAX+1];
 373 static Int    searchPos;
 374
 375 #define searchReset(n)          searchBuf[searchPos=(n)]='\0'
 376
 377 static Void local searchChr(c)  /* Add single character to search buffer   */
 378 Int c; {
 379     if (searchPos<FILENAME_MAX) {
 380         searchBuf[searchPos++] = (char)c;
 381         searchBuf[searchPos]   = '\0';
 382     }
 383 }
 384
 385 static Void local searchStr(s)  /* Add string to search buffer             */
 386 String s; {
 387     while (*s && searchPos<FILENAME_MAX)
 388         searchBuf[searchPos++] = *s++;
 389     searchBuf[searchPos] = '\0';
 390 }
 391
 392 static Bool local tryEndings(s) /* Try each of the listed endings          */
 393 String s; {
 394     Int i = 0;
 395     searchStr(s);
 396     for (; endings[i]; ++i) {
 397         Int save = searchPos;
 398         searchStr(endings[i]);
 399         if (readable(searchBuf))
 400             return TRUE;
 401         searchReset(save);
 402     }
 403     return FALSE;
 404 }
 405
 406
 407
 408 #if SEARCH_DIR
 409
 410 /* scandir, June 98 Daan Leijen
 411    searches the base directory and its direct subdirectories for a file
 412
 413    input: searchbuf contains SLASH terminated base directory
 414               argument s contains the (base) filename
 415    output: TRUE: searchBuf contains the full filename
 416                    FALSE: searchBuf is garbage, file not found
 417 */
 418
 419
 420 #ifdef HAVE_WINDOWS_H
 421
 422 static Bool scanSubDirs(s)
 423 String s;
 424 {
 425     struct _finddata_t findInfo;
 426     long handle;
 427     int  save;
 428
 429     save = searchPos;
 430     /* is it in the current directory ? */
 431     if (tryEndings(s)) return TRUE;
 432
 433     searchReset(save);
 434     searchStr("*");
 435
 436     /* initiate the search */
 437     handle = _findfirst( searchBuf, &findInfo );
 438     if (handle==-1) { errno = 0; return FALSE; }
 439
 440     /* search all subdirectories */
 441     do {
 442         /* if we have a valid sub directory */
 443         if (((findInfo.attrib & _A_SUBDIR) == _A_SUBDIR) &&
 444             (findInfo.name[0] != '.')) {
 445             searchReset(save);
 446             searchStr(findInfo.name);
 447             searchChr(SLASH);
 448             if (tryEndings(s)) {
 449                 return TRUE;
 450             }
 451         }
 452     } while (_findnext( handle, &findInfo ) == 0);
 453
 454     _findclose( handle );
 455     return FALSE;
 456 }
 457
 458 #elif defined(HAVE_FTW_H)
 459
 460 #include <ftw.h>
 461
 462 static char baseFile[FILENAME_MAX+1];
 463 static char basePath[FILENAME_MAX+1];
 464 static int  basePathLen;
 465
 466 static int scanitem( const char* path,
 467                      const struct stat* statinfo,
 468                      int info )
 469 {
 470     if (info == FTW_D) { /* is it a directory */
 471         searchReset(0);
 472         searchStr(path);
 473         searchChr(SLASH);
 474         if (tryEndings(baseFile)) {
 475             return 1;
 476         }
 477     }
 478     return 0;
 479 }
 480
 481 static Bool scanSubDirs(s)
 482 String s;
 483 {
 484     int r;
 485     strcpy(baseFile,s);
 486     strcpy(basePath,searchBuf);
 487     basePathLen = strlen(basePath);
 488
 489     /* is it in the current directory ? */
 490     if (tryEndings(s)) return TRUE;
 491
 492     /* otherwise scan the subdirectories */
 493     r = ftw( basePath, scanitem, 2 );
 494     errno = 0;
 495     return (r > 0);
 496 }
 497
 498 #endif /* HAVE_WINDOWS_H || HAVE_FTW_H */
 499 #endif /* SEARCH_DIR */
 500
 501 String findPathname(along,nm)   /* Look for a file along specified path    */
 502 String along;                   /* Return NULL if file does not exist      */
 503 String nm; {
 504     /* AC, 1/21/99: modified to search hugsPath first, then projectPath */
 505     String s = findMPathname(along,nm,hugsPath);
 506 #if USE_REGISTRY
 507 #if 0
 508  ToDo:
 509     if (s==NULL) {
 510         s = findMPathname(along,nm,projectPath);
 511     }
 512 #endif /* 0 */
 513 #endif /* USE_REGISTRY */
 514     return s ? s : normPath(searchBuf);
 515 }
 516
 517 /* AC, 1/21/99: modified to pass in path to search explicitly */
 518 String findMPathname(along,nm,path)/* Look for a file along specified path   */
 519 String along;                   /* If nonzero, a path prefix from along is */
 520 String nm;                      /* used as the first prefix in the search. */
 521 String path; {
 522     String pathpt = path;
 523
 524     searchReset(0);
 525     if (along) {                /* Was a path for an existing file given?  */
 526         Int last = (-1);
 527         Int i    = 0;
 528         for (; along[i]; i++) {
 529             searchChr(along[i]);
 530             if (isSLASH(along[i]))
 531                 last = i;
 532         }
 533         searchReset(last+1);
 534     }
 535     if (tryEndings(nm))
 536         return normPath(searchBuf);
 537
 538     if (pathpt && *pathpt) {    /* Otherwise, we look along the HUGSPATH   */
 539         Bool more = TRUE;
 540         do {
 541             Bool recurse = FALSE;   /* DL: shall we recurse ? */
 542             searchReset(0);
 543             if (*pathpt) {
 544                 if (*pathpt!=PATHSEP) {
 545                     /* Pre-define one MPW-style "shell-variable" */
 546                     if (strncmp(pathpt,"{Hugs}",6)==0) {
 547                         searchStr(hugsdir());
 548                         pathpt += 6;
 549                     }
 550 #if HSCRIPT
 551                     /* And another - we ought to generalise this stuff */
 552                     else if (strncmp(pathpt,"{HScript}",9)==0) {
 553                         searchStr(hscriptDir());
 554                         pathpt += 9;
 555                     }
 556 #endif
 557                     do {
 558                         searchChr(*pathpt++);
 559                     } while (*pathpt && *pathpt!=PATHSEP);
 560                     recurse = (pathpt[-1] == SLASH);
 561                     if (!recurse) {
 562                         searchChr(SLASH);
 563                     }
 564                 }
 565                 if (*pathpt==PATHSEP)
 566                     pathpt++;
 567                 else
 568                     more = FALSE;
 569             } else {
 570                 more = FALSE;
 571             }
 572 #if SEARCH_DIR
 573             if (recurse ? scanSubDirs(nm) : tryEndings(nm)) {
 574                 return normPath(searchBuf);
 575             }
 576 #else
 577             if (tryEndings(nm)) {
 578                 return normPath(searchBuf);
 579             }
 580 #endif
 581         } while (more);
 582     }
 583
 584     searchReset(0);  /* As a last resort, look for file in the current dir */
 585     return (tryEndings(nm) ? normPath(searchBuf) : 0);
 586 }
 587
 588 /* --------------------------------------------------------------------------
 589  * Substitute old value of path into empty entries in new path
 590  * eg substPath("a:b:c::d:e","x:y:z") = "a:b:c:x:y:z:d:e"
 591  * ------------------------------------------------------------------------*/
 592
 593 static String local substPath Args((String,String));
 594
 595 static String local substPath(new,sub) /* substitute sub path into new path*/
 596 String new;
 597 String sub; {
 598     Bool   substituted = FALSE;            /*   only allow one replacement */
 599     Int    maxlen      = strlen(sub) + strlen(new);    /* safe upper bound */
 600     String r = (String) malloc(maxlen+1);  /* result string                */
 601     String t = r;                          /* pointer into r               */
 602     String next = new;                     /* next uncopied char in new    */
 603     String start = next;                   /* start of last path component */
 604     if (r == 0) {
 605         ERRMSG(0) "String storage space exhausted"
 606         EEND;
 607     }
 608     do {
 609         if (*next == PATHSEP || *next == '\0') {
 610             if (!substituted && next == start) {
 611                 String s = sub;
 612                 for(; *s != '\0'; ++s) {
 613                     *t++ = *s;
 614                 }
 615                 substituted = TRUE;
 616             }
 617             start = next+1;
 618         }
 619     } while ((*t++ = *next++) != '\0');
 620     return r;
 621 }
 622
 623
 624 /* --------------------------------------------------------------------------
 625  * Get time/date stamp for inclusion in compiled files:
 626  * ------------------------------------------------------------------------*/
 627
 628 #if PROFILING
 629 String timeString() {                   /* return time&date string         */
 630     time_t clock;                       /* must end with '\n' character    */
 631     time(&clock);
 632     return(ctime(&clock));
 633 }
 634 #endif
 635
 636 /* --------------------------------------------------------------------------
 637  * Garbage collection notification:
 638  * ------------------------------------------------------------------------*/
 639
 640 Bool gcMessages = FALSE;                /* TRUE => print GC messages       */
 641
 642 Void gcStarted() {                      /* Notify garbage collector start  */
 643 #if HUGS_FOR_WINDOWS
 644     SaveCursor = SetCursor(GarbageCursor);
 645 #endif
 646     if (gcMessages) {
 647         Printf("{{Gc");
 648         FlushStdout();
 649     }
 650 }
 651
 652 Void gcScanning() {                     /* Notify garbage collector scans  */
 653     if (gcMessages) {
 654         Putchar(':');
 655         FlushStdout();
 656     }
 657 }
 658
 659 Void gcRecovered(recovered)             /* Notify garbage collection done  */
 660 Int recovered; {
 661     if (gcMessages) {
 662         Printf("%d}}",recovered);
 663         FlushStdout();
 664     }
 665 #if HUGS_FOR_WINDOWS
 666     SetCursor(SaveCursor);
 667 #endif
 668 }
 669
 670 Cell *CStackBase;                       /* Retain start of C control stack */
 671
 672 #if RISCOS                              /* Stack traversal for RISCOS      */
 673
 674 /* Warning: The following code is specific to the Acorn ARM under RISCOS
 675    (and C4).  We must explicitly walk back through the stack frames, since
 676    the stack is extended from the heap. (see PRM pp. 1757).  gcCStack must
 677    not be modified, since the offset '5' assumes that only v1 is used inside
 678    this function. Hence we do all the real work in gcARM.
 679 */
 680
 681 #define spreg 13 /* C3 has SP=R13 */
 682
 683 #define previousFrame(fp)       ((int *)((fp)[-3]))
 684 #define programCounter(fp)      ((int *)((*(fp)-12) & ~0xFC000003))
 685 #define isSubSPSP(w)            (((w)&dontCare) == doCare)
 686 #define doCare                  (0xE24DD000)  /* SUB r13,r13,#0 */
 687 #define dontCare                (~0x00100FFF) /* S and # bits   */
 688 #define immediateArg(x)         ( ((x)&0xFF) << (((x)&0xF00)>>7) )
 689
 690 static void gcARM(int *fp) {
 691     int si = *programCounter(fp);       /* Save instruction indicates how */
 692                                         /* many registers in this frame   */
 693     int *regs = fp - 4;
 694     if (si & (1<<0)) markWithoutMove(*regs--);
 695     if (si & (1<<1)) markWithoutMove(*regs--);
 696     if (si & (1<<2)) markWithoutMove(*regs--);
 697     if (si & (1<<3)) markWithoutMove(*regs--);
 698     if (si & (1<<4)) markWithoutMove(*regs--);
 699     if (si & (1<<5)) markWithoutMove(*regs--);
 700     if (si & (1<<6)) markWithoutMove(*regs--);
 701     if (si & (1<<7)) markWithoutMove(*regs--);
 702     if (si & (1<<8)) markWithoutMove(*regs--);
 703     if (si & (1<<9)) markWithoutMove(*regs--);
 704     if (previousFrame(fp)) {
 705         /* The non-register stack space is for the previous frame is above
 706            this fp, and not below the previous fp, because of the way stack
 707            extension works. It seems the only way of discovering its size is
 708            finding the SUB sp, sp, #? instruction by walking through the code
 709            following the entry point.
 710         */
 711         int *oldpc = programCounter(previousFrame(fp));
 712         int fsize = 0, i;
 713         for(i = 1; i < 6; ++i)
 714             if(isSubSPSP(oldpc[i])) fsize += immediateArg(oldpc[i]) / 4;
 715         for(i=1; i<=fsize; ++i)
 716             markWithoutMove(fp[i]);
 717     }
 718 }
 719
 720 void gcCStack() {
 721     int dummy;
 722     int *fp = 5 + &dummy;
 723     while (fp) {
 724         gcARM(fp);
 725         fp = previousFrame(fp);
 726     }
 727 }
 728
 729 #else                   /* Garbage collection for standard stack machines  */
 730
 731 Void gcCStack() {                       /* Garbage collect elements off    */
 732     Cell stackTop = NIL;                /* C stack                         */
 733     Cell *ptr = &stackTop;
 734 #if SIZEOF_INTP == 2
 735     if (((long)(ptr) - (long)(CStackBase))&1)
 736         fatal("gcCStack");
 737 #elif STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
 738     if (((long)(ptr) - (long)(CStackBase))&1)
 739         fatal("gcCStack");
 740 #else
 741     if (((long)(ptr) - (long)(CStackBase))&3)
 742         fatal("gcCStack");
 743 #endif
 744
 745 #define StackGrowsDown  while (ptr<=CStackBase) markWithoutMove(*ptr++)
 746 #define StackGrowsUp    while (ptr>=CStackBase) markWithoutMove(*ptr--)
 747 #define GuessDirection  if (ptr>CStackBase) StackGrowsUp; else StackGrowsDown
 748
 749 #if STACK_DIRECTION > 0
 750     StackGrowsUp;
 751 #elif STACK_DIRECTION < 0
 752     StackGrowsDown;
 753 #else
 754     GuessDirection;
 755 #endif
 756
 757 #if SIZEOF_INTP==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
 758     ptr = (Cell *)((long)(&stackTop) + 2);
 759     StackGrowsDown;
 760 #endif
 761
 762 #undef  StackGrowsDown
 763 #undef  StackGrowsUp
 764 #undef  GuessDirection
 765 }
 766 #endif
 767
 768 /* --------------------------------------------------------------------------
 769  * Terminal dependent stuff:
 770  * ------------------------------------------------------------------------*/
 771
 772 #if (HAVE_TERMIO_H | HAVE_SGTTY_H | HAVE_TERMIOS_H)
 773
 774 /* grab the varargs prototype for ioctl */
 775 #if HAVE_SYS_IOCTL_H
 776 # include <sys/ioctl.h>
 777 #endif
 778
 779 /* The order of these three tests is very important because
 780  * some systems have more than one of the requisite header file
 781  * but only one of them seems to work.
 782  * Anyone changing the order of the tests should try enabling each of the
 783  * three branches in turn and write down which ones work as well as which
 784  * OS/compiler they're using.
 785  *
 786  * OS            Compiler      sgtty     termio  termios   notes
 787  * Linux 2.0.18  gcc 2.7.2     absent    works   works     1
 788  *
 789  * Notes:
 790  * 1) On Linux, termio.h just #includes termios.h and sgtty.h is
 791  *    implemented using termios.h.
 792  *    sgtty.h is in /usr/include/bsd which is not on my standard include
 793  *    path.  Adding it does no harm but you might as well use termios.
 794  *    --
 795  *    reid-alastair@cs.yale.edu
 796  */
 797 #if HAVE_TERMIOS_H
 798
 799 #include <termios.h>
 800 typedef  struct termios  TermParams;
 801 #define  getTerminal(tp) tcgetattr(fileno(stdin), &tp)
 802 #define  setTerminal(tp) tcsetattr(fileno(stdin), TCSAFLUSH, &tp)
 803 #define  noEcho(tp)      tp.c_lflag    &= ~(ICANON | ECHO); \
 804                          tp.c_cc[VMIN]  = 1;                \
 805                          tp.c_cc[VTIME] = 0;
 806
 807 #elif HAVE_SGTTY_H
 808
 809 #include <sgtty.h>
 810 typedef  struct sgttyb   TermParams;
 811 #define  getTerminal(tp) ioctl(fileno(stdin),TIOCGETP,&tp)
 812 #define  setTerminal(tp) ioctl(fileno(stdin),TIOCSETP,&tp)
 813 #if HPUX
 814 #define  noEcho(tp)      tp.sg_flags |= RAW; tp.sg_flags &= (~ECHO);
 815 #else
 816 #define  noEcho(tp)      tp.sg_flags |= CBREAK; tp.sg_flags &= (~ECHO);
 817 #endif
 818
 819 #elif HAVE_TERMIO_H
 820
 821 #include <termio.h>
 822 typedef  struct termio   TermParams;
 823 #define  getTerminal(tp) ioctl(fileno(stdin),TCGETA,&tp)
 824 #define  setTerminal(tp) ioctl(fileno(stdin),TCSETAF,&tp)
 825 #define  noEcho(tp)      tp.c_lflag    &= ~(ICANON | ECHO); \
 826                          tp.c_cc[VMIN]  = 1;                \
 827                          tp.c_cc[VTIME] = 0;
 828
 829 #endif
 830
 831 static Bool messedWithTerminal = FALSE;
 832 static TermParams originalSettings;
 833
 834 Void normalTerminal() {                 /* restore terminal initial state  */
 835     if (messedWithTerminal)
 836         setTerminal(originalSettings);
 837 }
 838
 839 Void noechoTerminal() {                 /* set terminal into noecho mode   */
 840     TermParams settings;
 841
 842     if (!messedWithTerminal) {
 843         getTerminal(originalSettings);
 844         messedWithTerminal = TRUE;
 845     }
 846     getTerminal(settings);
 847     noEcho(settings);
 848     setTerminal(settings);
 849 }
 850
 851 Int getTerminalWidth() {                /* determine width of terminal     */
 852 #ifdef TIOCGWINSZ
 853 #ifdef _M_UNIX                          /* SCO Unix 3.2.4 defines TIOCGWINSZ*/
 854 #include <sys/stream.h>                 /* Required by sys/ptem.h          */
 855 #include <sys/ptem.h>                   /* Required to declare winsize     */
 856 #endif
 857     static struct winsize terminalSize;
 858     ioctl(fileno(stdout),TIOCGWINSZ,&terminalSize);
 859     return (terminalSize.ws_col==0)? 80 : terminalSize.ws_col;
 860 #else
 861     return 80;
 862 #endif
 863 }
 864
 865 Int readTerminalChar() {                /* read character from terminal    */
 866     return getchar();                   /* without echo, assuming that     */
 867 }                                       /* noechoTerminal() is active...   */
 868
 869 #elif SYMANTEC_C
 870
 871 Int readTerminalChar() {                /* read character from terminal    */
 872     return getchar();                   /* without echo, assuming that     */
 873 }                                       /* noechoTerminal() is active...   */
 874
 875 Int getTerminalWidth() {
 876     return console_options.ncols;
 877 }
 878
 879 Void normalTerminal() {
 880     csetmode(C_ECHO, stdin);
 881 }
 882
 883 Void noechoTerminal() {
 884     csetmode(C_NOECHO, stdin);
 885 }
 886
 887 #else /* no terminal driver - eg DOS, RISCOS */
 888
 889 static Bool terminalEchoReqd = TRUE;
 890
 891 Int getTerminalWidth() {
 892 #if RISCOS
 893     int dummy, width;
 894     (void) os_swi3r(OS_ReadModeVariable, -1, 1, 0, &dummy, &dummy, &width);
 895     return width+1;
 896 #else
 897     return 80;
 898 #endif
 899 }
 900
 901 Void normalTerminal() {                 /* restore terminal initial state  */
 902     terminalEchoReqd = TRUE;
 903 }
 904
 905 Void noechoTerminal() {                 /* turn terminal echo on/off       */
 906     terminalEchoReqd = FALSE;
 907 }
 908
 909 Int readTerminalChar() {                /* read character from terminal    */
 910     if (terminalEchoReqd) {
 911         return getchar();
 912     } else {
 913         Int c = getch();
 914         return c=='\r' ? '\n' : c;      /* slight paranoia about CR-LF    */
 915     }
 916 }
 917
 918 #endif /* no terminal driver */
 919
 920 /* --------------------------------------------------------------------------
 921  * Interrupt handling:
 922  * ------------------------------------------------------------------------*/
 923
 924 Bool    broken         = FALSE;
 925 static  Bool breakReqd = FALSE;
 926 static  sigProto(ignoreBreak);
 927 static  Void local installHandlers Args((Void));
 928
 929 Bool breakOn(reqd)                      /* set break trapping on if reqd,  */
 930 Bool reqd; {                            /* or off otherwise, returning old */
 931     Bool old  = breakReqd;
 932
 933     breakReqd = reqd;
 934     if (reqd) {
 935         if (broken) {                   /* repond to break signal received */
 936             broken = FALSE;             /* whilst break trap disabled      */
 937             sigRaise(breakHandler);
 938             /* not reached */
 939         }
 940 #if HANDLERS_CANT_LONGJMP
 941         ctrlbrk(ignoreBreak);
 942 #else
 943         ctrlbrk(breakHandler);
 944 #endif
 945     } else {
 946         ctrlbrk(ignoreBreak);
 947     }
 948     return old;
 949 }
 950
 951 static sigHandler(ignoreBreak) {        /* record but don't respond to break*/
 952     ctrlbrk(ignoreBreak);         /* reinstall signal handler               */
 953                                   /* redundant on BSD systems but essential */
 954                                   /* on POSIX and other systems             */
 955     broken = TRUE;
 956     interruptStgRts();
 957     sigResume;
 958 }
 959
 960 #if !DONT_PANIC
 961 static sigProto(panic);
 962 static sigHandler(panic) {              /* exit in a panic, on receipt of  */
 963     everybody(EXIT);                    /* an unexpected signal            */
 964     fprintf(stderr,"\nUnexpected signal\n");
 965     exit(1);
 966     sigResume;/*NOTREACHED*/
 967 }
 968 #endif /* !DONT_PANIC */
 969
 970 static Void local installHandlers() { /* Install handlers for all fatal    */
 971                                       /* signals except SIGINT and SIGBREAK*/
 972 #if !DONT_PANIC && !DOS
 973 # ifdef SIGABRT
 974     signal(SIGABRT,panic);
 975 # endif
 976 # ifdef SIGBUS
 977     signal(SIGBUS,panic);
 978 # endif
 979 # ifdef SIGFPE
 980     signal(SIGFPE,panic);
 981 # endif
 982 # ifdef SIGHUP
 983     signal(SIGHUP,panic);
 984 # endif
 985 # ifdef SIGILL
 986     signal(SIGILL,panic);
 987 # endif
 988 # ifdef SIGQUIT
 989     signal(SIGQUIT,panic);
 990 # endif
 991 # ifdef SIGSEGV
 992     signal(SIGSEGV,panic);
 993 # endif
 994 # ifdef SIGTERM
 995     signal(SIGTERM,panic);
 996 # endif
 997 #endif /* !DONT_PANIC && !DOS */
 998 }
 999
1000 /* --------------------------------------------------------------------------
1001  * Shell escapes:
1002  * ------------------------------------------------------------------------*/
1003
1004 static Bool local startEdit(line,nm)    /* Start editor on file name at    */
1005 Int    line;                            /* given line.  Both name and line */
1006 String nm; {                            /* or just line may be zero        */
1007     static char editorCmd[FILENAME_MAX+1];
1008
1009 #if !SYMANTEC_C
1010     if (hugsEdit && *hugsEdit) {        /* Check that editor configured    */
1011 #else
1012     /* On a Mac, files have creator information, telling which program
1013        to launch to, so an editor named to the empty string "" is often
1014        desirable. */
1015     if (hugsEdit) {        /* Check that editor configured    */
1016 #endif
1017         Int n     = FILENAME_MAX;
1018         String he = hugsEdit;
1019         String ec = editorCmd;
1020         String rd = NULL;               /* Set to nonnull to redo ...      */
1021
1022         for (; n>0 && *he && *he!=' '; n--)
1023             *ec++ = *he++;              /* Copy editor name to buffer      */
1024                                         /* assuming filename ends at space */
1025
1026         if (nm && line && n>1 && *he){  /* Name, line, and enough space    */
1027             rd = ec;                    /* save, in case we don't find name*/
1028             while (n>0 && *he) {
1029                 if (*he=='%') {
1030                     if (*++he=='d' && n>10) {
1031                         sprintf(ec,"%d",line);
1032                         he++;
1033                     }
1034                     else if (*he=='s' && (size_t)n>strlen(nm)) {
1035                         strcpy(ec,nm);
1036                         rd = NULL;
1037                         he++;
1038                     }
1039                     else if (*he=='%' && n>1) {
1040                         strcpy(ec,"%");
1041                         he++;
1042                     }
1043                     else                /* Ignore % char if not followed   */
1044                         *ec = '\0';     /* by one of d, s, or %,           */
1045                     for (; *ec && n>0; n--)
1046                         ec++;
1047                 }   /* ignore % followed by anything other than d, s, or % */
1048                 else {                  /* Copy other characters across    */
1049                     *ec++ = *he++;
1050                     n--;
1051                 }
1052             }
1053         }
1054         else
1055             line = 0;
1056
1057         if (rd) {                       /* If file name was not included   */
1058             ec   = rd;
1059             line = 0;
1060         }
1061
1062         if (nm && line==0 && n>1) {     /* Name, but no line ...           */
1063             *ec++ = ' ';
1064             for (; n>0 && *nm; n--)     /* ... just copy file name         */
1065                 *ec++ = *nm++;
1066         }
1067
1068         *ec = '\0';                     /* Add terminating null byte       */
1069     }
1070     else {
1071         ERRMSG(0) "Hugs is not configured to use an editor"
1072         EEND;
1073     }
1074
1075 #if HAVE_WINEXEC
1076     WinExec(editorCmd, SW_SHOW);
1077     return FALSE;
1078 #else
1079     if (shellEsc(editorCmd))
1080         Printf("Warning: Editor terminated abnormally\n");
1081     return TRUE;
1082 #endif
1083 }
1084
1085 Int shellEsc(s)                         /* run a shell command (or shell)  */
1086 String s; {
1087 #if HAVE_MACSYSTEM
1088     return macsystem(s);
1089 #else
1090 #if HAVE_BIN_SH
1091     if (s[0]=='\0') {
1092         s = fromEnv("SHELL","/bin/sh");
1093     }
1094 #endif
1095     return system(s);
1096 #endif
1097 }
1098
1099 #if RISCOS                              /* RISCOS also needs a chdir()     */
1100 int chdir(char *s) {                    /* RISCOS PRM p. 885    -- JBS     */
1101     return os_swi2(OS_FSControl + XOS_Bit, 0, (int)s) != NULL;
1102 }
1103 #elif defined HAVE_PBHSETVOLSYNC        /* Macintosh */
1104 int chdir(const char *s) {
1105     char* str;
1106     WDPBRec wd;
1107     wd.ioCompletion = 0;
1108     str = (char*)malloc(strlen(s) + 1);
1109     if (str == 0) return -1;
1110     strcpy(str, s);
1111     wd.ioNamePtr = C2PStr(str);
1112     wd.ioVRefNum = 0;
1113     wd.ioWDDirID = 0;
1114     errno = PBHSetVolSync(&wd);
1115     free(str);
1116     if (errno == 0) {
1117         return 0;
1118     } else {
1119         return -1;
1120     }
1121 }
1122 #endif
1123
1124
1125 /*---------------------------------------------------------------------------
1126  * Printf-related operations:
1127  *-------------------------------------------------------------------------*/
1128
1129 #if !defined(HAVE_VSNPRINTF)
1130 int vsnprintf(buffer, count, fmt, ap)
1131 char*       buffer;
1132 int         count;
1133 const char* fmt;
1134 va_list     ap; {
1135 #if defined(HAVE__VSNPRINTF)
1136     return _vsnprintf(buffer, count, fmt, ap);
1137 #else
1138     return 0;
1139 #endif
1140 }
1141 #endif /* HAVE_VSNPRINTF */
1142
1143 #if !defined(HAVE_SNPRINTF)
1144 int snprintf(char* buffer, int count, const char* fmt, ...) {
1145 #if defined(HAVE__VSNPRINTF)
1146     int r;
1147     va_list ap;                    /* pointer into argument list           */
1148     va_start(ap, fmt);             /* make ap point to first arg after fmt */
1149     r = vsnprintf(buffer, count, fmt, ap);
1150     va_end(ap);                    /* clean up                             */
1151     return r;
1152 #else
1153     return 0;
1154 #endif
1155 }
1156 #endif /* HAVE_SNPRINTF */
1157
1158 /* --------------------------------------------------------------------------
1159  * Read/write values from/to the registry
1160  *
1161  * All reads are from either HUGS_CURRENT_USER\\hugs_ROOT\\key or
1162  * HUGS_LOCAL_MACHINE\\hugs_ROOT\\key.  (Machine entry is only used if
1163  * user entry doesn't exist).
1164  *
1165  * All writes are to HUGS_CURRENT_USER\\HugsRoot\\key
1166  * ------------------------------------------------------------------------*/
1167
1168 #if USE_REGISTRY
1169
1170 #define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
1171
1172 static Bool   local createKey      Args((HKEY, PHKEY, REGSAM));
1173 static Bool   local queryValue     Args((HKEY, String, LPDWORD, LPBYTE, DWORD));
1174 static Bool   local setValue       Args((HKEY, String, DWORD, LPBYTE, DWORD));
1175
1176 static Bool local createKey(hKey, phRootKey, samDesired)
1177 HKEY    hKey;
1178 PHKEY   phRootKey;
1179 REGSAM  samDesired; {
1180     DWORD  dwDisp;
1181     return RegCreateKeyEx(hKey, HugsRoot,
1182                           0, "", REG_OPTION_NON_VOLATILE,
1183                           samDesired, NULL, phRootKey, &dwDisp)
1184            == ERROR_SUCCESS;
1185 }
1186
1187 static Bool local queryValue(hKey, regPath, var, type, buf, bufSize)
1188 HKEY    hKey;
1189 String  regPath;
1190 String  var;
1191 LPDWORD type;
1192 LPBYTE  buf;
1193 DWORD   bufSize; {
1194     HKEY hRootKey;
1195
1196     if (!createKey(hKey, regPath, &hRootKey, KEY_READ)) {
1197         return FALSE;
1198     } else {
1199         LONG res = RegQueryValueEx(hRootKey, var, NULL, type, buf, &bufSize);
1200         RegCloseKey(hRootKey);
1201         return (res == ERROR_SUCCESS);
1202     }
1203 }
1204
1205 static Bool local setValue(hKey, regPath, var, type, buf, bufSize)
1206 HKEY   hKey;
1207 String regPath;
1208 String var;
1209 DWORD  type;
1210 LPBYTE buf;
1211 DWORD  bufSize; {
1212     HKEY hRootKey;
1213
1214     if (!createKey(hKey, regPath, &hRootKey, KEY_WRITE)) {
1215         return FALSE;
1216     } else {
1217         LONG res = RegSetValueEx(hRootKey, var, 0, type, buf, bufSize);
1218         RegCloseKey(hRootKey);
1219         return (res == ERROR_SUCCESS);
1220     }
1221 }
1222
1223 static String local readRegString(key,regPath,var,def) /* read String from registry */
1224 HKEY   key;
1225 String regPath;
1226 String var;
1227 String def; {
1228     static char  buf[300];
1229     DWORD type;
1230     if (queryValue(key, regPath,var, &type, buf, sizeof(buf))
1231         && type == REG_SZ) {
1232         return (String)buf;
1233     } else {
1234         return def;
1235     }
1236 }
1237
1238 static Int local readRegInt(var, def)            /* read Int from registry */
1239 String var;
1240 Int    def; {
1241     DWORD buf;
1242     DWORD type;
1243
1244     if (queryValue(HKEY_CURRENT_USER, HugsRoot, var, &type,
1245                    (LPBYTE)&buf, sizeof(buf))
1246         && type == REG_DWORD) {
1247         return (Int)buf;
1248     } else if (queryValue(HKEY_LOCAL_MACHINE, HugsRoot, var, &type,
1249                           (LPBYTE)&buf, sizeof(buf))
1250                && type == REG_DWORD) {
1251         return (Int)buf;
1252     } else {
1253         return def;
1254     }
1255 }
1256
1257 static Bool local writeRegString(var,val)      /* write String to registry */
1258 String var;
1259 String val; {
1260     if (NULL == val) {
1261         val = "";
1262     }
1263     return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1264                     REG_SZ, (LPBYTE)val, lstrlen(val)+1);
1265 }
1266
1267 static Bool local writeRegInt(var,val)         /* write String to registry */
1268 String var;
1269 Int    val; {
1270     return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1271                     REG_DWORD, (LPBYTE)&val, sizeof(val));
1272 }
1273
1274 #endif /* USE_REGISTRY */
1275
1276 /* --------------------------------------------------------------------------
1277  * Machine dependent control:
1278  * ------------------------------------------------------------------------*/
1279
1280 Void machdep(what)                      /* Handle machine specific         */
1281 Int what; {                             /* initialisation etc..            */
1282     switch (what) {
1283         case MARK    : break;
1284         case INSTALL : installHandlers();
1285                        break;
1286         case RESET   :
1287         case BREAK   :
1288         case EXIT    : normalTerminal();
1289 #if HUGS_FOR_WINDOWS
1290                        if (what==EXIT)
1291                            DestroyWindow(hWndMain);
1292                        else
1293                            SetCursor(LoadCursor(NULL,IDC_ARROW));
1294 #endif
1295                        break;
1296     }
1297 }
1298
1299 /*-------------------------------------------------------------------------*/