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/17 11:39:23 $
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-1999\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) {
1767 ERRMSG(0) "Unresolved overloading" ETHEN
1768 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1769 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1772 goto cleanup_and_return;
1776 if (isProgType(ks,bd)) {
1777 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1781 Cell d = provePred(ks,NIL,ap(classShow,bd));
1784 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1785 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1786 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1789 goto cleanup_and_return;
1791 inputExpr = ap2(nameShow, d,inputExpr);
1792 inputExpr = ap (namePutStr, inputExpr);
1793 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1795 evalExp(); printf("\n");
1798 printType(stdout,type);
1805 printf ( "result type is " );
1806 printType ( stdout, type );
1814 setBreakAction ( HugsIgnoreBreak );
1815 nukeModule(evalMod);
1816 setCurrModule(currMod);
1817 setCurrentFile(currMod);
1822 /* --------------------------------------------------------------------------
1823 * Print type of input expression:
1824 * ------------------------------------------------------------------------*/
1826 static Void showtype ( void ) { /* print type of expression (if any)*/
1829 volatile Module evalMod = allocEvalModule();
1830 volatile Module currMod = currentModule;
1831 setCurrModule(evalMod);
1833 if (setjmp(catch_error)==0) {
1837 defaultDefns = evalDefaults;
1838 type = typeCheckExp(FALSE);
1839 printExp(stdout,inputExpr);
1841 printType(stdout,type);
1844 /* if an exception happens, we arrive here */
1847 nukeModule(evalMod);
1848 setCurrModule(currMod);
1852 static Void local browseit(mod,t,all)
1859 Printf("module %s where\n",textToStr(module(mod).text));
1860 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1862 /* only look at things defined in this module,
1863 unless `all' flag is set */
1864 if (all || name(nm).mod == mod) {
1865 /* unwanted artifacts, like lambda lifted values,
1866 are in the list of names, but have no types */
1867 if (nonNull(name(nm).type)) {
1868 printExp(stdout,nm);
1870 printType(stdout,name(nm).type);
1872 Printf(" -- data constructor");
1873 } else if (isMfun(nm)) {
1874 Printf(" -- class member");
1875 } else if (isSfun(nm)) {
1876 Printf(" -- selector function");
1884 Printf("Unknown module %s\n",t);
1889 static Void local browse() { /* browse modules */
1890 Int count = 0; /* or give menu of commands */
1894 for (; (s=readFilename())!=0; count++)
1895 if (strcmp(s,"all") == 0) {
1899 browseit(findModule(findText(s)),s,all);
1901 browseit(currentModule,NULL,all);
1905 #if EXPLAIN_INSTANCE_RESOLUTION
1906 static Void local xplain() { /* print type of expression (if any)*/
1908 Bool sir = showInstRes;
1910 setCurrModule(findEvalModule());
1911 startNewScript(0); /* Enables recovery of storage */
1912 /* allocated during evaluation */
1916 d = provePred(NIL,NIL,hd(inputContext));
1918 fprintf(stdout, "not Sat\n");
1920 fprintf(stdout, "Sat\n");
1926 /* --------------------------------------------------------------------------
1927 * Enhanced help system: print current list of scripts or give information
1929 * ------------------------------------------------------------------------*/
1931 static String local objToStr(m,c)
1934 #if 1 || DISPLAY_QUANTIFIERS
1935 static char newVar[60];
1936 switch (whatIs(c)) {
1937 case NAME : if (m == name(c).mod) {
1938 sprintf(newVar,"%s", textToStr(name(c).text));
1940 sprintf(newVar,"%s.%s",
1941 textToStr(module(name(c).mod).text),
1942 textToStr(name(c).text));
1946 case TYCON : if (m == tycon(c).mod) {
1947 sprintf(newVar,"%s", textToStr(tycon(c).text));
1949 sprintf(newVar,"%s.%s",
1950 textToStr(module(tycon(c).mod).text),
1951 textToStr(tycon(c).text));
1955 case CLASS : if (m == cclass(c).mod) {
1956 sprintf(newVar,"%s", textToStr(cclass(c).text));
1958 sprintf(newVar,"%s.%s",
1959 textToStr(module(cclass(c).mod).text),
1960 textToStr(cclass(c).text));
1964 default : internal("objToStr");
1968 static char newVar[33];
1969 switch (whatIs(c)) {
1970 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1973 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1976 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1979 default : internal("objToStr");
1987 static Void dumpStg ( void )
1993 setCurrModule(findEvalModule());
1998 /* request to locate a symbol by name */
1999 if (s && (*s == '?')) {
2000 Text t = findText(s+1);
2001 locateSymbolByName(t);
2005 /* request to dump a bit of the heap */
2006 if (s && (*s == '-' || isdigit(*s))) {
2013 /* request to dump a symbol table entry */
2015 || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
2016 || !isdigit(s[1])) {
2017 fprintf(stderr, ":d -- bad request `%s'\n", s );
2022 case 't': dumpTycon(i); break;
2023 case 'n': dumpName(i); break;
2024 case 'c': dumpClass(i); break;
2025 case 'i': dumpInst(i); break;
2026 default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
2032 static Void local dumpStg( void ) { /* print STG stuff */
2037 Cell v; /* really StgVar */
2038 setCurrModule(findEvalModule());
2040 for (; (s=readFilename())!=0;) {
2043 /* find the name while ignoring module scopes */
2044 for (i=NAMEMIN; i<nameHw; i++)
2045 if (name(i).text == t) n = i;
2047 /* perhaps it's an "idNNNNNN" thing? */
2050 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2053 while (isdigit(s[i])) {
2054 v = v * 10 + (s[i]-'0');
2058 n = nameFromStgVar(v);
2061 if (isNull(n) && whatIs(v)==STGVAR) {
2062 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2063 printStg(stderr, v );
2066 Printf ( "Unknown reference `%s'\n", s );
2069 Printf ( "Not a Name: `%s'\n", s );
2071 if (isNull(name(n).stgVar)) {
2072 Printf ( "Doesn't have a STG tree: %s\n", s );
2074 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2075 printStg(stderr, name(n).stgVar);
2081 static Void local info() { /* describe objects */
2082 Int count = 0; /* or give menu of commands */
2085 for (; (s=readFilename())!=0; count++) {
2086 describe(findText(s));
2089 /* whatScripts(); */
2094 static Void local describe(t) /* describe an object */
2096 Tycon tc = findTycon(t);
2097 Class cl = findClass(t);
2098 Name nm = findName(t);
2100 if (nonNull(tc)) { /* as a type constructor */
2104 for (i=0; i<tycon(tc).arity; ++i) {
2105 t = ap(t,mkOffset(i));
2107 Printf("-- type constructor");
2109 Printf(" with kind ");
2110 printKind(stdout,tycon(tc).kind);
2113 switch (tycon(tc).what) {
2114 case SYNONYM : Printf("type ");
2115 printType(stdout,t);
2117 printType(stdout,tycon(tc).defn);
2121 case DATATYPE : { List cs = tycon(tc).defn;
2122 if (tycon(tc).what==DATATYPE) {
2127 printType(stdout,t);
2129 mapProc(printSyntax,cs);
2131 Printf("\n-- constructors:");
2133 for (; hasCfun(cs); cs=tl(cs)) {
2135 printExp(stdout,hd(cs));
2137 printType(stdout,name(hd(cs)).type);
2140 Printf("\n-- selectors:");
2142 for (; nonNull(cs); cs=tl(cs)) {
2144 printExp(stdout,hd(cs));
2146 printType(stdout,name(hd(cs)).type);
2151 case RESTRICTSYN : Printf("type ");
2152 printType(stdout,t);
2153 Printf(" = <restricted>");
2157 if (nonNull(in=findFirstInst(tc))) {
2158 Printf("\n-- instances:\n");
2161 in = findNextInst(tc,in);
2162 } while (nonNull(in));
2167 if (nonNull(cl)) { /* as a class */
2168 List ins = cclass(cl).instances;
2169 Kinds ks = cclass(cl).kinds;
2170 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2171 Printf("-- type class");
2173 Printf("-- constructor class");
2175 Printf(" with arity ");
2176 printKinds(stdout,ks);
2180 mapProc(printSyntax,cclass(cl).members);
2182 if (nonNull(cclass(cl).supers)) {
2183 printContext(stdout,cclass(cl).supers);
2186 printPred(stdout,cclass(cl).head);
2188 if (nonNull(cclass(cl).fds)) {
2189 List fds = cclass(cl).fds;
2191 for (; nonNull(fds); fds=tl(fds)) {
2193 printFD(stdout,hd(fds));
2198 if (nonNull(cclass(cl).members)) {
2199 List ms = cclass(cl).members;
2202 Type t = name(hd(ms)).type;
2203 if (isPolyType(t)) {
2207 printExp(stdout,hd(ms));
2209 if (isNull(tl(fst(snd(t))))) {
2212 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2214 printType(stdout,t);
2216 } while (nonNull(ms));
2220 Printf("\n-- instances:\n");
2224 } while (nonNull(ins));
2229 if (nonNull(nm)) { /* as a function/name */
2231 printExp(stdout,nm);
2233 if (nonNull(name(nm).type)) {
2234 printType(stdout,name(nm).type);
2236 Printf("<unknown type>");
2239 Printf(" -- data constructor");
2240 } else if (isMfun(nm)) {
2241 Printf(" -- class member");
2242 } else if (isSfun(nm)) {
2243 Printf(" -- selector function");
2249 if (isNull(tc) && isNull(cl) && isNull(nm)) {
2250 Printf("Unknown reference `%s'\n",textToStr(t));
2254 static Void local printSyntax(nm)
2256 Syntax sy = syntaxOf(nm);
2257 Text t = name(nm).text;
2258 String s = textToStr(t);
2259 if (sy != defaultSyntax(t)) {
2261 switch (assocOf(sy)) {
2262 case LEFT_ASS : Putchar('l'); break;
2263 case RIGHT_ASS : Putchar('r'); break;
2264 case NON_ASS : break;
2266 Printf(" %i ",precOf(sy));
2267 if (isascii((int)(*s)) && isalpha((int)(*s))) {
2276 static Void local showInst(in) /* Display instance decl header */
2278 Printf("instance ");
2279 if (nonNull(inst(in).specifics)) {
2280 printContext(stdout,inst(in).specifics);
2283 printPred(stdout,inst(in).head);
2287 /* --------------------------------------------------------------------------
2288 * List all names currently in scope:
2289 * ------------------------------------------------------------------------*/
2291 static Void local listNames() { /* list names matching optional pat*/
2292 String pat = readFilename();
2294 Int width = getTerminalWidth() - 1;
2297 Module mod = currentModule;
2299 if (pat) { /* First gather names to list */
2301 names = addNamesMatching(pat,names);
2302 } while ((pat=readFilename())!=0);
2304 names = addNamesMatching((String)0,names);
2306 if (isNull(names)) { /* Then print them out */
2308 ERRMSG(0) "No names selected"
2312 for (termPos=0; nonNull(names); names=tl(names)) {
2313 String s = objToStr(mod,hd(names));
2315 if (termPos+1+l>width) {
2318 } else if (termPos>0) {
2326 Printf("\n(%d names listed)\n", count);
2329 /* --------------------------------------------------------------------------
2330 * print a prompt and read a line of input:
2331 * ------------------------------------------------------------------------*/
2333 static Void local promptForInput(moduleName)
2334 String moduleName; {
2335 char promptBuffer[1000];
2337 /* This is portable but could overflow buffer */
2338 sprintf(promptBuffer,prompt,moduleName);
2340 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2341 * promptBuffer instead.
2343 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2344 /* Reset prompt to a safe default to avoid an infinite loop */
2346 prompt = strCopy("? ");
2347 internal("Combined prompt and evaluation module name too long");
2351 stringInput("main\0"); else
2352 consoleInput(promptBuffer);
2355 /* --------------------------------------------------------------------------
2356 * main read-eval-print loop, with error trapping:
2357 * ------------------------------------------------------------------------*/
2359 static Void local interpreter(argc,argv)/* main interpreter loop */
2363 List modConIds; /* :: [CONID] */
2367 setBreakAction ( HugsIgnoreBreak );
2368 modConIds = initialize(argc,argv); /* the initial modules to load */
2369 setBreakAction ( HugsIgnoreBreak );
2370 prelOK = loadThePrelude();
2374 fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2376 fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2380 if (combined) everybody(POSTPREL);
2381 loadActions(modConIds);
2384 for (; nonNull(modConIds); modConIds=tl(modConIds))
2385 if (!elemMG(hd(modConIds))) {
2387 "hugs +Q: compilation failed -- can't run `main'\n" );
2394 /* initialize calls startupHaskell, which trashes our signal handlers */
2395 setBreakAction ( HugsIgnoreBreak );
2400 everybody(RESET); /* reset to sensible initial state */
2402 promptForInput(textToStr(module(currentModule).text));
2404 cmd = readCommand(cmds, (Char)':', (Char)'!');
2406 case EDIT : editor();
2410 case LOAD : modConIds = NIL;
2411 while ((s=readFilename())!=0)
2412 modConIds = cons(mkCon(findText(s)),modConIds);
2413 loadActions(modConIds);
2416 case ALSO : modConIds = NIL;
2417 while ((s=readFilename())!=0)
2418 modConIds = cons(mkCon(findText(s)),modConIds);
2419 addActions(modConIds);
2422 case RELOAD : refreshActions(NIL,FALSE);
2427 case EVAL : evaluator();
2429 case TYPEOF : showtype();
2431 case BROWSE : browse();
2433 #if EXPLAIN_INSTANCE_RESOLUTION
2434 case XPLAIN : xplain();
2437 case NAMES : listNames();
2441 case BADCMD : guidance();
2446 #ifdef CRUDE_PROFILING
2450 case SYSTEM : if (shellEsc(readLine()))
2451 Printf("Warning: Shell escape terminated abnormally\n");
2453 case CHGDIR : changeDir();
2457 case PNTVER: Printf("-- Hugs Version %s\n",
2460 case DUMP : dumpStg();
2463 case COLLECT: consGC = FALSE;
2466 Printf("Garbage collection recovered %d cells\n",
2472 if (autoMain) break;
2476 /* --------------------------------------------------------------------------
2477 * Display progress towards goal:
2478 * ------------------------------------------------------------------------*/
2480 static Target currTarget;
2481 static Bool aiming = FALSE;
2484 static Int charCount;
2486 Void setGoal(what, t) /* Set goal for what to be t */
2491 #if EXPLAIN_INSTANCE_RESOLUTION
2495 currTarget = (t?t:1);
2498 currPos = strlen(what);
2499 maxPos = getTerminalWidth() - 1;
2503 for (charCount=0; *what; charCount++)
2508 Void soFar(t) /* Indicate progress towards goal */
2509 Target t; { /* has now reached t */
2512 #if EXPLAIN_INSTANCE_RESOLUTION
2517 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2522 if (newPos>currPos) {
2525 while (newPos>++currPos);
2532 Void done() { /* Goal has now been achieved */
2535 #if EXPLAIN_INSTANCE_RESOLUTION
2540 while (maxPos>currPos++)
2545 for (; charCount>0; charCount--) {
2554 static Void local failed() { /* Goal cannot be reached due to */
2555 if (aiming) { /* errors */
2562 /* --------------------------------------------------------------------------
2564 * ------------------------------------------------------------------------*/
2566 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
2567 if (printing) { /* after successful termination or */
2568 printing = FALSE; /* runtime error (e.g. interrupt) */
2571 #define plural(v) v, (v==1?"":"s")
2572 Printf("%lu cell%s",plural(numCells));
2574 Printf(", %u garbage collection%s",plural(numGcs));
2583 Cell errAssert(l) /* message to use when raising asserts, etc */
2587 str = mkStr(findText(currentFile));
2589 str = mkStr(findText(""));
2591 return (ap2(nameTangleMessage,str,mkInt(l)));
2594 Void errHead(l) /* print start of error message */
2596 failed(); /* failed to reach target ... */
2598 FPrintf(errorStream,"ERROR");
2601 FPrintf(errorStream," \"%s\"", currentFile);
2602 setLastEdit(currentFile,l);
2603 if (l) FPrintf(errorStream," (line %d)",l);
2606 FPrintf(errorStream,": ");
2607 FFlush(errorStream);
2610 Void errFail() { /* terminate error message and */
2611 Putc('\n',errorStream); /* produce exception to return to */
2612 FFlush(errorStream); /* main command loop */
2613 longjmp(catch_error,1);
2616 Void errFail_no_longjmp() { /* terminate error message but */
2617 Putc('\n',errorStream); /* don't produce an exception */
2618 FFlush(errorStream);
2621 Void errAbort() { /* altern. form of error handling */
2622 failed(); /* used when suitable error message*/
2623 stopAnyPrinting(); /* has already been printed */
2627 Void internal(msg) /* handle internal error */
2631 Printf("INTERNAL ERROR: %s\n",msg);
2634 longjmp(catch_error,1);
2637 Void fatal(msg) /* handle fatal error */
2640 Printf("\nFATAL ERROR: %s\n",msg);
2646 /* --------------------------------------------------------------------------
2647 * Read value from environment variable or registry:
2648 * ------------------------------------------------------------------------*/
2650 String fromEnv(var,def) /* return value of: */
2651 String var; /* environment variable named by var */
2652 String def; { /* or: default value given by def */
2653 String s = getenv(var);
2654 return (s ? s : def);
2657 /* --------------------------------------------------------------------------
2658 * String manipulation routines:
2659 * ------------------------------------------------------------------------*/
2661 static String local strCopy(s) /* make malloced copy of a string */
2665 if ((t=(char *)malloc(strlen(s)+1))==0) {
2666 ERRMSG(0) "String storage space exhausted"
2669 for (r=t; (*r++ = *s++)!=0; ) {
2677 /* --------------------------------------------------------------------------
2679 * We can redirect compiler output (prompts, error messages, etc) by
2680 * tweaking these functions.
2681 * ------------------------------------------------------------------------*/
2683 #ifdef HAVE_STDARG_H
2686 #include <varargs.h>
2689 Void hugsEnableOutput(f)
2694 #ifdef HAVE_STDARG_H
2695 Void hugsPrintf(const char *fmt, ...) {
2696 va_list ap; /* pointer into argument list */
2697 va_start(ap, fmt); /* make ap point to first arg after fmt */
2698 if (!disableOutput) {
2702 va_end(ap); /* clean up */
2705 Void hugsPrintf(fmt, va_alist)
2708 va_list ap; /* pointer into argument list */
2709 va_start(ap); /* make ap point to first arg after fmt */
2710 if (!disableOutput) {
2714 va_end(ap); /* clean up */
2720 if (!disableOutput) {
2726 Void hugsFlushStdout() {
2727 if (!disableOutput) {
2734 if (!disableOutput) {
2739 #ifdef HAVE_STDARG_H
2740 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2743 if (!disableOutput) {
2744 vfprintf(fp, fmt, ap);
2750 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2756 if (!disableOutput) {
2757 vfprintf(fp, fmt, ap);
2764 Void hugsPutc(c, fp)
2767 if (!disableOutput) {
2773 /* --------------------------------------------------------------------------
2774 * Send message to each component of system:
2775 * ------------------------------------------------------------------------*/
2777 Void everybody(what) /* send command `what' to each component of*/
2778 Int what; { /* system to respond as appropriate ... */
2780 fprintf ( stderr, "EVERYBODY %d\n", what );
2782 machdep(what); /* The order of calling each component is */
2783 storage(what); /* important for the PREPREL command */
2786 translateControl(what);
2788 staticAnalysis(what);
2789 deriveControl(what);
2797 mark(targetModules);
2799 mark(currentModule_failed);
2803 /*-------------------------------------------------------------------------*/