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/22 18:14:22 $
14 * ------------------------------------------------------------------------*/
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 String scriptFile; /* Name of current script (if any) */
114 static Text evalModule = 0; /* Name of module we eval exprs in */
115 static String currProject = 0; /* Name of current project file */
116 static Bool projectLoaded = FALSE; /* TRUE => project file loaded */
118 static Bool autoMain = FALSE;
119 static String lastEdit = 0; /* Name of script to edit (if any) */
120 static Int lastEdLine = 0; /* Editor line number (if possible)*/
121 static String prompt = 0; /* Prompt string */
122 static Int hpSize = DEFAULTHEAP; /* Desired heap size */
123 String hugsEdit = 0; /* String for editor command */
124 String hugsPath = 0; /* String for file search path */
126 List ifaces_outstanding = NIL;
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(argc,argv) /* Interpreter initialization */
213 char argv_0_orig[1000];
216 setLastEdit((String)0,0);
223 hugsEdit = strCopy(fromEnv("EDITOR",NULL));
225 hugsPath = strCopy(HUGSPATH);
226 readOptions("-p\"%s> \" -r$$");
228 projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
229 "HUGSPATH", PATHSEP, ""));
230 readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
231 readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
232 #endif /* USE_REGISTRY */
233 readOptions(fromEnv("STGHUGSFLAGS",""));
235 strncpy(argv_0_orig,argv[0],1000); /* startupHaskell mangles argv[0] */
236 startupHaskell (argc,argv);
242 char exe_name[N_INSTALLDIR + 6];
243 strcpy(exe_name, installDir);
244 strcat(exe_name, "hugs");
245 DEBUG_LoadSymbols(exe_name);
249 /* Find out early on if we're in combined mode or not.
250 everybody(PREPREL) needs to know this.
252 for (i=1; i < argc; ++i) {
253 if (strcmp(argv[i], "--")==0) break;
254 if (strcmp(argv[i], "-c")==0) combined = FALSE;
255 if (strcmp(argv[i], "+c")==0) combined = TRUE;
259 initialModules = NIL;
261 for (i=1; i < argc; ++i) { /* process command line arguments */
262 if (strcmp(argv[i], "--")==0) break;
263 if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
264 && !processOption(argv[i])) {
266 = cons ( mkCon(findText(argv[i])), initialModules );
271 Printf("Haskell 98 mode: Restart with command line option -98"
272 " to enable extensions\n");
274 Printf("Hugs mode: Restart with command line option +98 for"
275 " Haskell 98 mode\n");
279 Printf("Combined mode: Restart with command line -c for"
280 " standalone mode\n\n" );
282 Printf("Standalone mode: Restart with command line +c for"
283 " combined mode\n\n" );
286 return initialModules;
289 /* --------------------------------------------------------------------------
290 * Command line options:
291 * ------------------------------------------------------------------------*/
293 struct options { /* command line option toggles */
294 char c; /* table defined in main app. */
299 extern struct options toggle[];
301 static Void local toggleSet(c,state) /* Set command line toggle */
305 for (i=0; toggle[i].c; ++i)
306 if (toggle[i].c == c) {
307 *toggle[i].flag = state;
310 ERRMSG(0) "Unknown toggle `%c'", c
314 static Void local togglesIn(state) /* Print current list of toggles in*/
315 Bool state; { /* given state */
318 for (i=0; toggle[i].c; ++i)
319 if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
321 Putchar((char)(state ? '+' : '-'));
322 Putchar(toggle[i].c);
329 static Void local optionInfo() { /* Print information about command */
330 static String fmts = "%-5s%s\n"; /* line settings */
331 static String fmtc = "%-5c%s\n";
334 Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
335 for (i=0; toggle[i].c; ++i) {
336 if (!haskell98 || toggle[i].h98) {
337 Printf(fmtc,toggle[i].c,toggle[i].description);
341 Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
342 Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
343 Printf(fmts,"pstr","Set prompt string to str");
344 Printf(fmts,"rstr","Set repeat last expression string to str");
345 Printf(fmts,"Pstr","Set search path for modules to str");
346 Printf(fmts,"Estr","Use editor setting given by str");
347 Printf(fmts,"cnum","Set constraint cutoff limit");
348 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
349 Printf(fmts,"Fstr","Set preprocessor filter to str");
352 Printf("\nCurrent settings: ");
355 Printf("-h%d",heapSize);
359 printString(repeatStr);
360 Printf(" -c%d",cutoff);
361 Printf("\nSearch path : -P");
362 printString(hugsPath);
365 if (projectPath!=NULL) {
366 Printf("\nProject Path : %s",projectPath);
369 Printf("\nEditor setting : -E");
370 printString(hugsEdit);
371 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
372 Printf("\nPreprocessor : -F");
373 printString(preprocessor);
375 Printf("\nCompatibility : %s", haskell98 ? "Haskell 98 (+98)"
376 : "Hugs Extensions (-98)");
388 #define PUTInt(optc,i) \
389 sprintf(next,"-%c%d",optc,i); \
392 #define PUTStr(c,s) \
393 next=PUTStr_aux(next,c,s)
395 static String local PUTStr_aux ( String,Char, String));
397 static String local PUTStr_aux(next,c,s)
403 sprintf(next,"-%c\"",c);
406 PUTS(unlexChar(*t,'"'));
414 static String local optionsToStr() { /* convert options to string */
415 static char buffer[2000];
416 String next = buffer;
419 for (i=0; toggle[i].c; ++i) {
420 PUTC(*toggle[i].flag ? '+' : '-');
424 PUTS(haskell98 ? "+98 " : "-98 ");
425 PUTInt('h',hpSize); PUTC(' ');
427 PUTStr('r',repeatStr);
428 PUTStr('P',hugsPath);
429 PUTStr('E',hugsEdit);
430 PUTInt('c',cutoff); PUTC(' ');
431 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
432 PUTStr('F',preprocessor);
437 #endif /* USE_REGISTRY */
444 static Void local readOptions(options) /* read options from string */
448 stringInput(options);
449 while ((s=readFilename())!=0) {
450 if (*s && !processOption(s)) {
451 ERRMSG(0) "Option string must begin with `+' or `-'"
458 static Bool local processOption(s) /* process string s for options, */
459 String s; { /* return FALSE if none found. */
471 case 'Q' : break; /* already handled */
473 case 'p' : if (s[1]) {
474 if (prompt) free(prompt);
475 prompt = strCopy(s+1);
479 case 'r' : if (s[1]) {
480 if (repeatStr) free(repeatStr);
481 repeatStr = strCopy(s+1);
486 String p = substPath(s+1,hugsPath ? hugsPath : "");
487 if (hugsPath) free(hugsPath);
492 case 'E' : if (hugsEdit) free(hugsEdit);
493 hugsEdit = strCopy(s+1);
496 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
497 case 'F' : if (preprocessor) free(preprocessor);
498 preprocessor = strCopy(s+1);
502 case 'h' : setHeapSize(s+1);
505 case 'c' : /* don't do anything, since pre-scan of args
506 will have got it already */
509 case 'D' : /* hack */
511 extern void setRtsFlags( int x );
512 setRtsFlags(argToInt(s+1));
516 default : if (strcmp("98",s)==0) {
517 if (heapBuilt() && ((state && !haskell98) ||
518 (!state && haskell98))) {
520 "Haskell 98 compatibility cannot be changed"
521 " while the interpreter is running\n");
534 static Void local setHeapSize(s)
537 hpSize = argToInt(s);
538 if (hpSize < MINIMUMHEAP)
539 hpSize = MINIMUMHEAP;
540 else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
541 hpSize = MAXIMUMHEAP;
542 if (heapBuilt() && hpSize != heapSize) {
543 /* ToDo: should this use a message box in winhugs? */
545 FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
547 FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
555 static Int local argToInt(s) /* read integer from argument str */
560 if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
561 ERRMSG(0) "Missing integer in option setting \"%s\"", t
566 Int d = (*s++) - '0';
567 if (n > ((MAXPOSINT - d)/10)) {
568 ERRMSG(0) "Option setting \"%s\" is too large", t
572 } while (isascii((int)(*s)) && isdigit((int)(*s)));
574 if (*s=='K' || *s=='k') {
575 if (n > (MAXPOSINT/1000)) {
576 ERRMSG(0) "Option setting \"%s\" is too large", t
583 #if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
584 if (*s=='M' || *s=='m') {
585 if (n > (MAXPOSINT/1000000)) {
586 ERRMSG(0) "Option setting \"%s\" is too large", t
594 #if MAXPOSINT > 1000000000
595 if (*s=='G' || *s=='g') {
596 if (n > (MAXPOSINT/1000000000)) {
597 ERRMSG(0) "Option setting \"%s\" is too large", t
606 ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
613 /* --------------------------------------------------------------------------
614 * Print Menu of list of commands:
615 * ------------------------------------------------------------------------*/
617 static struct cmd cmds[] = {
618 {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
619 {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
620 {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
621 {":quit", QUIT}, {":set", SET}, {":find", FIND},
622 {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
623 {":dump", DUMP}, {":ztats", STATS},
624 {":module",SETMODULE},
626 #if EXPLAIN_INSTANCE_RESOLUTION
629 {":version", PNTVER},
634 static Void local menu() {
635 Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
636 Printf("c is the first character in the full name.\n\n");
637 Printf(":load <filenames> load modules from specified files\n");
638 Printf(":load clear all files except prelude\n");
639 Printf(":also <filenames> read additional modules\n");
640 Printf(":reload repeat last load command\n");
641 Printf(":project <filename> use project file\n");
642 Printf(":edit <filename> edit file\n");
643 Printf(":edit edit last module\n");
644 Printf(":module <module> set module for evaluating expressions\n");
645 Printf("<expr> evaluate expression\n");
646 Printf(":type <expr> print type of expression\n");
647 Printf(":? display this list of commands\n");
648 Printf(":set <options> set command line options\n");
649 Printf(":set help on command line options\n");
650 Printf(":names [pat] list names currently in scope\n");
651 Printf(":info <names> describe named objects\n");
652 Printf(":browse <modules> browse names defined in <modules>\n");
653 #if EXPLAIN_INSTANCE_RESOLUTION
654 Printf(":xplain <context> explain instance resolution for <context>\n");
656 Printf(":find <name> edit module containing definition of name\n");
657 Printf(":!command shell escape\n");
658 Printf(":cd dir change directory\n");
659 Printf(":gc force garbage collection\n");
660 Printf(":version print Hugs version\n");
661 Printf(":dump <name> print STG code for named fn\n");
662 #ifdef CRUDE_PROFILING
663 Printf(":ztats <name> print reduction stats\n");
665 Printf(":quit exit Hugs interpreter\n");
668 static Void local guidance() {
669 Printf("Command not recognised. ");
673 static Void local forHelp() {
674 Printf("Type :? for help\n");
677 /* --------------------------------------------------------------------------
678 * Setting of command line options:
679 * ------------------------------------------------------------------------*/
681 struct options toggle[] = { /* List of command line toggles */
682 {'s', 1, "Print no. reductions/cells after eval", &showStats},
683 {'t', 1, "Print type after evaluation", &addType},
684 {'g', 1, "Print no. cells recovered after gc", &gcMessages},
685 {'l', 1, "Literate modules as default", &literateScripts},
686 {'e', 1, "Warn about errors in literate modules", &literateErrors},
687 {'.', 1, "Print dots to show progress", &useDots},
688 {'q', 1, "Print nothing to show progress", &quiet},
689 {'w', 1, "Always show which modules are loaded", &listScripts},
690 {'k', 1, "Show kind errors in full", &kindExpert},
691 {'o', 0, "Allow overlapping instances", &allowOverlap},
692 {'S', 1, "Debug: show generated SC code", &debugSC},
693 {'a', 1, "Raise exception on assert failure", &flagAssert},
694 #if EXPLAIN_INSTANCE_RESOLUTION
695 {'x', 1, "Explain instance resolution", &showInstRes},
698 {'m', 0, "Use multi instance resolution", &multiInstRes},
703 static Void local set() { /* change command line options from*/
704 String s; /* Hugs command line */
706 if ((s=readFilename())!=0) {
708 if (!processOption(s)) {
709 ERRMSG(0) "Option string must begin with `+' or `-'"
712 } while ((s=readFilename())!=0);
714 writeRegString("Options", optionsToStr());
721 /* --------------------------------------------------------------------------
722 * Change directory command:
723 * ------------------------------------------------------------------------*/
725 static Void local changeDir() { /* change directory */
726 String s = readFilename();
728 ERRMSG(0) "Unable to change to directory \"%s\"", s
734 /* --------------------------------------------------------------------------
735 * The new module chaser, loader, etc
736 * ------------------------------------------------------------------------*/
738 List moduleGraph = NIL;
739 List prelModules = NIL;
740 List targetModules = NIL;
741 static jmp_buf catch_error; /* jump buffer for error trapping */
745 static void ppMG ( void )
748 for (t = moduleGraph; nonNull(t); t=tl(t)) {
752 fprintf ( stderr, "%s\n", textToStr(textOf(snd(u))));
755 fprintf ( stderr, "{" );
756 for (v = snd(u); nonNull(v); v=tl(v))
757 fprintf ( stderr, "%s ", textToStr(textOf(hd(v))) );
758 fprintf ( stderr, "}\n" );
767 static Bool elemMG ( ConId mod )
770 for (gs = moduleGraph; nonNull(gs); gs=tl(gs))
771 switch (whatIs(hd(gs))) {
773 if (textOf(mod)==textOf(snd(hd(gs)))) return TRUE;
776 if (varIsMember(textOf(mod),snd(hd(gs)))) return TRUE;
785 static ConId selectArbitrarilyFromGroup ( Cell group )
787 switch (whatIs(group)) {
788 case GRP_NONREC: return snd(group);
789 case GRP_REC: return hd(snd(group));
790 default: internal("selectArbitrarilyFromGroup");
794 static ConId selectLatestMG ( void )
796 List gs = moduleGraph;
797 if (isNull(gs)) internal("selectLatestMG(1)");
798 while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs);
799 return selectArbitrarilyFromGroup(hd(gs));
803 static List /* of CONID */ listFromMG ( void )
807 for (gs = moduleGraph; nonNull(gs); gs=tl(gs)) {
808 switch (whatIs(hd(gs))) {
809 case GRP_REC: cs = appendOnto(cs,snd(hd(gs))); break;
810 case GRP_NONREC: cs = cons(snd(hd(gs)),cs); break;
811 default: internal("listFromMG");
818 /* Calculate the strongly connected components of modgList
819 and assign them to moduleGraph. Uses the .uses field of
820 each of the modules to build the graph structure.
822 #define SCC modScc /* make scc algorithm for StgVars */
823 #define LOWLINK modLowlink
824 #define DEPENDS(t) snd(t)
825 #define SETDEPENDS(c,v) snd(c)=v
832 static void mgFromList ( List /* of CONID */ modgList )
838 List adjList; /* :: [ (Text, [Text]) ] */
844 for (t = modgList; nonNull(t); t=tl(t)) {
846 mod = findModule(mT);
847 assert(nonNull(mod));
849 for (u = module(mod).uses; nonNull(u); u=tl(u))
850 usesT = cons(textOf(hd(u)),usesT);
851 adjList = cons(pair(mT,usesT),adjList);
854 /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
855 Modify this so that the adjacency list is a list of pointers
856 back to bits of adjList -- that's what modScc needs.
858 for (t = adjList; nonNull(t); t=tl(t)) {
860 /* for each elem of the adjacency list ... */
861 for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
864 /* find the element of adjList whose fst is a */
865 for (v = adjList; nonNull(v); v=tl(v)) {
867 assert(isText(fst(hd(v))));
868 if (fst(hd(v))==a) break;
870 if (isNull(v)) internal("mgFromList");
871 adj = cons(hd(v),adj);
876 adjList = modScc ( adjList );
877 adjList = rev(adjList);
878 /* adjList is now [ [(module-text, aux-info-field)] ] */
882 for (t = adjList; nonNull(t); t=tl(t)) {
885 /* scc :: [ (module-text, aux-info-field) ] */
886 for (u = scc; nonNull(u); u=tl(u))
887 hd(u) = mkCon(fst(hd(u)));
890 if (length(scc) > 1) {
893 /* singleton module in scc; does it import itself? */
894 mod = findModule ( textOf(hd(scc)) );
895 assert(nonNull(mod));
897 for (u = module(mod).uses; nonNull(u); u=tl(u))
898 if (textOf(hd(u))==textOf(hd(scc)))
903 moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
904 moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
909 static List /* of CONID */ getModuleImports ( Cell tree )
915 for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
919 use = zfst(unap(M_IMPORT_Q,te));
921 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
924 use = zfst(unap(M_IMPORT_UNQ,te));
926 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
936 static void processModule ( Module m )
953 foreignImports = NIL;
954 foreignExports = NIL;
960 tree = unap(M_MODULE,module(m).tree);
962 assert(textOf(modNm)==module(m).text); /* wrong, but ... */
963 setExportList(zsnd3(tree));
964 topEnts = zthd3(tree);
966 for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
968 assert(isGenPair(te));
972 addQualImport(zfst(te2),zsnd(te2));
975 addUnqualImport(zfst(te2),zsnd(te2));
978 tyconDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
981 classDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
984 instDefn(zfst3(te2),zsnd3(te2),zthd3(te2));
987 defaultDefn(zfst(te2),zsnd(te2));
990 foreignImport(zsel15(te2),zsel25(te2),zsel35(te2),
991 zsel45(te2),zsel55(te2));
994 foreignExport(zsel15(te2),zsel25(te2),zsel35(te2),
995 zsel45(te2),zsel55(te2));
997 valDefns = cons(te2,valDefns);
1000 internal("processModule");
1009 static Module parseModuleOrInterface ( ConId mc,
1010 List renewFromSource,
1011 List renewFromObject )
1013 /* Allocate a module-table entry. */
1014 /* Parse the entity and fill in the .tree and .uses entries. */
1017 Bool sAvail; Time sTime; Long sSize;
1018 Bool iAvail; Time iTime; Long iSize;
1019 Bool oAvail; Time oTime; Long oSize;
1024 Text mt = textOf(mc);
1025 Module mod = findModule ( mt );
1027 /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
1028 textToStr(mt),mod); */
1029 if (nonNull(mod) && !module(mod).fake)
1030 internal("parseModuleOrInterface");
1032 module(mod).fake = FALSE;
1035 mod = newModule(mt);
1037 /* This call malloc-ates path; we should deallocate it. */
1038 ok = findFilesForModule (
1039 textToStr(module(mod).text),
1042 &sAvail, &sTime, &sSize,
1043 &iAvail, &iTime, &iSize,
1044 &oAvail, &oTime, &oSize
1047 if (!ok) goto cant_find;
1048 if (!sAvail && !(iAvail && oAvail)) goto cant_find;
1050 /* Find out whether to use source or object. */
1051 if (varIsMember(mt,renewFromSource)) {
1052 if (!sAvail) goto cant_find;
1055 if (varIsMember(mt,renewFromObject)) {
1056 if (!(oAvail && iAvail)) goto cant_find;
1059 if (sAvail && !(iAvail && oAvail)) {
1062 if (!sAvail && (iAvail && oAvail)) {
1065 useSource = firstTimeIsLater(sTime,whicheverIsLater(oTime,iTime));
1068 if (!combined && !sAvail) goto cant_find;
1069 if (!combined) useSource = TRUE;
1071 /* Actually do the parsing. */
1074 strcat(name, textToStr(mt));
1076 module(mod).tree = parseModule(name,sSize);
1077 module(mod).uses = getModuleImports(module(mod).tree);
1078 module(mod).fromSrc = TRUE;
1079 module(mod).lastStamp = sTime;
1083 strcat(name, textToStr(mt));
1084 strcat(name, DLL_ENDING);
1085 module(mod).objName = findText(name);
1086 module(mod).objSize = oSize;
1088 strcat(name, textToStr(mt));
1089 strcat(name, ".u_hi");
1090 module(mod).tree = parseInterface(name,iSize);
1091 module(mod).uses = getInterfaceImports(module(mod).tree);
1092 module(mod).fromSrc = FALSE;
1093 module(mod).lastStamp = whicheverIsLater(oTime,iTime);
1096 if (path) free(path);
1100 if (path) free(path);
1102 "Can't find source or object+interface for module \"%s\"",
1108 static void tryLoadGroup ( Cell grp )
1112 switch (whatIs(grp)) {
1114 m = findModule(textOf(snd(grp)));
1116 if (module(m).fromSrc) {
1117 processModule ( m );
1119 processInterfaces ( singleton(snd(grp)) );
1123 for (t = snd(grp); nonNull(t); t=tl(t)) {
1124 m = findModule(textOf(hd(t)));
1126 if (module(m).fromSrc) {
1127 ERRMSG(0) "Source module \"%s\" imports itself recursively",
1128 textToStr(textOf(hd(t)))
1132 processInterfaces ( snd(grp) );
1135 internal("tryLoadGroup");
1140 static void fallBackToPrelModules ( void )
1143 for (m = MODULE_BASE_ADDR;
1144 m < MODULE_BASE_ADDR+tabModuleSz; m++)
1146 && !varIsMember(module(m).text, prelModules))
1151 /* This function catches exceptions in most of the system.
1152 So it's only ok for procedures called from this one
1153 to do EENDs (ie, write error messages). Others should use
1156 static void achieveTargetModules ( void )
1159 volatile List modgList;
1160 volatile List renewFromSource;
1161 volatile List renewFromObject;
1163 volatile Module mod;
1168 Bool sAvail; Time sTime; Long sSize;
1169 Bool iAvail; Time iTime; Long iSize;
1170 Bool oAvail; Time oTime; Long oSize;
1172 volatile Time oisTime;
1173 volatile Time oiTime;
1174 volatile Bool sourceIsLatest;
1175 volatile Bool out_of_date;
1176 volatile List ood_new;
1178 volatile List modgList_new;
1179 volatile List parsedButNotLoaded;
1180 volatile List toChase;
1181 volatile List trans_cl;
1182 volatile List trans_cl_new;
1187 volatile List badMods;
1189 /* First, examine timestamps to find out which modules are
1190 out of date with respect to the source/interface/object files.
1193 modgList = listFromMG();
1195 renewFromSource = renewFromObject = NIL;
1197 for (t = modgList; nonNull(t); t=tl(t)) {
1199 if (varIsMember(textOf(hd(t)),prelModules))
1202 mod = findModule(textOf(hd(t)));
1203 if (isNull(mod)) internal("achieveTargetSet(1)");
1205 ok = findFilesForModule (
1206 textToStr(module(mod).text),
1209 &sAvail, &sTime, &sSize,
1210 &iAvail, &iTime, &iSize,
1211 &oAvail, &oTime, &oSize
1213 if (!combined && !sAvail) ok = FALSE;
1215 fallBackToPrelModules();
1217 "Can't find source or object+interface for module \"%s\"",
1218 textToStr(module(mod).text)
1220 if (path) free(path);
1223 /* findFilesForModule should enforce this */
1224 if (!(sAvail || (oAvail && iAvail)))
1225 internal("achieveTargetSet(2)");
1229 sourceIsLatest = TRUE;
1231 if (sAvail && !(oAvail && iAvail)) {
1233 sourceIsLatest = TRUE;
1235 if (!sAvail && (oAvail && iAvail)) {
1236 oisTime = whicheverIsLater(oTime,iTime);
1237 sourceIsLatest = FALSE;
1239 if (sAvail && (oAvail && iAvail)) {
1240 oisTime = whicheverIsLater(oTime,iTime);
1241 if (firstTimeIsLater(sTime,oisTime)) {
1243 sourceIsLatest = TRUE;
1245 sourceIsLatest = FALSE;
1248 internal("achieveTargetSet(1a)");
1252 out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
1254 assert(!varIsMember(textOf(hd(t)),ood));
1255 ood = cons(hd(t),ood);
1257 renewFromSource = cons(hd(t),renewFromSource); else
1258 renewFromObject = cons(hd(t),renewFromObject);
1261 if (path) { free(path); path = NULL; };
1264 /* Second, form a simplistic transitive closure of the out-of-date
1265 modules: a module is out of date if it imports an out-of-date
1270 for (t = modgList; nonNull(t); t=tl(t)) {
1271 mod = findModule(textOf(hd(t)));
1272 assert(nonNull(mod));
1273 for (us = module(mod).uses; nonNull(us); us=tl(us))
1274 if (varIsMember(textOf(hd(us)),ood))
1277 fprintf ( stderr, "new OOD %s\n", textToStr(textOf(hd(t))) );
1278 if (varIsMember(textOf(hd(t)),prelModules))
1279 Printf ( "warning: prelude module \"%s\" is out-of-date\n",
1280 textToStr(textOf(hd(t))) );
1282 if (!varIsMember(textOf(hd(t)),ood_new) &&
1283 !varIsMember(textOf(hd(t)),ood))
1284 ood_new = cons(hd(t),ood_new);
1287 printf ( "\nood_new = " );print(ood_new,100);
1288 printf ( "\nood = " );print(ood,100); printf("\n");
1289 if (isNull(ood_new)) break;
1290 ood = appendOnto(ood_new,ood);
1293 /* Now ood holds the entire set of modules which are out-of-date.
1294 Throw them out of the system, yielding a "reduced system",
1295 in which the remaining modules are in-date.
1297 for (t = ood; nonNull(t); t=tl(t)) {
1298 mod = findModule(textOf(hd(t)));
1299 assert(nonNull(mod));
1303 for (t = modgList; nonNull(t); t=tl(t))
1304 if (!varIsMember(textOf(hd(t)),ood))
1305 modgList_new = cons(hd(t),modgList_new);
1306 modgList = modgList_new;
1308 /* Update the module group list to reflect the reduced system.
1309 We do this so that if the following parsing phases fail, we can
1310 safely fall back to the reduced system.
1312 mgFromList ( modgList );
1314 /* Parse modules/interfaces, collecting parse trees and chasing
1315 imports, starting from the target set.
1317 parsedButNotLoaded = NIL;
1318 toChase = dupList(targetModules);
1320 while (nonNull(toChase)) {
1321 ConId mc = hd(toChase);
1322 toChase = tl(toChase);
1323 if (!varIsMember(textOf(mc),modgList)
1324 && !varIsMember(textOf(mc),parsedButNotLoaded)) {
1326 if (setjmp(catch_error)==0) {
1327 /* try this; it may throw an exception */
1328 mod = parseModuleOrInterface (
1329 mc, renewFromSource, renewFromObject );
1331 /* here's the exception handler, if parsing fails */
1332 /* A parse error (or similar). Clean up and abort. */
1333 for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
1334 mod = findModule(textOf(hd(t)));
1335 assert(nonNull(mod));
1336 if (nonNull(mod)) nukeModule(mod);
1339 /* end of the exception handler */
1342 parsedButNotLoaded = cons(mc, parsedButNotLoaded);
1343 toChase = dupOnto(module(mod).uses,toChase);
1347 modgList = dupOnto(parsedButNotLoaded, modgList);
1349 /* We successfully parsed all modules reachable from the target
1350 set which were not part of the reduced system. However, there
1351 may be modules in the reduced system which are not reachable from
1352 the target set. We detect these now by building the transitive
1353 closure of the target set, and nuking modules in the reduced
1354 system which are not part of that closure.
1356 trans_cl = dupList(targetModules);
1359 for (t = trans_cl; nonNull(t); t=tl(t)) {
1360 mod = findModule(textOf(hd(t)));
1361 assert(nonNull(mod));
1362 for (u = module(mod).uses; nonNull(u); u=tl(u))
1363 if (!varIsMember(textOf(hd(u)),trans_cl)
1364 && !varIsMember(textOf(hd(u)),trans_cl_new)
1365 && !varIsMember(textOf(hd(u)),prelModules))
1366 trans_cl_new = cons(hd(u),trans_cl_new);
1368 if (isNull(trans_cl_new)) break;
1369 trans_cl = appendOnto(trans_cl_new,trans_cl);
1372 for (t = modgList; nonNull(t); t=tl(t)) {
1373 if (varIsMember(textOf(hd(t)),trans_cl)) {
1374 modgList_new = cons(hd(t),modgList_new);
1376 mod = findModule(textOf(hd(t)));
1377 assert(nonNull(mod));
1381 modgList = modgList_new;
1383 /* Now, the module symbol tables hold exactly the set of
1384 modules reachable from the target set, and modgList holds
1385 their names. Calculate the scc-ified module graph,
1386 since we need that to guide the next stage, that of
1387 Actually Loading the modules.
1389 If no errors occur, moduleGraph will reflect the final graph
1390 loaded. If an error occurs loading a group, we nuke
1391 that group, truncate the moduleGraph just prior to that
1392 group, and exit. That leaves the system having successfully
1393 loaded all groups prior to the one which failed.
1395 mgFromList ( modgList );
1397 for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
1400 if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
1401 parsedButNotLoaded)) continue;
1403 if (setjmp(catch_error)==0) {
1404 /* try this; it may throw an exception */
1407 /* here's the exception handler, if static/typecheck etc fails */
1408 badMods = whatIs(grp)==GRP_REC
1410 : singleton(snd(grp));
1411 for (t = badMods; nonNull(t); t=tl(t)) {
1412 mod = findModule(textOf(hd(t)));
1413 if (nonNull(mod)) nukeModule(mod);
1416 while (nonNull(mg2) && nonNull(tl(mg2)) && tl(mg2) != mg)
1418 assert(nonNull(mg2) && nonNull(tl(mg2)));
1421 /* end of the exception handler */
1426 /* Err .. I think that's it. If we get here, we've successfully
1427 achieved the target set. Phew!
1432 static Bool loadThePrelude ( void )
1437 moduleGraph = prelModules = NIL;
1440 conPrelude = mkCon(findText("Prelude"));
1441 conPrelHugs = mkCon(findText("PrelHugs"));
1442 targetModules = doubleton(conPrelude,conPrelHugs);
1443 achieveTargetModules();
1444 ok = elemMG(conPrelude) && elemMG(conPrelHugs);
1446 conPrelude = mkCon(findText("Prelude"));
1447 targetModules = singleton(conPrelude);
1448 achieveTargetModules();
1449 ok = elemMG(conPrelude);
1452 if (ok) prelModules = listFromMG();
1457 static void refreshActions ( ConId nextCurrMod )
1459 ConId tryFor = mkCon(module(currentModule).text);
1460 achieveTargetModules();
1461 if (nonNull(nextCurrMod))
1462 tryFor = nextCurrMod;
1463 if (!elemMG(tryFor))
1464 tryFor = selectLatestMG();
1465 /* combined mode kludge, to get Prelude rather than PrelHugs */
1466 if (combined && textOf(tryFor)==findText("PrelHugs"))
1467 tryFor = mkCon(findText("Prelude"));
1469 setCurrModule ( findModule(textOf(tryFor)) );
1470 Printf("Hugs session for:\n");
1475 static void addActions ( List extraModules /* :: [CONID] */ )
1478 for (t = extraModules; nonNull(t); t=tl(t)) {
1479 ConId extra = hd(t);
1480 if (!varIsMember(textOf(extra),targetModules))
1481 targetModules = cons(extra,targetModules);
1483 refreshActions ( isNull(extraModules)
1485 : hd(reverse(extraModules))
1490 static void loadActions ( List loadModules /* :: [CONID] */ )
1493 targetModules = dupList ( prelModules );
1495 for (t = loadModules; nonNull(t); t=tl(t)) {
1497 if (!varIsMember(textOf(load),targetModules))
1498 targetModules = cons(load,targetModules);
1500 refreshActions ( isNull(loadModules)
1502 : hd(reverse(loadModules))
1507 /* --------------------------------------------------------------------------
1508 * Access to external editor:
1509 * ------------------------------------------------------------------------*/
1511 /* ToDo: All this editor stuff needs fixing. */
1513 static Void local editor() { /* interpreter-editor interface */
1515 String newFile = readFilename();
1517 setLastEdit(newFile,0);
1518 if (readFilename()) {
1519 ERRMSG(0) "Multiple filenames not permitted"
1527 static Void local find() { /* edit file containing definition */
1530 String nm = readFilename(); /* of specified name */
1532 ERRMSG(0) "No name specified"
1535 else if (readFilename()) {
1536 ERRMSG(0) "Multiple names not permitted"
1542 setCurrModule(findEvalModule());
1544 if (nonNull(c=findTycon(t=findText(nm)))) {
1545 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1546 readScripts(N_PRELUDE_SCRIPTS);
1548 } else if (nonNull(c=findName(t))) {
1549 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1550 readScripts(N_PRELUDE_SCRIPTS);
1553 ERRMSG(0) "No current definition for name \"%s\"", nm
1560 static Void local runEditor() { /* run editor on script lastEdit */
1562 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1563 readScripts(N_PRELUDE_SCRIPTS);
1567 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1573 lastEdit = strCopy(fname);
1578 /* --------------------------------------------------------------------------
1579 * Read and evaluate an expression:
1580 * ------------------------------------------------------------------------*/
1582 static Void setModule ( void ) {
1583 /*set module in which to evaluate expressions*/
1586 String s = readFilename();
1588 mc = selectLatestMG();
1589 if (combined && textOf(mc)==findText("PrelHugs"))
1590 mc = mkCon(findText("Prelude"));
1591 m = findModule(textOf(mc));
1594 m = findModule(findText(s));
1596 ERRMSG(0) "Cannot find module \"%s\"", s
1604 static Module allocEvalModule ( void )
1606 Module evalMod = newModule( findText("_Eval_Module_") );
1607 module(evalMod).names = module(currentModule).names;
1608 module(evalMod).tycons = module(currentModule).tycons;
1609 module(evalMod).classes = module(currentModule).classes;
1613 static Void local evaluator() { /* evaluate expr and print value */
1616 volatile Kinds ks = NIL;
1617 volatile Module evalMod = allocEvalModule();
1618 volatile Module currMod = currentModule;
1619 setCurrModule(evalMod);
1622 defaultDefns = combined ? stdDefaults : evalDefaults;
1624 if (setjmp(catch_error)==0) {
1628 type = typeCheckExp(TRUE);
1630 /* if an exception happens, we arrive here */
1631 goto cleanup_and_return;
1634 if (isPolyType(type)) {
1635 ks = polySigOf(type);
1636 bd = monotypeOf(type);
1641 if (whatIs(bd)==QUAL) {
1642 ERRMSG(0) "Unresolved overloading" ETHEN
1643 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1644 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1647 goto cleanup_and_return;
1651 if (isProgType(ks,bd)) {
1652 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1656 Cell d = provePred(ks,NIL,ap(classShow,bd));
1658 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1659 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1660 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1663 goto cleanup_and_return;
1665 inputExpr = ap2(nameShow, d,inputExpr);
1666 inputExpr = ap (namePutStr, inputExpr);
1667 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1669 evalExp(); printf("\n");
1672 printType(stdout,type);
1679 printf ( "result type is " );
1680 printType ( stdout, type );
1688 nukeModule(evalMod);
1689 setCurrModule(currMod);
1694 /* --------------------------------------------------------------------------
1695 * Print type of input expression:
1696 * ------------------------------------------------------------------------*/
1698 static Void showtype ( void ) { /* print type of expression (if any)*/
1701 volatile Module evalMod = allocEvalModule();
1702 volatile Module currMod = currentModule;
1703 setCurrModule(evalMod);
1705 if (setjmp(catch_error)==0) {
1709 defaultDefns = evalDefaults;
1710 type = typeCheckExp(FALSE);
1711 printExp(stdout,inputExpr);
1713 printType(stdout,type);
1716 /* if an exception happens, we arrive here */
1719 nukeModule(evalMod);
1720 setCurrModule(currMod);
1724 static Void local browseit(mod,t,all)
1731 Printf("module %s where\n",textToStr(module(mod).text));
1732 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1734 /* only look at things defined in this module,
1735 unless `all' flag is set */
1736 if (all || name(nm).mod == mod) {
1737 /* unwanted artifacts, like lambda lifted values,
1738 are in the list of names, but have no types */
1739 if (nonNull(name(nm).type)) {
1740 printExp(stdout,nm);
1742 printType(stdout,name(nm).type);
1744 Printf(" -- data constructor");
1745 } else if (isMfun(nm)) {
1746 Printf(" -- class member");
1747 } else if (isSfun(nm)) {
1748 Printf(" -- selector function");
1756 Printf("Unknown module %s\n",t);
1761 static Void local browse() { /* browse modules */
1762 Int count = 0; /* or give menu of commands */
1766 for (; (s=readFilename())!=0; count++)
1767 if (strcmp(s,"all") == 0) {
1771 browseit(findModule(findText(s)),s,all);
1773 browseit(currentModule,NULL,all);
1777 #if EXPLAIN_INSTANCE_RESOLUTION
1778 static Void local xplain() { /* print type of expression (if any)*/
1780 Bool sir = showInstRes;
1782 setCurrModule(findEvalModule());
1783 startNewScript(0); /* Enables recovery of storage */
1784 /* allocated during evaluation */
1788 d = provePred(NIL,NIL,hd(inputContext));
1790 fprintf(stdout, "not Sat\n");
1792 fprintf(stdout, "Sat\n");
1798 /* --------------------------------------------------------------------------
1799 * Enhanced help system: print current list of scripts or give information
1801 * ------------------------------------------------------------------------*/
1803 static String local objToStr(m,c)
1806 #if 1 || DISPLAY_QUANTIFIERS
1807 static char newVar[60];
1808 switch (whatIs(c)) {
1809 case NAME : if (m == name(c).mod) {
1810 sprintf(newVar,"%s", textToStr(name(c).text));
1812 sprintf(newVar,"%s.%s",
1813 textToStr(module(name(c).mod).text),
1814 textToStr(name(c).text));
1818 case TYCON : if (m == tycon(c).mod) {
1819 sprintf(newVar,"%s", textToStr(tycon(c).text));
1821 sprintf(newVar,"%s.%s",
1822 textToStr(module(tycon(c).mod).text),
1823 textToStr(tycon(c).text));
1827 case CLASS : if (m == cclass(c).mod) {
1828 sprintf(newVar,"%s", textToStr(cclass(c).text));
1830 sprintf(newVar,"%s.%s",
1831 textToStr(module(cclass(c).mod).text),
1832 textToStr(cclass(c).text));
1836 default : internal("objToStr");
1840 static char newVar[33];
1841 switch (whatIs(c)) {
1842 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1845 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1848 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1851 default : internal("objToStr");
1859 static Void dumpStg ( void )
1865 setCurrModule(findEvalModule());
1870 /* request to locate a symbol by name */
1871 if (s && (*s == '?')) {
1872 Text t = findText(s+1);
1873 locateSymbolByName(t);
1877 /* request to dump a bit of the heap */
1878 if (s && (*s == '-' || isdigit(*s))) {
1885 /* request to dump a symbol table entry */
1887 || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
1888 || !isdigit(s[1])) {
1889 fprintf(stderr, ":d -- bad request `%s'\n", s );
1894 case 't': dumpTycon(i); break;
1895 case 'n': dumpName(i); break;
1896 case 'c': dumpClass(i); break;
1897 case 'i': dumpInst(i); break;
1898 default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
1904 static Void local dumpStg( void ) { /* print STG stuff */
1909 Cell v; /* really StgVar */
1910 setCurrModule(findEvalModule());
1912 for (; (s=readFilename())!=0;) {
1915 /* find the name while ignoring module scopes */
1916 for (i=NAMEMIN; i<nameHw; i++)
1917 if (name(i).text == t) n = i;
1919 /* perhaps it's an "idNNNNNN" thing? */
1922 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
1925 while (isdigit(s[i])) {
1926 v = v * 10 + (s[i]-'0');
1930 n = nameFromStgVar(v);
1933 if (isNull(n) && whatIs(v)==STGVAR) {
1934 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
1935 printStg(stderr, v );
1938 Printf ( "Unknown reference `%s'\n", s );
1941 Printf ( "Not a Name: `%s'\n", s );
1943 if (isNull(name(n).stgVar)) {
1944 Printf ( "Doesn't have a STG tree: %s\n", s );
1946 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
1947 printStg(stderr, name(n).stgVar);
1953 static Void local info() { /* describe objects */
1954 Int count = 0; /* or give menu of commands */
1957 for (; (s=readFilename())!=0; count++) {
1958 describe(findText(s));
1961 /* whatScripts(); */
1966 static Void local describe(t) /* describe an object */
1968 Tycon tc = findTycon(t);
1969 Class cl = findClass(t);
1970 Name nm = findName(t);
1972 if (nonNull(tc)) { /* as a type constructor */
1976 for (i=0; i<tycon(tc).arity; ++i) {
1977 t = ap(t,mkOffset(i));
1979 Printf("-- type constructor");
1981 Printf(" with kind ");
1982 printKind(stdout,tycon(tc).kind);
1985 switch (tycon(tc).what) {
1986 case SYNONYM : Printf("type ");
1987 printType(stdout,t);
1989 printType(stdout,tycon(tc).defn);
1993 case DATATYPE : { List cs = tycon(tc).defn;
1994 if (tycon(tc).what==DATATYPE) {
1999 printType(stdout,t);
2001 mapProc(printSyntax,cs);
2003 Printf("\n-- constructors:");
2005 for (; hasCfun(cs); cs=tl(cs)) {
2007 printExp(stdout,hd(cs));
2009 printType(stdout,name(hd(cs)).type);
2012 Printf("\n-- selectors:");
2014 for (; nonNull(cs); cs=tl(cs)) {
2016 printExp(stdout,hd(cs));
2018 printType(stdout,name(hd(cs)).type);
2023 case RESTRICTSYN : Printf("type ");
2024 printType(stdout,t);
2025 Printf(" = <restricted>");
2029 if (nonNull(in=findFirstInst(tc))) {
2030 Printf("\n-- instances:\n");
2033 in = findNextInst(tc,in);
2034 } while (nonNull(in));
2039 if (nonNull(cl)) { /* as a class */
2040 List ins = cclass(cl).instances;
2041 Kinds ks = cclass(cl).kinds;
2042 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2043 Printf("-- type class");
2045 Printf("-- constructor class");
2047 Printf(" with arity ");
2048 printKinds(stdout,ks);
2052 mapProc(printSyntax,cclass(cl).members);
2054 if (nonNull(cclass(cl).supers)) {
2055 printContext(stdout,cclass(cl).supers);
2058 printPred(stdout,cclass(cl).head);
2060 if (nonNull(cclass(cl).fds)) {
2061 List fds = cclass(cl).fds;
2063 for (; nonNull(fds); fds=tl(fds)) {
2065 printFD(stdout,hd(fds));
2070 if (nonNull(cclass(cl).members)) {
2071 List ms = cclass(cl).members;
2074 Type t = name(hd(ms)).type;
2075 if (isPolyType(t)) {
2079 printExp(stdout,hd(ms));
2081 if (isNull(tl(fst(snd(t))))) {
2084 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2086 printType(stdout,t);
2088 } while (nonNull(ms));
2092 Printf("\n-- instances:\n");
2096 } while (nonNull(ins));
2101 if (nonNull(nm)) { /* as a function/name */
2103 printExp(stdout,nm);
2105 if (nonNull(name(nm).type)) {
2106 printType(stdout,name(nm).type);
2108 Printf("<unknown type>");
2111 Printf(" -- data constructor");
2112 } else if (isMfun(nm)) {
2113 Printf(" -- class member");
2114 } else if (isSfun(nm)) {
2115 Printf(" -- selector function");
2121 if (isNull(tc) && isNull(cl) && isNull(nm)) {
2122 Printf("Unknown reference `%s'\n",textToStr(t));
2126 static Void local printSyntax(nm)
2128 Syntax sy = syntaxOf(nm);
2129 Text t = name(nm).text;
2130 String s = textToStr(t);
2131 if (sy != defaultSyntax(t)) {
2133 switch (assocOf(sy)) {
2134 case LEFT_ASS : Putchar('l'); break;
2135 case RIGHT_ASS : Putchar('r'); break;
2136 case NON_ASS : break;
2138 Printf(" %i ",precOf(sy));
2139 if (isascii((int)(*s)) && isalpha((int)(*s))) {
2148 static Void local showInst(in) /* Display instance decl header */
2150 Printf("instance ");
2151 if (nonNull(inst(in).specifics)) {
2152 printContext(stdout,inst(in).specifics);
2155 printPred(stdout,inst(in).head);
2159 /* --------------------------------------------------------------------------
2160 * List all names currently in scope:
2161 * ------------------------------------------------------------------------*/
2163 static Void local listNames() { /* list names matching optional pat*/
2164 String pat = readFilename();
2166 Int width = getTerminalWidth() - 1;
2169 Module mod = currentModule;
2171 if (pat) { /* First gather names to list */
2173 names = addNamesMatching(pat,names);
2174 } while ((pat=readFilename())!=0);
2176 names = addNamesMatching((String)0,names);
2178 if (isNull(names)) { /* Then print them out */
2179 ERRMSG(0) "No names selected"
2183 for (termPos=0; nonNull(names); names=tl(names)) {
2184 String s = objToStr(mod,hd(names));
2186 if (termPos+1+l>width) {
2189 } else if (termPos>0) {
2197 Printf("\n(%d names listed)\n", count);
2200 /* --------------------------------------------------------------------------
2201 * print a prompt and read a line of input:
2202 * ------------------------------------------------------------------------*/
2204 static Void local promptForInput(moduleName)
2205 String moduleName; {
2206 char promptBuffer[1000];
2208 /* This is portable but could overflow buffer */
2209 sprintf(promptBuffer,prompt,moduleName);
2211 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2212 * promptBuffer instead.
2214 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2215 /* Reset prompt to a safe default to avoid an infinite loop */
2217 prompt = strCopy("? ");
2218 internal("Combined prompt and evaluation module name too long");
2222 stringInput("main\0"); else
2223 consoleInput(promptBuffer);
2226 /* --------------------------------------------------------------------------
2227 * main read-eval-print loop, with error trapping:
2228 * ------------------------------------------------------------------------*/
2230 static Void local interpreter(argc,argv)/* main interpreter loop */
2234 List modConIds; /* :: [CONID] */
2238 breakOn(TRUE); /* enable break trapping */
2239 modConIds = initialize(argc,argv); /* the initial modules to load */
2240 prelOK = loadThePrelude();
2241 if (combined) everybody(POSTPREL);
2245 fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2247 fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2251 loadActions(modConIds);
2254 for (; nonNull(modConIds); modConIds=tl(modConIds))
2255 if (!elemMG(hd(modConIds))) {
2257 "hugs +Q: compilation failed -- can't run `main'\n" );
2264 /* initialize calls startupHaskell, which trashes our signal handlers */
2270 everybody(RESET); /* reset to sensible initial state */
2272 promptForInput(textToStr(module(currentModule).text));
2274 cmd = readCommand(cmds, (Char)':', (Char)'!');
2276 case EDIT : editor();
2280 case LOAD : modConIds = NIL;
2281 while ((s=readFilename())!=0)
2282 modConIds = cons(mkCon(findText(s)),modConIds);
2283 loadActions(modConIds);
2286 case ALSO : modConIds = NIL;
2287 while ((s=readFilename())!=0)
2288 modConIds = cons(mkCon(findText(s)),modConIds);
2289 addActions(modConIds);
2292 case RELOAD : refreshActions(NIL);
2297 case EVAL : evaluator();
2299 case TYPEOF : showtype();
2301 case BROWSE : browse();
2303 #if EXPLAIN_INSTANCE_RESOLUTION
2304 case XPLAIN : xplain();
2307 case NAMES : listNames();
2311 case BADCMD : guidance();
2316 #ifdef CRUDE_PROFILING
2320 case SYSTEM : if (shellEsc(readLine()))
2321 Printf("Warning: Shell escape terminated abnormally\n");
2323 case CHGDIR : changeDir();
2327 case PNTVER: Printf("-- Hugs Version %s\n",
2330 case DUMP : dumpStg();
2333 case COLLECT: consGC = FALSE;
2336 Printf("Garbage collection recovered %d cells\n",
2342 if (autoMain) break;
2347 /* --------------------------------------------------------------------------
2348 * Display progress towards goal:
2349 * ------------------------------------------------------------------------*/
2351 static Target currTarget;
2352 static Bool aiming = FALSE;
2355 static Int charCount;
2357 Void setGoal(what, t) /* Set goal for what to be t */
2362 #if EXPLAIN_INSTANCE_RESOLUTION
2366 currTarget = (t?t:1);
2369 currPos = strlen(what);
2370 maxPos = getTerminalWidth() - 1;
2374 for (charCount=0; *what; charCount++)
2379 Void soFar(t) /* Indicate progress towards goal */
2380 Target t; { /* has now reached t */
2383 #if EXPLAIN_INSTANCE_RESOLUTION
2388 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2393 if (newPos>currPos) {
2396 while (newPos>++currPos);
2403 Void done() { /* Goal has now been achieved */
2406 #if EXPLAIN_INSTANCE_RESOLUTION
2411 while (maxPos>currPos++)
2416 for (; charCount>0; charCount--) {
2425 static Void local failed() { /* Goal cannot be reached due to */
2426 if (aiming) { /* errors */
2433 /* --------------------------------------------------------------------------
2435 * ------------------------------------------------------------------------*/
2437 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
2438 if (printing) { /* after successful termination or */
2439 printing = FALSE; /* runtime error (e.g. interrupt) */
2442 #define plural(v) v, (v==1?"":"s")
2443 Printf("%lu cell%s",plural(numCells));
2445 Printf(", %u garbage collection%s",plural(numGcs));
2454 Cell errAssert(l) /* message to use when raising asserts, etc */
2459 str = mkStr(findText(scriptFile));
2461 str = mkStr(findText(""));
2463 return (ap2(nameTangleMessage,str,mkInt(l)));
2466 Void errHead(l) /* print start of error message */
2468 failed(); /* failed to reach target ... */
2470 FPrintf(errorStream,"ERROR");
2473 FPrintf(errorStream," \"%s\"", scriptFile);
2474 setLastEdit(scriptFile,l);
2475 if (l) FPrintf(errorStream," (line %d)",l);
2478 FPrintf(errorStream,": ");
2479 FFlush(errorStream);
2482 Void errFail() { /* terminate error message and */
2483 Putc('\n',errorStream); /* produce exception to return to */
2484 FFlush(errorStream); /* main command loop */
2485 longjmp(catch_error,1);
2488 Void errFail_no_longjmp() { /* terminate error message but */
2489 Putc('\n',errorStream); /* don't produce an exception */
2490 FFlush(errorStream);
2493 Void errAbort() { /* altern. form of error handling */
2494 failed(); /* used when suitable error message*/
2495 stopAnyPrinting(); /* has already been printed */
2499 Void internal(msg) /* handle internal error */
2503 Printf("INTERNAL ERROR: %s\n",msg);
2506 longjmp(catch_error,1);
2509 Void fatal(msg) /* handle fatal error */
2512 Printf("\nFATAL ERROR: %s\n",msg);
2517 sigHandler(breakHandler) { /* respond to break interrupt */
2519 Printf("{Interrupted!}\n");
2521 breakOn(TRUE); /* reinstall signal handler - redundant on BSD systems */
2522 /* but essential on POSIX (and other?) systems */
2528 longjmp(catch_error,1);
2529 sigResume;/*NOTREACHED*/
2532 /* --------------------------------------------------------------------------
2533 * Read value from environment variable or registry:
2534 * ------------------------------------------------------------------------*/
2536 String fromEnv(var,def) /* return value of: */
2537 String var; /* environment variable named by var */
2538 String def; { /* or: default value given by def */
2539 String s = getenv(var);
2540 return (s ? s : def);
2543 /* --------------------------------------------------------------------------
2544 * String manipulation routines:
2545 * ------------------------------------------------------------------------*/
2547 static String local strCopy(s) /* make malloced copy of a string */
2551 if ((t=(char *)malloc(strlen(s)+1))==0) {
2552 ERRMSG(0) "String storage space exhausted"
2555 for (r=t; (*r++ = *s++)!=0; ) {
2562 /* --------------------------------------------------------------------------
2564 * We can redirect compiler output (prompts, error messages, etc) by
2565 * tweaking these functions.
2566 * ------------------------------------------------------------------------*/
2568 /* --------------------------------------------------------------------------
2569 * Send message to each component of system:
2570 * ------------------------------------------------------------------------*/
2572 Void everybody(what) /* send command `what' to each component of*/
2573 Int what; { /* system to respond as appropriate ... */
2575 fprintf ( stderr, "EVERYBODY %d\n", what );
2577 machdep(what); /* The order of calling each component is */
2578 storage(what); /* important for the PREPREL command */
2581 translateControl(what);
2583 staticAnalysis(what);
2584 deriveControl(what);
2590 /*-------------------------------------------------------------------------*/