* included in the distribution.
*
* $RCSfile: hugs.c,v $
- * $Revision: 1.21 $
- * $Date: 1999/11/17 16:57:38 $
+ * $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;
* 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));
-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 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 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));
+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 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;
-
-typedef
- struct {
- String modName; /* Module name */
- Bool details; /* FALSE => remaining fields are invalid */
- String path; /* Path to module */
- String srcExt; /* ".hs" or ".lhs" if fromSource */
- Time lastChange; /* Time of last change to script */
- Bool fromSource; /* FALSE => load object code */
- Bool postponed; /* Indicates postponed load */
- Bool objLoaded;
- Long size;
- Long oSize;
- }
- ScriptInfo;
-
-static Void local makeStackEntry Args((ScriptInfo*,String));
-static Void local addStackEntry Args((String));
-
-static ScriptInfo scriptInfo[NUM_SCRIPTS];
-
-static Int numScripts; /* Number of scripts loaded */
-static Int nextNumScripts;
-static Int namesUpto; /* Number of script names set */
-static Bool needsImports; /* set to TRUE if imports required */
- String scriptFile; /* Name of current script (if any) */
-
+ Bool flagAssert = FALSE; /* TRUE => assert False <e> causes
+ an assertion failure */
+ Bool preludeLoaded = FALSE;
+ Bool debugSC = FALSE;
+ Bool combined = FALSE;
-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 */
+ 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 */
+static Bool disableOutput = FALSE; /* TRUE => quiet */
String hugsEdit = 0; /* String for editor command */
String hugsPath = 0; /* String for file search path */
-#if REDIRECT_OUTPUT
-static Bool disableOutput = FALSE; /* redirect output to buffer? */
-#endif
+ List ifaces_outstanding = NIL;
+
+static ConId currentModule_failed = NIL; /* Remember failed module from :r */
-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:
#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 */
- /* Try and figure out an absolute path to the executable, so
- we can make a reasonable guess about where the default
- libraries (Prelude etc) are.
- */
- setDefaultLibDir ( argv[0] );
+#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;
- hugsEnableOutput(0);
+ if (strcmp(argv[1],"-Q") == 0) {
+ EnableOutput(0);
+ }
}
Printf("__ __ __ __ ____ ___ _________________________________________\n");
- Printf("|| || || || || || ||__ Hugs 98: Based on the Haskell 98 standard\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");
#endif
* 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;
- char argv_0_orig[1000];
-
- 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 = "";
+static List /*CONID*/ initialize ( Int argc, String argv[] )
+{
+ Int i, j;
+ List initialModules;
+
+ setLastEdit((String)0,0);
+ lastEdit = 0;
+ currentFile = NULL;
+
+#if SYMANTEC_C
+ hugsEdit = "";
#else
- hugsEdit = strCopy(fromEnv("EDITOR",NULL));
+ 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("STGHUGSFLAGS",""));
-
- strncpy(argv_0_orig,argv[0],1000); /* startupHaskell mangles argv[0] */
- startupHaskell (argc,argv);
- argc = prog_argc; argv = prog_argv;
-
- namesUpto = numScripts = 0;
- 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"
- EEND;
- } else {
- proj = argv[++i];
- }
- } else if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
- && !processOption(argv[i])) {
- addStackEntry(argv[i]);
- }
- }
+ 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
-#if DEBUG
- DEBUG_LoadSymbols(argv_0_orig);
-#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 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 (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);
+ 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;
}
/* --------------------------------------------------------------------------
*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*/
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(' ');
- }
- 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
- PUTC('\0');
- return buffer;
-}
-#endif /* USE_REGISTRY */
-
#undef PUTC
#undef PUTS
#undef PUTInt
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 */
}
default : if (strcmp("98",s)==0) {
- if (heapBuilt() && ((state && !haskell98) ||
+ if (initDone && ((state && !haskell98) ||
(!state && haskell98))) {
FPrintf(stderr,
"Haskell 98 compatibility cannot be changed"
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;
}
{'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
+ {'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
-#if DEBUG_CODE
- {'D', 1, "Debug: show generated G code", &debugCode},
-#endif
-#if DEBUG_SHOWSC
- {'S', 1, "Debug: show generated SC code", &debugSC},
-#endif
-#if 0
- {'f', 1, "Terminate evaluation on first error", &failOnError},
- {'u', 1, "Use \"show\" to display results", &useShow},
- {'i', 1, "Chase imports while loading modules", &chaseImports},
-#endif
{0, 0, 0, 0}
};
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(1);
- while ((s=readFilename())!=0)
- addStackEntry(s);
- if (namesUpto<=1) {
- ERRMSG(0) "Empty project file"
- EEND;
- }
- scriptFile = 0;
- projectLoaded = TRUE;
+static jmp_buf catch_error; /* jump buffer for error trapping */
+
+HugsBreakAction currentBreakAction = HugsIgnoreBreak;
+
+static void handler_IgnoreBreak ( int sig )
+{
+ setHandler ( handler_IgnoreBreak );
}
-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
+static void handler_LongjmpOnBreak ( int sig )
+{
+ setHandler ( handler_LongjmpOnBreak );
+ Printf("{Interrupted!}\n");
+ longjmp(catch_error,1);
}
+static void handler_RtsInterrupt ( int sig )
+{
+ setHandler ( handler_RtsInterrupt );
+ interruptStgRts();
+}
+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;
+}
-static Void local makeStackEntry ( ScriptInfo* ent, String iname )
+
+/* --------------------------------------------------------------------------
+ * The new module chaser, loader, etc
+ * ------------------------------------------------------------------------*/
+
+List moduleGraph = NIL;
+List prelModules = NIL;
+List targetModules = NIL;
+
+static String modeToString ( Cell mode )
{
- Bool ok, fromObj;
- Bool sAvail, iAvail, oAvail;
- Time sTime, iTime, oTime;
- Long sSize, iSize, oSize;
- String path, sExt;
+ switch (mode) {
+ case FM_SOURCE: return "source";
+ case FM_OBJECT: return "object";
+ case FM_EITHER: return "source or object";
+ default: internal("modeToString");
+ }
+}
- ok = findFilesForModule (
- iname,
- &path,
- &sExt,
- &sAvail, &sTime, &sSize,
- &iAvail, &iTime, &iSize,
- &oAvail, &oTime, &oSize
- );
- if (!ok) {
- ERRMSG(0)
- /* "Can't file source or object+interface for module \"%s\"", */
- "Can't file source for module \"%s\"",
- iname
- EEND;
+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;
+ 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");
+ }
}
- /* 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.
- fromObj = sAvail
- ? (oAvail && iAvail && timeEarlier(sTime,oTime))
- : TRUE;
- */
- 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 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 Void nukeEnding( String s )
+static ConId selectLatestMG ( void )
{
- Int l = strlen(s);
- if (l > 2 && strncmp(s+l-2,".o" ,3)==0) s[l-2] = 0; else
- if (l > 3 && strncmp(s+l-3,".hi" ,3)==0) s[l-3] = 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;
+ List gs = moduleGraph;
+ if (isNull(gs)) internal("selectLatestMG(1)");
+ while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs);
+ return selectArbitrarilyFromGroup(hd(gs));
+}
- if (namesUpto>=NUM_SCRIPTS) {
- ERRMSG(0) "Too many module files (maximum of %d allowed)",
- NUM_SCRIPTS
- EEND;
- }
- s = strCopy(s);
- nukeEnding(s);
- for (s2 = s; *s2; s2++)
- if (*s2 == SLASH && *(s2+1)) s = s2+1;
+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;
+}
- found = FALSE;
- for (i = 0; i < namesUpto; i++)
- if (strcmp(scriptInfo[i].modName,s)==0)
- found = TRUE;
+static List /* of CONID */ listFromMG ( void )
+{
+ return listFromSpecifiedMG ( moduleGraph );
+}
- if (!found) {
- makeStackEntry ( &scriptInfo[namesUpto], strCopy(s) );
- namesUpto++;
- }
- free(s);
+
+/* 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);
}
-/* 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
+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
+ );
- // setLastEdit(name,0);
-
- nameObj[0] = 0;
- strcpy(name, scriptInfo[stacknum].path);
- strcat(name, scriptInfo[stacknum].modName);
- if (scriptInfo[stacknum].fromSource)
- strcat(name, scriptInfo[stacknum].srcExt); else
- strcat(name, ".hi");
-
- scriptFile = name;
-
- if (scriptInfo[stacknum].fromSource) {
- if (lastWasObject) finishInterfaces();
- lastWasObject = FALSE;
- Printf("Reading script \"%s\":\n",name);
- needsImports = FALSE;
- parseScript(name,len);
- if (needsImports) return FALSE;
- checkDefns();
- typeCheckDefns();
- compileDefns();
+ 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 {
- 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;
-
- loadInterface(name,len);
- scriptFile = 0;
- lastWasObject = TRUE;
- if (needsImports) return FALSE;
+ 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;
}
-
- scriptFile = 0;
- preludeLoaded = TRUE;
- return TRUE;
-}
-
-
-Bool chase(imps) /* Process list of import requests */
-List imps; {
- 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;
+ if (path) free(path);
+ return mod;
- needsImports = TRUE;
- if (scriptInfo[origPos].fromSource)
- scriptInfo[origPos].postponed = TRUE;
+ cant_find:
+ if (path) free(path);
+ clearCurrentFile();
+ ERRMSG(0)
+ "Can't find %s for module \"%s\"",
+ modeToString(modeRequest), textToStr(mt)
+ EEND;
+}
- 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;
+
+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;
}
- /* 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;
+ }
+ 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 local forgetScriptsFrom(scno)/* remove scripts from system */
-Script scno; {
- Script i;
-#if 0
- for (i=scno; i<namesUpto; ++i)
- if (scriptName[i])
- free(scriptName[i]);
-#endif
- dropScriptsFrom(scno-1);
- namesUpto = scno;
- if (numScripts>namesUpto)
- numScripts = scno;
+
+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);
}
-/* --------------------------------------------------------------------------
- * Commands for loading and removing script files:
- * ------------------------------------------------------------------------*/
-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)
- addStackEntry(s);
- readScripts(1);
-}
+/* 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();
-static Void local project() { /* read list of script names from */
- String s; /* project file */
+ for (t = modgList; nonNull(t); t=tl(t)) {
- 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(1);
-}
+ if (varIsMember(textOf(hd(t)),prelModules))
+ continue;
-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];
+ 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;
+ }
- lastWasObject = FALSE;
- ppSmStack("readscripts-begin");
-#if HUGS_FOR_WINDOWS
- SetCursor(LoadCursor(NULL, IDC_WAIT));
-#endif
+ if (sAvail && oiAvail) {
+ oisTime = whicheverIsLater(sTime,oiTime);
+ }
+ else if (sAvail && !oiAvail) {
+ oisTime = sTime;
+ }
+ else if (!sAvail && oiAvail) {
+ oisTime = oiTime;
+ }
+ else {
+ internal("achieveTargetSet(2)");
+ }
-#if 0
- for (; n<numScripts; n++) { /* Scan previously loaded scripts */
- ppSmStack("readscripts-loop1");
- getFileInfo(scriptName[n], &timeStamp, &fileSize);
- if (timeChanged(timeStamp,lastChange[n])) {
- dropScriptsFrom(n-1);
- 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);
- if (numScripts>0) /* no new script for prelude */
- startNewScript(scriptName[numScripts]);
- if (addScript(scriptName[numScripts],fileSize))
- numScripts++;
- else
- dropScriptsFrom(numScripts-1);
- }
-#endif
+ out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
+ if (out_of_date) {
+ assert(!varIsMember(textOf(hd(t)),ood));
+ ood = cons(hd(t),ood);
+ }
- 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, ".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;
+ if (path) { free(path); path = NULL; };
+ }
- //numScripts = 0;
+ /* 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);
+ }
- while (numScripts < namesUpto) {
-ppSmStack ( "readscripts-loop2" );
+ /* 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 );
- if (scriptInfo[numScripts].fromSource) {
+ /* 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);
+ }
+ }
- if (numScripts>0)
- startNewScript(scriptInfo[numScripts].modName);
- nextNumScripts = NUM_SCRIPTS; //bogus initialisation
- if (addScript(numScripts)) {
- numScripts++;
-assert(nextNumScripts==NUM_SCRIPTS);
- }
- else
- dropScriptsFrom(numScripts-1);
+ modgList = dupOnto(parsedButNotLoaded, modgList);
- } else {
+ /* 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 (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") ;
- }
+ 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 );
+ }
- finishInterfaces();
+ /* Err .. I think that's it. If we get here, we've successfully
+ achieved the target set. Phew!
+ */
+ setBreakAction ( HugsIgnoreBreak );
+}
- { 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;
- }
-
+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 (listScripts)
- whatScripts();
- if (numScripts<=1)
- setLastEdit((String)0, 0);
- ppSmStack("readscripts-end ");
+ if (ok) prelModules = listFromMG();
+ return ok;
}
-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%s",scriptInfo[i].path, scriptInfo[i].modName);
- Putchar('\n');
+
+/* 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
+ );
+}
+
+
/* --------------------------------------------------------------------------
* 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
-This just plain wont work no more.
ToDo: Fix!
String nm = readFilename(); /* of specified name */
if (!nm) {
startNewScript(0);
if (nonNull(c=findTycon(t=findText(nm)))) {
if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
- readScripts(1);
+ readScripts(N_PRELUDE_SCRIPTS);
}
} else if (nonNull(c=findName(t))) {
if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
- readScripts(1);
+ readScripts(N_PRELUDE_SCRIPTS);
}
} else {
ERRMSG(0) "No current definition for name \"%s\"", nm
}
static Void local runEditor() { /* run editor on script lastEdit */
+#if 0
if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
- readScripts(1);
+ 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:
* ------------------------------------------------------------------------*/
-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 local findEvalModule() { /*Module in which to eval expressions*/
- Module m = findModule(evalModule);
- if (isNull(m))
- m = lastModule();
- return 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 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;
}
-#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(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) {
#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 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;
-
- 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');
+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);
}
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;
} else
browseit(findModule(findText(s)),s,all);
if (count == 0) {
- browseit(findEvalModule(),NULL,all);
+ browseit(currentModule,NULL,all);
}
}
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;
}
}
}
+#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(); */
}
}
} else {
Printf("<unknown type>");
}
-
if (isCfun(nm)) {
Printf(" -- data constructor");
} else if (isMfun(nm)) {
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));
* 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);
- if (errorNumber && autoMain) {
- fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" );
+ 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);
- 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();
+ 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 */
- breakOn(TRUE);
+ setBreakAction ( HugsIgnoreBreak );
+ forHelp();
for (;;) {
Command cmd;
everybody(RESET); /* reset to sensible initial state */
- dropScriptsFrom(numScripts-1); /* remove partially loaded scripts */
- /* not counting prelude as a script*/
- 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(1);
- 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(1);
+ 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;
case SETMODULE :
setModule();
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);
}
/* --------------------------------------------------------------------------
* 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 10000 /* 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);
typeChecker(what);
compiler(what);
codegen(what);
-}
-/* --------------------------------------------------------------------------
- * Hugs for Windows code (WinMain and related functions)
- * ------------------------------------------------------------------------*/
+ if (what == MARK) {
+ mark(moduleGraph);
+ mark(prelModules);
+ mark(targetModules);
+ mark(daSccs);
+ mark(currentModule_failed);
+ }
+}
-#if HUGS_FOR_WINDOWS
-#include "winhugs.c"
-#endif
+/*-------------------------------------------------------------------------*/
projects / ghc-hetmet.git / blobdiff