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)
9 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
10 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
11 * Technology, 1994-1999, All rights reserved. It is distributed as
12 * free software under the license in the file "License", which is
13 * included in the distribution.
15 * $RCSfile: machdep.c,v $
17 * $Date: 2000/03/20 04:26:23 $
18 * ------------------------------------------------------------------------*/
23 #ifdef HAVE_SYS_TYPES_H
24 # include <sys/types.h>
31 # include <sys/param.h>
33 #ifdef HAVE_SYS_STAT_H
34 # include <sys/stat.h>
44 /* Windows/DOS include files */
48 #if defined HAVE_CONIO_H && ! HUGS_FOR_WINDOWS
65 extern HCURSOR HandCursor; /* Forward references to cursors */
66 extern HCURSOR GarbageCursor;
67 extern HCURSOR SaveCursor;
68 static void local DrawStatusLine ( HWND );
73 extern unsigned _stklen = 8000; /* Allocate an 8k stack segment */
81 /* Macintosh include files */
104 int allow_break_count = 0;
107 /* --------------------------------------------------------------------------
108 * Prototypes for registry reading
109 * ------------------------------------------------------------------------*/
113 /* where have we hidden things in the registry? */
115 #define HScriptRoot ("SOFTWARE\\Haskell\\HaskellScript\\")
118 #define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
119 #define ProjectRoot ("SOFTWARE\\Haskell\\Projects\\")
121 static Bool local createKey ( HKEY, String, PHKEY, REGSAM );
122 static Bool local queryValue ( HKEY, String, String, LPDWORD, LPBYTE, DWORD );
123 static Bool local setValue ( HKEY, String, String, DWORD, LPBYTE, DWORD );
124 static String local readRegString ( HKEY, String, String, String );
125 static Int local readRegInt ( String,Int );
126 static Bool local writeRegString ( String,String );
127 static Bool local writeRegInt ( String,Int );
129 static String local readRegChildStrings ( HKEY, String, String, Char, String );
130 #endif /* USE_REGISTRY */
132 /* --------------------------------------------------------------------------
133 * Find information about a file:
134 * ------------------------------------------------------------------------*/
137 typedef struct { unsigned hi, lo; } Time;
138 #define timeChanged(now,thn) (now.hi!=thn.hi || now.lo!=thn.lo)
139 #define timeSet(var,tm) var.hi = tm.hi; var.lo = tm.lo
140 error timeEarlier not defined
143 #define timeChanged(now,thn) (now!=thn)
144 #define timeSet(var,tm) var = tm
145 #define timeEarlier(earlier,now) (earlier < now)
148 static Bool local readable ( String );
149 static Void local getFileInfo ( String, Time *, Long * );
151 static Void local getFileInfo(f,tm,sz) /* find time stamp and size of file*/
155 #if defined HAVE_SYS_STAT_H || defined HAVE_STAT_H || defined HAVE_UNIX_H
157 if (!stat(f,&scbuf)) {
158 if (tm) *tm = scbuf.st_mtime;
159 *sz = (Long)(scbuf.st_size);
164 #else /* normally just use stat() */
165 os_regset r; /* RISCOS PRM p.850 and p.837 */
166 r.r[0] = 17; /* Read catalogue, no path */
169 if(r.r[0] == 1 && (r.r[2] & 0xFFF00000) == 0xFFF00000) {
170 if (tm) tm->hi = r.r[2] & 0xFF; /* Load address (high byte) */
171 if (tm) tm->lo = r.r[3]; /* Execution address (low 4 bytes) */
172 } else { /* Not found, or not time-stamped */
173 if (tm) tm->hi = tm->lo = 0;
175 *sz = (Long)(r.r[0] == 1 ? r.r[4] : 0);
179 Void getFileSize ( String f, Long* sz )
181 getFileInfo ( f, NULL, sz );
184 #if defined HAVE_GETFINFO /* Mac971031 */
185 /* --------------------------------------------------------------------------
186 * Define a MacOS version of access():
187 * If the file is not accessible, -1 is returned and errno is set to
188 * the reason for the failure.
189 * If the file is accessible and the dummy is 0 (existence), 2 (write),
190 * or 4 (read), the return is 0.
191 * If the file is accessible, and the dummy is 1 (executable), then if
192 * the file is a program (of type 'APPL'), the return is 0, otherwise -1.
193 * Warnings: Use with caution. UNIX access do no translate to Macs.
194 * Check of write access is not implemented (same as read).
195 * ------------------------------------------------------------------------*/
197 int access(char *fileName, int dummy) {
201 errno = getfinfo(fileName, 0, &fi);
202 if (errno != 0) return -1; /* Check file accessible. */
204 /* Cases dummy = existence, read, write. */
205 if (dummy == 0 || dummy & 0x6) return 0;
207 /* Case dummy = executable. */
209 if (fi.fdType == 'APPL') return 0;
218 static Bool local readable(f) /* is f a regular, readable file */
220 #if DJGPP2 || defined HAVE_GETFINFO /* stat returns bogus mode bits on djgpp2 */
221 return (0 == access(f,4));
222 #elif defined HAVE_SYS_STAT_H || defined HAVE_STAT_H
224 /* fprintf(stderr, "readable: %s\n", f ); */
225 return ( !stat(f,&scbuf)
226 && (scbuf.st_mode & S_IREAD) /* readable */
227 && (scbuf.st_mode & S_IFREG) /* regular file */
229 #elif defined HAVE_OS_SWI /* RISCOS specific */
230 os_regset r; /* RISCOS PRM p.850 -- JBS */
232 r.r[0] = 17; /* Read catalogue, no path */
235 return r.r[0] != 1; /* Does this check it's a regular file? ADR */
240 /* --------------------------------------------------------------------------
241 * Search for script files on the HUGS path:
242 * ------------------------------------------------------------------------*/
244 static String local hugsdir ( Void );
246 static String local hscriptDir ( Void );
248 static int local pathCmp ( String, String );
249 static String local normPath ( String );
250 static Void local searchChr ( Int );
251 static Void local searchStr ( String );
252 static Bool local tryEndings ( String );
254 #if (DOS_FILENAMES || __CYGWIN32__)
256 # define isSLASH(c) ((c)=='\\' || (c)=='/')
258 # define PATHSEP_STR ";"
259 # define DLL_ENDING ".dll"
262 # define isSLASH(c) ((c)==SLASH)
264 # define PATHSEP_STR ";"
265 /* Mac PEF (Preferred Executable Format) file */
266 # define DLL_ENDING ".pef"
269 # define isSLASH(c) ((c)==SLASH)
271 # define PATHSEP_STR ":"
272 # define DLL_ENDING ".u_o"
275 static String local hugsdir() { /* directory containing lib/Prelude.hs */
277 /* In HaskellScript (Win32 only), we lookup InstallDir in the registry. */
278 static char dir[FILENAME_MAX+1] = "";
279 if (dir[0] == '\0') { /* not initialised yet */
280 String s = readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"InstallDir",
287 #elif HAVE_GETMODULEFILENAME && !DOS && !__CYGWIN32__
288 /* On Windows, we can find the binary we're running and it's
289 * conventional to put the libraries in the same place.
291 static char dir[FILENAME_MAX+1] = "";
292 if (dir[0] == '\0') { /* not initialised yet */
294 GetModuleFileName((HMODULE)0,dir,FILENAME_MAX+1);
295 if (dir[0] == '\0') { /* GetModuleFileName must have failed */
298 slash = strrchr(dir,SLASH);
299 if (slash) { /* truncate after directory name */
305 /* On Unix systems, we can't find the binary we're running and
306 * the libraries may not be installed near the binary anyway.
307 * This forces us to use a hardwired path which is set at
308 * configuration time (--datadir=...).
315 static String local hscriptDir() { /* Directory containing hscript.dll */
316 static char dir[FILENAME_MAX+1] = "";
317 if (dir[0] == '\0') { /* not initialised yet */
318 String s = readRegString(HKEY_LOCAL_MACHINE,HScriptRoot,"InstallDir","");
327 #if 0 /* apparently unused */
328 static String local RealPath(s) /* Find absolute pathname of file */
330 #if HAVE__FULLPATH /* eg DOS */
331 static char path[FILENAME_MAX+1];
332 _fullpath(path,s,FILENAME_MAX+1);
333 #elif HAVE_REALPATH /* eg Unix */
334 static char path[MAXPATHLEN+1];
337 static char path[FILENAME_MAX+1];
345 static int local pathCmp(p1,p2) /* Compare paths after normalisation */
348 #if HAVE__FULLPATH /* eg DOS */
349 static char path1[FILENAME_MAX+1];
350 static char path2[FILENAME_MAX+1];
351 _fullpath(path1,p1,FILENAME_MAX+1);
352 _fullpath(path2,p2,FILENAME_MAX+1);
353 #elif HAVE_REALPATH /* eg Unix */
354 static char path1[MAXPATHLEN+1];
355 static char path2[MAXPATHLEN+1];
359 static char path1[FILENAME_MAX+1];
360 static char path2[FILENAME_MAX+1];
364 #if CASE_INSENSITIVE_FILENAMES
368 return filenamecmp(path1,path2);
371 static String local normPath(s) /* Try, as much as possible, to normalize */
372 String s; { /* a pathname in some appropriate manner. */
373 #if PATH_CANONICALIZATION
374 String path = RealPath(s);
375 #if CASE_INSENSITIVE_FILENAMES
376 strlwr(path); /* and convert to lowercase */
379 #else /* ! PATH_CANONICALIZATION */
381 #endif /* ! PATH_CANONICALIZATION */
385 static String endings[] = { "", ".u_hi", ".hs", ".lhs", ".hsx", ".hash", 0 };
387 static String endings[] = { "", ".u_hi", ".hs", ".lhs", 0 };
389 static char searchBuf[FILENAME_MAX+1];
390 static Int searchPos;
392 #define searchReset(n) searchBuf[searchPos=(n)]='\0'
394 static Void local searchChr(c) /* Add single character to search buffer */
396 if (searchPos<FILENAME_MAX) {
397 searchBuf[searchPos++] = (char)c;
398 searchBuf[searchPos] = '\0';
402 static Void local searchStr(s) /* Add string to search buffer */
404 while (*s && searchPos<FILENAME_MAX)
405 searchBuf[searchPos++] = *s++;
406 searchBuf[searchPos] = '\0';
409 static Bool local tryEndings(s) /* Try each of the listed endings */
413 for (; endings[i]; ++i) {
414 Int save = searchPos;
415 searchStr(endings[i]);
416 if (readable(searchBuf))
427 /* scandir, June 98 Daan Leijen
428 searches the base directory and its direct subdirectories for a file
430 input: searchbuf contains SLASH terminated base directory
431 argument s contains the (base) filename
432 output: TRUE: searchBuf contains the full filename
433 FALSE: searchBuf is garbage, file not found
437 #ifdef HAVE_WINDOWS_H
439 static Bool scanSubDirs(s)
442 struct _finddata_t findInfo;
447 /* is it in the current directory ? */
448 if (tryEndings(s)) return TRUE;
453 /* initiate the search */
454 handle = _findfirst( searchBuf, &findInfo );
455 if (handle==-1) { errno = 0; return FALSE; }
457 /* search all subdirectories */
459 /* if we have a valid sub directory */
460 if (((findInfo.attrib & _A_SUBDIR) == _A_SUBDIR) &&
461 (findInfo.name[0] != '.')) {
463 searchStr(findInfo.name);
469 } while (_findnext( handle, &findInfo ) == 0);
471 _findclose( handle );
475 #elif defined(HAVE_FTW_H)
479 static char baseFile[FILENAME_MAX+1];
480 static char basePath[FILENAME_MAX+1];
481 static int basePathLen;
483 static int scanitem( const char* path,
484 const struct stat* statinfo,
487 if (info == FTW_D) { /* is it a directory */
491 if (tryEndings(baseFile)) {
498 static Bool scanSubDirs(s)
503 strcpy(basePath,searchBuf);
504 basePathLen = strlen(basePath);
506 /* is it in the current directory ? */
507 if (tryEndings(s)) return TRUE;
509 /* otherwise scan the subdirectories */
510 r = ftw( basePath, scanitem, 2 );
515 #endif /* HAVE_WINDOWS_H || HAVE_FTW_H */
516 #endif /* SEARCH_DIR */
518 String findPathname(along,nm) /* Look for a file along specified path */
519 String along; /* Return NULL if file does not exist */
521 /* AC, 1/21/99: modified to search hugsPath first, then projectPath */
522 String s = findMPathname(along,nm,hugsPath);
527 s = findMPathname(along,nm,projectPath);
530 #endif /* USE_REGISTRY */
531 return s ? s : normPath(searchBuf);
534 /* AC, 1/21/99: modified to pass in path to search explicitly */
535 String findMPathname(along,nm,path)/* Look for a file along specified path */
536 String along; /* If nonzero, a path prefix from along is */
537 String nm; /* used as the first prefix in the search. */
539 String pathpt = path;
542 if (along) { /* Was a path for an existing file given? */
545 for (; along[i]; i++) {
547 if (isSLASH(along[i]))
553 return normPath(searchBuf);
555 if (pathpt && *pathpt) { /* Otherwise, we look along the HUGSPATH */
558 Bool recurse = FALSE; /* DL: shall we recurse ? */
561 if (*pathpt!=PATHSEP) {
562 /* Pre-define one MPW-style "shell-variable" */
563 if (strncmp(pathpt,"{Hugs}",6)==0) {
564 searchStr(hugsdir());
568 /* And another - we ought to generalise this stuff */
569 else if (strncmp(pathpt,"{HScript}",9)==0) {
570 searchStr(hscriptDir());
575 searchChr(*pathpt++);
576 } while (*pathpt && *pathpt!=PATHSEP);
577 recurse = (pathpt[-1] == SLASH);
582 if (*pathpt==PATHSEP)
590 if (recurse ? scanSubDirs(nm) : tryEndings(nm)) {
591 return normPath(searchBuf);
594 if (tryEndings(nm)) {
595 return normPath(searchBuf);
601 searchReset(0); /* As a last resort, look for file in the current dir */
602 return (tryEndings(nm) ? normPath(searchBuf) : 0);
605 /* --------------------------------------------------------------------------
606 * New path handling stuff for the Combined System (tm)
607 * ------------------------------------------------------------------------*/
609 char installDir[N_INSTALLDIR];
611 /* Sets installDir to $STGHUGSDIR, and ensures there is a trailing
614 void setInstallDir ( String argv_0 )
617 char* r = getenv("STGHUGSDIR");
620 "%s: installation error: environment variable STGHUGSDIR is not set.\n",
623 "%s: pls set it to be the directory where STGHugs98 is installed.\n\n",
629 if (strlen(r) > N_INSTALLDIR-30 ) {
631 "%s: environment variable STGHUGSDIR is suspiciously long; pls remedy\n\n",
636 strcpy ( installDir, r );
637 i = strlen(installDir);
638 if (installDir[i-1] != SLASH) installDir[i++] = SLASH;
643 Bool findFilesForModule (
647 Bool* sAvail, Time* sTime, Long* sSize,
648 Bool* iAvail, Time* iTime, Long* iSize,
649 Bool* oAvail, Time* oTime, Long* oSize
652 /* Let the module name given be M.
653 For each path entry P,
654 a s(rc) file will be P/M.hs or P/M.lhs
655 an i(nterface) file will be P/M.hi
656 an o(bject) file will be P/M.o
657 If there is a s file or (both i and o files)
658 use P to fill in the path names.
659 Otherwise, move on to the next path entry.
660 If all path entries are exhausted, return False.
664 String peStart, peEnd;
665 String augdPath; /* .:hugsPath:installDir/GhcPrel:installDir/lib */
667 *path = *sExt = NULL;
668 *sAvail = *iAvail = *oAvail = FALSE;
669 *sSize = *iSize = *oSize = 0;
671 augdPath = malloc( 2*(10+3+strlen(installDir))
672 +strlen(hugsPath) +10/*paranoia*/);
674 internal("moduleNameToFileNames: malloc failed(2)");
677 strcat(augdPath, ".");
678 strcat(augdPath, PATHSEP_STR);
680 strcat(augdPath, hugsPath);
681 strcat(augdPath, PATHSEP_STR);
684 strcat(augdPath, installDir);
685 strcat(augdPath, "GhcPrel");
686 strcat(augdPath, PATHSEP_STR);
689 strcat(augdPath, installDir);
690 strcat(augdPath, "lib");
691 strcat(augdPath, PATHSEP_STR);
693 /* fprintf ( stderr, "augdpath = `%s'\n", augdPath ); */
697 /* Advance peStart and peEnd very paranoically, giving up at
698 the first sign of mutancy in the path string.
700 if (peEnd >= augdPath && !(*peEnd)) { free(augdPath); return FALSE; }
703 while (*peEnd && *peEnd != PATHSEP) peEnd++;
705 /* Now peStart .. peEnd-1 bracket the next path element. */
706 nPath = peEnd-peStart;
707 if (nPath + strlen(modName) + 10 /*slush*/ > FILENAME_MAX) {
708 ERRMSG(0) "Hugs path \"%s\" contains excessively long component",
715 strncpy(searchBuf, peStart, nPath);
716 searchBuf[nPath] = 0;
717 if (nPath > 0 && !isSLASH(searchBuf[nPath-1]))
718 searchBuf[nPath++] = SLASH;
720 strcpy(searchBuf+nPath, modName);
721 nPath += strlen(modName);
723 /* searchBuf now holds 'P/M'. Try out the various endings. */
724 *path = *sExt = NULL;
725 *sAvail = *iAvail = *oAvail = FALSE;
726 *sSize = *iSize = *oSize = 0;
728 strcpy(searchBuf+nPath, DLL_ENDING);
729 if (readable(searchBuf)) {
731 getFileInfo(searchBuf, oTime, oSize);
734 strcpy(searchBuf+nPath, ".u_hi");
735 if (readable(searchBuf)) {
737 getFileInfo(searchBuf, iTime, iSize);
740 strcpy(searchBuf+nPath, ".hs");
741 if (readable(searchBuf)) {
744 getFileInfo(searchBuf, sTime, sSize);
747 strcpy(searchBuf+nPath, ".lhs");
748 if (readable(searchBuf)) {
751 getFileInfo(searchBuf, sTime, sSize);
757 if (*sAvail || (*oAvail && *iAvail)) {
758 nPath -= strlen(modName);
759 *path = malloc(nPath+1);
761 internal("moduleNameToFileNames: malloc failed(1)");
762 strncpy(*path, searchBuf, nPath);
773 /* If the primaryObjectName for is (eg)
775 and the extraFileName is (eg)
777 and DLL_ENDING is set to .o
779 /foo/bar/swampy_cbits.o
780 and set *extraFileSize to its size, or -1 if not avail
782 String getExtraObjectInfo ( String primaryObjectName,
783 String extraFileName,
790 Int i = strlen(primaryObjectName)-1;
791 while (i >= 0 && primaryObjectName[i] != SLASH) i--;
792 if (i == -1) return extraFileName;
794 xtra = malloc ( i+3+strlen(extraFileName)+strlen(DLL_ENDING) );
795 if (!xtra) internal("deriveExtraObjectName: malloc failed");
796 strncpy ( xtra, primaryObjectName, i );
798 strcat ( xtra, extraFileName );
799 strcat ( xtra, DLL_ENDING );
802 if (readable(xtra)) {
803 getFileInfo ( xtra, &xTime, &xSize );
804 *extraFileSize = xSize;
810 /* --------------------------------------------------------------------------
811 * Substitute old value of path into empty entries in new path
812 * eg substPath("a:b:c::d:e","x:y:z") = "a:b:c:x:y:z:d:e"
813 * ------------------------------------------------------------------------*/
815 static String local substPath ( String,String );
817 static String local substPath(new,sub) /* substitute sub path into new path*/
820 Bool substituted = FALSE; /* only allow one replacement */
821 Int maxlen = strlen(sub) + strlen(new); /* safe upper bound */
822 String r = (String) malloc(maxlen+1); /* result string */
823 String t = r; /* pointer into r */
824 String next = new; /* next uncopied char in new */
825 String start = next; /* start of last path component */
827 ERRMSG(0) "String storage space exhausted"
831 if (*next == PATHSEP || *next == '\0') {
832 if (!substituted && next == start) {
834 for(; *s != '\0'; ++s) {
841 } while ((*t++ = *next++) != '\0');
846 /* --------------------------------------------------------------------------
847 * Garbage collection notification:
848 * ------------------------------------------------------------------------*/
850 Bool gcMessages = FALSE; /* TRUE => print GC messages */
852 Void gcStarted() { /* Notify garbage collector start */
854 SaveCursor = SetCursor(GarbageCursor);
862 Void gcScanning() { /* Notify garbage collector scans */
869 Void gcRecovered(recovered) /* Notify garbage collection done */
872 Printf("%d}}",recovered);
876 SetCursor(SaveCursor);
880 Cell *CStackBase; /* Retain start of C control stack */
882 #if RISCOS /* Stack traversal for RISCOS */
884 /* Warning: The following code is specific to the Acorn ARM under RISCOS
885 (and C4). We must explicitly walk back through the stack frames, since
886 the stack is extended from the heap. (see PRM pp. 1757). gcCStack must
887 not be modified, since the offset '5' assumes that only v1 is used inside
888 this function. Hence we do all the real work in gcARM.
891 #define spreg 13 /* C3 has SP=R13 */
893 #define previousFrame(fp) ((int *)((fp)[-3]))
894 #define programCounter(fp) ((int *)((*(fp)-12) & ~0xFC000003))
895 #define isSubSPSP(w) (((w)&dontCare) == doCare)
896 #define doCare (0xE24DD000) /* SUB r13,r13,#0 */
897 #define dontCare (~0x00100FFF) /* S and # bits */
898 #define immediateArg(x) ( ((x)&0xFF) << (((x)&0xF00)>>7) )
900 static void gcARM(int *fp) {
901 int si = *programCounter(fp); /* Save instruction indicates how */
902 /* many registers in this frame */
904 if (si & (1<<0)) markWithoutMove(*regs--);
905 if (si & (1<<1)) markWithoutMove(*regs--);
906 if (si & (1<<2)) markWithoutMove(*regs--);
907 if (si & (1<<3)) markWithoutMove(*regs--);
908 if (si & (1<<4)) markWithoutMove(*regs--);
909 if (si & (1<<5)) markWithoutMove(*regs--);
910 if (si & (1<<6)) markWithoutMove(*regs--);
911 if (si & (1<<7)) markWithoutMove(*regs--);
912 if (si & (1<<8)) markWithoutMove(*regs--);
913 if (si & (1<<9)) markWithoutMove(*regs--);
914 if (previousFrame(fp)) {
915 /* The non-register stack space is for the previous frame is above
916 this fp, and not below the previous fp, because of the way stack
917 extension works. It seems the only way of discovering its size is
918 finding the SUB sp, sp, #? instruction by walking through the code
919 following the entry point.
921 int *oldpc = programCounter(previousFrame(fp));
923 for(i = 1; i < 6; ++i)
924 if(isSubSPSP(oldpc[i])) fsize += immediateArg(oldpc[i]) / 4;
925 for(i=1; i<=fsize; ++i)
926 markWithoutMove(fp[i]);
932 int *fp = 5 + &dummy;
935 fp = previousFrame(fp);
939 #else /* Garbage collection for standard stack machines */
941 Void gcCStack() { /* Garbage collect elements off */
942 Cell stackTop = NIL; /* C stack */
943 Cell *ptr = &stackTop;
944 #if SIZEOF_VOID_P == 2
945 if (((long)(ptr) - (long)(CStackBase))&1)
947 #elif STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
948 if (((long)(ptr) - (long)(CStackBase))&1)
951 if (((long)(ptr) - (long)(CStackBase))&3)
955 #define Blargh markWithoutMove(*ptr);
957 markWithoutMove((*ptr)/sizeof(Cell)); \
958 markWithoutMove(( (void*)(*ptr)-(void*)heapTopFst)/sizeof(Cell)); \
959 markWithoutMove(( (void*)(*ptr)-(void*)heapTopSnd)/sizeof(Cell))
962 #define StackGrowsDown { while (ptr<=CStackBase) { Blargh; ptr++; }; }
963 #define StackGrowsUp { while (ptr>=CStackBase) { Blargh; ptr--; }; }
964 #define GuessDirection if (ptr>CStackBase) StackGrowsUp else StackGrowsDown
966 #if STACK_DIRECTION > 0
968 #elif STACK_DIRECTION < 0
974 #if SIZEOF_VOID_P==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
975 ptr = (Cell *)((long)(&stackTop) + 2);
979 #undef StackGrowsDown
981 #undef GuessDirection
985 /* --------------------------------------------------------------------------
986 * Terminal dependent stuff:
987 * ------------------------------------------------------------------------*/
989 #if (HAVE_TERMIO_H | HAVE_SGTTY_H | HAVE_TERMIOS_H)
991 /* grab the varargs prototype for ioctl */
993 # include <sys/ioctl.h>
996 /* The order of these three tests is very important because
997 * some systems have more than one of the requisite header file
998 * but only one of them seems to work.
999 * Anyone changing the order of the tests should try enabling each of the
1000 * three branches in turn and write down which ones work as well as which
1001 * OS/compiler they're using.
1003 * OS Compiler sgtty termio termios notes
1004 * Linux 2.0.18 gcc 2.7.2 absent works works 1
1007 * 1) On Linux, termio.h just #includes termios.h and sgtty.h is
1008 * implemented using termios.h.
1009 * sgtty.h is in /usr/include/bsd which is not on my standard include
1010 * path. Adding it does no harm but you might as well use termios.
1012 * reid-alastair@cs.yale.edu
1016 #include <termios.h>
1017 typedef struct termios TermParams;
1018 #define getTerminal(tp) tcgetattr(fileno(stdin), &tp)
1019 #define setTerminal(tp) tcsetattr(fileno(stdin), TCSAFLUSH, &tp)
1020 #define noEcho(tp) tp.c_lflag &= ~(ICANON | ECHO); \
1021 tp.c_cc[VMIN] = 1; \
1027 typedef struct sgttyb TermParams;
1028 #define getTerminal(tp) ioctl(fileno(stdin),TIOCGETP,&tp)
1029 #define setTerminal(tp) ioctl(fileno(stdin),TIOCSETP,&tp)
1031 #define noEcho(tp) tp.sg_flags |= RAW; tp.sg_flags &= (~ECHO);
1033 #define noEcho(tp) tp.sg_flags |= CBREAK; tp.sg_flags &= (~ECHO);
1039 typedef struct termio TermParams;
1040 #define getTerminal(tp) ioctl(fileno(stdin),TCGETA,&tp)
1041 #define setTerminal(tp) ioctl(fileno(stdin),TCSETAF,&tp)
1042 #define noEcho(tp) tp.c_lflag &= ~(ICANON | ECHO); \
1043 tp.c_cc[VMIN] = 1; \
1048 static Bool messedWithTerminal = FALSE;
1049 static TermParams originalSettings;
1051 Void normalTerminal() { /* restore terminal initial state */
1052 if (messedWithTerminal)
1053 setTerminal(originalSettings);
1056 Void noechoTerminal() { /* set terminal into noecho mode */
1057 TermParams settings;
1059 if (!messedWithTerminal) {
1060 getTerminal(originalSettings);
1061 messedWithTerminal = TRUE;
1063 getTerminal(settings);
1065 setTerminal(settings);
1068 Int getTerminalWidth() { /* determine width of terminal */
1070 #ifdef _M_UNIX /* SCO Unix 3.2.4 defines TIOCGWINSZ*/
1071 #include <sys/stream.h> /* Required by sys/ptem.h */
1072 #include <sys/ptem.h> /* Required to declare winsize */
1074 static struct winsize terminalSize;
1075 ioctl(fileno(stdout),TIOCGWINSZ,&terminalSize);
1076 return (terminalSize.ws_col==0)? 80 : terminalSize.ws_col;
1082 Int readTerminalChar() { /* read character from terminal */
1083 return getchar(); /* without echo, assuming that */
1084 } /* noechoTerminal() is active... */
1088 Int readTerminalChar() { /* read character from terminal */
1089 return getchar(); /* without echo, assuming that */
1090 } /* noechoTerminal() is active... */
1092 Int getTerminalWidth() {
1093 return console_options.ncols;
1096 Void normalTerminal() {
1097 csetmode(C_ECHO, stdin);
1100 Void noechoTerminal() {
1101 csetmode(C_NOECHO, stdin);
1104 #else /* no terminal driver - eg DOS, RISCOS */
1106 static Bool terminalEchoReqd = TRUE;
1108 Int getTerminalWidth() {
1111 (void) os_swi3r(OS_ReadModeVariable, -1, 1, 0, &dummy, &dummy, &width);
1118 Void normalTerminal() { /* restore terminal initial state */
1119 terminalEchoReqd = TRUE;
1122 Void noechoTerminal() { /* turn terminal echo on/off */
1123 terminalEchoReqd = FALSE;
1126 Int readTerminalChar() { /* read character from terminal */
1127 if (terminalEchoReqd) {
1130 #if IS_WIN32 && !HUGS_FOR_WINDOWS && !__BORLANDC__
1131 /* When reading a character from the console/terminal, we want
1132 * to operate in 'raw' mode (to use old UNIX tty parlance) and have
1133 * it return when a character is available and _not_ wait until
1134 * the next time the user hits carriage return. On Windows platforms,
1135 * this _can_ be done by reading directly from the console, using
1136 * getch(). However, this doesn't sit well with programming
1137 * environments such as Emacs which allow you to create sub-processes
1138 * running Hugs, and then communicate with the running interpreter
1139 * through its standard input and output handles. If you use getch()
1140 * in that setting, you end up trying to read the (unused) console
1141 * of the editor itself, through which not a lot of characters is
1142 * bound to come out, since the editor communicates input to Hugs
1143 * via the standard input handle.
1145 * To avoid this rather unfortunate situation, we use the Win32
1146 * console API and re-jig the input properties of the standard
1147 * input handle before trying to read a character using stdio's
1150 * The 'cost' of this solution is that it is Win32 specific and
1151 * won't work with Windows 3.1 + it is kind of ugly and verbose
1152 * to have to futz around with the console properties on a
1153 * per-char basis. Both of these disadvantages aren't in my
1162 /* I don't quite understand why, but if the FILE*'s underlying file
1163 descriptor is in text mode, we seem to lose the first carriage
1166 setmode(fileno(stdin), _O_BINARY);
1167 hIn = GetStdHandle(STD_INPUT_HANDLE);
1168 GetConsoleMode(hIn, &mo);
1169 SetConsoleMode(hIn, mo & ~(ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT));
1171 * On Win9x, the first time you change the mode (as above) a
1172 * raw '\n' is inserted. Since enter maps to a raw '\r', and we
1173 * map this (below) to '\n', we can just ignore all *raw* '\n's.
1177 } while (c == '\n');
1179 /* Same as it ever was - revert back state of stdin. */
1180 SetConsoleMode(hIn, mo);
1181 setmode(fileno(stdin), _O_TEXT);
1185 return c=='\r' ? '\n' : c; /* slight paranoia about CR-LF */
1189 #endif /* no terminal driver */
1191 /* --------------------------------------------------------------------------
1192 * Interrupt handling:
1193 * ------------------------------------------------------------------------*/
1195 Bool broken = FALSE;
1196 static Bool breakReqd = FALSE;
1197 static sigProto(ignoreBreak);
1198 static Void local installHandlers ( Void );
1200 Bool breakOn(reqd) /* set break trapping on if reqd, */
1201 Bool reqd; { /* or off otherwise, returning old */
1202 Bool old = breakReqd;
1206 if (broken) { /* repond to break signal received */
1207 broken = FALSE; /* whilst break trap disabled */
1208 sigRaise(breakHandler);
1211 #if HANDLERS_CANT_LONGJMP
1212 ctrlbrk(ignoreBreak);
1214 ctrlbrk(breakHandler);
1217 ctrlbrk(ignoreBreak);
1222 static sigHandler(ignoreBreak) { /* record but don't respond to break*/
1223 ctrlbrk(ignoreBreak); /* reinstall signal handler */
1224 /* redundant on BSD systems but essential */
1225 /* on POSIX and other systems */
1232 static sigProto(panic);
1233 static sigHandler(panic) { /* exit in a panic, on receipt of */
1234 everybody(EXIT); /* an unexpected signal */
1235 fprintf(stderr,"\nUnexpected signal\n");
1237 sigResume;/*NOTREACHED*/
1239 #endif /* !DONT_PANIC */
1242 BOOL WINAPI consoleHandler(DWORD dwCtrlType) {
1243 switch (dwCtrlType) { /* Allows Hugs to be terminated */
1244 case CTRL_CLOSE_EVENT : /* from the window's close menu. */
1251 static Void local installHandlers() { /* Install handlers for all fatal */
1252 /* signals except SIGINT and SIGBREAK*/
1254 SetConsoleCtrlHandler(consoleHandler,TRUE);
1256 #if !DONT_PANIC && !DOS
1258 signal(SIGABRT,panic);
1261 signal(SIGBUS,panic);
1264 signal(SIGFPE,panic);
1267 signal(SIGHUP,panic);
1270 signal(SIGILL,panic);
1273 signal(SIGQUIT,panic);
1276 signal(SIGSEGV,panic);
1279 signal(SIGTERM,panic);
1281 #endif /* !DONT_PANIC && !DOS */
1284 /* --------------------------------------------------------------------------
1286 * ------------------------------------------------------------------------*/
1288 static Bool local startEdit(line,nm) /* Start editor on file name at */
1289 Int line; /* given line. Both name and line */
1290 String nm; { /* or just line may be zero */
1291 static char editorCmd[FILENAME_MAX+1];
1294 if (hugsEdit && *hugsEdit) { /* Check that editor configured */
1296 /* On a Mac, files have creator information, telling which program
1297 to launch to, so an editor named to the empty string "" is often
1299 if (hugsEdit) { /* Check that editor configured */
1301 Int n = FILENAME_MAX;
1302 String he = hugsEdit;
1303 String ec = editorCmd;
1304 String rd = NULL; /* Set to nonnull to redo ... */
1306 for (; n>0 && *he && *he!=' ' && *he!='%'; n--)
1307 *ec++ = *he++; /* Copy editor name to buffer */
1308 /* assuming filename ends at space */
1310 if (nm && line && n>1 && *he){ /* Name, line, and enough space */
1311 rd = ec; /* save, in case we don't find name*/
1312 while (n>0 && *he) {
1314 if (*++he=='d' && n>10) {
1315 sprintf(ec,"%d",line);
1318 else if (*he=='s' && (size_t)n>strlen(nm)) {
1323 else if (*he=='%' && n>1) {
1327 else /* Ignore % char if not followed */
1328 *ec = '\0'; /* by one of d, s, or %, */
1329 for (; *ec && n>0; n--)
1331 } /* ignore % followed by anything other than d, s, or % */
1332 else { /* Copy other characters across */
1341 if (rd) { /* If file name was not included */
1346 if (nm && line==0 && n>1) { /* Name, but no line ... */
1348 for (; n>0 && *nm; n--) /* ... just copy file name */
1352 *ec = '\0'; /* Add terminating null byte */
1355 ERRMSG(0) "Hugs is not configured to use an editor"
1360 WinExec(editorCmd, SW_SHOW);
1363 if (shellEsc(editorCmd))
1364 Printf("Warning: Editor terminated abnormally\n");
1369 Int shellEsc(s) /* run a shell command (or shell) */
1372 return macsystem(s);
1376 s = fromEnv("SHELL","/bin/sh");
1383 #if RISCOS /* RISCOS also needs a chdir() */
1384 int chdir(char *s) { /* RISCOS PRM p. 885 -- JBS */
1385 return os_swi2(OS_FSControl + XOS_Bit, 0, (int)s) != NULL;
1387 #elif defined HAVE_PBHSETVOLSYNC /* Macintosh */
1388 int chdir(const char *s) {
1391 wd.ioCompletion = 0;
1392 str = (char*)malloc(strlen(s) + 1);
1393 if (str == 0) return -1;
1395 wd.ioNamePtr = C2PStr(str);
1398 errno = PBHSetVolSync(&wd);
1409 /*---------------------------------------------------------------------------
1410 * Printf-related operations:
1411 *-------------------------------------------------------------------------*/
1413 #if !defined(HAVE_VSNPRINTF)
1414 int vsnprintf(buffer, count, fmt, ap)
1419 #if defined(HAVE__VSNPRINTF)
1420 return _vsnprintf(buffer, count, fmt, ap);
1425 #endif /* HAVE_VSNPRINTF */
1427 #if !defined(HAVE_SNPRINTF)
1428 int snprintf(char* buffer, int count, const char* fmt, ...) {
1429 #if defined(HAVE__VSNPRINTF)
1431 va_list ap; /* pointer into argument list */
1432 va_start(ap, fmt); /* make ap point to first arg after fmt */
1433 r = vsnprintf(buffer, count, fmt, ap);
1434 va_end(ap); /* clean up */
1440 #endif /* HAVE_SNPRINTF */
1442 /* --------------------------------------------------------------------------
1443 * Read/write values from/to the registry
1445 * All reads are from either HUGS_CURRENT_USER\\hugs_ROOT\\key or
1446 * HUGS_LOCAL_MACHINE\\hugs_ROOT\\key. (Machine entry is only used if
1447 * user entry doesn't exist).
1449 * All writes are to HUGS_CURRENT_USER\\HugsRoot\\key
1450 * ------------------------------------------------------------------------*/
1454 #define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
1456 static Bool local createKey ( HKEY, PHKEY, REGSAM );
1457 static Bool local queryValue ( HKEY, String, LPDWORD, LPBYTE, DWORD );
1458 static Bool local setValue ( HKEY, String, DWORD, LPBYTE, DWORD );
1460 static Bool local createKey(hKey, phRootKey, samDesired)
1463 REGSAM samDesired; {
1465 return RegCreateKeyEx(hKey, HugsRoot,
1466 0, "", REG_OPTION_NON_VOLATILE,
1467 samDesired, NULL, phRootKey, &dwDisp)
1471 static Bool local queryValue(hKey, regPath, var, type, buf, bufSize)
1480 if (!createKey(hKey, regPath, &hRootKey, KEY_READ)) {
1483 LONG res = RegQueryValueEx(hRootKey, var, NULL, type, buf, &bufSize);
1484 RegCloseKey(hRootKey);
1485 return (res == ERROR_SUCCESS);
1489 static Bool local setValue(hKey, regPath, var, type, buf, bufSize)
1498 if (!createKey(hKey, regPath, &hRootKey, KEY_WRITE)) {
1501 LONG res = RegSetValueEx(hRootKey, var, 0, type, buf, bufSize);
1502 RegCloseKey(hRootKey);
1503 return (res == ERROR_SUCCESS);
1507 static String local readRegString(key,regPath,var,def) /* read String from registry */
1512 static char buf[300];
1514 if (queryValue(key, regPath,var, &type, buf, sizeof(buf))
1515 && type == REG_SZ) {
1522 static Int local readRegInt(var, def) /* read Int from registry */
1528 if (queryValue(HKEY_CURRENT_USER, HugsRoot, var, &type,
1529 (LPBYTE)&buf, sizeof(buf))
1530 && type == REG_DWORD) {
1532 } else if (queryValue(HKEY_LOCAL_MACHINE, HugsRoot, var, &type,
1533 (LPBYTE)&buf, sizeof(buf))
1534 && type == REG_DWORD) {
1541 static Bool local writeRegString(var,val) /* write String to registry */
1547 return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1548 REG_SZ, (LPBYTE)val, lstrlen(val)+1);
1551 static Bool local writeRegInt(var,val) /* write String to registry */
1554 return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1555 REG_DWORD, (LPBYTE)&val, sizeof(val));
1558 #endif /* USE_REGISTRY */
1560 /* --------------------------------------------------------------------------
1561 * Things to do with the argv/argc and the env
1562 * ------------------------------------------------------------------------*/
1564 int nh_argc ( void )
1569 int nh_argvb ( int argno, int offset )
1571 return (int)(prog_argv[argno][offset]);
1574 /* --------------------------------------------------------------------------
1575 * Machine dependent control:
1576 * ------------------------------------------------------------------------*/
1578 Void machdep(what) /* Handle machine specific */
1579 Int what; { /* initialisation etc.. */
1582 case POSTPREL: break;
1583 case PREPREL : installHandlers();
1587 case EXIT : normalTerminal();
1588 #if HUGS_FOR_WINDOWS
1590 DestroyWindow(hWndMain);
1592 SetCursor(LoadCursor(NULL,IDC_ARROW));
1598 /*-------------------------------------------------------------------------*/