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/02/24 14:05:55 $
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 Args((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 Args((HKEY, String, PHKEY, REGSAM));
122 static Bool local queryValue Args((HKEY, String, String, LPDWORD, LPBYTE, DWORD));
123 static Bool local setValue Args((HKEY, String, String, DWORD, LPBYTE, DWORD));
124 static String local readRegString Args((HKEY, String, String, String));
125 static Int local readRegInt Args((String,Int));
126 static Bool local writeRegString Args((String,String));
127 static Bool local writeRegInt Args((String,Int));
129 static String local readRegChildStrings Args((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 Args((String));
149 static Void local getFileInfo Args((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 Args((Void));
246 static String local hscriptDir Args((Void));
248 //static String local RealPath Args((String));
249 static int local pathCmp Args((String, String));
250 static String local normPath Args((String));
251 static Void local searchChr Args((Int));
252 static Void local searchStr Args((String));
253 static Bool local tryEndings Args((String));
257 # define isSLASH(c) ((c)=='\\' || (c)=='/')
259 # define PATHSEP_STR ";"
260 # define DLL_ENDING ".dll"
263 # define isSLASH(c) ((c)==SLASH)
265 # define PATHSEP_STR ";"
266 /* Mac PEF (Preferred Executable Format) file */
267 # define DLL_ENDING ".pef"
270 # define isSLASH(c) ((c)==SLASH)
272 # define PATHSEP_STR ":"
273 # define DLL_ENDING ".u_o"
276 static String local hugsdir() { /* directory containing lib/Prelude.hs */
278 /* In HaskellScript (Win32 only), we lookup InstallDir in the registry. */
279 static char dir[FILENAME_MAX+1] = "";
280 if (dir[0] == '\0') { /* not initialised yet */
281 String s = readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"InstallDir",
288 #elif HAVE_GETMODULEFILENAME && !DOS && !__CYGWIN32__
289 /* On Windows, we can find the binary we're running and it's
290 * conventional to put the libraries in the same place.
292 static char dir[FILENAME_MAX+1] = "";
293 if (dir[0] == '\0') { /* not initialised yet */
295 GetModuleFileName((HMODULE)0,dir,FILENAME_MAX+1);
296 if (dir[0] == '\0') { /* GetModuleFileName must have failed */
299 slash = strrchr(dir,SLASH);
300 if (slash) { /* truncate after directory name */
306 /* On Unix systems, we can't find the binary we're running and
307 * the libraries may not be installed near the binary anyway.
308 * This forces us to use a hardwired path which is set at
309 * configuration time (--datadir=...).
316 static String local hscriptDir() { /* Directory containing hscript.dll */
317 static char dir[FILENAME_MAX+1] = "";
318 if (dir[0] == '\0') { /* not initialised yet */
319 String s = readRegString(HKEY_LOCAL_MACHINE,HScriptRoot,"InstallDir","");
328 #if 0 /* apparently unused */
329 static String local RealPath(s) /* Find absolute pathname of file */
331 #if HAVE__FULLPATH /* eg DOS */
332 static char path[FILENAME_MAX+1];
333 _fullpath(path,s,FILENAME_MAX+1);
334 #elif HAVE_REALPATH /* eg Unix */
335 static char path[MAXPATHLEN+1];
338 static char path[FILENAME_MAX+1];
346 static int local pathCmp(p1,p2) /* Compare paths after normalisation */
349 #if HAVE__FULLPATH /* eg DOS */
350 static char path1[FILENAME_MAX+1];
351 static char path2[FILENAME_MAX+1];
352 _fullpath(path1,p1,FILENAME_MAX+1);
353 _fullpath(path2,p2,FILENAME_MAX+1);
354 #elif HAVE_REALPATH /* eg Unix */
355 static char path1[MAXPATHLEN+1];
356 static char path2[MAXPATHLEN+1];
360 static char path1[FILENAME_MAX+1];
361 static char path2[FILENAME_MAX+1];
365 #if CASE_INSENSITIVE_FILENAMES
369 return filenamecmp(path1,path2);
372 static String local normPath(s) /* Try, as much as possible, to normalize */
373 String s; { /* a pathname in some appropriate manner. */
374 #if PATH_CANONICALIZATION
375 String path = RealPath(s);
376 #if CASE_INSENSITIVE_FILENAMES
377 strlwr(path); /* and convert to lowercase */
380 #else /* ! PATH_CANONICALIZATION */
382 #endif /* ! PATH_CANONICALIZATION */
386 static String endings[] = { "", ".u_hi", ".hs", ".lhs", ".hsx", ".hash", 0 };
388 static String endings[] = { "", ".u_hi", ".hs", ".lhs", 0 };
390 static char searchBuf[FILENAME_MAX+1];
391 static Int searchPos;
393 #define searchReset(n) searchBuf[searchPos=(n)]='\0'
395 static Void local searchChr(c) /* Add single character to search buffer */
397 if (searchPos<FILENAME_MAX) {
398 searchBuf[searchPos++] = (char)c;
399 searchBuf[searchPos] = '\0';
403 static Void local searchStr(s) /* Add string to search buffer */
405 while (*s && searchPos<FILENAME_MAX)
406 searchBuf[searchPos++] = *s++;
407 searchBuf[searchPos] = '\0';
410 static Bool local tryEndings(s) /* Try each of the listed endings */
414 for (; endings[i]; ++i) {
415 Int save = searchPos;
416 searchStr(endings[i]);
417 if (readable(searchBuf))
428 /* scandir, June 98 Daan Leijen
429 searches the base directory and its direct subdirectories for a file
431 input: searchbuf contains SLASH terminated base directory
432 argument s contains the (base) filename
433 output: TRUE: searchBuf contains the full filename
434 FALSE: searchBuf is garbage, file not found
438 #ifdef HAVE_WINDOWS_H
440 static Bool scanSubDirs(s)
443 struct _finddata_t findInfo;
448 /* is it in the current directory ? */
449 if (tryEndings(s)) return TRUE;
454 /* initiate the search */
455 handle = _findfirst( searchBuf, &findInfo );
456 if (handle==-1) { errno = 0; return FALSE; }
458 /* search all subdirectories */
460 /* if we have a valid sub directory */
461 if (((findInfo.attrib & _A_SUBDIR) == _A_SUBDIR) &&
462 (findInfo.name[0] != '.')) {
464 searchStr(findInfo.name);
470 } while (_findnext( handle, &findInfo ) == 0);
472 _findclose( handle );
476 #elif defined(HAVE_FTW_H)
480 static char baseFile[FILENAME_MAX+1];
481 static char basePath[FILENAME_MAX+1];
482 static int basePathLen;
484 static int scanitem( const char* path,
485 const struct stat* statinfo,
488 if (info == FTW_D) { /* is it a directory */
492 if (tryEndings(baseFile)) {
499 static Bool scanSubDirs(s)
504 strcpy(basePath,searchBuf);
505 basePathLen = strlen(basePath);
507 /* is it in the current directory ? */
508 if (tryEndings(s)) return TRUE;
510 /* otherwise scan the subdirectories */
511 r = ftw( basePath, scanitem, 2 );
516 #endif /* HAVE_WINDOWS_H || HAVE_FTW_H */
517 #endif /* SEARCH_DIR */
519 String findPathname(along,nm) /* Look for a file along specified path */
520 String along; /* Return NULL if file does not exist */
522 /* AC, 1/21/99: modified to search hugsPath first, then projectPath */
523 String s = findMPathname(along,nm,hugsPath);
528 s = findMPathname(along,nm,projectPath);
531 #endif /* USE_REGISTRY */
532 return s ? s : normPath(searchBuf);
535 /* AC, 1/21/99: modified to pass in path to search explicitly */
536 String findMPathname(along,nm,path)/* Look for a file along specified path */
537 String along; /* If nonzero, a path prefix from along is */
538 String nm; /* used as the first prefix in the search. */
540 String pathpt = path;
543 if (along) { /* Was a path for an existing file given? */
546 for (; along[i]; i++) {
548 if (isSLASH(along[i]))
554 return normPath(searchBuf);
556 if (pathpt && *pathpt) { /* Otherwise, we look along the HUGSPATH */
559 Bool recurse = FALSE; /* DL: shall we recurse ? */
562 if (*pathpt!=PATHSEP) {
563 /* Pre-define one MPW-style "shell-variable" */
564 if (strncmp(pathpt,"{Hugs}",6)==0) {
565 searchStr(hugsdir());
569 /* And another - we ought to generalise this stuff */
570 else if (strncmp(pathpt,"{HScript}",9)==0) {
571 searchStr(hscriptDir());
576 searchChr(*pathpt++);
577 } while (*pathpt && *pathpt!=PATHSEP);
578 recurse = (pathpt[-1] == SLASH);
583 if (*pathpt==PATHSEP)
591 if (recurse ? scanSubDirs(nm) : tryEndings(nm)) {
592 return normPath(searchBuf);
595 if (tryEndings(nm)) {
596 return normPath(searchBuf);
602 searchReset(0); /* As a last resort, look for file in the current dir */
603 return (tryEndings(nm) ? normPath(searchBuf) : 0);
606 /* --------------------------------------------------------------------------
607 * New path handling stuff for the Combined System (tm)
608 * ------------------------------------------------------------------------*/
610 char installDir[N_INSTALLDIR];
612 /* Sets installDir to $STGHUGSDIR, and ensures there is a trailing
615 void setInstallDir ( String argv_0 )
618 char* r = getenv("STGHUGSDIR");
621 "%s: installation error: environment variable STGHUGSDIR is not set.\n",
624 "%s: pls set it to be the directory where STGHugs98 is installed.\n\n",
630 if (strlen(r) > N_INSTALLDIR-30 ) {
632 "%s: environment variable STGHUGSDIR is suspiciously long; pls remedy\n\n",
637 strcpy ( installDir, r );
638 i = strlen(installDir);
639 if (installDir[i-1] != SLASH) installDir[i++] = SLASH;
644 Bool findFilesForModule (
648 Bool* sAvail, Time* sTime, Long* sSize,
649 Bool* iAvail, Time* iTime, Long* iSize,
650 Bool* oAvail, Time* oTime, Long* oSize
653 /* Let the module name given be M.
654 For each path entry P,
655 a s(rc) file will be P/M.hs or P/M.lhs
656 an i(nterface) file will be P/M.hi
657 an o(bject) file will be P/M.o
658 If there is a s file or (both i and o files)
659 use P to fill in the path names.
660 Otherwise, move on to the next path entry.
661 If all path entries are exhausted, return False.
665 String peStart, peEnd;
666 String augdPath; /* .:hugsPath:installDir/GhcPrel:installDir/lib */
668 *path = *sExt = NULL;
669 *sAvail = *iAvail = *oAvail = FALSE;
670 *sSize = *iSize = *oSize = 0;
672 augdPath = malloc( 2*(10+3+strlen(installDir))
673 +strlen(hugsPath) +10/*paranoia*/);
675 internal("moduleNameToFileNames: malloc failed(2)");
678 strcat(augdPath, ".");
679 strcat(augdPath, PATHSEP_STR);
681 strcat(augdPath, hugsPath);
682 strcat(augdPath, PATHSEP_STR);
685 strcat(augdPath, installDir);
686 strcat(augdPath, "GhcPrel");
687 strcat(augdPath, PATHSEP_STR);
690 strcat(augdPath, installDir);
691 strcat(augdPath, "lib");
692 strcat(augdPath, PATHSEP_STR);
694 /* fprintf ( stderr, "augdpath = `%s'\n", augdPath ); */
698 /* Advance peStart and peEnd very paranoically, giving up at
699 the first sign of mutancy in the path string.
701 if (peEnd >= augdPath && !(*peEnd)) { free(augdPath); return FALSE; }
704 while (*peEnd && *peEnd != PATHSEP) peEnd++;
706 /* Now peStart .. peEnd-1 bracket the next path element. */
707 nPath = peEnd-peStart;
708 if (nPath + strlen(modName) + 10 /*slush*/ > FILENAME_MAX) {
709 ERRMSG(0) "Hugs path \"%s\" contains excessively long component",
716 strncpy(searchBuf, peStart, nPath);
717 searchBuf[nPath] = 0;
718 if (nPath > 0 && !isSLASH(searchBuf[nPath-1]))
719 searchBuf[nPath++] = SLASH;
721 strcpy(searchBuf+nPath, modName);
722 nPath += strlen(modName);
724 /* searchBuf now holds 'P/M'. Try out the various endings. */
725 *path = *sExt = NULL;
726 *sAvail = *iAvail = *oAvail = FALSE;
727 *sSize = *iSize = *oSize = 0;
729 strcpy(searchBuf+nPath, DLL_ENDING);
730 if (readable(searchBuf)) {
732 getFileInfo(searchBuf, oTime, oSize);
735 strcpy(searchBuf+nPath, ".u_hi");
736 if (readable(searchBuf)) {
738 getFileInfo(searchBuf, iTime, iSize);
741 strcpy(searchBuf+nPath, ".hs");
742 if (readable(searchBuf)) {
745 getFileInfo(searchBuf, sTime, sSize);
748 strcpy(searchBuf+nPath, ".lhs");
749 if (readable(searchBuf)) {
752 getFileInfo(searchBuf, sTime, sSize);
758 if (*sAvail || (*oAvail && *iAvail)) {
759 nPath -= strlen(modName);
760 *path = malloc(nPath+1);
762 internal("moduleNameToFileNames: malloc failed(1)");
763 strncpy(*path, searchBuf, nPath);
774 /* If the primaryObjectName for is (eg)
776 and the extraFileName is (eg)
778 and DLL_ENDING is set to .o
780 /foo/bar/swampy_cbits.o
781 and set *extraFileSize to its size, or -1 if not avail
783 String getExtraObjectInfo ( String primaryObjectName,
784 String extraFileName,
791 Int i = strlen(primaryObjectName)-1;
792 while (i >= 0 && primaryObjectName[i] != SLASH) i--;
793 if (i == -1) return extraFileName;
795 xtra = malloc ( i+3+strlen(extraFileName)+strlen(DLL_ENDING) );
796 if (!xtra) internal("deriveExtraObjectName: malloc failed");
797 strncpy ( xtra, primaryObjectName, i );
799 strcat ( xtra, extraFileName );
800 strcat ( xtra, DLL_ENDING );
803 if (readable(xtra)) {
804 getFileInfo ( xtra, &xTime, &xSize );
805 *extraFileSize = xSize;
811 /* --------------------------------------------------------------------------
812 * Substitute old value of path into empty entries in new path
813 * eg substPath("a:b:c::d:e","x:y:z") = "a:b:c:x:y:z:d:e"
814 * ------------------------------------------------------------------------*/
816 static String local substPath Args((String,String));
818 static String local substPath(new,sub) /* substitute sub path into new path*/
821 Bool substituted = FALSE; /* only allow one replacement */
822 Int maxlen = strlen(sub) + strlen(new); /* safe upper bound */
823 String r = (String) malloc(maxlen+1); /* result string */
824 String t = r; /* pointer into r */
825 String next = new; /* next uncopied char in new */
826 String start = next; /* start of last path component */
828 ERRMSG(0) "String storage space exhausted"
832 if (*next == PATHSEP || *next == '\0') {
833 if (!substituted && next == start) {
835 for(; *s != '\0'; ++s) {
842 } while ((*t++ = *next++) != '\0');
847 /* --------------------------------------------------------------------------
848 * Garbage collection notification:
849 * ------------------------------------------------------------------------*/
851 Bool gcMessages = FALSE; /* TRUE => print GC messages */
853 Void gcStarted() { /* Notify garbage collector start */
855 SaveCursor = SetCursor(GarbageCursor);
863 Void gcScanning() { /* Notify garbage collector scans */
870 Void gcRecovered(recovered) /* Notify garbage collection done */
873 Printf("%d}}",recovered);
877 SetCursor(SaveCursor);
881 Cell *CStackBase; /* Retain start of C control stack */
883 #if RISCOS /* Stack traversal for RISCOS */
885 /* Warning: The following code is specific to the Acorn ARM under RISCOS
886 (and C4). We must explicitly walk back through the stack frames, since
887 the stack is extended from the heap. (see PRM pp. 1757). gcCStack must
888 not be modified, since the offset '5' assumes that only v1 is used inside
889 this function. Hence we do all the real work in gcARM.
892 #define spreg 13 /* C3 has SP=R13 */
894 #define previousFrame(fp) ((int *)((fp)[-3]))
895 #define programCounter(fp) ((int *)((*(fp)-12) & ~0xFC000003))
896 #define isSubSPSP(w) (((w)&dontCare) == doCare)
897 #define doCare (0xE24DD000) /* SUB r13,r13,#0 */
898 #define dontCare (~0x00100FFF) /* S and # bits */
899 #define immediateArg(x) ( ((x)&0xFF) << (((x)&0xF00)>>7) )
901 static void gcARM(int *fp) {
902 int si = *programCounter(fp); /* Save instruction indicates how */
903 /* many registers in this frame */
905 if (si & (1<<0)) markWithoutMove(*regs--);
906 if (si & (1<<1)) markWithoutMove(*regs--);
907 if (si & (1<<2)) markWithoutMove(*regs--);
908 if (si & (1<<3)) markWithoutMove(*regs--);
909 if (si & (1<<4)) markWithoutMove(*regs--);
910 if (si & (1<<5)) markWithoutMove(*regs--);
911 if (si & (1<<6)) markWithoutMove(*regs--);
912 if (si & (1<<7)) markWithoutMove(*regs--);
913 if (si & (1<<8)) markWithoutMove(*regs--);
914 if (si & (1<<9)) markWithoutMove(*regs--);
915 if (previousFrame(fp)) {
916 /* The non-register stack space is for the previous frame is above
917 this fp, and not below the previous fp, because of the way stack
918 extension works. It seems the only way of discovering its size is
919 finding the SUB sp, sp, #? instruction by walking through the code
920 following the entry point.
922 int *oldpc = programCounter(previousFrame(fp));
924 for(i = 1; i < 6; ++i)
925 if(isSubSPSP(oldpc[i])) fsize += immediateArg(oldpc[i]) / 4;
926 for(i=1; i<=fsize; ++i)
927 markWithoutMove(fp[i]);
933 int *fp = 5 + &dummy;
936 fp = previousFrame(fp);
940 #else /* Garbage collection for standard stack machines */
942 Void gcCStack() { /* Garbage collect elements off */
943 Cell stackTop = NIL; /* C stack */
944 Cell *ptr = &stackTop;
945 #if SIZEOF_VOID_P == 2
946 if (((long)(ptr) - (long)(CStackBase))&1)
948 #elif STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
949 if (((long)(ptr) - (long)(CStackBase))&1)
952 if (((long)(ptr) - (long)(CStackBase))&3)
956 #define Blargh markWithoutMove(*ptr);
958 markWithoutMove((*ptr)/sizeof(Cell)); \
959 markWithoutMove(( (void*)(*ptr)-(void*)heapTopFst)/sizeof(Cell)); \
960 markWithoutMove(( (void*)(*ptr)-(void*)heapTopSnd)/sizeof(Cell))
963 #define StackGrowsDown { while (ptr<=CStackBase) { Blargh; ptr++; }; }
964 #define StackGrowsUp { while (ptr>=CStackBase) { Blargh; ptr--; }; }
965 #define GuessDirection if (ptr>CStackBase) StackGrowsUp else StackGrowsDown
967 #if STACK_DIRECTION > 0
969 #elif STACK_DIRECTION < 0
975 #if SIZEOF_VOID_P==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
976 ptr = (Cell *)((long)(&stackTop) + 2);
980 #undef StackGrowsDown
982 #undef GuessDirection
986 /* --------------------------------------------------------------------------
987 * Terminal dependent stuff:
988 * ------------------------------------------------------------------------*/
990 #if (HAVE_TERMIO_H | HAVE_SGTTY_H | HAVE_TERMIOS_H)
992 /* grab the varargs prototype for ioctl */
994 # include <sys/ioctl.h>
997 /* The order of these three tests is very important because
998 * some systems have more than one of the requisite header file
999 * but only one of them seems to work.
1000 * Anyone changing the order of the tests should try enabling each of the
1001 * three branches in turn and write down which ones work as well as which
1002 * OS/compiler they're using.
1004 * OS Compiler sgtty termio termios notes
1005 * Linux 2.0.18 gcc 2.7.2 absent works works 1
1008 * 1) On Linux, termio.h just #includes termios.h and sgtty.h is
1009 * implemented using termios.h.
1010 * sgtty.h is in /usr/include/bsd which is not on my standard include
1011 * path. Adding it does no harm but you might as well use termios.
1013 * reid-alastair@cs.yale.edu
1017 #include <termios.h>
1018 typedef struct termios TermParams;
1019 #define getTerminal(tp) tcgetattr(fileno(stdin), &tp)
1020 #define setTerminal(tp) tcsetattr(fileno(stdin), TCSAFLUSH, &tp)
1021 #define noEcho(tp) tp.c_lflag &= ~(ICANON | ECHO); \
1022 tp.c_cc[VMIN] = 1; \
1028 typedef struct sgttyb TermParams;
1029 #define getTerminal(tp) ioctl(fileno(stdin),TIOCGETP,&tp)
1030 #define setTerminal(tp) ioctl(fileno(stdin),TIOCSETP,&tp)
1032 #define noEcho(tp) tp.sg_flags |= RAW; tp.sg_flags &= (~ECHO);
1034 #define noEcho(tp) tp.sg_flags |= CBREAK; tp.sg_flags &= (~ECHO);
1040 typedef struct termio TermParams;
1041 #define getTerminal(tp) ioctl(fileno(stdin),TCGETA,&tp)
1042 #define setTerminal(tp) ioctl(fileno(stdin),TCSETAF,&tp)
1043 #define noEcho(tp) tp.c_lflag &= ~(ICANON | ECHO); \
1044 tp.c_cc[VMIN] = 1; \
1049 static Bool messedWithTerminal = FALSE;
1050 static TermParams originalSettings;
1052 Void normalTerminal() { /* restore terminal initial state */
1053 if (messedWithTerminal)
1054 setTerminal(originalSettings);
1057 Void noechoTerminal() { /* set terminal into noecho mode */
1058 TermParams settings;
1060 if (!messedWithTerminal) {
1061 getTerminal(originalSettings);
1062 messedWithTerminal = TRUE;
1064 getTerminal(settings);
1066 setTerminal(settings);
1069 Int getTerminalWidth() { /* determine width of terminal */
1071 #ifdef _M_UNIX /* SCO Unix 3.2.4 defines TIOCGWINSZ*/
1072 #include <sys/stream.h> /* Required by sys/ptem.h */
1073 #include <sys/ptem.h> /* Required to declare winsize */
1075 static struct winsize terminalSize;
1076 ioctl(fileno(stdout),TIOCGWINSZ,&terminalSize);
1077 return (terminalSize.ws_col==0)? 80 : terminalSize.ws_col;
1083 Int readTerminalChar() { /* read character from terminal */
1084 return getchar(); /* without echo, assuming that */
1085 } /* noechoTerminal() is active... */
1089 Int readTerminalChar() { /* read character from terminal */
1090 return getchar(); /* without echo, assuming that */
1091 } /* noechoTerminal() is active... */
1093 Int getTerminalWidth() {
1094 return console_options.ncols;
1097 Void normalTerminal() {
1098 csetmode(C_ECHO, stdin);
1101 Void noechoTerminal() {
1102 csetmode(C_NOECHO, stdin);
1105 #else /* no terminal driver - eg DOS, RISCOS */
1107 static Bool terminalEchoReqd = TRUE;
1109 Int getTerminalWidth() {
1112 (void) os_swi3r(OS_ReadModeVariable, -1, 1, 0, &dummy, &dummy, &width);
1119 Void normalTerminal() { /* restore terminal initial state */
1120 terminalEchoReqd = TRUE;
1123 Void noechoTerminal() { /* turn terminal echo on/off */
1124 terminalEchoReqd = FALSE;
1127 Int readTerminalChar() { /* read character from terminal */
1128 if (terminalEchoReqd) {
1131 #if IS_WIN32 && !HUGS_FOR_WINDOWS && !__BORLANDC__
1132 /* When reading a character from the console/terminal, we want
1133 * to operate in 'raw' mode (to use old UNIX tty parlance) and have
1134 * it return when a character is available and _not_ wait until
1135 * the next time the user hits carriage return. On Windows platforms,
1136 * this _can_ be done by reading directly from the console, using
1137 * getch(). However, this doesn't sit well with programming
1138 * environments such as Emacs which allow you to create sub-processes
1139 * running Hugs, and then communicate with the running interpreter
1140 * through its standard input and output handles. If you use getch()
1141 * in that setting, you end up trying to read the (unused) console
1142 * of the editor itself, through which not a lot of characters is
1143 * bound to come out, since the editor communicates input to Hugs
1144 * via the standard input handle.
1146 * To avoid this rather unfortunate situation, we use the Win32
1147 * console API and re-jig the input properties of the standard
1148 * input handle before trying to read a character using stdio's
1151 * The 'cost' of this solution is that it is Win32 specific and
1152 * won't work with Windows 3.1 + it is kind of ugly and verbose
1153 * to have to futz around with the console properties on a
1154 * per-char basis. Both of these disadvantages aren't in my
1163 /* I don't quite understand why, but if the FILE*'s underlying file
1164 descriptor is in text mode, we seem to lose the first carriage
1167 setmode(fileno(stdin), _O_BINARY);
1168 hIn = GetStdHandle(STD_INPUT_HANDLE);
1169 GetConsoleMode(hIn, &mo);
1170 SetConsoleMode(hIn, mo & ~(ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT));
1172 * On Win9x, the first time you change the mode (as above) a
1173 * raw '\n' is inserted. Since enter maps to a raw '\r', and we
1174 * map this (below) to '\n', we can just ignore all *raw* '\n's.
1178 } while (c == '\n');
1180 /* Same as it ever was - revert back state of stdin. */
1181 SetConsoleMode(hIn, mo);
1182 setmode(fileno(stdin), _O_TEXT);
1186 return c=='\r' ? '\n' : c; /* slight paranoia about CR-LF */
1190 #endif /* no terminal driver */
1192 /* --------------------------------------------------------------------------
1193 * Interrupt handling:
1194 * ------------------------------------------------------------------------*/
1196 Bool broken = FALSE;
1197 static Bool breakReqd = FALSE;
1198 static sigProto(ignoreBreak);
1199 static Void local installHandlers Args((Void));
1201 Bool breakOn(reqd) /* set break trapping on if reqd, */
1202 Bool reqd; { /* or off otherwise, returning old */
1203 Bool old = breakReqd;
1207 if (broken) { /* repond to break signal received */
1208 broken = FALSE; /* whilst break trap disabled */
1209 sigRaise(breakHandler);
1212 #if HANDLERS_CANT_LONGJMP
1213 ctrlbrk(ignoreBreak);
1215 ctrlbrk(breakHandler);
1218 ctrlbrk(ignoreBreak);
1223 static sigHandler(ignoreBreak) { /* record but don't respond to break*/
1224 ctrlbrk(ignoreBreak); /* reinstall signal handler */
1225 /* redundant on BSD systems but essential */
1226 /* on POSIX and other systems */
1233 static sigProto(panic);
1234 static sigHandler(panic) { /* exit in a panic, on receipt of */
1235 everybody(EXIT); /* an unexpected signal */
1236 fprintf(stderr,"\nUnexpected signal\n");
1238 sigResume;/*NOTREACHED*/
1240 #endif /* !DONT_PANIC */
1243 BOOL WINAPI consoleHandler(DWORD dwCtrlType) {
1244 switch (dwCtrlType) { /* Allows Hugs to be terminated */
1245 case CTRL_CLOSE_EVENT : /* from the window's close menu. */
1252 static Void local installHandlers() { /* Install handlers for all fatal */
1253 /* signals except SIGINT and SIGBREAK*/
1255 SetConsoleCtrlHandler(consoleHandler,TRUE);
1257 #if !DONT_PANIC && !DOS
1259 signal(SIGABRT,panic);
1262 signal(SIGBUS,panic);
1265 signal(SIGFPE,panic);
1268 signal(SIGHUP,panic);
1271 signal(SIGILL,panic);
1274 signal(SIGQUIT,panic);
1277 signal(SIGSEGV,panic);
1280 signal(SIGTERM,panic);
1282 #endif /* !DONT_PANIC && !DOS */
1285 /* --------------------------------------------------------------------------
1287 * ------------------------------------------------------------------------*/
1289 static Bool local startEdit(line,nm) /* Start editor on file name at */
1290 Int line; /* given line. Both name and line */
1291 String nm; { /* or just line may be zero */
1292 static char editorCmd[FILENAME_MAX+1];
1295 if (hugsEdit && *hugsEdit) { /* Check that editor configured */
1297 /* On a Mac, files have creator information, telling which program
1298 to launch to, so an editor named to the empty string "" is often
1300 if (hugsEdit) { /* Check that editor configured */
1302 Int n = FILENAME_MAX;
1303 String he = hugsEdit;
1304 String ec = editorCmd;
1305 String rd = NULL; /* Set to nonnull to redo ... */
1307 for (; n>0 && *he && *he!=' ' && *he!='%'; n--)
1308 *ec++ = *he++; /* Copy editor name to buffer */
1309 /* assuming filename ends at space */
1311 if (nm && line && n>1 && *he){ /* Name, line, and enough space */
1312 rd = ec; /* save, in case we don't find name*/
1313 while (n>0 && *he) {
1315 if (*++he=='d' && n>10) {
1316 sprintf(ec,"%d",line);
1319 else if (*he=='s' && (size_t)n>strlen(nm)) {
1324 else if (*he=='%' && n>1) {
1328 else /* Ignore % char if not followed */
1329 *ec = '\0'; /* by one of d, s, or %, */
1330 for (; *ec && n>0; n--)
1332 } /* ignore % followed by anything other than d, s, or % */
1333 else { /* Copy other characters across */
1342 if (rd) { /* If file name was not included */
1347 if (nm && line==0 && n>1) { /* Name, but no line ... */
1349 for (; n>0 && *nm; n--) /* ... just copy file name */
1353 *ec = '\0'; /* Add terminating null byte */
1356 ERRMSG(0) "Hugs is not configured to use an editor"
1361 WinExec(editorCmd, SW_SHOW);
1364 if (shellEsc(editorCmd))
1365 Printf("Warning: Editor terminated abnormally\n");
1370 Int shellEsc(s) /* run a shell command (or shell) */
1373 return macsystem(s);
1377 s = fromEnv("SHELL","/bin/sh");
1384 #if RISCOS /* RISCOS also needs a chdir() */
1385 int chdir(char *s) { /* RISCOS PRM p. 885 -- JBS */
1386 return os_swi2(OS_FSControl + XOS_Bit, 0, (int)s) != NULL;
1388 #elif defined HAVE_PBHSETVOLSYNC /* Macintosh */
1389 int chdir(const char *s) {
1392 wd.ioCompletion = 0;
1393 str = (char*)malloc(strlen(s) + 1);
1394 if (str == 0) return -1;
1396 wd.ioNamePtr = C2PStr(str);
1399 errno = PBHSetVolSync(&wd);
1410 /*---------------------------------------------------------------------------
1411 * Printf-related operations:
1412 *-------------------------------------------------------------------------*/
1414 #if !defined(HAVE_VSNPRINTF)
1415 int vsnprintf(buffer, count, fmt, ap)
1420 #if defined(HAVE__VSNPRINTF)
1421 return _vsnprintf(buffer, count, fmt, ap);
1426 #endif /* HAVE_VSNPRINTF */
1428 #if !defined(HAVE_SNPRINTF)
1429 int snprintf(char* buffer, int count, const char* fmt, ...) {
1430 #if defined(HAVE__VSNPRINTF)
1432 va_list ap; /* pointer into argument list */
1433 va_start(ap, fmt); /* make ap point to first arg after fmt */
1434 r = vsnprintf(buffer, count, fmt, ap);
1435 va_end(ap); /* clean up */
1441 #endif /* HAVE_SNPRINTF */
1443 /* --------------------------------------------------------------------------
1444 * Read/write values from/to the registry
1446 * All reads are from either HUGS_CURRENT_USER\\hugs_ROOT\\key or
1447 * HUGS_LOCAL_MACHINE\\hugs_ROOT\\key. (Machine entry is only used if
1448 * user entry doesn't exist).
1450 * All writes are to HUGS_CURRENT_USER\\HugsRoot\\key
1451 * ------------------------------------------------------------------------*/
1455 #define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
1457 static Bool local createKey Args((HKEY, PHKEY, REGSAM));
1458 static Bool local queryValue Args((HKEY, String, LPDWORD, LPBYTE, DWORD));
1459 static Bool local setValue Args((HKEY, String, DWORD, LPBYTE, DWORD));
1461 static Bool local createKey(hKey, phRootKey, samDesired)
1464 REGSAM samDesired; {
1466 return RegCreateKeyEx(hKey, HugsRoot,
1467 0, "", REG_OPTION_NON_VOLATILE,
1468 samDesired, NULL, phRootKey, &dwDisp)
1472 static Bool local queryValue(hKey, regPath, var, type, buf, bufSize)
1481 if (!createKey(hKey, regPath, &hRootKey, KEY_READ)) {
1484 LONG res = RegQueryValueEx(hRootKey, var, NULL, type, buf, &bufSize);
1485 RegCloseKey(hRootKey);
1486 return (res == ERROR_SUCCESS);
1490 static Bool local setValue(hKey, regPath, var, type, buf, bufSize)
1499 if (!createKey(hKey, regPath, &hRootKey, KEY_WRITE)) {
1502 LONG res = RegSetValueEx(hRootKey, var, 0, type, buf, bufSize);
1503 RegCloseKey(hRootKey);
1504 return (res == ERROR_SUCCESS);
1508 static String local readRegString(key,regPath,var,def) /* read String from registry */
1513 static char buf[300];
1515 if (queryValue(key, regPath,var, &type, buf, sizeof(buf))
1516 && type == REG_SZ) {
1523 static Int local readRegInt(var, def) /* read Int from registry */
1529 if (queryValue(HKEY_CURRENT_USER, HugsRoot, var, &type,
1530 (LPBYTE)&buf, sizeof(buf))
1531 && type == REG_DWORD) {
1533 } else if (queryValue(HKEY_LOCAL_MACHINE, HugsRoot, var, &type,
1534 (LPBYTE)&buf, sizeof(buf))
1535 && type == REG_DWORD) {
1542 static Bool local writeRegString(var,val) /* write String to registry */
1548 return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1549 REG_SZ, (LPBYTE)val, lstrlen(val)+1);
1552 static Bool local writeRegInt(var,val) /* write String to registry */
1555 return setValue(HKEY_CURRENT_USER, HugsRoot, var,
1556 REG_DWORD, (LPBYTE)&val, sizeof(val));
1559 #endif /* USE_REGISTRY */
1561 /* --------------------------------------------------------------------------
1562 * Things to do with the argv/argc and the env
1563 * ------------------------------------------------------------------------*/
1565 int nh_argc ( void )
1570 int nh_argvb ( int argno, int offset )
1572 return (int)(prog_argv[argno][offset]);
1575 /* --------------------------------------------------------------------------
1576 * Machine dependent control:
1577 * ------------------------------------------------------------------------*/
1579 Void machdep(what) /* Handle machine specific */
1580 Int what; { /* initialisation etc.. */
1583 case POSTPREL: break;
1584 case PREPREL : installHandlers();
1588 case EXIT : normalTerminal();
1589 #if HUGS_FOR_WINDOWS
1591 DestroyWindow(hWndMain);
1593 SetCursor(LoadCursor(NULL,IDC_ARROW));
1599 /*-------------------------------------------------------------------------*/