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/03/24 12:36:43 $
14 * ------------------------------------------------------------------------*/
20 #include "hugsbasictypes.h"
29 #include "Assembler.h" /* DEBUG_LoadSymbols */
31 Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
33 #if EXPLAIN_INSTANCE_RESOLUTION
34 Bool showInstRes = FALSE;
37 Bool multiInstRes = FALSE;
40 /* --------------------------------------------------------------------------
41 * Local function prototypes:
42 * ------------------------------------------------------------------------*/
44 static List local initialize ( Int,String [] );
45 static Void local promptForInput ( String );
46 static Void local interpreter ( Int,String [] );
47 static Void local menu ( Void );
48 static Void local guidance ( Void );
49 static Void local forHelp ( Void );
50 static Void local set ( Void );
51 static Void local changeDir ( Void );
52 static Void local load ( Void );
53 static Void local project ( Void );
54 static Void local editor ( Void );
55 static Void local find ( Void );
56 static Bool local startEdit ( Int,String );
57 static Void local runEditor ( Void );
58 static Void local setModule ( Void );
59 static Void local evaluator ( Void );
60 static Void local stopAnyPrinting ( Void );
61 static Void local showtype ( Void );
62 static String local objToStr ( Module, Cell );
63 static Void local info ( Void );
64 static Void local printSyntax ( Name );
65 static Void local showInst ( Inst );
66 static Void local describe ( Text );
67 static Void local listNames ( Void );
69 static Void local toggleSet ( Char,Bool );
70 static Void local togglesIn ( Bool );
71 static Void local optionInfo ( Void );
73 static String local optionsToStr ( Void );
75 static Void local readOptions ( String );
76 static Bool local processOption ( String );
77 static Void local setHeapSize ( String );
78 static Int local argToInt ( String );
80 static Void local setLastEdit ( String,Int );
81 static Void local failed ( Void );
82 static String local strCopy ( String );
83 static Void local browseit ( Module,String,Bool );
84 static Void local browse ( Void );
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 char* currentFile; /* Name of current file, or NULL */
111 static char currentFileName[1000]; /* name is stored here if it exists*/
115 static Text evalModule = 0; /* Name of module we eval exprs in */
116 static String currProject = 0; /* Name of current project file */
117 static Bool projectLoaded = FALSE; /* TRUE => project file loaded */
119 static Bool autoMain = FALSE;
120 static String lastEdit = 0; /* Name of script to edit (if any) */
121 static Int lastEdLine = 0; /* Editor line number (if possible)*/
122 static String prompt = 0; /* Prompt string */
123 static Int hpSize = DEFAULTHEAP; /* Desired heap size */
124 String hugsEdit = 0; /* String for editor command */
125 String hugsPath = 0; /* String for file search path */
127 List ifaces_outstanding = NIL;
130 /* --------------------------------------------------------------------------
132 * ------------------------------------------------------------------------*/
134 #ifndef NO_MAIN /* we omit main when building the "Hugs server" */
136 Main main ( Int, String [] ); /* now every func has a prototype */
141 #ifdef HAVE_CONSOLE_H /* Macintosh port */
143 _fcreator = 'R*ch'; /* // 'KAHL'; //'*TEX'; //'ttxt'; */
145 console_options.top = 50;
146 console_options.left = 20;
148 console_options.nrows = 32;
149 console_options.ncols = 80;
151 console_options.pause_atexit = 1;
152 console_options.title = "\pHugs";
154 console_options.procID = 5;
155 argc = ccommand(&argv);
158 CStackBase = &argc; /* Save stack base for use in gc */
162 checkBytecodeCount(); /* check for too many bytecodes */
166 /* If first arg is +Q or -Q, be entirely silent, and automatically run
167 main after loading scripts. Useful for running the nofib suite. */
168 if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
170 if (strcmp(argv[1],"-Q") == 0) {
175 Printf("__ __ __ __ ____ ___ _________________________________________\n");
176 Printf("|| || || || || || ||__ STGHugs: Based on the Haskell 98 standard\n");
177 Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n");
178 Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
179 Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
180 Printf("|| || Version: %s _________________________________________\n\n",HUGS_VERSION);
182 /* Get the absolute path to the directory containing the hugs
183 executable, so that we know where the Prelude and nHandle.so/.dll are.
184 We do this by reading env var STGHUGSDIR. This needs to succeed, so
185 setInstallDir won't return unless it succeeds.
187 setInstallDir ( argv[0] );
190 Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
193 interpreter(argc,argv);
194 Printf("[Leaving Hugs]\n");
205 /* --------------------------------------------------------------------------
206 * Initialization, interpret command line args and read prelude:
207 * ------------------------------------------------------------------------*/
209 static List /*CONID*/ initialize(argc,argv) /* Interpreter initialization */
214 char argv_0_orig[1000];
217 setLastEdit((String)0,0);
224 hugsEdit = strCopy(fromEnv("EDITOR",NULL));
226 hugsPath = strCopy(HUGSPATH);
227 readOptions("-p\"%s> \" -r$$");
229 projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
230 "HUGSPATH", PATHSEP, ""));
231 readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
232 readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
233 #endif /* USE_REGISTRY */
234 readOptions(fromEnv("STGHUGSFLAGS",""));
236 strncpy(argv_0_orig,argv[0],1000); /* startupHaskell mangles argv[0] */
237 startupHaskell (argc,argv);
243 char exe_name[N_INSTALLDIR + 6];
244 strcpy(exe_name, installDir);
245 strcat(exe_name, "hugs");
246 DEBUG_LoadSymbols(exe_name);
250 /* Find out early on if we're in combined mode or not.
251 everybody(PREPREL) needs to know this.
253 for (i=1; i < argc; ++i) {
254 if (strcmp(argv[i], "--")==0) break;
255 if (strcmp(argv[i], "-c")==0) combined = FALSE;
256 if (strcmp(argv[i], "+c")==0) combined = TRUE;
260 initialModules = NIL;
262 for (i=1; i < argc; ++i) { /* process command line arguments */
263 if (strcmp(argv[i], "--")==0) break;
264 if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
265 && !processOption(argv[i])) {
267 = cons ( mkCon(findText(argv[i])), initialModules );
272 Printf("Haskell 98 mode: Restart with command line option -98"
273 " to enable extensions\n");
275 Printf("Hugs mode: Restart with command line option +98 for"
276 " Haskell 98 mode\n");
280 Printf("Combined mode: Restart with command line -c for"
281 " standalone mode\n\n" );
283 Printf("Standalone mode: Restart with command line +c for"
284 " combined mode\n\n" );
287 return initialModules;
290 /* --------------------------------------------------------------------------
291 * Command line options:
292 * ------------------------------------------------------------------------*/
294 struct options { /* command line option toggles */
295 char c; /* table defined in main app. */
300 extern struct options toggle[];
302 static Void local toggleSet(c,state) /* Set command line toggle */
306 for (i=0; toggle[i].c; ++i)
307 if (toggle[i].c == c) {
308 *toggle[i].flag = state;
311 ERRMSG(0) "Unknown toggle `%c'", c
315 static Void local togglesIn(state) /* Print current list of toggles in*/
316 Bool state; { /* given state */
319 for (i=0; toggle[i].c; ++i)
320 if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
322 Putchar((char)(state ? '+' : '-'));
323 Putchar(toggle[i].c);
330 static Void local optionInfo() { /* Print information about command */
331 static String fmts = "%-5s%s\n"; /* line settings */
332 static String fmtc = "%-5c%s\n";
335 Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
336 for (i=0; toggle[i].c; ++i) {
337 if (!haskell98 || toggle[i].h98) {
338 Printf(fmtc,toggle[i].c,toggle[i].description);
342 Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
343 Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
344 Printf(fmts,"pstr","Set prompt string to str");
345 Printf(fmts,"rstr","Set repeat last expression string to str");
346 Printf(fmts,"Pstr","Set search path for modules to str");
347 Printf(fmts,"Estr","Use editor setting given by str");
348 Printf(fmts,"cnum","Set constraint cutoff limit");
349 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
350 Printf(fmts,"Fstr","Set preprocessor filter to str");
353 Printf("\nCurrent settings: ");
356 Printf("-h%d",heapSize);
360 printString(repeatStr);
361 Printf(" -c%d",cutoff);
362 Printf("\nSearch path : -P");
363 printString(hugsPath);
366 if (projectPath!=NULL) {
367 Printf("\nProject Path : %s",projectPath);
370 Printf("\nEditor setting : -E");
371 printString(hugsEdit);
372 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
373 Printf("\nPreprocessor : -F");
374 printString(preprocessor);
376 Printf("\nCompatibility : %s", haskell98 ? "Haskell 98 (+98)"
377 : "Hugs Extensions (-98)");
389 #define PUTInt(optc,i) \
390 sprintf(next,"-%c%d",optc,i); \
393 #define PUTStr(c,s) \
394 next=PUTStr_aux(next,c,s)
396 static String local PUTStr_aux ( String,Char, String));
398 static String local PUTStr_aux(next,c,s)
404 sprintf(next,"-%c\"",c);
407 PUTS(unlexChar(*t,'"'));
415 static String local optionsToStr() { /* convert options to string */
416 static char buffer[2000];
417 String next = buffer;
420 for (i=0; toggle[i].c; ++i) {
421 PUTC(*toggle[i].flag ? '+' : '-');
425 PUTS(haskell98 ? "+98 " : "-98 ");
426 PUTInt('h',hpSize); PUTC(' ');
428 PUTStr('r',repeatStr);
429 PUTStr('P',hugsPath);
430 PUTStr('E',hugsEdit);
431 PUTInt('c',cutoff); PUTC(' ');
432 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
433 PUTStr('F',preprocessor);
438 #endif /* USE_REGISTRY */
445 static Void local readOptions(options) /* read options from string */
449 stringInput(options);
450 while ((s=readFilename())!=0) {
451 if (*s && !processOption(s)) {
452 ERRMSG(0) "Option string must begin with `+' or `-'"
459 static Bool local processOption(s) /* process string s for options, */
460 String s; { /* return FALSE if none found. */
472 case 'Q' : break; /* already handled */
474 case 'p' : if (s[1]) {
475 if (prompt) free(prompt);
476 prompt = strCopy(s+1);
480 case 'r' : if (s[1]) {
481 if (repeatStr) free(repeatStr);
482 repeatStr = strCopy(s+1);
487 String p = substPath(s+1,hugsPath ? hugsPath : "");
488 if (hugsPath) free(hugsPath);
493 case 'E' : if (hugsEdit) free(hugsEdit);
494 hugsEdit = strCopy(s+1);
497 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
498 case 'F' : if (preprocessor) free(preprocessor);
499 preprocessor = strCopy(s+1);
503 case 'h' : setHeapSize(s+1);
506 case 'c' : /* don't do anything, since pre-scan of args
507 will have got it already */
510 case 'D' : /* hack */
512 extern void setRtsFlags( int x );
513 setRtsFlags(argToInt(s+1));
517 default : if (strcmp("98",s)==0) {
518 if (heapBuilt() && ((state && !haskell98) ||
519 (!state && haskell98))) {
521 "Haskell 98 compatibility cannot be changed"
522 " while the interpreter is running\n");
535 static Void local setHeapSize(s)
538 hpSize = argToInt(s);
539 if (hpSize < MINIMUMHEAP)
540 hpSize = MINIMUMHEAP;
541 else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
542 hpSize = MAXIMUMHEAP;
543 if (heapBuilt() && hpSize != heapSize) {
544 /* ToDo: should this use a message box in winhugs? */
546 FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
548 FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
556 static Int local argToInt(s) /* read integer from argument str */
561 if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
562 ERRMSG(0) "Missing integer in option setting \"%s\"", t
567 Int d = (*s++) - '0';
568 if (n > ((MAXPOSINT - d)/10)) {
569 ERRMSG(0) "Option setting \"%s\" is too large", t
573 } while (isascii((int)(*s)) && isdigit((int)(*s)));
575 if (*s=='K' || *s=='k') {
576 if (n > (MAXPOSINT/1000)) {
577 ERRMSG(0) "Option setting \"%s\" is too large", t
584 #if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
585 if (*s=='M' || *s=='m') {
586 if (n > (MAXPOSINT/1000000)) {
587 ERRMSG(0) "Option setting \"%s\" is too large", t
595 #if MAXPOSINT > 1000000000
596 if (*s=='G' || *s=='g') {
597 if (n > (MAXPOSINT/1000000000)) {
598 ERRMSG(0) "Option setting \"%s\" is too large", t
607 ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
614 /* --------------------------------------------------------------------------
615 * Print Menu of list of commands:
616 * ------------------------------------------------------------------------*/
618 static struct cmd cmds[] = {
619 {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
620 {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
621 {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
622 {":quit", QUIT}, {":set", SET}, {":find", FIND},
623 {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
624 {":dump", DUMP}, {":ztats", STATS},
625 {":module",SETMODULE},
627 #if EXPLAIN_INSTANCE_RESOLUTION
630 {":version", PNTVER},
635 static Void local menu() {
636 Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
637 Printf("c is the first character in the full name.\n\n");
638 Printf(":load <filenames> load modules from specified files\n");
639 Printf(":load clear all files except prelude\n");
640 Printf(":also <filenames> read additional modules\n");
641 Printf(":reload repeat last load command\n");
642 Printf(":project <filename> use project file\n");
643 Printf(":edit <filename> edit file\n");
644 Printf(":edit edit last module\n");
645 Printf(":module <module> set module for evaluating expressions\n");
646 Printf("<expr> evaluate expression\n");
647 Printf(":type <expr> print type of expression\n");
648 Printf(":? display this list of commands\n");
649 Printf(":set <options> set command line options\n");
650 Printf(":set help on command line options\n");
651 Printf(":names [pat] list names currently in scope\n");
652 Printf(":info <names> describe named objects\n");
653 Printf(":browse <modules> browse names defined in <modules>\n");
654 #if EXPLAIN_INSTANCE_RESOLUTION
655 Printf(":xplain <context> explain instance resolution for <context>\n");
657 Printf(":find <name> edit module containing definition of name\n");
658 Printf(":!command shell escape\n");
659 Printf(":cd dir change directory\n");
660 Printf(":gc force garbage collection\n");
661 Printf(":version print Hugs version\n");
662 Printf(":dump <name> print STG code for named fn\n");
663 #ifdef CRUDE_PROFILING
664 Printf(":ztats <name> print reduction stats\n");
666 Printf(":quit exit Hugs interpreter\n");
669 static Void local guidance() {
670 Printf("Command not recognised. ");
674 static Void local forHelp() {
675 Printf("Type :? for help\n");
678 /* --------------------------------------------------------------------------
679 * Setting of command line options:
680 * ------------------------------------------------------------------------*/
682 struct options toggle[] = { /* List of command line toggles */
683 {'s', 1, "Print no. reductions/cells after eval", &showStats},
684 {'t', 1, "Print type after evaluation", &addType},
685 {'g', 1, "Print no. cells recovered after gc", &gcMessages},
686 {'l', 1, "Literate modules as default", &literateScripts},
687 {'e', 1, "Warn about errors in literate modules", &literateErrors},
688 {'.', 1, "Print dots to show progress", &useDots},
689 {'q', 1, "Print nothing to show progress", &quiet},
690 {'w', 1, "Always show which modules are loaded", &listScripts},
691 {'k', 1, "Show kind errors in full", &kindExpert},
692 {'o', 0, "Allow overlapping instances", &allowOverlap},
693 {'S', 1, "Debug: show generated SC code", &debugSC},
694 {'a', 1, "Raise exception on assert failure", &flagAssert},
695 #if EXPLAIN_INSTANCE_RESOLUTION
696 {'x', 1, "Explain instance resolution", &showInstRes},
699 {'m', 0, "Use multi instance resolution", &multiInstRes},
704 static Void local set() { /* change command line options from*/
705 String s; /* Hugs command line */
707 if ((s=readFilename())!=0) {
709 if (!processOption(s)) {
710 ERRMSG(0) "Option string must begin with `+' or `-'"
713 } while ((s=readFilename())!=0);
715 writeRegString("Options", optionsToStr());
722 /* --------------------------------------------------------------------------
723 * Change directory command:
724 * ------------------------------------------------------------------------*/
726 static Void local changeDir() { /* change directory */
727 String s = readFilename();
729 ERRMSG(0) "Unable to change to directory \"%s\"", s
735 /* --------------------------------------------------------------------------
736 * The new module chaser, loader, etc
737 * ------------------------------------------------------------------------*/
739 List moduleGraph = NIL;
740 List prelModules = NIL;
741 List targetModules = NIL;
742 static jmp_buf catch_error; /* jump buffer for error trapping */
744 static void setCurrentFile ( Module mod )
746 assert(isModule(mod));
747 strncpy(currentFileName, textToStr(module(mod).text), 990);
748 strcat(currentFileName, textToStr(module(mod).srcExt));
749 currentFile = currentFileName;
752 static void ppMG ( void )
755 for (t = moduleGraph; nonNull(t); t=tl(t)) {
759 fprintf ( stderr, " %s\n", textToStr(textOf(snd(u))));
762 fprintf ( stderr, " {" );
763 for (v = snd(u); nonNull(v); v=tl(v))
764 fprintf ( stderr, "%s ", textToStr(textOf(hd(v))) );
765 fprintf ( stderr, "}\n" );
774 static Bool elemMG ( ConId mod )
777 for (gs = moduleGraph; nonNull(gs); gs=tl(gs))
778 switch (whatIs(hd(gs))) {
780 if (textOf(mod)==textOf(snd(hd(gs)))) return TRUE;
783 if (varIsMember(textOf(mod),snd(hd(gs)))) return TRUE;
792 static ConId selectArbitrarilyFromGroup ( Cell group )
794 switch (whatIs(group)) {
795 case GRP_NONREC: return snd(group);
796 case GRP_REC: return hd(snd(group));
797 default: internal("selectArbitrarilyFromGroup");
801 static ConId selectLatestMG ( void )
803 List gs = moduleGraph;
804 if (isNull(gs)) internal("selectLatestMG(1)");
805 while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs);
806 return selectArbitrarilyFromGroup(hd(gs));
810 static List /* of CONID */ listFromSpecifiedMG ( List mg )
814 for (gs = mg; nonNull(gs); gs=tl(gs)) {
815 switch (whatIs(hd(gs))) {
816 case GRP_REC: cs = appendOnto(cs,snd(hd(gs))); break;
817 case GRP_NONREC: cs = cons(snd(hd(gs)),cs); break;
818 default: internal("listFromSpecifiedMG");
824 static List /* of CONID */ listFromMG ( void )
826 return listFromSpecifiedMG ( moduleGraph );
830 /* Calculate the strongly connected components of modgList
831 and assign them to moduleGraph. Uses the .uses field of
832 each of the modules to build the graph structure.
834 #define SCC modScc /* make scc algorithm for StgVars */
835 #define LOWLINK modLowlink
836 #define DEPENDS(t) snd(t)
837 #define SETDEPENDS(c,v) snd(c)=v
844 static void mgFromList ( List /* of CONID */ modgList )
850 List adjList; /* :: [ (Text, [Text]) ] */
856 for (t = modgList; nonNull(t); t=tl(t)) {
858 mod = findModule(mT);
859 assert(nonNull(mod));
861 for (u = module(mod).uses; nonNull(u); u=tl(u))
862 usesT = cons(textOf(hd(u)),usesT);
863 /* artifically give all modules a dependency on Prelude */
864 if (mT != textPrelude)
865 usesT = cons(textPrelude,usesT);
866 adjList = cons(pair(mT,usesT),adjList);
869 /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
870 Modify this so that the adjacency list is a list of pointers
871 back to bits of adjList -- that's what modScc needs.
873 for (t = adjList; nonNull(t); t=tl(t)) {
875 /* for each elem of the adjacency list ... */
876 for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
879 /* find the element of adjList whose fst is a */
880 for (v = adjList; nonNull(v); v=tl(v)) {
882 assert(isText(fst(hd(v))));
883 if (fst(hd(v))==a) break;
885 if (isNull(v)) internal("mgFromList");
886 adj = cons(hd(v),adj);
891 adjList = modScc ( adjList );
892 /* adjList is now [ [(module-text, aux-info-field)] ] */
896 for (t = adjList; nonNull(t); t=tl(t)) {
899 /* scc :: [ (module-text, aux-info-field) ] */
900 for (u = scc; nonNull(u); u=tl(u))
901 hd(u) = mkCon(fst(hd(u)));
904 if (length(scc) > 1) {
907 /* singleton module in scc; does it import itself? */
908 mod = findModule ( textOf(hd(scc)) );
909 assert(nonNull(mod));
911 for (u = module(mod).uses; nonNull(u); u=tl(u))
912 if (textOf(hd(u))==textOf(hd(scc)))
917 moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
918 moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
920 moduleGraph = reverse(moduleGraph);
924 static List /* of CONID */ getModuleImports ( Cell tree )
930 for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
934 use = zfst(unap(M_IMPORT_Q,te));
936 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
939 use = zfst(unap(M_IMPORT_UNQ,te));
941 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
951 static void processModule ( Module m )
968 foreignImports = NIL;
969 foreignExports = NIL;
976 tree = unap(M_MODULE,module(m).tree);
978 assert(textOf(modNm)==module(m).text); /* wrong, but ... */
979 setExportList(zsnd3(tree));
980 topEnts = zthd3(tree);
982 for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
984 assert(isGenPair(te));
988 addQualImport(zfst(te2),zsnd(te2));
991 addUnqualImport(zfst(te2),zsnd(te2));
994 tyconDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
997 classDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
1000 instDefn(zfst3(te2),zsnd3(te2),zthd3(te2));
1003 defaultDefn(zfst(te2),zsnd(te2));
1006 foreignImport(zsel15(te2),zsel25(te2),zsel35(te2),
1007 zsel45(te2),zsel55(te2));
1010 foreignExport(zsel15(te2),zsel25(te2),zsel35(te2),
1011 zsel45(te2),zsel55(te2));
1013 valDefns = cons(te2,valDefns);
1016 internal("processModule");
1025 static Module parseModuleOrInterface ( ConId mc,
1026 List renewFromSource,
1027 List renewFromObject )
1029 /* Allocate a module-table entry. */
1030 /* Parse the entity and fill in the .tree and .uses entries. */
1033 Bool sAvail; Time sTime; Long sSize;
1034 Bool iAvail; Time iTime; Long iSize;
1035 Bool oAvail; Time oTime; Long oSize;
1040 Text mt = textOf(mc);
1041 Module mod = findModule ( mt );
1043 /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
1044 textToStr(mt),mod); */
1045 if (nonNull(mod) && !module(mod).fake)
1046 internal("parseModuleOrInterface");
1048 module(mod).fake = FALSE;
1051 mod = newModule(mt);
1053 /* This call malloc-ates path; we should deallocate it. */
1054 ok = findFilesForModule (
1055 textToStr(module(mod).text),
1058 &sAvail, &sTime, &sSize,
1059 &iAvail, &iTime, &iSize,
1060 &oAvail, &oTime, &oSize
1063 if (!ok) goto cant_find;
1064 if (!sAvail && !(iAvail && oAvail)) goto cant_find;
1066 /* Find out whether to use source or object. */
1067 if (varIsMember(mt,renewFromSource)) {
1068 if (!sAvail) goto cant_find;
1071 if (varIsMember(mt,renewFromObject)) {
1072 if (!(oAvail && iAvail)) goto cant_find;
1075 if (sAvail && !(iAvail && oAvail)) {
1078 if (!sAvail && (iAvail && oAvail)) {
1081 useSource = firstTimeIsLater(sTime,whicheverIsLater(oTime,iTime));
1084 if (!combined && !sAvail) goto cant_find;
1085 if (!combined) useSource = TRUE;
1087 module(mod).srcExt = findText(sExt);
1088 setCurrentFile(mod);
1090 /* Actually do the parsing. */
1093 strcat(name, textToStr(mt));
1095 module(mod).tree = parseModule(name,sSize);
1096 module(mod).uses = getModuleImports(module(mod).tree);
1097 module(mod).fromSrc = TRUE;
1098 module(mod).lastStamp = sTime;
1101 strcat(name, textToStr(mt));
1102 strcat(name, DLL_ENDING);
1103 module(mod).objName = findText(name);
1104 module(mod).objSize = oSize;
1106 strcat(name, textToStr(mt));
1107 strcat(name, ".u_hi");
1108 module(mod).tree = parseInterface(name,iSize);
1109 module(mod).uses = getInterfaceImports(module(mod).tree);
1110 module(mod).fromSrc = FALSE;
1111 module(mod).lastStamp = whicheverIsLater(oTime,iTime);
1114 if (path) free(path);
1118 if (path) free(path);
1120 "Can't find source or object+interface for module \"%s\"",
1126 static void tryLoadGroup ( Cell grp )
1130 switch (whatIs(grp)) {
1132 m = findModule(textOf(snd(grp)));
1134 if (module(m).fromSrc) {
1135 processModule ( m );
1137 processInterfaces ( singleton(snd(grp)) );
1141 for (t = snd(grp); nonNull(t); t=tl(t)) {
1142 m = findModule(textOf(hd(t)));
1144 if (module(m).fromSrc) {
1145 ERRMSG(0) "Source module \"%s\" imports itself recursively",
1146 textToStr(textOf(hd(t)))
1150 processInterfaces ( snd(grp) );
1153 internal("tryLoadGroup");
1158 static void fallBackToPrelModules ( void )
1161 for (m = MODULE_BASE_ADDR;
1162 m < MODULE_BASE_ADDR+tabModuleSz; m++)
1164 && !varIsMember(module(m).text, prelModules))
1169 /* This function catches exceptions in most of the system.
1170 So it's only ok for procedures called from this one
1171 to do EENDs (ie, write error messages). Others should use
1174 static void achieveTargetModules ( void )
1177 volatile List modgList;
1178 volatile List renewFromSource;
1179 volatile List renewFromObject;
1181 volatile Module mod;
1186 Bool sAvail; Time sTime; Long sSize;
1187 Bool iAvail; Time iTime; Long iSize;
1188 Bool oAvail; Time oTime; Long oSize;
1190 volatile Time oisTime;
1191 volatile Time oiTime;
1192 volatile Bool sourceIsLatest;
1193 volatile Bool out_of_date;
1194 volatile List ood_new;
1196 volatile List modgList_new;
1197 volatile List parsedButNotLoaded;
1198 volatile List toChase;
1199 volatile List trans_cl;
1200 volatile List trans_cl_new;
1205 volatile List badMods;
1207 /* First, examine timestamps to find out which modules are
1208 out of date with respect to the source/interface/object files.
1211 modgList = listFromMG();
1213 renewFromSource = renewFromObject = NIL;
1215 for (t = modgList; nonNull(t); t=tl(t)) {
1217 if (varIsMember(textOf(hd(t)),prelModules))
1220 mod = findModule(textOf(hd(t)));
1221 if (isNull(mod)) internal("achieveTargetSet(1)");
1223 ok = findFilesForModule (
1224 textToStr(module(mod).text),
1227 &sAvail, &sTime, &sSize,
1228 &iAvail, &iTime, &iSize,
1229 &oAvail, &oTime, &oSize
1231 if (!combined && !sAvail) ok = FALSE;
1233 fallBackToPrelModules();
1235 "Can't find source or object+interface for module \"%s\"",
1236 textToStr(module(mod).text)
1238 if (path) free(path);
1241 /* findFilesForModule should enforce this */
1242 if (!(sAvail || (oAvail && iAvail)))
1243 internal("achieveTargetSet(2)");
1247 sourceIsLatest = TRUE;
1249 if (sAvail && !(oAvail && iAvail)) {
1251 sourceIsLatest = TRUE;
1253 if (!sAvail && (oAvail && iAvail)) {
1254 oisTime = whicheverIsLater(oTime,iTime);
1255 sourceIsLatest = FALSE;
1257 if (sAvail && (oAvail && iAvail)) {
1258 oisTime = whicheverIsLater(oTime,iTime);
1259 if (firstTimeIsLater(sTime,oisTime)) {
1261 sourceIsLatest = TRUE;
1263 sourceIsLatest = FALSE;
1266 internal("achieveTargetSet(1a)");
1270 out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
1272 assert(!varIsMember(textOf(hd(t)),ood));
1273 ood = cons(hd(t),ood);
1275 renewFromSource = cons(hd(t),renewFromSource); else
1276 renewFromObject = cons(hd(t),renewFromObject);
1279 if (path) { free(path); path = NULL; };
1282 /* Second, form a simplistic transitive closure of the out-of-date
1283 modules: a module is out of date if it imports an out-of-date
1288 for (t = modgList; nonNull(t); t=tl(t)) {
1289 mod = findModule(textOf(hd(t)));
1290 assert(nonNull(mod));
1291 for (us = module(mod).uses; nonNull(us); us=tl(us))
1292 if (varIsMember(textOf(hd(us)),ood))
1295 if (varIsMember(textOf(hd(t)),prelModules))
1296 Printf ( "warning: prelude module \"%s\" is out-of-date\n",
1297 textToStr(textOf(hd(t))) );
1299 if (!varIsMember(textOf(hd(t)),ood_new) &&
1300 !varIsMember(textOf(hd(t)),ood))
1301 ood_new = cons(hd(t),ood_new);
1304 if (isNull(ood_new)) break;
1305 ood = appendOnto(ood_new,ood);
1308 /* Now ood holds the entire set of modules which are out-of-date.
1309 Throw them out of the system, yielding a "reduced system",
1310 in which the remaining modules are in-date.
1312 for (t = ood; nonNull(t); t=tl(t)) {
1313 mod = findModule(textOf(hd(t)));
1314 assert(nonNull(mod));
1318 for (t = modgList; nonNull(t); t=tl(t))
1319 if (!varIsMember(textOf(hd(t)),ood))
1320 modgList_new = cons(hd(t),modgList_new);
1321 modgList = modgList_new;
1323 /* Update the module group list to reflect the reduced system.
1324 We do this so that if the following parsing phases fail, we can
1325 safely fall back to the reduced system.
1327 mgFromList ( modgList );
1329 /* Parse modules/interfaces, collecting parse trees and chasing
1330 imports, starting from the target set.
1332 parsedButNotLoaded = NIL;
1333 toChase = dupList(targetModules);
1335 while (nonNull(toChase)) {
1336 ConId mc = hd(toChase);
1337 toChase = tl(toChase);
1338 if (!varIsMember(textOf(mc),modgList)
1339 && !varIsMember(textOf(mc),parsedButNotLoaded)) {
1341 if (setjmp(catch_error)==0) {
1342 /* try this; it may throw an exception */
1343 mod = parseModuleOrInterface (
1344 mc, renewFromSource, renewFromObject );
1346 /* here's the exception handler, if parsing fails */
1347 /* A parse error (or similar). Clean up and abort. */
1348 mod = findModule(textOf(mc));
1349 if (nonNull(mod)) nukeModule(mod);
1350 for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
1351 mod = findModule(textOf(hd(t)));
1352 assert(nonNull(mod));
1353 if (nonNull(mod)) nukeModule(mod);
1356 /* end of the exception handler */
1359 parsedButNotLoaded = cons(mc, parsedButNotLoaded);
1360 toChase = dupOnto(module(mod).uses,toChase);
1364 modgList = dupOnto(parsedButNotLoaded, modgList);
1366 /* We successfully parsed all modules reachable from the target
1367 set which were not part of the reduced system. However, there
1368 may be modules in the reduced system which are not reachable from
1369 the target set. We detect these now by building the transitive
1370 closure of the target set, and nuking modules in the reduced
1371 system which are not part of that closure.
1373 trans_cl = dupList(targetModules);
1376 for (t = trans_cl; nonNull(t); t=tl(t)) {
1377 mod = findModule(textOf(hd(t)));
1378 assert(nonNull(mod));
1379 for (u = module(mod).uses; nonNull(u); u=tl(u))
1380 if (!varIsMember(textOf(hd(u)),trans_cl)
1381 && !varIsMember(textOf(hd(u)),trans_cl_new)
1382 && !varIsMember(textOf(hd(u)),prelModules))
1383 trans_cl_new = cons(hd(u),trans_cl_new);
1385 if (isNull(trans_cl_new)) break;
1386 trans_cl = appendOnto(trans_cl_new,trans_cl);
1389 for (t = modgList; nonNull(t); t=tl(t)) {
1390 if (varIsMember(textOf(hd(t)),trans_cl)) {
1391 modgList_new = cons(hd(t),modgList_new);
1393 mod = findModule(textOf(hd(t)));
1394 assert(nonNull(mod));
1398 modgList = modgList_new;
1400 /* Now, the module symbol tables hold exactly the set of
1401 modules reachable from the target set, and modgList holds
1402 their names. Calculate the scc-ified module graph,
1403 since we need that to guide the next stage, that of
1404 Actually Loading the modules.
1406 If no errors occur, moduleGraph will reflect the final graph
1407 loaded. If an error occurs loading a group, we nuke
1408 that group, truncate the moduleGraph just prior to that
1409 group, and exit. That leaves the system having successfully
1410 loaded all groups prior to the one which failed.
1412 mgFromList ( modgList );
1414 for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
1417 if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
1418 parsedButNotLoaded)) continue;
1420 if (setjmp(catch_error)==0) {
1421 /* try this; it may throw an exception */
1424 /* here's the exception handler, if static/typecheck etc fails */
1425 /* nuke the entire rest (ie, the unloaded part)
1426 of the module graph */
1427 badMods = listFromSpecifiedMG ( mg );
1428 for (t = badMods; nonNull(t); t=tl(t)) {
1429 mod = findModule(textOf(hd(t)));
1430 if (nonNull(mod)) nukeModule(mod);
1432 /* truncate the module graph just prior to this group. */
1436 if (isNull(mg)) break;
1437 if (hd(mg) == grp) break;
1438 mg2 = cons ( hd(mg), mg2 );
1441 moduleGraph = reverse(mg2);
1443 /* end of the exception handler */
1448 /* Err .. I think that's it. If we get here, we've successfully
1449 achieved the target set. Phew!
1454 static Bool loadThePrelude ( void )
1459 moduleGraph = prelModules = NIL;
1462 conPrelude = mkCon(findText("Prelude"));
1463 conPrelHugs = mkCon(findText("PrelHugs"));
1464 targetModules = doubleton(conPrelude,conPrelHugs);
1465 achieveTargetModules();
1466 ok = elemMG(conPrelude) && elemMG(conPrelHugs);
1468 conPrelude = mkCon(findText("Prelude"));
1469 targetModules = singleton(conPrelude);
1470 achieveTargetModules();
1471 ok = elemMG(conPrelude);
1474 if (ok) prelModules = listFromMG();
1479 static void refreshActions ( ConId nextCurrMod )
1481 ConId tryFor = mkCon(module(currentModule).text);
1482 achieveTargetModules();
1483 if (nonNull(nextCurrMod))
1484 tryFor = nextCurrMod;
1485 if (!elemMG(tryFor))
1486 tryFor = selectLatestMG();
1487 /* combined mode kludge, to get Prelude rather than PrelHugs */
1488 if (combined && textOf(tryFor)==findText("PrelHugs"))
1489 tryFor = mkCon(findText("Prelude"));
1491 setCurrModule ( findModule(textOf(tryFor)) );
1492 Printf("Hugs session for:\n");
1497 static void addActions ( List extraModules /* :: [CONID] */ )
1500 for (t = extraModules; nonNull(t); t=tl(t)) {
1501 ConId extra = hd(t);
1502 if (!varIsMember(textOf(extra),targetModules))
1503 targetModules = cons(extra,targetModules);
1505 refreshActions ( isNull(extraModules)
1507 : hd(reverse(extraModules))
1512 static void loadActions ( List loadModules /* :: [CONID] */ )
1515 targetModules = dupList ( prelModules );
1517 for (t = loadModules; nonNull(t); t=tl(t)) {
1519 if (!varIsMember(textOf(load),targetModules))
1520 targetModules = cons(load,targetModules);
1522 refreshActions ( isNull(loadModules)
1524 : hd(reverse(loadModules))
1529 /* --------------------------------------------------------------------------
1530 * Access to external editor:
1531 * ------------------------------------------------------------------------*/
1533 /* ToDo: All this editor stuff needs fixing. */
1535 static Void local editor() { /* interpreter-editor interface */
1537 String newFile = readFilename();
1539 setLastEdit(newFile,0);
1540 if (readFilename()) {
1541 ERRMSG(0) "Multiple filenames not permitted"
1549 static Void local find() { /* edit file containing definition */
1552 String nm = readFilename(); /* of specified name */
1554 ERRMSG(0) "No name specified"
1557 else if (readFilename()) {
1558 ERRMSG(0) "Multiple names not permitted"
1564 setCurrModule(findEvalModule());
1566 if (nonNull(c=findTycon(t=findText(nm)))) {
1567 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1568 readScripts(N_PRELUDE_SCRIPTS);
1570 } else if (nonNull(c=findName(t))) {
1571 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1572 readScripts(N_PRELUDE_SCRIPTS);
1575 ERRMSG(0) "No current definition for name \"%s\"", nm
1582 static Void local runEditor() { /* run editor on script lastEdit */
1584 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1585 readScripts(N_PRELUDE_SCRIPTS);
1589 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1595 lastEdit = strCopy(fname);
1600 /* --------------------------------------------------------------------------
1601 * Read and evaluate an expression:
1602 * ------------------------------------------------------------------------*/
1604 static Void setModule ( void ) {
1605 /*set module in which to evaluate expressions*/
1608 String s = readFilename();
1610 mc = selectLatestMG();
1611 if (combined && textOf(mc)==findText("PrelHugs"))
1612 mc = mkCon(findText("Prelude"));
1613 m = findModule(textOf(mc));
1616 m = findModule(findText(s));
1618 ERRMSG(0) "Cannot find module \"%s\"", s
1626 static Module allocEvalModule ( void )
1628 Module evalMod = newModule( findText("_Eval_Module_") );
1629 module(evalMod).names = module(currentModule).names;
1630 module(evalMod).tycons = module(currentModule).tycons;
1631 module(evalMod).classes = module(currentModule).classes;
1635 static Void local evaluator() { /* evaluate expr and print value */
1638 volatile Kinds ks = NIL;
1639 volatile Module evalMod = allocEvalModule();
1640 volatile Module currMod = currentModule;
1641 setCurrModule(evalMod);
1644 defaultDefns = combined ? stdDefaults : evalDefaults;
1646 if (setjmp(catch_error)==0) {
1650 type = typeCheckExp(TRUE);
1652 /* if an exception happens, we arrive here */
1653 goto cleanup_and_return;
1656 if (isPolyType(type)) {
1657 ks = polySigOf(type);
1658 bd = monotypeOf(type);
1663 if (whatIs(bd)==QUAL) {
1664 ERRMSG(0) "Unresolved overloading" ETHEN
1665 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1666 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1669 goto cleanup_and_return;
1673 if (isProgType(ks,bd)) {
1674 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1678 Cell d = provePred(ks,NIL,ap(classShow,bd));
1680 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1681 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1682 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1685 goto cleanup_and_return;
1687 inputExpr = ap2(nameShow, d,inputExpr);
1688 inputExpr = ap (namePutStr, inputExpr);
1689 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1691 evalExp(); printf("\n");
1694 printType(stdout,type);
1701 printf ( "result type is " );
1702 printType ( stdout, type );
1710 nukeModule(evalMod);
1711 setCurrModule(currMod);
1712 setCurrentFile(currMod);
1717 /* --------------------------------------------------------------------------
1718 * Print type of input expression:
1719 * ------------------------------------------------------------------------*/
1721 static Void showtype ( void ) { /* print type of expression (if any)*/
1724 volatile Module evalMod = allocEvalModule();
1725 volatile Module currMod = currentModule;
1726 setCurrModule(evalMod);
1728 if (setjmp(catch_error)==0) {
1732 defaultDefns = evalDefaults;
1733 type = typeCheckExp(FALSE);
1734 printExp(stdout,inputExpr);
1736 printType(stdout,type);
1739 /* if an exception happens, we arrive here */
1742 nukeModule(evalMod);
1743 setCurrModule(currMod);
1747 static Void local browseit(mod,t,all)
1754 Printf("module %s where\n",textToStr(module(mod).text));
1755 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1757 /* only look at things defined in this module,
1758 unless `all' flag is set */
1759 if (all || name(nm).mod == mod) {
1760 /* unwanted artifacts, like lambda lifted values,
1761 are in the list of names, but have no types */
1762 if (nonNull(name(nm).type)) {
1763 printExp(stdout,nm);
1765 printType(stdout,name(nm).type);
1767 Printf(" -- data constructor");
1768 } else if (isMfun(nm)) {
1769 Printf(" -- class member");
1770 } else if (isSfun(nm)) {
1771 Printf(" -- selector function");
1779 Printf("Unknown module %s\n",t);
1784 static Void local browse() { /* browse modules */
1785 Int count = 0; /* or give menu of commands */
1789 for (; (s=readFilename())!=0; count++)
1790 if (strcmp(s,"all") == 0) {
1794 browseit(findModule(findText(s)),s,all);
1796 browseit(currentModule,NULL,all);
1800 #if EXPLAIN_INSTANCE_RESOLUTION
1801 static Void local xplain() { /* print type of expression (if any)*/
1803 Bool sir = showInstRes;
1805 setCurrModule(findEvalModule());
1806 startNewScript(0); /* Enables recovery of storage */
1807 /* allocated during evaluation */
1811 d = provePred(NIL,NIL,hd(inputContext));
1813 fprintf(stdout, "not Sat\n");
1815 fprintf(stdout, "Sat\n");
1821 /* --------------------------------------------------------------------------
1822 * Enhanced help system: print current list of scripts or give information
1824 * ------------------------------------------------------------------------*/
1826 static String local objToStr(m,c)
1829 #if 1 || DISPLAY_QUANTIFIERS
1830 static char newVar[60];
1831 switch (whatIs(c)) {
1832 case NAME : if (m == name(c).mod) {
1833 sprintf(newVar,"%s", textToStr(name(c).text));
1835 sprintf(newVar,"%s.%s",
1836 textToStr(module(name(c).mod).text),
1837 textToStr(name(c).text));
1841 case TYCON : if (m == tycon(c).mod) {
1842 sprintf(newVar,"%s", textToStr(tycon(c).text));
1844 sprintf(newVar,"%s.%s",
1845 textToStr(module(tycon(c).mod).text),
1846 textToStr(tycon(c).text));
1850 case CLASS : if (m == cclass(c).mod) {
1851 sprintf(newVar,"%s", textToStr(cclass(c).text));
1853 sprintf(newVar,"%s.%s",
1854 textToStr(module(cclass(c).mod).text),
1855 textToStr(cclass(c).text));
1859 default : internal("objToStr");
1863 static char newVar[33];
1864 switch (whatIs(c)) {
1865 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1868 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1871 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1874 default : internal("objToStr");
1882 static Void dumpStg ( void )
1888 setCurrModule(findEvalModule());
1893 /* request to locate a symbol by name */
1894 if (s && (*s == '?')) {
1895 Text t = findText(s+1);
1896 locateSymbolByName(t);
1900 /* request to dump a bit of the heap */
1901 if (s && (*s == '-' || isdigit(*s))) {
1908 /* request to dump a symbol table entry */
1910 || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
1911 || !isdigit(s[1])) {
1912 fprintf(stderr, ":d -- bad request `%s'\n", s );
1917 case 't': dumpTycon(i); break;
1918 case 'n': dumpName(i); break;
1919 case 'c': dumpClass(i); break;
1920 case 'i': dumpInst(i); break;
1921 default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
1927 static Void local dumpStg( void ) { /* print STG stuff */
1932 Cell v; /* really StgVar */
1933 setCurrModule(findEvalModule());
1935 for (; (s=readFilename())!=0;) {
1938 /* find the name while ignoring module scopes */
1939 for (i=NAMEMIN; i<nameHw; i++)
1940 if (name(i).text == t) n = i;
1942 /* perhaps it's an "idNNNNNN" thing? */
1945 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
1948 while (isdigit(s[i])) {
1949 v = v * 10 + (s[i]-'0');
1953 n = nameFromStgVar(v);
1956 if (isNull(n) && whatIs(v)==STGVAR) {
1957 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
1958 printStg(stderr, v );
1961 Printf ( "Unknown reference `%s'\n", s );
1964 Printf ( "Not a Name: `%s'\n", s );
1966 if (isNull(name(n).stgVar)) {
1967 Printf ( "Doesn't have a STG tree: %s\n", s );
1969 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
1970 printStg(stderr, name(n).stgVar);
1976 static Void local info() { /* describe objects */
1977 Int count = 0; /* or give menu of commands */
1980 for (; (s=readFilename())!=0; count++) {
1981 describe(findText(s));
1984 /* whatScripts(); */
1989 static Void local describe(t) /* describe an object */
1991 Tycon tc = findTycon(t);
1992 Class cl = findClass(t);
1993 Name nm = findName(t);
1995 if (nonNull(tc)) { /* as a type constructor */
1999 for (i=0; i<tycon(tc).arity; ++i) {
2000 t = ap(t,mkOffset(i));
2002 Printf("-- type constructor");
2004 Printf(" with kind ");
2005 printKind(stdout,tycon(tc).kind);
2008 switch (tycon(tc).what) {
2009 case SYNONYM : Printf("type ");
2010 printType(stdout,t);
2012 printType(stdout,tycon(tc).defn);
2016 case DATATYPE : { List cs = tycon(tc).defn;
2017 if (tycon(tc).what==DATATYPE) {
2022 printType(stdout,t);
2024 mapProc(printSyntax,cs);
2026 Printf("\n-- constructors:");
2028 for (; hasCfun(cs); cs=tl(cs)) {
2030 printExp(stdout,hd(cs));
2032 printType(stdout,name(hd(cs)).type);
2035 Printf("\n-- selectors:");
2037 for (; nonNull(cs); cs=tl(cs)) {
2039 printExp(stdout,hd(cs));
2041 printType(stdout,name(hd(cs)).type);
2046 case RESTRICTSYN : Printf("type ");
2047 printType(stdout,t);
2048 Printf(" = <restricted>");
2052 if (nonNull(in=findFirstInst(tc))) {
2053 Printf("\n-- instances:\n");
2056 in = findNextInst(tc,in);
2057 } while (nonNull(in));
2062 if (nonNull(cl)) { /* as a class */
2063 List ins = cclass(cl).instances;
2064 Kinds ks = cclass(cl).kinds;
2065 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2066 Printf("-- type class");
2068 Printf("-- constructor class");
2070 Printf(" with arity ");
2071 printKinds(stdout,ks);
2075 mapProc(printSyntax,cclass(cl).members);
2077 if (nonNull(cclass(cl).supers)) {
2078 printContext(stdout,cclass(cl).supers);
2081 printPred(stdout,cclass(cl).head);
2083 if (nonNull(cclass(cl).fds)) {
2084 List fds = cclass(cl).fds;
2086 for (; nonNull(fds); fds=tl(fds)) {
2088 printFD(stdout,hd(fds));
2093 if (nonNull(cclass(cl).members)) {
2094 List ms = cclass(cl).members;
2097 Type t = name(hd(ms)).type;
2098 if (isPolyType(t)) {
2102 printExp(stdout,hd(ms));
2104 if (isNull(tl(fst(snd(t))))) {
2107 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2109 printType(stdout,t);
2111 } while (nonNull(ms));
2115 Printf("\n-- instances:\n");
2119 } while (nonNull(ins));
2124 if (nonNull(nm)) { /* as a function/name */
2126 printExp(stdout,nm);
2128 if (nonNull(name(nm).type)) {
2129 printType(stdout,name(nm).type);
2131 Printf("<unknown type>");
2134 Printf(" -- data constructor");
2135 } else if (isMfun(nm)) {
2136 Printf(" -- class member");
2137 } else if (isSfun(nm)) {
2138 Printf(" -- selector function");
2144 if (isNull(tc) && isNull(cl) && isNull(nm)) {
2145 Printf("Unknown reference `%s'\n",textToStr(t));
2149 static Void local printSyntax(nm)
2151 Syntax sy = syntaxOf(nm);
2152 Text t = name(nm).text;
2153 String s = textToStr(t);
2154 if (sy != defaultSyntax(t)) {
2156 switch (assocOf(sy)) {
2157 case LEFT_ASS : Putchar('l'); break;
2158 case RIGHT_ASS : Putchar('r'); break;
2159 case NON_ASS : break;
2161 Printf(" %i ",precOf(sy));
2162 if (isascii((int)(*s)) && isalpha((int)(*s))) {
2171 static Void local showInst(in) /* Display instance decl header */
2173 Printf("instance ");
2174 if (nonNull(inst(in).specifics)) {
2175 printContext(stdout,inst(in).specifics);
2178 printPred(stdout,inst(in).head);
2182 /* --------------------------------------------------------------------------
2183 * List all names currently in scope:
2184 * ------------------------------------------------------------------------*/
2186 static Void local listNames() { /* list names matching optional pat*/
2187 String pat = readFilename();
2189 Int width = getTerminalWidth() - 1;
2192 Module mod = currentModule;
2194 if (pat) { /* First gather names to list */
2196 names = addNamesMatching(pat,names);
2197 } while ((pat=readFilename())!=0);
2199 names = addNamesMatching((String)0,names);
2201 if (isNull(names)) { /* Then print them out */
2202 ERRMSG(0) "No names selected"
2206 for (termPos=0; nonNull(names); names=tl(names)) {
2207 String s = objToStr(mod,hd(names));
2209 if (termPos+1+l>width) {
2212 } else if (termPos>0) {
2220 Printf("\n(%d names listed)\n", count);
2223 /* --------------------------------------------------------------------------
2224 * print a prompt and read a line of input:
2225 * ------------------------------------------------------------------------*/
2227 static Void local promptForInput(moduleName)
2228 String moduleName; {
2229 char promptBuffer[1000];
2231 /* This is portable but could overflow buffer */
2232 sprintf(promptBuffer,prompt,moduleName);
2234 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2235 * promptBuffer instead.
2237 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2238 /* Reset prompt to a safe default to avoid an infinite loop */
2240 prompt = strCopy("? ");
2241 internal("Combined prompt and evaluation module name too long");
2245 stringInput("main\0"); else
2246 consoleInput(promptBuffer);
2249 /* --------------------------------------------------------------------------
2250 * main read-eval-print loop, with error trapping:
2251 * ------------------------------------------------------------------------*/
2253 static Void local interpreter(argc,argv)/* main interpreter loop */
2257 List modConIds; /* :: [CONID] */
2261 breakOn(TRUE); /* enable break trapping */
2262 modConIds = initialize(argc,argv); /* the initial modules to load */
2263 prelOK = loadThePrelude();
2264 if (combined) everybody(POSTPREL);
2268 fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2270 fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2274 loadActions(modConIds);
2277 for (; nonNull(modConIds); modConIds=tl(modConIds))
2278 if (!elemMG(hd(modConIds))) {
2280 "hugs +Q: compilation failed -- can't run `main'\n" );
2287 /* initialize calls startupHaskell, which trashes our signal handlers */
2293 everybody(RESET); /* reset to sensible initial state */
2295 promptForInput(textToStr(module(currentModule).text));
2297 cmd = readCommand(cmds, (Char)':', (Char)'!');
2299 case EDIT : editor();
2303 case LOAD : modConIds = NIL;
2304 while ((s=readFilename())!=0)
2305 modConIds = cons(mkCon(findText(s)),modConIds);
2306 loadActions(modConIds);
2309 case ALSO : modConIds = NIL;
2310 while ((s=readFilename())!=0)
2311 modConIds = cons(mkCon(findText(s)),modConIds);
2312 addActions(modConIds);
2315 case RELOAD : refreshActions(NIL);
2320 case EVAL : evaluator();
2322 case TYPEOF : showtype();
2324 case BROWSE : browse();
2326 #if EXPLAIN_INSTANCE_RESOLUTION
2327 case XPLAIN : xplain();
2330 case NAMES : listNames();
2334 case BADCMD : guidance();
2339 #ifdef CRUDE_PROFILING
2343 case SYSTEM : if (shellEsc(readLine()))
2344 Printf("Warning: Shell escape terminated abnormally\n");
2346 case CHGDIR : changeDir();
2350 case PNTVER: Printf("-- Hugs Version %s\n",
2353 case DUMP : dumpStg();
2356 case COLLECT: consGC = FALSE;
2359 Printf("Garbage collection recovered %d cells\n",
2365 if (autoMain) break;
2370 /* --------------------------------------------------------------------------
2371 * Display progress towards goal:
2372 * ------------------------------------------------------------------------*/
2374 static Target currTarget;
2375 static Bool aiming = FALSE;
2378 static Int charCount;
2380 Void setGoal(what, t) /* Set goal for what to be t */
2385 #if EXPLAIN_INSTANCE_RESOLUTION
2389 currTarget = (t?t:1);
2392 currPos = strlen(what);
2393 maxPos = getTerminalWidth() - 1;
2397 for (charCount=0; *what; charCount++)
2402 Void soFar(t) /* Indicate progress towards goal */
2403 Target t; { /* has now reached t */
2406 #if EXPLAIN_INSTANCE_RESOLUTION
2411 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2416 if (newPos>currPos) {
2419 while (newPos>++currPos);
2426 Void done() { /* Goal has now been achieved */
2429 #if EXPLAIN_INSTANCE_RESOLUTION
2434 while (maxPos>currPos++)
2439 for (; charCount>0; charCount--) {
2448 static Void local failed() { /* Goal cannot be reached due to */
2449 if (aiming) { /* errors */
2456 /* --------------------------------------------------------------------------
2458 * ------------------------------------------------------------------------*/
2460 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
2461 if (printing) { /* after successful termination or */
2462 printing = FALSE; /* runtime error (e.g. interrupt) */
2465 #define plural(v) v, (v==1?"":"s")
2466 Printf("%lu cell%s",plural(numCells));
2468 Printf(", %u garbage collection%s",plural(numGcs));
2477 Cell errAssert(l) /* message to use when raising asserts, etc */
2482 str = mkStr(findText(currentFile));
2484 str = mkStr(findText(""));
2486 return (ap2(nameTangleMessage,str,mkInt(l)));
2489 Void errHead(l) /* print start of error message */
2491 failed(); /* failed to reach target ... */
2493 FPrintf(errorStream,"ERROR");
2496 FPrintf(errorStream," \"%s\"", currentFile);
2497 setLastEdit(currentFile,l);
2498 if (l) FPrintf(errorStream," (line %d)",l);
2501 FPrintf(errorStream,": ");
2502 FFlush(errorStream);
2505 Void errFail() { /* terminate error message and */
2506 Putc('\n',errorStream); /* produce exception to return to */
2507 FFlush(errorStream); /* main command loop */
2508 longjmp(catch_error,1);
2511 Void errFail_no_longjmp() { /* terminate error message but */
2512 Putc('\n',errorStream); /* don't produce an exception */
2513 FFlush(errorStream);
2516 Void errAbort() { /* altern. form of error handling */
2517 failed(); /* used when suitable error message*/
2518 stopAnyPrinting(); /* has already been printed */
2522 Void internal(msg) /* handle internal error */
2526 Printf("INTERNAL ERROR: %s\n",msg);
2529 longjmp(catch_error,1);
2532 Void fatal(msg) /* handle fatal error */
2535 Printf("\nFATAL ERROR: %s\n",msg);
2540 sigHandler(breakHandler) { /* respond to break interrupt */
2542 Printf("{Interrupted!}\n");
2544 breakOn(TRUE); /* reinstall signal handler - redundant on BSD systems */
2545 /* but essential on POSIX (and other?) systems */
2551 longjmp(catch_error,1);
2552 sigResume;/*NOTREACHED*/
2555 /* --------------------------------------------------------------------------
2556 * Read value from environment variable or registry:
2557 * ------------------------------------------------------------------------*/
2559 String fromEnv(var,def) /* return value of: */
2560 String var; /* environment variable named by var */
2561 String def; { /* or: default value given by def */
2562 String s = getenv(var);
2563 return (s ? s : def);
2566 /* --------------------------------------------------------------------------
2567 * String manipulation routines:
2568 * ------------------------------------------------------------------------*/
2570 static String local strCopy(s) /* make malloced copy of a string */
2574 if ((t=(char *)malloc(strlen(s)+1))==0) {
2575 ERRMSG(0) "String storage space exhausted"
2578 for (r=t; (*r++ = *s++)!=0; ) {
2585 /* --------------------------------------------------------------------------
2587 * We can redirect compiler output (prompts, error messages, etc) by
2588 * tweaking these functions.
2589 * ------------------------------------------------------------------------*/
2591 /* --------------------------------------------------------------------------
2592 * Send message to each component of system:
2593 * ------------------------------------------------------------------------*/
2595 Void everybody(what) /* send command `what' to each component of*/
2596 Int what; { /* system to respond as appropriate ... */
2598 fprintf ( stderr, "EVERYBODY %d\n", what );
2600 machdep(what); /* The order of calling each component is */
2601 storage(what); /* important for the PREPREL command */
2604 translateControl(what);
2606 staticAnalysis(what);
2607 deriveControl(what);
2613 /*-------------------------------------------------------------------------*/