2 /* --------------------------------------------------------------------------
5 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
6 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
7 * Technology, 1994-1999, All rights reserved. It is distributed as
8 * free software under the license in the file "License", which is
9 * included in the distribution.
11 * $RCSfile: hugs.c,v $
13 * $Date: 2000/05/12 13:41:59 $
14 * ------------------------------------------------------------------------*/
20 #include "hugsbasictypes.h"
29 #include "Assembler.h" /* DEBUG_LoadSymbols */
30 #include "ForeignCall.h" /* createAdjThunk */
33 Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
34 Bool initDone = FALSE;
36 #if EXPLAIN_INSTANCE_RESOLUTION
37 Bool showInstRes = FALSE;
40 Bool multiInstRes = FALSE;
43 /* --------------------------------------------------------------------------
44 * Local function prototypes:
45 * ------------------------------------------------------------------------*/
47 static List local initialize ( Int,String [] );
48 static Void local promptForInput ( String );
49 static Void local interpreter ( Int,String [] );
50 static Void local menu ( Void );
51 static Void local guidance ( Void );
52 static Void local forHelp ( Void );
53 static Void local set ( Void );
54 static Void local changeDir ( Void );
55 static Void local load ( Void );
56 static Void local project ( Void );
57 static Void local editor ( Void );
58 static Void local find ( Void );
59 static Bool local startEdit ( Int,String );
60 static Void local runEditor ( Void );
61 static Void local setModule ( Void );
62 static Void local evaluator ( Void );
63 static Void local stopAnyPrinting ( Void );
64 static Void local showtype ( Void );
65 static String local objToStr ( Module, Cell );
66 static Void local info ( Void );
67 static Void local printSyntax ( Name );
68 static Void local showInst ( Inst );
69 static Void local describe ( Text );
70 static Void local listNames ( Void );
72 static Void local toggleSet ( Char,Bool );
73 static Void local togglesIn ( Bool );
74 static Void local optionInfo ( Void );
75 static Void local readOptions ( String );
76 static Bool local processOption ( String );
77 static Void local setHeapSize ( String );
78 static Int local argToInt ( String );
80 static Void local setLastEdit ( String,Int );
81 static Void local failed ( Void );
82 static String local strCopy ( String );
83 static Void local browseit ( Module,String,Bool );
84 static Void local browse ( Void );
85 static void local clearCurrentFile ( void );
87 static void loadActions ( List loadModules /* :: [CONID] */ );
88 static void addActions ( List extraModules /* :: [CONID] */ );
89 static Bool loadThePrelude ( void );
92 /* --------------------------------------------------------------------------
93 * Machine dependent code for Hugs interpreter:
94 * ------------------------------------------------------------------------*/
98 /* --------------------------------------------------------------------------
100 * ------------------------------------------------------------------------*/
102 static Bool printing = FALSE; /* TRUE => currently printing value*/
103 static Bool showStats = FALSE; /* TRUE => print stats after eval */
104 static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
105 static Bool addType = FALSE; /* TRUE => print type with value */
106 static Bool useDots = RISCOS; /* TRUE => use dots in progress */
107 static Bool quiet = FALSE; /* TRUE => don't show progress */
108 static Bool lastWasObject = FALSE;
110 Bool flagAssert = FALSE; /* TRUE => assert False <e> causes
111 an assertion failure */
112 Bool preludeLoaded = FALSE;
113 Bool debugSC = FALSE;
114 Bool combined = FALSE;
116 Module moduleBeingParsed; /* so the parser (topModule) knows */
117 static char* currentFile; /* Name of current file, or NULL */
118 static char currentFileName[1000]; /* name is stored here if it exists*/
120 static Bool autoMain = FALSE;
121 static String lastEdit = 0; /* Name of script to edit (if any) */
122 static Int lastEdLine = 0; /* Editor line number (if possible)*/
123 static String prompt = 0; /* Prompt string */
124 static Int hpSize = DEFAULTHEAP; /* Desired heap size */
125 static Bool disableOutput = FALSE; /* TRUE => quiet */
126 String hugsEdit = 0; /* String for editor command */
127 String hugsPath = 0; /* String for file search path */
129 List ifaces_outstanding = NIL;
131 static ConId currentModule_failed = NIL; /* Remember failed module from :r */
135 /* --------------------------------------------------------------------------
137 * ------------------------------------------------------------------------*/
143 static int diet_hep_initialised = 0;
146 void diet_hep_initialise ( void* cstackbase )
148 List modConIds; /* :: [CONID] */
151 String fakeargv[1] = { "diet_hep" };
153 if (diet_hep_initialised) return;
154 diet_hep_initialised = 1;
156 CStackBase = cstackbase;
158 setInstallDir ( "diet_hep" );
160 /* The following copied from interpreter() */
161 setBreakAction ( HugsIgnoreBreak );
162 modConIds = initialize(1,fakeargv);
163 assert(isNull(modConIds));
164 setBreakAction ( HugsIgnoreBreak );
165 prelOK = loadThePrelude();
168 fprintf(stderr, "diet_hep_initialise: fatal error: "
169 "can't load the Prelude.\n" );
175 if (combined) everybody(POSTPREL);
176 /* we now leave, and wait for requests */
181 DH_MODULE DH_LoadLibrary_wrk ( DH_LPCSTR modname )
185 t = findText(modname);
186 addActions ( singleton(mkCon(t)) );
188 if (isModule(m)) return m; else return 0;
191 DH_MODULE DH_LoadLibrary ( DH_LPCSTR modname )
195 diet_hep_initialise ( &xxx );
196 hdl = DH_LoadLibrary_wrk ( modname );
197 printf ( "hdl = %d\n", hdl );
203 void* DH_GetProcAddress_wrk ( DH_CALLCONV cconv,
205 DH_LPCSTR lpProcName )
210 StgStablePtr stableptr;
212 if (!isModule(hModule)) return NULL;
213 setCurrModule(hModule);
214 n = findName ( findText(lpProcName) );
215 if (!isName(n)) return NULL;
216 assert(isCPtr(name(n).closure));
218 /* n is the function which we want to f-x-d,
219 n :: prim_arg* -> IO prim_result.
220 Assume that name(n).closure is a cptr which points to n's BCO.
222 Make ns a stable pointer to n.
223 Manufacture a type descriptor string for n's type.
224 use createAdjThunk to build the adj thunk.
226 typedescr = makeTypeDescrText ( name(n).type );
227 if (!isText(typedescr)) return NULL;
228 if (cconv != dh_stdcall && cconv != dh_ccall) return NULL;
230 stableptr = getStablePtr( cptrOf(name(n).closure) );
231 adj_thunk = createAdjThunk ( stableptr,
232 textToStr(typedescr),
233 cconv==dh_stdcall ? 's' : 'c' );
237 void* DH_GetProcAddress ( DH_CALLCONV cconv,
239 DH_LPCSTR lpProcName )
242 diet_hep_initialise ( &xxx );
243 return DH_GetProcAddress_wrk ( cconv, hModule, lpProcName );
246 //---------------------------------
248 int main ( int argc, char** argv )
252 hdl = DH_LoadLibrary("FooBar");
253 assert(isModule(hdl));
254 proc = DH_GetProcAddress ( dh_ccall, hdl, "wurble" );
255 fprintf ( stderr, "just before calling it\n");
256 ((void(*)(int)) proc) (33);
257 ((void(*)(int)) proc) (34);
258 ((void(*)(int)) proc) (35);
259 fprintf ( stderr, "exiting safely\n");
265 Main main ( Int, String [] ); /* now every func has a prototype */
270 CStackBase = &argc; /* Save stack base for use in gc */
274 checkBytecodeCount(); /* check for too many bytecodes */
278 /* If first arg is +Q or -Q, be entirely silent, and automatically run
279 main after loading scripts. Useful for running the nofib suite. */
280 if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
282 if (strcmp(argv[1],"-Q") == 0) {
287 Printf("__ __ __ __ ____ ___ _________________________________________\n");
288 Printf("|| || || || || || ||__ STGHugs: Based on the Haskell 98 standard\n");
289 Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-2000\n");
290 Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
291 Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
292 Printf("|| || Version: %s _________________________________________\n\n",HUGS_VERSION);
294 /* Get the absolute path to the directory containing the hugs
295 executable, so that we know where the Prelude and nHandle.so/.dll are.
296 We do this by reading env var STGHUGSDIR. This needs to succeed, so
297 setInstallDir won't return unless it succeeds.
299 setInstallDir ( argv[0] );
302 interpreter(argc,argv);
303 Printf("[Leaving Hugs]\n");
312 #endif /* DIET_HEP */
314 /* --------------------------------------------------------------------------
315 * Initialization, interpret command line args and read prelude:
316 * ------------------------------------------------------------------------*/
318 static List /*CONID*/ initialize ( Int argc, String argv[] )
323 setLastEdit((String)0,0);
330 hugsEdit = strCopy(fromEnv("EDITOR",NULL));
332 hugsPath = strCopy(HUGSPATH);
333 readOptions("-p\"%s> \" -r$$");
334 readOptions(fromEnv("STGHUGSFLAGS",""));
338 char exe_name[N_INSTALLDIR + 6];
339 strcpy(exe_name, installDir);
340 strcat(exe_name, "hugs");
341 DEBUG_LoadSymbols(exe_name);
345 /* startupHaskell extracts args between +RTS ... -RTS, and sets
346 prog_argc/prog_argv to the rest. We want to further process
347 the rest, so we then get hold of them again.
349 startupHaskell ( argc, argv, NULL );
350 getProgArgv ( &argc, &argv );
352 /* Find out early on if we're in combined mode or not.
353 everybody(PREPREL) needs to know this. Also, establish the
356 for (i = 1; i < argc; ++i) {
357 if (strcmp(argv[i], "--")==0) break;
358 if (strcmp(argv[i], "-c")==0) combined = FALSE;
359 if (strcmp(argv[i], "+c")==0) combined = TRUE;
361 if (strncmp(argv[i],"+h",2)==0 || strncmp(argv[i],"-h",2)==0)
362 setHeapSize(&(argv[i][2]));
366 initialModules = NIL;
368 for (i = 1; i < argc; ++i) { /* process command line arguments */
369 if (strcmp(argv[i], "--")==0)
370 { argv[i] = NULL; break; }
371 if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/) {
372 if (!processOption(argv[i]))
374 = cons ( mkCon(findText(argv[i])), initialModules );
380 Printf("Haskell 98 mode: Restart with command line option -98"
381 " to enable extensions\n");
383 Printf("Hugs mode: Restart with command line option +98 for"
384 " Haskell 98 mode\n");
388 Printf("Combined mode: Restart with command line -c for"
389 " standalone mode\n\n" );
391 Printf("Standalone mode: Restart with command line +c for"
392 " combined mode\n\n" );
395 /* slide args back over the deleted ones. */
397 for (i = 1; i < argc; i++)
403 setProgArgv ( argc, argv );
406 return initialModules;
409 /* --------------------------------------------------------------------------
410 * Command line options:
411 * ------------------------------------------------------------------------*/
413 struct options { /* command line option toggles */
414 char c; /* table defined in main app. */
419 extern struct options toggle[];
421 static Void local toggleSet(c,state) /* Set command line toggle */
425 for (i=0; toggle[i].c; ++i)
426 if (toggle[i].c == c) {
427 *toggle[i].flag = state;
431 ERRMSG(0) "Unknown toggle `%c'", c
435 static Void local togglesIn(state) /* Print current list of toggles in*/
436 Bool state; { /* given state */
439 for (i=0; toggle[i].c; ++i)
440 if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
442 Putchar((char)(state ? '+' : '-'));
443 Putchar(toggle[i].c);
450 static Void local optionInfo() { /* Print information about command */
451 static String fmts = "%-5s%s\n"; /* line settings */
452 static String fmtc = "%-5c%s\n";
455 Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
456 for (i=0; toggle[i].c; ++i) {
457 if (!haskell98 || toggle[i].h98) {
458 Printf(fmtc,toggle[i].c,toggle[i].description);
462 Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
463 Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
464 Printf(fmts,"pstr","Set prompt string to str");
465 Printf(fmts,"rstr","Set repeat last expression string to str");
466 Printf(fmts,"Pstr","Set search path for modules to str");
467 Printf(fmts,"Estr","Use editor setting given by str");
468 Printf(fmts,"cnum","Set constraint cutoff limit");
469 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
470 Printf(fmts,"Fstr","Set preprocessor filter to str");
473 Printf("\nCurrent settings: ");
476 Printf("-h%d",heapSize);
480 printString(repeatStr);
481 Printf(" -c%d",cutoff);
482 Printf("\nSearch path : -P");
483 printString(hugsPath);
486 if (projectPath!=NULL) {
487 Printf("\nProject Path : %s",projectPath);
490 Printf("\nEditor setting : -E");
491 printString(hugsEdit);
492 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
493 Printf("\nPreprocessor : -F");
494 printString(preprocessor);
496 Printf("\nCompatibility : %s", haskell98 ? "Haskell 98 (+98)"
497 : "Hugs Extensions (-98)");
506 static Void local readOptions(options) /* read options from string */
510 stringInput(options);
511 while ((s=readFilename())!=0) {
512 if (*s && !processOption(s)) {
513 ERRMSG(0) "Option string must begin with `+' or `-'"
520 static Bool local processOption(s) /* process string s for options, */
521 String s; { /* return FALSE if none found. */
533 case 'Q' : break; /* already handled */
535 case 'p' : if (s[1]) {
536 if (prompt) free(prompt);
537 prompt = strCopy(s+1);
541 case 'r' : if (s[1]) {
542 if (repeatStr) free(repeatStr);
543 repeatStr = strCopy(s+1);
548 String p = substPath(s+1,hugsPath ? hugsPath : "");
549 if (hugsPath) free(hugsPath);
554 case 'E' : if (hugsEdit) free(hugsEdit);
555 hugsEdit = strCopy(s+1);
558 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
559 case 'F' : if (preprocessor) free(preprocessor);
560 preprocessor = strCopy(s+1);
564 case 'h' : /* don't do anything, since pre-scan of args
565 will have got it already */
568 case 'c' : /* don't do anything, since pre-scan of args
569 will have got it already */
572 case 'D' : /* hack */
574 extern void setRtsFlags( int x );
575 setRtsFlags(argToInt(s+1));
579 default : if (strcmp("98",s)==0) {
580 if (initDone && ((state && !haskell98) ||
581 (!state && haskell98))) {
583 "Haskell 98 compatibility cannot be changed"
584 " while the interpreter is running\n");
597 static Void local setHeapSize(s)
600 hpSize = argToInt(s);
601 if (hpSize < MINIMUMHEAP)
602 hpSize = MINIMUMHEAP;
603 else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
604 hpSize = MAXIMUMHEAP;
605 if (initDone && hpSize != heapSize) {
606 /* ToDo: should this use a message box in winhugs? */
607 FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
614 static Int local argToInt(s) /* read integer from argument str */
619 if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
620 ERRMSG(0) "Missing integer in option setting \"%s\"", t
625 Int d = (*s++) - '0';
626 if (n > ((MAXPOSINT - d)/10)) {
627 ERRMSG(0) "Option setting \"%s\" is too large", t
631 } while (isascii((int)(*s)) && isdigit((int)(*s)));
633 if (*s=='K' || *s=='k') {
634 if (n > (MAXPOSINT/1000)) {
635 ERRMSG(0) "Option setting \"%s\" is too large", t
642 #if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
643 if (*s=='M' || *s=='m') {
644 if (n > (MAXPOSINT/1000000)) {
645 ERRMSG(0) "Option setting \"%s\" is too large", t
653 #if MAXPOSINT > 1000000000
654 if (*s=='G' || *s=='g') {
655 if (n > (MAXPOSINT/1000000000)) {
656 ERRMSG(0) "Option setting \"%s\" is too large", t
665 ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
672 /* --------------------------------------------------------------------------
673 * Print Menu of list of commands:
674 * ------------------------------------------------------------------------*/
676 static struct cmd cmds[] = {
677 {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
678 {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
679 {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
680 {":quit", QUIT}, {":set", SET}, {":find", FIND},
681 {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
683 {":module", SETMODULE},
685 #if EXPLAIN_INSTANCE_RESOLUTION
688 {":version", PNTVER},
693 static Void local menu() {
694 Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
695 Printf("c is the first character in the full name.\n\n");
696 Printf(":load <filenames> load modules from specified files\n");
697 Printf(":load clear all files except prelude\n");
698 Printf(":also <filenames> read additional modules\n");
699 Printf(":reload repeat last load command\n");
700 Printf(":project <filename> use project file\n");
701 Printf(":edit <filename> edit file\n");
702 Printf(":edit edit last module\n");
703 Printf(":module <module> set module for evaluating expressions\n");
704 Printf("<expr> evaluate expression\n");
705 Printf(":type <expr> print type of expression\n");
706 Printf(":? display this list of commands\n");
707 Printf(":set <options> set command line options\n");
708 Printf(":set help on command line options\n");
709 Printf(":names [pat] list names currently in scope\n");
710 Printf(":info <names> describe named objects\n");
711 Printf(":browse <modules> browse names defined in <modules>\n");
712 #if EXPLAIN_INSTANCE_RESOLUTION
713 Printf(":xplain <context> explain instance resolution for <context>\n");
715 Printf(":find <name> edit module containing definition of name\n");
716 Printf(":!command shell escape\n");
717 Printf(":cd dir change directory\n");
718 Printf(":gc force garbage collection\n");
719 Printf(":version print Hugs version\n");
720 Printf(":dump <name> print STG code for named fn\n");
721 Printf(":quit exit Hugs interpreter\n");
724 static Void local guidance() {
725 Printf("Command not recognised. ");
729 static Void local forHelp() {
730 Printf("Type :? for help\n");
733 /* --------------------------------------------------------------------------
734 * Setting of command line options:
735 * ------------------------------------------------------------------------*/
737 struct options toggle[] = { /* List of command line toggles */
738 {'s', 1, "Print no. reductions/cells after eval", &showStats},
739 {'t', 1, "Print type after evaluation", &addType},
740 {'g', 1, "Print no. cells recovered after gc", &gcMessages},
741 {'l', 1, "Literate modules as default", &literateScripts},
742 {'e', 1, "Warn about errors in literate modules", &literateErrors},
743 {'.', 1, "Print dots to show progress", &useDots},
744 {'q', 1, "Print nothing to show progress", &quiet},
745 {'w', 1, "Always show which modules are loaded", &listScripts},
746 {'k', 1, "Show kind errors in full", &kindExpert},
747 {'o', 0, "Allow overlapping instances", &allowOverlap},
748 {'S', 1, "Debug: show generated SC code", &debugSC},
749 {'a', 1, "Raise exception on assert failure", &flagAssert},
750 #if EXPLAIN_INSTANCE_RESOLUTION
751 {'x', 1, "Explain instance resolution", &showInstRes},
754 {'m', 0, "Use multi instance resolution", &multiInstRes},
759 static Void local set() { /* change command line options from*/
760 String s; /* Hugs command line */
762 if ((s=readFilename())!=0) {
764 if (!processOption(s)) {
765 ERRMSG(0) "Option string must begin with `+' or `-'"
768 } while ((s=readFilename())!=0);
774 /* --------------------------------------------------------------------------
775 * Change directory command:
776 * ------------------------------------------------------------------------*/
778 static Void local changeDir() { /* change directory */
779 String s = readFilename();
781 ERRMSG(0) "Unable to change to directory \"%s\"", s
787 /* --------------------------------------------------------------------------
789 * ------------------------------------------------------------------------*/
791 static jmp_buf catch_error; /* jump buffer for error trapping */
793 HugsBreakAction currentBreakAction = HugsIgnoreBreak;
795 static void handler_IgnoreBreak ( int sig )
797 setHandler ( handler_IgnoreBreak );
800 static void handler_LongjmpOnBreak ( int sig )
802 setHandler ( handler_LongjmpOnBreak );
803 Printf("{Interrupted!}\n");
804 longjmp(catch_error,1);
807 static void handler_RtsInterrupt ( int sig )
809 setHandler ( handler_RtsInterrupt );
813 HugsBreakAction setBreakAction ( HugsBreakAction newAction )
815 HugsBreakAction tmp = currentBreakAction;
816 currentBreakAction = newAction;
818 case HugsIgnoreBreak:
819 setHandler ( handler_IgnoreBreak ); break;
820 case HugsLongjmpOnBreak:
821 setHandler ( handler_LongjmpOnBreak ); break;
822 case HugsRtsInterrupt:
823 setHandler ( handler_RtsInterrupt ); break;
825 internal("setBreakAction");
831 /* --------------------------------------------------------------------------
832 * The new module chaser, loader, etc
833 * ------------------------------------------------------------------------*/
835 List moduleGraph = NIL;
836 List prelModules = NIL;
837 List targetModules = NIL;
839 static String modeToString ( Cell mode )
842 case FM_SOURCE: return "source";
843 case FM_OBJECT: return "object";
844 case FM_EITHER: return "source or object";
845 default: internal("modeToString");
849 static Cell childMode ( Cell modeMeRequest, Cell modeMeActual )
851 assert(modeMeActual == FM_SOURCE ||
852 modeMeActual == FM_OBJECT);
853 assert(modeMeRequest == FM_SOURCE ||
854 modeMeRequest == FM_OBJECT ||
855 modeMeRequest == FM_EITHER);
856 if (modeMeRequest == FM_SOURCE) return modeMeRequest;
857 if (modeMeRequest == FM_OBJECT) return modeMeRequest;
858 if (modeMeActual == FM_OBJECT) return FM_OBJECT;
859 if (modeMeActual == FM_SOURCE) return FM_EITHER;
860 internal("childMode");
863 static Bool compatibleNewMode ( Cell modeNew, Cell modeExisting )
865 if (modeNew == FM_OBJECT && modeExisting == FM_OBJECT) return TRUE;
866 if (modeNew == FM_SOURCE && modeExisting == FM_SOURCE) return TRUE;
867 if (modeNew == FM_EITHER && modeExisting == FM_OBJECT) return TRUE;
868 if (modeNew == FM_EITHER && modeExisting == FM_SOURCE) return TRUE;
872 static void setCurrentFile ( Module mod )
874 assert(isModule(mod));
875 strncpy(currentFileName, textToStr(module(mod).text), 990);
876 strcat(currentFileName, textToStr(module(mod).srcExt));
877 currentFile = currentFileName;
878 moduleBeingParsed = mod;
881 static void clearCurrentFile ( void )
884 moduleBeingParsed = NIL;
887 static void ppMG ( void )
890 for (t = moduleGraph; nonNull(t); t=tl(t)) {
894 FPrintf ( stderr, " %s\n", textToStr(textOf(snd(u))));
897 FPrintf ( stderr, " {" );
898 for (v = snd(u); nonNull(v); v=tl(v))
899 FPrintf ( stderr, "%s ", textToStr(textOf(hd(v))) );
900 FPrintf ( stderr, "}\n" );
909 static Bool elemMG ( ConId mod )
912 for (gs = moduleGraph; nonNull(gs); gs=tl(gs))
913 switch (whatIs(hd(gs))) {
915 if (textOf(mod)==textOf(snd(hd(gs)))) return TRUE;
918 if (varIsMember(textOf(mod),snd(hd(gs)))) return TRUE;
927 static ConId selectArbitrarilyFromGroup ( Cell group )
929 switch (whatIs(group)) {
930 case GRP_NONREC: return snd(group);
931 case GRP_REC: return hd(snd(group));
932 default: internal("selectArbitrarilyFromGroup");
936 static ConId selectLatestMG ( void )
938 List gs = moduleGraph;
939 if (isNull(gs)) internal("selectLatestMG(1)");
940 while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs);
941 return selectArbitrarilyFromGroup(hd(gs));
945 static List /* of CONID */ listFromSpecifiedMG ( List mg )
949 for (gs = mg; nonNull(gs); gs=tl(gs)) {
950 switch (whatIs(hd(gs))) {
951 case GRP_REC: cs = appendOnto(cs,snd(hd(gs))); break;
952 case GRP_NONREC: cs = cons(snd(hd(gs)),cs); break;
953 default: internal("listFromSpecifiedMG");
959 static List /* of CONID */ listFromMG ( void )
961 return listFromSpecifiedMG ( moduleGraph );
965 /* Calculate the strongly connected components of modgList
966 and assign them to moduleGraph. Uses the .uses field of
967 each of the modules to build the graph structure.
969 #define SCC modScc /* make scc algorithm for StgVars */
970 #define LOWLINK modLowlink
971 #define DEPENDS(t) snd(t)
972 #define SETDEPENDS(c,v) snd(c)=v
979 static void mgFromList ( List /* of CONID */ modgList )
985 List adjList; /* :: [ (Text, [Text]) ] */
991 for (t = modgList; nonNull(t); t=tl(t)) {
993 mod = findModule(mT);
994 assert(nonNull(mod));
996 for (u = module(mod).uses; nonNull(u); u=tl(u))
997 usesT = cons(textOf(hd(u)),usesT);
999 /* artificially give all modules a dependency on Prelude */
1000 if (mT != textPrelude && mT != textPrelPrim)
1001 usesT = cons(textPrelude,usesT);
1002 adjList = cons(pair(mT,usesT),adjList);
1005 /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
1006 Modify this so that the adjacency list is a list of pointers
1007 back to bits of adjList -- that's what modScc needs.
1009 for (t = adjList; nonNull(t); t=tl(t)) {
1011 /* for each elem of the adjacency list ... */
1012 for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
1015 /* find the element of adjList whose fst is a */
1016 for (v = adjList; nonNull(v); v=tl(v)) {
1018 assert(isText(fst(hd(v))));
1019 if (fst(hd(v))==a) break;
1021 if (isNull(v)) internal("mgFromList");
1022 adj = cons(hd(v),adj);
1027 adjList = modScc ( adjList );
1028 /* adjList is now [ [(module-text, aux-info-field)] ] */
1032 for (t = adjList; nonNull(t); t=tl(t)) {
1035 /* scc :: [ (module-text, aux-info-field) ] */
1036 for (u = scc; nonNull(u); u=tl(u))
1037 hd(u) = mkCon(fst(hd(u)));
1039 /* scc :: [CONID] */
1040 if (length(scc) > 1) {
1043 /* singleton module in scc; does it import itself? */
1044 mod = findModule ( textOf(hd(scc)) );
1045 assert(nonNull(mod));
1047 for (u = module(mod).uses; nonNull(u); u=tl(u))
1048 if (textOf(hd(u))==textOf(hd(scc)))
1053 moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
1054 moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
1056 moduleGraph = reverse(moduleGraph);
1060 static List /* of CONID */ getModuleImports ( Cell tree )
1066 for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
1068 switch(whatIs(te)) {
1070 use = zfst(unap(M_IMPORT_Q,te));
1072 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
1075 use = zfst(unap(M_IMPORT_UNQ,te));
1077 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
1087 static void processModule ( Module m )
1103 unqualImports = NIL;
1104 foreignImports = NIL;
1105 foreignExports = NIL;
1112 tree = unap(M_MODULE,module(m).tree);
1113 modNm = zfst3(tree);
1115 if (textOf(modNm) != module(m).text) {
1116 ERRMSG(0) "Module name \"%s\" does not match file name \"%s%s\"",
1117 textToStr(textOf(modNm)),
1118 textToStr(module(m).text),
1119 textToStr(module(m).srcExt)
1123 setExportList(zsnd3(tree));
1124 topEnts = zthd3(tree);
1126 for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
1128 assert(isGenPair(te));
1130 switch(whatIs(te)) {
1132 addQualImport(zfst(te2),zsnd(te2));
1135 addUnqualImport(zfst(te2),zsnd(te2));
1138 tyconDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
1141 classDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
1144 instDefn(intOf(zfst3(te2)),zsnd3(te2),zthd3(te2));
1147 defaultDefn(intOf(zfst(te2)),zsnd(te2));
1150 foreignImport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
1151 zsel45(te2),zsel55(te2));
1154 foreignExport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
1155 zsel45(te2),zsel55(te2));
1157 valDefns = cons(te2,valDefns);
1160 internal("processModule");
1169 static Module parseModuleOrInterface ( ConId mc, Cell modeRequest )
1171 /* Allocate a module-table entry. */
1172 /* Parse the entity and fill in the .tree and .uses entries. */
1175 Bool sAvail; Time sTime; Long sSize;
1176 Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1181 Text mt = textOf(mc);
1182 Module mod = findModule ( mt );
1184 /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
1185 textToStr(mt),mod); */
1186 if (nonNull(mod) && !module(mod).fake)
1187 internal("parseModuleOrInterface");
1189 module(mod).fake = FALSE;
1192 mod = newModule(mt);
1194 /* This call malloc-ates path; we should deallocate it. */
1195 ok = findFilesForModule (
1196 textToStr(module(mod).text),
1199 &sAvail, &sTime, &sSize,
1200 &oiAvail, &oiTime, &oSize, &iSize
1203 if (!ok) goto cant_find;
1204 if (!sAvail && !oiAvail) goto cant_find;
1206 /* Find out whether to use source or object. */
1207 switch (modeRequest) {
1209 if (!sAvail) goto cant_find;
1213 if (!oiAvail) goto cant_find;
1217 if ( sAvail && !oiAvail) { useSource = TRUE; break; }
1218 if (!sAvail && oiAvail) { useSource = FALSE; break; }
1219 useSource = firstTimeIsLater ( sTime, oiTime ) ? TRUE : FALSE;
1222 internal("parseModuleOrInterface");
1225 /* Actually do the parsing. */
1227 module(mod).srcExt = findText(sExt);
1228 setCurrentFile(mod);
1230 strcat(name, textToStr(mt));
1232 module(mod).tree = parseModule(name,sSize);
1233 module(mod).uses = getModuleImports(module(mod).tree);
1234 module(mod).mode = FM_SOURCE;
1235 module(mod).lastStamp = sTime;
1237 module(mod).srcExt = findText(HI_ENDING);
1238 setCurrentFile(mod);
1240 strcat(name, textToStr(mt));
1241 strcat(name, DLL_ENDING);
1242 module(mod).objName = findText(name);
1243 module(mod).objSize = oSize;
1245 strcat(name, textToStr(mt));
1246 strcat(name, ".u_hi");
1247 module(mod).tree = parseInterface(name,iSize);
1248 module(mod).uses = getInterfaceImports(module(mod).tree);
1249 module(mod).mode = FM_OBJECT;
1250 module(mod).lastStamp = oiTime;
1253 if (path) free(path);
1257 if (path) free(path);
1260 "Can't find %s for module \"%s\"",
1261 modeToString(modeRequest), textToStr(mt)
1266 static void tryLoadGroup ( Cell grp )
1270 switch (whatIs(grp)) {
1272 m = findModule(textOf(snd(grp)));
1274 if (module(m).mode == FM_SOURCE) {
1275 processModule ( m );
1276 module(m).tree = NIL;
1278 processInterfaces ( singleton(snd(grp)) );
1279 m = findModule(textOf(snd(grp)));
1281 module(m).tree = NIL;
1285 for (t = snd(grp); nonNull(t); t=tl(t)) {
1286 m = findModule(textOf(hd(t)));
1288 if (module(m).mode == FM_SOURCE) {
1289 ERRMSG(0) "Source module \"%s\" imports itself recursively",
1290 textToStr(textOf(hd(t)))
1294 processInterfaces ( snd(grp) );
1295 for (t = snd(grp); nonNull(t); t=tl(t)) {
1296 m = findModule(textOf(hd(t)));
1298 module(m).tree = NIL;
1302 internal("tryLoadGroup");
1307 static void fallBackToPrelModules ( void )
1310 for (m = MODULE_BASE_ADDR;
1311 m < MODULE_BASE_ADDR+tabModuleSz; m++)
1313 && !varIsMember(module(m).text, prelModules))
1318 /* This function catches exceptions in most of the system.
1319 So it's only ok for procedures called from this one
1320 to do EENDs (ie, write error messages). Others should use
1323 static void achieveTargetModules ( Bool loadingThePrelude )
1326 volatile List modgList;
1328 volatile Module mod;
1333 Bool sAvail; Time sTime; Long sSize;
1334 Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1336 volatile Time oisTime;
1337 volatile Bool out_of_date;
1338 volatile List ood_new;
1340 volatile List modgList_new;
1341 volatile List parsedButNotLoaded;
1342 volatile List toChase;
1343 volatile List trans_cl;
1344 volatile List trans_cl_new;
1349 volatile List badMods;
1351 setBreakAction ( HugsIgnoreBreak );
1353 /* First, examine timestamps to find out which modules are
1354 out of date with respect to the source/interface/object files.
1357 modgList = listFromMG();
1359 for (t = modgList; nonNull(t); t=tl(t)) {
1361 if (varIsMember(textOf(hd(t)),prelModules))
1364 mod = findModule(textOf(hd(t)));
1365 if (isNull(mod)) internal("achieveTargetSet(1)");
1367 /* In standalone mode, only succeeds for source modules. */
1368 ok = findFilesForModule (
1369 textToStr(module(mod).text),
1372 &sAvail, &sTime, &sSize,
1373 &oiAvail, &oiTime, &oSize, &iSize
1376 if (!combined && !sAvail) ok = FALSE;
1378 fallBackToPrelModules();
1380 "Can't find source or object+interface for module \"%s\"",
1381 textToStr(module(mod).text)
1383 if (path) free(path);
1387 if (sAvail && oiAvail) {
1388 oisTime = whicheverIsLater(sTime,oiTime);
1390 else if (sAvail && !oiAvail) {
1393 else if (!sAvail && oiAvail) {
1397 internal("achieveTargetSet(2)");
1400 out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
1402 assert(!varIsMember(textOf(hd(t)),ood));
1403 ood = cons(hd(t),ood);
1406 if (path) { free(path); path = NULL; };
1409 /* Second, form a simplistic transitive closure of the out-of-date
1410 modules: a module is out of date if it imports an out-of-date
1415 for (t = modgList; nonNull(t); t=tl(t)) {
1416 mod = findModule(textOf(hd(t)));
1417 assert(nonNull(mod));
1418 for (us = module(mod).uses; nonNull(us); us=tl(us))
1419 if (varIsMember(textOf(hd(us)),ood))
1422 if (varIsMember(textOf(hd(t)),prelModules))
1423 Printf ( "warning: prelude module \"%s\" is out-of-date\n",
1424 textToStr(textOf(hd(t))) );
1426 if (!varIsMember(textOf(hd(t)),ood_new) &&
1427 !varIsMember(textOf(hd(t)),ood))
1428 ood_new = cons(hd(t),ood_new);
1431 if (isNull(ood_new)) break;
1432 ood = appendOnto(ood_new,ood);
1435 /* Now ood holds the entire set of modules which are out-of-date.
1436 Throw them out of the system, yielding a "reduced system",
1437 in which the remaining modules are in-date.
1439 for (t = ood; nonNull(t); t=tl(t)) {
1440 mod = findModule(textOf(hd(t)));
1441 assert(nonNull(mod));
1445 for (t = modgList; nonNull(t); t=tl(t))
1446 if (!varIsMember(textOf(hd(t)),ood))
1447 modgList_new = cons(hd(t),modgList_new);
1448 modgList = modgList_new;
1450 /* Update the module group list to reflect the reduced system.
1451 We do this so that if the following parsing phases fail, we can
1452 safely fall back to the reduced system.
1454 mgFromList ( modgList );
1456 /* Parse modules/interfaces, collecting parse trees and chasing
1457 imports, starting from the target set.
1459 toChase = dupList(targetModules);
1460 for (t = toChase; nonNull(t); t=tl(t)) {
1461 Cell mode = (!combined)
1463 : ( (loadingThePrelude && combined)
1466 hd(t) = zpair(hd(t), mode);
1469 /* toChase :: [ ((ConId, {FM_SOURCE|FM_OBJECT|FM_EITHER} )) ] */
1471 parsedButNotLoaded = NIL;
1474 while (nonNull(toChase)) {
1475 ConId mc = zfst(hd(toChase));
1476 Cell mode = zsnd(hd(toChase));
1477 toChase = tl(toChase);
1478 if (varIsMember(textOf(mc),modgList)
1479 || varIsMember(textOf(mc),parsedButNotLoaded)) {
1480 /* either exists fully, or is at least parsed */
1481 mod = findModule(textOf(mc));
1482 assert(nonNull(mod));
1483 if (!compatibleNewMode(mode,module(mod).mode)) {
1486 "module %s: %s required, but %s is more recent",
1487 textToStr(textOf(mc)), modeToString(mode),
1488 modeToString(module(mod).mode)
1490 goto parseException;
1494 setBreakAction ( HugsLongjmpOnBreak );
1495 if (setjmp(catch_error)==0) {
1496 /* try this; it may throw an exception */
1497 mod = parseModuleOrInterface ( mc, mode );
1499 /* here's the exception handler, if parsing fails */
1500 /* A parse error (or similar). Clean up and abort. */
1502 setBreakAction ( HugsIgnoreBreak );
1503 mod = findModule(textOf(mc));
1504 if (nonNull(mod)) nukeModule(mod);
1505 for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
1506 mod = findModule(textOf(hd(t)));
1507 assert(nonNull(mod));
1508 if (nonNull(mod)) nukeModule(mod);
1511 /* end of the exception handler */
1513 setBreakAction ( HugsIgnoreBreak );
1515 parsedButNotLoaded = cons(mc, parsedButNotLoaded);
1516 for (t = module(mod).uses; nonNull(t); t=tl(t))
1518 zpair( hd(t), childMode(mode,module(mod).mode) ),
1523 modgList = dupOnto(parsedButNotLoaded, modgList);
1525 /* We successfully parsed all modules reachable from the target
1526 set which were not part of the reduced system. However, there
1527 may be modules in the reduced system which are not reachable from
1528 the target set. We detect these now by building the transitive
1529 closure of the target set, and nuking modules in the reduced
1530 system which are not part of that closure.
1532 trans_cl = dupList(targetModules);
1535 for (t = trans_cl; nonNull(t); t=tl(t)) {
1536 mod = findModule(textOf(hd(t)));
1537 assert(nonNull(mod));
1538 for (u = module(mod).uses; nonNull(u); u=tl(u))
1539 if (!varIsMember(textOf(hd(u)),trans_cl)
1540 && !varIsMember(textOf(hd(u)),trans_cl_new)
1541 && !varIsMember(textOf(hd(u)),prelModules))
1542 trans_cl_new = cons(hd(u),trans_cl_new);
1544 if (isNull(trans_cl_new)) break;
1545 trans_cl = appendOnto(trans_cl_new,trans_cl);
1548 for (t = modgList; nonNull(t); t=tl(t)) {
1549 if (varIsMember(textOf(hd(t)),trans_cl)) {
1550 modgList_new = cons(hd(t),modgList_new);
1552 mod = findModule(textOf(hd(t)));
1553 assert(nonNull(mod));
1557 modgList = modgList_new;
1559 /* Now, the module symbol tables hold exactly the set of
1560 modules reachable from the target set, and modgList holds
1561 their names. Calculate the scc-ified module graph,
1562 since we need that to guide the next stage, that of
1563 Actually Loading the modules.
1565 If no errors occur, moduleGraph will reflect the final graph
1566 loaded. If an error occurs loading a group, we nuke
1567 that group, truncate the moduleGraph just prior to that
1568 group, and exit. That leaves the system having successfully
1569 loaded all groups prior to the one which failed.
1571 mgFromList ( modgList );
1573 for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
1576 if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
1577 parsedButNotLoaded)) continue;
1579 setBreakAction ( HugsLongjmpOnBreak );
1580 if (setjmp(catch_error)==0) {
1581 /* try this; it may throw an exception */
1584 /* here's the exception handler, if static/typecheck etc fails */
1585 /* nuke the entire rest (ie, the unloaded part)
1586 of the module graph */
1587 setBreakAction ( HugsIgnoreBreak );
1588 badMods = listFromSpecifiedMG ( mg );
1589 for (t = badMods; nonNull(t); t=tl(t)) {
1590 mod = findModule(textOf(hd(t)));
1591 if (nonNull(mod)) nukeModule(mod);
1593 /* truncate the module graph just prior to this group. */
1597 if (isNull(mg)) break;
1598 if (hd(mg) == grp) break;
1599 mg2 = cons ( hd(mg), mg2 );
1602 moduleGraph = reverse(mg2);
1604 /* end of the exception handler */
1606 setBreakAction ( HugsIgnoreBreak );
1609 /* Err .. I think that's it. If we get here, we've successfully
1610 achieved the target set. Phew!
1612 setBreakAction ( HugsIgnoreBreak );
1616 static Bool loadThePrelude ( void )
1621 moduleGraph = prelModules = NIL;
1624 conPrelude = mkCon(findText("Prelude"));
1625 conPrelHugs = mkCon(findText("PrelHugs"));
1626 targetModules = doubleton(conPrelude,conPrelHugs);
1627 achieveTargetModules(TRUE);
1628 ok = elemMG(conPrelude) && elemMG(conPrelHugs);
1630 conPrelude = mkCon(findText("Prelude"));
1631 targetModules = singleton(conPrelude);
1632 achieveTargetModules(TRUE);
1633 ok = elemMG(conPrelude);
1636 if (ok) prelModules = listFromMG();
1641 /* Refresh the current target modules, and attempt to set the
1642 current module to what it was before (ie currentModule):
1643 if currentModule_failed is different from currentModule,
1645 if nextCurrMod is non null, try to set it to that instead
1646 if the one we're after insn't available, select a target
1647 from the end of the module group list.
1649 static void refreshActions ( ConId nextCurrMod, Bool cleanAfter )
1654 /* Remember what the old current module was. */
1655 tryFor = mkCon(module(currentModule).text);
1657 /* Do the Real Work. */
1658 achieveTargetModules(FALSE);
1660 /* Remember if the current module was invalidated by this
1661 refresh, so later refreshes can attempt to reload it. */
1662 if (!elemMG(tryFor))
1663 currentModule_failed = tryFor;
1665 /* If a previous refresh failed to get an old current module,
1666 try for that instead. */
1667 if (nonNull(currentModule_failed)
1668 && textOf(currentModule_failed) != textOf(tryFor)
1669 && elemMG(currentModule_failed))
1670 tryFor = currentModule_failed;
1671 /* If our caller specified a new current module, that overrides
1672 all historical settings. */
1673 if (nonNull(nextCurrMod))
1674 tryFor = nextCurrMod;
1675 /* Finally, if we can't actually get hold of whatever it was we
1676 were after, select something which is possible. */
1677 if (!elemMG(tryFor))
1678 tryFor = selectLatestMG();
1680 /* combined mode kludge, to get Prelude rather than PrelHugs */
1681 if (combined && textOf(tryFor)==findText("PrelHugs"))
1682 tryFor = mkCon(findText("Prelude"));
1685 /* delete any targetModules which didn't actually get loaded */
1687 targetModules = NIL;
1688 for (; nonNull(t); t=tl(t))
1690 targetModules = cons(hd(t),targetModules);
1693 setCurrModule ( findModule(textOf(tryFor)) );
1694 Printf("Hugs session for:\n");
1699 static void addActions ( List extraModules /* :: [CONID] */ )
1702 for (t = extraModules; nonNull(t); t=tl(t)) {
1703 ConId extra = hd(t);
1704 if (!varIsMember(textOf(extra),targetModules))
1705 targetModules = cons(extra,targetModules);
1707 refreshActions ( isNull(extraModules)
1709 : hd(reverse(extraModules)),
1715 static void loadActions ( List loadModules /* :: [CONID] */ )
1718 targetModules = dupList ( prelModules );
1720 for (t = loadModules; nonNull(t); t=tl(t)) {
1722 if (!varIsMember(textOf(load),targetModules))
1723 targetModules = cons(load,targetModules);
1725 refreshActions ( isNull(loadModules)
1727 : hd(reverse(loadModules)),
1733 /* --------------------------------------------------------------------------
1734 * Access to external editor:
1735 * ------------------------------------------------------------------------*/
1737 /* ToDo: All this editor stuff needs fixing. */
1739 static Void local editor() { /* interpreter-editor interface */
1741 String newFile = readFilename();
1743 setLastEdit(newFile,0);
1744 if (readFilename()) {
1745 ERRMSG(0) "Multiple filenames not permitted"
1753 static Void local find() { /* edit file containing definition */
1756 String nm = readFilename(); /* of specified name */
1758 ERRMSG(0) "No name specified"
1761 else if (readFilename()) {
1762 ERRMSG(0) "Multiple names not permitted"
1768 setCurrModule(findEvalModule());
1770 if (nonNull(c=findTycon(t=findText(nm)))) {
1771 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1772 readScripts(N_PRELUDE_SCRIPTS);
1774 } else if (nonNull(c=findName(t))) {
1775 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1776 readScripts(N_PRELUDE_SCRIPTS);
1779 ERRMSG(0) "No current definition for name \"%s\"", nm
1786 static Void local runEditor() { /* run editor on script lastEdit */
1788 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1789 readScripts(N_PRELUDE_SCRIPTS);
1793 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1799 lastEdit = strCopy(fname);
1804 /* --------------------------------------------------------------------------
1805 * Read and evaluate an expression:
1806 * ------------------------------------------------------------------------*/
1808 static Void setModule ( void ) {
1809 /*set module in which to evaluate expressions*/
1812 String s = readFilename();
1814 mc = selectLatestMG();
1815 if (combined && textOf(mc)==findText("PrelHugs"))
1816 mc = mkCon(findText("Prelude"));
1817 m = findModule(textOf(mc));
1820 m = findModule(findText(s));
1822 ERRMSG(0) "Cannot find module \"%s\"", s
1830 static Module allocEvalModule ( void )
1832 Module evalMod = newModule( findText("_Eval_Module_") );
1833 module(evalMod).names = module(currentModule).names;
1834 module(evalMod).tycons = module(currentModule).tycons;
1835 module(evalMod).classes = module(currentModule).classes;
1836 module(evalMod).qualImports
1837 = singleton(pair(mkCon(textPrelude),modulePrelude));
1841 static Void local evaluator() { /* evaluate expr and print value */
1844 volatile Kinds ks = NIL;
1845 volatile Module evalMod = allocEvalModule();
1846 volatile Module currMod = currentModule;
1847 setCurrModule(evalMod);
1850 defaultDefns = combined ? stdDefaults : evalDefaults;
1852 setBreakAction ( HugsLongjmpOnBreak );
1853 if (setjmp(catch_error)==0) {
1857 type = typeCheckExp(TRUE);
1859 /* if an exception happens, we arrive here */
1860 setBreakAction ( HugsIgnoreBreak );
1861 goto cleanup_and_return;
1864 setBreakAction ( HugsIgnoreBreak );
1865 if (isPolyType(type)) {
1866 ks = polySigOf(type);
1867 bd = monotypeOf(type);
1872 if (whatIs(bd)==QUAL) {
1875 ERRMSG(0) "Unresolved overloading" ETHEN
1876 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1877 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1880 goto cleanup_and_return;
1886 if (isProgType(ks,bd)) {
1887 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1891 Cell d = provePred(ks,NIL,ap(classShow,bd));
1895 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1896 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1897 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1900 goto cleanup_and_return;
1902 inputExpr = ap2(nameShow, d,inputExpr);
1903 inputExpr = ap (namePutStr, inputExpr);
1904 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1906 evalExp(); printf("\n");
1909 printType(stdout,type);
1916 printf ( "result type is " );
1917 printType ( stdout, type );
1925 setBreakAction ( HugsIgnoreBreak );
1926 nukeModule(evalMod);
1927 setCurrModule(currMod);
1928 setCurrentFile(currMod);
1934 /* --------------------------------------------------------------------------
1935 * Print type of input expression:
1936 * ------------------------------------------------------------------------*/
1938 static Void showtype ( void ) { /* print type of expression (if any)*/
1941 volatile Module evalMod = allocEvalModule();
1942 volatile Module currMod = currentModule;
1943 setCurrModule(evalMod);
1945 if (setjmp(catch_error)==0) {
1949 defaultDefns = evalDefaults;
1950 type = typeCheckExp(FALSE);
1951 printExp(stdout,inputExpr);
1953 printType(stdout,type);
1956 /* if an exception happens, we arrive here */
1959 nukeModule(evalMod);
1960 setCurrModule(currMod);
1964 static Void local browseit(mod,t,all)
1971 Printf("module %s where\n",textToStr(module(mod).text));
1972 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1974 /* only look at things defined in this module,
1975 unless `all' flag is set */
1976 if (all || name(nm).mod == mod) {
1977 /* unwanted artifacts, like lambda lifted values,
1978 are in the list of names, but have no types */
1979 if (nonNull(name(nm).type)) {
1980 printExp(stdout,nm);
1982 printType(stdout,name(nm).type);
1984 Printf(" -- data constructor");
1985 } else if (isMfun(nm)) {
1986 Printf(" -- class member");
1987 } else if (isSfun(nm)) {
1988 Printf(" -- selector function");
1996 Printf("Unknown module %s\n",t);
2001 static Void local browse() { /* browse modules */
2002 Int count = 0; /* or give menu of commands */
2006 for (; (s=readFilename())!=0; count++)
2007 if (strcmp(s,"all") == 0) {
2011 browseit(findModule(findText(s)),s,all);
2013 browseit(currentModule,NULL,all);
2017 #if EXPLAIN_INSTANCE_RESOLUTION
2018 static Void local xplain() { /* print type of expression (if any)*/
2020 Bool sir = showInstRes;
2022 setCurrModule(findEvalModule());
2023 startNewScript(0); /* Enables recovery of storage */
2024 /* allocated during evaluation */
2028 d = provePred(NIL,NIL,hd(inputContext));
2030 fprintf(stdout, "not Sat\n");
2032 fprintf(stdout, "Sat\n");
2038 /* --------------------------------------------------------------------------
2039 * Enhanced help system: print current list of scripts or give information
2041 * ------------------------------------------------------------------------*/
2043 static String local objToStr(m,c)
2046 #if 1 || DISPLAY_QUANTIFIERS
2047 static char newVar[60];
2048 switch (whatIs(c)) {
2049 case NAME : if (m == name(c).mod) {
2050 sprintf(newVar,"%s", textToStr(name(c).text));
2052 sprintf(newVar,"%s.%s",
2053 textToStr(module(name(c).mod).text),
2054 textToStr(name(c).text));
2058 case TYCON : if (m == tycon(c).mod) {
2059 sprintf(newVar,"%s", textToStr(tycon(c).text));
2061 sprintf(newVar,"%s.%s",
2062 textToStr(module(tycon(c).mod).text),
2063 textToStr(tycon(c).text));
2067 case CLASS : if (m == cclass(c).mod) {
2068 sprintf(newVar,"%s", textToStr(cclass(c).text));
2070 sprintf(newVar,"%s.%s",
2071 textToStr(module(cclass(c).mod).text),
2072 textToStr(cclass(c).text));
2076 default : internal("objToStr");
2080 static char newVar[33];
2081 switch (whatIs(c)) {
2082 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
2085 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
2088 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
2091 default : internal("objToStr");
2099 static Void dumpStg ( void )
2105 setCurrModule(findEvalModule());
2110 /* request to locate a symbol by name */
2111 if (s && (*s == '?')) {
2112 Text t = findText(s+1);
2113 locateSymbolByName(t);
2117 /* request to dump a bit of the heap */
2118 if (s && (*s == '-' || isdigit(*s))) {
2125 /* request to dump a symbol table entry */
2127 || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
2128 || !isdigit(s[1])) {
2129 fprintf(stderr, ":d -- bad request `%s'\n", s );
2134 case 't': dumpTycon(i); break;
2135 case 'n': dumpName(i); break;
2136 case 'c': dumpClass(i); break;
2137 case 'i': dumpInst(i); break;
2138 default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
2144 static Void local dumpStg( void ) { /* print STG stuff */
2149 Cell v; /* really StgVar */
2150 setCurrModule(findEvalModule());
2152 for (; (s=readFilename())!=0;) {
2155 /* find the name while ignoring module scopes */
2156 for (i=NAMEMIN; i<nameHw; i++)
2157 if (name(i).text == t) n = i;
2159 /* perhaps it's an "idNNNNNN" thing? */
2162 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2165 while (isdigit(s[i])) {
2166 v = v * 10 + (s[i]-'0');
2170 n = nameFromStgVar(v);
2173 if (isNull(n) && whatIs(v)==STGVAR) {
2174 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2175 printStg(stderr, v );
2178 Printf ( "Unknown reference `%s'\n", s );
2181 Printf ( "Not a Name: `%s'\n", s );
2183 if (isNull(name(n).stgVar)) {
2184 Printf ( "Doesn't have a STG tree: %s\n", s );
2186 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2187 printStg(stderr, name(n).stgVar);
2193 static Void local info() { /* describe objects */
2194 Int count = 0; /* or give menu of commands */
2197 for (; (s=readFilename())!=0; count++) {
2198 describe(findText(s));
2201 /* whatScripts(); */
2206 static Void local describe(t) /* describe an object */
2208 Tycon tc = findTycon(t);
2209 Class cl = findClass(t);
2210 Name nm = findName(t);
2212 if (nonNull(tc)) { /* as a type constructor */
2216 for (i=0; i<tycon(tc).arity; ++i) {
2217 t = ap(t,mkOffset(i));
2219 Printf("-- type constructor");
2221 Printf(" with kind ");
2222 printKind(stdout,tycon(tc).kind);
2225 switch (tycon(tc).what) {
2226 case SYNONYM : Printf("type ");
2227 printType(stdout,t);
2229 printType(stdout,tycon(tc).defn);
2233 case DATATYPE : { List cs = tycon(tc).defn;
2234 if (tycon(tc).what==DATATYPE) {
2239 printType(stdout,t);
2241 mapProc(printSyntax,cs);
2243 Printf("\n-- constructors:");
2245 for (; hasCfun(cs); cs=tl(cs)) {
2247 printExp(stdout,hd(cs));
2249 printType(stdout,name(hd(cs)).type);
2252 Printf("\n-- selectors:");
2254 for (; nonNull(cs); cs=tl(cs)) {
2256 printExp(stdout,hd(cs));
2258 printType(stdout,name(hd(cs)).type);
2263 case RESTRICTSYN : Printf("type ");
2264 printType(stdout,t);
2265 Printf(" = <restricted>");
2269 if (nonNull(in=findFirstInst(tc))) {
2270 Printf("\n-- instances:\n");
2273 in = findNextInst(tc,in);
2274 } while (nonNull(in));
2279 if (nonNull(cl)) { /* as a class */
2280 List ins = cclass(cl).instances;
2281 Kinds ks = cclass(cl).kinds;
2282 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2283 Printf("-- type class");
2285 Printf("-- constructor class");
2287 Printf(" with arity ");
2288 printKinds(stdout,ks);
2292 mapProc(printSyntax,cclass(cl).members);
2294 if (nonNull(cclass(cl).supers)) {
2295 printContext(stdout,cclass(cl).supers);
2298 printPred(stdout,cclass(cl).head);
2300 if (nonNull(cclass(cl).fds)) {
2301 List fds = cclass(cl).fds;
2303 for (; nonNull(fds); fds=tl(fds)) {
2305 printFD(stdout,hd(fds));
2310 if (nonNull(cclass(cl).members)) {
2311 List ms = cclass(cl).members;
2314 Type t = name(hd(ms)).type;
2315 if (isPolyType(t)) {
2319 printExp(stdout,hd(ms));
2321 if (isNull(tl(fst(snd(t))))) {
2324 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2326 printType(stdout,t);
2328 } while (nonNull(ms));
2332 Printf("\n-- instances:\n");
2336 } while (nonNull(ins));
2341 if (nonNull(nm)) { /* as a function/name */
2343 printExp(stdout,nm);
2345 if (nonNull(name(nm).type)) {
2346 printType(stdout,name(nm).type);
2348 Printf("<unknown type>");
2351 Printf(" -- data constructor");
2352 } else if (isMfun(nm)) {
2353 Printf(" -- class member");
2354 } else if (isSfun(nm)) {
2355 Printf(" -- selector function");
2361 if (isNull(tc) && isNull(cl) && isNull(nm)) {
2362 Printf("Unknown reference `%s'\n",textToStr(t));
2366 static Void local printSyntax(nm)
2368 Syntax sy = syntaxOf(nm);
2369 Text t = name(nm).text;
2370 String s = textToStr(t);
2371 if (sy != defaultSyntax(t)) {
2373 switch (assocOf(sy)) {
2374 case LEFT_ASS : Putchar('l'); break;
2375 case RIGHT_ASS : Putchar('r'); break;
2376 case NON_ASS : break;
2378 Printf(" %i ",precOf(sy));
2379 if (isascii((int)(*s)) && isalpha((int)(*s))) {
2388 static Void local showInst(in) /* Display instance decl header */
2390 Printf("instance ");
2391 if (nonNull(inst(in).specifics)) {
2392 printContext(stdout,inst(in).specifics);
2395 printPred(stdout,inst(in).head);
2399 /* --------------------------------------------------------------------------
2400 * List all names currently in scope:
2401 * ------------------------------------------------------------------------*/
2403 static Void local listNames() { /* list names matching optional pat*/
2404 String pat = readFilename();
2406 Int width = getTerminalWidth() - 1;
2409 Module mod = currentModule;
2411 if (pat) { /* First gather names to list */
2413 names = addNamesMatching(pat,names);
2414 } while ((pat=readFilename())!=0);
2416 names = addNamesMatching((String)0,names);
2418 if (isNull(names)) { /* Then print them out */
2420 ERRMSG(0) "No names selected"
2424 for (termPos=0; nonNull(names); names=tl(names)) {
2425 String s = objToStr(mod,hd(names));
2427 if (termPos+1+l>width) {
2430 } else if (termPos>0) {
2438 Printf("\n(%d names listed)\n", count);
2441 /* --------------------------------------------------------------------------
2442 * print a prompt and read a line of input:
2443 * ------------------------------------------------------------------------*/
2445 static Void local promptForInput(moduleName)
2446 String moduleName; {
2447 char promptBuffer[1000];
2449 /* This is portable but could overflow buffer */
2450 sprintf(promptBuffer,prompt,moduleName);
2452 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2453 * promptBuffer instead.
2455 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2456 /* Reset prompt to a safe default to avoid an infinite loop */
2458 prompt = strCopy("? ");
2459 internal("Combined prompt and evaluation module name too long");
2463 stringInput("main\0"); else
2464 consoleInput(promptBuffer);
2467 /* --------------------------------------------------------------------------
2468 * main read-eval-print loop, with error trapping:
2469 * ------------------------------------------------------------------------*/
2471 static Void local interpreter(argc,argv)/* main interpreter loop */
2475 List modConIds; /* :: [CONID] */
2479 setBreakAction ( HugsIgnoreBreak );
2480 modConIds = initialize(argc,argv); /* the initial modules to load */
2481 setBreakAction ( HugsIgnoreBreak );
2482 prelOK = loadThePrelude();
2486 fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2488 fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2492 if (combined) everybody(POSTPREL);
2493 loadActions(modConIds);
2496 for (; nonNull(modConIds); modConIds=tl(modConIds))
2497 if (!elemMG(hd(modConIds))) {
2499 "hugs +Q: compilation failed -- can't run `main'\n" );
2506 /* initialize calls startupHaskell, which trashes our signal handlers */
2507 setBreakAction ( HugsIgnoreBreak );
2512 everybody(RESET); /* reset to sensible initial state */
2514 promptForInput(textToStr(module(currentModule).text));
2516 cmd = readCommand(cmds, (Char)':', (Char)'!');
2518 case EDIT : editor();
2522 case LOAD : modConIds = NIL;
2523 while ((s=readFilename())!=0) {
2524 modConIds = cons(mkCon(findText(s)),modConIds);
2527 loadActions(modConIds);
2530 case ALSO : modConIds = NIL;
2531 while ((s=readFilename())!=0)
2532 modConIds = cons(mkCon(findText(s)),modConIds);
2533 addActions(modConIds);
2536 case RELOAD : refreshActions(NIL,FALSE);
2541 case EVAL : evaluator();
2543 case TYPEOF : showtype();
2545 case BROWSE : browse();
2547 #if EXPLAIN_INSTANCE_RESOLUTION
2548 case XPLAIN : xplain();
2551 case NAMES : listNames();
2555 case BADCMD : guidance();
2559 case SYSTEM : if (shellEsc(readLine()))
2560 Printf("Warning: Shell escape terminated abnormally\n");
2562 case CHGDIR : changeDir();
2566 case PNTVER: Printf("-- Hugs Version %s\n",
2569 case DUMP : dumpStg();
2572 case COLLECT: consGC = FALSE;
2575 Printf("Garbage collection recovered %d cells\n",
2581 if (autoMain) break;
2585 /* --------------------------------------------------------------------------
2586 * Display progress towards goal:
2587 * ------------------------------------------------------------------------*/
2589 static Target currTarget;
2590 static Bool aiming = FALSE;
2593 static Int charCount;
2595 Void setGoal(what, t) /* Set goal for what to be t */
2600 #if EXPLAIN_INSTANCE_RESOLUTION
2604 currTarget = (t?t:1);
2607 currPos = strlen(what);
2608 maxPos = getTerminalWidth() - 1;
2612 for (charCount=0; *what; charCount++)
2617 Void soFar(t) /* Indicate progress towards goal */
2618 Target t; { /* has now reached t */
2621 #if EXPLAIN_INSTANCE_RESOLUTION
2626 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2631 if (newPos>currPos) {
2634 while (newPos>++currPos);
2641 Void done() { /* Goal has now been achieved */
2644 #if EXPLAIN_INSTANCE_RESOLUTION
2649 while (maxPos>currPos++)
2654 for (; charCount>0; charCount--) {
2663 static Void local failed() { /* Goal cannot be reached due to */
2664 if (aiming) { /* errors */
2671 /* --------------------------------------------------------------------------
2673 * ------------------------------------------------------------------------*/
2675 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
2676 if (printing) { /* after successful termination or */
2677 printing = FALSE; /* runtime error (e.g. interrupt) */
2680 #define plural(v) v, (v==1?"":"s")
2681 Printf("(%lu enter%s)\n",plural(numEnters));
2689 Cell errAssert(l) /* message to use when raising asserts, etc */
2693 str = mkStr(findText(currentFile));
2695 str = mkStr(findText(""));
2697 return (ap2(nameTangleMessage,str,mkInt(l)));
2700 Void errHead(l) /* print start of error message */
2702 failed(); /* failed to reach target ... */
2704 FPrintf(errorStream,"ERROR");
2707 FPrintf(errorStream," \"%s\"", currentFile);
2708 setLastEdit(currentFile,l);
2709 if (l) FPrintf(errorStream," (line %d)",l);
2712 FPrintf(errorStream,": ");
2713 FFlush(errorStream);
2716 Void errFail() { /* terminate error message and */
2717 Putc('\n',errorStream); /* produce exception to return to */
2718 FFlush(errorStream); /* main command loop */
2719 longjmp(catch_error,1);
2722 Void errFail_no_longjmp() { /* terminate error message but */
2723 Putc('\n',errorStream); /* don't produce an exception */
2724 FFlush(errorStream);
2727 Void errAbort() { /* altern. form of error handling */
2728 failed(); /* used when suitable error message*/
2729 stopAnyPrinting(); /* has already been printed */
2733 Void internal(msg) /* handle internal error */
2737 Printf("INTERNAL ERROR: %s\n",msg);
2740 longjmp(catch_error,1);
2743 Void fatal(msg) /* handle fatal error */
2746 Printf("\nFATAL ERROR: %s\n",msg);
2752 /* --------------------------------------------------------------------------
2753 * Read value from environment variable or registry:
2754 * ------------------------------------------------------------------------*/
2756 String fromEnv(var,def) /* return value of: */
2757 String var; /* environment variable named by var */
2758 String def; { /* or: default value given by def */
2759 String s = getenv(var);
2760 return (s ? s : def);
2763 /* --------------------------------------------------------------------------
2764 * String manipulation routines:
2765 * ------------------------------------------------------------------------*/
2767 static String local strCopy(s) /* make malloced copy of a string */
2771 if ((t=(char *)malloc(strlen(s)+1))==0) {
2772 ERRMSG(0) "String storage space exhausted"
2775 for (r=t; (*r++ = *s++)!=0; ) {
2783 /* --------------------------------------------------------------------------
2785 * We can redirect compiler output (prompts, error messages, etc) by
2786 * tweaking these functions.
2787 * ------------------------------------------------------------------------*/
2789 #ifdef HAVE_STDARG_H
2792 #include <varargs.h>
2795 Void hugsEnableOutput(f)
2800 #ifdef HAVE_STDARG_H
2801 Void hugsPrintf(const char *fmt, ...) {
2802 va_list ap; /* pointer into argument list */
2803 va_start(ap, fmt); /* make ap point to first arg after fmt */
2804 if (!disableOutput) {
2808 va_end(ap); /* clean up */
2811 Void hugsPrintf(fmt, va_alist)
2814 va_list ap; /* pointer into argument list */
2815 va_start(ap); /* make ap point to first arg after fmt */
2816 if (!disableOutput) {
2820 va_end(ap); /* clean up */
2826 if (!disableOutput) {
2832 Void hugsFlushStdout() {
2833 if (!disableOutput) {
2840 if (!disableOutput) {
2845 #ifdef HAVE_STDARG_H
2846 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2849 if (!disableOutput) {
2850 vfprintf(fp, fmt, ap);
2856 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2862 if (!disableOutput) {
2863 vfprintf(fp, fmt, ap);
2870 Void hugsPutc(c, fp)
2873 if (!disableOutput) {
2879 /* --------------------------------------------------------------------------
2880 * Send message to each component of system:
2881 * ------------------------------------------------------------------------*/
2883 Void everybody(what) /* send command `what' to each component of*/
2884 Int what; { /* system to respond as appropriate ... */
2886 fprintf ( stderr, "EVERYBODY %d\n", what );
2888 machdep(what); /* The order of calling each component is */
2889 storage(what); /* important for the PREPREL command */
2892 translateControl(what);
2894 staticAnalysis(what);
2895 deriveControl(what);
2903 mark(targetModules);
2905 mark(currentModule_failed);
2909 /*-------------------------------------------------------------------------*/