-/* -*- mode: hugs-c; -*- */
+
/* --------------------------------------------------------------------------
* Command interpreter
*
- * 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: hugs.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:09 $
+ * $Revision: 1.31 $
+ * $Date: 2000/01/05 18:05:33 $
* ------------------------------------------------------------------------*/
+#include <setjmp.h>
+#include <ctype.h>
+#include <stdio.h>
+
#include "prelude.h"
-#include "version.h"
#include "storage.h"
#include "command.h"
+#include "backend.h"
#include "connect.h"
-#include "charset.h"
-#include "input.h"
-#include "type.h"
-#include "subst.h" /* for typeMatches */
-#include "link.h" /* for classShow, nameRunIO and namePrint */
-#include "static.h"
-#include "compiler.h"
-#include "interface.h"
-#include "hugs.h"
#include "errors.h"
-#include <setjmp.h>
-#include <ctype.h>
+#include "version.h"
+#include "link.h"
-#include <stdio.h>
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "Schedule.h"
+#include "Assembler.h" /* DEBUG_LoadSymbols */
-#include "machdep.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 whatScripts Args((Void));
static Void local editor Args((Void));
static Void local find Args((Void));
+static Bool local startEdit Args((Int,String));
static Void local runEditor Args((Void));
static Void local setModule Args((Void));
static Module local findEvalModule Args((Void));
static Void local evaluator Args((Void));
+static Void local stopAnyPrinting Args((Void));
static Void local showtype Args((Void));
+static String local objToStr Args((Module, Cell));
static Void local info Args((Void));
+static Void local printSyntax Args((Name));
static Void local showInst Args((Inst));
static Void local describe Args((Text));
static Void local listNames 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"
#endif
* Local data areas:
* ------------------------------------------------------------------------*/
-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 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 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 Int scriptBase; /* Number of scripts in Prelude */
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 lastLine = 0; /* Editor line number (if possible)*/
+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 */
+ String hugsEdit = 0; /* String for editor command */
+ String hugsPath = 0; /* String for file search path */
+
+ 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:
* ------------------------------------------------------------------------*/
Main main(argc,argv)
int argc;
char *argv[]; {
-
#ifdef HAVE_CONSOLE_H /* Macintosh port */
_ftype = 'TEXT';
_fcreator = 'R*ch'; /* // 'KAHL'; //'*TEX'; //'ttxt'; */
CStackBase = &argc; /* Save stack base for use in gc */
- /* The startup banner now includes my name. Hugs is provided free of */
- /* charge. I ask however that you show your appreciation for the many */
- /* hours of work involved by retaining my name in the banner. Thanks! */
+ /* 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 SMALL_BANNER
- Printf("Hugs 1.4, %s release.\n", HUGS_VERSION);
- Printf("Copyright (c) The University of Nottingham and Yale University, 1994-1998.\n");
- Printf("Home page: http://haskell.org/hugs. Bug reports: hugs-bugs@haskell.org.\n");
-#else
-#ifdef OLD_LOGO
- Printf(" ___ ___ ___ ___ __________ __________ \n");
- Printf(" / / / / / / / / / _______/ / _______/ Hugs 1.4 \n");
- Printf(" / /___/ / / / / / / / _____ / /______ \n");
- Printf(" / ____ / / / / / / / /_ / /______ / The Nottingham and Yale\n");
- Printf(" / / / / / /___/ / / /___/ / _______/ / Haskell User's System \n");
- Printf(" /__/ /__/ /_________/ /_________/ /_________/ %s\n\n", HUGS_VERSION);
- Printf("Copyright (c) The University of Nottingham and Yale University, 1994-1998.\n");
- Printf("Home page: http://haskell.org/hugs. Bug reports: hugs-bugs@haskell.org.\n");
-#else
- /* There is now a new banner, designed to draw attention to the fact */
- /* that the version of Hugs being used is substantially different from */
- /* previous releases (and to correct the mistaken view that Hugs is */
- /* written in capitals). If you really prefer the old style banner, */
- /* you can still get it by compiling with -DOLD_LOGO. */
-
- printf(" __ __ __ __ ____ ___ __________________________________________\n");
- printf(" || || || || || || ||__ Hugs 1.4: The Haskell User's Gofer System\n");
- printf(" ||___|| ||__|| ||__|| __|| (c) The University of Nottingham\n");
- printf(" ||---|| ___|| and Yale University, 1994-1998.\n");
- printf(" || || Report bugs to hugs-bugs@haskell.org\n");
- printf(" || || "HUGS_VERSION" __________________________________________\n\n");
-#endif
-#endif
#if SYMANTEC_C
Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
#endif
interpreter(argc,argv);
Printf("[Leaving Hugs]\n");
everybody(EXIT);
+ shutdownHaskell();
FlushStdout();
fflush(stderr);
exit(0);
Int argc;
String argv[]; {
Script i;
- String proj = 0;
+ String proj = 0;
+ char argv_0_orig[1000];
setLastEdit((String)0,0);
lastEdit = 0;
scriptFile = 0;
numScripts = 0;
namesUpto = 1;
- initCharTab();
#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
hugsPath = strCopy(HUGSPATH);
readOptions("-p\"%s> \" -r$$");
#if USE_REGISTRY
- readOptions(readRegString("Options",""));
-#endif
- readOptions(fromEnv("HUGSFLAGS",""));
+ projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
+ "HUGSPATH", PATHSEP, ""));
+ readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
+ readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
+#endif /* USE_REGISTRY */
+ readOptions(fromEnv("STGHUGSFLAGS",""));
+
+ strncpy(argv_0_orig,argv[0],1000); /* startupHaskell mangles argv[0] */
+ startupHaskell (argc,argv);
+ argc = prog_argc; argv = prog_argv;
+
+ namesUpto = numScripts = 0;
- for (i=1; i<argc; ++i) { /* process command line arguments */
+ /* 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");
+
+ 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 {
proj = argv[++i];
}
- } else if (!processOption(argv[i])) {
- addScriptName(argv[i],TRUE);
+ } else if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
+ && !processOption(argv[i])) {
+ addStackEntry(argv[i]);
}
}
- /* ToDo: clean up this hack */
+
+#if DEBUG
{
- static char* my_argv[] = {"Hugs"};
- startupHaskell(sizeof(my_argv)/sizeof(char*),my_argv);
+ char exe_name[N_INSTALLDIR + 6];
+ strcpy(exe_name, installDir);
+ strcat(exe_name, "hugs");
+ DEBUG_LoadSymbols(exe_name);
}
-#ifdef DEBUG
- DEBUG_LoadSymbols(argv[0]);
#endif
- scriptName[0] = strCopy(findMPathname(NULL,STD_PRELUDE));
+
+#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");
+ } 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("Standalone mode: Restart with command line +c for combined mode\n\n" );
+ }
+
+ everybody(PREPREL);
- everybody(INSTALL);
evalModule = findText(""); /* evaluate wrt last module by default */
if (proj) {
if (namesUpto>1) {
loadProject(strCopy(proj));
}
readScripts(0);
- scriptBase = numScripts;
}
/* --------------------------------------------------------------------------
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(fmts,"rstr","Set repeat last expression string to str");
Printf(fmts,"Pstr","Set search path for modules to str");
Printf(fmts,"Estr","Use editor setting given by str");
+ Printf(fmts,"cnum","Set constraint cutoff limit");
#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
Printf(fmts,"Fstr","Set preprocessor filter to str");
#endif
printString(prompt);
Printf(" -r");
printString(repeatStr);
+ Printf(" -c%d",cutoff);
Printf("\nSearch path : -P");
printString(hugsPath);
+#if 0
+ToDo
+ if (projectPath!=NULL) {
+ Printf("\nProject Path : %s",projectPath);
+ }
+#endif
Printf("\nEditor setting : -E");
printString(hugsEdit);
#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
Printf("\nPreprocessor : -F");
printString(preprocessor);
#endif
+ 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);
PUTStr('P',hugsPath);
PUTStr('E',hugsEdit);
+ PUTInt('c',cutoff); PUTC(' ');
#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
PUTStr('F',preprocessor);
#endif
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 'd' : /* hack */
+ 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 );
setRtsFlags(argToInt(s+1));
return TRUE;
}
- default : toggleSet(*s,state);
+ 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");
+ } else {
+ haskell98 = state;
+ }
+ return TRUE;
+ } else {
+ toggleSet(*s,state);
+ }
break;
}
return TRUE;
#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;
Int n = 0;
String t = s;
- if (*s=='\0' || !isascii(*s) || !isdigit(*s)) {
+ if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
ERRMSG(0) "Missing integer in option setting \"%s\"", t
EEND;
}
EEND;
}
n = 10*n + d;
- } while (isascii(*s) && isdigit(*s));
+ } while (isascii((int)(*s)) && isdigit((int)(*s)));
if (*s=='K' || *s=='k') {
if (n > (MAXPOSINT/1000)) {
{":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
{":quit", QUIT}, {":set", SET}, {":find", FIND},
{":names", NAMES}, {":info", INFO}, {":project", PROJECT},
- {":module", SETMODULE},
- {":version", SHOWVERSION},
+ {":dump", DUMP}, {":ztats", STATS},
+ {":module",SETMODULE},
+ {":browse", BROWSE},
+#if EXPLAIN_INSTANCE_RESOLUTION
+ {":xplain", XPLAIN},
+#endif
+ {":version", PNTVER},
{"", EVAL},
{0,0}
};
Printf(":module <module> set module for evaluating expressions\n");
Printf("<expr> evaluate expression\n");
Printf(":type <expr> print type of expression\n");
- Printf(":version show Hugs version\n");
Printf(":? display this list of commands\n");
Printf(":set <options> set command line options\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");
}
* Setting of command line options:
* ------------------------------------------------------------------------*/
-struct options toggle[] = { /* List of command line toggles */
- {'t', "Print type after evaluation", &addType},
- {'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},
+struct options toggle[] = { /* List of command line toggles */
+ {'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
- {0, 0, 0}
+ {'S', 1, "Debug: show generated SC code", &debugSC},
+ {0, 0, 0, 0}
};
static Void local set() { /* change command line options from*/
currProject = s;
projInput(currProject);
scriptFile = currProject;
- forgetScriptsFrom(scriptBase);
+ 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; {
+ 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) processInterfaces();
+ 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 (isInterfaceFile(fname)) {
- loadInterface(fname);
- } else {
- needsImports = FALSE;
- parseScript(fname,len); /* process script file */
- if (needsImports)
- return FALSE;
- checkDefns();
- typeCheckDefns();
- compileDefns();
- }
- scriptFile = 0;
- return TRUE;
+ if (strcmp(scriptInfo[stacknum].modName, "Prelude")==0) {
+ preludeLoaded = TRUE;
+ everybody(POSTPREL);
+ }
+ 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]);
- dropScriptsFrom(scno);
+#endif
+ dropScriptsFrom(scno-1);
namesUpto = scno;
if (numScripts>namesUpto)
numScripts = scno;
String s; /* and add to list of scripts waiting */
/* to be read */
while ((s=readFilename())!=0)
- addScriptName(s,TRUE);
- readScripts(scriptBase);
+ addStackEntry(s);
+ readScripts(1);
}
static Void local project() { /* read list of script names from */
EEND;
}
loadProject(s);
- readScripts(scriptBase);
+ readScripts(1);
}
static Void local readScripts(n) /* Reread current list of scripts, */
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];
+ 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);
+ dropScriptsFrom(n-1);
numScripts = n;
break;
}
}
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);
- startNewScript(scriptName[numScripts]);
+ if (numScripts>0) /* no new script for prelude */
+ startNewScript(scriptName[numScripts]);
if (addScript(scriptName[numScripts],fileSize))
numScripts++;
else
- dropScriptsFrom(numScripts);
+ 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") ;
+ }
+
+ processInterfaces();
+
+ { Int m = namesUpto-1;
+ Text mtext = findText(scriptInfo[m].modName);
+ /* 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<=scriptBase)
+ 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"
startNewScript(0);
if (nonNull(c=findTycon(t=findText(nm)))) {
if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
- readScripts(scriptBase);
+ readScripts(1);
}
} else if (nonNull(c=findName(t))) {
if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
- readScripts(scriptBase);
+ readScripts(1);
}
} else {
ERRMSG(0) "No current definition for name \"%s\"", nm
EEND;
}
}
+#endif
}
static Void local runEditor() { /* run editor on script lastEdit */
- if (startEdit(lastLine,lastEdit)) /* at line lastLine */
- readScripts(scriptBase);
+ if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
+ readScripts(1);
}
static Void local setLastEdit(fname,line)/* keep name of last file to edit */
if (lastEdit)
free(lastEdit);
lastEdit = strCopy(fname);
- lastLine = line;
+ lastEdLine = line;
#if HUGS_FOR_WINDOWS
DrawStatusLine(hWndMain); /* Redo status line */
#endif
static Module local findEvalModule() { /*Module in which to eval expressions*/
Module m = findModule(evalModule);
- if (isNull(m)) {
+ if (isNull(m))
m = lastModule();
- }
return m;
}
static Void local evaluator() { /* evaluate expr and print value */
Type type, bd;
- Kinds ks = NIL;
+ Kinds ks = NIL;
setCurrModule(findEvalModule());
scriptFile = 0;
if (whatIs(bd)==QUAL) {
ERRMSG(0) "Unresolved overloading" ETHEN
- ERRTEXT "\n*** type : " ETHEN ERRTYPE(type);
- ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
+ ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
+ ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
ERRTEXT "\n"
EEND;
}
-
- /* ToDo: restore the code to print types, use show, etc */
-
+
#ifdef WANT_TIMER
updateTimers();
#endif
- if (typeMatches(type,ap(typeIO,typeUnit))) {
+
+#if 1
+ if (isProgType(ks,bd)) {
inputExpr = ap(nameRunIO,inputExpr);
evalExp();
Putchar('\n');
ERRTEXT "\n"
EEND;
}
- inputExpr = ap2(namePrint,d,inputExpr);
- inputExpr = ap(nameRunIO,inputExpr);
- evalExp();
+ inputExpr = ap2(findName(findText("show")),d,inputExpr);
+ inputExpr = ap(findName(findText("putStr")), inputExpr);
+ inputExpr = ap(nameRunIO, inputExpr);
+
+ evalExp(); printf("\n");
if (addType) {
printf(" :: ");
printType(stdout,type);
Putchar('\n');
}
}
+
+#else
+
+ printf ( "result type is " );
+ printType ( stdout, type );
+ printf ( "\n" );
+ evalExp();
+ printf ( "\n" );
+
+#endif
+
+}
+
+static Void local stopAnyPrinting() { /* terminate printing of expression,*/
+ if (printing) { /* after successful termination or */
+ printing = FALSE; /* runtime error (e.g. interrupt) */
+ Putchar('\n');
+ if (showStats) {
+#define plural(v) v, (v==1?"":"s")
+ Printf("%lu cell%s",plural(numCells));
+ if (numGcs>0)
+ Printf(", %u garbage collection%s",plural(numGcs));
+ Printf(")\n");
+#undef plural
+ }
+ FlushStdout();
+ garbageCollect();
+ }
}
/* --------------------------------------------------------------------------
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.
* ------------------------------------------------------------------------*/
-static String local objToStr Args((Module, Cell));
-
static String local objToStr(m,c)
Module m;
Cell c; {
-#if DISPLAY_QUANTIFIERS
+#if 1 || DISPLAY_QUANTIFIERS
static char newVar[60];
switch (whatIs(c)) {
- case NAME : if (m == name(c).mod) {
- sprintf(newVar,"%s", textToStr(name(c).text));
- } else {
- sprintf(newVar,"%s.%s",textToStr(module(name(c).mod).text),
- textToStr(name(c).text));
- }
- break;
- case TYCON : if (m == tycon(c).mod) {
- sprintf(newVar,"%s", textToStr(tycon(c).text));
- } else {
- sprintf(newVar,"%s.%s",textToStr(module(tycon(c).mod).text),
- textToStr(tycon(c).text));
- }
- break;
- case CLASS : if (m == cclass(c).mod) {
- sprintf(newVar,"%s", textToStr(cclass(c).text));
- } else {
- sprintf(newVar,"%s.%s",textToStr(module(cclass(c).mod).text),
- textToStr(cclass(c).text));
- }
- break;
- default : internal("objToStr");
+ case NAME : if (m == name(c).mod) {
+ sprintf(newVar,"%s", textToStr(name(c).text));
+ } else {
+ sprintf(newVar,"%s.%s",
+ textToStr(module(name(c).mod).text),
+ textToStr(name(c).text));
+ }
+ break;
+
+ case TYCON : if (m == tycon(c).mod) {
+ sprintf(newVar,"%s", textToStr(tycon(c).text));
+ } else {
+ sprintf(newVar,"%s.%s",
+ textToStr(module(tycon(c).mod).text),
+ textToStr(tycon(c).text));
+ }
+ break;
+
+ case CLASS : if (m == cclass(c).mod) {
+ sprintf(newVar,"%s", textToStr(cclass(c).text));
+ } else {
+ sprintf(newVar,"%s.%s",
+ textToStr(module(cclass(c).mod).text),
+ textToStr(cclass(c).text));
+ }
+ break;
+
+ default : internal("objToStr");
}
return newVar;
#else
static char newVar[33];
switch (whatIs(c)) {
- case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
- break;
- case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
- break;
- case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
- default : internal("objToStr");
+ case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
+ break;
+
+ case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
+ break;
+
+ case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
+ break;
+
+ default : internal("objToStr");
}
return newVar;
#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();
+ Tycon tc = findTycon(t);
+ Class cl = findClass(t);
+ Name nm = findName(t);
if (nonNull(tc)) { /* as a type constructor */
- Type ty = tc;
+ Type t = tc;
Int i;
Inst in;
for (i=0; i<tycon(tc).arity; ++i) {
- ty = ap(ty,mkOffset(i));
+ t = ap(t,mkOffset(i));
}
Printf("-- type constructor");
if (kindExpert) {
Putchar('\n');
switch (tycon(tc).what) {
case SYNONYM : Printf("type ");
- printType(stdout,ty);
+ printType(stdout,t);
Printf(" = ");
printType(stdout,tycon(tc).defn);
break;
} else {
Printf("newtype ");
}
- printType(stdout,ty);
+ printType(stdout,t);
+ Putchar('\n');
+ mapProc(printSyntax,cs);
if (hasCfun(cs)) {
- Printf("\n\n-- constructors:");
+ Printf("\n-- constructors:");
}
for (; hasCfun(cs); cs=tl(cs)) {
Putchar('\n');
printType(stdout,name(hd(cs)).type);
}
if (nonNull(cs)) {
- Printf("\n\n-- selectors:");
+ Printf("\n-- selectors:");
}
for (; nonNull(cs); cs=tl(cs)) {
Putchar('\n');
break;
case RESTRICTSYN : Printf("type ");
- printType(stdout,ty);
+ printType(stdout,t);
Printf(" = <restricted>");
break;
}
List ins = cclass(cl).instances;
Kinds ks = cclass(cl).kinds;
if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
- printf("-- type class");
+ Printf("-- type class");
} else {
- printf("-- constructor class");
+ Printf("-- constructor class");
if (kindExpert) {
- printf(" with arity ");
+ Printf(" with arity ");
printKinds(stdout,ks);
}
}
- printf("\nclass ");
+ Putchar('\n');
+ mapProc(printSyntax,cclass(cl).members);
+ Printf("class ");
if (nonNull(cclass(cl).supers)) {
printContext(stdout,cclass(cl).supers);
- printf(" => ");
+ 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");
+ Printf(" where");
do {
- Type t = monotypeOf(name(hd(ms)).type);
- printf("\n ");
+ Type t = name(hd(ms)).type;
+ if (isPolyType(t)) {
+ t = monotypeOf(t);
+ }
+ Printf("\n ");
printExp(stdout,hd(ms));
- printf(" :: ");
+ Printf(" :: ");
if (isNull(tl(fst(snd(t))))) {
t = snd(snd(t));
} else {
ms = tl(ms);
} while (nonNull(ms));
}
- putchar('\n');
+ Putchar('\n');
if (nonNull(ins)) {
- printf("\n-- instances:\n");
+ Printf("\n-- instances:\n");
do {
showInst(hd(ins));
ins = tl(ins);
} while (nonNull(ins));
}
- putchar('\n');
+ Putchar('\n');
}
if (nonNull(nm)) { /* as a function/name */
+ printSyntax(nm);
printExp(stdout,nm);
- printf(" :: ");
+ Printf(" :: ");
if (nonNull(name(nm).type)) {
printType(stdout,name(nm).type);
} else {
- printf("<unknown type>");
+ Printf("<unknown type>");
}
-
+printf("\n");print(name(nm).type,10);printf("\n");
if (isCfun(nm)) {
- printf(" -- data constructor");
+ Printf(" -- data constructor");
} else if (isMfun(nm)) {
- printf(" -- class member");
+ Printf(" -- class member");
} else if (isSfun(nm)) {
- printf(" -- selector function");
- }
- if (name(nm).primop) {
- printf(" -- primitive");
+ Printf(" -- selector function");
}
- printf("\n\n");
+ Printf("\n\n");
}
+
if (isNull(tc) && isNull(cl) && isNull(nm)) {
Printf("Unknown reference `%s'\n",textToStr(t));
}
}
+static Void local printSyntax(nm)
+Name nm; {
+ Syntax sy = syntaxOf(nm);
+ Text t = name(nm).text;
+ String s = textToStr(t);
+ if (sy != defaultSyntax(t)) {
+ Printf("infix");
+ switch (assocOf(sy)) {
+ case LEFT_ASS : Putchar('l'); break;
+ case RIGHT_ASS : Putchar('r'); break;
+ case NON_ASS : break;
+ }
+ Printf(" %i ",precOf(sy));
+ if (isascii((int)(*s)) && isalpha((int)(*s))) {
+ Printf("`%s`",s);
+ } else {
+ Printf("%s",s);
+ }
+ Putchar('\n');
+ }
+}
+
static Void local showInst(in) /* Display instance decl header */
Inst in; {
- printf("instance ");
+ Printf("instance ");
if (nonNull(inst(in).specifics)) {
printContext(stdout,inst(in).specifics);
- printf(" => ");
+ Printf(" => ");
}
printPred(stdout,inst(in).head);
- putchar('\n');
+ Putchar('\n');
}
/* --------------------------------------------------------------------------
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 */
- dropScriptsFrom(numScripts); /* remove partially loaded scripts */
+ dropScriptsFrom(numScripts-1); /* remove partially loaded scripts */
+ /* not counting prelude as a script*/
promptForInput(textToStr(module(findEvalModule()).text));
case FIND : find();
break;
case LOAD : clearProject();
- forgetScriptsFrom(scriptBase);
+ forgetScriptsFrom(1);
load();
break;
case ALSO : clearProject();
forgetScriptsFrom(numScripts);
load();
break;
- case RELOAD : readScripts(scriptBase);
+ case RELOAD : readScripts(1);
break;
case PROJECT: project();
break;
case SETMODULE :
setModule();
break;
- case SHOWVERSION :
- Printf("Hugs 1.4, %s release.\n", HUGS_VERSION);
- break;
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 SYSTEM : if (shellEsc(readLine()))
+ case STATS:
+#ifdef CRUDE_PROFILING
+ cp_show();
+#endif
+ break;
+ case SYSTEM : if (shellEsc(readLine()))
Printf("Warning: Shell escape terminated abnormally\n");
break;
case CHGDIR : changeDir();
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('.');
Void errHead(l) /* print start of error message */
Int l; {
failed(); /* failed to reach target ... */
+ stopAnyPrinting();
FPrintf(errorStream,"ERROR");
if (scriptFile) {
Void errAbort() { /* altern. form of error handling */
failed(); /* used when suitable error message*/
- errFail(); /* has already been printed */
+ stopAnyPrinting(); /* has already been printed */
+ errFail();
}
Void internal(msg) /* handle internal error */
MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
#endif
failed();
+ stopAnyPrinting();
Printf("INTERNAL ERROR: %s\n",msg);
FlushStdout();
longjmp(catch_error,1);
Hilite();
Printf("{Interrupted!}\n");
Lolite();
- breakOn(TRUE);
+ breakOn(TRUE); /* reinstall signal handler - redundant on BSD systems */
+ /* but essential on POSIX (and other?) systems */
everybody(BREAK);
failed();
+ stopAnyPrinting();
FlushStdout();
clearerr(stdin);
longjmp(catch_error,1);
/* ----------------------------------------------------------------------- */
-#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 */
/* ----------------------------------------------------------------------- */
-static HugsStream outputStream;
+static HugsStream outputStreamH;
/* ADR note:
- * We rely on standard C semantics to initialise outputStream.next to 0.
+ * We rely on standard C semantics to initialise outputStreamH.next to 0.
*/
Void hugsEnableOutput(f)
}
String hugsClearOutputBuffer() {
- return bufferClear(&outputStream);
+ return bufferClear(&outputStreamH);
}
#ifdef HAVE_STDARG_H
if (!disableOutput) {
vprintf(fmt, ap);
} else {
- vBufferedPrintf(&outputStream, fmt, ap);
+ vBufferedPrintf(&outputStreamH, fmt, ap);
}
va_end(ap); /* clean up */
}
if (!disableOutput) {
vprintf(fmt, ap);
} else {
- vBufferedPrintf(&outputStream, fmt, ap);
+ vBufferedPrintf(&outputStreamH, fmt, ap);
}
va_end(ap); /* clean up */
}
if (!disableOutput) {
putchar(c);
} else {
- bufferedPutchar(&outputStream, c);
+ bufferedPutchar(&outputStreamH, c);
}
}
if (!disableOutput) {
vfprintf(fp, fmt, ap);
} else {
- vBufferedPrintf(&outputStream, fmt, ap);
+ vBufferedPrintf(&outputStreamH, fmt, ap);
}
va_end(ap);
}
if (!disableOutput) {
vfprintf(fp, fmt, ap);
} else {
- vBufferedPrintf(&outputStream, fmt, ap);
+ vBufferedPrintf(&outputStreamH, fmt, ap);
}
va_end(ap);
}
if (!disableOutput) {
putc(c,fp);
} else {
- bufferedPutchar(&outputStream, c);
+ bufferedPutchar(&outputStreamH, c);
}
}
#endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
+/* --------------------------------------------------------------------------
+ * Send message to each component of system:
+ * ------------------------------------------------------------------------*/
+
+Void everybody(what) /* send command `what' to each component of*/
+Int what; { /* system to respond as appropriate ... */
+fprintf ( stderr, "EVERYBODY %d\n", what );
+ machdep(what); /* The order of calling each component is */
+ storage(what); /* important for the PREPREL command */
+ substitution(what);
+ input(what);
+ translateControl(what);
+ linkControl(what);
+ staticAnalysis(what);
+ deriveControl(what);
+ typeChecker(what);
+ compiler(what);
+ codegen(what);
+}
/* --------------------------------------------------------------------------
* Hugs for Windows code (WinMain and related functions)
#if HUGS_FOR_WINDOWS
#include "winhugs.c"
#endif
-
-/*-------------------------------------------------------------------------*/
-
projects / ghc-hetmet.git / blobdiff