2 /* --------------------------------------------------------------------------
5 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
6 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
7 * Technology, 1994-1999, All rights reserved. It is distributed as
8 * free software under the license in the file "License", which is
9 * included in the distribution.
11 * $RCSfile: hugs.c,v $
13 * $Date: 2000/04/05 16:57:18 $
14 * ------------------------------------------------------------------------*/
20 #include "hugsbasictypes.h"
29 #include "Assembler.h" /* DEBUG_LoadSymbols */
31 Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
32 Bool initDone = FALSE;
34 #if EXPLAIN_INSTANCE_RESOLUTION
35 Bool showInstRes = FALSE;
38 Bool multiInstRes = FALSE;
41 /* --------------------------------------------------------------------------
42 * Local function prototypes:
43 * ------------------------------------------------------------------------*/
45 static List local initialize ( Int,String [] );
46 static Void local promptForInput ( String );
47 static Void local interpreter ( Int,String [] );
48 static Void local menu ( Void );
49 static Void local guidance ( Void );
50 static Void local forHelp ( Void );
51 static Void local set ( Void );
52 static Void local changeDir ( Void );
53 static Void local load ( Void );
54 static Void local project ( Void );
55 static Void local editor ( Void );
56 static Void local find ( Void );
57 static Bool local startEdit ( Int,String );
58 static Void local runEditor ( Void );
59 static Void local setModule ( Void );
60 static Void local evaluator ( Void );
61 static Void local stopAnyPrinting ( Void );
62 static Void local showtype ( Void );
63 static String local objToStr ( Module, Cell );
64 static Void local info ( Void );
65 static Void local printSyntax ( Name );
66 static Void local showInst ( Inst );
67 static Void local describe ( Text );
68 static Void local listNames ( Void );
70 static Void local toggleSet ( Char,Bool );
71 static Void local togglesIn ( Bool );
72 static Void local optionInfo ( Void );
74 static String local optionsToStr ( Void );
76 static Void local readOptions ( String );
77 static Bool local processOption ( String );
78 static Void local setHeapSize ( String );
79 static Int local argToInt ( String );
81 static Void local setLastEdit ( String,Int );
82 static Void local failed ( Void );
83 static String local strCopy ( String );
84 static Void local browseit ( Module,String,Bool );
85 static Void local browse ( Void );
87 /* --------------------------------------------------------------------------
88 * Machine dependent code for Hugs interpreter:
89 * ------------------------------------------------------------------------*/
93 /* --------------------------------------------------------------------------
95 * ------------------------------------------------------------------------*/
97 static Bool printing = FALSE; /* TRUE => currently printing value*/
98 static Bool showStats = FALSE; /* TRUE => print stats after eval */
99 static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
100 static Bool addType = FALSE; /* TRUE => print type with value */
101 static Bool useDots = RISCOS; /* TRUE => use dots in progress */
102 static Bool quiet = FALSE; /* TRUE => don't show progress */
103 static Bool lastWasObject = FALSE;
105 Bool flagAssert = FALSE; /* TRUE => assert False <e> causes
106 an assertion failure */
107 Bool preludeLoaded = FALSE;
108 Bool debugSC = FALSE;
109 Bool combined = FALSE;
111 Module moduleBeingParsed; /* so the parser (topModule) knows */
112 static char* currentFile; /* Name of current file, or NULL */
113 static char currentFileName[1000]; /* name is stored here if it exists*/
115 static Bool autoMain = FALSE;
116 static String lastEdit = 0; /* Name of script to edit (if any) */
117 static Int lastEdLine = 0; /* Editor line number (if possible)*/
118 static String prompt = 0; /* Prompt string */
119 static Int hpSize = DEFAULTHEAP; /* Desired heap size */
120 static Bool disableOutput = FALSE; /* TRUE => quiet */
121 String hugsEdit = 0; /* String for editor command */
122 String hugsPath = 0; /* String for file search path */
124 List ifaces_outstanding = NIL;
127 /* --------------------------------------------------------------------------
129 * ------------------------------------------------------------------------*/
131 #ifndef NO_MAIN /* we omit main when building the "Hugs server" */
133 Main main ( Int, String [] ); /* now every func has a prototype */
138 #ifdef HAVE_CONSOLE_H /* Macintosh port */
140 _fcreator = 'R*ch'; /* // 'KAHL'; //'*TEX'; //'ttxt'; */
142 console_options.top = 50;
143 console_options.left = 20;
145 console_options.nrows = 32;
146 console_options.ncols = 80;
148 console_options.pause_atexit = 1;
149 console_options.title = "\pHugs";
151 console_options.procID = 5;
152 argc = ccommand(&argv);
155 CStackBase = &argc; /* Save stack base for use in gc */
159 checkBytecodeCount(); /* check for too many bytecodes */
163 /* If first arg is +Q or -Q, be entirely silent, and automatically run
164 main after loading scripts. Useful for running the nofib suite. */
165 if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
167 if (strcmp(argv[1],"-Q") == 0) {
172 Printf("__ __ __ __ ____ ___ _________________________________________\n");
173 Printf("|| || || || || || ||__ STGHugs: Based on the Haskell 98 standard\n");
174 Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n");
175 Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
176 Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
177 Printf("|| || Version: %s _________________________________________\n\n",HUGS_VERSION);
179 /* Get the absolute path to the directory containing the hugs
180 executable, so that we know where the Prelude and nHandle.so/.dll are.
181 We do this by reading env var STGHUGSDIR. This needs to succeed, so
182 setInstallDir won't return unless it succeeds.
184 setInstallDir ( argv[0] );
187 Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
190 interpreter(argc,argv);
191 Printf("[Leaving Hugs]\n");
202 /* --------------------------------------------------------------------------
203 * Initialization, interpret command line args and read prelude:
204 * ------------------------------------------------------------------------*/
206 static List /*CONID*/ initialize(argc,argv) /* Interpreter initialization */
210 char argv_0_orig[1000];
213 setLastEdit((String)0,0);
220 hugsEdit = strCopy(fromEnv("EDITOR",NULL));
222 hugsPath = strCopy(HUGSPATH);
223 readOptions("-p\"%s> \" -r$$");
225 projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
226 "HUGSPATH", PATHSEP, ""));
227 readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
228 readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
229 #endif /* USE_REGISTRY */
230 readOptions(fromEnv("STGHUGSFLAGS",""));
232 strncpy(argv_0_orig,argv[0],1000); /* startupHaskell mangles argv[0] */
233 startupHaskell (argc,argv,NULL);
239 char exe_name[N_INSTALLDIR + 6];
240 strcpy(exe_name, installDir);
241 strcat(exe_name, "hugs");
242 DEBUG_LoadSymbols(exe_name);
246 /* Find out early on if we're in combined mode or not.
247 everybody(PREPREL) needs to know this. Also, establish the
250 for (i=1; i < argc; ++i) {
251 if (strcmp(argv[i], "--")==0) break;
252 if (strcmp(argv[i], "-c")==0) combined = FALSE;
253 if (strcmp(argv[i], "+c")==0) combined = TRUE;
255 if (strncmp(argv[i],"+h",2)==0 ||
256 strncmp(argv[i],"-h",2)==0)
257 setHeapSize(&(argv[i][2]));
261 initialModules = NIL;
263 for (i=1; i < argc; ++i) { /* process command line arguments */
264 if (strcmp(argv[i], "--")==0) break;
265 if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
266 && !processOption(argv[i])) {
268 = cons ( mkCon(findText(argv[i])), initialModules );
273 Printf("Haskell 98 mode: Restart with command line option -98"
274 " to enable extensions\n");
276 Printf("Hugs mode: Restart with command line option +98 for"
277 " Haskell 98 mode\n");
281 Printf("Combined mode: Restart with command line -c for"
282 " standalone mode\n\n" );
284 Printf("Standalone mode: Restart with command line +c for"
285 " combined mode\n\n" );
289 return initialModules;
292 /* --------------------------------------------------------------------------
293 * Command line options:
294 * ------------------------------------------------------------------------*/
296 struct options { /* command line option toggles */
297 char c; /* table defined in main app. */
302 extern struct options toggle[];
304 static Void local toggleSet(c,state) /* Set command line toggle */
308 for (i=0; toggle[i].c; ++i)
309 if (toggle[i].c == c) {
310 *toggle[i].flag = state;
313 ERRMSG(0) "Unknown toggle `%c'", c
317 static Void local togglesIn(state) /* Print current list of toggles in*/
318 Bool state; { /* given state */
321 for (i=0; toggle[i].c; ++i)
322 if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
324 Putchar((char)(state ? '+' : '-'));
325 Putchar(toggle[i].c);
332 static Void local optionInfo() { /* Print information about command */
333 static String fmts = "%-5s%s\n"; /* line settings */
334 static String fmtc = "%-5c%s\n";
337 Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
338 for (i=0; toggle[i].c; ++i) {
339 if (!haskell98 || toggle[i].h98) {
340 Printf(fmtc,toggle[i].c,toggle[i].description);
344 Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
345 Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
346 Printf(fmts,"pstr","Set prompt string to str");
347 Printf(fmts,"rstr","Set repeat last expression string to str");
348 Printf(fmts,"Pstr","Set search path for modules to str");
349 Printf(fmts,"Estr","Use editor setting given by str");
350 Printf(fmts,"cnum","Set constraint cutoff limit");
351 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
352 Printf(fmts,"Fstr","Set preprocessor filter to str");
355 Printf("\nCurrent settings: ");
358 Printf("-h%d",heapSize);
362 printString(repeatStr);
363 Printf(" -c%d",cutoff);
364 Printf("\nSearch path : -P");
365 printString(hugsPath);
368 if (projectPath!=NULL) {
369 Printf("\nProject Path : %s",projectPath);
372 Printf("\nEditor setting : -E");
373 printString(hugsEdit);
374 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
375 Printf("\nPreprocessor : -F");
376 printString(preprocessor);
378 Printf("\nCompatibility : %s", haskell98 ? "Haskell 98 (+98)"
379 : "Hugs Extensions (-98)");
391 #define PUTInt(optc,i) \
392 sprintf(next,"-%c%d",optc,i); \
395 #define PUTStr(c,s) \
396 next=PUTStr_aux(next,c,s)
398 static String local PUTStr_aux ( String,Char, String));
400 static String local PUTStr_aux(next,c,s)
406 sprintf(next,"-%c\"",c);
409 PUTS(unlexChar(*t,'"'));
417 static String local optionsToStr() { /* convert options to string */
418 static char buffer[2000];
419 String next = buffer;
422 for (i=0; toggle[i].c; ++i) {
423 PUTC(*toggle[i].flag ? '+' : '-');
427 PUTS(haskell98 ? "+98 " : "-98 ");
428 PUTInt('h',hpSize); PUTC(' ');
430 PUTStr('r',repeatStr);
431 PUTStr('P',hugsPath);
432 PUTStr('E',hugsEdit);
433 PUTInt('c',cutoff); PUTC(' ');
434 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
435 PUTStr('F',preprocessor);
440 #endif /* USE_REGISTRY */
447 static Void local readOptions(options) /* read options from string */
451 stringInput(options);
452 while ((s=readFilename())!=0) {
453 if (*s && !processOption(s)) {
454 ERRMSG(0) "Option string must begin with `+' or `-'"
461 static Bool local processOption(s) /* process string s for options, */
462 String s; { /* return FALSE if none found. */
474 case 'Q' : break; /* already handled */
476 case 'p' : if (s[1]) {
477 if (prompt) free(prompt);
478 prompt = strCopy(s+1);
482 case 'r' : if (s[1]) {
483 if (repeatStr) free(repeatStr);
484 repeatStr = strCopy(s+1);
489 String p = substPath(s+1,hugsPath ? hugsPath : "");
490 if (hugsPath) free(hugsPath);
495 case 'E' : if (hugsEdit) free(hugsEdit);
496 hugsEdit = strCopy(s+1);
499 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
500 case 'F' : if (preprocessor) free(preprocessor);
501 preprocessor = strCopy(s+1);
505 case 'h' : /* don't do anything, since pre-scan of args
506 will have got it already */
509 case 'c' : /* don't do anything, since pre-scan of args
510 will have got it already */
513 case 'D' : /* hack */
515 extern void setRtsFlags( int x );
516 setRtsFlags(argToInt(s+1));
520 default : if (strcmp("98",s)==0) {
521 if (initDone && ((state && !haskell98) ||
522 (!state && haskell98))) {
524 "Haskell 98 compatibility cannot be changed"
525 " while the interpreter is running\n");
538 static Void local setHeapSize(s)
541 hpSize = argToInt(s);
542 if (hpSize < MINIMUMHEAP)
543 hpSize = MINIMUMHEAP;
544 else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
545 hpSize = MAXIMUMHEAP;
546 if (initDone && hpSize != heapSize) {
547 /* ToDo: should this use a message box in winhugs? */
549 FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
551 FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
559 static Int local argToInt(s) /* read integer from argument str */
564 if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
565 ERRMSG(0) "Missing integer in option setting \"%s\"", t
570 Int d = (*s++) - '0';
571 if (n > ((MAXPOSINT - d)/10)) {
572 ERRMSG(0) "Option setting \"%s\" is too large", t
576 } while (isascii((int)(*s)) && isdigit((int)(*s)));
578 if (*s=='K' || *s=='k') {
579 if (n > (MAXPOSINT/1000)) {
580 ERRMSG(0) "Option setting \"%s\" is too large", t
587 #if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
588 if (*s=='M' || *s=='m') {
589 if (n > (MAXPOSINT/1000000)) {
590 ERRMSG(0) "Option setting \"%s\" is too large", t
598 #if MAXPOSINT > 1000000000
599 if (*s=='G' || *s=='g') {
600 if (n > (MAXPOSINT/1000000000)) {
601 ERRMSG(0) "Option setting \"%s\" is too large", t
610 ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
617 /* --------------------------------------------------------------------------
618 * Print Menu of list of commands:
619 * ------------------------------------------------------------------------*/
621 static struct cmd cmds[] = {
622 {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
623 {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
624 {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
625 {":quit", QUIT}, {":set", SET}, {":find", FIND},
626 {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
627 {":dump", DUMP}, {":ztats", STATS},
628 {":module",SETMODULE},
630 #if EXPLAIN_INSTANCE_RESOLUTION
633 {":version", PNTVER},
638 static Void local menu() {
639 Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
640 Printf("c is the first character in the full name.\n\n");
641 Printf(":load <filenames> load modules from specified files\n");
642 Printf(":load clear all files except prelude\n");
643 Printf(":also <filenames> read additional modules\n");
644 Printf(":reload repeat last load command\n");
645 Printf(":project <filename> use project file\n");
646 Printf(":edit <filename> edit file\n");
647 Printf(":edit edit last module\n");
648 Printf(":module <module> set module for evaluating expressions\n");
649 Printf("<expr> evaluate expression\n");
650 Printf(":type <expr> print type of expression\n");
651 Printf(":? display this list of commands\n");
652 Printf(":set <options> set command line options\n");
653 Printf(":set help on command line options\n");
654 Printf(":names [pat] list names currently in scope\n");
655 Printf(":info <names> describe named objects\n");
656 Printf(":browse <modules> browse names defined in <modules>\n");
657 #if EXPLAIN_INSTANCE_RESOLUTION
658 Printf(":xplain <context> explain instance resolution for <context>\n");
660 Printf(":find <name> edit module containing definition of name\n");
661 Printf(":!command shell escape\n");
662 Printf(":cd dir change directory\n");
663 Printf(":gc force garbage collection\n");
664 Printf(":version print Hugs version\n");
665 Printf(":dump <name> print STG code for named fn\n");
666 #ifdef CRUDE_PROFILING
667 Printf(":ztats <name> print reduction stats\n");
669 Printf(":quit exit Hugs interpreter\n");
672 static Void local guidance() {
673 Printf("Command not recognised. ");
677 static Void local forHelp() {
678 Printf("Type :? for help\n");
681 /* --------------------------------------------------------------------------
682 * Setting of command line options:
683 * ------------------------------------------------------------------------*/
685 struct options toggle[] = { /* List of command line toggles */
686 {'s', 1, "Print no. reductions/cells after eval", &showStats},
687 {'t', 1, "Print type after evaluation", &addType},
688 {'g', 1, "Print no. cells recovered after gc", &gcMessages},
689 {'l', 1, "Literate modules as default", &literateScripts},
690 {'e', 1, "Warn about errors in literate modules", &literateErrors},
691 {'.', 1, "Print dots to show progress", &useDots},
692 {'q', 1, "Print nothing to show progress", &quiet},
693 {'w', 1, "Always show which modules are loaded", &listScripts},
694 {'k', 1, "Show kind errors in full", &kindExpert},
695 {'o', 0, "Allow overlapping instances", &allowOverlap},
696 {'S', 1, "Debug: show generated SC code", &debugSC},
697 {'a', 1, "Raise exception on assert failure", &flagAssert},
698 #if EXPLAIN_INSTANCE_RESOLUTION
699 {'x', 1, "Explain instance resolution", &showInstRes},
702 {'m', 0, "Use multi instance resolution", &multiInstRes},
707 static Void local set() { /* change command line options from*/
708 String s; /* Hugs command line */
710 if ((s=readFilename())!=0) {
712 if (!processOption(s)) {
713 ERRMSG(0) "Option string must begin with `+' or `-'"
716 } while ((s=readFilename())!=0);
718 writeRegString("Options", optionsToStr());
725 /* --------------------------------------------------------------------------
726 * Change directory command:
727 * ------------------------------------------------------------------------*/
729 static Void local changeDir() { /* change directory */
730 String s = readFilename();
732 ERRMSG(0) "Unable to change to directory \"%s\"", s
738 /* --------------------------------------------------------------------------
740 * ------------------------------------------------------------------------*/
742 static jmp_buf catch_error; /* jump buffer for error trapping */
744 HugsBreakAction currentBreakAction = HugsIgnoreBreak;
746 static void handler_IgnoreBreak ( int sig )
748 setHandler ( handler_IgnoreBreak );
751 static void handler_LongjmpOnBreak ( int sig )
753 setHandler ( handler_LongjmpOnBreak );
754 Printf("{Interrupted!}\n");
755 longjmp(catch_error,1);
758 static void handler_RtsInterrupt ( int sig )
760 setHandler ( handler_RtsInterrupt );
764 HugsBreakAction setBreakAction ( HugsBreakAction newAction )
766 HugsBreakAction tmp = currentBreakAction;
767 currentBreakAction = newAction;
769 case HugsIgnoreBreak:
770 setHandler ( handler_IgnoreBreak ); break;
771 case HugsLongjmpOnBreak:
772 setHandler ( handler_LongjmpOnBreak ); break;
773 case HugsRtsInterrupt:
774 setHandler ( handler_RtsInterrupt ); break;
776 internal("setBreakAction");
782 /* --------------------------------------------------------------------------
783 * The new module chaser, loader, etc
784 * ------------------------------------------------------------------------*/
786 List moduleGraph = NIL;
787 List prelModules = NIL;
788 List targetModules = NIL;
790 static String modeToString ( Cell mode )
793 case FM_SOURCE: return "source";
794 case FM_OBJECT: return "object";
795 case FM_EITHER: return "source or object";
796 default: internal("modeToString");
800 static Cell childMode ( Cell modeMeRequest, Cell modeMeActual )
802 assert(modeMeActual == FM_SOURCE ||
803 modeMeActual == FM_OBJECT);
804 assert(modeMeRequest == FM_SOURCE ||
805 modeMeRequest == FM_OBJECT ||
806 modeMeRequest == FM_EITHER);
807 if (modeMeRequest == FM_SOURCE) return modeMeRequest;
808 if (modeMeRequest == FM_OBJECT) return modeMeRequest;
809 if (modeMeActual == FM_OBJECT) return FM_OBJECT;
810 if (modeMeActual == FM_SOURCE) return FM_EITHER;
811 internal("childMode");
814 static Bool compatibleNewMode ( Cell modeNew, Cell modeExisting )
816 if (modeNew == FM_OBJECT && modeExisting == FM_OBJECT) return TRUE;
817 if (modeNew == FM_SOURCE && modeExisting == FM_SOURCE) return TRUE;
818 if (modeNew == FM_EITHER && modeExisting == FM_OBJECT) return TRUE;
819 if (modeNew == FM_EITHER && modeExisting == FM_SOURCE) return TRUE;
823 static void setCurrentFile ( Module mod )
825 assert(isModule(mod));
826 strncpy(currentFileName, textToStr(module(mod).text), 990);
827 strcat(currentFileName, textToStr(module(mod).srcExt));
828 currentFile = currentFileName;
829 moduleBeingParsed = mod;
832 static void clearCurrentFile ( void )
835 moduleBeingParsed = NIL;
838 static void ppMG ( void )
841 for (t = moduleGraph; nonNull(t); t=tl(t)) {
845 FPrintf ( stderr, " %s\n", textToStr(textOf(snd(u))));
848 FPrintf ( stderr, " {" );
849 for (v = snd(u); nonNull(v); v=tl(v))
850 FPrintf ( stderr, "%s ", textToStr(textOf(hd(v))) );
851 FPrintf ( stderr, "}\n" );
860 static Bool elemMG ( ConId mod )
863 for (gs = moduleGraph; nonNull(gs); gs=tl(gs))
864 switch (whatIs(hd(gs))) {
866 if (textOf(mod)==textOf(snd(hd(gs)))) return TRUE;
869 if (varIsMember(textOf(mod),snd(hd(gs)))) return TRUE;
878 static ConId selectArbitrarilyFromGroup ( Cell group )
880 switch (whatIs(group)) {
881 case GRP_NONREC: return snd(group);
882 case GRP_REC: return hd(snd(group));
883 default: internal("selectArbitrarilyFromGroup");
887 static ConId selectLatestMG ( void )
889 List gs = moduleGraph;
890 if (isNull(gs)) internal("selectLatestMG(1)");
891 while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs);
892 return selectArbitrarilyFromGroup(hd(gs));
896 static List /* of CONID */ listFromSpecifiedMG ( List mg )
900 for (gs = mg; nonNull(gs); gs=tl(gs)) {
901 switch (whatIs(hd(gs))) {
902 case GRP_REC: cs = appendOnto(cs,snd(hd(gs))); break;
903 case GRP_NONREC: cs = cons(snd(hd(gs)),cs); break;
904 default: internal("listFromSpecifiedMG");
910 static List /* of CONID */ listFromMG ( void )
912 return listFromSpecifiedMG ( moduleGraph );
916 /* Calculate the strongly connected components of modgList
917 and assign them to moduleGraph. Uses the .uses field of
918 each of the modules to build the graph structure.
920 #define SCC modScc /* make scc algorithm for StgVars */
921 #define LOWLINK modLowlink
922 #define DEPENDS(t) snd(t)
923 #define SETDEPENDS(c,v) snd(c)=v
930 static void mgFromList ( List /* of CONID */ modgList )
936 List adjList; /* :: [ (Text, [Text]) ] */
942 for (t = modgList; nonNull(t); t=tl(t)) {
944 mod = findModule(mT);
945 assert(nonNull(mod));
947 for (u = module(mod).uses; nonNull(u); u=tl(u))
948 usesT = cons(textOf(hd(u)),usesT);
950 /* artificially give all modules a dependency on Prelude */
951 if (mT != textPrelude && mT != textPrimPrel)
952 usesT = cons(textPrelude,usesT);
954 adjList = cons(pair(mT,usesT),adjList);
957 /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
958 Modify this so that the adjacency list is a list of pointers
959 back to bits of adjList -- that's what modScc needs.
961 for (t = adjList; nonNull(t); t=tl(t)) {
963 /* for each elem of the adjacency list ... */
964 for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
967 /* find the element of adjList whose fst is a */
968 for (v = adjList; nonNull(v); v=tl(v)) {
970 assert(isText(fst(hd(v))));
971 if (fst(hd(v))==a) break;
973 if (isNull(v)) internal("mgFromList");
974 adj = cons(hd(v),adj);
979 adjList = modScc ( adjList );
980 /* adjList is now [ [(module-text, aux-info-field)] ] */
984 for (t = adjList; nonNull(t); t=tl(t)) {
987 /* scc :: [ (module-text, aux-info-field) ] */
988 for (u = scc; nonNull(u); u=tl(u))
989 hd(u) = mkCon(fst(hd(u)));
992 if (length(scc) > 1) {
995 /* singleton module in scc; does it import itself? */
996 mod = findModule ( textOf(hd(scc)) );
997 assert(nonNull(mod));
999 for (u = module(mod).uses; nonNull(u); u=tl(u))
1000 if (textOf(hd(u))==textOf(hd(scc)))
1005 moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
1006 moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
1008 moduleGraph = reverse(moduleGraph);
1012 static List /* of CONID */ getModuleImports ( Cell tree )
1018 for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
1020 switch(whatIs(te)) {
1022 use = zfst(unap(M_IMPORT_Q,te));
1024 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
1027 use = zfst(unap(M_IMPORT_UNQ,te));
1029 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
1039 static void processModule ( Module m )
1055 unqualImports = NIL;
1056 foreignImports = NIL;
1057 foreignExports = NIL;
1064 tree = unap(M_MODULE,module(m).tree);
1065 modNm = zfst3(tree);
1067 if (textOf(modNm) != module(m).text) {
1068 ERRMSG(0) "Module name \"%s\" does not match file name \"%s%s\"",
1069 textToStr(textOf(modNm)),
1070 textToStr(module(m).text),
1071 textToStr(module(m).srcExt)
1075 setExportList(zsnd3(tree));
1076 topEnts = zthd3(tree);
1078 for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
1080 assert(isGenPair(te));
1082 switch(whatIs(te)) {
1084 addQualImport(zfst(te2),zsnd(te2));
1087 addUnqualImport(zfst(te2),zsnd(te2));
1090 tyconDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
1093 classDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
1096 instDefn(zfst3(te2),zsnd3(te2),zthd3(te2));
1099 defaultDefn(zfst(te2),zsnd(te2));
1102 foreignImport(zsel15(te2),zsel25(te2),zsel35(te2),
1103 zsel45(te2),zsel55(te2));
1106 foreignExport(zsel15(te2),zsel25(te2),zsel35(te2),
1107 zsel45(te2),zsel55(te2));
1109 valDefns = cons(te2,valDefns);
1112 internal("processModule");
1121 static Module parseModuleOrInterface ( ConId mc, Cell modeRequest )
1123 /* Allocate a module-table entry. */
1124 /* Parse the entity and fill in the .tree and .uses entries. */
1127 Bool sAvail; Time sTime; Long sSize;
1128 Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1133 Text mt = textOf(mc);
1134 Module mod = findModule ( mt );
1136 /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
1137 textToStr(mt),mod); */
1138 if (nonNull(mod) && !module(mod).fake)
1139 internal("parseModuleOrInterface");
1141 module(mod).fake = FALSE;
1144 mod = newModule(mt);
1146 /* This call malloc-ates path; we should deallocate it. */
1147 ok = findFilesForModule (
1148 textToStr(module(mod).text),
1151 &sAvail, &sTime, &sSize,
1152 &oiAvail, &oiTime, &oSize, &iSize
1155 if (!ok) goto cant_find;
1156 if (!sAvail && !oiAvail) goto cant_find;
1158 /* Find out whether to use source or object. */
1159 switch (modeRequest) {
1161 if (!sAvail) goto cant_find;
1165 if (!oiAvail) goto cant_find;
1169 if ( sAvail && !oiAvail) { useSource = TRUE; break; }
1170 if (!sAvail && oiAvail) { useSource = FALSE; break; }
1171 useSource = firstTimeIsLater ( sTime, oiTime ) ? TRUE : FALSE;
1174 internal("parseModuleOrInterface");
1178 /* Actually do the parsing. */
1180 module(mod).srcExt = findText(sExt);
1181 setCurrentFile(mod);
1183 strcat(name, textToStr(mt));
1185 module(mod).tree = parseModule(name,sSize);
1186 module(mod).uses = getModuleImports(module(mod).tree);
1187 module(mod).mode = FM_SOURCE;
1188 module(mod).lastStamp = sTime;
1190 module(mod).srcExt = findText(HI_ENDING);
1191 setCurrentFile(mod);
1193 strcat(name, textToStr(mt));
1194 strcat(name, DLL_ENDING);
1195 module(mod).objName = findText(name);
1196 module(mod).objSize = oSize;
1198 strcat(name, textToStr(mt));
1199 strcat(name, ".u_hi");
1200 module(mod).tree = parseInterface(name,iSize);
1201 module(mod).uses = getInterfaceImports(module(mod).tree);
1202 module(mod).mode = FM_OBJECT;
1203 module(mod).lastStamp = oiTime;
1206 if (path) free(path);
1210 if (path) free(path);
1213 "Can't find %s for module \"%s\"",
1214 modeToString(modeRequest), textToStr(mt)
1219 static void tryLoadGroup ( Cell grp )
1223 switch (whatIs(grp)) {
1225 m = findModule(textOf(snd(grp)));
1227 if (module(m).mode == FM_SOURCE) {
1228 processModule ( m );
1229 module(m).tree = NIL;
1231 processInterfaces ( singleton(snd(grp)) );
1232 m = findModule(textOf(snd(grp)));
1234 module(m).tree = NIL;
1238 for (t = snd(grp); nonNull(t); t=tl(t)) {
1239 m = findModule(textOf(hd(t)));
1241 if (module(m).mode == FM_SOURCE) {
1242 ERRMSG(0) "Source module \"%s\" imports itself recursively",
1243 textToStr(textOf(hd(t)))
1247 processInterfaces ( snd(grp) );
1248 for (t = snd(grp); nonNull(t); t=tl(t)) {
1249 m = findModule(textOf(hd(t)));
1251 module(m).tree = NIL;
1255 internal("tryLoadGroup");
1260 static void fallBackToPrelModules ( void )
1263 for (m = MODULE_BASE_ADDR;
1264 m < MODULE_BASE_ADDR+tabModuleSz; m++)
1266 && !varIsMember(module(m).text, prelModules))
1271 /* This function catches exceptions in most of the system.
1272 So it's only ok for procedures called from this one
1273 to do EENDs (ie, write error messages). Others should use
1276 static void achieveTargetModules ( Bool loadingThePrelude )
1279 volatile List modgList;
1281 volatile Module mod;
1286 Bool sAvail; Time sTime; Long sSize;
1287 Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1289 volatile Time oisTime;
1290 volatile Bool out_of_date;
1291 volatile List ood_new;
1293 volatile List modgList_new;
1294 volatile List parsedButNotLoaded;
1295 volatile List toChase;
1296 volatile List trans_cl;
1297 volatile List trans_cl_new;
1302 volatile List badMods;
1304 setBreakAction ( HugsIgnoreBreak );
1306 /* First, examine timestamps to find out which modules are
1307 out of date with respect to the source/interface/object files.
1310 modgList = listFromMG();
1312 for (t = modgList; nonNull(t); t=tl(t)) {
1314 if (varIsMember(textOf(hd(t)),prelModules))
1317 mod = findModule(textOf(hd(t)));
1318 if (isNull(mod)) internal("achieveTargetSet(1)");
1320 /* In standalone mode, only succeeds for source modules. */
1321 ok = findFilesForModule (
1322 textToStr(module(mod).text),
1325 &sAvail, &sTime, &sSize,
1326 &oiAvail, &oiTime, &oSize, &iSize
1329 if (!combined && !sAvail) ok = FALSE;
1331 fallBackToPrelModules();
1333 "Can't find source or object+interface for module \"%s\"",
1334 textToStr(module(mod).text)
1336 if (path) free(path);
1340 if (sAvail && oiAvail) {
1341 oisTime = whicheverIsLater(sTime,oiTime);
1343 else if (sAvail && !oiAvail) {
1346 else if (!sAvail && oiAvail) {
1350 internal("achieveTargetSet(2)");
1353 out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
1355 assert(!varIsMember(textOf(hd(t)),ood));
1356 ood = cons(hd(t),ood);
1359 if (path) { free(path); path = NULL; };
1362 /* Second, form a simplistic transitive closure of the out-of-date
1363 modules: a module is out of date if it imports an out-of-date
1368 for (t = modgList; nonNull(t); t=tl(t)) {
1369 mod = findModule(textOf(hd(t)));
1370 assert(nonNull(mod));
1371 for (us = module(mod).uses; nonNull(us); us=tl(us))
1372 if (varIsMember(textOf(hd(us)),ood))
1375 if (varIsMember(textOf(hd(t)),prelModules))
1376 Printf ( "warning: prelude module \"%s\" is out-of-date\n",
1377 textToStr(textOf(hd(t))) );
1379 if (!varIsMember(textOf(hd(t)),ood_new) &&
1380 !varIsMember(textOf(hd(t)),ood))
1381 ood_new = cons(hd(t),ood_new);
1384 if (isNull(ood_new)) break;
1385 ood = appendOnto(ood_new,ood);
1388 /* Now ood holds the entire set of modules which are out-of-date.
1389 Throw them out of the system, yielding a "reduced system",
1390 in which the remaining modules are in-date.
1392 for (t = ood; nonNull(t); t=tl(t)) {
1393 mod = findModule(textOf(hd(t)));
1394 assert(nonNull(mod));
1398 for (t = modgList; nonNull(t); t=tl(t))
1399 if (!varIsMember(textOf(hd(t)),ood))
1400 modgList_new = cons(hd(t),modgList_new);
1401 modgList = modgList_new;
1403 /* Update the module group list to reflect the reduced system.
1404 We do this so that if the following parsing phases fail, we can
1405 safely fall back to the reduced system.
1407 mgFromList ( modgList );
1409 /* Parse modules/interfaces, collecting parse trees and chasing
1410 imports, starting from the target set.
1412 toChase = dupList(targetModules);
1413 for (t = toChase; nonNull(t); t=tl(t)) {
1414 Cell mode = (!combined)
1416 : ( (loadingThePrelude && combined)
1419 hd(t) = zpair(hd(t), mode);
1422 /* toChase :: [ ((ConId, {FM_SOURCE|FM_OBJECT|FM_EITHER} )) ] */
1424 parsedButNotLoaded = NIL;
1427 while (nonNull(toChase)) {
1428 ConId mc = zfst(hd(toChase));
1429 Cell mode = zsnd(hd(toChase));
1430 toChase = tl(toChase);
1431 if (varIsMember(textOf(mc),modgList)
1432 || varIsMember(textOf(mc),parsedButNotLoaded)) {
1433 /* either exists fully, or is at least parsed */
1434 mod = findModule(textOf(mc));
1435 assert(nonNull(mod));
1436 if (!compatibleNewMode(mode,module(mod).mode)) {
1439 "module %s: %s required, but %s is more recent",
1440 textToStr(textOf(mc)), modeToString(mode),
1441 modeToString(module(mod).mode)
1443 goto parseException;
1447 setBreakAction ( HugsLongjmpOnBreak );
1448 if (setjmp(catch_error)==0) {
1449 /* try this; it may throw an exception */
1450 mod = parseModuleOrInterface ( mc, mode );
1452 /* here's the exception handler, if parsing fails */
1453 /* A parse error (or similar). Clean up and abort. */
1455 setBreakAction ( HugsIgnoreBreak );
1456 mod = findModule(textOf(mc));
1457 if (nonNull(mod)) nukeModule(mod);
1458 for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
1459 mod = findModule(textOf(hd(t)));
1460 assert(nonNull(mod));
1461 if (nonNull(mod)) nukeModule(mod);
1464 /* end of the exception handler */
1466 setBreakAction ( HugsIgnoreBreak );
1468 parsedButNotLoaded = cons(mc, parsedButNotLoaded);
1469 for (t = module(mod).uses; nonNull(t); t=tl(t))
1471 zpair( hd(t), childMode(mode,module(mod).mode) ),
1476 modgList = dupOnto(parsedButNotLoaded, modgList);
1478 /* We successfully parsed all modules reachable from the target
1479 set which were not part of the reduced system. However, there
1480 may be modules in the reduced system which are not reachable from
1481 the target set. We detect these now by building the transitive
1482 closure of the target set, and nuking modules in the reduced
1483 system which are not part of that closure.
1485 trans_cl = dupList(targetModules);
1488 for (t = trans_cl; nonNull(t); t=tl(t)) {
1489 mod = findModule(textOf(hd(t)));
1490 assert(nonNull(mod));
1491 for (u = module(mod).uses; nonNull(u); u=tl(u))
1492 if (!varIsMember(textOf(hd(u)),trans_cl)
1493 && !varIsMember(textOf(hd(u)),trans_cl_new)
1494 && !varIsMember(textOf(hd(u)),prelModules))
1495 trans_cl_new = cons(hd(u),trans_cl_new);
1497 if (isNull(trans_cl_new)) break;
1498 trans_cl = appendOnto(trans_cl_new,trans_cl);
1501 for (t = modgList; nonNull(t); t=tl(t)) {
1502 if (varIsMember(textOf(hd(t)),trans_cl)) {
1503 modgList_new = cons(hd(t),modgList_new);
1505 mod = findModule(textOf(hd(t)));
1506 assert(nonNull(mod));
1510 modgList = modgList_new;
1512 /* Now, the module symbol tables hold exactly the set of
1513 modules reachable from the target set, and modgList holds
1514 their names. Calculate the scc-ified module graph,
1515 since we need that to guide the next stage, that of
1516 Actually Loading the modules.
1518 If no errors occur, moduleGraph will reflect the final graph
1519 loaded. If an error occurs loading a group, we nuke
1520 that group, truncate the moduleGraph just prior to that
1521 group, and exit. That leaves the system having successfully
1522 loaded all groups prior to the one which failed.
1524 mgFromList ( modgList );
1526 for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
1529 if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
1530 parsedButNotLoaded)) continue;
1532 setBreakAction ( HugsLongjmpOnBreak );
1533 if (setjmp(catch_error)==0) {
1534 /* try this; it may throw an exception */
1537 /* here's the exception handler, if static/typecheck etc fails */
1538 /* nuke the entire rest (ie, the unloaded part)
1539 of the module graph */
1540 setBreakAction ( HugsIgnoreBreak );
1541 badMods = listFromSpecifiedMG ( mg );
1542 for (t = badMods; nonNull(t); t=tl(t)) {
1543 mod = findModule(textOf(hd(t)));
1544 if (nonNull(mod)) nukeModule(mod);
1546 /* truncate the module graph just prior to this group. */
1550 if (isNull(mg)) break;
1551 if (hd(mg) == grp) break;
1552 mg2 = cons ( hd(mg), mg2 );
1555 moduleGraph = reverse(mg2);
1557 /* end of the exception handler */
1559 setBreakAction ( HugsIgnoreBreak );
1562 /* Err .. I think that's it. If we get here, we've successfully
1563 achieved the target set. Phew!
1565 setBreakAction ( HugsIgnoreBreak );
1569 static Bool loadThePrelude ( void )
1574 moduleGraph = prelModules = NIL;
1577 conPrelude = mkCon(findText("Prelude"));
1578 conPrelHugs = mkCon(findText("PrelHugs"));
1579 targetModules = doubleton(conPrelude,conPrelHugs);
1580 achieveTargetModules(TRUE);
1581 ok = elemMG(conPrelude) && elemMG(conPrelHugs);
1583 conPrelude = mkCon(findText("Prelude"));
1584 targetModules = singleton(conPrelude);
1585 achieveTargetModules(TRUE);
1586 ok = elemMG(conPrelude);
1589 if (ok) prelModules = listFromMG();
1594 static void refreshActions ( ConId nextCurrMod, Bool cleanAfter )
1597 ConId tryFor = mkCon(module(currentModule).text);
1598 achieveTargetModules(FALSE);
1599 if (nonNull(nextCurrMod))
1600 tryFor = nextCurrMod;
1601 if (!elemMG(tryFor))
1602 tryFor = selectLatestMG();
1603 /* combined mode kludge, to get Prelude rather than PrelHugs */
1604 if (combined && textOf(tryFor)==findText("PrelHugs"))
1605 tryFor = mkCon(findText("Prelude"));
1608 /* delete any targetModules which didn't actually get loaded */
1610 targetModules = NIL;
1611 for (; nonNull(t); t=tl(t))
1613 targetModules = cons(hd(t),targetModules);
1616 setCurrModule ( findModule(textOf(tryFor)) );
1617 Printf("Hugs session for:\n");
1622 static void addActions ( List extraModules /* :: [CONID] */ )
1625 for (t = extraModules; nonNull(t); t=tl(t)) {
1626 ConId extra = hd(t);
1627 if (!varIsMember(textOf(extra),targetModules))
1628 targetModules = cons(extra,targetModules);
1630 refreshActions ( isNull(extraModules)
1632 : hd(reverse(extraModules)),
1638 static void loadActions ( List loadModules /* :: [CONID] */ )
1641 targetModules = dupList ( prelModules );
1643 for (t = loadModules; nonNull(t); t=tl(t)) {
1645 if (!varIsMember(textOf(load),targetModules))
1646 targetModules = cons(load,targetModules);
1648 refreshActions ( isNull(loadModules)
1650 : hd(reverse(loadModules)),
1656 /* --------------------------------------------------------------------------
1657 * Access to external editor:
1658 * ------------------------------------------------------------------------*/
1660 /* ToDo: All this editor stuff needs fixing. */
1662 static Void local editor() { /* interpreter-editor interface */
1664 String newFile = readFilename();
1666 setLastEdit(newFile,0);
1667 if (readFilename()) {
1668 ERRMSG(0) "Multiple filenames not permitted"
1676 static Void local find() { /* edit file containing definition */
1679 String nm = readFilename(); /* of specified name */
1681 ERRMSG(0) "No name specified"
1684 else if (readFilename()) {
1685 ERRMSG(0) "Multiple names not permitted"
1691 setCurrModule(findEvalModule());
1693 if (nonNull(c=findTycon(t=findText(nm)))) {
1694 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1695 readScripts(N_PRELUDE_SCRIPTS);
1697 } else if (nonNull(c=findName(t))) {
1698 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1699 readScripts(N_PRELUDE_SCRIPTS);
1702 ERRMSG(0) "No current definition for name \"%s\"", nm
1709 static Void local runEditor() { /* run editor on script lastEdit */
1711 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1712 readScripts(N_PRELUDE_SCRIPTS);
1716 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1722 lastEdit = strCopy(fname);
1727 /* --------------------------------------------------------------------------
1728 * Read and evaluate an expression:
1729 * ------------------------------------------------------------------------*/
1731 static Void setModule ( void ) {
1732 /*set module in which to evaluate expressions*/
1735 String s = readFilename();
1737 mc = selectLatestMG();
1738 if (combined && textOf(mc)==findText("PrelHugs"))
1739 mc = mkCon(findText("Prelude"));
1740 m = findModule(textOf(mc));
1743 m = findModule(findText(s));
1745 ERRMSG(0) "Cannot find module \"%s\"", s
1753 static Module allocEvalModule ( void )
1755 Module evalMod = newModule( findText("_Eval_Module_") );
1756 module(evalMod).names = module(currentModule).names;
1757 module(evalMod).tycons = module(currentModule).tycons;
1758 module(evalMod).classes = module(currentModule).classes;
1759 module(evalMod).qualImports
1760 = singleton(pair(mkCon(textPrelude),modulePrelude));
1764 static Void local evaluator() { /* evaluate expr and print value */
1767 volatile Kinds ks = NIL;
1768 volatile Module evalMod = allocEvalModule();
1769 volatile Module currMod = currentModule;
1770 setCurrModule(evalMod);
1773 defaultDefns = combined ? stdDefaults : evalDefaults;
1775 setBreakAction ( HugsLongjmpOnBreak );
1776 if (setjmp(catch_error)==0) {
1780 type = typeCheckExp(TRUE);
1782 /* if an exception happens, we arrive here */
1783 setBreakAction ( HugsIgnoreBreak );
1784 goto cleanup_and_return;
1787 setBreakAction ( HugsIgnoreBreak );
1788 if (isPolyType(type)) {
1789 ks = polySigOf(type);
1790 bd = monotypeOf(type);
1795 if (whatIs(bd)==QUAL) {
1796 ERRMSG(0) "Unresolved overloading" ETHEN
1797 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1798 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1801 goto cleanup_and_return;
1805 if (isProgType(ks,bd)) {
1806 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1810 Cell d = provePred(ks,NIL,ap(classShow,bd));
1812 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1813 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1814 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1817 goto cleanup_and_return;
1819 inputExpr = ap2(nameShow, d,inputExpr);
1820 inputExpr = ap (namePutStr, inputExpr);
1821 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1823 evalExp(); printf("\n");
1826 printType(stdout,type);
1833 printf ( "result type is " );
1834 printType ( stdout, type );
1842 setBreakAction ( HugsIgnoreBreak );
1843 nukeModule(evalMod);
1844 setCurrModule(currMod);
1845 setCurrentFile(currMod);
1850 /* --------------------------------------------------------------------------
1851 * Print type of input expression:
1852 * ------------------------------------------------------------------------*/
1854 static Void showtype ( void ) { /* print type of expression (if any)*/
1857 volatile Module evalMod = allocEvalModule();
1858 volatile Module currMod = currentModule;
1859 setCurrModule(evalMod);
1861 if (setjmp(catch_error)==0) {
1865 defaultDefns = evalDefaults;
1866 type = typeCheckExp(FALSE);
1867 printExp(stdout,inputExpr);
1869 printType(stdout,type);
1872 /* if an exception happens, we arrive here */
1875 nukeModule(evalMod);
1876 setCurrModule(currMod);
1880 static Void local browseit(mod,t,all)
1887 Printf("module %s where\n",textToStr(module(mod).text));
1888 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1890 /* only look at things defined in this module,
1891 unless `all' flag is set */
1892 if (all || name(nm).mod == mod) {
1893 /* unwanted artifacts, like lambda lifted values,
1894 are in the list of names, but have no types */
1895 if (nonNull(name(nm).type)) {
1896 printExp(stdout,nm);
1898 printType(stdout,name(nm).type);
1900 Printf(" -- data constructor");
1901 } else if (isMfun(nm)) {
1902 Printf(" -- class member");
1903 } else if (isSfun(nm)) {
1904 Printf(" -- selector function");
1912 Printf("Unknown module %s\n",t);
1917 static Void local browse() { /* browse modules */
1918 Int count = 0; /* or give menu of commands */
1922 for (; (s=readFilename())!=0; count++)
1923 if (strcmp(s,"all") == 0) {
1927 browseit(findModule(findText(s)),s,all);
1929 browseit(currentModule,NULL,all);
1933 #if EXPLAIN_INSTANCE_RESOLUTION
1934 static Void local xplain() { /* print type of expression (if any)*/
1936 Bool sir = showInstRes;
1938 setCurrModule(findEvalModule());
1939 startNewScript(0); /* Enables recovery of storage */
1940 /* allocated during evaluation */
1944 d = provePred(NIL,NIL,hd(inputContext));
1946 fprintf(stdout, "not Sat\n");
1948 fprintf(stdout, "Sat\n");
1954 /* --------------------------------------------------------------------------
1955 * Enhanced help system: print current list of scripts or give information
1957 * ------------------------------------------------------------------------*/
1959 static String local objToStr(m,c)
1962 #if 1 || DISPLAY_QUANTIFIERS
1963 static char newVar[60];
1964 switch (whatIs(c)) {
1965 case NAME : if (m == name(c).mod) {
1966 sprintf(newVar,"%s", textToStr(name(c).text));
1968 sprintf(newVar,"%s.%s",
1969 textToStr(module(name(c).mod).text),
1970 textToStr(name(c).text));
1974 case TYCON : if (m == tycon(c).mod) {
1975 sprintf(newVar,"%s", textToStr(tycon(c).text));
1977 sprintf(newVar,"%s.%s",
1978 textToStr(module(tycon(c).mod).text),
1979 textToStr(tycon(c).text));
1983 case CLASS : if (m == cclass(c).mod) {
1984 sprintf(newVar,"%s", textToStr(cclass(c).text));
1986 sprintf(newVar,"%s.%s",
1987 textToStr(module(cclass(c).mod).text),
1988 textToStr(cclass(c).text));
1992 default : internal("objToStr");
1996 static char newVar[33];
1997 switch (whatIs(c)) {
1998 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
2001 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
2004 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
2007 default : internal("objToStr");
2015 static Void dumpStg ( void )
2021 setCurrModule(findEvalModule());
2026 /* request to locate a symbol by name */
2027 if (s && (*s == '?')) {
2028 Text t = findText(s+1);
2029 locateSymbolByName(t);
2033 /* request to dump a bit of the heap */
2034 if (s && (*s == '-' || isdigit(*s))) {
2041 /* request to dump a symbol table entry */
2043 || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
2044 || !isdigit(s[1])) {
2045 fprintf(stderr, ":d -- bad request `%s'\n", s );
2050 case 't': dumpTycon(i); break;
2051 case 'n': dumpName(i); break;
2052 case 'c': dumpClass(i); break;
2053 case 'i': dumpInst(i); break;
2054 default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
2060 static Void local dumpStg( void ) { /* print STG stuff */
2065 Cell v; /* really StgVar */
2066 setCurrModule(findEvalModule());
2068 for (; (s=readFilename())!=0;) {
2071 /* find the name while ignoring module scopes */
2072 for (i=NAMEMIN; i<nameHw; i++)
2073 if (name(i).text == t) n = i;
2075 /* perhaps it's an "idNNNNNN" thing? */
2078 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2081 while (isdigit(s[i])) {
2082 v = v * 10 + (s[i]-'0');
2086 n = nameFromStgVar(v);
2089 if (isNull(n) && whatIs(v)==STGVAR) {
2090 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2091 printStg(stderr, v );
2094 Printf ( "Unknown reference `%s'\n", s );
2097 Printf ( "Not a Name: `%s'\n", s );
2099 if (isNull(name(n).stgVar)) {
2100 Printf ( "Doesn't have a STG tree: %s\n", s );
2102 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2103 printStg(stderr, name(n).stgVar);
2109 static Void local info() { /* describe objects */
2110 Int count = 0; /* or give menu of commands */
2113 for (; (s=readFilename())!=0; count++) {
2114 describe(findText(s));
2117 /* whatScripts(); */
2122 static Void local describe(t) /* describe an object */
2124 Tycon tc = findTycon(t);
2125 Class cl = findClass(t);
2126 Name nm = findName(t);
2128 if (nonNull(tc)) { /* as a type constructor */
2132 for (i=0; i<tycon(tc).arity; ++i) {
2133 t = ap(t,mkOffset(i));
2135 Printf("-- type constructor");
2137 Printf(" with kind ");
2138 printKind(stdout,tycon(tc).kind);
2141 switch (tycon(tc).what) {
2142 case SYNONYM : Printf("type ");
2143 printType(stdout,t);
2145 printType(stdout,tycon(tc).defn);
2149 case DATATYPE : { List cs = tycon(tc).defn;
2150 if (tycon(tc).what==DATATYPE) {
2155 printType(stdout,t);
2157 mapProc(printSyntax,cs);
2159 Printf("\n-- constructors:");
2161 for (; hasCfun(cs); cs=tl(cs)) {
2163 printExp(stdout,hd(cs));
2165 printType(stdout,name(hd(cs)).type);
2168 Printf("\n-- selectors:");
2170 for (; nonNull(cs); cs=tl(cs)) {
2172 printExp(stdout,hd(cs));
2174 printType(stdout,name(hd(cs)).type);
2179 case RESTRICTSYN : Printf("type ");
2180 printType(stdout,t);
2181 Printf(" = <restricted>");
2185 if (nonNull(in=findFirstInst(tc))) {
2186 Printf("\n-- instances:\n");
2189 in = findNextInst(tc,in);
2190 } while (nonNull(in));
2195 if (nonNull(cl)) { /* as a class */
2196 List ins = cclass(cl).instances;
2197 Kinds ks = cclass(cl).kinds;
2198 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2199 Printf("-- type class");
2201 Printf("-- constructor class");
2203 Printf(" with arity ");
2204 printKinds(stdout,ks);
2208 mapProc(printSyntax,cclass(cl).members);
2210 if (nonNull(cclass(cl).supers)) {
2211 printContext(stdout,cclass(cl).supers);
2214 printPred(stdout,cclass(cl).head);
2216 if (nonNull(cclass(cl).fds)) {
2217 List fds = cclass(cl).fds;
2219 for (; nonNull(fds); fds=tl(fds)) {
2221 printFD(stdout,hd(fds));
2226 if (nonNull(cclass(cl).members)) {
2227 List ms = cclass(cl).members;
2230 Type t = name(hd(ms)).type;
2231 if (isPolyType(t)) {
2235 printExp(stdout,hd(ms));
2237 if (isNull(tl(fst(snd(t))))) {
2240 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2242 printType(stdout,t);
2244 } while (nonNull(ms));
2248 Printf("\n-- instances:\n");
2252 } while (nonNull(ins));
2257 if (nonNull(nm)) { /* as a function/name */
2259 printExp(stdout,nm);
2261 if (nonNull(name(nm).type)) {
2262 printType(stdout,name(nm).type);
2264 Printf("<unknown type>");
2267 Printf(" -- data constructor");
2268 } else if (isMfun(nm)) {
2269 Printf(" -- class member");
2270 } else if (isSfun(nm)) {
2271 Printf(" -- selector function");
2277 if (isNull(tc) && isNull(cl) && isNull(nm)) {
2278 Printf("Unknown reference `%s'\n",textToStr(t));
2282 static Void local printSyntax(nm)
2284 Syntax sy = syntaxOf(nm);
2285 Text t = name(nm).text;
2286 String s = textToStr(t);
2287 if (sy != defaultSyntax(t)) {
2289 switch (assocOf(sy)) {
2290 case LEFT_ASS : Putchar('l'); break;
2291 case RIGHT_ASS : Putchar('r'); break;
2292 case NON_ASS : break;
2294 Printf(" %i ",precOf(sy));
2295 if (isascii((int)(*s)) && isalpha((int)(*s))) {
2304 static Void local showInst(in) /* Display instance decl header */
2306 Printf("instance ");
2307 if (nonNull(inst(in).specifics)) {
2308 printContext(stdout,inst(in).specifics);
2311 printPred(stdout,inst(in).head);
2315 /* --------------------------------------------------------------------------
2316 * List all names currently in scope:
2317 * ------------------------------------------------------------------------*/
2319 static Void local listNames() { /* list names matching optional pat*/
2320 String pat = readFilename();
2322 Int width = getTerminalWidth() - 1;
2325 Module mod = currentModule;
2327 if (pat) { /* First gather names to list */
2329 names = addNamesMatching(pat,names);
2330 } while ((pat=readFilename())!=0);
2332 names = addNamesMatching((String)0,names);
2334 if (isNull(names)) { /* Then print them out */
2335 ERRMSG(0) "No names selected"
2339 for (termPos=0; nonNull(names); names=tl(names)) {
2340 String s = objToStr(mod,hd(names));
2342 if (termPos+1+l>width) {
2345 } else if (termPos>0) {
2353 Printf("\n(%d names listed)\n", count);
2356 /* --------------------------------------------------------------------------
2357 * print a prompt and read a line of input:
2358 * ------------------------------------------------------------------------*/
2360 static Void local promptForInput(moduleName)
2361 String moduleName; {
2362 char promptBuffer[1000];
2364 /* This is portable but could overflow buffer */
2365 sprintf(promptBuffer,prompt,moduleName);
2367 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2368 * promptBuffer instead.
2370 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2371 /* Reset prompt to a safe default to avoid an infinite loop */
2373 prompt = strCopy("? ");
2374 internal("Combined prompt and evaluation module name too long");
2378 stringInput("main\0"); else
2379 consoleInput(promptBuffer);
2382 /* --------------------------------------------------------------------------
2383 * main read-eval-print loop, with error trapping:
2384 * ------------------------------------------------------------------------*/
2386 static Void local interpreter(argc,argv)/* main interpreter loop */
2390 List modConIds; /* :: [CONID] */
2394 setBreakAction ( HugsIgnoreBreak );
2395 modConIds = initialize(argc,argv); /* the initial modules to load */
2396 setBreakAction ( HugsIgnoreBreak );
2397 prelOK = loadThePrelude();
2398 if (combined) everybody(POSTPREL);
2402 fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2404 fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2408 loadActions(modConIds);
2411 for (; nonNull(modConIds); modConIds=tl(modConIds))
2412 if (!elemMG(hd(modConIds))) {
2414 "hugs +Q: compilation failed -- can't run `main'\n" );
2421 /* initialize calls startupHaskell, which trashes our signal handlers */
2422 setBreakAction ( HugsIgnoreBreak );
2427 everybody(RESET); /* reset to sensible initial state */
2429 promptForInput(textToStr(module(currentModule).text));
2431 cmd = readCommand(cmds, (Char)':', (Char)'!');
2433 case EDIT : editor();
2437 case LOAD : modConIds = NIL;
2438 while ((s=readFilename())!=0)
2439 modConIds = cons(mkCon(findText(s)),modConIds);
2440 loadActions(modConIds);
2443 case ALSO : modConIds = NIL;
2444 while ((s=readFilename())!=0)
2445 modConIds = cons(mkCon(findText(s)),modConIds);
2446 addActions(modConIds);
2449 case RELOAD : refreshActions(NIL,FALSE);
2454 case EVAL : evaluator();
2456 case TYPEOF : showtype();
2458 case BROWSE : browse();
2460 #if EXPLAIN_INSTANCE_RESOLUTION
2461 case XPLAIN : xplain();
2464 case NAMES : listNames();
2468 case BADCMD : guidance();
2473 #ifdef CRUDE_PROFILING
2477 case SYSTEM : if (shellEsc(readLine()))
2478 Printf("Warning: Shell escape terminated abnormally\n");
2480 case CHGDIR : changeDir();
2484 case PNTVER: Printf("-- Hugs Version %s\n",
2487 case DUMP : dumpStg();
2490 case COLLECT: consGC = FALSE;
2493 Printf("Garbage collection recovered %d cells\n",
2499 if (autoMain) break;
2503 /* --------------------------------------------------------------------------
2504 * Display progress towards goal:
2505 * ------------------------------------------------------------------------*/
2507 static Target currTarget;
2508 static Bool aiming = FALSE;
2511 static Int charCount;
2513 Void setGoal(what, t) /* Set goal for what to be t */
2518 #if EXPLAIN_INSTANCE_RESOLUTION
2522 currTarget = (t?t:1);
2525 currPos = strlen(what);
2526 maxPos = getTerminalWidth() - 1;
2530 for (charCount=0; *what; charCount++)
2535 Void soFar(t) /* Indicate progress towards goal */
2536 Target t; { /* has now reached t */
2539 #if EXPLAIN_INSTANCE_RESOLUTION
2544 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2549 if (newPos>currPos) {
2552 while (newPos>++currPos);
2559 Void done() { /* Goal has now been achieved */
2562 #if EXPLAIN_INSTANCE_RESOLUTION
2567 while (maxPos>currPos++)
2572 for (; charCount>0; charCount--) {
2581 static Void local failed() { /* Goal cannot be reached due to */
2582 if (aiming) { /* errors */
2589 /* --------------------------------------------------------------------------
2591 * ------------------------------------------------------------------------*/
2593 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
2594 if (printing) { /* after successful termination or */
2595 printing = FALSE; /* runtime error (e.g. interrupt) */
2598 #define plural(v) v, (v==1?"":"s")
2599 Printf("%lu cell%s",plural(numCells));
2601 Printf(", %u garbage collection%s",plural(numGcs));
2610 Cell errAssert(l) /* message to use when raising asserts, etc */
2614 str = mkStr(findText(currentFile));
2616 str = mkStr(findText(""));
2618 return (ap2(nameTangleMessage,str,mkInt(l)));
2621 Void errHead(l) /* print start of error message */
2623 failed(); /* failed to reach target ... */
2625 FPrintf(errorStream,"ERROR");
2628 FPrintf(errorStream," \"%s\"", currentFile);
2629 setLastEdit(currentFile,l);
2630 if (l) FPrintf(errorStream," (line %d)",l);
2633 FPrintf(errorStream,": ");
2634 FFlush(errorStream);
2637 Void errFail() { /* terminate error message and */
2638 Putc('\n',errorStream); /* produce exception to return to */
2639 FFlush(errorStream); /* main command loop */
2640 longjmp(catch_error,1);
2643 Void errFail_no_longjmp() { /* terminate error message but */
2644 Putc('\n',errorStream); /* don't produce an exception */
2645 FFlush(errorStream);
2648 Void errAbort() { /* altern. form of error handling */
2649 failed(); /* used when suitable error message*/
2650 stopAnyPrinting(); /* has already been printed */
2654 Void internal(msg) /* handle internal error */
2658 Printf("INTERNAL ERROR: %s\n",msg);
2661 longjmp(catch_error,1);
2664 Void fatal(msg) /* handle fatal error */
2667 Printf("\nFATAL ERROR: %s\n",msg);
2673 /* --------------------------------------------------------------------------
2674 * Read value from environment variable or registry:
2675 * ------------------------------------------------------------------------*/
2677 String fromEnv(var,def) /* return value of: */
2678 String var; /* environment variable named by var */
2679 String def; { /* or: default value given by def */
2680 String s = getenv(var);
2681 return (s ? s : def);
2684 /* --------------------------------------------------------------------------
2685 * String manipulation routines:
2686 * ------------------------------------------------------------------------*/
2688 static String local strCopy(s) /* make malloced copy of a string */
2692 if ((t=(char *)malloc(strlen(s)+1))==0) {
2693 ERRMSG(0) "String storage space exhausted"
2696 for (r=t; (*r++ = *s++)!=0; ) {
2704 /* --------------------------------------------------------------------------
2706 * We can redirect compiler output (prompts, error messages, etc) by
2707 * tweaking these functions.
2708 * ------------------------------------------------------------------------*/
2710 #ifdef HAVE_STDARG_H
2713 #include <varargs.h>
2716 Void hugsEnableOutput(f)
2721 #ifdef HAVE_STDARG_H
2722 Void hugsPrintf(const char *fmt, ...) {
2723 va_list ap; /* pointer into argument list */
2724 va_start(ap, fmt); /* make ap point to first arg after fmt */
2725 if (!disableOutput) {
2729 va_end(ap); /* clean up */
2732 Void hugsPrintf(fmt, va_alist)
2735 va_list ap; /* pointer into argument list */
2736 va_start(ap); /* make ap point to first arg after fmt */
2737 if (!disableOutput) {
2741 va_end(ap); /* clean up */
2747 if (!disableOutput) {
2753 Void hugsFlushStdout() {
2754 if (!disableOutput) {
2761 if (!disableOutput) {
2766 #ifdef HAVE_STDARG_H
2767 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2770 if (!disableOutput) {
2771 vfprintf(fp, fmt, ap);
2777 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2783 if (!disableOutput) {
2784 vfprintf(fp, fmt, ap);
2791 Void hugsPutc(c, fp)
2794 if (!disableOutput) {
2800 /* --------------------------------------------------------------------------
2801 * Send message to each component of system:
2802 * ------------------------------------------------------------------------*/
2804 Void everybody(what) /* send command `what' to each component of*/
2805 Int what; { /* system to respond as appropriate ... */
2807 fprintf ( stderr, "EVERYBODY %d\n", what );
2809 machdep(what); /* The order of calling each component is */
2810 storage(what); /* important for the PREPREL command */
2813 translateControl(what);
2815 staticAnalysis(what);
2816 deriveControl(what);
2823 mark(targetModules);
2827 /*-------------------------------------------------------------------------*/