X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fhugs.c;h=e2507bcaf4d97f1f8b929d77e07a47c932147888;hb=e4706792d290d4c5cb6a020d2973689efb7457ff;hp=08dfe07113b0c68533b449fd3f7346298885d3b7;hpb=8931116063aaf06ed2759e2b2ca2e554cfa7124f;p=ghc-hetmet.git diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index 08dfe07..e2507bc 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -2,136 +2,129 @@ /* -------------------------------------------------------------------------- * Command interpreter * - * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale - * Haskell Group 1994-99, and is distributed as Open Source software - * under the Artistic License; see the file "Artistic" that is included - * in the distribution for details. + * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the + * Yale Haskell Group, and the Oregon Graduate Institute of Science and + * Technology, 1994-1999, All rights reserved. It is distributed as + * free software under the license in the file "License", which is + * included in the distribution. * * $RCSfile: hugs.c,v $ - * $Revision: 1.4 $ - * $Date: 1999/03/01 14:46:45 $ + * $Revision: 1.67 $ + * $Date: 2000/04/17 11:39:23 $ * ------------------------------------------------------------------------*/ #include #include #include -#include "prelude.h" +#include "hugsbasictypes.h" #include "storage.h" -#include "command.h" -#include "backend.h" #include "connect.h" #include "errors.h" #include "version.h" -#include "link.h" #include "Rts.h" #include "RtsAPI.h" #include "Schedule.h" - +#include "Assembler.h" /* DEBUG_LoadSymbols */ Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/ +Bool initDone = FALSE; + +#if EXPLAIN_INSTANCE_RESOLUTION +Bool showInstRes = FALSE; +#endif +#if MULTI_INST +Bool multiInstRes = FALSE; +#endif /* -------------------------------------------------------------------------- * Local function prototypes: * ------------------------------------------------------------------------*/ -static Void local initialize Args((Int,String [])); -static Void local promptForInput Args((String)); -static Void local interpreter Args((Int,String [])); -static Void local menu Args((Void)); -static Void local guidance Args((Void)); -static Void local forHelp Args((Void)); -static Void local set Args((Void)); -static Void local changeDir Args((Void)); -static Void local load Args((Void)); -static Void local project Args((Void)); -static Void local readScripts Args((Int)); -static Void local whatScripts Args((Void)); -static Void local editor Args((Void)); -static Void local find Args((Void)); -static Bool local startEdit Args((Int,String)); -static Void local runEditor Args((Void)); -#if IGNORE_MODULES -#define findEvalModule() doNothing() -#else -static Void local setModule Args((Void)); -static Module local findEvalModule Args((Void)); -#endif -static Void local evaluator Args((Void)); -static Void local stopAnyPrinting Args((Void)); -static Void local showtype Args((Void)); -static String local objToStr Args((Module, Cell)); -static Void local info Args((Void)); -static Void local printSyntax Args((Name)); -static Void local showInst Args((Inst)); -static Void local describe Args((Text)); -static Void local listNames Args((Void)); - -static Void local toggleSet Args((Char,Bool)); -static Void local togglesIn Args((Bool)); -static Void local optionInfo Args((Void)); -#if USE_REGISTRY || HUGS_FOR_WINDOWS -static String local optionsToStr Args((Void)); -#endif -static Void local readOptions Args((String)); -static Bool local processOption Args((String)); -static Void local setHeapSize Args((String)); -static Int local argToInt Args((String)); - -static Void local loadProject Args((String)); -static Void local clearProject Args((Void)); -static Void local addScriptName Args((String,Bool)); -static Bool local addScript Args((String,Long)); -static Void local forgetScriptsFrom Args((Script)); -static Void local setLastEdit Args((String,Int)); -static Void local failed Args((Void)); -static String local strCopy Args((String)); +static List local initialize ( Int,String [] ); +static Void local promptForInput ( String ); +static Void local interpreter ( Int,String [] ); +static Void local menu ( Void ); +static Void local guidance ( Void ); +static Void local forHelp ( Void ); +static Void local set ( Void ); +static Void local changeDir ( Void ); +static Void local load ( Void ); +static Void local project ( Void ); +static Void local editor ( Void ); +static Void local find ( Void ); +static Bool local startEdit ( Int,String ); +static Void local runEditor ( Void ); +static Void local setModule ( Void ); +static Void local evaluator ( Void ); +static Void local stopAnyPrinting ( Void ); +static Void local showtype ( Void ); +static String local objToStr ( Module, Cell ); +static Void local info ( Void ); +static Void local printSyntax ( Name ); +static Void local showInst ( Inst ); +static Void local describe ( Text ); +static Void local listNames ( Void ); + +static Void local toggleSet ( Char,Bool ); +static Void local togglesIn ( Bool ); +static Void local optionInfo ( Void ); +static Void local readOptions ( String ); +static Bool local processOption ( String ); +static Void local setHeapSize ( String ); +static Int local argToInt ( String ); + +static Void local setLastEdit ( String,Int ); +static Void local failed ( Void ); +static String local strCopy ( String ); +static Void local browseit ( Module,String,Bool ); +static Void local browse ( Void ); +static void local clearCurrentFile ( void ); + /* -------------------------------------------------------------------------- * Machine dependent code for Hugs interpreter: * ------------------------------------------------------------------------*/ #include "machdep.c" -#ifdef WANT_TIMER -#include "timer.c" -#endif /* -------------------------------------------------------------------------- * Local data areas: * ------------------------------------------------------------------------*/ -static Bool printing = FALSE; /* TRUE => currently printing value*/ -static Bool showStats = FALSE; /* TRUE => print stats after eval */ -static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/ -static Bool addType = FALSE; /* TRUE => print type with value */ -static Bool chaseImports = TRUE; /* TRUE => chase imports on load */ -static Bool useDots = RISCOS; /* TRUE => use dots in progress */ -static Bool quiet = FALSE; /* TRUE => don't show progress */ - -static String scriptName[NUM_SCRIPTS]; /* Script file names */ -static Time lastChange[NUM_SCRIPTS]; /* Time of last change to script */ -static Bool postponed[NUM_SCRIPTS]; /* Indicates postponed load */ -static Int scriptBase; /* Number of scripts in Prelude */ -static Int numScripts; /* Number of scripts loaded */ -static Int namesUpto; /* Number of script names set */ -static Bool needsImports; /* set to TRUE if imports required */ - String scriptFile; /* Name of current script (if any) */ - -static Text evalModule = 0; /* Name of module we eval exprs in */ -static String currProject = 0; /* Name of current project file */ -static Bool projectLoaded = FALSE; /* TRUE => project file loaded */ - +static Bool printing = FALSE; /* TRUE => currently printing value*/ +static Bool showStats = FALSE; /* TRUE => print stats after eval */ +static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/ +static Bool addType = FALSE; /* TRUE => print type with value */ +static Bool useDots = RISCOS; /* TRUE => use dots in progress */ +static Bool quiet = FALSE; /* TRUE => don't show progress */ +static Bool lastWasObject = FALSE; + + Bool flagAssert = FALSE; /* TRUE => assert False causes + an assertion failure */ + Bool preludeLoaded = FALSE; + Bool debugSC = FALSE; + Bool combined = FALSE; + + Module moduleBeingParsed; /* so the parser (topModule) knows */ +static char* currentFile; /* Name of current file, or NULL */ +static char currentFileName[1000]; /* name is stored here if it exists*/ + +static Bool autoMain = FALSE; static String lastEdit = 0; /* Name of script to edit (if any) */ static Int lastEdLine = 0; /* Editor line number (if possible)*/ static String prompt = 0; /* Prompt string */ static Int hpSize = DEFAULTHEAP; /* Desired heap size */ -String hugsEdit = 0; /* String for editor command */ -String hugsPath = 0; /* String for file search path */ +static Bool disableOutput = FALSE; /* TRUE => quiet */ + String hugsEdit = 0; /* String for editor command */ + String hugsPath = 0; /* String for file search path */ + + List ifaces_outstanding = NIL; + +static ConId currentModule_failed = NIL; /* Remember failed module from :r */ + -#if REDIRECT_OUTPUT -static Bool disableOutput = FALSE; /* redirect output to buffer? */ -#endif /* -------------------------------------------------------------------------- * Hugs entry point: @@ -139,7 +132,7 @@ static Bool disableOutput = FALSE; /* redirect output to buffer? */ #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; @@ -163,12 +156,34 @@ char *argv[]; { CStackBase = &argc; /* Save stack base for use in gc */ - Printf("__ __ __ __ ____ ___ _______________________________________________\n"); - Printf("|| || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system\n"); - Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n"); - Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n"); - Printf("|| || Report bugs to: hugs-bugs@haskell.org\n"); - Printf("|| || Version: %s _______________________________________________\n\n",HUGS_VERSION); +#ifdef DEBUG +#if 0 + checkBytecodeCount(); /* check for too many bytecodes */ +#endif +#endif + + /* If first arg is +Q or -Q, be entirely silent, and automatically run + main after loading scripts. Useful for running the nofib suite. */ + if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) { + autoMain = TRUE; + if (strcmp(argv[1],"-Q") == 0) { + EnableOutput(0); + } + } + + Printf("__ __ __ __ ____ ___ _________________________________________\n"); + Printf("|| || || || || || ||__ STGHugs: Based on the Haskell 98 standard\n"); + Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n"); + Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n"); + Printf("|| || Report bugs to: hugs-bugs@haskell.org\n"); + Printf("|| || Version: %s _________________________________________\n\n",HUGS_VERSION); + + /* Get the absolute path to the directory containing the hugs + executable, so that we know where the Prelude and nHandle.so/.dll are. + We do this by reading env var STGHUGSDIR. This needs to succeed, so + setInstallDir won't return unless it succeeds. + */ + setInstallDir ( argv[0] ); #if SYMANTEC_C Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n"); @@ -190,79 +205,95 @@ char *argv[]; { * Initialization, interpret command line args and read prelude: * ------------------------------------------------------------------------*/ -static Void local initialize(argc,argv)/* Interpreter initialization */ -Int argc; -String argv[]; { - Script i; - String proj = 0; - - setLastEdit((String)0,0); - lastEdit = 0; - scriptFile = 0; - numScripts = 0; - namesUpto = 1; - -#if HUGS_FOR_WINDOWS - hugsEdit = strCopy(fromEnv("EDITOR","c:\\windows\notepad.exe")); -#elif SYMANTEC_C - hugsEdit = ""; -#else - hugsEdit = strCopy(fromEnv("EDITOR",NULL)); -#endif - hugsPath = strCopy(HUGSPATH); readOptions("-p\"%s> \" -r$$"); -#if USE_REGISTRY - projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot, - "HUGSPATH", PATHSEP, "")); - readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options","")); - readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options","")); -#endif /* USE_REGISTRY */ - readOptions(fromEnv("HUGSFLAGS","")); - - startupHaskell ( argc, argv ); - argc = prog_argc; argv = prog_argv; - - for (i=1; i1) { - fprintf(stderr, - "\nUsing project file, ignoring additional filenames\n"); - } - loadProject(strCopy(proj)); - } - readScripts(0); - scriptBase = numScripts; +#if SYMANTEC_C + hugsEdit = ""; +#else + hugsEdit = strCopy(fromEnv("EDITOR",NULL)); +#endif + hugsPath = strCopy(HUGSPATH); + readOptions("-p\"%s> \" -r$$"); + readOptions(fromEnv("STGHUGSFLAGS","")); + +# if DEBUG + { + char exe_name[N_INSTALLDIR + 6]; + strcpy(exe_name, installDir); + strcat(exe_name, "hugs"); + DEBUG_LoadSymbols(exe_name); + } +# endif + + /* startupHaskell extracts args between +RTS ... -RTS, and sets + prog_argc/prog_argv to the rest. We want to further process + the rest, so we then get hold of them again. + */ + startupHaskell ( argc, argv, NULL ); + getProgArgv ( &argc, &argv ); + + /* Find out early on if we're in combined mode or not. + everybody(PREPREL) needs to know this. Also, establish the + heap size; + */ + for (i = 1; i < argc; ++i) { + if (strcmp(argv[i], "--")==0) break; + if (strcmp(argv[i], "-c")==0) combined = FALSE; + if (strcmp(argv[i], "+c")==0) combined = TRUE; + + if (strncmp(argv[i],"+h",2)==0 || strncmp(argv[i],"-h",2)==0) + setHeapSize(&(argv[i][2])); + } + + everybody(PREPREL); + initialModules = NIL; + + for (i = 1; i < argc; ++i) { /* process command line arguments */ + if (strcmp(argv[i], "--")==0) + { argv[i] = NULL; break; } + if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/) { + if (!processOption(argv[i])) + initialModules + = cons ( mkCon(findText(argv[i])), initialModules ); + argv[i] = NULL; + } + } + + if (haskell98) { + Printf("Haskell 98 mode: Restart with command line option -98" + " to enable extensions\n"); + } else { + Printf("Hugs mode: Restart with command line option +98 for" + " Haskell 98 mode\n"); + } + + if (combined) { + Printf("Combined mode: Restart with command line -c for" + " standalone mode\n\n" ); + } else { + Printf("Standalone mode: Restart with command line +c for" + " combined mode\n\n" ); + } + + /* slide args back over the deleted ones. */ + j = 1; + for (i = 1; i < argc; i++) + if (argv[i]) + argv[j++] = argv[i]; + + argc = j; + + setProgArgv ( argc, argv ); + + initDone = TRUE; + return initialModules; } /* -------------------------------------------------------------------------- @@ -271,6 +302,7 @@ String argv[]; { struct options { /* command line option toggles */ char c; /* table defined in main app. */ + int h98; String description; Bool *flag; }; @@ -285,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*/ @@ -294,7 +327,7 @@ Bool state; { /* given state */ Int count = 0; Int i; for (i=0; toggle[i].c; ++i) - if (*toggle[i].flag == state) { + if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) { if (count==0) Putchar((char)(state ? '+' : '-')); Putchar(toggle[i].c); @@ -310,8 +343,11 @@ static Void local optionInfo() { /* Print information about command */ Int i; Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n"); - for (i=0; toggle[i].c; ++i) - Printf(fmtc,toggle[i].c,toggle[i].description); + for (i=0; toggle[i].c; ++i) { + if (!haskell98 || toggle[i].h98) { + Printf(fmtc,toggle[i].c,toggle[i].description); + } + } Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n"); Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)"); @@ -323,9 +359,6 @@ static Void local optionInfo() { /* Print information about command */ #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN)) Printf(fmts,"Fstr","Set preprocessor filter to str"); #endif -#if PROFILING - Printf(fmts,"dnum","Gather profiling statistics every reductions\n"); -#endif Printf("\nCurrent settings: "); togglesIn(TRUE); @@ -350,75 +383,11 @@ ToDo Printf("\nPreprocessor : -F"); printString(preprocessor); #endif -#if PROFILING - Printf("\nProfile interval: -d%d", profiling ? profInterval : 0); -#endif - Printf("\nCompatibility : %s", haskell98 ? "Haskell 98" - : "Hugs Extensions"); + Printf("\nCompatibility : %s", haskell98 ? "Haskell 98 (+98)" + : "Hugs Extensions (-98)"); Putchar('\n'); } -#if USE_REGISTRY || HUGS_FOR_WINDOWS -#define PUTC(c) \ - *next++=(c) - -#define PUTS(s) \ - strcpy(next,s); \ - next+=strlen(next) - -#define PUTInt(optc,i) \ - sprintf(next,"-%c%d",optc,i); \ - next+=strlen(next) - -#define PUTStr(c,s) \ - next=PUTStr_aux(next,c,s) - -static String local PUTStr_aux Args((String,Char, String)); - -static String local PUTStr_aux(next,c,s) -String next; -Char c; -String s; { - if (s) { - String t = 0; - sprintf(next,"-%c\"",c); - next+=strlen(next); - for(t=s; *t; ++t) { - PUTS(unlexChar(*t,'"')); - } - next+=strlen(next); - PUTS("\" "); - } - return next; -} - -static String local optionsToStr() { /* convert options to string */ - static char buffer[2000]; - String next = buffer; - - Int i; - for (i=0; toggle[i].c; ++i) { - PUTC(*toggle[i].flag ? '+' : '-'); - PUTC(toggle[i].c); - PUTC(' '); - } - PUTInt('h',hpSize); PUTC(' '); - PUTStr('p',prompt); - PUTStr('r',repeatStr); - PUTStr('P',hugsPath); - PUTStr('E',hugsEdit); - PUTInt('c',cutoff); PUTC(' '); -#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN)) - PUTStr('F',preprocessor); -#endif -#if PROFILING - PUTInt('d',profiling ? profInterval : 0); -#endif - PUTC('\0'); - return buffer; -} -#endif /* USE_REGISTRY */ - #undef PUTC #undef PUTS #undef PUTInt @@ -451,6 +420,8 @@ String s; { /* return FALSE if none found. */ while (*++s) switch (*s) { + case 'Q' : break; /* already handled */ + case 'p' : if (s[1]) { if (prompt) free(prompt); prompt = strCopy(s+1); @@ -480,10 +451,15 @@ 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 + will have got it already */ return TRUE; - case 'd' : /* hack */ + case 'D' : /* hack */ { extern void setRtsFlags( int x ); setRtsFlags(argToInt(s+1)); @@ -491,9 +467,11 @@ 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 while the interpreter is running\n"); + FPrintf(stderr, + "Haskell 98 compatibility cannot be changed" + " while the interpreter is running\n"); } else { haskell98 = state; } @@ -514,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,"Cannot change heap size\n"); -#endif + FPrintf(stderr,"You cannot change heap size from inside Hugs\n"); } else { heapSize = hpSize; } @@ -595,9 +569,13 @@ static struct cmd cmds[] = { {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT}, {":quit", QUIT}, {":set", SET}, {":find", FIND}, {":names", NAMES}, {":info", INFO}, {":project", PROJECT}, -#if !IGNORE_MODULES + {":dump", DUMP}, {":ztats", STATS}, {":module",SETMODULE}, + {":browse", BROWSE}, +#if EXPLAIN_INSTANCE_RESOLUTION + {":xplain", XPLAIN}, #endif + {":version", PNTVER}, {"", EVAL}, {0,0} }; @@ -612,9 +590,7 @@ static Void local menu() { Printf(":project use project file\n"); Printf(":edit edit file\n"); Printf(":edit edit last module\n"); -#if !IGNORE_MODULES Printf(":module set module for evaluating expressions\n"); -#endif Printf(" evaluate expression\n"); Printf(":type print type of expression\n"); Printf(":? display this list of commands\n"); @@ -622,10 +598,19 @@ static Void local menu() { Printf(":set help on command line options\n"); Printf(":names [pat] list names currently in scope\n"); Printf(":info describe named objects\n"); + Printf(":browse browse names defined in \n"); +#if EXPLAIN_INSTANCE_RESOLUTION + Printf(":xplain explain instance resolution for \n"); +#endif Printf(":find edit module containing definition of name\n"); Printf(":!command shell escape\n"); Printf(":cd dir change directory\n"); Printf(":gc force garbage collection\n"); + Printf(":version print Hugs version\n"); + Printf(":dump print STG code for named fn\n"); +#ifdef CRUDE_PROFILING + Printf(":ztats print reduction stats\n"); +#endif Printf(":quit exit Hugs interpreter\n"); } @@ -643,22 +628,25 @@ static Void local forHelp() { * ------------------------------------------------------------------------*/ struct options toggle[] = { /* List of command line toggles */ - {'s', "Print no. reductions/cells after eval", &showStats}, - {'t', "Print type after evaluation", &addType}, - /*ToDo?? {'f', "Terminate evaluation on first error", &failOnError},*/ - {'g', "Print no. cells recovered after gc", &gcMessages}, - {'l', "Literate modules as default", &literateScripts}, - {'e', "Warn about errors in literate modules", &literateErrors}, - {'.', "Print dots to show progress", &useDots}, - {'q', "Print nothing to show progress", &quiet}, - {'w', "Always show which modules are loaded", &listScripts}, - {'k', "Show kind errors in full", &kindExpert}, - {'o', "Allow overlapping instances", &allowOverlap}, - {'i', "Chase imports while loading modules", &chaseImports}, -#if DEBUG_CODE - {'D', "Debug: show generated code", &debugCode}, + {'s', 1, "Print no. reductions/cells after eval", &showStats}, + {'t', 1, "Print type after evaluation", &addType}, + {'g', 1, "Print no. cells recovered after gc", &gcMessages}, + {'l', 1, "Literate modules as default", &literateScripts}, + {'e', 1, "Warn about errors in literate modules", &literateErrors}, + {'.', 1, "Print dots to show progress", &useDots}, + {'q', 1, "Print nothing to show progress", &quiet}, + {'w', 1, "Always show which modules are loaded", &listScripts}, + {'k', 1, "Show kind errors in full", &kindExpert}, + {'o', 0, "Allow overlapping instances", &allowOverlap}, + {'S', 1, "Debug: show generated SC code", &debugSC}, + {'a', 1, "Raise exception on assert failure", &flagAssert}, +#if EXPLAIN_INSTANCE_RESOLUTION + {'x', 1, "Explain instance resolution", &showInstRes}, +#endif +#if MULTI_INST + {'m', 0, "Use multi instance resolution", &multiInstRes}, #endif - {0, 0, 0} + {0, 0, 0, 0} }; static Void local set() { /* change command line options from*/ @@ -668,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(); @@ -687,231 +672,965 @@ 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; } } + /* -------------------------------------------------------------------------- - * Loading project and script files: + * Interrupt handling * ------------------------------------------------------------------------*/ -static Void local loadProject(s) /* Load project file */ -String s; { - clearProject(); - currProject = s; - projInput(currProject); - scriptFile = currProject; - forgetScriptsFrom(scriptBase); - while ((s=readFilename())!=0) - addScriptName(s,TRUE); - if (namesUpto<=1) { - ERRMSG(0) "Empty project file" - EEND; - } - scriptFile = 0; - projectLoaded = TRUE; -} +static jmp_buf catch_error; /* jump buffer for error trapping */ -static Void local clearProject() { /* clear name for current project */ - if (currProject) - free(currProject); - currProject = 0; - projectLoaded = FALSE; -#if HUGS_FOR_WINDOWS - setLastEdit((String)0,0); -#endif -} +HugsBreakAction currentBreakAction = HugsIgnoreBreak; -static Void local addScriptName(s,sch) /* Add script to list of scripts */ -String s; /* to be read in ... */ -Bool sch; { /* TRUE => requires pathname search*/ - if (namesUpto>=NUM_SCRIPTS) { - ERRMSG(0) "Too many module files (maximum of %d allowed)", - NUM_SCRIPTS - EEND; - } - else - scriptName[namesUpto++] = strCopy(sch ? findPathname(NULL,s) : s); +static void handler_IgnoreBreak ( int sig ) +{ + setHandler ( handler_IgnoreBreak ); } -static Bool local addScript(fname,len) /* read single script file */ -String fname; /* name of script file */ -Long len; { /* length of script file */ - scriptFile = fname; - -#if HUGS_FOR_WINDOWS /* Set clock cursor while loading */ - allowBreak(); - SetCursor(LoadCursor(NULL, IDC_WAIT)); -#endif - - Printf("Reading file \"%s\":\n",fname); - setLastEdit(fname,0); - -#if 0 -ToDo: reinstate - if (isInterfaceFile(fname)) { - loadInterface(fname); - } else -#else - { - needsImports = FALSE; - parseScript(fname,len); /* process script file */ - if (needsImports) - return FALSE; - checkDefns(); - typeCheckDefns(); - compileDefns(); - } -#endif - scriptFile = 0; - return TRUE; +static void handler_LongjmpOnBreak ( int sig ) +{ + setHandler ( handler_LongjmpOnBreak ); + Printf("{Interrupted!}\n"); + longjmp(catch_error,1); } -Bool chase(imps) /* Process list of import requests */ -List imps; { - if (chaseImports) { - Int origPos = numScripts; /* keep track of original position */ - String origName = scriptName[origPos]; - for (; nonNull(imps); imps=tl(imps)) { - String iname = findPathname(origName,textToStr(textOf(hd(imps)))); - Int i = 0; - for (; i=origPos) { /* Neither loaded or queued */ - String theName; - Time theTime; - Bool thePost; - - postponed[origPos] = TRUE; - needsImports = TRUE; - - if (i>=namesUpto) /* Name not found (i==namesUpto) */ - addScriptName(iname,FALSE); - else if (postponed[i]) {/* Check for recursive dependency */ - ERRMSG(0) - "Recursive import dependency between \"%s\" and \"%s\"", - scriptName[origPos], iname - EEND; - } - /* Right rotate section of tables between numScripts and i so - * that i ends up with other imports in front of orig. script - */ - theName = scriptName[i]; - thePost = postponed[i]; - timeSet(theTime,lastChange[i]); - for (; i>numScripts; i--) { - scriptName[i] = scriptName[i-1]; - postponed[i] = postponed[i-1]; - timeSet(lastChange[i],lastChange[i-1]); - } - scriptName[numScripts] = theName; - postponed[numScripts] = thePost; - timeSet(lastChange[numScripts],theTime); - origPos++; - } - } - return needsImports; - } - return FALSE; +static void handler_RtsInterrupt ( int sig ) +{ + setHandler ( handler_RtsInterrupt ); + interruptStgRts(); } -static Void local forgetScriptsFrom(scno)/* remove scripts from system */ -Script scno; { - Script i; - for (i=scno; inamesUpto) - numScripts = scno; +HugsBreakAction setBreakAction ( HugsBreakAction newAction ) +{ + HugsBreakAction tmp = currentBreakAction; + currentBreakAction = newAction; + switch (newAction) { + case HugsIgnoreBreak: + setHandler ( handler_IgnoreBreak ); break; + case HugsLongjmpOnBreak: + setHandler ( handler_LongjmpOnBreak ); break; + case HugsRtsInterrupt: + setHandler ( handler_RtsInterrupt ); break; + default: + internal("setBreakAction"); + } + return tmp; } + /* -------------------------------------------------------------------------- - * Commands for loading and removing script files: + * The new module chaser, loader, etc * ------------------------------------------------------------------------*/ -static Void local load() { /* read filenames from command line */ - String s; /* and add to list of scripts waiting */ - /* to be read */ - while ((s=readFilename())!=0) - addScriptName(s,TRUE); - readScripts(scriptBase); -} - -static Void local project() { /* read list of script names from */ - String s; /* project file */ - - if ((s=readFilename()) || currProject) { - if (!s) - s = strCopy(currProject); - else if (readFilename()) { - ERRMSG(0) "Too many project files" - EEND; - } - else - s = strCopy(s); - } - else { - ERRMSG(0) "No project filename specified" - EEND; - } - loadProject(s); - readScripts(scriptBase); -} - -static Void local readScripts(n) /* Reread current list of scripts, */ -Int n; { /* loading everything after and */ - Time timeStamp; /* including the first script which*/ - Long fileSize; /* has been either changed or added*/ - -#if HUGS_FOR_WINDOWS - SetCursor(LoadCursor(NULL, IDC_WAIT)); -#endif - - for (; n 1) { + isRec = TRUE; + } else { + /* singleton module in scc; does it import itself? */ + mod = findModule ( textOf(hd(scc)) ); + assert(nonNull(mod)); + isRec = FALSE; + for (u = module(mod).uses; nonNull(u); u=tl(u)) + if (textOf(hd(u))==textOf(hd(scc))) + isRec = TRUE; + } + + if (isRec) + moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else + moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph ); + } + moduleGraph = reverse(moduleGraph); +} + + +static List /* of CONID */ getModuleImports ( Cell tree ) +{ + Cell te; + List tes; + ConId use; + List uses = NIL; + for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) { + te = hd(tes); + switch(whatIs(te)) { + case M_IMPORT_Q: + use = zfst(unap(M_IMPORT_Q,te)); + assert(isCon(use)); + if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses ); + break; + case M_IMPORT_UNQ: + use = zfst(unap(M_IMPORT_UNQ,te)); + assert(isCon(use)); + if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses ); + break; + default: + break; + } + } + return uses; +} + + +static void processModule ( Module m ) +{ + Cell tree; + ConId modNm; + List topEnts; + List tes; + Cell te; + Cell te2; + + tyconDefns = NIL; + typeInDefns = NIL; + valDefns = NIL; + classDefns = NIL; + instDefns = NIL; + selDefns = NIL; + genDefns = NIL; + unqualImports = NIL; + foreignImports = NIL; + foreignExports = NIL; + defaultDefns = NIL; + defaultLine = 0; + inputExpr = NIL; + + setCurrentFile(m); + startModule(m); + tree = unap(M_MODULE,module(m).tree); + modNm = zfst3(tree); + + if (textOf(modNm) != module(m).text) { + ERRMSG(0) "Module name \"%s\" does not match file name \"%s%s\"", + textToStr(textOf(modNm)), + textToStr(module(m).text), + textToStr(module(m).srcExt) + EEND; + } + + setExportList(zsnd3(tree)); + topEnts = zthd3(tree); + + for (tes = topEnts; nonNull(tes); tes=tl(tes)) { + te = hd(tes); + assert(isGenPair(te)); + te2 = snd(te); + switch(whatIs(te)) { + case M_IMPORT_Q: + addQualImport(zfst(te2),zsnd(te2)); + break; + case M_IMPORT_UNQ: + addUnqualImport(zfst(te2),zsnd(te2)); + break; + case M_TYCON: + tyconDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2)); + break; + case M_CLASS: + classDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2)); + break; + case M_INST: + instDefn(intOf(zfst3(te2)),zsnd3(te2),zthd3(te2)); + break; + case M_DEFAULT: + defaultDefn(intOf(zfst(te2)),zsnd(te2)); + break; + case M_FOREIGN_IM: + foreignImport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2), + zsel45(te2),zsel55(te2)); + break; + case M_FOREIGN_EX: + foreignExport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2), + zsel45(te2),zsel55(te2)); + case M_VALUE: + valDefns = cons(te2,valDefns); + break; + default: + internal("processModule"); + } + } + checkDefns(m); + typeCheckDefns(); + compileDefns(); +} + + +static Module parseModuleOrInterface ( ConId mc, Cell modeRequest ) +{ + /* Allocate a module-table entry. */ + /* Parse the entity and fill in the .tree and .uses entries. */ + String path; + String sExt; + Bool sAvail; Time sTime; Long sSize; + Bool oiAvail; Time oiTime; Long oSize; Long iSize; + Bool ok; + Bool useSource; + char name[10000]; + + Text mt = textOf(mc); + Module mod = findModule ( mt ); + + /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n", + textToStr(mt),mod); */ + if (nonNull(mod) && !module(mod).fake) + internal("parseModuleOrInterface"); + if (nonNull(mod)) + module(mod).fake = FALSE; + + if (isNull(mod)) + mod = newModule(mt); + + /* This call malloc-ates path; we should deallocate it. */ + ok = findFilesForModule ( + textToStr(module(mod).text), + &path, + &sExt, + &sAvail, &sTime, &sSize, + &oiAvail, &oiTime, &oSize, &iSize + ); + + if (!ok) goto cant_find; + if (!sAvail && !oiAvail) goto cant_find; + + /* Find out whether to use source or object. */ + switch (modeRequest) { + case FM_SOURCE: + if (!sAvail) goto cant_find; + useSource = TRUE; + break; + case FM_OBJECT: + if (!oiAvail) goto cant_find; + useSource = FALSE; + break; + case FM_EITHER: + if ( sAvail && !oiAvail) { useSource = TRUE; break; } + if (!sAvail && oiAvail) { useSource = FALSE; break; } + useSource = firstTimeIsLater ( sTime, oiTime ) ? TRUE : FALSE; + break; + default: + internal("parseModuleOrInterface"); + } + + /* Actually do the parsing. */ + if (useSource) { + module(mod).srcExt = findText(sExt); + setCurrentFile(mod); + strcpy(name, path); + strcat(name, textToStr(mt)); + strcat(name, sExt); + module(mod).tree = parseModule(name,sSize); + module(mod).uses = getModuleImports(module(mod).tree); + module(mod).mode = FM_SOURCE; + module(mod).lastStamp = sTime; + } else { + module(mod).srcExt = findText(HI_ENDING); + setCurrentFile(mod); + strcpy(name, path); + strcat(name, textToStr(mt)); + strcat(name, DLL_ENDING); + module(mod).objName = findText(name); + module(mod).objSize = oSize; + strcpy(name, path); + strcat(name, textToStr(mt)); + strcat(name, ".u_hi"); + module(mod).tree = parseInterface(name,iSize); + module(mod).uses = getInterfaceImports(module(mod).tree); + module(mod).mode = FM_OBJECT; + module(mod).lastStamp = oiTime; + } + + if (path) free(path); + return mod; + + cant_find: + if (path) free(path); + clearCurrentFile(); + ERRMSG(0) + "Can't find %s for module \"%s\"", + modeToString(modeRequest), textToStr(mt) + EEND; +} + + +static void tryLoadGroup ( Cell grp ) +{ + Module m; + List t; + switch (whatIs(grp)) { + case GRP_NONREC: + m = findModule(textOf(snd(grp))); + assert(nonNull(m)); + if (module(m).mode == FM_SOURCE) { + processModule ( m ); + module(m).tree = NIL; + } else { + processInterfaces ( singleton(snd(grp)) ); + m = findModule(textOf(snd(grp))); + assert(nonNull(m)); + module(m).tree = NIL; + } + break; + case GRP_REC: + for (t = snd(grp); nonNull(t); t=tl(t)) { + m = findModule(textOf(hd(t))); + assert(nonNull(m)); + if (module(m).mode == FM_SOURCE) { + ERRMSG(0) "Source module \"%s\" imports itself recursively", + textToStr(textOf(hd(t))) + EEND; + } + } + processInterfaces ( snd(grp) ); + for (t = snd(grp); nonNull(t); t=tl(t)) { + m = findModule(textOf(hd(t))); + assert(nonNull(m)); + module(m).tree = NIL; + } + break; + default: + internal("tryLoadGroup"); + } +} + + +static void fallBackToPrelModules ( void ) +{ + Module m; + for (m = MODULE_BASE_ADDR; + m < MODULE_BASE_ADDR+tabModuleSz; m++) + if (module(m).inUse + && !varIsMember(module(m).text, prelModules)) + nukeModule(m); +} + + +/* This function catches exceptions in most of the system. + So it's only ok for procedures called from this one + to do EENDs (ie, write error messages). Others should use + EEND_NO_LONGJMP. +*/ +static void achieveTargetModules ( Bool loadingThePrelude ) +{ + volatile List ood; + volatile List modgList; + volatile List t; + volatile Module mod; + volatile Bool ok; + + String path = NULL; + String sExt = NULL; + Bool sAvail; Time sTime; Long sSize; + Bool oiAvail; Time oiTime; Long oSize; Long iSize; + + volatile Time oisTime; + volatile Bool out_of_date; + volatile List ood_new; + volatile List us; + volatile List modgList_new; + volatile List parsedButNotLoaded; + volatile List toChase; + volatile List trans_cl; + volatile List trans_cl_new; + volatile List u; + volatile List mg; + volatile List mg2; + volatile Cell grp; + volatile List badMods; + + setBreakAction ( HugsIgnoreBreak ); + + /* First, examine timestamps to find out which modules are + out of date with respect to the source/interface/object files. + */ + ood = NIL; + modgList = listFromMG(); + + for (t = modgList; nonNull(t); t=tl(t)) { + + if (varIsMember(textOf(hd(t)),prelModules)) + continue; + + mod = findModule(textOf(hd(t))); + if (isNull(mod)) internal("achieveTargetSet(1)"); + + /* In standalone mode, only succeeds for source modules. */ + ok = findFilesForModule ( + textToStr(module(mod).text), + &path, + &sExt, + &sAvail, &sTime, &sSize, + &oiAvail, &oiTime, &oSize, &iSize + ); + + if (!combined && !sAvail) ok = FALSE; + if (!ok) { + fallBackToPrelModules(); + ERRMSG(0) + "Can't find source or object+interface for module \"%s\"", + textToStr(module(mod).text) + EEND_NO_LONGJMP; + if (path) free(path); + return; + } + + if (sAvail && oiAvail) { + oisTime = whicheverIsLater(sTime,oiTime); + } + else if (sAvail && !oiAvail) { + oisTime = sTime; + } + else if (!sAvail && oiAvail) { + oisTime = oiTime; + } + else { + internal("achieveTargetSet(2)"); + } + + out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp); + if (out_of_date) { + assert(!varIsMember(textOf(hd(t)),ood)); + ood = cons(hd(t),ood); + } + + if (path) { free(path); path = NULL; }; + } + + /* Second, form a simplistic transitive closure of the out-of-date + modules: a module is out of date if it imports an out-of-date + module. + */ + while (1) { + ood_new = NIL; + for (t = modgList; nonNull(t); t=tl(t)) { + mod = findModule(textOf(hd(t))); + assert(nonNull(mod)); + for (us = module(mod).uses; nonNull(us); us=tl(us)) + if (varIsMember(textOf(hd(us)),ood)) + break; + if (nonNull(us)) { + if (varIsMember(textOf(hd(t)),prelModules)) + Printf ( "warning: prelude module \"%s\" is out-of-date\n", + textToStr(textOf(hd(t))) ); + else + if (!varIsMember(textOf(hd(t)),ood_new) && + !varIsMember(textOf(hd(t)),ood)) + ood_new = cons(hd(t),ood_new); + } + } + if (isNull(ood_new)) break; + ood = appendOnto(ood_new,ood); + } + + /* Now ood holds the entire set of modules which are out-of-date. + Throw them out of the system, yielding a "reduced system", + in which the remaining modules are in-date. + */ + for (t = ood; nonNull(t); t=tl(t)) { + mod = findModule(textOf(hd(t))); + assert(nonNull(mod)); + nukeModule(mod); + } + modgList_new = NIL; + for (t = modgList; nonNull(t); t=tl(t)) + if (!varIsMember(textOf(hd(t)),ood)) + modgList_new = cons(hd(t),modgList_new); + modgList = modgList_new; + + /* Update the module group list to reflect the reduced system. + We do this so that if the following parsing phases fail, we can + safely fall back to the reduced system. + */ + mgFromList ( modgList ); + + /* Parse modules/interfaces, collecting parse trees and chasing + imports, starting from the target set. + */ + toChase = dupList(targetModules); + for (t = toChase; nonNull(t); t=tl(t)) { + Cell mode = (!combined) + ? FM_SOURCE + : ( (loadingThePrelude && combined) + ? FM_OBJECT + : FM_EITHER ); + hd(t) = zpair(hd(t), mode); + } + + /* toChase :: [ ((ConId, {FM_SOURCE|FM_OBJECT|FM_EITHER} )) ] */ + + parsedButNotLoaded = NIL; + + + while (nonNull(toChase)) { + ConId mc = zfst(hd(toChase)); + Cell mode = zsnd(hd(toChase)); + toChase = tl(toChase); + if (varIsMember(textOf(mc),modgList) + || varIsMember(textOf(mc),parsedButNotLoaded)) { + /* either exists fully, or is at least parsed */ + mod = findModule(textOf(mc)); + assert(nonNull(mod)); + if (!compatibleNewMode(mode,module(mod).mode)) { + clearCurrentFile(); + ERRMSG(0) + "module %s: %s required, but %s is more recent", + textToStr(textOf(mc)), modeToString(mode), + modeToString(module(mod).mode) + EEND_NO_LONGJMP; + goto parseException; + } + } else { + + setBreakAction ( HugsLongjmpOnBreak ); + if (setjmp(catch_error)==0) { + /* try this; it may throw an exception */ + mod = parseModuleOrInterface ( mc, mode ); + } else { + /* here's the exception handler, if parsing fails */ + /* A parse error (or similar). Clean up and abort. */ + parseException: + setBreakAction ( HugsIgnoreBreak ); + mod = findModule(textOf(mc)); + if (nonNull(mod)) nukeModule(mod); + for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) { + mod = findModule(textOf(hd(t))); + assert(nonNull(mod)); + if (nonNull(mod)) nukeModule(mod); + } + return; + /* end of the exception handler */ + } + setBreakAction ( HugsIgnoreBreak ); + + parsedButNotLoaded = cons(mc, parsedButNotLoaded); + for (t = module(mod).uses; nonNull(t); t=tl(t)) + toChase = cons( + zpair( hd(t), childMode(mode,module(mod).mode) ), + toChase); + } + } + + modgList = dupOnto(parsedButNotLoaded, modgList); + + /* We successfully parsed all modules reachable from the target + set which were not part of the reduced system. However, there + may be modules in the reduced system which are not reachable from + the target set. We detect these now by building the transitive + closure of the target set, and nuking modules in the reduced + system which are not part of that closure. + */ + trans_cl = dupList(targetModules); + while (1) { + trans_cl_new = NIL; + for (t = trans_cl; nonNull(t); t=tl(t)) { + mod = findModule(textOf(hd(t))); + assert(nonNull(mod)); + for (u = module(mod).uses; nonNull(u); u=tl(u)) + if (!varIsMember(textOf(hd(u)),trans_cl) + && !varIsMember(textOf(hd(u)),trans_cl_new) + && !varIsMember(textOf(hd(u)),prelModules)) + trans_cl_new = cons(hd(u),trans_cl_new); + } + if (isNull(trans_cl_new)) break; + trans_cl = appendOnto(trans_cl_new,trans_cl); + } + modgList_new = NIL; + for (t = modgList; nonNull(t); t=tl(t)) { + if (varIsMember(textOf(hd(t)),trans_cl)) { + modgList_new = cons(hd(t),modgList_new); + } else { + mod = findModule(textOf(hd(t))); + assert(nonNull(mod)); + nukeModule(mod); + } + } + modgList = modgList_new; + + /* Now, the module symbol tables hold exactly the set of + modules reachable from the target set, and modgList holds + their names. Calculate the scc-ified module graph, + since we need that to guide the next stage, that of + Actually Loading the modules. + + If no errors occur, moduleGraph will reflect the final graph + loaded. If an error occurs loading a group, we nuke + that group, truncate the moduleGraph just prior to that + group, and exit. That leaves the system having successfully + loaded all groups prior to the one which failed. + */ + mgFromList ( modgList ); + + for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) { + grp = hd(mg); + + if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)), + parsedButNotLoaded)) continue; + + setBreakAction ( HugsLongjmpOnBreak ); + if (setjmp(catch_error)==0) { + /* try this; it may throw an exception */ + tryLoadGroup(grp); + } else { + /* here's the exception handler, if static/typecheck etc fails */ + /* nuke the entire rest (ie, the unloaded part) + of the module graph */ + setBreakAction ( HugsIgnoreBreak ); + badMods = listFromSpecifiedMG ( mg ); + for (t = badMods; nonNull(t); t=tl(t)) { + mod = findModule(textOf(hd(t))); + if (nonNull(mod)) nukeModule(mod); + } + /* truncate the module graph just prior to this group. */ + mg2 = NIL; + mg = moduleGraph; + while (TRUE) { + if (isNull(mg)) break; + if (hd(mg) == grp) break; + mg2 = cons ( hd(mg), mg2 ); + mg = tl(mg); + } + moduleGraph = reverse(mg2); + return; + /* end of the exception handler */ + } + setBreakAction ( HugsIgnoreBreak ); + } + + /* Err .. I think that's it. If we get here, we've successfully + achieved the target set. Phew! + */ + setBreakAction ( HugsIgnoreBreak ); +} + + +static Bool loadThePrelude ( void ) +{ + Bool ok; + ConId conPrelude; + ConId conPrelHugs; + moduleGraph = prelModules = NIL; + + if (combined) { + conPrelude = mkCon(findText("Prelude")); + conPrelHugs = mkCon(findText("PrelHugs")); + targetModules = doubleton(conPrelude,conPrelHugs); + achieveTargetModules(TRUE); + ok = elemMG(conPrelude) && elemMG(conPrelHugs); + } else { + conPrelude = mkCon(findText("Prelude")); + targetModules = singleton(conPrelude); + achieveTargetModules(TRUE); + ok = elemMG(conPrelude); + } + + if (ok) prelModules = listFromMG(); + return ok; +} + + +/* Refresh the current target modules, and attempt to set the + current module to what it was before (ie currentModule): + if currentModule_failed is different from currentModule, + use that instead + if nextCurrMod is non null, try to set it to that instead + if the one we're after insn't available, select a target + from the end of the module group list. +*/ +static void refreshActions ( ConId nextCurrMod, Bool cleanAfter ) +{ + List t; + ConId tryFor; + + /* Remember what the old current module was. */ + tryFor = mkCon(module(currentModule).text); + + /* Do the Real Work. */ + achieveTargetModules(FALSE); + + /* Remember if the current module was invalidated by this + refresh, so later refreshes can attempt to reload it. */ + if (!elemMG(tryFor)) + currentModule_failed = tryFor; + + /* If a previous refresh failed to get an old current module, + try for that instead. */ + if (nonNull(currentModule_failed) + && textOf(currentModule_failed) != textOf(tryFor) + && elemMG(currentModule_failed)) + tryFor = currentModule_failed; + /* If our caller specified a new current module, that overrides + all historical settings. */ + if (nonNull(nextCurrMod)) + tryFor = nextCurrMod; + /* Finally, if we can't actually get hold of whatever it was we + were after, select something which is possible. */ + if (!elemMG(tryFor)) + tryFor = selectLatestMG(); + + /* combined mode kludge, to get Prelude rather than PrelHugs */ + if (combined && textOf(tryFor)==findText("PrelHugs")) + tryFor = mkCon(findText("Prelude")); + + if (cleanAfter) { + /* delete any targetModules which didn't actually get loaded */ + t = targetModules; + targetModules = NIL; + for (; nonNull(t); t=tl(t)) + if (elemMG(hd(t))) + targetModules = cons(hd(t),targetModules); + } + + setCurrModule ( findModule(textOf(tryFor)) ); + Printf("Hugs session for:\n"); + ppMG(); +} + + +static void addActions ( List extraModules /* :: [CONID] */ ) +{ + List t; + for (t = extraModules; nonNull(t); t=tl(t)) { + ConId extra = hd(t); + if (!varIsMember(textOf(extra),targetModules)) + targetModules = cons(extra,targetModules); + } + refreshActions ( isNull(extraModules) + ? NIL + : hd(reverse(extraModules)), + TRUE + ); +} + + +static void loadActions ( List loadModules /* :: [CONID] */ ) +{ + List t; + targetModules = dupList ( prelModules ); + + for (t = loadModules; nonNull(t); t=tl(t)) { + ConId load = hd(t); + if (!varIsMember(textOf(load),targetModules)) + targetModules = cons(load,targetModules); + } + refreshActions ( isNull(loadModules) + ? NIL + : hd(reverse(loadModules)), + TRUE + ); } -static Void local whatScripts() { /* list scripts in current session */ - int i; - Printf("\nHugs session for:"); - if (projectLoaded) - Printf(" (project: %s)",currProject); - for (i=0; i0) - Printf(", %u garbage collection%s",plural(numGcs)); - Printf(")\n"); -#undef plural - } - FlushStdout(); - garbageCollect(); - } -} + /* -------------------------------------------------------------------------- * Print type of input expression: * ------------------------------------------------------------------------*/ -static Void local showtype() { /* print type of expression (if any)*/ - Cell type; +static Void showtype ( void ) { /* print type of expression (if any)*/ + + volatile Cell type; + volatile Module evalMod = allocEvalModule(); + volatile Module currMod = currentModule; + setCurrModule(evalMod); + + if (setjmp(catch_error)==0) { + /* try this */ + parseExp(); + checkExp(); + defaultDefns = evalDefaults; + type = typeCheckExp(FALSE); + printExp(stdout,inputExpr); + Printf(" :: "); + printType(stdout,type); + Putchar('\n'); + } else { + /* if an exception happens, we arrive here */ + } + + nukeModule(evalMod); + setCurrModule(currMod); +} + + +static Void local browseit(mod,t,all) +Module mod; +String t; +Bool all; { + if (nonNull(mod)) { + Cell cs; + if (nonNull(t)) + Printf("module %s where\n",textToStr(module(mod).text)); + for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) { + Name nm = hd(cs); + /* only look at things defined in this module, + unless `all' flag is set */ + if (all || name(nm).mod == mod) { + /* unwanted artifacts, like lambda lifted values, + are in the list of names, but have no types */ + if (nonNull(name(nm).type)) { + printExp(stdout,nm); + Printf(" :: "); + printType(stdout,name(nm).type); + if (isCfun(nm)) { + Printf(" -- data constructor"); + } else if (isMfun(nm)) { + Printf(" -- class member"); + } else if (isSfun(nm)) { + Printf(" -- selector function"); + } + Printf("\n"); + } + } + } + } else { + if (isNull(mod)) { + Printf("Unknown module %s\n",t); + } + } +} + +static Void local browse() { /* browse modules */ + Int count = 0; /* or give menu of commands */ + String s; + Bool all = FALSE; + + for (; (s=readFilename())!=0; count++) + if (strcmp(s,"all") == 0) { + all = TRUE; + --count; + } else + browseit(findModule(findText(s)),s,all); + if (count == 0) { + browseit(currentModule,NULL,all); + } +} + +#if EXPLAIN_INSTANCE_RESOLUTION +static Void local xplain() { /* print type of expression (if any)*/ + Cell d; + Bool sir = showInstRes; setCurrModule(findEvalModule()); startNewScript(0); /* Enables recovery of storage */ - /* allocated during evaluation */ - parseExp(); - checkExp(); - defaultDefns = evalDefaults; - type = typeCheckExp(FALSE); - printExp(stdout,inputExpr); - Printf(" :: "); - printType(stdout,type); - Putchar('\n'); + /* allocated during evaluation */ + parseContext(); + checkContext(); + showInstRes = TRUE; + d = provePred(NIL,NIL,hd(inputContext)); + if (isNull(d)) { + fprintf(stdout, "not Sat\n"); + } else { + fprintf(stdout, "Sat\n"); + } + showInstRes = sir; } +#endif /* -------------------------------------------------------------------------- * Enhanced help system: print current list of scripts or give information @@ -1165,26 +1982,120 @@ Cell c; { #endif } +extern Name nameHw; + +static Void dumpStg ( void ) +{ + String s; + Int i; +#if 0 + Whats this for? + setCurrModule(findEvalModule()); + startNewScript(0); +#endif + s = readFilename(); + + /* request to locate a symbol by name */ + if (s && (*s == '?')) { + Text t = findText(s+1); + locateSymbolByName(t); + return; + } + + /* request to dump a bit of the heap */ + if (s && (*s == '-' || isdigit(*s))) { + int i = atoi(s); + print(i,100); + printf("\n"); + return; + } + + /* request to dump a symbol table entry */ + if (!s + || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i') + || !isdigit(s[1])) { + fprintf(stderr, ":d -- bad request `%s'\n", s ); + return; + } + i = atoi(s+1); + switch (*s) { + case 't': dumpTycon(i); break; + case 'n': dumpName(i); break; + case 'c': dumpClass(i); break; + case 'i': dumpInst(i); break; + default: fprintf(stderr, ":d -- `%c' not implemented\n", *s ); + } +} + + +#if 0 +static Void local dumpStg( void ) { /* print STG stuff */ + String s; + Text t; + Name n; + Int i; + Cell v; /* really StgVar */ + setCurrModule(findEvalModule()); + startNewScript(0); + for (; (s=readFilename())!=0;) { + t = findText(s); + v = n = NIL; + /* find the name while ignoring module scopes */ + for (i=NAMEMIN; i= 3 && + s[0]=='i' && s[1]=='d' && isdigit(s[2])) { + v = 0; + i = 2; + while (isdigit(s[i])) { + v = v * 10 + (s[i]-'0'); + i++; + } + v = -v; + n = nameFromStgVar(v); + } + + if (isNull(n) && whatIs(v)==STGVAR) { + Printf ( "\n{- `%s' has no nametable entry -}\n", s ); + printStg(stderr, v ); + } else + if (isNull(n)) { + Printf ( "Unknown reference `%s'\n", s ); + } else + if (!isName(n)) { + Printf ( "Not a Name: `%s'\n", s ); + } else + if (isNull(name(n).stgVar)) { + Printf ( "Doesn't have a STG tree: %s\n", s ); + } else { + Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar); + printStg(stderr, name(n).stgVar); + } + } +} +#endif + static Void local info() { /* describe objects */ Int count = 0; /* or give menu of commands */ String s; - setCurrModule(findEvalModule()); - startNewScript(0); /* for recovery of storage */ for (; (s=readFilename())!=0; count++) { describe(findText(s)); } if (count == 0) { - whatScripts(); + /* whatScripts(); */ } } + static Void local describe(t) /* describe an object */ Text t; { Tycon tc = findTycon(t); Class cl = findClass(t); Name nm = findName(t); - //Module mod = findEvalModule(); if (nonNull(tc)) { /* as a type constructor */ Type t = tc; @@ -1273,11 +2184,25 @@ Text t; { Printf(" => "); } printPred(stdout,cclass(cl).head); + + if (nonNull(cclass(cl).fds)) { + List fds = cclass(cl).fds; + String pre = " | "; + for (; nonNull(fds); fds=tl(fds)) { + Printf(pre); + printFD(stdout,hd(fds)); + pre = ", "; + } + } + if (nonNull(cclass(cl).members)) { List ms = cclass(cl).members; Printf(" where"); do { - Type t = monotypeOf(name(hd(ms)).type); + Type t = name(hd(ms)).type; + if (isPolyType(t)) { + t = monotypeOf(t); + } Printf("\n "); printExp(stdout,hd(ms)); Printf(" :: "); @@ -1310,7 +2235,6 @@ Text t; { } else { Printf(""); } - if (isCfun(nm)) { Printf(" -- data constructor"); } else if (isMfun(nm)) { @@ -1318,15 +2242,10 @@ Text t; { } else if (isSfun(nm)) { Printf(" -- selector function"); } -#if 0 - ToDo: reinstate - if (name(nm).primDef) { - Printf(" -- primitive"); - } -#endif Printf("\n\n"); } + if (isNull(tc) && isNull(cl) && isNull(nm)) { Printf("Unknown reference `%s'\n",textToStr(t)); } @@ -1375,7 +2294,7 @@ static Void local listNames() { /* list names matching optional pat*/ Int width = getTerminalWidth() - 1; Int count = 0; Int termPos; - Module mod = findEvalModule(); + Module mod = currentModule; if (pat) { /* First gather names to list */ do { @@ -1385,8 +2304,10 @@ 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; + EEND_NO_LONGJMP; + return; } for (termPos=0; nonNull(names); names=tl(names)) { String s = objToStr(mod,hd(names)); @@ -1426,65 +2347,93 @@ String moduleName; { internal("Combined prompt and evaluation module name too long"); } #endif - consoleInput(promptBuffer); + if (autoMain) + stringInput("main\0"); else + consoleInput(promptBuffer); } /* -------------------------------------------------------------------------- * main read-eval-print loop, with error trapping: * ------------------------------------------------------------------------*/ -static jmp_buf catch_error; /* jump buffer for error trapping */ - static Void local interpreter(argc,argv)/* main interpreter loop */ Int argc; String argv[]; { - Int errorNumber = setjmp(catch_error); - - breakOn(TRUE); /* enable break trapping */ - if (numScripts==0) { /* only succeeds on first time, */ - if (errorNumber) /* before prelude has been loaded */ - fatal("Unable to load prelude"); - initialize(argc,argv); - forHelp(); + + List modConIds; /* :: [CONID] */ + Bool prelOK; + String s; + + setBreakAction ( HugsIgnoreBreak ); + modConIds = initialize(argc,argv); /* the initial modules to load */ + setBreakAction ( HugsIgnoreBreak ); + prelOK = loadThePrelude(); + + if (!prelOK) { + if (autoMain) + fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" ); + else + fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" ); + exit(1); + } + + if (combined) everybody(POSTPREL); + loadActions(modConIds); + + if (autoMain) { + for (; nonNull(modConIds); modConIds=tl(modConIds)) + if (!elemMG(hd(modConIds))) { + fprintf(stderr, + "hugs +Q: compilation failed -- can't run `main'\n" ); + exit(1); + } } + modConIds = NIL; + + /* initialize calls startupHaskell, which trashes our signal handlers */ + setBreakAction ( HugsIgnoreBreak ); + forHelp(); + for (;;) { Command cmd; everybody(RESET); /* reset to sensible initial state */ - dropScriptsFrom(numScripts); /* remove partially loaded scripts */ - promptForInput(textToStr(module(findEvalModule()).text)); + promptForInput(textToStr(module(currentModule).text)); cmd = readCommand(cmds, (Char)':', (Char)'!'); -#ifdef WANT_TIMER - updateTimers(); -#endif switch (cmd) { case EDIT : editor(); break; case FIND : find(); break; - case LOAD : clearProject(); - forgetScriptsFrom(scriptBase); - load(); - break; - case ALSO : clearProject(); - forgetScriptsFrom(numScripts); - load(); + case LOAD : modConIds = NIL; + while ((s=readFilename())!=0) + modConIds = cons(mkCon(findText(s)),modConIds); + loadActions(modConIds); + modConIds = NIL; break; - case RELOAD : readScripts(scriptBase); + case ALSO : modConIds = NIL; + while ((s=readFilename())!=0) + modConIds = cons(mkCon(findText(s)),modConIds); + addActions(modConIds); + modConIds = NIL; break; - case PROJECT: project(); + case RELOAD : refreshActions(NIL,FALSE); break; -#if !IGNORE_MODULES case SETMODULE : setModule(); break; -#endif case EVAL : evaluator(); break; case TYPEOF : showtype(); break; + case BROWSE : browse(); + break; +#if EXPLAIN_INSTANCE_RESOLUTION + case XPLAIN : xplain(); + break; +#endif case NAMES : listNames(); break; case HELP : menu(); @@ -1493,6 +2442,11 @@ String argv[]; { break; case SET : set(); break; + case STATS: +#ifdef CRUDE_PROFILING + cp_show(); +#endif + break; case SYSTEM : if (shellEsc(readLine())) Printf("Warning: Shell escape terminated abnormally\n"); break; @@ -1500,6 +2454,11 @@ String argv[]; { break; case INFO : info(); break; + case PNTVER: Printf("-- Hugs Version %s\n", + HUGS_VERSION); + break; + case DUMP : dumpStg(); + break; case QUIT : return; case COLLECT: consGC = FALSE; garbageCollect(); @@ -1509,13 +2468,9 @@ String argv[]; { 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); } /* -------------------------------------------------------------------------- @@ -1531,7 +2486,12 @@ static Int charCount; Void setGoal(what, t) /* Set goal for what to be t */ String what; Target t; { - if (quiet) return; + if (quiet) + return; +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) + return; +#endif currTarget = (t?t:1); aiming = TRUE; if (useDots) { @@ -1547,7 +2507,12 @@ Target t; { Void soFar(t) /* Indicate progress towards goal */ Target t; { /* has now reached t */ - if (quiet) return; + if (quiet) + return; +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) + return; +#endif if (useDots) { Int newPos = (Int)((maxPos * ((long)t))/currTarget); @@ -1565,7 +2530,12 @@ Target t; { /* has now reached t */ } Void done() { /* Goal has now been achieved */ - if (quiet) return; + if (quiet) + return; +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) + return; +#endif if (useDots) { while (maxPos>currPos++) Putchar('.'); @@ -1593,17 +2563,45 @@ static Void local failed() { /* Goal cannot be reached due to */ * 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); @@ -1615,6 +2613,11 @@ Void errFail() { /* terminate error message and */ 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 */ @@ -1623,48 +2626,22 @@ Void errAbort() { /* altern. form of error handling */ 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: @@ -1696,83 +2673,24 @@ String s; { 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 #else #include #endif -/* ----------------------------------------------------------------------- */ - -#define BufferSize 5000 /* size of redirected output buffer */ - -typedef struct _HugsStream { - char buffer[BufferSize]; /* buffer for redirected output */ - Int next; /* next space in buffer */ -} HugsStream; - -static Void local vBufferedPrintf Args((HugsStream*, const char*, va_list)); -static Void local bufferedPutchar Args((HugsStream*, Char)); -static String local bufferClear Args((HugsStream *stream)); - -static Void local vBufferedPrintf(stream, fmt, ap) -HugsStream* stream; -const char* fmt; -va_list ap; { - Int spaceLeft = BufferSize - stream->next; - char* p = &stream->buffer[stream->next]; - Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap); - if (0 <= charsAdded && charsAdded < spaceLeft) - stream->next += charsAdded; -#if 1 /* we can either buffer the first n chars or buffer the last n chars */ - else - stream->next = 0; -#endif -} - -static Void local bufferedPutchar(stream, c) -HugsStream *stream; -Char c; { - if (BufferSize - stream->next >= 2) { - stream->buffer[stream->next++] = c; - stream->buffer[stream->next] = '\0'; - } -} - -static String local bufferClear(stream) -HugsStream *stream; { - if (stream->next == 0) { - return ""; - } else { - stream->next = 0; - return stream->buffer; - } -} - -/* ----------------------------------------------------------------------- */ - -static HugsStream outputStreamH; -/* ADR note: - * We rely on standard C semantics to initialise outputStreamH.next to 0. - */ - Void hugsEnableOutput(f) Bool f; { disableOutput = !f; } -String hugsClearOutputBuffer() { - return bufferClear(&outputStreamH); -} - #ifdef HAVE_STDARG_H Void hugsPrintf(const char *fmt, ...) { va_list ap; /* pointer into argument list */ @@ -1780,7 +2698,6 @@ Void hugsPrintf(const char *fmt, ...) { if (!disableOutput) { vprintf(fmt, ap); } else { - vBufferedPrintf(&outputStreamH, fmt, ap); } va_end(ap); /* clean up */ } @@ -1793,7 +2710,6 @@ va_dcl { if (!disableOutput) { vprintf(fmt, ap); } else { - vBufferedPrintf(&outputStreamH, fmt, ap); } va_end(ap); /* clean up */ } @@ -1804,7 +2720,6 @@ int c; { if (!disableOutput) { putchar(c); } else { - bufferedPutchar(&outputStreamH, c); } } @@ -1828,7 +2743,6 @@ Void hugsFPrintf(FILE *fp, const char* fmt, ...) { if (!disableOutput) { vfprintf(fp, fmt, ap); } else { - vBufferedPrintf(&outputStreamH, fmt, ap); } va_end(ap); } @@ -1842,7 +2756,6 @@ va_dcl { if (!disableOutput) { vfprintf(fp, fmt, ap); } else { - vBufferedPrintf(&outputStreamH, fmt, ap); } va_end(ap); } @@ -1854,38 +2767,37 @@ FILE* fp; { if (!disableOutput) { putc(c,fp); } else { - bufferedPutchar(&outputStreamH, c); } } - -#endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */ + /* -------------------------------------------------------------------------- * Send message to each component of system: * ------------------------------------------------------------------------*/ Void everybody(what) /* send command `what' to each component of*/ Int what; { /* system to respond as appropriate ... */ +#if 0 + fprintf ( stderr, "EVERYBODY %d\n", what ); +#endif machdep(what); /* The order of calling each component is */ - storage(what); /* important for the INSTALL command */ + storage(what); /* important for the PREPREL command */ substitution(what); input(what); + translateControl(what); linkControl(what); staticAnalysis(what); deriveControl(what); typeChecker(what); - translateControl(what); compiler(what); codegen(what); -} - - -/* -------------------------------------------------------------------------- - * Hugs for Windows code (WinMain and related functions) - * ------------------------------------------------------------------------*/ -#if HUGS_FOR_WINDOWS -#include "winhugs.c" -#endif + if (what == MARK) { + mark(moduleGraph); + mark(prelModules); + mark(targetModules); + mark(daSccs); + mark(currentModule_failed); + } +} /*-------------------------------------------------------------------------*/ -