* included in the distribution.
*
* $RCSfile: hugs.c,v $
- * $Revision: 1.46 $
- * $Date: 2000/03/22 18:14:22 $
+ * $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 "connect.h"
#include "errors.h"
#include "Assembler.h" /* DEBUG_LoadSymbols */
Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
+Bool initDone = FALSE;
#if EXPLAIN_INSTANCE_RESOLUTION
Bool showInstRes = FALSE;
static Void local toggleSet ( Char,Bool );
static Void local togglesIn ( Bool );
static Void local optionInfo ( Void );
-#if USE_REGISTRY
-static String local optionsToStr ( Void );
-#endif
static Void local readOptions ( String );
static Bool local processOption ( String );
static Void local setHeapSize ( String );
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:
Bool debugSC = FALSE;
Bool combined = FALSE;
- 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 */
+ 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 */
List ifaces_outstanding = NIL;
+static ConId currentModule_failed = NIL; /* Remember failed module from :r */
+
+
/* --------------------------------------------------------------------------
* Hugs entry point:
* Initialization, interpret command line args and read prelude:
* ------------------------------------------------------------------------*/
-static List /*CONID*/ initialize(argc,argv) /* Interpreter initialization */
-Int argc;
-String argv[]; {
- Int i;
- String proj = 0;
- char argv_0_orig[1000];
+static List /*CONID*/ initialize ( Int argc, String argv[] )
+{
+ Int i, j;
List initialModules;
setLastEdit((String)0,0);
lastEdit = 0;
- scriptFile = 0;
+ currentFile = NULL;
#if SYMANTEC_C
hugsEdit = "";
#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;
-
# if DEBUG
{
char exe_name[N_INSTALLDIR + 6];
}
# 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.
+ everybody(PREPREL) needs to know this. Also, establish the
+ heap size;
*/
- for (i=1; i < argc; ++i) {
+ 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) break;
- if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
- && !processOption(argv[i])) {
- initialModules
- = cons ( mkCon(findText(argv[i])), initialModules );
+ 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;
}
}
" 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
-#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 ( 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
}
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,"You cannot change heap size from inside Hugs\n");
-#endif
} else {
heapSize = hpSize;
}
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;
}
}
/* --------------------------------------------------------------------------
+ * Interrupt handling
+ * ------------------------------------------------------------------------*/
+
+static jmp_buf catch_error; /* jump buffer for error trapping */
+
+HugsBreakAction currentBreakAction = HugsIgnoreBreak;
+
+static void handler_IgnoreBreak ( int sig )
+{
+ setHandler ( handler_IgnoreBreak );
+}
+
+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;
+}
+
+
+/* --------------------------------------------------------------------------
* The new module chaser, loader, etc
* ------------------------------------------------------------------------*/
List moduleGraph = NIL;
List prelModules = NIL;
List targetModules = NIL;
-static jmp_buf catch_error; /* jump buffer for error trapping */
+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 )
{
u = hd(t);
switch (whatIs(u)) {
case GRP_NONREC:
- fprintf ( stderr, "%s\n", textToStr(textOf(snd(u))));
+ FPrintf ( stderr, " %s\n", textToStr(textOf(snd(u))));
break;
case GRP_REC:
- fprintf ( stderr, "{" );
+ FPrintf ( stderr, " {" );
for (v = snd(u); nonNull(v); v=tl(v))
- fprintf ( stderr, "%s ", textToStr(textOf(hd(v))) );
- fprintf ( stderr, "}\n" );
+ FPrintf ( stderr, "%s ", textToStr(textOf(hd(v))) );
+ FPrintf ( stderr, "}\n" );
break;
default:
internal("ppMG");
}
-static List /* of CONID */ listFromMG ( void )
+static List /* of CONID */ listFromSpecifiedMG ( List mg )
{
List gs;
List cs = NIL;
- for (gs = moduleGraph; nonNull(gs); gs=tl(gs)) {
+ 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("listFromMG");
+ 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
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 = modScc ( adjList );
- adjList = rev(adjList);
/* adjList is now [ [(module-text, aux-info-field)] ] */
moduleGraph = NIL;
if (isRec)
moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
- moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
+ moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
}
+ moduleGraph = reverse(moduleGraph);
}
defaultLine = 0;
inputExpr = NIL;
+ setCurrentFile(m);
startModule(m);
tree = unap(M_MODULE,module(m).tree);
modNm = zfst3(tree);
- assert(textOf(modNm)==module(m).text); /* wrong, but ... */
+
+ 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);
addUnqualImport(zfst(te2),zsnd(te2));
break;
case M_TYCON:
- tyconDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
+ tyconDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
break;
case M_CLASS:
- classDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
+ classDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
break;
case M_INST:
- instDefn(zfst3(te2),zsnd3(te2),zthd3(te2));
+ instDefn(intOf(zfst3(te2)),zsnd3(te2),zthd3(te2));
break;
case M_DEFAULT:
- defaultDefn(zfst(te2),zsnd(te2));
+ defaultDefn(intOf(zfst(te2)),zsnd(te2));
break;
case M_FOREIGN_IM:
- foreignImport(zsel15(te2),zsel25(te2),zsel35(te2),
+ foreignImport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
zsel45(te2),zsel55(te2));
break;
case M_FOREIGN_EX:
- foreignExport(zsel15(te2),zsel25(te2),zsel35(te2),
+ foreignExport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
zsel45(te2),zsel55(te2));
case M_VALUE:
valDefns = cons(te2,valDefns);
}
-static Module parseModuleOrInterface ( ConId mc,
- List renewFromSource,
- List renewFromObject )
+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 iAvail; Time iTime; Long iSize;
- Bool oAvail; Time oTime; Long oSize;
+ Bool sAvail; Time sTime; Long sSize;
+ Bool oiAvail; Time oiTime; Long oSize; Long iSize;
Bool ok;
Bool useSource;
char name[10000];
textToStr(module(mod).text),
&path,
&sExt,
- &sAvail, &sTime, &sSize,
- &iAvail, &iTime, &iSize,
- &oAvail, &oTime, &oSize
+ &sAvail, &sTime, &sSize,
+ &oiAvail, &oiTime, &oSize, &iSize
);
if (!ok) goto cant_find;
- if (!sAvail && !(iAvail && oAvail)) goto cant_find;
+ if (!sAvail && !oiAvail) goto cant_find;
/* Find out whether to use source or object. */
- if (varIsMember(mt,renewFromSource)) {
- if (!sAvail) goto cant_find;
- useSource = TRUE;
- } else
- if (varIsMember(mt,renewFromObject)) {
- if (!(oAvail && iAvail)) goto cant_find;
- useSource = FALSE;
- } else
- if (sAvail && !(iAvail && oAvail)) {
- useSource = TRUE;
- } else
- if (!sAvail && (iAvail && oAvail)) {
- useSource = FALSE;
- } else {
- useSource = firstTimeIsLater(sTime,whicheverIsLater(oTime,iTime));
+ 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");
}
- if (!combined && !sAvail) goto cant_find;
- if (!combined) useSource = TRUE;
-
/* 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).fromSrc = TRUE;
+ 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);
strcat(name, ".u_hi");
module(mod).tree = parseInterface(name,iSize);
module(mod).uses = getInterfaceImports(module(mod).tree);
- module(mod).fromSrc = FALSE;
- module(mod).lastStamp = whicheverIsLater(oTime,iTime);
+ module(mod).mode = FM_OBJECT;
+ module(mod).lastStamp = oiTime;
}
if (path) free(path);
cant_find:
if (path) free(path);
+ clearCurrentFile();
ERRMSG(0)
- "Can't find source or object+interface for module \"%s\"",
- textToStr(mt)
+ "Can't find %s for module \"%s\"",
+ modeToString(modeRequest), textToStr(mt)
EEND;
}
case GRP_NONREC:
m = findModule(textOf(snd(grp)));
assert(nonNull(m));
- if (module(m).fromSrc) {
+ 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).fromSrc) {
+ 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");
to do EENDs (ie, write error messages). Others should use
EEND_NO_LONGJMP.
*/
-static void achieveTargetModules ( void )
+static void achieveTargetModules ( Bool loadingThePrelude )
{
volatile List ood;
volatile List modgList;
- volatile List renewFromSource;
- volatile List renewFromObject;
volatile List t;
volatile Module mod;
volatile Bool ok;
String path = NULL;
String sExt = NULL;
- Bool sAvail; Time sTime; Long sSize;
- Bool iAvail; Time iTime; Long iSize;
- Bool oAvail; Time oTime; Long oSize;
+ Bool sAvail; Time sTime; Long sSize;
+ Bool oiAvail; Time oiTime; Long oSize; Long iSize;
volatile Time oisTime;
- volatile Time oiTime;
- volatile Bool sourceIsLatest;
volatile Bool out_of_date;
volatile List ood_new;
volatile List us;
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();
- renewFromSource = renewFromObject = NIL;
-
for (t = modgList; nonNull(t); t=tl(t)) {
if (varIsMember(textOf(hd(t)),prelModules))
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,
- &iAvail, &iTime, &iSize,
- &oAvail, &oTime, &oSize
+ &sAvail, &sTime, &sSize,
+ &oiAvail, &oiTime, &oSize, &iSize
);
+
if (!combined && !sAvail) ok = FALSE;
if (!ok) {
fallBackToPrelModules();
if (path) free(path);
return;
}
- /* findFilesForModule should enforce this */
- if (!(sAvail || (oAvail && iAvail)))
- internal("achieveTargetSet(2)");
- if (!combined) {
+ if (sAvail && oiAvail) {
+ oisTime = whicheverIsLater(sTime,oiTime);
+ }
+ else if (sAvail && !oiAvail) {
oisTime = sTime;
- sourceIsLatest = TRUE;
- } else {
- if (sAvail && !(oAvail && iAvail)) {
- oisTime = sTime;
- sourceIsLatest = TRUE;
- } else
- if (!sAvail && (oAvail && iAvail)) {
- oisTime = whicheverIsLater(oTime,iTime);
- sourceIsLatest = FALSE;
- } else
- if (sAvail && (oAvail && iAvail)) {
- oisTime = whicheverIsLater(oTime,iTime);
- if (firstTimeIsLater(sTime,oisTime)) {
- oisTime = sTime;
- sourceIsLatest = TRUE;
- } else {
- sourceIsLatest = FALSE;
- }
- } else {
- internal("achieveTargetSet(1a)");
- }
+ }
+ 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 (sourceIsLatest)
- renewFromSource = cons(hd(t),renewFromSource); else
- renewFromObject = cons(hd(t),renewFromObject);
}
if (path) { free(path); path = NULL; };
if (varIsMember(textOf(hd(us)),ood))
break;
if (nonNull(us)) {
-fprintf ( stderr, "new OOD %s\n", textToStr(textOf(hd(t))) );
if (varIsMember(textOf(hd(t)),prelModules))
Printf ( "warning: prelude module \"%s\" is out-of-date\n",
textToStr(textOf(hd(t))) );
ood_new = cons(hd(t),ood_new);
}
}
-printf ( "\nood_new = " );print(ood_new,100);
-printf ( "\nood = " );print(ood,100); printf("\n");
if (isNull(ood_new)) break;
ood = appendOnto(ood_new,ood);
}
/* Parse modules/interfaces, collecting parse trees and chasing
imports, starting from the target set.
*/
- parsedButNotLoaded = NIL;
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 = hd(toChase);
- toChase = tl(toChase);
- if (!varIsMember(textOf(mc),modgList)
- && !varIsMember(textOf(mc),parsedButNotLoaded)) {
+ 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, renewFromSource, renewFromObject );
+ 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));
return;
/* end of the exception handler */
}
+ setBreakAction ( HugsIgnoreBreak );
parsedButNotLoaded = cons(mc, parsedButNotLoaded);
- toChase = dupOnto(module(mod).uses,toChase);
+ for (t = module(mod).uses; nonNull(t); t=tl(t))
+ toChase = cons(
+ zpair( hd(t), childMode(mode,module(mod).mode) ),
+ toChase);
}
}
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 */
- badMods = whatIs(grp)==GRP_REC
- ? snd(grp)
- : singleton(snd(grp));
+ /* 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);
}
- mg2 = moduleGraph;
- while (nonNull(mg2) && nonNull(tl(mg2)) && tl(mg2) != mg)
- mg2 = tl(mg2);
- assert(nonNull(mg2) && nonNull(tl(mg2)));
- tl(mg2) = NIL;
+ /* 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 );
}
conPrelude = mkCon(findText("Prelude"));
conPrelHugs = mkCon(findText("PrelHugs"));
targetModules = doubleton(conPrelude,conPrelHugs);
- achieveTargetModules();
+ achieveTargetModules(TRUE);
ok = elemMG(conPrelude) && elemMG(conPrelHugs);
} else {
conPrelude = mkCon(findText("Prelude"));
targetModules = singleton(conPrelude);
- achieveTargetModules();
+ achieveTargetModules(TRUE);
ok = elemMG(conPrelude);
}
}
-static void refreshActions ( ConId nextCurrMod )
+/* 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 )
{
- ConId tryFor = mkCon(module(currentModule).text);
- achieveTargetModules();
+ 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();
targetModules = cons(extra,targetModules);
}
refreshActions ( isNull(extraModules)
- ? NIL
- : hd(reverse(extraModules))
+ ? NIL
+ : hd(reverse(extraModules)),
+ TRUE
);
}
targetModules = cons(load,targetModules);
}
refreshActions ( isNull(loadModules)
- ? NIL
- : hd(reverse(loadModules))
+ ? NIL
+ : hd(reverse(loadModules)),
+ TRUE
);
}
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;
}
volatile Module evalMod = allocEvalModule();
volatile Module currMod = currentModule;
setCurrModule(evalMod);
- scriptFile = 0;
+ currentFile = NULL;
defaultDefns = combined ? stdDefaults : evalDefaults;
+ setBreakAction ( HugsLongjmpOnBreak );
if (setjmp(catch_error)==0) {
/* try this */
parseExp();
type = typeCheckExp(TRUE);
} else {
/* if an exception happens, we arrive here */
+ setBreakAction ( HugsIgnoreBreak );
goto cleanup_and_return;
}
+ setBreakAction ( HugsIgnoreBreak );
if (isPolyType(type)) {
ks = polySigOf(type);
bd = monotypeOf(type);
bd = type;
if (whatIs(bd)==QUAL) {
+ clearCurrentFile();
ERRMSG(0) "Unresolved overloading" ETHEN
ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
} else {
Cell d = provePred(ks,NIL,ap(classShow,bd));
if (isNull(d)) {
+ clearCurrentFile();
ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
#endif
cleanup_and_return:
+ setBreakAction ( HugsIgnoreBreak );
nukeModule(evalMod);
setCurrModule(currMod);
+ setCurrentFile(currMod);
}
names = addNamesMatching((String)0,names);
}
if (isNull(names)) { /* Then print them out */
+ clearCurrentFile();
ERRMSG(0) "No names selected"
EEND_NO_LONGJMP;
return;
Bool prelOK;
String s;
- breakOn(TRUE); /* enable break trapping */
+ setBreakAction ( HugsIgnoreBreak );
modConIds = initialize(argc,argv); /* the initial modules to load */
+ setBreakAction ( HugsIgnoreBreak );
prelOK = loadThePrelude();
- if (combined) everybody(POSTPREL);
if (!prelOK) {
if (autoMain)
exit(1);
}
+ if (combined) everybody(POSTPREL);
loadActions(modConIds);
if (autoMain) {
modConIds = NIL;
/* initialize calls startupHaskell, which trashes our signal handlers */
- breakOn(TRUE);
+ setBreakAction ( HugsIgnoreBreak );
forHelp();
for (;;) {
addActions(modConIds);
modConIds = NIL;
break;
- case RELOAD : refreshActions(NIL);
+ case RELOAD : refreshActions(NIL,FALSE);
break;
case SETMODULE :
setModule();
if (autoMain) break;
}
- breakOn(FALSE);
}
/* --------------------------------------------------------------------------
Cell errAssert(l) /* message to use when raising asserts, etc */
Int l; {
- char tmp[100];
Cell str;
- if (scriptFile) {
- str = mkStr(findText(scriptFile));
+ if (currentFile) {
+ str = mkStr(findText(currentFile));
} else {
str = mkStr(findText(""));
}
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);
exit(1);
}
-sigHandler(breakHandler) { /* respond to break interrupt */
- 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.
* ------------------------------------------------------------------------*/
+#ifdef HAVE_STDARG_H
+#include <stdarg.h>
+#else
+#include <varargs.h>
+#endif
+
+Void hugsEnableOutput(f)
+Bool f; {
+ disableOutput = !f;
+}
+
+#ifdef HAVE_STDARG_H
+Void hugsPrintf(const char *fmt, ...) {
+ va_list ap; /* pointer into argument list */
+ va_start(ap, fmt); /* make ap point to first arg after fmt */
+ if (!disableOutput) {
+ vprintf(fmt, ap);
+ } else {
+ }
+ va_end(ap); /* clean up */
+}
+#else
+Void hugsPrintf(fmt, va_alist)
+const char *fmt;
+va_dcl {
+ va_list ap; /* pointer into argument list */
+ va_start(ap); /* make ap point to first arg after fmt */
+ if (!disableOutput) {
+ vprintf(fmt, ap);
+ } else {
+ }
+ va_end(ap); /* clean up */
+}
+#endif
+
+Void hugsPutchar(c)
+int c; {
+ if (!disableOutput) {
+ putchar(c);
+ } else {
+ }
+}
+
+Void hugsFlushStdout() {
+ if (!disableOutput) {
+ fflush(stdout);
+ }
+}
+
+Void hugsFFlush(fp)
+FILE* fp; {
+ if (!disableOutput) {
+ fflush(fp);
+ }
+}
+
+#ifdef HAVE_STDARG_H
+Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
+ va_list ap;
+ va_start(ap, fmt);
+ if (!disableOutput) {
+ vfprintf(fp, fmt, ap);
+ } else {
+ }
+ va_end(ap);
+}
+#else
+Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
+FILE* fp;
+const char* fmt;
+va_dcl {
+ va_list ap;
+ va_start(ap);
+ if (!disableOutput) {
+ vfprintf(fp, fmt, ap);
+ } else {
+ }
+ va_end(ap);
+}
+#endif
+
+Void hugsPutc(c, fp)
+int c;
+FILE* fp; {
+ if (!disableOutput) {
+ putc(c,fp);
+ } else {
+ }
+}
+
/* --------------------------------------------------------------------------
* Send message to each component of system:
* ------------------------------------------------------------------------*/
typeChecker(what);
compiler(what);
codegen(what);
+
+ if (what == MARK) {
+ mark(moduleGraph);
+ mark(prelModules);
+ mark(targetModules);
+ mark(daSccs);
+ mark(currentModule_failed);
+ }
}
/*-------------------------------------------------------------------------*/
projects / ghc-hetmet.git / blobdiff