/* --------------------------------------------------------------------------
* 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.8 $
- * $Date: 1999/07/06 15:24:37 $
+ * $Revision: 1.24 $
+ * $Date: 1999/11/25 10:19:16 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
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 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:
static Bool quiet = FALSE; /* TRUE => don't show progress */
static Bool lastWasObject = FALSE;
Bool preludeLoaded = FALSE;
- Bool optimise = FALSE;
typedef
struct {
scriptInfo[i].path
);
}
- // printf ( "\n" );
fflush(stdout);fflush(stderr);
-ppScripts();
-ppModules();
+ ppScripts();
+ ppModules();
printf ( "\n" );
}
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;
- hugsEnableOutput(0);
+ if (strcmp(argv[1],"-Q") == 0) {
+ hugsEnableOutput(0);
+ }
}
- 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);
+ 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");
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, ""));
startupHaskell (argc,argv);
argc = prog_argc; argv = prog_argv;
- namesUpto = numScripts = 0;
- addStackEntry("Prelude");
+ namesUpto = numScripts = 0;
+ addStackEntry("Prelude");
for (i=1; i<argc; ++i) { /* process command line arguments */
if (strcmp(argv[i], "--")==0) break;
}
}
-#ifdef DEBUG
- DEBUG_LoadSymbols(argv_0_orig);
+#if DEBUG
+ {
+ char exe_name[N_INSTALLDIR + 6];
+ strcpy(exe_name, installDir);
+ strcat(exe_name, "hugs");
+ DEBUG_LoadSymbols(exe_name);
+ }
#endif
-
#if 0
if (!scriptName[0]) {
Printf("Prelude not found on current path: \"%s\"\n",
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)");
Printf("\nPreprocessor : -F");
printString(preprocessor);
#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);
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;
}
{":names", NAMES}, {":info", INFO}, {":project", PROJECT},
{":dump", DUMP}, {":ztats", STATS},
{":module",SETMODULE},
+ {":browse", BROWSE},
+#if EXPLAIN_INSTANCE_RESOLUTION
+ {":xplain", XPLAIN},
+#endif
+ {":version", PNTVER},
{"", EVAL},
{0,0}
};
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");
* ------------------------------------------------------------------------*/
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},
- {'O', "Optimise (improve?) generated code", &optimise},
+ {'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', 1, "Debug: show generated code", &debugCode},
+#endif
+#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', "Debug: show generated code", &debugCode},
+ {'D', 1, "Debug: show generated G code", &debugCode},
+#endif
+#if DEBUG_SHOWSC
+ {'S', 1, "Debug: show generated SC code", &debugSC},
#endif
- {0, 0, 0}
+#if 0
+ {'f', 1, "Terminate evaluation on first error", &failOnError},
+ {'u', 1, "Use \"show\" to display results", &useShow},
+ {'i', 1, "Chase imports while loading modules", &chaseImports},
+#endif
+ {0, 0, 0, 0}
};
static Void local set() { /* change command line options from*/
);
if (!ok) {
ERRMSG(0)
- "Can't file source or object+interface for module \"%s\"",
+ /* "Can't file source or object+interface for module \"%s\"", */
+ "Can't file source for module \"%s\"",
iname
EEND;
}
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.
fromObj = sAvail
? (oAvail && iAvail && timeEarlier(sTime,oTime))
: TRUE;
+ */
+ fromObj = FALSE;
+
/* ToDo: namesUpto overflow */
ent->modName = strCopy(iname);
ent->details = TRUE;
{ Int m = namesUpto-1;
Text mtext = findText(scriptInfo[m].modName);
- setCurrModule(mtext);
+ /* 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 (projectLoaded)
Printf(" (project: %s)",currProject);
for (i=0; i<numScripts; ++i)
- Printf("\n%s",scriptInfo[i].modName);
+ Printf("\n%s%s",scriptInfo[i].path, scriptInfo[i].modName);
Putchar('\n');
}
#endif
#if 1
- if (typeMatches(type,ap(typeIO,typeUnit))) {
+ if (isProgType(ks,bd)) {
inputExpr = ap(nameRunIO,inputExpr);
evalExp();
Putchar('\n');
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.
if (isNull(n) && whatIs(v)==STGVAR) {
Printf ( "\n{- `%s' has no nametable entry -}\n", s );
- Printf ( "{- stgSize of body is %d -}\n\n", stgSize(stgVarBody(v)));
printStg(stderr, v );
} else
if (isNull(n)) {
Printf ( "Doesn't have a STG tree: %s\n", s );
} else {
Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
- Printf ( "{- stgSize of body is %d -}\n\n",
- stgSize(stgVarBody(name(n).stgVar)));
printStg(stderr, name(n).stgVar);
}
}
Tycon tc = findTycon(t);
Class cl = findClass(t);
Name nm = findName(t);
- Module mod = findModule(t);
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(" :: ");
Printf("\n\n");
}
- if (nonNull(mod)) { /* as a module */
- List t;
- Printf("-- module\n");
-
- Printf("\n-- values\n");
- for (t=module(mod).names; nonNull(t); t=tl(t)) {
- Name nm = hd(t);
- Printf ( "%s ", textToStr(name(nm).text));
- }
-
- Printf("\n\n-- type constructors\n");
- for (t=module(mod).tycons; nonNull(t); t=tl(t)) {
- Tycon tc = hd(t);
- Printf ( "%s ", textToStr(tycon(tc).text));
- }
-
- Printf("\n\n-- classes\n");
- for (t=module(mod).classes; nonNull(t); t=tl(t)) {
- Class cl = hd(t);
- Printf ( "%s ", textToStr(cclass(cl).text));
- }
- Printf("\n\n");
- }
-
- if (isNull(tc) && isNull(cl) && isNull(nm) && isNull(mod)) {
+ if (isNull(tc) && isNull(cl) && isNull(nm)) {
Printf("Unknown reference `%s'\n",textToStr(t));
}
}
forHelp();
}
+ /* initialize calls startupHaskell, which trashes our signal handlers */
+ breakOn(TRUE);
+
for (;;) {
Command cmd;
everybody(RESET); /* reset to sensible initial state */
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 INFO : info();
break;
+ case PNTVER: Printf("-- Hugs Version %s\n",
+ HUGS_VERSION);
+ break;
case DUMP : dumpStg();
break;
case QUIT : return;
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 */
typeChecker(what);
compiler(what);
codegen(what);
- optimiser(what);
}
/* --------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff