X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fhugs.c;h=e2507bcaf4d97f1f8b929d77e07a47c932147888;hb=e4706792d290d4c5cb6a020d2973689efb7457ff;hp=d596aa9a6a5f07383b7250a20538cae836328a37;hpb=300f02db67de8e69886035a6090c31ac0f279737;p=ghc-hetmet.git diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index d596aa9..e2507bc 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: hugs.c,v $ - * $Revision: 1.48 $ - * $Date: 2000/03/24 12:36:43 $ + * $Revision: 1.67 $ + * $Date: 2000/04/17 11:39:23 $ * ------------------------------------------------------------------------*/ #include @@ -29,6 +29,7 @@ #include "Assembler.h" /* DEBUG_LoadSymbols */ Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/ +Bool initDone = FALSE; #if EXPLAIN_INSTANCE_RESOLUTION Bool showInstRes = FALSE; @@ -69,9 +70,6 @@ static Void local listNames ( Void ); 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 ); @@ -82,6 +80,8 @@ 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: @@ -107,25 +107,24 @@ static Bool lastWasObject = FALSE; Bool debugSC = FALSE; Bool combined = FALSE; - char* currentFile; /* Name of current file, or NULL */ -static char currentFileName[1000]; /* name is stored here if it exists*/ - - - -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: @@ -206,12 +205,9 @@ char *argv[]; { * 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); @@ -225,19 +221,8 @@ String argv[]; { #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]; @@ -247,24 +232,37 @@ String argv[]; { } # 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; } } @@ -284,6 +282,17 @@ String argv[]; { " 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; } @@ -308,8 +317,9 @@ Bool state; { *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*/ @@ -378,65 +388,6 @@ ToDo 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 @@ -500,7 +451,8 @@ String s; { /* return FALSE if none found. */ 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 @@ -515,7 +467,7 @@ String s; { /* return FALSE if none found. */ } default : if (strcmp("98",s)==0) { - if (heapBuilt() && ((state && !haskell98) || + if (initDone && ((state && !haskell98) || (!state && haskell98))) { FPrintf(stderr, "Haskell 98 compatibility cannot be changed" @@ -540,13 +492,9 @@ String s; { 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; } @@ -708,12 +656,9 @@ static Void local set() { /* change command line options from*/ do { if (!processOption(s)) { ERRMSG(0) "Option string must begin with `+' or `-'" - EEND; + EEND_NO_LONGJMP; } } while ((s=readFilename())!=0); -#if USE_REGISTRY - writeRegString("Options", optionsToStr()); -#endif } else optionInfo(); @@ -727,26 +672,109 @@ static Void local changeDir() { /* change directory */ 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; + currentFile = currentFileName; + moduleBeingParsed = mod; +} + +static void clearCurrentFile ( void ) +{ + currentFile = NULL; + moduleBeingParsed = NIL; } static void ppMG ( void ) @@ -756,13 +784,13 @@ 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"); @@ -860,8 +888,9 @@ static void mgFromList ( List /* of CONID */ modgList ) usesT = NIL; for (u = module(mod).uses; nonNull(u); u=tl(u)) usesT = cons(textOf(hd(u)),usesT); - /* artifically give all modules a dependency on Prelude */ - if (mT != textPrelude) + + /* artificially give all modules a dependency on Prelude */ + if (mT != textPrelude && mT != textPrelPrim) usesT = cons(textPrelude,usesT); adjList = cons(pair(mT,usesT),adjList); } @@ -975,7 +1004,15 @@ static void processModule ( Module 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); @@ -991,23 +1028,23 @@ static void processModule ( Module m ) 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); @@ -1022,17 +1059,14 @@ static void processModule ( Module m ) } -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]; @@ -1055,48 +1089,46 @@ static Module parseModuleOrInterface ( ConId mc, 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; - - module(mod).srcExt = findText(sExt); - setCurrentFile(mod); - /* 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); @@ -1107,8 +1139,8 @@ static Module parseModuleOrInterface ( ConId mc, 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); @@ -1116,9 +1148,10 @@ static Module parseModuleOrInterface ( ConId mc, 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; } @@ -1131,23 +1164,32 @@ static void tryLoadGroup ( Cell grp ) 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"); @@ -1171,25 +1213,20 @@ static void fallBackToPrelModules ( void ) 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; @@ -1204,14 +1241,14 @@ static void achieveTargetModules ( void ) 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)) @@ -1220,14 +1257,15 @@ static void achieveTargetModules ( void ) 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(); @@ -1238,42 +1276,24 @@ static void achieveTargetModules ( void ) 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; }; @@ -1329,22 +1349,50 @@ static void achieveTargetModules ( void ) /* 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)) { @@ -1355,9 +1403,13 @@ static void achieveTargetModules ( void ) 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); } } @@ -1417,6 +1469,7 @@ static void achieveTargetModules ( void ) if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)), parsedButNotLoaded)) continue; + setBreakAction ( HugsLongjmpOnBreak ); if (setjmp(catch_error)==0) { /* try this; it may throw an exception */ tryLoadGroup(grp); @@ -1424,6 +1477,7 @@ static void achieveTargetModules ( void ) /* 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))); @@ -1442,12 +1496,13 @@ static void achieveTargetModules ( void ) 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 ); } @@ -1462,12 +1517,12 @@ static Bool loadThePrelude ( void ) 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); } @@ -1476,18 +1531,58 @@ static Bool loadThePrelude ( void ) } -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(); @@ -1503,8 +1598,9 @@ static void addActions ( List extraModules /* :: [CONID] */ ) targetModules = cons(extra,targetModules); } refreshActions ( isNull(extraModules) - ? NIL - : hd(reverse(extraModules)) + ? NIL + : hd(reverse(extraModules)), + TRUE ); } @@ -1520,8 +1616,9 @@ static void loadActions ( List loadModules /* :: [CONID] */ ) targetModules = cons(load,targetModules); } refreshActions ( isNull(loadModules) - ? NIL - : hd(reverse(loadModules)) + ? NIL + : hd(reverse(loadModules)), + TRUE ); } @@ -1629,6 +1726,8 @@ static Module allocEvalModule ( void ) 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; } @@ -1643,6 +1742,7 @@ static Void local evaluator() { /* evaluate expr and print value */ defaultDefns = combined ? stdDefaults : evalDefaults; + setBreakAction ( HugsLongjmpOnBreak ); if (setjmp(catch_error)==0) { /* try this */ parseExp(); @@ -1650,9 +1750,11 @@ static Void local evaluator() { /* evaluate expr and print value */ 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); @@ -1661,6 +1763,7 @@ static Void local evaluator() { /* evaluate expr and print value */ bd = type; if (whatIs(bd)==QUAL) { + clearCurrentFile(); ERRMSG(0) "Unresolved overloading" ETHEN ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type); ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr); @@ -1677,6 +1780,7 @@ static Void local evaluator() { /* evaluate expr and print value */ } 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); @@ -1707,6 +1811,7 @@ static Void local evaluator() { /* evaluate expr and print value */ #endif cleanup_and_return: + setBreakAction ( HugsIgnoreBreak ); nukeModule(evalMod); setCurrModule(currMod); setCurrentFile(currMod); @@ -2199,6 +2304,7 @@ static Void local listNames() { /* list names matching optional pat*/ names = addNamesMatching((String)0,names); } if (isNull(names)) { /* Then print them out */ + clearCurrentFile(); ERRMSG(0) "No names selected" EEND_NO_LONGJMP; return; @@ -2258,10 +2364,10 @@ String argv[]; { 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) @@ -2271,6 +2377,7 @@ String argv[]; { exit(1); } + if (combined) everybody(POSTPREL); loadActions(modConIds); if (autoMain) { @@ -2285,7 +2392,7 @@ String argv[]; { modConIds = NIL; /* initialize calls startupHaskell, which trashes our signal handlers */ - breakOn(TRUE); + setBreakAction ( HugsIgnoreBreak ); forHelp(); for (;;) { @@ -2312,7 +2419,7 @@ String argv[]; { addActions(modConIds); modConIds = NIL; break; - case RELOAD : refreshActions(NIL); + case RELOAD : refreshActions(NIL,FALSE); break; case SETMODULE : setModule(); @@ -2364,7 +2471,6 @@ String argv[]; { if (autoMain) break; } - breakOn(FALSE); } /* -------------------------------------------------------------------------- @@ -2476,7 +2582,6 @@ static Void local stopAnyPrinting() { /* terminate printing of expression,*/ Cell errAssert(l) /* message to use when raising asserts, etc */ Int l; { - char tmp[100]; Cell str; if (currentFile) { str = mkStr(findText(currentFile)); @@ -2537,20 +2642,6 @@ String msg; { 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: @@ -2582,12 +2673,103 @@ String s; { return NULL; } + /* -------------------------------------------------------------------------- * Compiler output * We can redirect compiler output (prompts, error messages, etc) by * tweaking these functions. * ------------------------------------------------------------------------*/ +#ifdef HAVE_STDARG_H +#include +#else +#include +#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: * ------------------------------------------------------------------------*/ @@ -2608,6 +2790,14 @@ Int what; { /* system to respond as appropriate ... */ typeChecker(what); compiler(what); codegen(what); + + if (what == MARK) { + mark(moduleGraph); + mark(prelModules); + mark(targetModules); + mark(daSccs); + mark(currentModule_failed); + } } /*-------------------------------------------------------------------------*/