/* --------------------------------------------------------------------------
* 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.4 $
- * $Date: 1999/03/01 14:46:45 $
+ * $Revision: 1.67 $
+ * $Date: 2000/04/17 11:39:23 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
#include <ctype.h>
#include <stdio.h>
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
-#include "command.h"
-#include "backend.h"
#include "connect.h"
#include "errors.h"
#include "version.h"
-#include "link.h"
#include "Rts.h"
#include "RtsAPI.h"
#include "Schedule.h"
-
+#include "Assembler.h" /* DEBUG_LoadSymbols */
Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
+Bool initDone = FALSE;
+
+#if EXPLAIN_INSTANCE_RESOLUTION
+Bool showInstRes = FALSE;
+#endif
+#if MULTI_INST
+Bool multiInstRes = FALSE;
+#endif
/* --------------------------------------------------------------------------
* Local function prototypes:
* ------------------------------------------------------------------------*/
-static Void local initialize Args((Int,String []));
-static Void local promptForInput Args((String));
-static Void local interpreter Args((Int,String []));
-static Void local menu Args((Void));
-static Void local guidance Args((Void));
-static Void local forHelp Args((Void));
-static Void local set Args((Void));
-static Void local changeDir Args((Void));
-static Void local load Args((Void));
-static Void local project Args((Void));
-static Void local readScripts Args((Int));
-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));
-#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 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 toggleSet Args((Char,Bool));
-static Void local togglesIn Args((Bool));
-static Void local optionInfo Args((Void));
-#if USE_REGISTRY || HUGS_FOR_WINDOWS
-static String local optionsToStr Args((Void));
-#endif
-static Void local readOptions Args((String));
-static Bool local processOption Args((String));
-static Void local setHeapSize Args((String));
-static Int local argToInt Args((String));
-
-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 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 List local initialize ( Int,String [] );
+static Void local promptForInput ( String );
+static Void local interpreter ( Int,String [] );
+static Void local menu ( Void );
+static Void local guidance ( Void );
+static Void local forHelp ( Void );
+static Void local set ( Void );
+static Void local changeDir ( Void );
+static Void local load ( Void );
+static Void local project ( Void );
+static Void local editor ( Void );
+static Void local find ( Void );
+static Bool local startEdit ( Int,String );
+static Void local runEditor ( Void );
+static Void local setModule ( Void );
+static Void local evaluator ( Void );
+static Void local stopAnyPrinting ( Void );
+static Void local showtype ( Void );
+static String local objToStr ( Module, Cell );
+static Void local info ( Void );
+static Void local printSyntax ( Name );
+static Void local showInst ( Inst );
+static Void local describe ( Text );
+static Void local listNames ( Void );
+
+static Void local toggleSet ( Char,Bool );
+static Void local togglesIn ( Bool );
+static Void local optionInfo ( Void );
+static Void local readOptions ( String );
+static Bool local processOption ( String );
+static Void local setHeapSize ( String );
+static Int local argToInt ( String );
+
+static Void local setLastEdit ( String,Int );
+static Void local failed ( Void );
+static String local strCopy ( String );
+static Void local browseit ( Module,String,Bool );
+static Void local browse ( Void );
+static void local clearCurrentFile ( void );
+
/* --------------------------------------------------------------------------
* Machine dependent code for Hugs interpreter:
* ------------------------------------------------------------------------*/
#include "machdep.c"
-#ifdef WANT_TIMER
-#include "timer.c"
-#endif
/* --------------------------------------------------------------------------
* 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 Int scriptBase; /* Number of scripts in Prelude */
-static Int numScripts; /* Number of scripts loaded */
-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 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 flagAssert = FALSE; /* TRUE => assert False <e> causes
+ an assertion failure */
+ Bool preludeLoaded = FALSE;
+ Bool debugSC = FALSE;
+ Bool combined = FALSE;
+
+ Module moduleBeingParsed; /* so the parser (topModule) knows */
+static char* currentFile; /* Name of current file, or NULL */
+static char currentFileName[1000]; /* name is stored here if it exists*/
+
+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 */
+static Bool disableOutput = FALSE; /* TRUE => quiet */
+ String hugsEdit = 0; /* String for editor command */
+ String hugsPath = 0; /* String for file search path */
+
+ List ifaces_outstanding = NIL;
+
+static ConId currentModule_failed = NIL; /* Remember failed module from :r */
+
-#if REDIRECT_OUTPUT
-static Bool disableOutput = FALSE; /* redirect output to buffer? */
-#endif
/* --------------------------------------------------------------------------
* Hugs entry point:
#ifndef NO_MAIN /* we omit main when building the "Hugs server" */
-Main main Args((Int, String [])); /* now every func has a prototype */
+Main main ( Int, String [] ); /* now every func has a prototype */
Main main(argc,argv)
int argc;
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);
+#ifdef DEBUG
+#if 0
+ checkBytecodeCount(); /* check for too many bytecodes */
+#endif
+#endif
+
+ /* 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) {
+ EnableOutput(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");
* Initialization, interpret command line args and read prelude:
* ------------------------------------------------------------------------*/
-static Void local initialize(argc,argv)/* Interpreter initialization */
-Int argc;
-String argv[]; {
- Script i;
- String proj = 0;
-
- setLastEdit((String)0,0);
- lastEdit = 0;
- scriptFile = 0;
- numScripts = 0;
- namesUpto = 1;
-
-#if HUGS_FOR_WINDOWS
- 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$$");
-#if USE_REGISTRY
- 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("HUGSFLAGS",""));
-
- startupHaskell ( argc, argv );
- argc = prog_argc; argv = prog_argv;
-
- for (i=1; i<argc; ++i) { /* process command line arguments */
- if (strcmp(argv[i],"+")==0 && i+1<argc) {
- if (proj) {
- ERRMSG(0) "Multiple project filenames on command line"
- EEND;
- } else {
- proj = argv[++i];
- }
- } else if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
- && !processOption(argv[i])) {
- addScriptName(argv[i],TRUE);
- }
- }
-
-#ifdef DEBUG
- DEBUG_LoadSymbols(argv[0]);
-#endif
+static List /*CONID*/ initialize ( Int argc, String argv[] )
+{
+ Int i, j;
+ List initialModules;
- scriptName[0] = strCopy(findMPathname(NULL,STD_PRELUDE,hugsPath));
- if (!scriptName[0]) {
- Printf("Prelude not found on current path: \"%s\"\n",
- hugsPath ? hugsPath : "");
- fatal("Unable to load prelude");
- }
+ setLastEdit((String)0,0);
+ lastEdit = 0;
+ currentFile = NULL;
- if (haskell98) {
- Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n\n");
- } else {
- Printf("Hugs mode: Restart with command line option +98 for Haskell 98 mode\n\n");
- }
-
- everybody(INSTALL);
- evalModule = findText(""); /* evaluate wrt last module by default */
- if (proj) {
- if (namesUpto>1) {
- fprintf(stderr,
- "\nUsing project file, ignoring additional filenames\n");
- }
- loadProject(strCopy(proj));
- }
- readScripts(0);
- scriptBase = numScripts;
+#if SYMANTEC_C
+ hugsEdit = "";
+#else
+ hugsEdit = strCopy(fromEnv("EDITOR",NULL));
+#endif
+ hugsPath = strCopy(HUGSPATH);
+ readOptions("-p\"%s> \" -r$$");
+ readOptions(fromEnv("STGHUGSFLAGS",""));
+
+# if DEBUG
+ {
+ char exe_name[N_INSTALLDIR + 6];
+ strcpy(exe_name, installDir);
+ strcat(exe_name, "hugs");
+ DEBUG_LoadSymbols(exe_name);
+ }
+# endif
+
+ /* startupHaskell extracts args between +RTS ... -RTS, and sets
+ prog_argc/prog_argv to the rest. We want to further process
+ the rest, so we then get hold of them again.
+ */
+ startupHaskell ( argc, argv, NULL );
+ getProgArgv ( &argc, &argv );
+
+ /* Find out early on if we're in combined mode or not.
+ everybody(PREPREL) needs to know this. Also, establish the
+ heap size;
+ */
+ 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;
+
+ if (strncmp(argv[i],"+h",2)==0 || strncmp(argv[i],"-h",2)==0)
+ setHeapSize(&(argv[i][2]));
+ }
+
+ everybody(PREPREL);
+ initialModules = NIL;
+
+ for (i = 1; i < argc; ++i) { /* process command line arguments */
+ if (strcmp(argv[i], "--")==0)
+ { argv[i] = NULL; break; }
+ if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/) {
+ if (!processOption(argv[i]))
+ initialModules
+ = cons ( mkCon(findText(argv[i])), initialModules );
+ argv[i] = NULL;
+ }
+ }
+
+ 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" );
+ }
+
+ /* slide args back over the deleted ones. */
+ j = 1;
+ for (i = 1; i < argc; i++)
+ if (argv[i])
+ argv[j++] = argv[i];
+
+ argc = j;
+
+ setProgArgv ( argc, argv );
+
+ initDone = TRUE;
+ return initialModules;
}
/* --------------------------------------------------------------------------
struct options { /* command line option toggles */
char c; /* table defined in main app. */
+ int h98;
String description;
Bool *flag;
};
*toggle[i].flag = state;
return;
}
+ clearCurrentFile();
ERRMSG(0) "Unknown toggle `%c'", c
- EEND;
+ EEND_NO_LONGJMP;
}
static Void local togglesIn(state) /* Print current list of toggles in*/
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');
}
-#if USE_REGISTRY || HUGS_FOR_WINDOWS
-#define PUTC(c) \
- *next++=(c)
-
-#define PUTS(s) \
- strcpy(next,s); \
- next+=strlen(next)
-
-#define PUTInt(optc,i) \
- sprintf(next,"-%c%d",optc,i); \
- next+=strlen(next)
-
-#define PUTStr(c,s) \
- next=PUTStr_aux(next,c,s)
-
-static String local PUTStr_aux Args((String,Char, String));
-
-static String local PUTStr_aux(next,c,s)
-String next;
-Char c;
-String s; {
- if (s) {
- String t = 0;
- sprintf(next,"-%c\"",c);
- next+=strlen(next);
- for(t=s; *t; ++t) {
- PUTS(unlexChar(*t,'"'));
- }
- next+=strlen(next);
- PUTS("\" ");
- }
- return next;
-}
-
-static String local optionsToStr() { /* convert options to string */
- static char buffer[2000];
- String next = buffer;
-
- Int i;
- for (i=0; toggle[i].c; ++i) {
- PUTC(*toggle[i].flag ? '+' : '-');
- PUTC(toggle[i].c);
- PUTC(' ');
- }
- 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
-#if PROFILING
- PUTInt('d',profiling ? profInterval : 0);
-#endif
- PUTC('\0');
- return buffer;
-}
-#endif /* USE_REGISTRY */
-
#undef PUTC
#undef PUTS
#undef PUTInt
while (*++s)
switch (*s) {
+ case 'Q' : break; /* already handled */
+
case 'p' : if (s[1]) {
if (prompt) free(prompt);
prompt = strCopy(s+1);
return TRUE;
#endif
- case 'h' : setHeapSize(s+1);
+ case 'h' : /* don't do anything, since pre-scan of args
+ will have got it already */
+ return TRUE;
+
+ case 'c' : /* don't do anything, since pre-scan of args
+ will have got it already */
return TRUE;
- case 'd' : /* hack */
+ case 'D' : /* hack */
{
extern void setRtsFlags( int x );
setRtsFlags(argToInt(s+1));
}
default : if (strcmp("98",s)==0) {
- if (heapBuilt() && ((state && !haskell98) ||
+ if (initDone && ((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;
}
hpSize = MINIMUMHEAP;
else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
hpSize = MAXIMUMHEAP;
- if (heapBuilt() && hpSize != heapSize) {
+ if (initDone && hpSize != heapSize) {
/* ToDo: should this use a message box in winhugs? */
-#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");
-#endif
+ FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
} 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},
-#if DEBUG_CODE
- {'D', "Debug: show generated code", &debugCode},
+ {'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},
+ {'S', 1, "Debug: show generated SC code", &debugSC},
+ {'a', 1, "Raise exception on assert failure", &flagAssert},
+#if EXPLAIN_INSTANCE_RESOLUTION
+ {'x', 1, "Explain instance resolution", &showInstRes},
+#endif
+#if MULTI_INST
+ {'m', 0, "Use multi instance resolution", &multiInstRes},
#endif
- {0, 0, 0}
+ {0, 0, 0, 0}
};
static Void local set() { /* change command line options from*/
do {
if (!processOption(s)) {
ERRMSG(0) "Option string must begin with `+' or `-'"
- EEND;
+ EEND_NO_LONGJMP;
}
} while ((s=readFilename())!=0);
-#if USE_REGISTRY
- writeRegString("Options", optionsToStr());
-#endif
}
else
optionInfo();
String s = readFilename();
if (s && chdir(s)) {
ERRMSG(0) "Unable to change to directory \"%s\"", s
- EEND;
+ EEND_NO_LONGJMP;
}
}
+
/* --------------------------------------------------------------------------
- * Loading project and script files:
+ * Interrupt handling
* ------------------------------------------------------------------------*/
-static Void local loadProject(s) /* Load project file */
-String s; {
- clearProject();
- currProject = s;
- projInput(currProject);
- scriptFile = currProject;
- forgetScriptsFrom(scriptBase);
- while ((s=readFilename())!=0)
- addScriptName(s,TRUE);
- if (namesUpto<=1) {
- ERRMSG(0) "Empty project file"
- EEND;
- }
- scriptFile = 0;
- projectLoaded = TRUE;
-}
+static jmp_buf catch_error; /* jump buffer for error trapping */
-static Void local clearProject() { /* clear name for current project */
- if (currProject)
- free(currProject);
- currProject = 0;
- projectLoaded = FALSE;
-#if HUGS_FOR_WINDOWS
- setLastEdit((String)0,0);
-#endif
-}
+HugsBreakAction currentBreakAction = HugsIgnoreBreak;
-static Void local addScriptName(s,sch) /* Add script to list of scripts */
-String s; /* to be read in ... */
-Bool sch; { /* TRUE => requires pathname search*/
- 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);
+static void handler_IgnoreBreak ( int sig )
+{
+ setHandler ( handler_IgnoreBreak );
}
-static Bool local addScript(fname,len) /* read single script file */
-String fname; /* name of script file */
-Long len; { /* length of script file */
- scriptFile = fname;
-
-#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);
-
-#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;
- return TRUE;
+static void handler_LongjmpOnBreak ( int sig )
+{
+ setHandler ( handler_LongjmpOnBreak );
+ Printf("{Interrupted!}\n");
+ longjmp(catch_error,1);
}
-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++;
- }
- }
- return needsImports;
- }
- return FALSE;
+static void handler_RtsInterrupt ( int sig )
+{
+ setHandler ( handler_RtsInterrupt );
+ interruptStgRts();
}
-static Void local forgetScriptsFrom(scno)/* remove scripts from system */
-Script scno; {
- Script i;
- for (i=scno; i<namesUpto; ++i)
- if (scriptName[i])
- free(scriptName[i]);
- dropScriptsFrom(scno);
- namesUpto = scno;
- if (numScripts>namesUpto)
- numScripts = scno;
+HugsBreakAction setBreakAction ( HugsBreakAction newAction )
+{
+ HugsBreakAction tmp = currentBreakAction;
+ currentBreakAction = newAction;
+ switch (newAction) {
+ case HugsIgnoreBreak:
+ setHandler ( handler_IgnoreBreak ); break;
+ case HugsLongjmpOnBreak:
+ setHandler ( handler_LongjmpOnBreak ); break;
+ case HugsRtsInterrupt:
+ setHandler ( handler_RtsInterrupt ); break;
+ default:
+ internal("setBreakAction");
+ }
+ return tmp;
}
+
/* --------------------------------------------------------------------------
- * Commands for loading and removing script files:
+ * The new module chaser, loader, etc
* ------------------------------------------------------------------------*/
-static Void local load() { /* read filenames from command line */
- String s; /* and add to list of scripts waiting */
- /* to be read */
- while ((s=readFilename())!=0)
- addScriptName(s,TRUE);
- readScripts(scriptBase);
-}
-
-static Void local project() { /* read list of script names from */
- String s; /* project file */
-
- if ((s=readFilename()) || currProject) {
- if (!s)
- s = strCopy(currProject);
- else if (readFilename()) {
- ERRMSG(0) "Too many project files"
- EEND;
- }
- else
- s = strCopy(s);
- }
- else {
- ERRMSG(0) "No project filename specified"
- EEND;
- }
- loadProject(s);
- readScripts(scriptBase);
-}
-
-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*/
-
-#if HUGS_FOR_WINDOWS
- SetCursor(LoadCursor(NULL, IDC_WAIT));
-#endif
-
- for (; n<numScripts; n++) { /* Scan previously loaded scripts */
- getFileInfo(scriptName[n], &timeStamp, &fileSize);
- if (timeChanged(timeStamp,lastChange[n])) {
- dropScriptsFrom(n);
- numScripts = n;
+List moduleGraph = NIL;
+List prelModules = NIL;
+List targetModules = NIL;
+
+static String modeToString ( Cell mode )
+{
+ switch (mode) {
+ case FM_SOURCE: return "source";
+ case FM_OBJECT: return "object";
+ case FM_EITHER: return "source or object";
+ default: internal("modeToString");
+ }
+}
+
+static Cell childMode ( Cell modeMeRequest, Cell modeMeActual )
+{
+ assert(modeMeActual == FM_SOURCE ||
+ modeMeActual == FM_OBJECT);
+ assert(modeMeRequest == FM_SOURCE ||
+ modeMeRequest == FM_OBJECT ||
+ modeMeRequest == FM_EITHER);
+ if (modeMeRequest == FM_SOURCE) return modeMeRequest;
+ if (modeMeRequest == FM_OBJECT) return modeMeRequest;
+ if (modeMeActual == FM_OBJECT) return FM_OBJECT;
+ if (modeMeActual == FM_SOURCE) return FM_EITHER;
+ internal("childMode");
+}
+
+static Bool compatibleNewMode ( Cell modeNew, Cell modeExisting )
+{
+ if (modeNew == FM_OBJECT && modeExisting == FM_OBJECT) return TRUE;
+ if (modeNew == FM_SOURCE && modeExisting == FM_SOURCE) return TRUE;
+ if (modeNew == FM_EITHER && modeExisting == FM_OBJECT) return TRUE;
+ if (modeNew == FM_EITHER && modeExisting == FM_SOURCE) return TRUE;
+ return FALSE;
+}
+
+static void setCurrentFile ( Module mod )
+{
+ assert(isModule(mod));
+ strncpy(currentFileName, textToStr(module(mod).text), 990);
+ strcat(currentFileName, textToStr(module(mod).srcExt));
+ currentFile = currentFileName;
+ moduleBeingParsed = mod;
+}
+
+static void clearCurrentFile ( void )
+{
+ currentFile = NULL;
+ moduleBeingParsed = NIL;
+}
+
+static void ppMG ( void )
+{
+ List t,u,v;
+ for (t = moduleGraph; nonNull(t); t=tl(t)) {
+ u = hd(t);
+ switch (whatIs(u)) {
+ case GRP_NONREC:
+ FPrintf ( stderr, " %s\n", textToStr(textOf(snd(u))));
break;
- }
- }
- for (; n<NUM_SCRIPTS; n++) /* No scripts have been postponed */
- postponed[n] = FALSE; /* at this stage */
-
- while (numScripts<namesUpto) { /* Process any remaining scripts */
- getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
- timeSet(lastChange[numScripts],timeStamp);
- startNewScript(scriptName[numScripts]);
- if (addScript(scriptName[numScripts],fileSize))
- numScripts++;
- else
- dropScriptsFrom(numScripts);
- }
-
- if (listScripts)
- whatScripts();
- if (numScripts<=scriptBase)
- setLastEdit((String)0, 0);
+ case GRP_REC:
+ FPrintf ( stderr, " {" );
+ for (v = snd(u); nonNull(v); v=tl(v))
+ FPrintf ( stderr, "%s ", textToStr(textOf(hd(v))) );
+ FPrintf ( stderr, "}\n" );
+ break;
+ default:
+ internal("ppMG");
+ }
+ }
+}
+
+
+static Bool elemMG ( ConId mod )
+{
+ List gs;
+ for (gs = moduleGraph; nonNull(gs); gs=tl(gs))
+ switch (whatIs(hd(gs))) {
+ case GRP_NONREC:
+ if (textOf(mod)==textOf(snd(hd(gs)))) return TRUE;
+ break;
+ case GRP_REC:
+ if (varIsMember(textOf(mod),snd(hd(gs)))) return TRUE;
+ break;
+ default:
+ internal("elemMG");
+ }
+ return FALSE;
+}
+
+
+static ConId selectArbitrarilyFromGroup ( Cell group )
+{
+ switch (whatIs(group)) {
+ case GRP_NONREC: return snd(group);
+ case GRP_REC: return hd(snd(group));
+ default: internal("selectArbitrarilyFromGroup");
+ }
+}
+
+static ConId selectLatestMG ( void )
+{
+ List gs = moduleGraph;
+ if (isNull(gs)) internal("selectLatestMG(1)");
+ while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs);
+ return selectArbitrarilyFromGroup(hd(gs));
+}
+
+
+static List /* of CONID */ listFromSpecifiedMG ( List mg )
+{
+ List gs;
+ List cs = NIL;
+ for (gs = mg; nonNull(gs); gs=tl(gs)) {
+ switch (whatIs(hd(gs))) {
+ case GRP_REC: cs = appendOnto(cs,snd(hd(gs))); break;
+ case GRP_NONREC: cs = cons(snd(hd(gs)),cs); break;
+ default: internal("listFromSpecifiedMG");
+ }
+ }
+ return cs;
+}
+
+static List /* of CONID */ listFromMG ( void )
+{
+ return listFromSpecifiedMG ( moduleGraph );
+}
+
+
+/* Calculate the strongly connected components of modgList
+ and assign them to moduleGraph. Uses the .uses field of
+ each of the modules to build the graph structure.
+*/
+#define SCC modScc /* make scc algorithm for StgVars */
+#define LOWLINK modLowlink
+#define DEPENDS(t) snd(t)
+#define SETDEPENDS(c,v) snd(c)=v
+#include "scc.c"
+#undef SETDEPENDS
+#undef DEPENDS
+#undef LOWLINK
+#undef SCC
+
+static void mgFromList ( List /* of CONID */ modgList )
+{
+ List t;
+ List u;
+ Text mT;
+ List usesT;
+ List adjList; /* :: [ (Text, [Text]) ] */
+ Module mod;
+ List scc;
+ Bool isRec;
+
+ adjList = NIL;
+ for (t = modgList; nonNull(t); t=tl(t)) {
+ mT = textOf(hd(t));
+ mod = findModule(mT);
+ assert(nonNull(mod));
+ usesT = NIL;
+ for (u = module(mod).uses; nonNull(u); u=tl(u))
+ usesT = cons(textOf(hd(u)),usesT);
+
+ /* artificially give all modules a dependency on Prelude */
+ if (mT != textPrelude && mT != textPrelPrim)
+ usesT = cons(textPrelude,usesT);
+ adjList = cons(pair(mT,usesT),adjList);
+ }
+
+ /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
+ Modify this so that the adjacency list is a list of pointers
+ back to bits of adjList -- that's what modScc needs.
+ */
+ for (t = adjList; nonNull(t); t=tl(t)) {
+ List adj = NIL;
+ /* for each elem of the adjacency list ... */
+ for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
+ List v;
+ Text a = hd(u);
+ /* find the element of adjList whose fst is a */
+ for (v = adjList; nonNull(v); v=tl(v)) {
+ assert(isText(a));
+ assert(isText(fst(hd(v))));
+ if (fst(hd(v))==a) break;
+ }
+ if (isNull(v)) internal("mgFromList");
+ adj = cons(hd(v),adj);
+ }
+ snd(hd(t)) = adj;
+ }
+
+ adjList = modScc ( adjList );
+ /* adjList is now [ [(module-text, aux-info-field)] ] */
+
+ moduleGraph = NIL;
+
+ for (t = adjList; nonNull(t); t=tl(t)) {
+
+ scc = hd(t);
+ /* scc :: [ (module-text, aux-info-field) ] */
+ for (u = scc; nonNull(u); u=tl(u))
+ hd(u) = mkCon(fst(hd(u)));
+
+ /* scc :: [CONID] */
+ if (length(scc) > 1) {
+ isRec = TRUE;
+ } else {
+ /* singleton module in scc; does it import itself? */
+ mod = findModule ( textOf(hd(scc)) );
+ assert(nonNull(mod));
+ isRec = FALSE;
+ for (u = module(mod).uses; nonNull(u); u=tl(u))
+ if (textOf(hd(u))==textOf(hd(scc)))
+ isRec = TRUE;
+ }
+
+ if (isRec)
+ moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
+ moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
+ }
+ moduleGraph = reverse(moduleGraph);
+}
+
+
+static List /* of CONID */ getModuleImports ( Cell tree )
+{
+ Cell te;
+ List tes;
+ ConId use;
+ List uses = NIL;
+ for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
+ te = hd(tes);
+ switch(whatIs(te)) {
+ case M_IMPORT_Q:
+ use = zfst(unap(M_IMPORT_Q,te));
+ assert(isCon(use));
+ if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
+ break;
+ case M_IMPORT_UNQ:
+ use = zfst(unap(M_IMPORT_UNQ,te));
+ assert(isCon(use));
+ if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
+ break;
+ default:
+ break;
+ }
+ }
+ return uses;
+}
+
+
+static void processModule ( Module m )
+{
+ Cell tree;
+ ConId modNm;
+ List topEnts;
+ List tes;
+ Cell te;
+ Cell te2;
+
+ tyconDefns = NIL;
+ typeInDefns = NIL;
+ valDefns = NIL;
+ classDefns = NIL;
+ instDefns = NIL;
+ selDefns = NIL;
+ genDefns = NIL;
+ unqualImports = NIL;
+ foreignImports = NIL;
+ foreignExports = NIL;
+ defaultDefns = NIL;
+ defaultLine = 0;
+ inputExpr = NIL;
+
+ setCurrentFile(m);
+ startModule(m);
+ tree = unap(M_MODULE,module(m).tree);
+ modNm = zfst3(tree);
+
+ if (textOf(modNm) != module(m).text) {
+ ERRMSG(0) "Module name \"%s\" does not match file name \"%s%s\"",
+ textToStr(textOf(modNm)),
+ textToStr(module(m).text),
+ textToStr(module(m).srcExt)
+ EEND;
+ }
+
+ setExportList(zsnd3(tree));
+ topEnts = zthd3(tree);
+
+ for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
+ te = hd(tes);
+ assert(isGenPair(te));
+ te2 = snd(te);
+ switch(whatIs(te)) {
+ case M_IMPORT_Q:
+ addQualImport(zfst(te2),zsnd(te2));
+ break;
+ case M_IMPORT_UNQ:
+ addUnqualImport(zfst(te2),zsnd(te2));
+ break;
+ case M_TYCON:
+ tyconDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
+ break;
+ case M_CLASS:
+ classDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
+ break;
+ case M_INST:
+ instDefn(intOf(zfst3(te2)),zsnd3(te2),zthd3(te2));
+ break;
+ case M_DEFAULT:
+ defaultDefn(intOf(zfst(te2)),zsnd(te2));
+ break;
+ case M_FOREIGN_IM:
+ foreignImport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
+ zsel45(te2),zsel55(te2));
+ break;
+ case M_FOREIGN_EX:
+ foreignExport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
+ zsel45(te2),zsel55(te2));
+ case M_VALUE:
+ valDefns = cons(te2,valDefns);
+ break;
+ default:
+ internal("processModule");
+ }
+ }
+ checkDefns(m);
+ typeCheckDefns();
+ compileDefns();
+}
+
+
+static Module parseModuleOrInterface ( ConId mc, Cell modeRequest )
+{
+ /* Allocate a module-table entry. */
+ /* Parse the entity and fill in the .tree and .uses entries. */
+ String path;
+ String sExt;
+ Bool sAvail; Time sTime; Long sSize;
+ Bool oiAvail; Time oiTime; Long oSize; Long iSize;
+ Bool ok;
+ Bool useSource;
+ char name[10000];
+
+ Text mt = textOf(mc);
+ Module mod = findModule ( mt );
+
+ /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
+ textToStr(mt),mod); */
+ if (nonNull(mod) && !module(mod).fake)
+ internal("parseModuleOrInterface");
+ if (nonNull(mod))
+ module(mod).fake = FALSE;
+
+ if (isNull(mod))
+ mod = newModule(mt);
+
+ /* This call malloc-ates path; we should deallocate it. */
+ ok = findFilesForModule (
+ textToStr(module(mod).text),
+ &path,
+ &sExt,
+ &sAvail, &sTime, &sSize,
+ &oiAvail, &oiTime, &oSize, &iSize
+ );
+
+ if (!ok) goto cant_find;
+ if (!sAvail && !oiAvail) goto cant_find;
+
+ /* Find out whether to use source or object. */
+ switch (modeRequest) {
+ case FM_SOURCE:
+ if (!sAvail) goto cant_find;
+ useSource = TRUE;
+ break;
+ case FM_OBJECT:
+ if (!oiAvail) goto cant_find;
+ useSource = FALSE;
+ break;
+ case FM_EITHER:
+ if ( sAvail && !oiAvail) { useSource = TRUE; break; }
+ if (!sAvail && oiAvail) { useSource = FALSE; break; }
+ useSource = firstTimeIsLater ( sTime, oiTime ) ? TRUE : FALSE;
+ break;
+ default:
+ internal("parseModuleOrInterface");
+ }
+
+ /* Actually do the parsing. */
+ if (useSource) {
+ module(mod).srcExt = findText(sExt);
+ setCurrentFile(mod);
+ strcpy(name, path);
+ strcat(name, textToStr(mt));
+ strcat(name, sExt);
+ module(mod).tree = parseModule(name,sSize);
+ module(mod).uses = getModuleImports(module(mod).tree);
+ module(mod).mode = FM_SOURCE;
+ module(mod).lastStamp = sTime;
+ } else {
+ module(mod).srcExt = findText(HI_ENDING);
+ setCurrentFile(mod);
+ strcpy(name, path);
+ strcat(name, textToStr(mt));
+ strcat(name, DLL_ENDING);
+ module(mod).objName = findText(name);
+ module(mod).objSize = oSize;
+ strcpy(name, path);
+ strcat(name, textToStr(mt));
+ strcat(name, ".u_hi");
+ module(mod).tree = parseInterface(name,iSize);
+ module(mod).uses = getInterfaceImports(module(mod).tree);
+ module(mod).mode = FM_OBJECT;
+ module(mod).lastStamp = oiTime;
+ }
+
+ if (path) free(path);
+ return mod;
+
+ cant_find:
+ if (path) free(path);
+ clearCurrentFile();
+ ERRMSG(0)
+ "Can't find %s for module \"%s\"",
+ modeToString(modeRequest), textToStr(mt)
+ EEND;
+}
+
+
+static void tryLoadGroup ( Cell grp )
+{
+ Module m;
+ List t;
+ switch (whatIs(grp)) {
+ case GRP_NONREC:
+ m = findModule(textOf(snd(grp)));
+ assert(nonNull(m));
+ if (module(m).mode == FM_SOURCE) {
+ processModule ( m );
+ module(m).tree = NIL;
+ } else {
+ processInterfaces ( singleton(snd(grp)) );
+ m = findModule(textOf(snd(grp)));
+ assert(nonNull(m));
+ module(m).tree = NIL;
+ }
+ break;
+ case GRP_REC:
+ for (t = snd(grp); nonNull(t); t=tl(t)) {
+ m = findModule(textOf(hd(t)));
+ assert(nonNull(m));
+ if (module(m).mode == FM_SOURCE) {
+ ERRMSG(0) "Source module \"%s\" imports itself recursively",
+ textToStr(textOf(hd(t)))
+ EEND;
+ }
+ }
+ processInterfaces ( snd(grp) );
+ for (t = snd(grp); nonNull(t); t=tl(t)) {
+ m = findModule(textOf(hd(t)));
+ assert(nonNull(m));
+ module(m).tree = NIL;
+ }
+ break;
+ default:
+ internal("tryLoadGroup");
+ }
+}
+
+
+static void fallBackToPrelModules ( void )
+{
+ Module m;
+ for (m = MODULE_BASE_ADDR;
+ m < MODULE_BASE_ADDR+tabModuleSz; m++)
+ if (module(m).inUse
+ && !varIsMember(module(m).text, prelModules))
+ nukeModule(m);
+}
+
+
+/* This function catches exceptions in most of the system.
+ So it's only ok for procedures called from this one
+ to do EENDs (ie, write error messages). Others should use
+ EEND_NO_LONGJMP.
+*/
+static void achieveTargetModules ( Bool loadingThePrelude )
+{
+ volatile List ood;
+ volatile List modgList;
+ volatile List t;
+ volatile Module mod;
+ volatile Bool ok;
+
+ String path = NULL;
+ String sExt = NULL;
+ Bool sAvail; Time sTime; Long sSize;
+ Bool oiAvail; Time oiTime; Long oSize; Long iSize;
+
+ volatile Time oisTime;
+ volatile Bool out_of_date;
+ volatile List ood_new;
+ volatile List us;
+ volatile List modgList_new;
+ volatile List parsedButNotLoaded;
+ volatile List toChase;
+ volatile List trans_cl;
+ volatile List trans_cl_new;
+ volatile List u;
+ volatile List mg;
+ volatile List mg2;
+ volatile Cell grp;
+ volatile List badMods;
+
+ setBreakAction ( HugsIgnoreBreak );
+
+ /* First, examine timestamps to find out which modules are
+ out of date with respect to the source/interface/object files.
+ */
+ ood = NIL;
+ modgList = listFromMG();
+
+ for (t = modgList; nonNull(t); t=tl(t)) {
+
+ if (varIsMember(textOf(hd(t)),prelModules))
+ continue;
+
+ mod = findModule(textOf(hd(t)));
+ if (isNull(mod)) internal("achieveTargetSet(1)");
+
+ /* In standalone mode, only succeeds for source modules. */
+ ok = findFilesForModule (
+ textToStr(module(mod).text),
+ &path,
+ &sExt,
+ &sAvail, &sTime, &sSize,
+ &oiAvail, &oiTime, &oSize, &iSize
+ );
+
+ if (!combined && !sAvail) ok = FALSE;
+ if (!ok) {
+ fallBackToPrelModules();
+ ERRMSG(0)
+ "Can't find source or object+interface for module \"%s\"",
+ textToStr(module(mod).text)
+ EEND_NO_LONGJMP;
+ if (path) free(path);
+ return;
+ }
+
+ if (sAvail && oiAvail) {
+ oisTime = whicheverIsLater(sTime,oiTime);
+ }
+ else if (sAvail && !oiAvail) {
+ oisTime = sTime;
+ }
+ else if (!sAvail && oiAvail) {
+ oisTime = oiTime;
+ }
+ else {
+ internal("achieveTargetSet(2)");
+ }
+
+ out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
+ if (out_of_date) {
+ assert(!varIsMember(textOf(hd(t)),ood));
+ ood = cons(hd(t),ood);
+ }
+
+ if (path) { free(path); path = NULL; };
+ }
+
+ /* Second, form a simplistic transitive closure of the out-of-date
+ modules: a module is out of date if it imports an out-of-date
+ module.
+ */
+ while (1) {
+ ood_new = NIL;
+ for (t = modgList; nonNull(t); t=tl(t)) {
+ mod = findModule(textOf(hd(t)));
+ assert(nonNull(mod));
+ for (us = module(mod).uses; nonNull(us); us=tl(us))
+ if (varIsMember(textOf(hd(us)),ood))
+ break;
+ if (nonNull(us)) {
+ if (varIsMember(textOf(hd(t)),prelModules))
+ Printf ( "warning: prelude module \"%s\" is out-of-date\n",
+ textToStr(textOf(hd(t))) );
+ else
+ if (!varIsMember(textOf(hd(t)),ood_new) &&
+ !varIsMember(textOf(hd(t)),ood))
+ ood_new = cons(hd(t),ood_new);
+ }
+ }
+ if (isNull(ood_new)) break;
+ ood = appendOnto(ood_new,ood);
+ }
+
+ /* Now ood holds the entire set of modules which are out-of-date.
+ Throw them out of the system, yielding a "reduced system",
+ in which the remaining modules are in-date.
+ */
+ for (t = ood; nonNull(t); t=tl(t)) {
+ mod = findModule(textOf(hd(t)));
+ assert(nonNull(mod));
+ nukeModule(mod);
+ }
+ modgList_new = NIL;
+ for (t = modgList; nonNull(t); t=tl(t))
+ if (!varIsMember(textOf(hd(t)),ood))
+ modgList_new = cons(hd(t),modgList_new);
+ modgList = modgList_new;
+
+ /* Update the module group list to reflect the reduced system.
+ We do this so that if the following parsing phases fail, we can
+ safely fall back to the reduced system.
+ */
+ mgFromList ( modgList );
+
+ /* Parse modules/interfaces, collecting parse trees and chasing
+ imports, starting from the target set.
+ */
+ toChase = dupList(targetModules);
+ for (t = toChase; nonNull(t); t=tl(t)) {
+ Cell mode = (!combined)
+ ? FM_SOURCE
+ : ( (loadingThePrelude && combined)
+ ? FM_OBJECT
+ : FM_EITHER );
+ hd(t) = zpair(hd(t), mode);
+ }
+
+ /* toChase :: [ ((ConId, {FM_SOURCE|FM_OBJECT|FM_EITHER} )) ] */
+
+ parsedButNotLoaded = NIL;
+
+
+ while (nonNull(toChase)) {
+ ConId mc = zfst(hd(toChase));
+ Cell mode = zsnd(hd(toChase));
+ toChase = tl(toChase);
+ if (varIsMember(textOf(mc),modgList)
+ || varIsMember(textOf(mc),parsedButNotLoaded)) {
+ /* either exists fully, or is at least parsed */
+ mod = findModule(textOf(mc));
+ assert(nonNull(mod));
+ if (!compatibleNewMode(mode,module(mod).mode)) {
+ clearCurrentFile();
+ ERRMSG(0)
+ "module %s: %s required, but %s is more recent",
+ textToStr(textOf(mc)), modeToString(mode),
+ modeToString(module(mod).mode)
+ EEND_NO_LONGJMP;
+ goto parseException;
+ }
+ } else {
+
+ setBreakAction ( HugsLongjmpOnBreak );
+ if (setjmp(catch_error)==0) {
+ /* try this; it may throw an exception */
+ mod = parseModuleOrInterface ( mc, mode );
+ } else {
+ /* here's the exception handler, if parsing fails */
+ /* A parse error (or similar). Clean up and abort. */
+ parseException:
+ setBreakAction ( HugsIgnoreBreak );
+ mod = findModule(textOf(mc));
+ if (nonNull(mod)) nukeModule(mod);
+ for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
+ mod = findModule(textOf(hd(t)));
+ assert(nonNull(mod));
+ if (nonNull(mod)) nukeModule(mod);
+ }
+ return;
+ /* end of the exception handler */
+ }
+ setBreakAction ( HugsIgnoreBreak );
+
+ parsedButNotLoaded = cons(mc, parsedButNotLoaded);
+ for (t = module(mod).uses; nonNull(t); t=tl(t))
+ toChase = cons(
+ zpair( hd(t), childMode(mode,module(mod).mode) ),
+ toChase);
+ }
+ }
+
+ modgList = dupOnto(parsedButNotLoaded, modgList);
+
+ /* We successfully parsed all modules reachable from the target
+ set which were not part of the reduced system. However, there
+ may be modules in the reduced system which are not reachable from
+ the target set. We detect these now by building the transitive
+ closure of the target set, and nuking modules in the reduced
+ system which are not part of that closure.
+ */
+ trans_cl = dupList(targetModules);
+ while (1) {
+ trans_cl_new = NIL;
+ for (t = trans_cl; nonNull(t); t=tl(t)) {
+ mod = findModule(textOf(hd(t)));
+ assert(nonNull(mod));
+ for (u = module(mod).uses; nonNull(u); u=tl(u))
+ if (!varIsMember(textOf(hd(u)),trans_cl)
+ && !varIsMember(textOf(hd(u)),trans_cl_new)
+ && !varIsMember(textOf(hd(u)),prelModules))
+ trans_cl_new = cons(hd(u),trans_cl_new);
+ }
+ if (isNull(trans_cl_new)) break;
+ trans_cl = appendOnto(trans_cl_new,trans_cl);
+ }
+ modgList_new = NIL;
+ for (t = modgList; nonNull(t); t=tl(t)) {
+ if (varIsMember(textOf(hd(t)),trans_cl)) {
+ modgList_new = cons(hd(t),modgList_new);
+ } else {
+ mod = findModule(textOf(hd(t)));
+ assert(nonNull(mod));
+ nukeModule(mod);
+ }
+ }
+ modgList = modgList_new;
+
+ /* Now, the module symbol tables hold exactly the set of
+ modules reachable from the target set, and modgList holds
+ their names. Calculate the scc-ified module graph,
+ since we need that to guide the next stage, that of
+ Actually Loading the modules.
+
+ If no errors occur, moduleGraph will reflect the final graph
+ loaded. If an error occurs loading a group, we nuke
+ that group, truncate the moduleGraph just prior to that
+ group, and exit. That leaves the system having successfully
+ loaded all groups prior to the one which failed.
+ */
+ mgFromList ( modgList );
+
+ for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
+ grp = hd(mg);
+
+ if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
+ parsedButNotLoaded)) continue;
+
+ setBreakAction ( HugsLongjmpOnBreak );
+ if (setjmp(catch_error)==0) {
+ /* try this; it may throw an exception */
+ tryLoadGroup(grp);
+ } else {
+ /* here's the exception handler, if static/typecheck etc fails */
+ /* nuke the entire rest (ie, the unloaded part)
+ of the module graph */
+ setBreakAction ( HugsIgnoreBreak );
+ badMods = listFromSpecifiedMG ( mg );
+ for (t = badMods; nonNull(t); t=tl(t)) {
+ mod = findModule(textOf(hd(t)));
+ if (nonNull(mod)) nukeModule(mod);
+ }
+ /* truncate the module graph just prior to this group. */
+ mg2 = NIL;
+ mg = moduleGraph;
+ while (TRUE) {
+ if (isNull(mg)) break;
+ if (hd(mg) == grp) break;
+ mg2 = cons ( hd(mg), mg2 );
+ mg = tl(mg);
+ }
+ moduleGraph = reverse(mg2);
+ return;
+ /* end of the exception handler */
+ }
+ setBreakAction ( HugsIgnoreBreak );
+ }
+
+ /* Err .. I think that's it. If we get here, we've successfully
+ achieved the target set. Phew!
+ */
+ setBreakAction ( HugsIgnoreBreak );
+}
+
+
+static Bool loadThePrelude ( void )
+{
+ Bool ok;
+ ConId conPrelude;
+ ConId conPrelHugs;
+ moduleGraph = prelModules = NIL;
+
+ if (combined) {
+ conPrelude = mkCon(findText("Prelude"));
+ conPrelHugs = mkCon(findText("PrelHugs"));
+ targetModules = doubleton(conPrelude,conPrelHugs);
+ achieveTargetModules(TRUE);
+ ok = elemMG(conPrelude) && elemMG(conPrelHugs);
+ } else {
+ conPrelude = mkCon(findText("Prelude"));
+ targetModules = singleton(conPrelude);
+ achieveTargetModules(TRUE);
+ ok = elemMG(conPrelude);
+ }
+
+ if (ok) prelModules = listFromMG();
+ return ok;
+}
+
+
+/* Refresh the current target modules, and attempt to set the
+ current module to what it was before (ie currentModule):
+ if currentModule_failed is different from currentModule,
+ use that instead
+ if nextCurrMod is non null, try to set it to that instead
+ if the one we're after insn't available, select a target
+ from the end of the module group list.
+*/
+static void refreshActions ( ConId nextCurrMod, Bool cleanAfter )
+{
+ List t;
+ ConId tryFor;
+
+ /* Remember what the old current module was. */
+ tryFor = mkCon(module(currentModule).text);
+
+ /* Do the Real Work. */
+ achieveTargetModules(FALSE);
+
+ /* Remember if the current module was invalidated by this
+ refresh, so later refreshes can attempt to reload it. */
+ if (!elemMG(tryFor))
+ currentModule_failed = tryFor;
+
+ /* If a previous refresh failed to get an old current module,
+ try for that instead. */
+ if (nonNull(currentModule_failed)
+ && textOf(currentModule_failed) != textOf(tryFor)
+ && elemMG(currentModule_failed))
+ tryFor = currentModule_failed;
+ /* If our caller specified a new current module, that overrides
+ all historical settings. */
+ if (nonNull(nextCurrMod))
+ tryFor = nextCurrMod;
+ /* Finally, if we can't actually get hold of whatever it was we
+ were after, select something which is possible. */
+ if (!elemMG(tryFor))
+ tryFor = selectLatestMG();
+
+ /* combined mode kludge, to get Prelude rather than PrelHugs */
+ if (combined && textOf(tryFor)==findText("PrelHugs"))
+ tryFor = mkCon(findText("Prelude"));
+
+ if (cleanAfter) {
+ /* delete any targetModules which didn't actually get loaded */
+ t = targetModules;
+ targetModules = NIL;
+ for (; nonNull(t); t=tl(t))
+ if (elemMG(hd(t)))
+ targetModules = cons(hd(t),targetModules);
+ }
+
+ setCurrModule ( findModule(textOf(tryFor)) );
+ Printf("Hugs session for:\n");
+ ppMG();
+}
+
+
+static void addActions ( List extraModules /* :: [CONID] */ )
+{
+ List t;
+ for (t = extraModules; nonNull(t); t=tl(t)) {
+ ConId extra = hd(t);
+ if (!varIsMember(textOf(extra),targetModules))
+ targetModules = cons(extra,targetModules);
+ }
+ refreshActions ( isNull(extraModules)
+ ? NIL
+ : hd(reverse(extraModules)),
+ TRUE
+ );
+}
+
+
+static void loadActions ( List loadModules /* :: [CONID] */ )
+{
+ List t;
+ targetModules = dupList ( prelModules );
+
+ for (t = loadModules; nonNull(t); t=tl(t)) {
+ ConId load = hd(t);
+ if (!varIsMember(textOf(load),targetModules))
+ targetModules = cons(load,targetModules);
+ }
+ refreshActions ( isNull(loadModules)
+ ? NIL
+ : hd(reverse(loadModules)),
+ TRUE
+ );
}
-static Void local whatScripts() { /* list scripts in current session */
- int i;
- Printf("\nHugs session for:");
- if (projectLoaded)
- Printf(" (project: %s)",currProject);
- for (i=0; i<numScripts; ++i)
- Printf("\n%s",scriptName[i]);
- Putchar('\n');
-}
/* --------------------------------------------------------------------------
* Access to external editor:
* ------------------------------------------------------------------------*/
+/* ToDo: All this editor stuff needs fixing. */
+
static Void local editor() { /* interpreter-editor interface */
+#if 0
String newFile = readFilename();
if (newFile) {
setLastEdit(newFile,0);
}
}
runEditor();
+#endif
}
static Void local find() { /* edit file containing definition */
+#if 0
+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(N_PRELUDE_SCRIPTS);
}
} else if (nonNull(c=findName(t))) {
if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
- readScripts(scriptBase);
+ readScripts(N_PRELUDE_SCRIPTS);
}
} else {
ERRMSG(0) "No current definition for name \"%s\"", nm
EEND;
}
}
+#endif
}
static Void local runEditor() { /* run editor on script lastEdit */
+#if 0
if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
- readScripts(scriptBase);
+ readScripts(N_PRELUDE_SCRIPTS);
+#endif
}
static Void local setLastEdit(fname,line)/* keep name of last file to edit */
String fname;
Int line; {
+#if 0
if (lastEdit)
free(lastEdit);
lastEdit = strCopy(fname);
lastEdLine = line;
-#if HUGS_FOR_WINDOWS
- DrawStatusLine(hWndMain); /* Redo status line */
#endif
}
* 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 */
- evalModule = findText(s);
- setLastEdit(fileOfModule(findEvalModule()),0);
+static Void setModule ( void ) {
+ /*set module in which to evaluate expressions*/
+ Module m;
+ ConId mc = NIL;
+ String s = readFilename();
+ if (!s) {
+ mc = selectLatestMG();
+ if (combined && textOf(mc)==findText("PrelHugs"))
+ mc = mkCon(findText("Prelude"));
+ m = findModule(textOf(mc));
+ assert(nonNull(m));
+ } else {
+ m = findModule(findText(s));
+ if (isNull(m)) {
+ ERRMSG(0) "Cannot find module \"%s\"", s
+ EEND_NO_LONGJMP;
+ return;
+ }
+ }
+ setCurrModule(m);
+}
+
+static Module allocEvalModule ( void )
+{
+ Module evalMod = newModule( findText("_Eval_Module_") );
+ module(evalMod).names = module(currentModule).names;
+ module(evalMod).tycons = module(currentModule).tycons;
+ module(evalMod).classes = module(currentModule).classes;
+ module(evalMod).qualImports
+ = singleton(pair(mkCon(textPrelude),modulePrelude));
+ return evalMod;
}
-static Module local findEvalModule() { /*Module in which to eval expressions*/
- Module m = findModule(evalModule);
- if (isNull(m))
- m = lastModule();
- return m;
-}
-#endif
-
static Void local evaluator() { /* evaluate expr and print value */
- Type type, bd;
- Kinds ks = NIL;
+ volatile Type type;
+ volatile Type bd;
+ volatile Kinds ks = NIL;
+ volatile Module evalMod = allocEvalModule();
+ volatile Module currMod = currentModule;
+ setCurrModule(evalMod);
+ currentFile = NULL;
+
+ defaultDefns = combined ? stdDefaults : evalDefaults;
+
+ setBreakAction ( HugsLongjmpOnBreak );
+ if (setjmp(catch_error)==0) {
+ /* try this */
+ parseExp();
+ checkExp();
+ type = typeCheckExp(TRUE);
+ } else {
+ /* if an exception happens, we arrive here */
+ setBreakAction ( HugsIgnoreBreak );
+ goto cleanup_and_return;
+ }
- setCurrModule(findEvalModule());
- scriptFile = 0;
- startNewScript(0); /* Enables recovery of storage */
- /* allocated during evaluation */
- parseExp();
- checkExp();
- defaultDefns = evalDefaults;
- type = typeCheckExp(TRUE);
+ setBreakAction ( HugsIgnoreBreak );
if (isPolyType(type)) {
ks = polySigOf(type);
bd = monotypeOf(type);
bd = type;
if (whatIs(bd)==QUAL) {
- ERRMSG(0) "Unresolved overloading" ETHEN
- ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
- ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
- ERRTEXT "\n"
- EEND;
+ clearCurrentFile();
+ ERRMSG(0) "Unresolved overloading" ETHEN
+ ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
+ ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
+ ERRTEXT "\n"
+ EEND_NO_LONGJMP;
+ goto cleanup_and_return;
}
-#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 {
Cell d = provePred(ks,NIL,ap(classShow,bd));
if (isNull(d)) {
- ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
- ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
- ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
- ERRTEXT "\n"
- EEND;
+ clearCurrentFile();
+ ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
+ ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
+ ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
+ ERRTEXT "\n"
+ EEND_NO_LONGJMP;
+ goto cleanup_and_return;
}
- //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
+ cleanup_and_return:
+ setBreakAction ( HugsIgnoreBreak );
+ nukeModule(evalMod);
+ setCurrModule(currMod);
+ setCurrentFile(currMod);
}
-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 reduction%s, ",plural(numReductions)); */
- Printf("%lu cell%s",plural(numCells));
- if (numGcs>0)
- Printf(", %u garbage collection%s",plural(numGcs));
- Printf(")\n");
-#undef plural
- }
- FlushStdout();
- garbageCollect();
- }
-}
+
/* --------------------------------------------------------------------------
* Print type of input expression:
* ------------------------------------------------------------------------*/
-static Void local showtype() { /* print type of expression (if any)*/
- Cell type;
+static Void showtype ( void ) { /* print type of expression (if any)*/
+
+ volatile Cell type;
+ volatile Module evalMod = allocEvalModule();
+ volatile Module currMod = currentModule;
+ setCurrModule(evalMod);
+
+ if (setjmp(catch_error)==0) {
+ /* try this */
+ parseExp();
+ checkExp();
+ defaultDefns = evalDefaults;
+ type = typeCheckExp(FALSE);
+ printExp(stdout,inputExpr);
+ Printf(" :: ");
+ printType(stdout,type);
+ Putchar('\n');
+ } else {
+ /* if an exception happens, we arrive here */
+ }
+
+ nukeModule(evalMod);
+ setCurrModule(currMod);
+}
+
+
+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;
+
+ for (; (s=readFilename())!=0; count++)
+ if (strcmp(s,"all") == 0) {
+ all = TRUE;
+ --count;
+ } else
+ browseit(findModule(findText(s)),s,all);
+ if (count == 0) {
+ browseit(currentModule,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 */
- parseExp();
- checkExp();
- defaultDefns = evalDefaults;
- type = typeCheckExp(FALSE);
- printExp(stdout,inputExpr);
- Printf(" :: ");
- printType(stdout,type);
- Putchar('\n');
+ /* 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
#endif
}
+extern Name nameHw;
+
+static Void dumpStg ( void )
+{
+ String s;
+ Int i;
+#if 0
+ Whats this for?
+ setCurrModule(findEvalModule());
+ startNewScript(0);
+#endif
+ s = readFilename();
+
+ /* request to locate a symbol by name */
+ if (s && (*s == '?')) {
+ Text t = findText(s+1);
+ locateSymbolByName(t);
+ return;
+ }
+
+ /* request to dump a bit of the heap */
+ if (s && (*s == '-' || isdigit(*s))) {
+ int i = atoi(s);
+ print(i,100);
+ printf("\n");
+ return;
+ }
+
+ /* request to dump a symbol table entry */
+ if (!s
+ || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
+ || !isdigit(s[1])) {
+ fprintf(stderr, ":d -- bad request `%s'\n", s );
+ return;
+ }
+ i = atoi(s+1);
+ switch (*s) {
+ case 't': dumpTycon(i); break;
+ case 'n': dumpName(i); break;
+ case 'c': dumpClass(i); break;
+ case 'i': dumpInst(i); break;
+ default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
+ }
+}
+
+
+#if 0
+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);
+ }
+ }
+}
+#endif
+
static Void local info() { /* describe objects */
Int count = 0; /* or give menu of commands */
String s;
- setCurrModule(findEvalModule());
- startNewScript(0); /* for recovery of storage */
for (; (s=readFilename())!=0; count++) {
describe(findText(s));
}
if (count == 0) {
- whatScripts();
+ /* whatScripts(); */
}
}
+
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>");
}
-
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));
}
Int width = getTerminalWidth() - 1;
Int count = 0;
Int termPos;
- Module mod = findEvalModule();
+ Module mod = currentModule;
if (pat) { /* First gather names to list */
do {
names = addNamesMatching((String)0,names);
}
if (isNull(names)) { /* Then print them out */
+ clearCurrentFile();
ERRMSG(0) "No names selected"
- EEND;
+ EEND_NO_LONGJMP;
+ return;
}
for (termPos=0; nonNull(names); names=tl(names)) {
String s = objToStr(mod,hd(names));
internal("Combined prompt and evaluation module name too long");
}
#endif
- consoleInput(promptBuffer);
+ if (autoMain)
+ stringInput("main\0"); else
+ consoleInput(promptBuffer);
}
/* --------------------------------------------------------------------------
* main read-eval-print loop, with error trapping:
* ------------------------------------------------------------------------*/
-static jmp_buf catch_error; /* jump buffer for error trapping */
-
static Void local interpreter(argc,argv)/* main interpreter loop */
Int argc;
String argv[]; {
- Int errorNumber = setjmp(catch_error);
-
- breakOn(TRUE); /* enable break trapping */
- if (numScripts==0) { /* only succeeds on first time, */
- if (errorNumber) /* before prelude has been loaded */
- fatal("Unable to load prelude");
- initialize(argc,argv);
- forHelp();
+
+ List modConIds; /* :: [CONID] */
+ Bool prelOK;
+ String s;
+
+ setBreakAction ( HugsIgnoreBreak );
+ modConIds = initialize(argc,argv); /* the initial modules to load */
+ setBreakAction ( HugsIgnoreBreak );
+ prelOK = loadThePrelude();
+
+ if (!prelOK) {
+ if (autoMain)
+ fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
+ else
+ fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
+ exit(1);
+ }
+
+ if (combined) everybody(POSTPREL);
+ loadActions(modConIds);
+
+ if (autoMain) {
+ for (; nonNull(modConIds); modConIds=tl(modConIds))
+ if (!elemMG(hd(modConIds))) {
+ fprintf(stderr,
+ "hugs +Q: compilation failed -- can't run `main'\n" );
+ exit(1);
+ }
}
+ modConIds = NIL;
+
+ /* initialize calls startupHaskell, which trashes our signal handlers */
+ setBreakAction ( HugsIgnoreBreak );
+ forHelp();
+
for (;;) {
Command cmd;
everybody(RESET); /* reset to sensible initial state */
- dropScriptsFrom(numScripts); /* remove partially loaded scripts */
- promptForInput(textToStr(module(findEvalModule()).text));
+ promptForInput(textToStr(module(currentModule).text));
cmd = readCommand(cmds, (Char)':', (Char)'!');
-#ifdef WANT_TIMER
- updateTimers();
-#endif
switch (cmd) {
case EDIT : editor();
break;
case FIND : find();
break;
- case LOAD : clearProject();
- forgetScriptsFrom(scriptBase);
- load();
- break;
- case ALSO : clearProject();
- forgetScriptsFrom(numScripts);
- load();
+ case LOAD : modConIds = NIL;
+ while ((s=readFilename())!=0)
+ modConIds = cons(mkCon(findText(s)),modConIds);
+ loadActions(modConIds);
+ modConIds = NIL;
break;
- case RELOAD : readScripts(scriptBase);
+ case ALSO : modConIds = NIL;
+ while ((s=readFilename())!=0)
+ modConIds = cons(mkCon(findText(s)),modConIds);
+ addActions(modConIds);
+ modConIds = NIL;
break;
- case PROJECT: project();
+ case RELOAD : refreshActions(NIL,FALSE);
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();
break;
case NOCMD : break;
}
-#ifdef WANT_TIMER
- updateTimers();
- 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('.');
* Error handling:
* ------------------------------------------------------------------------*/
+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();
+ }
+}
+
+Cell errAssert(l) /* message to use when raising asserts, etc */
+Int l; {
+ Cell str;
+ if (currentFile) {
+ str = mkStr(findText(currentFile));
+ } else {
+ str = mkStr(findText(""));
+ }
+ return (ap2(nameTangleMessage,str,mkInt(l)));
+}
+
Void errHead(l) /* print start of error message */
Int l; {
failed(); /* failed to reach target ... */
stopAnyPrinting();
FPrintf(errorStream,"ERROR");
- if (scriptFile) {
- FPrintf(errorStream," \"%s\"", scriptFile);
- setLastEdit(scriptFile,l);
+ if (currentFile) {
+ FPrintf(errorStream," \"%s\"", currentFile);
+ setLastEdit(currentFile,l);
if (l) FPrintf(errorStream," (line %d)",l);
- scriptFile = 0;
+ currentFile = NULL;
}
FPrintf(errorStream,": ");
FFlush(errorStream);
longjmp(catch_error,1);
}
+Void errFail_no_longjmp() { /* terminate error message but */
+ Putc('\n',errorStream); /* don't produce an exception */
+ FFlush(errorStream);
+}
+
Void errAbort() { /* altern. form of error handling */
failed(); /* used when suitable error message*/
stopAnyPrinting(); /* has already been printed */
Void internal(msg) /* handle internal error */
String msg; {
-#if HUGS_FOR_WINDOWS
- char buf[300];
- wsprintf(buf,"INTERNAL ERROR: %s",msg);
- MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
-#endif
failed();
stopAnyPrinting();
Printf("INTERNAL ERROR: %s\n",msg);
FlushStdout();
+exit(9);
longjmp(catch_error,1);
}
Void fatal(msg) /* handle fatal error */
String msg; {
-#if HUGS_FOR_WINDOWS
- char buf[300];
- wsprintf(buf,"FATAL ERROR: %s",msg);
- MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
-#endif
FlushStdout();
Printf("\nFATAL ERROR: %s\n",msg);
everybody(EXIT);
exit(1);
}
-sigHandler(breakHandler) { /* respond to break interrupt */
-#if HUGS_FOR_WINDOWS
- MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
-#endif
- Hilite();
- Printf("{Interrupted!}\n");
- Lolite();
- 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);
- sigResume;/*NOTREACHED*/
-}
/* --------------------------------------------------------------------------
* Read value from environment variable or registry:
return NULL;
}
+
/* --------------------------------------------------------------------------
* Compiler output
* We can redirect compiler output (prompts, error messages, etc) by
* tweaking these functions.
* ------------------------------------------------------------------------*/
-#if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
-
#ifdef HAVE_STDARG_H
#include <stdarg.h>
#else
#include <varargs.h>
#endif
-/* ----------------------------------------------------------------------- */
-
-#define BufferSize 5000 /* size of redirected output buffer */
-
-typedef struct _HugsStream {
- char buffer[BufferSize]; /* buffer for redirected output */
- Int next; /* next space in buffer */
-} HugsStream;
-
-static Void local vBufferedPrintf Args((HugsStream*, const char*, va_list));
-static Void local bufferedPutchar Args((HugsStream*, Char));
-static String local bufferClear Args((HugsStream *stream));
-
-static Void local vBufferedPrintf(stream, fmt, ap)
-HugsStream* stream;
-const char* fmt;
-va_list ap; {
- Int spaceLeft = BufferSize - stream->next;
- char* p = &stream->buffer[stream->next];
- Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
- if (0 <= charsAdded && charsAdded < spaceLeft)
- stream->next += charsAdded;
-#if 1 /* we can either buffer the first n chars or buffer the last n chars */
- else
- stream->next = 0;
-#endif
-}
-
-static Void local bufferedPutchar(stream, c)
-HugsStream *stream;
-Char c; {
- if (BufferSize - stream->next >= 2) {
- stream->buffer[stream->next++] = c;
- stream->buffer[stream->next] = '\0';
- }
-}
-
-static String local bufferClear(stream)
-HugsStream *stream; {
- if (stream->next == 0) {
- return "";
- } else {
- stream->next = 0;
- return stream->buffer;
- }
-}
-
-/* ----------------------------------------------------------------------- */
-
-static HugsStream outputStreamH;
-/* ADR note:
- * We rely on standard C semantics to initialise outputStreamH.next to 0.
- */
-
Void hugsEnableOutput(f)
Bool f; {
disableOutput = !f;
}
-String hugsClearOutputBuffer() {
- return bufferClear(&outputStreamH);
-}
-
#ifdef HAVE_STDARG_H
Void hugsPrintf(const char *fmt, ...) {
va_list ap; /* pointer into argument list */
if (!disableOutput) {
vprintf(fmt, ap);
} else {
- vBufferedPrintf(&outputStreamH, fmt, ap);
}
va_end(ap); /* clean up */
}
if (!disableOutput) {
vprintf(fmt, ap);
} else {
- vBufferedPrintf(&outputStreamH, fmt, ap);
}
va_end(ap); /* clean up */
}
if (!disableOutput) {
putchar(c);
} else {
- bufferedPutchar(&outputStreamH, c);
}
}
if (!disableOutput) {
vfprintf(fp, fmt, ap);
} else {
- vBufferedPrintf(&outputStreamH, fmt, ap);
}
va_end(ap);
}
if (!disableOutput) {
vfprintf(fp, fmt, ap);
} else {
- vBufferedPrintf(&outputStreamH, fmt, ap);
}
va_end(ap);
}
if (!disableOutput) {
putc(c,fp);
} else {
- 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 ... */
+#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);
linkControl(what);
staticAnalysis(what);
deriveControl(what);
typeChecker(what);
- translateControl(what);
compiler(what);
codegen(what);
-}
-
-
-/* --------------------------------------------------------------------------
- * Hugs for Windows code (WinMain and related functions)
- * ------------------------------------------------------------------------*/
-#if HUGS_FOR_WINDOWS
-#include "winhugs.c"
-#endif
+ if (what == MARK) {
+ mark(moduleGraph);
+ mark(prelModules);
+ mark(targetModules);
+ mark(daSccs);
+ mark(currentModule_failed);
+ }
+}
/*-------------------------------------------------------------------------*/
-
projects / ghc-hetmet.git / blobdiff