-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Machine dependent code
* RISCOS specific code provided by Bryan Scatergood, JBS
* Macintosh specific code provided by Hans Aberg (haberg@matematik.su.se)
+ * HaskellScript code and recursive directory search provided by
+ * Daan Leijen (leijen@fwi.uva.nl)
*
- * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
- * All rights reserved. See NOTICE for details and conditions of use etc...
- * Hugs version 1.4, December 1997
+ * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
+ * Yale Haskell Group, and the Oregon Graduate Institute of Science and
+ * Technology, 1994-1999, All rights reserved. It is distributed as
+ * free software under the license in the file "License", which is
+ * included in the distribution.
*
* $RCSfile: machdep.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:20 $
+ * $Revision: 1.32 $
+ * $Date: 2000/05/26 10:14:33 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
-#include "storage.h"
-#include "connect.h"
-#include "hugs.h" /* for fromEnv */
-#include "errors.h"
-#include "version.h"
-
-#include "machdep.h"
-
-#include <stdio.h>
#ifdef HAVE_SIGNAL_H
# include <signal.h>
#endif
# include <types.h>
# endif
#endif
+
+#if 0
#if HAVE_SYS_PARAM_H
# include <sys/param.h>
#endif
+#endif
+
#ifdef HAVE_SYS_STAT_H
# include <sys/stat.h>
#else
#ifdef HAVE_DOS_H
# include <dos.h>
#endif
-#if defined HAVE_CONIO_H && ! HUGS_FOR_WINDOWS
+#if defined HAVE_CONIO_H
# include <conio.h>
#endif
#ifdef HAVE_IO_H
# include <windows.h>
#endif
-#if HUGS_FOR_WINDOWS
-#include <dir.h>
-#include <mem.h>
-
-extern HCURSOR HandCursor; /* Forward references to cursors */
-extern HCURSOR GarbageCursor;
-extern HCURSOR SaveCursor;
-static void local DrawStatusLine Args((HWND));
-#endif
-
#if DOS
#include <mem.h>
extern unsigned _stklen = 8000; /* Allocate an 8k stack segment */
#ifdef HAVE_UNIX_H
#include <unix.h>
#endif
+#if SYMANTEC_C
+int allow_break_count = 0;
+#endif
/* --------------------------------------------------------------------------
* Find information about a file:
* ------------------------------------------------------------------------*/
-static Bool local readable Args((String));
+#include "machdep_time.h"
+
+static Bool local readable ( String );
+static Void local getFileInfo ( String, Time *, Long * );
-Void getFileInfo(f,tm,sz) /* find time stamp and size of file*/
+static Void local getFileInfo(f,tm,sz) /* find time stamp and size of file*/
String f;
Time *tm;
Long *sz; {
#if defined HAVE_SYS_STAT_H || defined HAVE_STAT_H || defined HAVE_UNIX_H
struct stat scbuf;
if (!stat(f,&scbuf)) {
- *tm = scbuf.st_mtime;
+ if (tm) *tm = scbuf.st_mtime;
*sz = (Long)(scbuf.st_size);
} else {
- *tm = 0;
+ if (tm) *tm = 0;
*sz = 0;
}
#else /* normally just use stat() */
r.r[1] = (int)s;
os_swi(OS_File, &r);
if(r.r[0] == 1 && (r.r[2] & 0xFFF00000) == 0xFFF00000) {
- tm->hi = r.r[2] & 0xFF; /* Load address (high byte) */
- tm->lo = r.r[3]; /* Execution address (low 4 bytes) */
+ if (tm) tm->hi = r.r[2] & 0xFF; /* Load address (high byte) */
+ if (tm) tm->lo = r.r[3]; /* Execution address (low 4 bytes) */
} else { /* Not found, or not time-stamped */
- tm->hi = tm->lo = 0;
+ if (tm) tm->hi = tm->lo = 0;
}
*sz = (Long)(r.r[0] == 1 ? r.r[4] : 0);
#endif
}
+Void getFileSize ( String f, Long* sz )
+{
+ getFileInfo ( f, NULL, sz );
+}
+
#if defined HAVE_GETFINFO /* Mac971031 */
/* --------------------------------------------------------------------------
* Define a MacOS version of access():
return (0 == access(f,4));
#elif defined HAVE_SYS_STAT_H || defined HAVE_STAT_H
struct stat scbuf;
+ /* fprintf(stderr, "readable: %s\n", f ); */
return ( !stat(f,&scbuf)
&& (scbuf.st_mode & S_IREAD) /* readable */
&& (scbuf.st_mode & S_IFREG) /* regular file */
* Search for script files on the HUGS path:
* ------------------------------------------------------------------------*/
-static String local hugsdir Args((Void));
-static String local RealPath Args((String));
-static String local normPath Args((String));
-static Void local searchChr Args((Int));
-static Void local searchStr Args((String));
-static Bool local tryEndings Args((String));
+static String local hugsdir ( Void );
+#if HSCRIPT
+static String local hscriptDir ( Void );
+#endif
+static int local pathCmp ( String, String );
+static String local normPath ( String );
+static Void local searchChr ( Int );
+static Void local searchStr ( String );
+static Bool local tryEndings ( String );
-#if DOS_FILENAMES
-# define SLASH '\\'
+#if (DOS_FILENAMES || __CYGWIN32__)
+# define SLASH '/'
+# define SLASH_STR "/"
# define isSLASH(c) ((c)=='\\' || (c)=='/')
# define PATHSEP ';'
-# define DLL_ENDING ".dll"
+# define PATHSEP_STR ";"
+# define DLL_ENDING ".u_o"
#elif MAC_FILENAMES
# define SLASH ':'
# define isSLASH(c) ((c)==SLASH)
# define PATHSEP ';'
+# define PATHSEP_STR ";"
/* Mac PEF (Preferred Executable Format) file */
# define DLL_ENDING ".pef"
#else
# define SLASH '/'
+# define SLASH_STR "/"
# define isSLASH(c) ((c)==SLASH)
# define PATHSEP ':'
-# define DLL_ENDING ".so"
+# define PATHSEP_STR ":"
+# define DLL_ENDING ".u_o"
#endif
static String local hugsdir() { /* directory containing lib/Prelude.hs */
-#if HAVE_GETMODULEFILENAME && !DOS
+#if HSCRIPT
+ /* In HaskellScript (Win32 only), we lookup InstallDir in the registry. */
+ static char dir[FILENAME_MAX+1] = "";
+ if (dir[0] == '\0') { /* not initialised yet */
+ String s = readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"InstallDir",
+ HUGSDIR);
+ if (s) {
+ strcpy(dir,s);
+ }
+ }
+ return dir;
+#elif HAVE_GETMODULEFILENAME && !DOS && !__CYGWIN32__
/* On Windows, we can find the binary we're running and it's
* conventional to put the libraries in the same place.
*/
if (dir[0] == '\0') { /* GetModuleFileName must have failed */
return HUGSDIR;
}
- if (slash = strrchr(dir,SLASH)) { /* truncate after directory name */
+ slash = strrchr(dir,SLASH);
+ if (slash) { /* truncate after directory name */
*slash = '\0';
}
}
return HUGSDIR;
#endif
}
-
-static String local RealPath(s) /* Find absolute pathname of file */
-String s; {
-#if HAVE__FULLPATH /* eg DOS */
- static char path[FILENAME_MAX+1];
- _fullpath(path,s,FILENAME_MAX+1);
-#elif HAVE_REALPATH /* eg Unix */
- static char path[MAXPATHLEN+1];
- realpath(s,path);
-#else
- static char path[FILENAME_MAX+1];
- strcpy(path,s);
-#endif
- return path;
-}
-int pathCmp(p1,p2) /* Compare paths after normalisation */
-String p1;
-String p2; {
-#if HAVE__FULLPATH /* eg DOS */
- static char path1[FILENAME_MAX+1];
- static char path2[FILENAME_MAX+1];
- _fullpath(path1,p1,FILENAME_MAX+1);
- _fullpath(path2,p2,FILENAME_MAX+1);
-#elif HAVE_REALPATH /* eg Unix */
- static char path1[MAXPATHLEN+1];
- static char path2[MAXPATHLEN+1];
- realpath(p1,path1);
- realpath(p2,path2);
-#else
- static char path1[FILENAME_MAX+1];
- static char path2[FILENAME_MAX+1];
- strcpy(path1,p1);
- strcpy(path2,p2);
-#endif
-#if CASE_INSENSITIVE_FILENAMES
- strlwr(path1);
- strlwr(path2);
-#endif
- return filenamecmp(path1,path2);
+#if HSCRIPT
+static String local hscriptDir() { /* Directory containing hscript.dll */
+ static char dir[FILENAME_MAX+1] = "";
+ if (dir[0] == '\0') { /* not initialised yet */
+ String s = readRegString(HKEY_LOCAL_MACHINE,HScriptRoot,"InstallDir","");
+ if (s) {
+ strcpy(dir,s);
+ }
+ }
+ return dir;
}
+#endif
+
static String local normPath(s) /* Try, as much as possible, to normalize */
String s; { /* a pathname in some appropriate manner. */
#endif /* ! PATH_CANONICALIZATION */
}
-static String endings[] = { "", ".myhi", ".hs", ".lhs", 0 };
+#if HSCRIPT
+static String endings[] = { "", ".u_hi", ".hs", ".lhs", ".hsx", ".hash", 0 };
+#else
+static String endings[] = { "", ".u_hi", ".hs", ".lhs", 0 };
+#endif
static char searchBuf[FILENAME_MAX+1];
static Int searchPos;
static Void local searchChr(c) /* Add single character to search buffer */
Int c; {
if (searchPos<FILENAME_MAX) {
- searchBuf[searchPos++] = c;
+ searchBuf[searchPos++] = (char)c;
searchBuf[searchPos] = '\0';
}
}
return FALSE;
}
+
+
+#if SEARCH_DIR
+
+/* scandir, June 98 Daan Leijen
+ searches the base directory and its direct subdirectories for a file
+
+ input: searchbuf contains SLASH terminated base directory
+ argument s contains the (base) filename
+ output: TRUE: searchBuf contains the full filename
+ FALSE: searchBuf is garbage, file not found
+*/
+
+
+#ifdef HAVE_WINDOWS_H
+
+static Bool scanSubDirs(s)
+String s;
+{
+ struct _finddata_t findInfo;
+ long handle;
+ int save;
+
+ save = searchPos;
+ /* is it in the current directory ? */
+ if (tryEndings(s)) return TRUE;
+
+ searchReset(save);
+ searchStr("*");
+
+ /* initiate the search */
+ handle = _findfirst( searchBuf, &findInfo );
+ if (handle==-1) { errno = 0; return FALSE; }
+
+ /* search all subdirectories */
+ do {
+ /* if we have a valid sub directory */
+ if (((findInfo.attrib & _A_SUBDIR) == _A_SUBDIR) &&
+ (findInfo.name[0] != '.')) {
+ searchReset(save);
+ searchStr(findInfo.name);
+ searchChr(SLASH);
+ if (tryEndings(s)) {
+ return TRUE;
+ }
+ }
+ } while (_findnext( handle, &findInfo ) == 0);
+
+ _findclose( handle );
+ return FALSE;
+}
+
+#elif defined(HAVE_FTW_H)
+
+#include <ftw.h>
+
+static char baseFile[FILENAME_MAX+1];
+static char basePath[FILENAME_MAX+1];
+static int basePathLen;
+
+static int scanitem( const char* path,
+ const struct stat* statinfo,
+ int info )
+{
+ if (info == FTW_D) { /* is it a directory */
+ searchReset(0);
+ searchStr(path);
+ searchChr(SLASH);
+ if (tryEndings(baseFile)) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+static Bool scanSubDirs(s)
+String s;
+{
+ int r;
+ strcpy(baseFile,s);
+ strcpy(basePath,searchBuf);
+ basePathLen = strlen(basePath);
+
+ /* is it in the current directory ? */
+ if (tryEndings(s)) return TRUE;
+
+ /* otherwise scan the subdirectories */
+ r = ftw( basePath, scanitem, 2 );
+ errno = 0;
+ return (r > 0);
+}
+
+#endif /* HAVE_WINDOWS_H || HAVE_FTW_H */
+#endif /* SEARCH_DIR */
+
String findPathname(along,nm) /* Look for a file along specified path */
String along; /* Return NULL if file does not exist */
String nm; {
- String s = findMPathname(along,nm);
+ /* AC, 1/21/99: modified to search hugsPath first, then projectPath */
+ String s = findMPathname(along,nm,hugsPath);
return s ? s : normPath(searchBuf);
}
-String findMPathname(along,nm) /* Look for a file along specified path */
+/* AC, 1/21/99: modified to pass in path to search explicitly */
+String findMPathname(along,nm,path)/* Look for a file along specified path */
String along; /* If nonzero, a path prefix from along is */
-String nm; { /* used as the first prefix in the search. */
- String pathpt = hugsPath;
+String nm; /* used as the first prefix in the search. */
+String path; {
+ String pathpt = path;
searchReset(0);
if (along) { /* Was a path for an existing file given? */
if (pathpt && *pathpt) { /* Otherwise, we look along the HUGSPATH */
Bool more = TRUE;
do {
+ Bool recurse = FALSE; /* DL: shall we recurse ? */
searchReset(0);
if (*pathpt) {
if (*pathpt!=PATHSEP) {
searchStr(hugsdir());
pathpt += 6;
}
- do
+#if HSCRIPT
+ /* And another - we ought to generalise this stuff */
+ else if (strncmp(pathpt,"{HScript}",9)==0) {
+ searchStr(hscriptDir());
+ pathpt += 9;
+ }
+#endif
+ do {
searchChr(*pathpt++);
- while (*pathpt && *pathpt!=PATHSEP);
- searchChr(SLASH);
+ } while (*pathpt && *pathpt!=PATHSEP);
+ recurse = (pathpt[-1] == SLASH);
+ if (!recurse) {
+ searchChr(SLASH);
+ }
}
if (*pathpt==PATHSEP)
pathpt++;
else
more = FALSE;
- }
- else
+ } else {
more = FALSE;
- if (tryEndings(nm))
+ }
+#if SEARCH_DIR
+ if (recurse ? scanSubDirs(nm) : tryEndings(nm)) {
return normPath(searchBuf);
+ }
+#else
+ if (tryEndings(nm)) {
+ return normPath(searchBuf);
+ }
+#endif
} while (more);
}
}
/* --------------------------------------------------------------------------
+ * New path handling stuff for the Combined System (tm)
+ * ------------------------------------------------------------------------*/
+
+char installDir[N_INSTALLDIR];
+
+/* Sets installDir to $STGHUGSDIR, and ensures there is a trailing
+ slash at the end.
+*/
+void setInstallDir ( String argv_0 )
+{
+ int i;
+ char* r = getenv("STGHUGSDIR");
+ if (!r) {
+ fprintf(stderr,
+ "%s: installation error: environment variable STGHUGSDIR is not set.\n",
+ argv_0 );
+ fprintf(stderr,
+ "%s: pls set it to be the directory where STGHugs98 is installed.\n\n",
+ argv_0 );
+ exit(2);
+
+ }
+
+ if (strlen(r) > N_INSTALLDIR-30 ) {
+ fprintf(stderr,
+ "%s: environment variable STGHUGSDIR is suspiciously long; pls remedy\n\n",
+ argv_0 );
+ exit(2);
+ }
+
+ strcpy ( installDir, r );
+ i = strlen(installDir);
+ if (installDir[i-1] != SLASH) installDir[i++] = SLASH;
+ installDir[i] = 0;
+}
+
+
+Bool findFilesForModule (
+ String modName,
+ String* path,
+ String* sExt,
+ Bool* sAvail, Time* sTime, Long* sSize,
+ Bool* oiAvail, Time* oiTime, Long* oSize, Long* iSize
+ )
+{
+ /* Let the module name given be M.
+ For each path entry P,
+ a s(rc) file will be P/M.hs or P/M.lhs
+ an i(nterface) file will be P/M.hi
+ an o(bject) file will be P/M.o
+ If there is a s file or (both i and o files)
+ use P to fill in the path names.
+ Otherwise, move on to the next path entry.
+ If all path entries are exhausted, return False.
+
+ If in standalone, only look for (and succeed for) source modules.
+ Caller free()s path. sExt is statically allocated.
+ srcExt is only set if a valid source file is found.
+ */
+ Int nPath;
+ Bool literate;
+ String peStart, peEnd;
+ String augdPath; /* .:hugsPath:installDir/../lib/std:installDir/lib */
+ Time oTime, iTime;
+ Bool oAvail, iAvail;
+
+ *path = *sExt = NULL;
+ *sAvail = *oiAvail = oAvail = iAvail = FALSE;
+ *sSize = *oSize = *iSize = 0;
+
+ augdPath = malloc( 2*(10+3+strlen(installDir))
+ +strlen(hugsPath) +50/*paranoia*/);
+ if (!augdPath)
+ internal("moduleNameToFileNames: malloc failed(2)");
+
+ augdPath[0] = 0;
+
+ if (combined) {
+ strcat(augdPath, installDir);
+ strcat(augdPath, "..");
+ strcat(augdPath, SLASH_STR);
+ strcat(augdPath, "lib");
+ strcat(augdPath, SLASH_STR);
+ strcat(augdPath, "std");
+ strcat(augdPath, PATHSEP_STR);
+ }
+
+ strcat(augdPath, installDir);
+ strcat(augdPath, "lib");
+ strcat(augdPath, PATHSEP_STR);
+
+ /* these two were previously before the above `if' */
+ strcat(augdPath, ".");
+ strcat(augdPath, PATHSEP_STR);
+
+ strcat(augdPath, hugsPath);
+ strcat(augdPath, PATHSEP_STR);
+
+ /* fprintf ( stderr, "augdpath = `%s'\n", augdPath ); */
+
+ peEnd = augdPath-1;
+ while (1) {
+ /* Advance peStart and peEnd very paranoically, giving up at
+ the first sign of mutancy in the path string.
+ */
+ if (peEnd >= augdPath && !(*peEnd)) { free(augdPath); return FALSE; }
+ peStart = peEnd+1;
+ peEnd = peStart;
+ while (*peEnd && *peEnd != PATHSEP) peEnd++;
+
+ /* Now peStart .. peEnd-1 bracket the next path element. */
+ nPath = peEnd-peStart;
+ if (nPath + strlen(modName) + 10 /*slush*/ > FILENAME_MAX) {
+ ERRMSG(0) "Hugs path \"%s\" contains excessively long component",
+ hugsPath
+ EEND;
+ free(augdPath);
+ return FALSE;
+ }
+
+ strncpy(searchBuf, peStart, nPath);
+ searchBuf[nPath] = 0;
+ if (nPath > 0 && !isSLASH(searchBuf[nPath-1]))
+ searchBuf[nPath++] = SLASH;
+
+ strcpy(searchBuf+nPath, modName);
+ nPath += strlen(modName);
+
+ /* searchBuf now holds 'P/M'. Try out the various endings. */
+ *path = *sExt = NULL;
+ *sAvail = *oiAvail = oAvail = iAvail = FALSE;
+ *sSize = *oSize = *iSize = 0;
+
+ if (combined) {
+ strcpy(searchBuf+nPath, DLL_ENDING);
+ if (readable(searchBuf)) {
+ oAvail = TRUE;
+ getFileInfo(searchBuf, &oTime, oSize);
+ }
+ strcpy(searchBuf+nPath, HI_ENDING);
+ if (readable(searchBuf)) {
+ iAvail = TRUE;
+ getFileInfo(searchBuf, &iTime, iSize);
+ }
+ if (oAvail && iAvail) {
+ *oiAvail = TRUE;
+ *oiTime = whicheverIsLater ( oTime, iTime );
+ }
+ }
+
+ strcpy(searchBuf+nPath, ".hs");
+ if (readable(searchBuf)) {
+ *sAvail = TRUE;
+ literate = FALSE;
+ getFileInfo(searchBuf, sTime, sSize);
+ *sExt = ".hs";
+ } else {
+ strcpy(searchBuf+nPath, ".lhs");
+ if (readable(searchBuf)) {
+ *sAvail = TRUE;
+ literate = TRUE;
+ getFileInfo(searchBuf, sTime, sSize);
+ *sExt = ".lhs";
+ }
+ }
+
+ /* Success? */
+ if (*sAvail || *oiAvail) {
+ nPath -= strlen(modName);
+ *path = malloc(nPath+1);
+ if (!(*path))
+ internal("moduleNameToFileNames: malloc failed(1)");
+ strncpy(*path, searchBuf, nPath);
+ (*path)[nPath] = 0;
+ free(augdPath);
+ return TRUE;
+ }
+
+ }
+
+}
+
+
+/* If the primaryObjectName is (eg)
+ /foo/bar/PrelSwamp.o
+ and the extraFileName is (eg)
+ swampy_cbits
+ and DLL_ENDING is set to .o
+ return
+ /foo/bar/swampy_cbits.o
+ and set *extraFileSize to its size, or -1 if not avail
+*/
+String getExtraObjectInfo ( String primaryObjectName,
+ String extraFileName,
+ Int* extraFileSize )
+{
+ Time xTime;
+ Long xSize;
+ String xtra;
+
+ Int i = strlen(primaryObjectName)-1;
+ while (i >= 0 && primaryObjectName[i] != SLASH) i--;
+ if (i == -1) return extraFileName;
+ i++;
+ xtra = malloc ( i+3+strlen(extraFileName)+strlen(DLL_ENDING) );
+ if (!xtra) internal("deriveExtraObjectName: malloc failed");
+ strncpy ( xtra, primaryObjectName, i );
+ xtra[i] = 0;
+ strcat ( xtra, extraFileName );
+ strcat ( xtra, DLL_ENDING );
+
+ *extraFileSize = -1;
+ if (readable(xtra)) {
+ getFileInfo ( xtra, &xTime, &xSize );
+ *extraFileSize = xSize;
+ }
+ return xtra;
+}
+
+
+/* --------------------------------------------------------------------------
* Substitute old value of path into empty entries in new path
* eg substPath("a:b:c::d:e","x:y:z") = "a:b:c:x:y:z:d:e"
* ------------------------------------------------------------------------*/
-String substPath(new,sub) /* substitute sub path into new path*/
+static String local substPath ( String,String );
+
+static String local substPath(new,sub) /* substitute sub path into new path*/
String new;
String sub; {
Bool substituted = FALSE; /* only allow one replacement */
Bool gcMessages = FALSE; /* TRUE => print GC messages */
-Void gcStarted() { /* notify garbage collector start */
-#if HUGS_FOR_WINDOWS
- SaveCursor = SetCursor(GarbageCursor);
-#endif
+Void gcStarted() { /* Notify garbage collector start */
if (gcMessages) {
- printf("{{Gc");
+ Printf("{{Gc");
FlushStdout();
}
}
-Void gcScanning() { /* notify garbage collector scans */
+Void gcScanning() { /* Notify garbage collector scans */
if (gcMessages) {
Putchar(':');
FlushStdout();
}
}
-Void gcRecovered(recovered) /* notify garbage collection done */
+Void gcRecovered(recovered) /* Notify garbage collection done */
Int recovered; {
if (gcMessages) {
- printf("%d}}",recovered);
- fflush(stdout);
+ Printf("%d}}",recovered);
+ FlushStdout();
}
-#if HUGS_FOR_WINDOWS
- SetCursor(SaveCursor);
-#endif
}
Cell *CStackBase; /* Retain start of C control stack */
Void gcCStack() { /* Garbage collect elements off */
Cell stackTop = NIL; /* C stack */
Cell *ptr = &stackTop;
-#if SIZEOF_INTP == 2
+#if SIZEOF_VOID_P == 2
if (((long)(ptr) - (long)(CStackBase))&1)
fatal("gcCStack");
#elif STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
fatal("gcCStack");
#endif
-#define StackGrowsDown while (ptr<=CStackBase) markWithoutMove(*ptr++)
-#define StackGrowsUp while (ptr>=CStackBase) markWithoutMove(*ptr--)
-#define GuessDirection if (ptr>CStackBase) StackGrowsUp; else StackGrowsDown
+#define Blargh mark(*ptr);
+#if 0
+ markWithoutMove((*ptr)/sizeof(Cell)); \
+ markWithoutMove(( (void*)(*ptr)-(void*)heapTopFst)/sizeof(Cell)); \
+ markWithoutMove(( (void*)(*ptr)-(void*)heapTopSnd)/sizeof(Cell))
+#endif
+
+#define StackGrowsDown { while (ptr<=CStackBase) { Blargh; ptr++; }; }
+#define StackGrowsUp { while (ptr>=CStackBase) { Blargh; ptr--; }; }
+#define GuessDirection if (ptr>CStackBase) StackGrowsUp else StackGrowsDown
#if STACK_DIRECTION > 0
StackGrowsUp;
GuessDirection;
#endif
-#if SIZEOF_INTP==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
+#if SIZEOF_VOID_P==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
ptr = (Cell *)((long)(&stackTop) + 2);
StackGrowsDown;
#endif
#endif
/* --------------------------------------------------------------------------
- * Terminal dependent stuff:
- * ------------------------------------------------------------------------*/
-
-#if (HAVE_TERMIO_H | HAVE_SGTTY_H | HAVE_TERMIOS_H)
-
-/* This is believed to be redundant! ADR */
-#if HAVE_SYS_IOCTL_H
-# include <sys/ioctl.h>
-#endif
-
-/* The order of these three tests is very important because
- * some systems have more than one of the requisite header file
- * but only one of them seems to work.
- * Anyone changing the order of the tests should try enabling each of the
- * three branches in turn and write down which ones work as well as which
- * OS/compiler they're using.
- *
- * OS Compiler sgtty termio termios notes
- * Linux 2.0.18 gcc 2.7.2 absent works works 1
- *
- * Notes:
- * 1) On Linux, termio.h just #includes termios.h and sgtty.h is
- * implemented using termios.h.
- * sgtty.h is in /usr/include/bsd which is not on my standard include
- * path. Adding it does no harm but you might as well use termios.
- * --
- * reid-alastair@cs.yale.edu
- */
-#if HAVE_TERMIOS_H
-
-#include <termios.h>
-typedef struct termios TermParams;
-#define getTerminal(tp) tcgetattr(fileno(stdin), &tp)
-#define setTerminal(tp) tcsetattr(fileno(stdin), TCSAFLUSH, &tp)
-#define noEcho(tp) tp.c_lflag &= ~(ICANON | ECHO); \
- tp.c_cc[VMIN] = 1; \
- tp.c_cc[VTIME] = 0;
-
-#elif HAVE_SGTTY_H
-
-#include <sgtty.h>
-typedef struct sgttyb TermParams;
-#define getTerminal(tp) ioctl(fileno(stdin),TIOCGETP,&tp)
-#define setTerminal(tp) ioctl(fileno(stdin),TIOCSETP,&tp)
-#if HPUX
-#define noEcho(tp) tp.sg_flags |= RAW; tp.sg_flags &= (~ECHO);
-#else
-#define noEcho(tp) tp.sg_flags |= CBREAK; tp.sg_flags &= (~ECHO);
-#endif
-
-#elif HAVE_TERMIO_H
-
-#include <termio.h>
-typedef struct termio TermParams;
-#define getTerminal(tp) ioctl(fileno(stdin),TCGETA,&tp)
-#define setTerminal(tp) ioctl(fileno(stdin),TCSETAF,&tp)
-#define noEcho(tp) tp.c_lflag &= ~(ICANON | ECHO); \
- tp.c_cc[VMIN] = 1; \
- tp.c_cc[VTIME] = 0;
-
-#endif
-
-static Bool messedWithTerminal = FALSE;
-static TermParams originalSettings;
-
-Void normalTerminal() { /* restore terminal initial state */
- if (messedWithTerminal)
- setTerminal(originalSettings);
-}
-
-Void noechoTerminal() { /* set terminal into noecho mode */
- TermParams settings;
-
- if (!messedWithTerminal) {
- getTerminal(originalSettings);
- messedWithTerminal = TRUE;
- }
- getTerminal(settings);
- noEcho(settings);
- setTerminal(settings);
-}
-
-Int getTerminalWidth() { /* determine width of terminal */
-#ifdef TIOCGWINSZ
-#ifdef _M_UNIX /* SCO Unix 3.2.4 defines TIOCGWINSZ*/
-#include <sys/stream.h> /* Required by sys/ptem.h */
-#include <sys/ptem.h> /* Required to declare winsize */
-#endif
- static struct winsize terminalSize;
- ioctl(fileno(stdout),TIOCGWINSZ,&terminalSize);
- return (terminalSize.ws_col==0)? 80 : terminalSize.ws_col;
-#else
- return 80;
-#endif
-}
-
-Int readTerminalChar() { /* read character from terminal */
- return getchar(); /* without echo, assuming that */
-} /* noechoTerminal() is active... */
-
-#elif SYMANTEC_C
-
-Int readTerminalChar() { /* read character from terminal */
- return getchar(); /* without echo, assuming that */
-} /* noechoTerminal() is active... */
-
-Int getTerminalWidth() {
- return console_options.ncols;
-}
-
-Void normalTerminal() {
- csetmode(C_ECHO, stdin);
-}
-
-Void noechoTerminal() {
- csetmode(C_NOECHO, stdin);
-}
-
-#else /* no terminal driver - eg DOS, RISCOS */
-
-static Bool terminalEchoReqd = TRUE;
-
-Int getTerminalWidth() {
-#if RISCOS
- int dummy, width;
- (void) os_swi3r(OS_ReadModeVariable, -1, 1, 0, &dummy, &dummy, &width);
- return width+1;
-#else
- return 80;
-#endif
-}
-
-Void normalTerminal() { /* restore terminal initial state */
- terminalEchoReqd = TRUE;
-}
-
-Void noechoTerminal() { /* turn terminal echo on/off */
- terminalEchoReqd = FALSE;
-}
-
-Int readTerminalChar() { /* read character from terminal */
- if (terminalEchoReqd) {
- return getchar();
- } else {
- Int c = getch();
- return c=='\r' ? '\n' : c; /* slight paranoia about CR-LF */
- }
-}
-
-#endif /* no terminal driver */
-
-/* --------------------------------------------------------------------------
* Interrupt handling:
* ------------------------------------------------------------------------*/
-Bool broken = FALSE;
-static Bool breakReqd = FALSE;
-static sigProto(ignoreBreak);
-static Void local installHandlers Args((Void));
-
-Bool breakOn(reqd) /* set break trapping on if reqd, */
-Bool reqd; { /* or off otherwise, returning old */
- Bool old = breakReqd;
-
- breakReqd = reqd;
- if (reqd) {
- if (broken) { /* repond to break signal received */
- broken = FALSE; /* whilst break trap disabled */
- sigRaise(breakHandler);
- }
- ctrlbrk(ignoreBreak);
- } else {
- ctrlbrk(ignoreBreak);
- }
- return old;
-}
-
-static sigHandler(ignoreBreak) { /* record but don't respond to break*/
- ctrlbrk(ignoreBreak);
- broken = TRUE;
- interruptStgRts();
- sigResume;
-}
-
-#if !DONT_PANIC
-static sigProto(panic);
-static sigHandler(panic) { /* exit in a panic, on receipt of */
- everybody(EXIT); /* an unexpected signal */
- fprintf(stderr,"\nUnexpected signal\n");
- exit(1);
- sigResume;/*NOTREACHED*/
-}
-#endif /* !DONT_PANIC */
-
-static Void local installHandlers() { /* Install handlers for all fatal */
+static Void installHandlers ( void ) { /* Install handlers for all fatal */
/* signals except SIGINT and SIGBREAK*/
+#if IS_WIN32
+ /* SetConsoleCtrlHandler(consoleHandler,TRUE); */
+#endif
#if !DONT_PANIC && !DOS
# ifdef SIGABRT
signal(SIGABRT,panic);
* Shell escapes:
* ------------------------------------------------------------------------*/
-Bool startEdit(line,nm) /* Start editor on file name at */
+static Bool local startEdit(line,nm) /* Start editor on file name at */
Int line; /* given line. Both name and line */
String nm; { /* or just line may be zero */
static char editorCmd[FILENAME_MAX+1];
String ec = editorCmd;
String rd = NULL; /* Set to nonnull to redo ... */
- for (; n>0 && *he && *he!=' '; n--)
+ for (; n>0 && *he && *he!=' ' && *he!='%'; n--)
*ec++ = *he++; /* Copy editor name to buffer */
/* assuming filename ends at space */
#endif
-/*---------------------------------------------------------------------------
- * Printf-related operations:
- *-------------------------------------------------------------------------*/
-
-#if !defined(HAVE_VSNPRINTF)
-int vsnprintf(buffer, count, fmt, ap)
-char* buffer;
-int count;
-const char* fmt;
-va_list ap; {
-#if defined(HAVE__VSNPRINTF)
- return _vsnprintf(buffer, count, fmt, ap);
-#else
- return 0;
-#endif
-}
-#endif /* HAVE_VSNPRINTF */
-
-#if !defined(HAVE_SNPRINTF)
-int snprintf(char* buffer, int count, const char* fmt, ...) {
-#if defined(HAVE__VSNPRINTF)
- int r;
- va_list ap; /* pointer into argument list */
- va_start(ap, fmt); /* make ap point to first arg after fmt */
- r = vsnprintf(buffer, count, fmt, ap);
- va_end(ap); /* clean up */
- return r;
-#else
- return 0;
-#endif
-}
-#endif /* HAVE_SNPRINTF */
-
/* --------------------------------------------------------------------------
- * Read/write values from/to the registry
- *
- * All reads are from either HUGS_CURRENT_USER\\hugs_ROOT\\key or
- * HUGS_LOCAL_MACHINE\\hugs_ROOT\\key. (Machine entry is only used if
- * user entry doesn't exist).
- *
- * All writes are to HUGS_CURRENT_USER\\HugsRoot\\key
+ * Things to do with the argv/argc and the env
* ------------------------------------------------------------------------*/
-#if USE_REGISTRY
-
-#define HugsRoot ("SOFTWARE\\Haskell\\Hugs\\" HUGS_VERSION "\\")
-
-static Bool local createKey Args((HKEY, PHKEY, REGSAM));
-static Bool local queryValue Args((HKEY, String, LPDWORD, LPBYTE, DWORD));
-static Bool local setValue Args((HKEY, String, DWORD, LPBYTE, DWORD));
-
-static Bool local createKey(hKey, phRootKey, samDesired)
-HKEY hKey;
-PHKEY phRootKey;
-REGSAM samDesired; {
- DWORD dwDisp;
- return RegCreateKeyEx(hKey, HugsRoot,
- 0, "", REG_OPTION_NON_VOLATILE,
- samDesired, NULL, phRootKey, &dwDisp)
- == ERROR_SUCCESS;
+int nh_argc ( void )
+{
+ return prog_argc;
}
-static Bool local queryValue(hKey, var, type, buf, bufSize)
-HKEY hKey;
-String var;
-LPDWORD type;
-LPBYTE buf;
-DWORD bufSize; {
- HKEY hRootKey;
-
- if (!createKey(hKey, &hRootKey, KEY_READ)) {
- return FALSE;
- } else {
- LONG res = RegQueryValueEx(hRootKey, var, NULL, type, buf, &bufSize);
- RegCloseKey(hRootKey);
- return (res == ERROR_SUCCESS);
- }
+int nh_argvb ( int argno, int offset )
+{
+ return (int)(prog_argv[argno][offset]);
}
-static Bool local setValue(hKey, var, type, buf, bufSize)
-HKEY hKey;
-String var;
-DWORD type;
-LPBYTE buf;
-DWORD bufSize; {
- HKEY hRootKey;
-
- if (!createKey(hKey, &hRootKey, KEY_WRITE)) {
- return FALSE;
- } else {
- LONG res = RegSetValueEx(hRootKey, var, 0, type, buf, bufSize);
- RegCloseKey(hRootKey);
- return (res == ERROR_SUCCESS);
- }
-}
-
-String readRegString(var,def) /* read String from registry */
-String var;
-String def; {
- static char buf[300];
- DWORD type;
-
- if (queryValue(HKEY_CURRENT_USER, var, &type, buf, sizeof(buf))
- && type == REG_SZ) {
- return (String)buf;
- } else if (queryValue(HKEY_LOCAL_MACHINE, var, &type, buf, sizeof(buf))
- && type == REG_SZ) {
- return (String)buf;
- } else {
- return NULL;
- }
-}
-
-Int readRegInt(var, def) /* read Int from registry */
-String var;
-Int def; {
- DWORD buf;
- DWORD type;
-
- if (queryValue(HKEY_CURRENT_USER, var, &type,
- (LPBYTE)&buf, sizeof(buf))
- && type == REG_DWORD) {
- return (Int)buf;
- } else if (queryValue(HKEY_LOCAL_MACHINE, var, &type,
- (LPBYTE)&buf, sizeof(buf))
- && type == REG_DWORD) {
- return (Int)buf;
- } else {
- return def;
- }
-}
-
-Bool writeRegString(var,val) /* write String to registry */
-String var;
-String val; {
- if (NULL == val) {
- val = "";
- }
- return setValue(HKEY_CURRENT_USER, var,
- REG_SZ, (LPBYTE)val, lstrlen(val)+1);
-}
-
-Bool writeRegInt(var,val) /* write String to registry */
-String var;
-Int val; {
- return setValue(HKEY_CURRENT_USER, var,
- REG_DWORD, (LPBYTE)&val, sizeof(val));
-}
-
-#endif /* USE_REGISTRY */
-
/* --------------------------------------------------------------------------
* Machine dependent control:
* ------------------------------------------------------------------------*/
Int what; { /* initialisation etc.. */
switch (what) {
case MARK : break;
- case INSTALL : installHandlers();
+ case POSTPREL: break;
+ case PREPREL : installHandlers();
break;
case RESET :
case BREAK :
- case EXIT : normalTerminal();
-#if HUGS_FOR_WINDOWS
- if (what==EXIT)
- DestroyWindow(hWndMain);
- else
- SetCursor(LoadCursor(NULL,IDC_ARROW));
-#endif
+ case EXIT :
break;
}
}