/* --------------------------------------------------------------------------
* Command interpreter
*
- * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
- * Haskell Group 1994-99, and is distributed as Open Source software
- * under the Artistic License; see the file "Artistic" that is included
- * in the distribution for details.
+ * 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: hugs.c,v $
- * $Revision: 1.5 $
- * $Date: 1999/03/09 14:51:07 $
+ * $Revision: 1.36 $
+ * $Date: 2000/01/12 14:47:27 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
#include "Rts.h"
#include "RtsAPI.h"
#include "Schedule.h"
-
+#include "Assembler.h" /* DEBUG_LoadSymbols */
Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
+#if EXPLAIN_INSTANCE_RESOLUTION
+Bool showInstRes = FALSE;
+#endif
+#if MULTI_INST
+Bool multiInstRes = FALSE;
+#endif
+
/* --------------------------------------------------------------------------
* Local function prototypes:
* ------------------------------------------------------------------------*/
static Void local find Args((Void));
static Bool local startEdit Args((Int,String));
static Void local runEditor Args((Void));
-#if IGNORE_MODULES
-#define findEvalModule() doNothing()
-#else
static Void local setModule Args((Void));
static Module local findEvalModule Args((Void));
-#endif
static Void local evaluator Args((Void));
static Void local stopAnyPrinting Args((Void));
static Void local showtype Args((Void));
static Void local loadProject Args((String));
static Void local clearProject Args((Void));
-static Void local addScriptName Args((String,Bool));
-static Bool local addScript Args((String,Long));
+static Bool local addScript Args((Int));
static Void local forgetScriptsFrom Args((Script));
static Void local setLastEdit Args((String,Int));
static Void local failed Args((Void));
static String local strCopy Args((String));
+static Void local browseit Args((Module,String,Bool));
+static Void local browse Args((Void));
/* --------------------------------------------------------------------------
* Machine dependent code for Hugs interpreter:
* ------------------------------------------------------------------------*/
+ Bool combined = TRUE;
+
#include "machdep.c"
#ifdef WANT_TIMER
#include "timer.c"
* Local data areas:
* ------------------------------------------------------------------------*/
-static Bool printing = FALSE; /* TRUE => currently printing value*/
-static Bool showStats = FALSE; /* TRUE => print stats after eval */
-static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
-static Bool addType = FALSE; /* TRUE => print type with value */
-static Bool chaseImports = TRUE; /* TRUE => chase imports on load */
-static Bool useDots = RISCOS; /* TRUE => use dots in progress */
-static Bool quiet = FALSE; /* TRUE => don't show progress */
-
-static String scriptName[NUM_SCRIPTS]; /* Script file names */
-static Time lastChange[NUM_SCRIPTS]; /* Time of last change to script */
-static Bool postponed[NUM_SCRIPTS]; /* Indicates postponed load */
+static Bool printing = FALSE; /* TRUE => currently printing value*/
+static Bool showStats = FALSE; /* TRUE => print stats after eval */
+static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
+static Bool addType = FALSE; /* TRUE => print type with value */
+static Bool useDots = RISCOS; /* TRUE => use dots in progress */
+static Bool quiet = FALSE; /* TRUE => don't show progress */
+static Bool lastWasObject = FALSE;
+ Bool preludeLoaded = FALSE;
+ Bool debugSC = FALSE;
+
+typedef
+ struct {
+ String modName; /* Module name */
+ Bool details; /* FALSE => remaining fields are invalid */
+ String path; /* Path to module */
+ String srcExt; /* ".hs" or ".lhs" if fromSource */
+ Time lastChange; /* Time of last change to script */
+ Bool fromSource; /* FALSE => load object code */
+ Bool postponed; /* Indicates postponed load */
+ Bool objLoaded;
+ Long size;
+ Long oSize;
+ }
+ ScriptInfo;
+
+static Void local makeStackEntry Args((ScriptInfo*,String));
+static Void local addStackEntry Args((String));
+
+static ScriptInfo scriptInfo[NUM_SCRIPTS];
+
static Int numScripts; /* Number of scripts loaded */
+static Int nextNumScripts;
static Int namesUpto; /* Number of script names set */
static Bool needsImports; /* set to TRUE if imports required */
String scriptFile; /* Name of current script (if any) */
+
+
static Text evalModule = 0; /* Name of module we eval exprs in */
static String currProject = 0; /* Name of current project file */
static Bool projectLoaded = FALSE; /* TRUE => project file loaded */
+static Bool autoMain = FALSE;
static String lastEdit = 0; /* Name of script to edit (if any) */
static Int lastEdLine = 0; /* Editor line number (if possible)*/
static String prompt = 0; /* Prompt string */
static Int hpSize = DEFAULTHEAP; /* Desired heap size */
String hugsEdit = 0; /* String for editor command */
String hugsPath = 0; /* String for file search path */
-Bool preludeLoaded = FALSE;
+
+ List ifaces_outstanding = NIL;
#if REDIRECT_OUTPUT
static Bool disableOutput = FALSE; /* redirect output to buffer? */
#endif
+String bool2str ( Bool b )
+{
+ if (b) return "Yes"; else return "No ";
+}
+
+void ppSmStack ( String who )
+{
+ int i, j;
+return;
+ fflush(stdout);fflush(stderr);
+ printf ( "\n" );
+ printf ( "ppSmStack %s: numScripts = %d namesUpto = %d needsImports = %s\n",
+ who, numScripts, namesUpto, bool2str(needsImports) );
+ assert (namesUpto >= numScripts);
+ printf ( " Det FrS Pst ObL Module Ext Size ModTime Path\n" );
+ for (i = namesUpto-1; i >= 0; i--) {
+ printf ( "%c%2d: %3s %3s %3s %3s %16s %-4s %5ld %8lx %s\n",
+ (i==numScripts ? '*' : ' '),
+ i, bool2str(scriptInfo[i].details),
+ bool2str(scriptInfo[i].fromSource),
+ bool2str(scriptInfo[i].postponed),
+ bool2str(scriptInfo[i].objLoaded),
+ scriptInfo[i].modName,
+ scriptInfo[i].fromSource ? scriptInfo[i].srcExt : "",
+ scriptInfo[i].size,
+ scriptInfo[i].lastChange,
+ scriptInfo[i].path
+ );
+ }
+ fflush(stdout);fflush(stderr);
+ ppScripts();
+ ppModules();
+ printf ( "\n" );
+}
+
/* --------------------------------------------------------------------------
* Hugs entry point:
* ------------------------------------------------------------------------*/
CStackBase = &argc; /* Save stack base for use in gc */
- Printf("__ __ __ __ ____ ___ _______________________________________________\n");
- Printf("|| || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system\n");
- Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n");
- Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
- Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
- Printf("|| || Version: %s _______________________________________________\n\n",HUGS_VERSION);
+ /* If first arg is +Q or -Q, be entirely silent, and automatically run
+ main after loading scripts. Useful for running the nofib suite. */
+ if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
+ autoMain = TRUE;
+ if (strcmp(argv[1],"-Q") == 0) {
+ hugsEnableOutput(0);
+ }
+ }
+
+ Printf("__ __ __ __ ____ ___ _________________________________________\n");
+ Printf("|| || || || || || ||__ STGHugs: Based on the Haskell 98 standard\n");
+ Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n");
+ Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
+ Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
+ Printf("|| || Version: %s _________________________________________\n\n",HUGS_VERSION);
+
+ /* Get the absolute path to the directory containing the hugs
+ executable, so that we know where the Prelude and nHandle.so/.dll are.
+ We do this by reading env var STGHUGSDIR. This needs to succeed, so
+ setInstallDir won't return unless it succeeds.
+ */
+ setInstallDir ( argv[0] );
#if SYMANTEC_C
Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
Int argc;
String argv[]; {
Script i;
- String proj = 0;
+ String proj = 0;
+ char argv_0_orig[1000];
setLastEdit((String)0,0);
lastEdit = 0;
namesUpto = 1;
#if HUGS_FOR_WINDOWS
- hugsEdit = strCopy(fromEnv("EDITOR","c:\\windows\notepad.exe"));
+ hugsEdit = strCopy(fromEnv("EDITOR","c:\\windows\\notepad.exe"));
#elif SYMANTEC_C
hugsEdit = "";
#else
hugsEdit = strCopy(fromEnv("EDITOR",NULL));
#endif
- hugsPath = strCopy(HUGSPATH); readOptions("-p\"%s> \" -r$$");
+ hugsPath = strCopy(HUGSPATH);
+ readOptions("-p\"%s> \" -r$$");
#if USE_REGISTRY
projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
"HUGSPATH", PATHSEP, ""));
#endif /* USE_REGISTRY */
readOptions(fromEnv("STGHUGSFLAGS",""));
- startupHaskell ( argc, argv );
+ strncpy(argv_0_orig,argv[0],1000); /* startupHaskell mangles argv[0] */
+ startupHaskell (argc,argv);
argc = prog_argc; argv = prog_argv;
- for (i=1; i<argc; ++i) { /* process command line arguments */
+ namesUpto = numScripts = 0;
+
+ /* Pre-scan flags to see if -c or +c is present. This needs to
+ precede adding the stack entry for Prelude. On the other hand,
+ that stack entry needs to be made before the cmd line args are
+ properly examined. Hence the following pre-scan of them.
+ */
+ for (i=1; i < argc; ++i) {
+ if (strcmp(argv[i], "--")==0) break;
+ if (strcmp(argv[i], "-c")==0) combined = FALSE;
+ if (strcmp(argv[i], "+c")==0) combined = TRUE;
+ }
+
+ addStackEntry("Prelude");
+ if (combined) addStackEntry("PrelHugs");
+
+ for (i=1; i < argc; ++i) { /* process command line arguments */
+ if (strcmp(argv[i], "--")==0) break;
if (strcmp(argv[i],"+")==0 && i+1<argc) {
if (proj) {
ERRMSG(0) "Multiple project filenames on command line"
}
} else if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
&& !processOption(argv[i])) {
- addScriptName(argv[i],TRUE);
+ addStackEntry(argv[i]);
}
}
-#ifdef DEBUG
- DEBUG_LoadSymbols(argv[0]);
+#if DEBUG
+ {
+ char exe_name[N_INSTALLDIR + 6];
+ strcpy(exe_name, installDir);
+ strcat(exe_name, "hugs");
+ DEBUG_LoadSymbols(exe_name);
+ }
#endif
- scriptName[0] = strCopy(findMPathname(NULL,STD_PRELUDE,hugsPath));
+
+#if 0
if (!scriptName[0]) {
Printf("Prelude not found on current path: \"%s\"\n",
hugsPath ? hugsPath : "");
fatal("Unable to load prelude");
}
+#endif
if (haskell98) {
- Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n\n");
+ Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n");
+ } else {
+ Printf("Hugs mode: Restart with command line option +98 for Haskell 98 mode\n");
+ }
+
+ if (combined) {
+ Printf("Combined mode: Restart with command line -c for standalone mode\n\n" );
} else {
- Printf("Hugs mode: Restart with command line option +98 for Haskell 98 mode\n\n");
+ Printf("Standalone mode: Restart with command line +c for combined mode\n\n" );
}
- everybody(INSTALL);
+ everybody(PREPREL);
+
evalModule = findText(""); /* evaluate wrt last module by default */
if (proj) {
if (namesUpto>1) {
struct options { /* command line option toggles */
char c; /* table defined in main app. */
+ int h98;
String description;
Bool *flag;
};
Int count = 0;
Int i;
for (i=0; toggle[i].c; ++i)
- if (*toggle[i].flag == state) {
+ if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
if (count==0)
Putchar((char)(state ? '+' : '-'));
Putchar(toggle[i].c);
Int i;
Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
- for (i=0; toggle[i].c; ++i)
- Printf(fmtc,toggle[i].c,toggle[i].description);
+ for (i=0; toggle[i].c; ++i) {
+ if (!haskell98 || toggle[i].h98) {
+ Printf(fmtc,toggle[i].c,toggle[i].description);
+ }
+ }
Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
Printf(fmts,"Fstr","Set preprocessor filter to str");
#endif
-#if PROFILING
- Printf(fmts,"dnum","Gather profiling statistics every <num> reductions\n");
-#endif
Printf("\nCurrent settings: ");
togglesIn(TRUE);
Printf("\nPreprocessor : -F");
printString(preprocessor);
#endif
-#if PROFILING
- Printf("\nProfile interval: -d%d", profiling ? profInterval : 0);
-#endif
- Printf("\nCompatibility : %s", haskell98 ? "Haskell 98"
- : "Hugs Extensions");
+ Printf("\nCompatibility : %s", haskell98 ? "Haskell 98 (+98)"
+ : "Hugs Extensions (-98)");
Putchar('\n');
}
PUTC(toggle[i].c);
PUTC(' ');
}
+ PUTS(haskell98 ? "+98 " : "-98 ");
PUTInt('h',hpSize); PUTC(' ');
PUTStr('p',prompt);
PUTStr('r',repeatStr);
#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
PUTStr('F',preprocessor);
#endif
-#if PROFILING
- PUTInt('d',profiling ? profInterval : 0);
-#endif
PUTC('\0');
return buffer;
}
while (*++s)
switch (*s) {
+ case 'Q' : break; /* already handled */
+
case 'p' : if (s[1]) {
if (prompt) free(prompt);
prompt = strCopy(s+1);
case 'h' : setHeapSize(s+1);
return TRUE;
+ case 'c' : if (heapBuilt()) {
+ FPrintf(stderr,
+ "You can't enable/disable combined"
+ " operation inside Hugs\n" );
+ } else {
+ /* don't do anything, since pre-scan of args
+ will have got it already */
+ }
+ return TRUE;
+
case 'D' : /* hack */
{
extern void setRtsFlags( int x );
default : if (strcmp("98",s)==0) {
if (heapBuilt() && ((state && !haskell98) ||
(!state && haskell98))) {
- FPrintf(stderr,"Haskell 98 compatibility cannot be changed while the interpreter is running\n");
+ FPrintf(stderr,
+ "Haskell 98 compatibility cannot be changed"
+ " while the interpreter is running\n");
} else {
haskell98 = state;
}
#if USE_REGISTRY
FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
#else
- FPrintf(stderr,"Cannot change heap size\n");
+ FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
#endif
} else {
heapSize = hpSize;
{":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
{":quit", QUIT}, {":set", SET}, {":find", FIND},
{":names", NAMES}, {":info", INFO}, {":project", PROJECT},
-#if !IGNORE_MODULES
+ {":dump", DUMP}, {":ztats", STATS},
{":module",SETMODULE},
+ {":browse", BROWSE},
+#if EXPLAIN_INSTANCE_RESOLUTION
+ {":xplain", XPLAIN},
#endif
+ {":version", PNTVER},
{"", EVAL},
{0,0}
};
Printf(":project <filename> use project file\n");
Printf(":edit <filename> edit file\n");
Printf(":edit edit last module\n");
-#if !IGNORE_MODULES
Printf(":module <module> set module for evaluating expressions\n");
-#endif
Printf("<expr> evaluate expression\n");
Printf(":type <expr> print type of expression\n");
Printf(":? display this list of commands\n");
Printf(":set help on command line options\n");
Printf(":names [pat] list names currently in scope\n");
Printf(":info <names> describe named objects\n");
+ Printf(":browse <modules> browse names defined in <modules>\n");
+#if EXPLAIN_INSTANCE_RESOLUTION
+ Printf(":xplain <context> explain instance resolution for <context>\n");
+#endif
Printf(":find <name> edit module containing definition of name\n");
Printf(":!command shell escape\n");
Printf(":cd dir change directory\n");
Printf(":gc force garbage collection\n");
+ Printf(":version print Hugs version\n");
+ Printf(":dump <name> print STG code for named fn\n");
+#ifdef CRUDE_PROFILING
+ Printf(":ztats <name> print reduction stats\n");
+#endif
Printf(":quit exit Hugs interpreter\n");
}
* ------------------------------------------------------------------------*/
struct options toggle[] = { /* List of command line toggles */
- {'s', "Print no. reductions/cells after eval", &showStats},
- {'t', "Print type after evaluation", &addType},
- /*ToDo?? {'f', "Terminate evaluation on first error", &failOnError},*/
- {'g', "Print no. cells recovered after gc", &gcMessages},
- {'l', "Literate modules as default", &literateScripts},
- {'e', "Warn about errors in literate modules", &literateErrors},
- {'.', "Print dots to show progress", &useDots},
- {'q', "Print nothing to show progress", &quiet},
- {'w', "Always show which modules are loaded", &listScripts},
- {'k', "Show kind errors in full", &kindExpert},
- {'o', "Allow overlapping instances", &allowOverlap},
- {'i', "Chase imports while loading modules", &chaseImports},
+ {'s', 1, "Print no. reductions/cells after eval", &showStats},
+ {'t', 1, "Print type after evaluation", &addType},
+ {'g', 1, "Print no. cells recovered after gc", &gcMessages},
+ {'l', 1, "Literate modules as default", &literateScripts},
+ {'e', 1, "Warn about errors in literate modules", &literateErrors},
+ {'.', 1, "Print dots to show progress", &useDots},
+ {'q', 1, "Print nothing to show progress", &quiet},
+ {'w', 1, "Always show which modules are loaded", &listScripts},
+ {'k', 1, "Show kind errors in full", &kindExpert},
+ {'o', 0, "Allow overlapping instances", &allowOverlap},
+
+
#if DEBUG_CODE
- {'D', "Debug: show generated code", &debugCode},
+ {'D', 1, "Debug: show generated code", &debugCode},
#endif
- {0, 0, 0}
+#if EXPLAIN_INSTANCE_RESOLUTION
+ {'x', 1, "Explain instance resolution", &showInstRes},
+#endif
+#if MULTI_INST
+ {'m', 0, "Use multi instance resolution", &multiInstRes},
+#endif
+#if DEBUG_CODE
+ {'D', 1, "Debug: show generated G code", &debugCode},
+#endif
+ {'S', 1, "Debug: show generated SC code", &debugSC},
+ {0, 0, 0, 0}
};
static Void local set() { /* change command line options from*/
scriptFile = currProject;
forgetScriptsFrom(1);
while ((s=readFilename())!=0)
- addScriptName(s,TRUE);
+ addStackEntry(s);
if (namesUpto<=1) {
ERRMSG(0) "Empty project file"
EEND;
#endif
}
-static Void local addScriptName(s,sch) /* Add script to list of scripts */
-String s; /* to be read in ... */
-Bool sch; { /* TRUE => requires pathname search*/
+
+
+static Void local makeStackEntry ( ScriptInfo* ent, String iname )
+{
+ Bool ok, fromObj;
+ Bool sAvail, iAvail, oAvail;
+ Time sTime, iTime, oTime;
+ Long sSize, iSize, oSize;
+ String path, sExt;
+
+ ok = findFilesForModule (
+ iname,
+ &path,
+ &sExt,
+ &sAvail, &sTime, &sSize,
+ &iAvail, &iTime, &iSize,
+ &oAvail, &oTime, &oSize
+ );
+ if (!ok) {
+ ERRMSG(0)
+ "Can't find source or object+interface for module \"%s\"",
+ /* "Can't find source for module \"%s\"", */
+ iname
+ EEND;
+ }
+ /* findFilesForModule should enforce this */
+ if (!(sAvail || (oAvail && iAvail)))
+ internal("chase");
+ /* Load objects in preference to sources if both are available */
+ /* 11 Oct 99: disable object loading in the interim.
+ Will probably only reinstate when HEP becomes available.
+ */
+ if (combined) {
+ fromObj = sAvail
+ ? (oAvail && iAvail && timeEarlier(sTime,oTime))
+ : TRUE;
+ } else {
+ fromObj = FALSE;
+ }
+
+ /* ToDo: namesUpto overflow */
+ ent->modName = strCopy(iname);
+ ent->details = TRUE;
+ ent->path = path;
+ ent->fromSource = !fromObj;
+ ent->srcExt = sExt;
+ ent->postponed = FALSE;
+ ent->lastChange = sTime; /* ToDo: is this right? */
+ ent->size = fromObj ? iSize : sSize;
+ ent->oSize = fromObj ? oSize : 0;
+ ent->objLoaded = FALSE;
+}
+
+
+
+static Void nukeEnding( String s )
+{
+ Int l = strlen(s);
+ if (l > 4 && strncmp(s+l-4,".u_o" ,4)==0) s[l-4] = 0; else
+ if (l > 5 && strncmp(s+l-5,".u_hi",5)==0) s[l-5] = 0; else
+ if (l > 3 && strncmp(s+l-3,".hs" ,3)==0) s[l-3] = 0; else
+ if (l > 4 && strncmp(s+l-4,".lhs" ,4)==0) s[l-4] = 0; else
+ if (l > 4 && strncmp(s+l-4,".dll" ,4)==0) s[l-4] = 0; else
+ if (l > 4 && strncmp(s+l-4,".DLL" ,4)==0) s[l-4] = 0;
+}
+
+static Void local addStackEntry(s) /* Add script to list of scripts */
+String s; { /* to be read in ... */
+ String s2;
+ Bool found;
+ Int i;
+
if (namesUpto>=NUM_SCRIPTS) {
ERRMSG(0) "Too many module files (maximum of %d allowed)",
NUM_SCRIPTS
EEND;
}
- else
- scriptName[namesUpto++] = strCopy(sch ? findPathname(NULL,s) : s);
+
+ s = strCopy(s);
+ nukeEnding(s);
+ for (s2 = s; *s2; s2++)
+ if (*s2 == SLASH && *(s2+1)) s = s2+1;
+
+ found = FALSE;
+ for (i = 0; i < namesUpto; i++)
+ if (strcmp(scriptInfo[i].modName,s)==0)
+ found = TRUE;
+
+ if (!found) {
+ makeStackEntry ( &scriptInfo[namesUpto], strCopy(s) );
+ namesUpto++;
+ }
+ free(s);
}
-static Bool local addScript(fname,len) /* read single script file */
-String fname; /* name of script file */
-Long len; { /* length of script file */
- scriptFile = fname;
+/* Return TRUE if no imports were needed; FALSE otherwise. */
+static Bool local addScript(stacknum) /* read single file */
+Int stacknum; {
+ Bool didPrelude;
+ static char name[FILENAME_MAX+1];
+ Int len = scriptInfo[stacknum].size;
#if HUGS_FOR_WINDOWS /* Set clock cursor while loading */
allowBreak();
SetCursor(LoadCursor(NULL, IDC_WAIT));
#endif
- Printf("Reading file \"%s\":\n",fname);
- setLastEdit(fname,0);
+ // setLastEdit(name,0);
+
+ strcpy(name, scriptInfo[stacknum].path);
+ strcat(name, scriptInfo[stacknum].modName);
+ if (scriptInfo[stacknum].fromSource)
+ strcat(name, scriptInfo[stacknum].srcExt); else
+ strcat(name, ".u_hi");
+
+ scriptFile = name;
+
+ if (scriptInfo[stacknum].fromSource) {
+ if (lastWasObject) {
+ didPrelude = processInterfaces();
+ if (didPrelude) {
+ preludeLoaded = TRUE;
+ everybody(POSTPREL);
+ }
+ }
+ lastWasObject = FALSE;
+ Printf("Reading script \"%s\":\n",name);
+ needsImports = FALSE;
+ parseScript(name,len);
+ if (needsImports) return FALSE;
+ checkDefns();
+ typeCheckDefns();
+ compileDefns();
+ } else {
+ Cell iface;
+ List imports;
+ ZTriple iface_info;
+ char nameObj[FILENAME_MAX+1];
+ Int sizeObj;
+
+ Printf("Reading iface \"%s\":\n", name);
+ scriptFile = name;
+ needsImports = FALSE;
+
+ // set nameObj for the benefit of openGHCIface
+ strcpy(nameObj, scriptInfo[stacknum].path);
+ strcat(nameObj, scriptInfo[stacknum].modName);
+ strcat(nameObj, DLL_ENDING);
+ sizeObj = scriptInfo[stacknum].oSize;
+
+ iface = readInterface(name,len);
+ imports = zsnd(iface); iface = zfst(iface);
+
+ if (nonNull(imports)) chase(imports);
+ scriptFile = 0;
+ lastWasObject = TRUE;
+
+ iface_info = ztriple(iface, findText(nameObj), mkInt(sizeObj) );
+ ifaces_outstanding = cons(iface_info,ifaces_outstanding);
+
+ if (needsImports) return FALSE;
+ }
+
+ scriptFile = 0;
-#if 0
-ToDo: reinstate
- if (isInterfaceFile(fname)) {
- loadInterface(fname);
- } else
-#else
- {
- needsImports = FALSE;
- parseScript(fname,len); /* process script file */
- if (needsImports)
- return FALSE;
- checkDefns();
- typeCheckDefns();
- compileDefns();
- }
-#endif
- scriptFile = 0;
- preludeLoaded = TRUE;
- return TRUE;
+ return TRUE;
}
+
Bool chase(imps) /* Process list of import requests */
List imps; {
- if (chaseImports) {
- Int origPos = numScripts; /* keep track of original position */
- String origName = scriptName[origPos];
- for (; nonNull(imps); imps=tl(imps)) {
- String iname = findPathname(origName,textToStr(textOf(hd(imps))));
- Int i = 0;
- for (; i<namesUpto; i++)
- if (pathCmp(scriptName[i],iname)==0)
- break;
- if (i>=origPos) { /* Neither loaded or queued */
- String theName;
- Time theTime;
- Bool thePost;
-
- postponed[origPos] = TRUE;
- needsImports = TRUE;
-
- if (i>=namesUpto) /* Name not found (i==namesUpto) */
- addScriptName(iname,FALSE);
- else if (postponed[i]) {/* Check for recursive dependency */
- ERRMSG(0)
- "Recursive import dependency between \"%s\" and \"%s\"",
- scriptName[origPos], iname
- EEND;
- }
- /* Right rotate section of tables between numScripts and i so
- * that i ends up with other imports in front of orig. script
- */
- theName = scriptName[i];
- thePost = postponed[i];
- timeSet(theTime,lastChange[i]);
- for (; i>numScripts; i--) {
- scriptName[i] = scriptName[i-1];
- postponed[i] = postponed[i-1];
- timeSet(lastChange[i],lastChange[i-1]);
- }
- scriptName[numScripts] = theName;
- postponed[numScripts] = thePost;
- timeSet(lastChange[numScripts],theTime);
- origPos++;
+ Int dstPosn;
+ ScriptInfo tmp;
+ Int origPos = numScripts; /* keep track of original position */
+ String origName = scriptInfo[origPos].modName;
+ for (; nonNull(imps); imps=tl(imps)) {
+ String iname = textToStr(textOf(hd(imps)));
+ Int i = 0;
+ for (; i<namesUpto; i++)
+ if (strcmp(scriptInfo[i].modName,iname)==0)
+ break;
+ //fprintf(stderr, "import name = %s num = %d\n", iname, i );
+
+ if (i<namesUpto) {
+ /* We should have filled in the details of each module
+ the first time we hear about it.
+ */
+ assert(scriptInfo[i].details);
+ }
+
+ if (i>=origPos) { /* Neither loaded or queued */
+ String theName;
+ Time theTime;
+ Bool thePost;
+ Bool theFS;
+
+ needsImports = TRUE;
+ if (scriptInfo[origPos].fromSource)
+ scriptInfo[origPos].postponed = TRUE;
+
+ if (i==namesUpto) { /* Name not found (i==namesUpto) */
+ /* Find out where it lives, whether source or object, etc */
+ makeStackEntry ( &scriptInfo[i], iname );
+ namesUpto++;
+ }
+ else
+ if (scriptInfo[i].postponed && scriptInfo[i].fromSource) {
+ /* Check for recursive dependency */
+ ERRMSG(0)
+ "Recursive import dependency between \"%s\" and \"%s\"",
+ scriptInfo[origPos].modName, iname
+ EEND;
}
+ /* Move stack entry i to somewhere below origPos. If i denotes
+ * an object, destination is immediately below origPos.
+ * Otherwise, it's underneath the queue of objects below origPos.
+ */
+ dstPosn = origPos-1;
+ if (scriptInfo[i].fromSource)
+ while (!scriptInfo[dstPosn].fromSource && dstPosn > 0)
+ dstPosn--;
+
+ dstPosn++;
+ tmp = scriptInfo[i];
+ for (; i > dstPosn; i--) scriptInfo[i] = scriptInfo[i-1];
+ scriptInfo[dstPosn] = tmp;
+ if (dstPosn < nextNumScripts) nextNumScripts = dstPosn;
+ origPos++;
}
- return needsImports;
}
- return FALSE;
+ return needsImports;
}
static Void local forgetScriptsFrom(scno)/* remove scripts from system */
Script scno; {
Script i;
+#if 0
for (i=scno; i<namesUpto; ++i)
if (scriptName[i])
free(scriptName[i]);
+#endif
dropScriptsFrom(scno-1);
namesUpto = scno;
if (numScripts>namesUpto)
String s; /* and add to list of scripts waiting */
/* to be read */
while ((s=readFilename())!=0)
- addScriptName(s,TRUE);
+ addStackEntry(s);
readScripts(1);
}
Int n; { /* loading everything after and */
Time timeStamp; /* including the first script which*/
Long fileSize; /* has been either changed or added*/
+ static char name[FILENAME_MAX+1];
+ Bool didPrelude;
+ lastWasObject = FALSE;
+ ppSmStack("readscripts-begin");
#if HUGS_FOR_WINDOWS
SetCursor(LoadCursor(NULL, IDC_WAIT));
#endif
+#if 0
for (; n<numScripts; n++) { /* Scan previously loaded scripts */
+ ppSmStack("readscripts-loop1");
getFileInfo(scriptName[n], &timeStamp, &fileSize);
if (timeChanged(timeStamp,lastChange[n])) {
dropScriptsFrom(n-1);
}
for (; n<NUM_SCRIPTS; n++) /* No scripts have been postponed */
postponed[n] = FALSE; /* at this stage */
+ numScripts = 0;
while (numScripts<namesUpto) { /* Process any remaining scripts */
+ ppSmStack("readscripts-loop2");
getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
timeSet(lastChange[numScripts],timeStamp);
if (numScripts>0) /* no new script for prelude */
else
dropScriptsFrom(numScripts-1);
}
+#endif
+
+ interface(RESET);
+
+ for (; n<numScripts; n++) {
+ ppSmStack("readscripts-loop2");
+ strcpy(name, scriptInfo[n].path);
+ strcat(name, scriptInfo[n].modName);
+ if (scriptInfo[n].fromSource)
+ strcat(name, scriptInfo[n].srcExt); else
+ strcat(name, ".u_hi"); //ToDo: should be .o
+ getFileInfo(name,&timeStamp, &fileSize);
+ if (timeChanged(timeStamp,scriptInfo[n].lastChange)) {
+ dropScriptsFrom(n-1);
+ numScripts = n;
+ break;
+ }
+ }
+ for (; n<NUM_SCRIPTS; n++)
+ scriptInfo[n].postponed = FALSE;
+
+ //numScripts = 0;
+
+ while (numScripts < namesUpto) {
+ ppSmStack ( "readscripts-loop2" );
+
+ if (scriptInfo[numScripts].fromSource) {
+
+ if (numScripts>0)
+ startNewScript(scriptInfo[numScripts].modName);
+ nextNumScripts = NUM_SCRIPTS; //bogus initialisation
+ if (addScript(numScripts)) {
+ numScripts++;
+ assert(nextNumScripts==NUM_SCRIPTS);
+ }
+ else
+ dropScriptsFrom(numScripts-1);
+
+ } else {
+
+ if (scriptInfo[numScripts].objLoaded) {
+ numScripts++;
+ } else {
+ scriptInfo[numScripts].objLoaded = TRUE;
+ /* new */
+ if (numScripts>0)
+ startNewScript(scriptInfo[numScripts].modName);
+ /* end */
+ nextNumScripts = NUM_SCRIPTS;
+ if (addScript(numScripts)) {
+ numScripts++;
+ assert(nextNumScripts==NUM_SCRIPTS);
+ } else {
+ //while (!scriptInfo[numScripts].fromSource && numScripts > 0)
+ // numScripts--;
+ //if (scriptInfo[numScripts].fromSource)
+ // numScripts++;
+ numScripts = nextNumScripts;
+ assert(nextNumScripts<NUM_SCRIPTS);
+ }
+ }
+ }
+ if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
+ }
+
+ didPrelude = processInterfaces();
+ if (didPrelude) {
+ preludeLoaded = TRUE;
+ everybody(POSTPREL);
+ }
+
+
+ { Int m = namesUpto-1;
+ Text mtext = findText(scriptInfo[m].modName);
+
+ /* Hack to avoid starting up in PrelHugs */
+ if (mtext == findText("PrelHugs")) mtext = findText("Prelude");
+
+
+ /* Commented out till we understand what
+ * this is trying to do.
+ * Problem, you cant find a module till later.
+ */
+#if 0
+ setCurrModule(findModule(mtext));
+#endif
+ evalModule = mtext;
+ }
+
+
if (listScripts)
whatScripts();
if (numScripts<=1)
setLastEdit((String)0, 0);
+ ppSmStack("readscripts-end ");
}
static Void local whatScripts() { /* list scripts in current session */
if (projectLoaded)
Printf(" (project: %s)",currProject);
for (i=0; i<numScripts; ++i)
- Printf("\n%s",scriptName[i]);
+ Printf("\n%s%s",scriptInfo[i].path, scriptInfo[i].modName);
Putchar('\n');
}
}
static Void local find() { /* edit file containing definition */
+#if 0
+This just plain wont work no more.
+ToDo: Fix!
String nm = readFilename(); /* of specified name */
if (!nm) {
ERRMSG(0) "No name specified"
EEND;
}
}
+#endif
}
static Void local runEditor() { /* run editor on script lastEdit */
* Read and evaluate an expression:
* ------------------------------------------------------------------------*/
-#if !IGNORE_MODULES
static Void local setModule(){/*set module in which to evaluate expressions*/
String s = readFilename();
if (!s) s = ""; /* :m clears the current module selection */
m = lastModule();
return m;
}
-#endif
static Void local evaluator() { /* evaluate expr and print value */
Type type, bd;
checkExp();
defaultDefns = evalDefaults;
type = typeCheckExp(TRUE);
+
if (isPolyType(type)) {
ks = polySigOf(type);
bd = monotypeOf(type);
EEND;
}
-#if PROFILING
- if (profiling)
- profilerLog("profile.hp");
- numReductions = 0;
- garbageCollect();
-#endif
-
#ifdef WANT_TIMER
updateTimers();
#endif
#if 1
- if (typeMatches(type,ap(typeIO,typeUnit))) {
- inputExpr = ap(nameRunIO,inputExpr);
+ if (isProgType(ks,bd)) {
+ inputExpr = ap(nameRunIO_toplevel,inputExpr);
evalExp();
Putchar('\n');
} else {
ERRTEXT "\n"
EEND;
}
- //inputExpr = ap2(namePrint,d,inputExpr);
- //inputExpr = ap(nameRunIO,inputExpr);
-
- inputExpr = ap2(findName(findText("show")),d,inputExpr);
- inputExpr = ap(findName(findText("putStr")), inputExpr);
- inputExpr = ap(nameRunIO, inputExpr);
+ inputExpr = ap2(nameShow, d,inputExpr);
+ inputExpr = ap (namePutStr, inputExpr);
+ inputExpr = ap (nameRunIO_toplevel, inputExpr);
evalExp(); printf("\n");
if (addType) {
Putchar('\n');
}
}
-#endif
-#if 0
+#else
+
printf ( "result type is " );
printType ( stdout, type );
printf ( "\n" );
evalExp();
printf ( "\n" );
+
#endif
}
Putchar('\n');
if (showStats) {
#define plural(v) v, (v==1?"":"s")
- /* Printf("(%lu reduction%s, ",plural(numReductions)); */
Printf("%lu cell%s",plural(numCells));
if (numGcs>0)
Printf(", %u garbage collection%s",plural(numGcs));
Putchar('\n');
}
+
+static Void local browseit(mod,t,all)
+Module mod;
+String t;
+Bool all; {
+ if (nonNull(mod)) {
+ Cell cs;
+ if (nonNull(t))
+ Printf("module %s where\n",textToStr(module(mod).text));
+ for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
+ Name nm = hd(cs);
+ /* only look at things defined in this module,
+ unless `all' flag is set */
+ if (all || name(nm).mod == mod) {
+ /* unwanted artifacts, like lambda lifted values,
+ are in the list of names, but have no types */
+ if (nonNull(name(nm).type)) {
+ printExp(stdout,nm);
+ Printf(" :: ");
+ printType(stdout,name(nm).type);
+ if (isCfun(nm)) {
+ Printf(" -- data constructor");
+ } else if (isMfun(nm)) {
+ Printf(" -- class member");
+ } else if (isSfun(nm)) {
+ Printf(" -- selector function");
+ }
+ Printf("\n");
+ }
+ }
+ }
+ } else {
+ if (isNull(mod)) {
+ Printf("Unknown module %s\n",t);
+ }
+ }
+}
+
+static Void local browse() { /* browse modules */
+ Int count = 0; /* or give menu of commands */
+ String s;
+ Bool all = FALSE;
+
+ setCurrModule(findEvalModule());
+ startNewScript(0); /* for recovery of storage */
+ for (; (s=readFilename())!=0; count++)
+ if (strcmp(s,"all") == 0) {
+ all = TRUE;
+ --count;
+ } else
+ browseit(findModule(findText(s)),s,all);
+ if (count == 0) {
+ browseit(findEvalModule(),NULL,all);
+ }
+}
+
+#if EXPLAIN_INSTANCE_RESOLUTION
+static Void local xplain() { /* print type of expression (if any)*/
+ Cell d;
+ Bool sir = showInstRes;
+
+ setCurrModule(findEvalModule());
+ startNewScript(0); /* Enables recovery of storage */
+ /* allocated during evaluation */
+ parseContext();
+ checkContext();
+ showInstRes = TRUE;
+ d = provePred(NIL,NIL,hd(inputContext));
+ if (isNull(d)) {
+ fprintf(stdout, "not Sat\n");
+ } else {
+ fprintf(stdout, "Sat\n");
+ }
+ showInstRes = sir;
+}
+#endif
+
/* --------------------------------------------------------------------------
* Enhanced help system: print current list of scripts or give information
* about an object.
#endif
}
+extern Name nameHw;
+
+static Void local dumpStg( void ) { /* print STG stuff */
+ String s;
+ Text t;
+ Name n;
+ Int i;
+ Cell v; /* really StgVar */
+ setCurrModule(findEvalModule());
+ startNewScript(0);
+ for (; (s=readFilename())!=0;) {
+ t = findText(s);
+ v = n = NIL;
+ /* find the name while ignoring module scopes */
+ for (i=NAMEMIN; i<nameHw; i++)
+ if (name(i).text == t) n = i;
+
+ /* perhaps it's an "idNNNNNN" thing? */
+ if (isNull(n) &&
+ strlen(s) >= 3 &&
+ s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
+ v = 0;
+ i = 2;
+ while (isdigit(s[i])) {
+ v = v * 10 + (s[i]-'0');
+ i++;
+ }
+ v = -v;
+ n = nameFromStgVar(v);
+ }
+
+ if (isNull(n) && whatIs(v)==STGVAR) {
+ Printf ( "\n{- `%s' has no nametable entry -}\n", s );
+ printStg(stderr, v );
+ } else
+ if (isNull(n)) {
+ Printf ( "Unknown reference `%s'\n", s );
+ } else
+ if (!isName(n)) {
+ Printf ( "Not a Name: `%s'\n", s );
+ } else
+ if (isNull(name(n).stgVar)) {
+ Printf ( "Doesn't have a STG tree: %s\n", s );
+ } else {
+ Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
+ printStg(stderr, name(n).stgVar);
+ }
+ }
+}
+
static Void local info() { /* describe objects */
Int count = 0; /* or give menu of commands */
String s;
}
}
+
static Void local describe(t) /* describe an object */
Text t; {
Tycon tc = findTycon(t);
Class cl = findClass(t);
Name nm = findName(t);
- //Module mod = findEvalModule();
if (nonNull(tc)) { /* as a type constructor */
Type t = tc;
Printf(" => ");
}
printPred(stdout,cclass(cl).head);
+
+ if (nonNull(cclass(cl).fds)) {
+ List fds = cclass(cl).fds;
+ String pre = " | ";
+ for (; nonNull(fds); fds=tl(fds)) {
+ Printf(pre);
+ printFD(stdout,hd(fds));
+ pre = ", ";
+ }
+ }
+
if (nonNull(cclass(cl).members)) {
List ms = cclass(cl).members;
Printf(" where");
do {
- Type t = monotypeOf(name(hd(ms)).type);
+ Type t = name(hd(ms)).type;
+ if (isPolyType(t)) {
+ t = monotypeOf(t);
+ }
Printf("\n ");
printExp(stdout,hd(ms));
Printf(" :: ");
} else {
Printf("<unknown type>");
}
-
+printf("\n");print(name(nm).type,10);printf("\n");
if (isCfun(nm)) {
Printf(" -- data constructor");
} else if (isMfun(nm)) {
} else if (isSfun(nm)) {
Printf(" -- selector function");
}
-#if 0
- ToDo: reinstate
- if (name(nm).primDef) {
- Printf(" -- primitive");
- }
-#endif
Printf("\n\n");
}
+
if (isNull(tc) && isNull(cl) && isNull(nm)) {
Printf("Unknown reference `%s'\n",textToStr(t));
}
internal("Combined prompt and evaluation module name too long");
}
#endif
- consoleInput(promptBuffer);
+ if (autoMain)
+ stringInput("main\0"); else
+ consoleInput(promptBuffer);
}
/* --------------------------------------------------------------------------
String argv[]; {
Int errorNumber = setjmp(catch_error);
+ if (errorNumber && autoMain) {
+ fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" );
+ exit(1);
+ }
+
breakOn(TRUE); /* enable break trapping */
if (numScripts==0) { /* only succeeds on first time, */
if (errorNumber) /* before prelude has been loaded */
forHelp();
}
+ /* initialize calls startupHaskell, which trashes our signal handlers */
+ breakOn(TRUE);
+
for (;;) {
Command cmd;
everybody(RESET); /* reset to sensible initial state */
break;
case PROJECT: project();
break;
-#if !IGNORE_MODULES
case SETMODULE :
setModule();
break;
-#endif
case EVAL : evaluator();
break;
case TYPEOF : showtype();
break;
+ case BROWSE : browse();
+ break;
+#if EXPLAIN_INSTANCE_RESOLUTION
+ case XPLAIN : xplain();
+ break;
+#endif
case NAMES : listNames();
break;
case HELP : menu();
break;
case SET : set();
break;
+ case STATS:
+#ifdef CRUDE_PROFILING
+ cp_show();
+#endif
+ break;
case SYSTEM : if (shellEsc(readLine()))
Printf("Warning: Shell escape terminated abnormally\n");
break;
break;
case INFO : info();
break;
+ case PNTVER: Printf("-- Hugs Version %s\n",
+ HUGS_VERSION);
+ break;
+ case DUMP : dumpStg();
+ break;
case QUIT : return;
case COLLECT: consGC = FALSE;
garbageCollect();
Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
millisecs(userElapsed), millisecs(systElapsed));
#endif
+ if (autoMain) break;
}
breakOn(FALSE);
}
Void setGoal(what, t) /* Set goal for what to be t */
String what;
Target t; {
- if (quiet) return;
+ if (quiet)
+ return;
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes)
+ return;
+#endif
currTarget = (t?t:1);
aiming = TRUE;
if (useDots) {
Void soFar(t) /* Indicate progress towards goal */
Target t; { /* has now reached t */
- if (quiet) return;
+ if (quiet)
+ return;
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes)
+ return;
+#endif
if (useDots) {
Int newPos = (Int)((maxPos * ((long)t))/currTarget);
}
Void done() { /* Goal has now been achieved */
- if (quiet) return;
+ if (quiet)
+ return;
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes)
+ return;
+#endif
if (useDots) {
while (maxPos>currPos++)
Putchar('.');
/* ----------------------------------------------------------------------- */
-#define BufferSize 5000 /* size of redirected output buffer */
+#define BufferSize 10000 /* size of redirected output buffer */
typedef struct _HugsStream {
char buffer[BufferSize]; /* buffer for redirected output */
Void everybody(what) /* send command `what' to each component of*/
Int what; { /* system to respond as appropriate ... */
+#if 0
+ fprintf ( stderr, "EVERYBODY %d\n", what );
+#endif
machdep(what); /* The order of calling each component is */
- storage(what); /* important for the INSTALL command */
+ storage(what); /* important for the PREPREL command */
substitution(what);
input(what);
translateControl(what);
#if HUGS_FOR_WINDOWS
#include "winhugs.c"
#endif
-
-/*-------------------------------------------------------------------------*/
-
projects / ghc-hetmet.git / blobdiff