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/04/27 16:35:29 $
14 * ------------------------------------------------------------------------*/
20 #include "hugsbasictypes.h"
29 #include "Assembler.h" /* DEBUG_LoadSymbols */
31 Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
32 Bool initDone = FALSE;
34 #if EXPLAIN_INSTANCE_RESOLUTION
35 Bool showInstRes = FALSE;
38 Bool multiInstRes = FALSE;
41 /* --------------------------------------------------------------------------
42 * Local function prototypes:
43 * ------------------------------------------------------------------------*/
45 static List local initialize ( Int,String [] );
46 static Void local promptForInput ( String );
47 static Void local interpreter ( Int,String [] );
48 static Void local menu ( Void );
49 static Void local guidance ( Void );
50 static Void local forHelp ( Void );
51 static Void local set ( Void );
52 static Void local changeDir ( Void );
53 static Void local load ( Void );
54 static Void local project ( Void );
55 static Void local editor ( Void );
56 static Void local find ( Void );
57 static Bool local startEdit ( Int,String );
58 static Void local runEditor ( Void );
59 static Void local setModule ( Void );
60 static Void local evaluator ( Void );
61 static Void local stopAnyPrinting ( Void );
62 static Void local showtype ( Void );
63 static String local objToStr ( Module, Cell );
64 static Void local info ( Void );
65 static Void local printSyntax ( Name );
66 static Void local showInst ( Inst );
67 static Void local describe ( Text );
68 static Void local listNames ( Void );
70 static Void local toggleSet ( Char,Bool );
71 static Void local togglesIn ( Bool );
72 static Void local optionInfo ( Void );
73 static Void local readOptions ( String );
74 static Bool local processOption ( String );
75 static Void local setHeapSize ( String );
76 static Int local argToInt ( String );
78 static Void local setLastEdit ( String,Int );
79 static Void local failed ( Void );
80 static String local strCopy ( String );
81 static Void local browseit ( Module,String,Bool );
82 static Void local browse ( Void );
83 static void local clearCurrentFile ( void );
86 /* --------------------------------------------------------------------------
87 * Machine dependent code for Hugs interpreter:
88 * ------------------------------------------------------------------------*/
92 /* --------------------------------------------------------------------------
94 * ------------------------------------------------------------------------*/
96 static Bool printing = FALSE; /* TRUE => currently printing value*/
97 static Bool showStats = FALSE; /* TRUE => print stats after eval */
98 static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
99 static Bool addType = FALSE; /* TRUE => print type with value */
100 static Bool useDots = RISCOS; /* TRUE => use dots in progress */
101 static Bool quiet = FALSE; /* TRUE => don't show progress */
102 static Bool lastWasObject = FALSE;
104 Bool flagAssert = FALSE; /* TRUE => assert False <e> causes
105 an assertion failure */
106 Bool preludeLoaded = FALSE;
107 Bool debugSC = FALSE;
108 Bool combined = FALSE;
110 Module moduleBeingParsed; /* so the parser (topModule) knows */
111 static char* currentFile; /* Name of current file, or NULL */
112 static char currentFileName[1000]; /* name is stored here if it exists*/
114 static Bool autoMain = FALSE;
115 static String lastEdit = 0; /* Name of script to edit (if any) */
116 static Int lastEdLine = 0; /* Editor line number (if possible)*/
117 static String prompt = 0; /* Prompt string */
118 static Int hpSize = DEFAULTHEAP; /* Desired heap size */
119 static Bool disableOutput = FALSE; /* TRUE => quiet */
120 String hugsEdit = 0; /* String for editor command */
121 String hugsPath = 0; /* String for file search path */
123 List ifaces_outstanding = NIL;
125 static ConId currentModule_failed = NIL; /* Remember failed module from :r */
129 /* --------------------------------------------------------------------------
131 * ------------------------------------------------------------------------*/
133 #ifndef NO_MAIN /* we omit main when building the "Hugs server" */
135 Main main ( Int, String [] ); /* now every func has a prototype */
140 #ifdef HAVE_CONSOLE_H /* Macintosh port */
142 _fcreator = 'R*ch'; /* // 'KAHL'; //'*TEX'; //'ttxt'; */
144 console_options.top = 50;
145 console_options.left = 20;
147 console_options.nrows = 32;
148 console_options.ncols = 80;
150 console_options.pause_atexit = 1;
151 console_options.title = "\pHugs";
153 console_options.procID = 5;
154 argc = ccommand(&argv);
157 CStackBase = &argc; /* Save stack base for use in gc */
161 checkBytecodeCount(); /* check for too many bytecodes */
165 /* If first arg is +Q or -Q, be entirely silent, and automatically run
166 main after loading scripts. Useful for running the nofib suite. */
167 if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
169 if (strcmp(argv[1],"-Q") == 0) {
174 Printf("__ __ __ __ ____ ___ _________________________________________\n");
175 Printf("|| || || || || || ||__ STGHugs: Based on the Haskell 98 standard\n");
176 Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-2000\n");
177 Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
178 Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
179 Printf("|| || Version: %s _________________________________________\n\n",HUGS_VERSION);
181 /* Get the absolute path to the directory containing the hugs
182 executable, so that we know where the Prelude and nHandle.so/.dll are.
183 We do this by reading env var STGHUGSDIR. This needs to succeed, so
184 setInstallDir won't return unless it succeeds.
186 setInstallDir ( argv[0] );
189 Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
192 interpreter(argc,argv);
193 Printf("[Leaving Hugs]\n");
204 /* --------------------------------------------------------------------------
205 * Initialization, interpret command line args and read prelude:
206 * ------------------------------------------------------------------------*/
208 static List /*CONID*/ initialize ( Int argc, String argv[] )
213 setLastEdit((String)0,0);
220 hugsEdit = strCopy(fromEnv("EDITOR",NULL));
222 hugsPath = strCopy(HUGSPATH);
223 readOptions("-p\"%s> \" -r$$");
224 readOptions(fromEnv("STGHUGSFLAGS",""));
228 char exe_name[N_INSTALLDIR + 6];
229 strcpy(exe_name, installDir);
230 strcat(exe_name, "hugs");
231 DEBUG_LoadSymbols(exe_name);
235 /* startupHaskell extracts args between +RTS ... -RTS, and sets
236 prog_argc/prog_argv to the rest. We want to further process
237 the rest, so we then get hold of them again.
239 startupHaskell ( argc, argv, NULL );
240 getProgArgv ( &argc, &argv );
242 /* Find out early on if we're in combined mode or not.
243 everybody(PREPREL) needs to know this. Also, establish the
246 for (i = 1; i < argc; ++i) {
247 if (strcmp(argv[i], "--")==0) break;
248 if (strcmp(argv[i], "-c")==0) combined = FALSE;
249 if (strcmp(argv[i], "+c")==0) combined = TRUE;
251 if (strncmp(argv[i],"+h",2)==0 || strncmp(argv[i],"-h",2)==0)
252 setHeapSize(&(argv[i][2]));
256 initialModules = NIL;
258 for (i = 1; i < argc; ++i) { /* process command line arguments */
259 if (strcmp(argv[i], "--")==0)
260 { argv[i] = NULL; break; }
261 if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/) {
262 if (!processOption(argv[i]))
264 = cons ( mkCon(findText(argv[i])), initialModules );
270 Printf("Haskell 98 mode: Restart with command line option -98"
271 " to enable extensions\n");
273 Printf("Hugs mode: Restart with command line option +98 for"
274 " Haskell 98 mode\n");
278 Printf("Combined mode: Restart with command line -c for"
279 " standalone mode\n\n" );
281 Printf("Standalone mode: Restart with command line +c for"
282 " combined mode\n\n" );
285 /* slide args back over the deleted ones. */
287 for (i = 1; i < argc; i++)
293 setProgArgv ( argc, argv );
296 return initialModules;
299 /* --------------------------------------------------------------------------
300 * Command line options:
301 * ------------------------------------------------------------------------*/
303 struct options { /* command line option toggles */
304 char c; /* table defined in main app. */
309 extern struct options toggle[];
311 static Void local toggleSet(c,state) /* Set command line toggle */
315 for (i=0; toggle[i].c; ++i)
316 if (toggle[i].c == c) {
317 *toggle[i].flag = state;
321 ERRMSG(0) "Unknown toggle `%c'", c
325 static Void local togglesIn(state) /* Print current list of toggles in*/
326 Bool state; { /* given state */
329 for (i=0; toggle[i].c; ++i)
330 if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
332 Putchar((char)(state ? '+' : '-'));
333 Putchar(toggle[i].c);
340 static Void local optionInfo() { /* Print information about command */
341 static String fmts = "%-5s%s\n"; /* line settings */
342 static String fmtc = "%-5c%s\n";
345 Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
346 for (i=0; toggle[i].c; ++i) {
347 if (!haskell98 || toggle[i].h98) {
348 Printf(fmtc,toggle[i].c,toggle[i].description);
352 Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
353 Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
354 Printf(fmts,"pstr","Set prompt string to str");
355 Printf(fmts,"rstr","Set repeat last expression string to str");
356 Printf(fmts,"Pstr","Set search path for modules to str");
357 Printf(fmts,"Estr","Use editor setting given by str");
358 Printf(fmts,"cnum","Set constraint cutoff limit");
359 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
360 Printf(fmts,"Fstr","Set preprocessor filter to str");
363 Printf("\nCurrent settings: ");
366 Printf("-h%d",heapSize);
370 printString(repeatStr);
371 Printf(" -c%d",cutoff);
372 Printf("\nSearch path : -P");
373 printString(hugsPath);
376 if (projectPath!=NULL) {
377 Printf("\nProject Path : %s",projectPath);
380 Printf("\nEditor setting : -E");
381 printString(hugsEdit);
382 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
383 Printf("\nPreprocessor : -F");
384 printString(preprocessor);
386 Printf("\nCompatibility : %s", haskell98 ? "Haskell 98 (+98)"
387 : "Hugs Extensions (-98)");
396 static Void local readOptions(options) /* read options from string */
400 stringInput(options);
401 while ((s=readFilename())!=0) {
402 if (*s && !processOption(s)) {
403 ERRMSG(0) "Option string must begin with `+' or `-'"
410 static Bool local processOption(s) /* process string s for options, */
411 String s; { /* return FALSE if none found. */
423 case 'Q' : break; /* already handled */
425 case 'p' : if (s[1]) {
426 if (prompt) free(prompt);
427 prompt = strCopy(s+1);
431 case 'r' : if (s[1]) {
432 if (repeatStr) free(repeatStr);
433 repeatStr = strCopy(s+1);
438 String p = substPath(s+1,hugsPath ? hugsPath : "");
439 if (hugsPath) free(hugsPath);
444 case 'E' : if (hugsEdit) free(hugsEdit);
445 hugsEdit = strCopy(s+1);
448 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
449 case 'F' : if (preprocessor) free(preprocessor);
450 preprocessor = strCopy(s+1);
454 case 'h' : /* don't do anything, since pre-scan of args
455 will have got it already */
458 case 'c' : /* don't do anything, since pre-scan of args
459 will have got it already */
462 case 'D' : /* hack */
464 extern void setRtsFlags( int x );
465 setRtsFlags(argToInt(s+1));
469 default : if (strcmp("98",s)==0) {
470 if (initDone && ((state && !haskell98) ||
471 (!state && haskell98))) {
473 "Haskell 98 compatibility cannot be changed"
474 " while the interpreter is running\n");
487 static Void local setHeapSize(s)
490 hpSize = argToInt(s);
491 if (hpSize < MINIMUMHEAP)
492 hpSize = MINIMUMHEAP;
493 else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
494 hpSize = MAXIMUMHEAP;
495 if (initDone && hpSize != heapSize) {
496 /* ToDo: should this use a message box in winhugs? */
497 FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
504 static Int local argToInt(s) /* read integer from argument str */
509 if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
510 ERRMSG(0) "Missing integer in option setting \"%s\"", t
515 Int d = (*s++) - '0';
516 if (n > ((MAXPOSINT - d)/10)) {
517 ERRMSG(0) "Option setting \"%s\" is too large", t
521 } while (isascii((int)(*s)) && isdigit((int)(*s)));
523 if (*s=='K' || *s=='k') {
524 if (n > (MAXPOSINT/1000)) {
525 ERRMSG(0) "Option setting \"%s\" is too large", t
532 #if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
533 if (*s=='M' || *s=='m') {
534 if (n > (MAXPOSINT/1000000)) {
535 ERRMSG(0) "Option setting \"%s\" is too large", t
543 #if MAXPOSINT > 1000000000
544 if (*s=='G' || *s=='g') {
545 if (n > (MAXPOSINT/1000000000)) {
546 ERRMSG(0) "Option setting \"%s\" is too large", t
555 ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
562 /* --------------------------------------------------------------------------
563 * Print Menu of list of commands:
564 * ------------------------------------------------------------------------*/
566 static struct cmd cmds[] = {
567 {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
568 {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
569 {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
570 {":quit", QUIT}, {":set", SET}, {":find", FIND},
571 {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
572 {":dump", DUMP}, {":ztats", STATS},
573 {":module",SETMODULE},
575 #if EXPLAIN_INSTANCE_RESOLUTION
578 {":version", PNTVER},
583 static Void local menu() {
584 Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
585 Printf("c is the first character in the full name.\n\n");
586 Printf(":load <filenames> load modules from specified files\n");
587 Printf(":load clear all files except prelude\n");
588 Printf(":also <filenames> read additional modules\n");
589 Printf(":reload repeat last load command\n");
590 Printf(":project <filename> use project file\n");
591 Printf(":edit <filename> edit file\n");
592 Printf(":edit edit last module\n");
593 Printf(":module <module> set module for evaluating expressions\n");
594 Printf("<expr> evaluate expression\n");
595 Printf(":type <expr> print type of expression\n");
596 Printf(":? display this list of commands\n");
597 Printf(":set <options> set command line options\n");
598 Printf(":set help on command line options\n");
599 Printf(":names [pat] list names currently in scope\n");
600 Printf(":info <names> describe named objects\n");
601 Printf(":browse <modules> browse names defined in <modules>\n");
602 #if EXPLAIN_INSTANCE_RESOLUTION
603 Printf(":xplain <context> explain instance resolution for <context>\n");
605 Printf(":find <name> edit module containing definition of name\n");
606 Printf(":!command shell escape\n");
607 Printf(":cd dir change directory\n");
608 Printf(":gc force garbage collection\n");
609 Printf(":version print Hugs version\n");
610 Printf(":dump <name> print STG code for named fn\n");
611 #ifdef CRUDE_PROFILING
612 Printf(":ztats <name> print reduction stats\n");
614 Printf(":quit exit Hugs interpreter\n");
617 static Void local guidance() {
618 Printf("Command not recognised. ");
622 static Void local forHelp() {
623 Printf("Type :? for help\n");
626 /* --------------------------------------------------------------------------
627 * Setting of command line options:
628 * ------------------------------------------------------------------------*/
630 struct options toggle[] = { /* List of command line toggles */
631 {'s', 1, "Print no. reductions/cells after eval", &showStats},
632 {'t', 1, "Print type after evaluation", &addType},
633 {'g', 1, "Print no. cells recovered after gc", &gcMessages},
634 {'l', 1, "Literate modules as default", &literateScripts},
635 {'e', 1, "Warn about errors in literate modules", &literateErrors},
636 {'.', 1, "Print dots to show progress", &useDots},
637 {'q', 1, "Print nothing to show progress", &quiet},
638 {'w', 1, "Always show which modules are loaded", &listScripts},
639 {'k', 1, "Show kind errors in full", &kindExpert},
640 {'o', 0, "Allow overlapping instances", &allowOverlap},
641 {'S', 1, "Debug: show generated SC code", &debugSC},
642 {'a', 1, "Raise exception on assert failure", &flagAssert},
643 #if EXPLAIN_INSTANCE_RESOLUTION
644 {'x', 1, "Explain instance resolution", &showInstRes},
647 {'m', 0, "Use multi instance resolution", &multiInstRes},
652 static Void local set() { /* change command line options from*/
653 String s; /* Hugs command line */
655 if ((s=readFilename())!=0) {
657 if (!processOption(s)) {
658 ERRMSG(0) "Option string must begin with `+' or `-'"
661 } while ((s=readFilename())!=0);
667 /* --------------------------------------------------------------------------
668 * Change directory command:
669 * ------------------------------------------------------------------------*/
671 static Void local changeDir() { /* change directory */
672 String s = readFilename();
674 ERRMSG(0) "Unable to change to directory \"%s\"", s
680 /* --------------------------------------------------------------------------
682 * ------------------------------------------------------------------------*/
684 static jmp_buf catch_error; /* jump buffer for error trapping */
686 HugsBreakAction currentBreakAction = HugsIgnoreBreak;
688 static void handler_IgnoreBreak ( int sig )
690 setHandler ( handler_IgnoreBreak );
693 static void handler_LongjmpOnBreak ( int sig )
695 setHandler ( handler_LongjmpOnBreak );
696 Printf("{Interrupted!}\n");
697 longjmp(catch_error,1);
700 static void handler_RtsInterrupt ( int sig )
702 setHandler ( handler_RtsInterrupt );
706 HugsBreakAction setBreakAction ( HugsBreakAction newAction )
708 HugsBreakAction tmp = currentBreakAction;
709 currentBreakAction = newAction;
711 case HugsIgnoreBreak:
712 setHandler ( handler_IgnoreBreak ); break;
713 case HugsLongjmpOnBreak:
714 setHandler ( handler_LongjmpOnBreak ); break;
715 case HugsRtsInterrupt:
716 setHandler ( handler_RtsInterrupt ); break;
718 internal("setBreakAction");
724 /* --------------------------------------------------------------------------
725 * The new module chaser, loader, etc
726 * ------------------------------------------------------------------------*/
728 List moduleGraph = NIL;
729 List prelModules = NIL;
730 List targetModules = NIL;
732 static String modeToString ( Cell mode )
735 case FM_SOURCE: return "source";
736 case FM_OBJECT: return "object";
737 case FM_EITHER: return "source or object";
738 default: internal("modeToString");
742 static Cell childMode ( Cell modeMeRequest, Cell modeMeActual )
744 assert(modeMeActual == FM_SOURCE ||
745 modeMeActual == FM_OBJECT);
746 assert(modeMeRequest == FM_SOURCE ||
747 modeMeRequest == FM_OBJECT ||
748 modeMeRequest == FM_EITHER);
749 if (modeMeRequest == FM_SOURCE) return modeMeRequest;
750 if (modeMeRequest == FM_OBJECT) return modeMeRequest;
751 if (modeMeActual == FM_OBJECT) return FM_OBJECT;
752 if (modeMeActual == FM_SOURCE) return FM_EITHER;
753 internal("childMode");
756 static Bool compatibleNewMode ( Cell modeNew, Cell modeExisting )
758 if (modeNew == FM_OBJECT && modeExisting == FM_OBJECT) return TRUE;
759 if (modeNew == FM_SOURCE && modeExisting == FM_SOURCE) return TRUE;
760 if (modeNew == FM_EITHER && modeExisting == FM_OBJECT) return TRUE;
761 if (modeNew == FM_EITHER && modeExisting == FM_SOURCE) return TRUE;
765 static void setCurrentFile ( Module mod )
767 assert(isModule(mod));
768 strncpy(currentFileName, textToStr(module(mod).text), 990);
769 strcat(currentFileName, textToStr(module(mod).srcExt));
770 currentFile = currentFileName;
771 moduleBeingParsed = mod;
774 static void clearCurrentFile ( void )
777 moduleBeingParsed = NIL;
780 static void ppMG ( void )
783 for (t = moduleGraph; nonNull(t); t=tl(t)) {
787 FPrintf ( stderr, " %s\n", textToStr(textOf(snd(u))));
790 FPrintf ( stderr, " {" );
791 for (v = snd(u); nonNull(v); v=tl(v))
792 FPrintf ( stderr, "%s ", textToStr(textOf(hd(v))) );
793 FPrintf ( stderr, "}\n" );
802 static Bool elemMG ( ConId mod )
805 for (gs = moduleGraph; nonNull(gs); gs=tl(gs))
806 switch (whatIs(hd(gs))) {
808 if (textOf(mod)==textOf(snd(hd(gs)))) return TRUE;
811 if (varIsMember(textOf(mod),snd(hd(gs)))) return TRUE;
820 static ConId selectArbitrarilyFromGroup ( Cell group )
822 switch (whatIs(group)) {
823 case GRP_NONREC: return snd(group);
824 case GRP_REC: return hd(snd(group));
825 default: internal("selectArbitrarilyFromGroup");
829 static ConId selectLatestMG ( void )
831 List gs = moduleGraph;
832 if (isNull(gs)) internal("selectLatestMG(1)");
833 while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs);
834 return selectArbitrarilyFromGroup(hd(gs));
838 static List /* of CONID */ listFromSpecifiedMG ( List mg )
842 for (gs = mg; nonNull(gs); gs=tl(gs)) {
843 switch (whatIs(hd(gs))) {
844 case GRP_REC: cs = appendOnto(cs,snd(hd(gs))); break;
845 case GRP_NONREC: cs = cons(snd(hd(gs)),cs); break;
846 default: internal("listFromSpecifiedMG");
852 static List /* of CONID */ listFromMG ( void )
854 return listFromSpecifiedMG ( moduleGraph );
858 /* Calculate the strongly connected components of modgList
859 and assign them to moduleGraph. Uses the .uses field of
860 each of the modules to build the graph structure.
862 #define SCC modScc /* make scc algorithm for StgVars */
863 #define LOWLINK modLowlink
864 #define DEPENDS(t) snd(t)
865 #define SETDEPENDS(c,v) snd(c)=v
872 static void mgFromList ( List /* of CONID */ modgList )
878 List adjList; /* :: [ (Text, [Text]) ] */
884 for (t = modgList; nonNull(t); t=tl(t)) {
886 mod = findModule(mT);
887 assert(nonNull(mod));
889 for (u = module(mod).uses; nonNull(u); u=tl(u))
890 usesT = cons(textOf(hd(u)),usesT);
892 /* artificially give all modules a dependency on Prelude */
893 if (mT != textPrelude && mT != textPrelPrim)
894 usesT = cons(textPrelude,usesT);
895 adjList = cons(pair(mT,usesT),adjList);
898 /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
899 Modify this so that the adjacency list is a list of pointers
900 back to bits of adjList -- that's what modScc needs.
902 for (t = adjList; nonNull(t); t=tl(t)) {
904 /* for each elem of the adjacency list ... */
905 for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
908 /* find the element of adjList whose fst is a */
909 for (v = adjList; nonNull(v); v=tl(v)) {
911 assert(isText(fst(hd(v))));
912 if (fst(hd(v))==a) break;
914 if (isNull(v)) internal("mgFromList");
915 adj = cons(hd(v),adj);
920 adjList = modScc ( adjList );
921 /* adjList is now [ [(module-text, aux-info-field)] ] */
925 for (t = adjList; nonNull(t); t=tl(t)) {
928 /* scc :: [ (module-text, aux-info-field) ] */
929 for (u = scc; nonNull(u); u=tl(u))
930 hd(u) = mkCon(fst(hd(u)));
933 if (length(scc) > 1) {
936 /* singleton module in scc; does it import itself? */
937 mod = findModule ( textOf(hd(scc)) );
938 assert(nonNull(mod));
940 for (u = module(mod).uses; nonNull(u); u=tl(u))
941 if (textOf(hd(u))==textOf(hd(scc)))
946 moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
947 moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
949 moduleGraph = reverse(moduleGraph);
953 static List /* of CONID */ getModuleImports ( Cell tree )
959 for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
963 use = zfst(unap(M_IMPORT_Q,te));
965 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
968 use = zfst(unap(M_IMPORT_UNQ,te));
970 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
980 static void processModule ( Module m )
997 foreignImports = NIL;
998 foreignExports = NIL;
1005 tree = unap(M_MODULE,module(m).tree);
1006 modNm = zfst3(tree);
1008 if (textOf(modNm) != module(m).text) {
1009 ERRMSG(0) "Module name \"%s\" does not match file name \"%s%s\"",
1010 textToStr(textOf(modNm)),
1011 textToStr(module(m).text),
1012 textToStr(module(m).srcExt)
1016 setExportList(zsnd3(tree));
1017 topEnts = zthd3(tree);
1019 for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
1021 assert(isGenPair(te));
1023 switch(whatIs(te)) {
1025 addQualImport(zfst(te2),zsnd(te2));
1028 addUnqualImport(zfst(te2),zsnd(te2));
1031 tyconDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
1034 classDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
1037 instDefn(intOf(zfst3(te2)),zsnd3(te2),zthd3(te2));
1040 defaultDefn(intOf(zfst(te2)),zsnd(te2));
1043 foreignImport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
1044 zsel45(te2),zsel55(te2));
1047 foreignExport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
1048 zsel45(te2),zsel55(te2));
1050 valDefns = cons(te2,valDefns);
1053 internal("processModule");
1062 static Module parseModuleOrInterface ( ConId mc, Cell modeRequest )
1064 /* Allocate a module-table entry. */
1065 /* Parse the entity and fill in the .tree and .uses entries. */
1068 Bool sAvail; Time sTime; Long sSize;
1069 Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1074 Text mt = textOf(mc);
1075 Module mod = findModule ( mt );
1077 /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
1078 textToStr(mt),mod); */
1079 if (nonNull(mod) && !module(mod).fake)
1080 internal("parseModuleOrInterface");
1082 module(mod).fake = FALSE;
1085 mod = newModule(mt);
1087 /* This call malloc-ates path; we should deallocate it. */
1088 ok = findFilesForModule (
1089 textToStr(module(mod).text),
1092 &sAvail, &sTime, &sSize,
1093 &oiAvail, &oiTime, &oSize, &iSize
1096 if (!ok) goto cant_find;
1097 if (!sAvail && !oiAvail) goto cant_find;
1099 /* Find out whether to use source or object. */
1100 switch (modeRequest) {
1102 if (!sAvail) goto cant_find;
1106 if (!oiAvail) goto cant_find;
1110 if ( sAvail && !oiAvail) { useSource = TRUE; break; }
1111 if (!sAvail && oiAvail) { useSource = FALSE; break; }
1112 useSource = firstTimeIsLater ( sTime, oiTime ) ? TRUE : FALSE;
1115 internal("parseModuleOrInterface");
1118 /* Actually do the parsing. */
1120 module(mod).srcExt = findText(sExt);
1121 setCurrentFile(mod);
1123 strcat(name, textToStr(mt));
1125 module(mod).tree = parseModule(name,sSize);
1126 module(mod).uses = getModuleImports(module(mod).tree);
1127 module(mod).mode = FM_SOURCE;
1128 module(mod).lastStamp = sTime;
1130 module(mod).srcExt = findText(HI_ENDING);
1131 setCurrentFile(mod);
1133 strcat(name, textToStr(mt));
1134 strcat(name, DLL_ENDING);
1135 module(mod).objName = findText(name);
1136 module(mod).objSize = oSize;
1138 strcat(name, textToStr(mt));
1139 strcat(name, ".u_hi");
1140 module(mod).tree = parseInterface(name,iSize);
1141 module(mod).uses = getInterfaceImports(module(mod).tree);
1142 module(mod).mode = FM_OBJECT;
1143 module(mod).lastStamp = oiTime;
1146 if (path) free(path);
1150 if (path) free(path);
1153 "Can't find %s for module \"%s\"",
1154 modeToString(modeRequest), textToStr(mt)
1159 static void tryLoadGroup ( Cell grp )
1163 switch (whatIs(grp)) {
1165 m = findModule(textOf(snd(grp)));
1167 if (module(m).mode == FM_SOURCE) {
1168 processModule ( m );
1169 module(m).tree = NIL;
1171 processInterfaces ( singleton(snd(grp)) );
1172 m = findModule(textOf(snd(grp)));
1174 module(m).tree = NIL;
1178 for (t = snd(grp); nonNull(t); t=tl(t)) {
1179 m = findModule(textOf(hd(t)));
1181 if (module(m).mode == FM_SOURCE) {
1182 ERRMSG(0) "Source module \"%s\" imports itself recursively",
1183 textToStr(textOf(hd(t)))
1187 processInterfaces ( snd(grp) );
1188 for (t = snd(grp); nonNull(t); t=tl(t)) {
1189 m = findModule(textOf(hd(t)));
1191 module(m).tree = NIL;
1195 internal("tryLoadGroup");
1200 static void fallBackToPrelModules ( void )
1203 for (m = MODULE_BASE_ADDR;
1204 m < MODULE_BASE_ADDR+tabModuleSz; m++)
1206 && !varIsMember(module(m).text, prelModules))
1211 /* This function catches exceptions in most of the system.
1212 So it's only ok for procedures called from this one
1213 to do EENDs (ie, write error messages). Others should use
1216 static void achieveTargetModules ( Bool loadingThePrelude )
1219 volatile List modgList;
1221 volatile Module mod;
1226 Bool sAvail; Time sTime; Long sSize;
1227 Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1229 volatile Time oisTime;
1230 volatile Bool out_of_date;
1231 volatile List ood_new;
1233 volatile List modgList_new;
1234 volatile List parsedButNotLoaded;
1235 volatile List toChase;
1236 volatile List trans_cl;
1237 volatile List trans_cl_new;
1242 volatile List badMods;
1244 setBreakAction ( HugsIgnoreBreak );
1246 /* First, examine timestamps to find out which modules are
1247 out of date with respect to the source/interface/object files.
1250 modgList = listFromMG();
1252 for (t = modgList; nonNull(t); t=tl(t)) {
1254 if (varIsMember(textOf(hd(t)),prelModules))
1257 mod = findModule(textOf(hd(t)));
1258 if (isNull(mod)) internal("achieveTargetSet(1)");
1260 /* In standalone mode, only succeeds for source modules. */
1261 ok = findFilesForModule (
1262 textToStr(module(mod).text),
1265 &sAvail, &sTime, &sSize,
1266 &oiAvail, &oiTime, &oSize, &iSize
1269 if (!combined && !sAvail) ok = FALSE;
1271 fallBackToPrelModules();
1273 "Can't find source or object+interface for module \"%s\"",
1274 textToStr(module(mod).text)
1276 if (path) free(path);
1280 if (sAvail && oiAvail) {
1281 oisTime = whicheverIsLater(sTime,oiTime);
1283 else if (sAvail && !oiAvail) {
1286 else if (!sAvail && oiAvail) {
1290 internal("achieveTargetSet(2)");
1293 out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
1295 assert(!varIsMember(textOf(hd(t)),ood));
1296 ood = cons(hd(t),ood);
1299 if (path) { free(path); path = NULL; };
1302 /* Second, form a simplistic transitive closure of the out-of-date
1303 modules: a module is out of date if it imports an out-of-date
1308 for (t = modgList; nonNull(t); t=tl(t)) {
1309 mod = findModule(textOf(hd(t)));
1310 assert(nonNull(mod));
1311 for (us = module(mod).uses; nonNull(us); us=tl(us))
1312 if (varIsMember(textOf(hd(us)),ood))
1315 if (varIsMember(textOf(hd(t)),prelModules))
1316 Printf ( "warning: prelude module \"%s\" is out-of-date\n",
1317 textToStr(textOf(hd(t))) );
1319 if (!varIsMember(textOf(hd(t)),ood_new) &&
1320 !varIsMember(textOf(hd(t)),ood))
1321 ood_new = cons(hd(t),ood_new);
1324 if (isNull(ood_new)) break;
1325 ood = appendOnto(ood_new,ood);
1328 /* Now ood holds the entire set of modules which are out-of-date.
1329 Throw them out of the system, yielding a "reduced system",
1330 in which the remaining modules are in-date.
1332 for (t = ood; nonNull(t); t=tl(t)) {
1333 mod = findModule(textOf(hd(t)));
1334 assert(nonNull(mod));
1338 for (t = modgList; nonNull(t); t=tl(t))
1339 if (!varIsMember(textOf(hd(t)),ood))
1340 modgList_new = cons(hd(t),modgList_new);
1341 modgList = modgList_new;
1343 /* Update the module group list to reflect the reduced system.
1344 We do this so that if the following parsing phases fail, we can
1345 safely fall back to the reduced system.
1347 mgFromList ( modgList );
1349 /* Parse modules/interfaces, collecting parse trees and chasing
1350 imports, starting from the target set.
1352 toChase = dupList(targetModules);
1353 for (t = toChase; nonNull(t); t=tl(t)) {
1354 Cell mode = (!combined)
1356 : ( (loadingThePrelude && combined)
1359 hd(t) = zpair(hd(t), mode);
1362 /* toChase :: [ ((ConId, {FM_SOURCE|FM_OBJECT|FM_EITHER} )) ] */
1364 parsedButNotLoaded = NIL;
1367 while (nonNull(toChase)) {
1368 ConId mc = zfst(hd(toChase));
1369 Cell mode = zsnd(hd(toChase));
1370 toChase = tl(toChase);
1371 if (varIsMember(textOf(mc),modgList)
1372 || varIsMember(textOf(mc),parsedButNotLoaded)) {
1373 /* either exists fully, or is at least parsed */
1374 mod = findModule(textOf(mc));
1375 assert(nonNull(mod));
1376 if (!compatibleNewMode(mode,module(mod).mode)) {
1379 "module %s: %s required, but %s is more recent",
1380 textToStr(textOf(mc)), modeToString(mode),
1381 modeToString(module(mod).mode)
1383 goto parseException;
1387 setBreakAction ( HugsLongjmpOnBreak );
1388 if (setjmp(catch_error)==0) {
1389 /* try this; it may throw an exception */
1390 mod = parseModuleOrInterface ( mc, mode );
1392 /* here's the exception handler, if parsing fails */
1393 /* A parse error (or similar). Clean up and abort. */
1395 setBreakAction ( HugsIgnoreBreak );
1396 mod = findModule(textOf(mc));
1397 if (nonNull(mod)) nukeModule(mod);
1398 for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
1399 mod = findModule(textOf(hd(t)));
1400 assert(nonNull(mod));
1401 if (nonNull(mod)) nukeModule(mod);
1404 /* end of the exception handler */
1406 setBreakAction ( HugsIgnoreBreak );
1408 parsedButNotLoaded = cons(mc, parsedButNotLoaded);
1409 for (t = module(mod).uses; nonNull(t); t=tl(t))
1411 zpair( hd(t), childMode(mode,module(mod).mode) ),
1416 modgList = dupOnto(parsedButNotLoaded, modgList);
1418 /* We successfully parsed all modules reachable from the target
1419 set which were not part of the reduced system. However, there
1420 may be modules in the reduced system which are not reachable from
1421 the target set. We detect these now by building the transitive
1422 closure of the target set, and nuking modules in the reduced
1423 system which are not part of that closure.
1425 trans_cl = dupList(targetModules);
1428 for (t = trans_cl; nonNull(t); t=tl(t)) {
1429 mod = findModule(textOf(hd(t)));
1430 assert(nonNull(mod));
1431 for (u = module(mod).uses; nonNull(u); u=tl(u))
1432 if (!varIsMember(textOf(hd(u)),trans_cl)
1433 && !varIsMember(textOf(hd(u)),trans_cl_new)
1434 && !varIsMember(textOf(hd(u)),prelModules))
1435 trans_cl_new = cons(hd(u),trans_cl_new);
1437 if (isNull(trans_cl_new)) break;
1438 trans_cl = appendOnto(trans_cl_new,trans_cl);
1441 for (t = modgList; nonNull(t); t=tl(t)) {
1442 if (varIsMember(textOf(hd(t)),trans_cl)) {
1443 modgList_new = cons(hd(t),modgList_new);
1445 mod = findModule(textOf(hd(t)));
1446 assert(nonNull(mod));
1450 modgList = modgList_new;
1452 /* Now, the module symbol tables hold exactly the set of
1453 modules reachable from the target set, and modgList holds
1454 their names. Calculate the scc-ified module graph,
1455 since we need that to guide the next stage, that of
1456 Actually Loading the modules.
1458 If no errors occur, moduleGraph will reflect the final graph
1459 loaded. If an error occurs loading a group, we nuke
1460 that group, truncate the moduleGraph just prior to that
1461 group, and exit. That leaves the system having successfully
1462 loaded all groups prior to the one which failed.
1464 mgFromList ( modgList );
1466 for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
1469 if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
1470 parsedButNotLoaded)) continue;
1472 setBreakAction ( HugsLongjmpOnBreak );
1473 if (setjmp(catch_error)==0) {
1474 /* try this; it may throw an exception */
1477 /* here's the exception handler, if static/typecheck etc fails */
1478 /* nuke the entire rest (ie, the unloaded part)
1479 of the module graph */
1480 setBreakAction ( HugsIgnoreBreak );
1481 badMods = listFromSpecifiedMG ( mg );
1482 for (t = badMods; nonNull(t); t=tl(t)) {
1483 mod = findModule(textOf(hd(t)));
1484 if (nonNull(mod)) nukeModule(mod);
1486 /* truncate the module graph just prior to this group. */
1490 if (isNull(mg)) break;
1491 if (hd(mg) == grp) break;
1492 mg2 = cons ( hd(mg), mg2 );
1495 moduleGraph = reverse(mg2);
1497 /* end of the exception handler */
1499 setBreakAction ( HugsIgnoreBreak );
1502 /* Err .. I think that's it. If we get here, we've successfully
1503 achieved the target set. Phew!
1505 setBreakAction ( HugsIgnoreBreak );
1509 static Bool loadThePrelude ( void )
1514 moduleGraph = prelModules = NIL;
1517 conPrelude = mkCon(findText("Prelude"));
1518 conPrelHugs = mkCon(findText("PrelHugs"));
1519 targetModules = doubleton(conPrelude,conPrelHugs);
1520 achieveTargetModules(TRUE);
1521 ok = elemMG(conPrelude) && elemMG(conPrelHugs);
1523 conPrelude = mkCon(findText("Prelude"));
1524 targetModules = singleton(conPrelude);
1525 achieveTargetModules(TRUE);
1526 ok = elemMG(conPrelude);
1529 if (ok) prelModules = listFromMG();
1534 /* Refresh the current target modules, and attempt to set the
1535 current module to what it was before (ie currentModule):
1536 if currentModule_failed is different from currentModule,
1538 if nextCurrMod is non null, try to set it to that instead
1539 if the one we're after insn't available, select a target
1540 from the end of the module group list.
1542 static void refreshActions ( ConId nextCurrMod, Bool cleanAfter )
1547 /* Remember what the old current module was. */
1548 tryFor = mkCon(module(currentModule).text);
1550 /* Do the Real Work. */
1551 achieveTargetModules(FALSE);
1553 /* Remember if the current module was invalidated by this
1554 refresh, so later refreshes can attempt to reload it. */
1555 if (!elemMG(tryFor))
1556 currentModule_failed = tryFor;
1558 /* If a previous refresh failed to get an old current module,
1559 try for that instead. */
1560 if (nonNull(currentModule_failed)
1561 && textOf(currentModule_failed) != textOf(tryFor)
1562 && elemMG(currentModule_failed))
1563 tryFor = currentModule_failed;
1564 /* If our caller specified a new current module, that overrides
1565 all historical settings. */
1566 if (nonNull(nextCurrMod))
1567 tryFor = nextCurrMod;
1568 /* Finally, if we can't actually get hold of whatever it was we
1569 were after, select something which is possible. */
1570 if (!elemMG(tryFor))
1571 tryFor = selectLatestMG();
1573 /* combined mode kludge, to get Prelude rather than PrelHugs */
1574 if (combined && textOf(tryFor)==findText("PrelHugs"))
1575 tryFor = mkCon(findText("Prelude"));
1578 /* delete any targetModules which didn't actually get loaded */
1580 targetModules = NIL;
1581 for (; nonNull(t); t=tl(t))
1583 targetModules = cons(hd(t),targetModules);
1586 setCurrModule ( findModule(textOf(tryFor)) );
1587 Printf("Hugs session for:\n");
1592 static void addActions ( List extraModules /* :: [CONID] */ )
1595 for (t = extraModules; nonNull(t); t=tl(t)) {
1596 ConId extra = hd(t);
1597 if (!varIsMember(textOf(extra),targetModules))
1598 targetModules = cons(extra,targetModules);
1600 refreshActions ( isNull(extraModules)
1602 : hd(reverse(extraModules)),
1608 static void loadActions ( List loadModules /* :: [CONID] */ )
1611 targetModules = dupList ( prelModules );
1613 for (t = loadModules; nonNull(t); t=tl(t)) {
1615 if (!varIsMember(textOf(load),targetModules))
1616 targetModules = cons(load,targetModules);
1618 refreshActions ( isNull(loadModules)
1620 : hd(reverse(loadModules)),
1626 /* --------------------------------------------------------------------------
1627 * Access to external editor:
1628 * ------------------------------------------------------------------------*/
1630 /* ToDo: All this editor stuff needs fixing. */
1632 static Void local editor() { /* interpreter-editor interface */
1634 String newFile = readFilename();
1636 setLastEdit(newFile,0);
1637 if (readFilename()) {
1638 ERRMSG(0) "Multiple filenames not permitted"
1646 static Void local find() { /* edit file containing definition */
1649 String nm = readFilename(); /* of specified name */
1651 ERRMSG(0) "No name specified"
1654 else if (readFilename()) {
1655 ERRMSG(0) "Multiple names not permitted"
1661 setCurrModule(findEvalModule());
1663 if (nonNull(c=findTycon(t=findText(nm)))) {
1664 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1665 readScripts(N_PRELUDE_SCRIPTS);
1667 } else if (nonNull(c=findName(t))) {
1668 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1669 readScripts(N_PRELUDE_SCRIPTS);
1672 ERRMSG(0) "No current definition for name \"%s\"", nm
1679 static Void local runEditor() { /* run editor on script lastEdit */
1681 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1682 readScripts(N_PRELUDE_SCRIPTS);
1686 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1692 lastEdit = strCopy(fname);
1697 /* --------------------------------------------------------------------------
1698 * Read and evaluate an expression:
1699 * ------------------------------------------------------------------------*/
1701 static Void setModule ( void ) {
1702 /*set module in which to evaluate expressions*/
1705 String s = readFilename();
1707 mc = selectLatestMG();
1708 if (combined && textOf(mc)==findText("PrelHugs"))
1709 mc = mkCon(findText("Prelude"));
1710 m = findModule(textOf(mc));
1713 m = findModule(findText(s));
1715 ERRMSG(0) "Cannot find module \"%s\"", s
1723 static Module allocEvalModule ( void )
1725 Module evalMod = newModule( findText("_Eval_Module_") );
1726 module(evalMod).names = module(currentModule).names;
1727 module(evalMod).tycons = module(currentModule).tycons;
1728 module(evalMod).classes = module(currentModule).classes;
1729 module(evalMod).qualImports
1730 = singleton(pair(mkCon(textPrelude),modulePrelude));
1734 static Void local evaluator() { /* evaluate expr and print value */
1737 volatile Kinds ks = NIL;
1738 volatile Module evalMod = allocEvalModule();
1739 volatile Module currMod = currentModule;
1740 setCurrModule(evalMod);
1743 defaultDefns = combined ? stdDefaults : evalDefaults;
1745 setBreakAction ( HugsLongjmpOnBreak );
1746 if (setjmp(catch_error)==0) {
1750 type = typeCheckExp(TRUE);
1752 /* if an exception happens, we arrive here */
1753 setBreakAction ( HugsIgnoreBreak );
1754 goto cleanup_and_return;
1757 setBreakAction ( HugsIgnoreBreak );
1758 if (isPolyType(type)) {
1759 ks = polySigOf(type);
1760 bd = monotypeOf(type);
1765 if (whatIs(bd)==QUAL) {
1768 ERRMSG(0) "Unresolved overloading" ETHEN
1769 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1770 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1773 goto cleanup_and_return;
1779 if (isProgType(ks,bd)) {
1780 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1784 Cell d = provePred(ks,NIL,ap(classShow,bd));
1788 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1789 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1790 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1793 goto cleanup_and_return;
1795 inputExpr = ap2(nameShow, d,inputExpr);
1796 inputExpr = ap (namePutStr, inputExpr);
1797 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1799 evalExp(); printf("\n");
1802 printType(stdout,type);
1809 printf ( "result type is " );
1810 printType ( stdout, type );
1818 setBreakAction ( HugsIgnoreBreak );
1819 nukeModule(evalMod);
1820 setCurrModule(currMod);
1821 setCurrentFile(currMod);
1827 /* --------------------------------------------------------------------------
1828 * Print type of input expression:
1829 * ------------------------------------------------------------------------*/
1831 static Void showtype ( void ) { /* print type of expression (if any)*/
1834 volatile Module evalMod = allocEvalModule();
1835 volatile Module currMod = currentModule;
1836 setCurrModule(evalMod);
1838 if (setjmp(catch_error)==0) {
1842 defaultDefns = evalDefaults;
1843 type = typeCheckExp(FALSE);
1844 printExp(stdout,inputExpr);
1846 printType(stdout,type);
1849 /* if an exception happens, we arrive here */
1852 nukeModule(evalMod);
1853 setCurrModule(currMod);
1857 static Void local browseit(mod,t,all)
1864 Printf("module %s where\n",textToStr(module(mod).text));
1865 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1867 /* only look at things defined in this module,
1868 unless `all' flag is set */
1869 if (all || name(nm).mod == mod) {
1870 /* unwanted artifacts, like lambda lifted values,
1871 are in the list of names, but have no types */
1872 if (nonNull(name(nm).type)) {
1873 printExp(stdout,nm);
1875 printType(stdout,name(nm).type);
1877 Printf(" -- data constructor");
1878 } else if (isMfun(nm)) {
1879 Printf(" -- class member");
1880 } else if (isSfun(nm)) {
1881 Printf(" -- selector function");
1889 Printf("Unknown module %s\n",t);
1894 static Void local browse() { /* browse modules */
1895 Int count = 0; /* or give menu of commands */
1899 for (; (s=readFilename())!=0; count++)
1900 if (strcmp(s,"all") == 0) {
1904 browseit(findModule(findText(s)),s,all);
1906 browseit(currentModule,NULL,all);
1910 #if EXPLAIN_INSTANCE_RESOLUTION
1911 static Void local xplain() { /* print type of expression (if any)*/
1913 Bool sir = showInstRes;
1915 setCurrModule(findEvalModule());
1916 startNewScript(0); /* Enables recovery of storage */
1917 /* allocated during evaluation */
1921 d = provePred(NIL,NIL,hd(inputContext));
1923 fprintf(stdout, "not Sat\n");
1925 fprintf(stdout, "Sat\n");
1931 /* --------------------------------------------------------------------------
1932 * Enhanced help system: print current list of scripts or give information
1934 * ------------------------------------------------------------------------*/
1936 static String local objToStr(m,c)
1939 #if 1 || DISPLAY_QUANTIFIERS
1940 static char newVar[60];
1941 switch (whatIs(c)) {
1942 case NAME : if (m == name(c).mod) {
1943 sprintf(newVar,"%s", textToStr(name(c).text));
1945 sprintf(newVar,"%s.%s",
1946 textToStr(module(name(c).mod).text),
1947 textToStr(name(c).text));
1951 case TYCON : if (m == tycon(c).mod) {
1952 sprintf(newVar,"%s", textToStr(tycon(c).text));
1954 sprintf(newVar,"%s.%s",
1955 textToStr(module(tycon(c).mod).text),
1956 textToStr(tycon(c).text));
1960 case CLASS : if (m == cclass(c).mod) {
1961 sprintf(newVar,"%s", textToStr(cclass(c).text));
1963 sprintf(newVar,"%s.%s",
1964 textToStr(module(cclass(c).mod).text),
1965 textToStr(cclass(c).text));
1969 default : internal("objToStr");
1973 static char newVar[33];
1974 switch (whatIs(c)) {
1975 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1978 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1981 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1984 default : internal("objToStr");
1992 static Void dumpStg ( void )
1998 setCurrModule(findEvalModule());
2003 /* request to locate a symbol by name */
2004 if (s && (*s == '?')) {
2005 Text t = findText(s+1);
2006 locateSymbolByName(t);
2010 /* request to dump a bit of the heap */
2011 if (s && (*s == '-' || isdigit(*s))) {
2018 /* request to dump a symbol table entry */
2020 || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
2021 || !isdigit(s[1])) {
2022 fprintf(stderr, ":d -- bad request `%s'\n", s );
2027 case 't': dumpTycon(i); break;
2028 case 'n': dumpName(i); break;
2029 case 'c': dumpClass(i); break;
2030 case 'i': dumpInst(i); break;
2031 default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
2037 static Void local dumpStg( void ) { /* print STG stuff */
2042 Cell v; /* really StgVar */
2043 setCurrModule(findEvalModule());
2045 for (; (s=readFilename())!=0;) {
2048 /* find the name while ignoring module scopes */
2049 for (i=NAMEMIN; i<nameHw; i++)
2050 if (name(i).text == t) n = i;
2052 /* perhaps it's an "idNNNNNN" thing? */
2055 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2058 while (isdigit(s[i])) {
2059 v = v * 10 + (s[i]-'0');
2063 n = nameFromStgVar(v);
2066 if (isNull(n) && whatIs(v)==STGVAR) {
2067 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2068 printStg(stderr, v );
2071 Printf ( "Unknown reference `%s'\n", s );
2074 Printf ( "Not a Name: `%s'\n", s );
2076 if (isNull(name(n).stgVar)) {
2077 Printf ( "Doesn't have a STG tree: %s\n", s );
2079 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2080 printStg(stderr, name(n).stgVar);
2086 static Void local info() { /* describe objects */
2087 Int count = 0; /* or give menu of commands */
2090 for (; (s=readFilename())!=0; count++) {
2091 describe(findText(s));
2094 /* whatScripts(); */
2099 static Void local describe(t) /* describe an object */
2101 Tycon tc = findTycon(t);
2102 Class cl = findClass(t);
2103 Name nm = findName(t);
2105 if (nonNull(tc)) { /* as a type constructor */
2109 for (i=0; i<tycon(tc).arity; ++i) {
2110 t = ap(t,mkOffset(i));
2112 Printf("-- type constructor");
2114 Printf(" with kind ");
2115 printKind(stdout,tycon(tc).kind);
2118 switch (tycon(tc).what) {
2119 case SYNONYM : Printf("type ");
2120 printType(stdout,t);
2122 printType(stdout,tycon(tc).defn);
2126 case DATATYPE : { List cs = tycon(tc).defn;
2127 if (tycon(tc).what==DATATYPE) {
2132 printType(stdout,t);
2134 mapProc(printSyntax,cs);
2136 Printf("\n-- constructors:");
2138 for (; hasCfun(cs); cs=tl(cs)) {
2140 printExp(stdout,hd(cs));
2142 printType(stdout,name(hd(cs)).type);
2145 Printf("\n-- selectors:");
2147 for (; nonNull(cs); cs=tl(cs)) {
2149 printExp(stdout,hd(cs));
2151 printType(stdout,name(hd(cs)).type);
2156 case RESTRICTSYN : Printf("type ");
2157 printType(stdout,t);
2158 Printf(" = <restricted>");
2162 if (nonNull(in=findFirstInst(tc))) {
2163 Printf("\n-- instances:\n");
2166 in = findNextInst(tc,in);
2167 } while (nonNull(in));
2172 if (nonNull(cl)) { /* as a class */
2173 List ins = cclass(cl).instances;
2174 Kinds ks = cclass(cl).kinds;
2175 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2176 Printf("-- type class");
2178 Printf("-- constructor class");
2180 Printf(" with arity ");
2181 printKinds(stdout,ks);
2185 mapProc(printSyntax,cclass(cl).members);
2187 if (nonNull(cclass(cl).supers)) {
2188 printContext(stdout,cclass(cl).supers);
2191 printPred(stdout,cclass(cl).head);
2193 if (nonNull(cclass(cl).fds)) {
2194 List fds = cclass(cl).fds;
2196 for (; nonNull(fds); fds=tl(fds)) {
2198 printFD(stdout,hd(fds));
2203 if (nonNull(cclass(cl).members)) {
2204 List ms = cclass(cl).members;
2207 Type t = name(hd(ms)).type;
2208 if (isPolyType(t)) {
2212 printExp(stdout,hd(ms));
2214 if (isNull(tl(fst(snd(t))))) {
2217 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2219 printType(stdout,t);
2221 } while (nonNull(ms));
2225 Printf("\n-- instances:\n");
2229 } while (nonNull(ins));
2234 if (nonNull(nm)) { /* as a function/name */
2236 printExp(stdout,nm);
2238 if (nonNull(name(nm).type)) {
2239 printType(stdout,name(nm).type);
2241 Printf("<unknown type>");
2244 Printf(" -- data constructor");
2245 } else if (isMfun(nm)) {
2246 Printf(" -- class member");
2247 } else if (isSfun(nm)) {
2248 Printf(" -- selector function");
2254 if (isNull(tc) && isNull(cl) && isNull(nm)) {
2255 Printf("Unknown reference `%s'\n",textToStr(t));
2259 static Void local printSyntax(nm)
2261 Syntax sy = syntaxOf(nm);
2262 Text t = name(nm).text;
2263 String s = textToStr(t);
2264 if (sy != defaultSyntax(t)) {
2266 switch (assocOf(sy)) {
2267 case LEFT_ASS : Putchar('l'); break;
2268 case RIGHT_ASS : Putchar('r'); break;
2269 case NON_ASS : break;
2271 Printf(" %i ",precOf(sy));
2272 if (isascii((int)(*s)) && isalpha((int)(*s))) {
2281 static Void local showInst(in) /* Display instance decl header */
2283 Printf("instance ");
2284 if (nonNull(inst(in).specifics)) {
2285 printContext(stdout,inst(in).specifics);
2288 printPred(stdout,inst(in).head);
2292 /* --------------------------------------------------------------------------
2293 * List all names currently in scope:
2294 * ------------------------------------------------------------------------*/
2296 static Void local listNames() { /* list names matching optional pat*/
2297 String pat = readFilename();
2299 Int width = getTerminalWidth() - 1;
2302 Module mod = currentModule;
2304 if (pat) { /* First gather names to list */
2306 names = addNamesMatching(pat,names);
2307 } while ((pat=readFilename())!=0);
2309 names = addNamesMatching((String)0,names);
2311 if (isNull(names)) { /* Then print them out */
2313 ERRMSG(0) "No names selected"
2317 for (termPos=0; nonNull(names); names=tl(names)) {
2318 String s = objToStr(mod,hd(names));
2320 if (termPos+1+l>width) {
2323 } else if (termPos>0) {
2331 Printf("\n(%d names listed)\n", count);
2334 /* --------------------------------------------------------------------------
2335 * print a prompt and read a line of input:
2336 * ------------------------------------------------------------------------*/
2338 static Void local promptForInput(moduleName)
2339 String moduleName; {
2340 char promptBuffer[1000];
2342 /* This is portable but could overflow buffer */
2343 sprintf(promptBuffer,prompt,moduleName);
2345 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2346 * promptBuffer instead.
2348 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2349 /* Reset prompt to a safe default to avoid an infinite loop */
2351 prompt = strCopy("? ");
2352 internal("Combined prompt and evaluation module name too long");
2356 stringInput("main\0"); else
2357 consoleInput(promptBuffer);
2360 /* --------------------------------------------------------------------------
2361 * main read-eval-print loop, with error trapping:
2362 * ------------------------------------------------------------------------*/
2364 static Void local interpreter(argc,argv)/* main interpreter loop */
2368 List modConIds; /* :: [CONID] */
2372 setBreakAction ( HugsIgnoreBreak );
2373 modConIds = initialize(argc,argv); /* the initial modules to load */
2374 setBreakAction ( HugsIgnoreBreak );
2375 prelOK = loadThePrelude();
2379 fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2381 fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2385 if (combined) everybody(POSTPREL);
2386 loadActions(modConIds);
2389 for (; nonNull(modConIds); modConIds=tl(modConIds))
2390 if (!elemMG(hd(modConIds))) {
2392 "hugs +Q: compilation failed -- can't run `main'\n" );
2399 /* initialize calls startupHaskell, which trashes our signal handlers */
2400 setBreakAction ( HugsIgnoreBreak );
2405 everybody(RESET); /* reset to sensible initial state */
2407 promptForInput(textToStr(module(currentModule).text));
2409 cmd = readCommand(cmds, (Char)':', (Char)'!');
2411 case EDIT : editor();
2415 case LOAD : modConIds = NIL;
2416 while ((s=readFilename())!=0) {
2417 modConIds = cons(mkCon(findText(s)),modConIds);
2420 loadActions(modConIds);
2423 case ALSO : modConIds = NIL;
2424 while ((s=readFilename())!=0)
2425 modConIds = cons(mkCon(findText(s)),modConIds);
2426 addActions(modConIds);
2429 case RELOAD : refreshActions(NIL,FALSE);
2434 case EVAL : evaluator();
2436 case TYPEOF : showtype();
2438 case BROWSE : browse();
2440 #if EXPLAIN_INSTANCE_RESOLUTION
2441 case XPLAIN : xplain();
2444 case NAMES : listNames();
2448 case BADCMD : guidance();
2453 #ifdef CRUDE_PROFILING
2457 case SYSTEM : if (shellEsc(readLine()))
2458 Printf("Warning: Shell escape terminated abnormally\n");
2460 case CHGDIR : changeDir();
2464 case PNTVER: Printf("-- Hugs Version %s\n",
2467 case DUMP : dumpStg();
2470 case COLLECT: consGC = FALSE;
2473 Printf("Garbage collection recovered %d cells\n",
2479 if (autoMain) break;
2483 /* --------------------------------------------------------------------------
2484 * Display progress towards goal:
2485 * ------------------------------------------------------------------------*/
2487 static Target currTarget;
2488 static Bool aiming = FALSE;
2491 static Int charCount;
2493 Void setGoal(what, t) /* Set goal for what to be t */
2498 #if EXPLAIN_INSTANCE_RESOLUTION
2502 currTarget = (t?t:1);
2505 currPos = strlen(what);
2506 maxPos = getTerminalWidth() - 1;
2510 for (charCount=0; *what; charCount++)
2515 Void soFar(t) /* Indicate progress towards goal */
2516 Target t; { /* has now reached t */
2519 #if EXPLAIN_INSTANCE_RESOLUTION
2524 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2529 if (newPos>currPos) {
2532 while (newPos>++currPos);
2539 Void done() { /* Goal has now been achieved */
2542 #if EXPLAIN_INSTANCE_RESOLUTION
2547 while (maxPos>currPos++)
2552 for (; charCount>0; charCount--) {
2561 static Void local failed() { /* Goal cannot be reached due to */
2562 if (aiming) { /* errors */
2569 /* --------------------------------------------------------------------------
2571 * ------------------------------------------------------------------------*/
2573 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
2574 if (printing) { /* after successful termination or */
2575 printing = FALSE; /* runtime error (e.g. interrupt) */
2578 #define plural(v) v, (v==1?"":"s")
2579 Printf("(%lu enter%s)\n",plural(numEnters));
2587 Cell errAssert(l) /* message to use when raising asserts, etc */
2591 str = mkStr(findText(currentFile));
2593 str = mkStr(findText(""));
2595 return (ap2(nameTangleMessage,str,mkInt(l)));
2598 Void errHead(l) /* print start of error message */
2600 failed(); /* failed to reach target ... */
2602 FPrintf(errorStream,"ERROR");
2605 FPrintf(errorStream," \"%s\"", currentFile);
2606 setLastEdit(currentFile,l);
2607 if (l) FPrintf(errorStream," (line %d)",l);
2610 FPrintf(errorStream,": ");
2611 FFlush(errorStream);
2614 Void errFail() { /* terminate error message and */
2615 Putc('\n',errorStream); /* produce exception to return to */
2616 FFlush(errorStream); /* main command loop */
2617 longjmp(catch_error,1);
2620 Void errFail_no_longjmp() { /* terminate error message but */
2621 Putc('\n',errorStream); /* don't produce an exception */
2622 FFlush(errorStream);
2625 Void errAbort() { /* altern. form of error handling */
2626 failed(); /* used when suitable error message*/
2627 stopAnyPrinting(); /* has already been printed */
2631 Void internal(msg) /* handle internal error */
2635 Printf("INTERNAL ERROR: %s\n",msg);
2638 longjmp(catch_error,1);
2641 Void fatal(msg) /* handle fatal error */
2644 Printf("\nFATAL ERROR: %s\n",msg);
2650 /* --------------------------------------------------------------------------
2651 * Read value from environment variable or registry:
2652 * ------------------------------------------------------------------------*/
2654 String fromEnv(var,def) /* return value of: */
2655 String var; /* environment variable named by var */
2656 String def; { /* or: default value given by def */
2657 String s = getenv(var);
2658 return (s ? s : def);
2661 /* --------------------------------------------------------------------------
2662 * String manipulation routines:
2663 * ------------------------------------------------------------------------*/
2665 static String local strCopy(s) /* make malloced copy of a string */
2669 if ((t=(char *)malloc(strlen(s)+1))==0) {
2670 ERRMSG(0) "String storage space exhausted"
2673 for (r=t; (*r++ = *s++)!=0; ) {
2681 /* --------------------------------------------------------------------------
2683 * We can redirect compiler output (prompts, error messages, etc) by
2684 * tweaking these functions.
2685 * ------------------------------------------------------------------------*/
2687 #ifdef HAVE_STDARG_H
2690 #include <varargs.h>
2693 Void hugsEnableOutput(f)
2698 #ifdef HAVE_STDARG_H
2699 Void hugsPrintf(const char *fmt, ...) {
2700 va_list ap; /* pointer into argument list */
2701 va_start(ap, fmt); /* make ap point to first arg after fmt */
2702 if (!disableOutput) {
2706 va_end(ap); /* clean up */
2709 Void hugsPrintf(fmt, va_alist)
2712 va_list ap; /* pointer into argument list */
2713 va_start(ap); /* make ap point to first arg after fmt */
2714 if (!disableOutput) {
2718 va_end(ap); /* clean up */
2724 if (!disableOutput) {
2730 Void hugsFlushStdout() {
2731 if (!disableOutput) {
2738 if (!disableOutput) {
2743 #ifdef HAVE_STDARG_H
2744 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2747 if (!disableOutput) {
2748 vfprintf(fp, fmt, ap);
2754 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2760 if (!disableOutput) {
2761 vfprintf(fp, fmt, ap);
2768 Void hugsPutc(c, fp)
2771 if (!disableOutput) {
2777 /* --------------------------------------------------------------------------
2778 * Send message to each component of system:
2779 * ------------------------------------------------------------------------*/
2781 Void everybody(what) /* send command `what' to each component of*/
2782 Int what; { /* system to respond as appropriate ... */
2784 fprintf ( stderr, "EVERYBODY %d\n", what );
2786 machdep(what); /* The order of calling each component is */
2787 storage(what); /* important for the PREPREL command */
2790 translateControl(what);
2792 staticAnalysis(what);
2793 deriveControl(what);
2801 mark(targetModules);
2803 mark(currentModule_failed);
2807 /*-------------------------------------------------------------------------*/