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/07 16:20:53 $
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 != textPrelPrim)
952 usesT = cons(textPrelude,usesT);
953 adjList = cons(pair(mT,usesT),adjList);
956 /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
957 Modify this so that the adjacency list is a list of pointers
958 back to bits of adjList -- that's what modScc needs.
960 for (t = adjList; nonNull(t); t=tl(t)) {
962 /* for each elem of the adjacency list ... */
963 for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
966 /* find the element of adjList whose fst is a */
967 for (v = adjList; nonNull(v); v=tl(v)) {
969 assert(isText(fst(hd(v))));
970 if (fst(hd(v))==a) break;
972 if (isNull(v)) internal("mgFromList");
973 adj = cons(hd(v),adj);
978 adjList = modScc ( adjList );
979 /* adjList is now [ [(module-text, aux-info-field)] ] */
983 for (t = adjList; nonNull(t); t=tl(t)) {
986 /* scc :: [ (module-text, aux-info-field) ] */
987 for (u = scc; nonNull(u); u=tl(u))
988 hd(u) = mkCon(fst(hd(u)));
991 if (length(scc) > 1) {
994 /* singleton module in scc; does it import itself? */
995 mod = findModule ( textOf(hd(scc)) );
996 assert(nonNull(mod));
998 for (u = module(mod).uses; nonNull(u); u=tl(u))
999 if (textOf(hd(u))==textOf(hd(scc)))
1004 moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
1005 moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
1007 moduleGraph = reverse(moduleGraph);
1011 static List /* of CONID */ getModuleImports ( Cell tree )
1017 for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
1019 switch(whatIs(te)) {
1021 use = zfst(unap(M_IMPORT_Q,te));
1023 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
1026 use = zfst(unap(M_IMPORT_UNQ,te));
1028 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
1038 static void processModule ( Module m )
1054 unqualImports = NIL;
1055 foreignImports = NIL;
1056 foreignExports = NIL;
1063 tree = unap(M_MODULE,module(m).tree);
1064 modNm = zfst3(tree);
1066 if (textOf(modNm) != module(m).text) {
1067 ERRMSG(0) "Module name \"%s\" does not match file name \"%s%s\"",
1068 textToStr(textOf(modNm)),
1069 textToStr(module(m).text),
1070 textToStr(module(m).srcExt)
1074 setExportList(zsnd3(tree));
1075 topEnts = zthd3(tree);
1077 for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
1079 assert(isGenPair(te));
1081 switch(whatIs(te)) {
1083 addQualImport(zfst(te2),zsnd(te2));
1086 addUnqualImport(zfst(te2),zsnd(te2));
1089 tyconDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
1092 classDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
1095 instDefn(intOf(zfst3(te2)),zsnd3(te2),zthd3(te2));
1098 defaultDefn(intOf(zfst(te2)),zsnd(te2));
1101 foreignImport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
1102 zsel45(te2),zsel55(te2));
1105 foreignExport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
1106 zsel45(te2),zsel55(te2));
1108 valDefns = cons(te2,valDefns);
1111 internal("processModule");
1120 static Module parseModuleOrInterface ( ConId mc, Cell modeRequest )
1122 /* Allocate a module-table entry. */
1123 /* Parse the entity and fill in the .tree and .uses entries. */
1126 Bool sAvail; Time sTime; Long sSize;
1127 Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1132 Text mt = textOf(mc);
1133 Module mod = findModule ( mt );
1135 /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
1136 textToStr(mt),mod); */
1137 if (nonNull(mod) && !module(mod).fake)
1138 internal("parseModuleOrInterface");
1140 module(mod).fake = FALSE;
1143 mod = newModule(mt);
1145 /* This call malloc-ates path; we should deallocate it. */
1146 ok = findFilesForModule (
1147 textToStr(module(mod).text),
1150 &sAvail, &sTime, &sSize,
1151 &oiAvail, &oiTime, &oSize, &iSize
1154 if (!ok) goto cant_find;
1155 if (!sAvail && !oiAvail) goto cant_find;
1157 /* Find out whether to use source or object. */
1158 switch (modeRequest) {
1160 if (!sAvail) goto cant_find;
1164 if (!oiAvail) goto cant_find;
1168 if ( sAvail && !oiAvail) { useSource = TRUE; break; }
1169 if (!sAvail && oiAvail) { useSource = FALSE; break; }
1170 useSource = firstTimeIsLater ( sTime, oiTime ) ? TRUE : FALSE;
1173 internal("parseModuleOrInterface");
1176 /* Actually do the parsing. */
1178 module(mod).srcExt = findText(sExt);
1179 setCurrentFile(mod);
1181 strcat(name, textToStr(mt));
1183 module(mod).tree = parseModule(name,sSize);
1184 module(mod).uses = getModuleImports(module(mod).tree);
1185 module(mod).mode = FM_SOURCE;
1186 module(mod).lastStamp = sTime;
1188 module(mod).srcExt = findText(HI_ENDING);
1189 setCurrentFile(mod);
1191 strcat(name, textToStr(mt));
1192 strcat(name, DLL_ENDING);
1193 module(mod).objName = findText(name);
1194 module(mod).objSize = oSize;
1196 strcat(name, textToStr(mt));
1197 strcat(name, ".u_hi");
1198 module(mod).tree = parseInterface(name,iSize);
1199 module(mod).uses = getInterfaceImports(module(mod).tree);
1200 module(mod).mode = FM_OBJECT;
1201 module(mod).lastStamp = oiTime;
1204 if (path) free(path);
1208 if (path) free(path);
1211 "Can't find %s for module \"%s\"",
1212 modeToString(modeRequest), textToStr(mt)
1217 static void tryLoadGroup ( Cell grp )
1221 switch (whatIs(grp)) {
1223 m = findModule(textOf(snd(grp)));
1225 if (module(m).mode == FM_SOURCE) {
1226 processModule ( m );
1227 module(m).tree = NIL;
1229 processInterfaces ( singleton(snd(grp)) );
1230 m = findModule(textOf(snd(grp)));
1232 module(m).tree = NIL;
1236 for (t = snd(grp); nonNull(t); t=tl(t)) {
1237 m = findModule(textOf(hd(t)));
1239 if (module(m).mode == FM_SOURCE) {
1240 ERRMSG(0) "Source module \"%s\" imports itself recursively",
1241 textToStr(textOf(hd(t)))
1245 processInterfaces ( snd(grp) );
1246 for (t = snd(grp); nonNull(t); t=tl(t)) {
1247 m = findModule(textOf(hd(t)));
1249 module(m).tree = NIL;
1253 internal("tryLoadGroup");
1258 static void fallBackToPrelModules ( void )
1261 for (m = MODULE_BASE_ADDR;
1262 m < MODULE_BASE_ADDR+tabModuleSz; m++)
1264 && !varIsMember(module(m).text, prelModules))
1269 /* This function catches exceptions in most of the system.
1270 So it's only ok for procedures called from this one
1271 to do EENDs (ie, write error messages). Others should use
1274 static void achieveTargetModules ( Bool loadingThePrelude )
1277 volatile List modgList;
1279 volatile Module mod;
1284 Bool sAvail; Time sTime; Long sSize;
1285 Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1287 volatile Time oisTime;
1288 volatile Bool out_of_date;
1289 volatile List ood_new;
1291 volatile List modgList_new;
1292 volatile List parsedButNotLoaded;
1293 volatile List toChase;
1294 volatile List trans_cl;
1295 volatile List trans_cl_new;
1300 volatile List badMods;
1302 setBreakAction ( HugsIgnoreBreak );
1304 /* First, examine timestamps to find out which modules are
1305 out of date with respect to the source/interface/object files.
1308 modgList = listFromMG();
1310 for (t = modgList; nonNull(t); t=tl(t)) {
1312 if (varIsMember(textOf(hd(t)),prelModules))
1315 mod = findModule(textOf(hd(t)));
1316 if (isNull(mod)) internal("achieveTargetSet(1)");
1318 /* In standalone mode, only succeeds for source modules. */
1319 ok = findFilesForModule (
1320 textToStr(module(mod).text),
1323 &sAvail, &sTime, &sSize,
1324 &oiAvail, &oiTime, &oSize, &iSize
1327 if (!combined && !sAvail) ok = FALSE;
1329 fallBackToPrelModules();
1331 "Can't find source or object+interface for module \"%s\"",
1332 textToStr(module(mod).text)
1334 if (path) free(path);
1338 if (sAvail && oiAvail) {
1339 oisTime = whicheverIsLater(sTime,oiTime);
1341 else if (sAvail && !oiAvail) {
1344 else if (!sAvail && oiAvail) {
1348 internal("achieveTargetSet(2)");
1351 out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
1353 assert(!varIsMember(textOf(hd(t)),ood));
1354 ood = cons(hd(t),ood);
1357 if (path) { free(path); path = NULL; };
1360 /* Second, form a simplistic transitive closure of the out-of-date
1361 modules: a module is out of date if it imports an out-of-date
1366 for (t = modgList; nonNull(t); t=tl(t)) {
1367 mod = findModule(textOf(hd(t)));
1368 assert(nonNull(mod));
1369 for (us = module(mod).uses; nonNull(us); us=tl(us))
1370 if (varIsMember(textOf(hd(us)),ood))
1373 if (varIsMember(textOf(hd(t)),prelModules))
1374 Printf ( "warning: prelude module \"%s\" is out-of-date\n",
1375 textToStr(textOf(hd(t))) );
1377 if (!varIsMember(textOf(hd(t)),ood_new) &&
1378 !varIsMember(textOf(hd(t)),ood))
1379 ood_new = cons(hd(t),ood_new);
1382 if (isNull(ood_new)) break;
1383 ood = appendOnto(ood_new,ood);
1386 /* Now ood holds the entire set of modules which are out-of-date.
1387 Throw them out of the system, yielding a "reduced system",
1388 in which the remaining modules are in-date.
1390 for (t = ood; nonNull(t); t=tl(t)) {
1391 mod = findModule(textOf(hd(t)));
1392 assert(nonNull(mod));
1396 for (t = modgList; nonNull(t); t=tl(t))
1397 if (!varIsMember(textOf(hd(t)),ood))
1398 modgList_new = cons(hd(t),modgList_new);
1399 modgList = modgList_new;
1401 /* Update the module group list to reflect the reduced system.
1402 We do this so that if the following parsing phases fail, we can
1403 safely fall back to the reduced system.
1405 mgFromList ( modgList );
1407 /* Parse modules/interfaces, collecting parse trees and chasing
1408 imports, starting from the target set.
1410 toChase = dupList(targetModules);
1411 for (t = toChase; nonNull(t); t=tl(t)) {
1412 Cell mode = (!combined)
1414 : ( (loadingThePrelude && combined)
1417 hd(t) = zpair(hd(t), mode);
1420 /* toChase :: [ ((ConId, {FM_SOURCE|FM_OBJECT|FM_EITHER} )) ] */
1422 parsedButNotLoaded = NIL;
1425 while (nonNull(toChase)) {
1426 ConId mc = zfst(hd(toChase));
1427 Cell mode = zsnd(hd(toChase));
1428 toChase = tl(toChase);
1429 if (varIsMember(textOf(mc),modgList)
1430 || varIsMember(textOf(mc),parsedButNotLoaded)) {
1431 /* either exists fully, or is at least parsed */
1432 mod = findModule(textOf(mc));
1433 assert(nonNull(mod));
1434 if (!compatibleNewMode(mode,module(mod).mode)) {
1437 "module %s: %s required, but %s is more recent",
1438 textToStr(textOf(mc)), modeToString(mode),
1439 modeToString(module(mod).mode)
1441 goto parseException;
1445 setBreakAction ( HugsLongjmpOnBreak );
1446 if (setjmp(catch_error)==0) {
1447 /* try this; it may throw an exception */
1448 mod = parseModuleOrInterface ( mc, mode );
1450 /* here's the exception handler, if parsing fails */
1451 /* A parse error (or similar). Clean up and abort. */
1453 setBreakAction ( HugsIgnoreBreak );
1454 mod = findModule(textOf(mc));
1455 if (nonNull(mod)) nukeModule(mod);
1456 for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
1457 mod = findModule(textOf(hd(t)));
1458 assert(nonNull(mod));
1459 if (nonNull(mod)) nukeModule(mod);
1462 /* end of the exception handler */
1464 setBreakAction ( HugsIgnoreBreak );
1466 parsedButNotLoaded = cons(mc, parsedButNotLoaded);
1467 for (t = module(mod).uses; nonNull(t); t=tl(t))
1469 zpair( hd(t), childMode(mode,module(mod).mode) ),
1474 modgList = dupOnto(parsedButNotLoaded, modgList);
1476 /* We successfully parsed all modules reachable from the target
1477 set which were not part of the reduced system. However, there
1478 may be modules in the reduced system which are not reachable from
1479 the target set. We detect these now by building the transitive
1480 closure of the target set, and nuking modules in the reduced
1481 system which are not part of that closure.
1483 trans_cl = dupList(targetModules);
1486 for (t = trans_cl; nonNull(t); t=tl(t)) {
1487 mod = findModule(textOf(hd(t)));
1488 assert(nonNull(mod));
1489 for (u = module(mod).uses; nonNull(u); u=tl(u))
1490 if (!varIsMember(textOf(hd(u)),trans_cl)
1491 && !varIsMember(textOf(hd(u)),trans_cl_new)
1492 && !varIsMember(textOf(hd(u)),prelModules))
1493 trans_cl_new = cons(hd(u),trans_cl_new);
1495 if (isNull(trans_cl_new)) break;
1496 trans_cl = appendOnto(trans_cl_new,trans_cl);
1499 for (t = modgList; nonNull(t); t=tl(t)) {
1500 if (varIsMember(textOf(hd(t)),trans_cl)) {
1501 modgList_new = cons(hd(t),modgList_new);
1503 mod = findModule(textOf(hd(t)));
1504 assert(nonNull(mod));
1508 modgList = modgList_new;
1510 /* Now, the module symbol tables hold exactly the set of
1511 modules reachable from the target set, and modgList holds
1512 their names. Calculate the scc-ified module graph,
1513 since we need that to guide the next stage, that of
1514 Actually Loading the modules.
1516 If no errors occur, moduleGraph will reflect the final graph
1517 loaded. If an error occurs loading a group, we nuke
1518 that group, truncate the moduleGraph just prior to that
1519 group, and exit. That leaves the system having successfully
1520 loaded all groups prior to the one which failed.
1522 mgFromList ( modgList );
1524 for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
1527 if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
1528 parsedButNotLoaded)) continue;
1530 setBreakAction ( HugsLongjmpOnBreak );
1531 if (setjmp(catch_error)==0) {
1532 /* try this; it may throw an exception */
1535 /* here's the exception handler, if static/typecheck etc fails */
1536 /* nuke the entire rest (ie, the unloaded part)
1537 of the module graph */
1538 setBreakAction ( HugsIgnoreBreak );
1539 badMods = listFromSpecifiedMG ( mg );
1540 for (t = badMods; nonNull(t); t=tl(t)) {
1541 mod = findModule(textOf(hd(t)));
1542 if (nonNull(mod)) nukeModule(mod);
1544 /* truncate the module graph just prior to this group. */
1548 if (isNull(mg)) break;
1549 if (hd(mg) == grp) break;
1550 mg2 = cons ( hd(mg), mg2 );
1553 moduleGraph = reverse(mg2);
1555 /* end of the exception handler */
1557 setBreakAction ( HugsIgnoreBreak );
1560 /* Err .. I think that's it. If we get here, we've successfully
1561 achieved the target set. Phew!
1563 setBreakAction ( HugsIgnoreBreak );
1567 static Bool loadThePrelude ( void )
1572 moduleGraph = prelModules = NIL;
1575 conPrelude = mkCon(findText("Prelude"));
1576 conPrelHugs = mkCon(findText("PrelHugs"));
1577 targetModules = doubleton(conPrelude,conPrelHugs);
1578 achieveTargetModules(TRUE);
1579 ok = elemMG(conPrelude) && elemMG(conPrelHugs);
1581 conPrelude = mkCon(findText("Prelude"));
1582 targetModules = singleton(conPrelude);
1583 achieveTargetModules(TRUE);
1584 ok = elemMG(conPrelude);
1587 if (ok) prelModules = listFromMG();
1592 static void refreshActions ( ConId nextCurrMod, Bool cleanAfter )
1595 ConId tryFor = mkCon(module(currentModule).text);
1596 achieveTargetModules(FALSE);
1597 if (nonNull(nextCurrMod))
1598 tryFor = nextCurrMod;
1599 if (!elemMG(tryFor))
1600 tryFor = selectLatestMG();
1601 /* combined mode kludge, to get Prelude rather than PrelHugs */
1602 if (combined && textOf(tryFor)==findText("PrelHugs"))
1603 tryFor = mkCon(findText("Prelude"));
1606 /* delete any targetModules which didn't actually get loaded */
1608 targetModules = NIL;
1609 for (; nonNull(t); t=tl(t))
1611 targetModules = cons(hd(t),targetModules);
1614 setCurrModule ( findModule(textOf(tryFor)) );
1615 Printf("Hugs session for:\n");
1620 static void addActions ( List extraModules /* :: [CONID] */ )
1623 for (t = extraModules; nonNull(t); t=tl(t)) {
1624 ConId extra = hd(t);
1625 if (!varIsMember(textOf(extra),targetModules))
1626 targetModules = cons(extra,targetModules);
1628 refreshActions ( isNull(extraModules)
1630 : hd(reverse(extraModules)),
1636 static void loadActions ( List loadModules /* :: [CONID] */ )
1639 targetModules = dupList ( prelModules );
1641 for (t = loadModules; nonNull(t); t=tl(t)) {
1643 if (!varIsMember(textOf(load),targetModules))
1644 targetModules = cons(load,targetModules);
1646 refreshActions ( isNull(loadModules)
1648 : hd(reverse(loadModules)),
1654 /* --------------------------------------------------------------------------
1655 * Access to external editor:
1656 * ------------------------------------------------------------------------*/
1658 /* ToDo: All this editor stuff needs fixing. */
1660 static Void local editor() { /* interpreter-editor interface */
1662 String newFile = readFilename();
1664 setLastEdit(newFile,0);
1665 if (readFilename()) {
1666 ERRMSG(0) "Multiple filenames not permitted"
1674 static Void local find() { /* edit file containing definition */
1677 String nm = readFilename(); /* of specified name */
1679 ERRMSG(0) "No name specified"
1682 else if (readFilename()) {
1683 ERRMSG(0) "Multiple names not permitted"
1689 setCurrModule(findEvalModule());
1691 if (nonNull(c=findTycon(t=findText(nm)))) {
1692 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1693 readScripts(N_PRELUDE_SCRIPTS);
1695 } else if (nonNull(c=findName(t))) {
1696 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1697 readScripts(N_PRELUDE_SCRIPTS);
1700 ERRMSG(0) "No current definition for name \"%s\"", nm
1707 static Void local runEditor() { /* run editor on script lastEdit */
1709 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1710 readScripts(N_PRELUDE_SCRIPTS);
1714 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1720 lastEdit = strCopy(fname);
1725 /* --------------------------------------------------------------------------
1726 * Read and evaluate an expression:
1727 * ------------------------------------------------------------------------*/
1729 static Void setModule ( void ) {
1730 /*set module in which to evaluate expressions*/
1733 String s = readFilename();
1735 mc = selectLatestMG();
1736 if (combined && textOf(mc)==findText("PrelHugs"))
1737 mc = mkCon(findText("Prelude"));
1738 m = findModule(textOf(mc));
1741 m = findModule(findText(s));
1743 ERRMSG(0) "Cannot find module \"%s\"", s
1751 static Module allocEvalModule ( void )
1753 Module evalMod = newModule( findText("_Eval_Module_") );
1754 module(evalMod).names = module(currentModule).names;
1755 module(evalMod).tycons = module(currentModule).tycons;
1756 module(evalMod).classes = module(currentModule).classes;
1757 module(evalMod).qualImports
1758 = singleton(pair(mkCon(textPrelude),modulePrelude));
1762 static Void local evaluator() { /* evaluate expr and print value */
1765 volatile Kinds ks = NIL;
1766 volatile Module evalMod = allocEvalModule();
1767 volatile Module currMod = currentModule;
1768 setCurrModule(evalMod);
1771 defaultDefns = combined ? stdDefaults : evalDefaults;
1773 setBreakAction ( HugsLongjmpOnBreak );
1774 if (setjmp(catch_error)==0) {
1778 type = typeCheckExp(TRUE);
1780 /* if an exception happens, we arrive here */
1781 setBreakAction ( HugsIgnoreBreak );
1782 goto cleanup_and_return;
1785 setBreakAction ( HugsIgnoreBreak );
1786 if (isPolyType(type)) {
1787 ks = polySigOf(type);
1788 bd = monotypeOf(type);
1793 if (whatIs(bd)==QUAL) {
1794 ERRMSG(0) "Unresolved overloading" ETHEN
1795 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1796 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1799 goto cleanup_and_return;
1803 if (isProgType(ks,bd)) {
1804 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1808 Cell d = provePred(ks,NIL,ap(classShow,bd));
1810 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1811 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1812 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1815 goto cleanup_and_return;
1817 inputExpr = ap2(nameShow, d,inputExpr);
1818 inputExpr = ap (namePutStr, inputExpr);
1819 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1821 evalExp(); printf("\n");
1824 printType(stdout,type);
1831 printf ( "result type is " );
1832 printType ( stdout, type );
1840 setBreakAction ( HugsIgnoreBreak );
1841 nukeModule(evalMod);
1842 setCurrModule(currMod);
1843 setCurrentFile(currMod);
1848 /* --------------------------------------------------------------------------
1849 * Print type of input expression:
1850 * ------------------------------------------------------------------------*/
1852 static Void showtype ( void ) { /* print type of expression (if any)*/
1855 volatile Module evalMod = allocEvalModule();
1856 volatile Module currMod = currentModule;
1857 setCurrModule(evalMod);
1859 if (setjmp(catch_error)==0) {
1863 defaultDefns = evalDefaults;
1864 type = typeCheckExp(FALSE);
1865 printExp(stdout,inputExpr);
1867 printType(stdout,type);
1870 /* if an exception happens, we arrive here */
1873 nukeModule(evalMod);
1874 setCurrModule(currMod);
1878 static Void local browseit(mod,t,all)
1885 Printf("module %s where\n",textToStr(module(mod).text));
1886 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1888 /* only look at things defined in this module,
1889 unless `all' flag is set */
1890 if (all || name(nm).mod == mod) {
1891 /* unwanted artifacts, like lambda lifted values,
1892 are in the list of names, but have no types */
1893 if (nonNull(name(nm).type)) {
1894 printExp(stdout,nm);
1896 printType(stdout,name(nm).type);
1898 Printf(" -- data constructor");
1899 } else if (isMfun(nm)) {
1900 Printf(" -- class member");
1901 } else if (isSfun(nm)) {
1902 Printf(" -- selector function");
1910 Printf("Unknown module %s\n",t);
1915 static Void local browse() { /* browse modules */
1916 Int count = 0; /* or give menu of commands */
1920 for (; (s=readFilename())!=0; count++)
1921 if (strcmp(s,"all") == 0) {
1925 browseit(findModule(findText(s)),s,all);
1927 browseit(currentModule,NULL,all);
1931 #if EXPLAIN_INSTANCE_RESOLUTION
1932 static Void local xplain() { /* print type of expression (if any)*/
1934 Bool sir = showInstRes;
1936 setCurrModule(findEvalModule());
1937 startNewScript(0); /* Enables recovery of storage */
1938 /* allocated during evaluation */
1942 d = provePred(NIL,NIL,hd(inputContext));
1944 fprintf(stdout, "not Sat\n");
1946 fprintf(stdout, "Sat\n");
1952 /* --------------------------------------------------------------------------
1953 * Enhanced help system: print current list of scripts or give information
1955 * ------------------------------------------------------------------------*/
1957 static String local objToStr(m,c)
1960 #if 1 || DISPLAY_QUANTIFIERS
1961 static char newVar[60];
1962 switch (whatIs(c)) {
1963 case NAME : if (m == name(c).mod) {
1964 sprintf(newVar,"%s", textToStr(name(c).text));
1966 sprintf(newVar,"%s.%s",
1967 textToStr(module(name(c).mod).text),
1968 textToStr(name(c).text));
1972 case TYCON : if (m == tycon(c).mod) {
1973 sprintf(newVar,"%s", textToStr(tycon(c).text));
1975 sprintf(newVar,"%s.%s",
1976 textToStr(module(tycon(c).mod).text),
1977 textToStr(tycon(c).text));
1981 case CLASS : if (m == cclass(c).mod) {
1982 sprintf(newVar,"%s", textToStr(cclass(c).text));
1984 sprintf(newVar,"%s.%s",
1985 textToStr(module(cclass(c).mod).text),
1986 textToStr(cclass(c).text));
1990 default : internal("objToStr");
1994 static char newVar[33];
1995 switch (whatIs(c)) {
1996 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1999 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
2002 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
2005 default : internal("objToStr");
2013 static Void dumpStg ( void )
2019 setCurrModule(findEvalModule());
2024 /* request to locate a symbol by name */
2025 if (s && (*s == '?')) {
2026 Text t = findText(s+1);
2027 locateSymbolByName(t);
2031 /* request to dump a bit of the heap */
2032 if (s && (*s == '-' || isdigit(*s))) {
2039 /* request to dump a symbol table entry */
2041 || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
2042 || !isdigit(s[1])) {
2043 fprintf(stderr, ":d -- bad request `%s'\n", s );
2048 case 't': dumpTycon(i); break;
2049 case 'n': dumpName(i); break;
2050 case 'c': dumpClass(i); break;
2051 case 'i': dumpInst(i); break;
2052 default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
2058 static Void local dumpStg( void ) { /* print STG stuff */
2063 Cell v; /* really StgVar */
2064 setCurrModule(findEvalModule());
2066 for (; (s=readFilename())!=0;) {
2069 /* find the name while ignoring module scopes */
2070 for (i=NAMEMIN; i<nameHw; i++)
2071 if (name(i).text == t) n = i;
2073 /* perhaps it's an "idNNNNNN" thing? */
2076 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2079 while (isdigit(s[i])) {
2080 v = v * 10 + (s[i]-'0');
2084 n = nameFromStgVar(v);
2087 if (isNull(n) && whatIs(v)==STGVAR) {
2088 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2089 printStg(stderr, v );
2092 Printf ( "Unknown reference `%s'\n", s );
2095 Printf ( "Not a Name: `%s'\n", s );
2097 if (isNull(name(n).stgVar)) {
2098 Printf ( "Doesn't have a STG tree: %s\n", s );
2100 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2101 printStg(stderr, name(n).stgVar);
2107 static Void local info() { /* describe objects */
2108 Int count = 0; /* or give menu of commands */
2111 for (; (s=readFilename())!=0; count++) {
2112 describe(findText(s));
2115 /* whatScripts(); */
2120 static Void local describe(t) /* describe an object */
2122 Tycon tc = findTycon(t);
2123 Class cl = findClass(t);
2124 Name nm = findName(t);
2126 if (nonNull(tc)) { /* as a type constructor */
2130 for (i=0; i<tycon(tc).arity; ++i) {
2131 t = ap(t,mkOffset(i));
2133 Printf("-- type constructor");
2135 Printf(" with kind ");
2136 printKind(stdout,tycon(tc).kind);
2139 switch (tycon(tc).what) {
2140 case SYNONYM : Printf("type ");
2141 printType(stdout,t);
2143 printType(stdout,tycon(tc).defn);
2147 case DATATYPE : { List cs = tycon(tc).defn;
2148 if (tycon(tc).what==DATATYPE) {
2153 printType(stdout,t);
2155 mapProc(printSyntax,cs);
2157 Printf("\n-- constructors:");
2159 for (; hasCfun(cs); cs=tl(cs)) {
2161 printExp(stdout,hd(cs));
2163 printType(stdout,name(hd(cs)).type);
2166 Printf("\n-- selectors:");
2168 for (; nonNull(cs); cs=tl(cs)) {
2170 printExp(stdout,hd(cs));
2172 printType(stdout,name(hd(cs)).type);
2177 case RESTRICTSYN : Printf("type ");
2178 printType(stdout,t);
2179 Printf(" = <restricted>");
2183 if (nonNull(in=findFirstInst(tc))) {
2184 Printf("\n-- instances:\n");
2187 in = findNextInst(tc,in);
2188 } while (nonNull(in));
2193 if (nonNull(cl)) { /* as a class */
2194 List ins = cclass(cl).instances;
2195 Kinds ks = cclass(cl).kinds;
2196 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2197 Printf("-- type class");
2199 Printf("-- constructor class");
2201 Printf(" with arity ");
2202 printKinds(stdout,ks);
2206 mapProc(printSyntax,cclass(cl).members);
2208 if (nonNull(cclass(cl).supers)) {
2209 printContext(stdout,cclass(cl).supers);
2212 printPred(stdout,cclass(cl).head);
2214 if (nonNull(cclass(cl).fds)) {
2215 List fds = cclass(cl).fds;
2217 for (; nonNull(fds); fds=tl(fds)) {
2219 printFD(stdout,hd(fds));
2224 if (nonNull(cclass(cl).members)) {
2225 List ms = cclass(cl).members;
2228 Type t = name(hd(ms)).type;
2229 if (isPolyType(t)) {
2233 printExp(stdout,hd(ms));
2235 if (isNull(tl(fst(snd(t))))) {
2238 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2240 printType(stdout,t);
2242 } while (nonNull(ms));
2246 Printf("\n-- instances:\n");
2250 } while (nonNull(ins));
2255 if (nonNull(nm)) { /* as a function/name */
2257 printExp(stdout,nm);
2259 if (nonNull(name(nm).type)) {
2260 printType(stdout,name(nm).type);
2262 Printf("<unknown type>");
2265 Printf(" -- data constructor");
2266 } else if (isMfun(nm)) {
2267 Printf(" -- class member");
2268 } else if (isSfun(nm)) {
2269 Printf(" -- selector function");
2275 if (isNull(tc) && isNull(cl) && isNull(nm)) {
2276 Printf("Unknown reference `%s'\n",textToStr(t));
2280 static Void local printSyntax(nm)
2282 Syntax sy = syntaxOf(nm);
2283 Text t = name(nm).text;
2284 String s = textToStr(t);
2285 if (sy != defaultSyntax(t)) {
2287 switch (assocOf(sy)) {
2288 case LEFT_ASS : Putchar('l'); break;
2289 case RIGHT_ASS : Putchar('r'); break;
2290 case NON_ASS : break;
2292 Printf(" %i ",precOf(sy));
2293 if (isascii((int)(*s)) && isalpha((int)(*s))) {
2302 static Void local showInst(in) /* Display instance decl header */
2304 Printf("instance ");
2305 if (nonNull(inst(in).specifics)) {
2306 printContext(stdout,inst(in).specifics);
2309 printPred(stdout,inst(in).head);
2313 /* --------------------------------------------------------------------------
2314 * List all names currently in scope:
2315 * ------------------------------------------------------------------------*/
2317 static Void local listNames() { /* list names matching optional pat*/
2318 String pat = readFilename();
2320 Int width = getTerminalWidth() - 1;
2323 Module mod = currentModule;
2325 if (pat) { /* First gather names to list */
2327 names = addNamesMatching(pat,names);
2328 } while ((pat=readFilename())!=0);
2330 names = addNamesMatching((String)0,names);
2332 if (isNull(names)) { /* Then print them out */
2333 ERRMSG(0) "No names selected"
2337 for (termPos=0; nonNull(names); names=tl(names)) {
2338 String s = objToStr(mod,hd(names));
2340 if (termPos+1+l>width) {
2343 } else if (termPos>0) {
2351 Printf("\n(%d names listed)\n", count);
2354 /* --------------------------------------------------------------------------
2355 * print a prompt and read a line of input:
2356 * ------------------------------------------------------------------------*/
2358 static Void local promptForInput(moduleName)
2359 String moduleName; {
2360 char promptBuffer[1000];
2362 /* This is portable but could overflow buffer */
2363 sprintf(promptBuffer,prompt,moduleName);
2365 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2366 * promptBuffer instead.
2368 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2369 /* Reset prompt to a safe default to avoid an infinite loop */
2371 prompt = strCopy("? ");
2372 internal("Combined prompt and evaluation module name too long");
2376 stringInput("main\0"); else
2377 consoleInput(promptBuffer);
2380 /* --------------------------------------------------------------------------
2381 * main read-eval-print loop, with error trapping:
2382 * ------------------------------------------------------------------------*/
2384 static Void local interpreter(argc,argv)/* main interpreter loop */
2388 List modConIds; /* :: [CONID] */
2392 setBreakAction ( HugsIgnoreBreak );
2393 modConIds = initialize(argc,argv); /* the initial modules to load */
2394 setBreakAction ( HugsIgnoreBreak );
2395 prelOK = loadThePrelude();
2396 if (combined) everybody(POSTPREL);
2400 fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2402 fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2406 loadActions(modConIds);
2409 for (; nonNull(modConIds); modConIds=tl(modConIds))
2410 if (!elemMG(hd(modConIds))) {
2412 "hugs +Q: compilation failed -- can't run `main'\n" );
2419 /* initialize calls startupHaskell, which trashes our signal handlers */
2420 setBreakAction ( HugsIgnoreBreak );
2425 everybody(RESET); /* reset to sensible initial state */
2427 promptForInput(textToStr(module(currentModule).text));
2429 cmd = readCommand(cmds, (Char)':', (Char)'!');
2431 case EDIT : editor();
2435 case LOAD : modConIds = NIL;
2436 while ((s=readFilename())!=0)
2437 modConIds = cons(mkCon(findText(s)),modConIds);
2438 loadActions(modConIds);
2441 case ALSO : modConIds = NIL;
2442 while ((s=readFilename())!=0)
2443 modConIds = cons(mkCon(findText(s)),modConIds);
2444 addActions(modConIds);
2447 case RELOAD : refreshActions(NIL,FALSE);
2452 case EVAL : evaluator();
2454 case TYPEOF : showtype();
2456 case BROWSE : browse();
2458 #if EXPLAIN_INSTANCE_RESOLUTION
2459 case XPLAIN : xplain();
2462 case NAMES : listNames();
2466 case BADCMD : guidance();
2471 #ifdef CRUDE_PROFILING
2475 case SYSTEM : if (shellEsc(readLine()))
2476 Printf("Warning: Shell escape terminated abnormally\n");
2478 case CHGDIR : changeDir();
2482 case PNTVER: Printf("-- Hugs Version %s\n",
2485 case DUMP : dumpStg();
2488 case COLLECT: consGC = FALSE;
2491 Printf("Garbage collection recovered %d cells\n",
2497 if (autoMain) break;
2501 /* --------------------------------------------------------------------------
2502 * Display progress towards goal:
2503 * ------------------------------------------------------------------------*/
2505 static Target currTarget;
2506 static Bool aiming = FALSE;
2509 static Int charCount;
2511 Void setGoal(what, t) /* Set goal for what to be t */
2516 #if EXPLAIN_INSTANCE_RESOLUTION
2520 currTarget = (t?t:1);
2523 currPos = strlen(what);
2524 maxPos = getTerminalWidth() - 1;
2528 for (charCount=0; *what; charCount++)
2533 Void soFar(t) /* Indicate progress towards goal */
2534 Target t; { /* has now reached t */
2537 #if EXPLAIN_INSTANCE_RESOLUTION
2542 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2547 if (newPos>currPos) {
2550 while (newPos>++currPos);
2557 Void done() { /* Goal has now been achieved */
2560 #if EXPLAIN_INSTANCE_RESOLUTION
2565 while (maxPos>currPos++)
2570 for (; charCount>0; charCount--) {
2579 static Void local failed() { /* Goal cannot be reached due to */
2580 if (aiming) { /* errors */
2587 /* --------------------------------------------------------------------------
2589 * ------------------------------------------------------------------------*/
2591 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
2592 if (printing) { /* after successful termination or */
2593 printing = FALSE; /* runtime error (e.g. interrupt) */
2596 #define plural(v) v, (v==1?"":"s")
2597 Printf("%lu cell%s",plural(numCells));
2599 Printf(", %u garbage collection%s",plural(numGcs));
2608 Cell errAssert(l) /* message to use when raising asserts, etc */
2612 str = mkStr(findText(currentFile));
2614 str = mkStr(findText(""));
2616 return (ap2(nameTangleMessage,str,mkInt(l)));
2619 Void errHead(l) /* print start of error message */
2621 failed(); /* failed to reach target ... */
2623 FPrintf(errorStream,"ERROR");
2626 FPrintf(errorStream," \"%s\"", currentFile);
2627 setLastEdit(currentFile,l);
2628 if (l) FPrintf(errorStream," (line %d)",l);
2631 FPrintf(errorStream,": ");
2632 FFlush(errorStream);
2635 Void errFail() { /* terminate error message and */
2636 Putc('\n',errorStream); /* produce exception to return to */
2637 FFlush(errorStream); /* main command loop */
2638 longjmp(catch_error,1);
2641 Void errFail_no_longjmp() { /* terminate error message but */
2642 Putc('\n',errorStream); /* don't produce an exception */
2643 FFlush(errorStream);
2646 Void errAbort() { /* altern. form of error handling */
2647 failed(); /* used when suitable error message*/
2648 stopAnyPrinting(); /* has already been printed */
2652 Void internal(msg) /* handle internal error */
2656 Printf("INTERNAL ERROR: %s\n",msg);
2659 longjmp(catch_error,1);
2662 Void fatal(msg) /* handle fatal error */
2665 Printf("\nFATAL ERROR: %s\n",msg);
2671 /* --------------------------------------------------------------------------
2672 * Read value from environment variable or registry:
2673 * ------------------------------------------------------------------------*/
2675 String fromEnv(var,def) /* return value of: */
2676 String var; /* environment variable named by var */
2677 String def; { /* or: default value given by def */
2678 String s = getenv(var);
2679 return (s ? s : def);
2682 /* --------------------------------------------------------------------------
2683 * String manipulation routines:
2684 * ------------------------------------------------------------------------*/
2686 static String local strCopy(s) /* make malloced copy of a string */
2690 if ((t=(char *)malloc(strlen(s)+1))==0) {
2691 ERRMSG(0) "String storage space exhausted"
2694 for (r=t; (*r++ = *s++)!=0; ) {
2702 /* --------------------------------------------------------------------------
2704 * We can redirect compiler output (prompts, error messages, etc) by
2705 * tweaking these functions.
2706 * ------------------------------------------------------------------------*/
2708 #ifdef HAVE_STDARG_H
2711 #include <varargs.h>
2714 Void hugsEnableOutput(f)
2719 #ifdef HAVE_STDARG_H
2720 Void hugsPrintf(const char *fmt, ...) {
2721 va_list ap; /* pointer into argument list */
2722 va_start(ap, fmt); /* make ap point to first arg after fmt */
2723 if (!disableOutput) {
2727 va_end(ap); /* clean up */
2730 Void hugsPrintf(fmt, va_alist)
2733 va_list ap; /* pointer into argument list */
2734 va_start(ap); /* make ap point to first arg after fmt */
2735 if (!disableOutput) {
2739 va_end(ap); /* clean up */
2745 if (!disableOutput) {
2751 Void hugsFlushStdout() {
2752 if (!disableOutput) {
2759 if (!disableOutput) {
2764 #ifdef HAVE_STDARG_H
2765 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2768 if (!disableOutput) {
2769 vfprintf(fp, fmt, ap);
2775 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2781 if (!disableOutput) {
2782 vfprintf(fp, fmt, ap);
2789 Void hugsPutc(c, fp)
2792 if (!disableOutput) {
2798 /* --------------------------------------------------------------------------
2799 * Send message to each component of system:
2800 * ------------------------------------------------------------------------*/
2802 Void everybody(what) /* send command `what' to each component of*/
2803 Int what; { /* system to respond as appropriate ... */
2805 fprintf ( stderr, "EVERYBODY %d\n", what );
2807 machdep(what); /* The order of calling each component is */
2808 storage(what); /* important for the PREPREL command */
2811 translateControl(what);
2813 staticAnalysis(what);
2814 deriveControl(what);
2821 mark(targetModules);
2825 /*-------------------------------------------------------------------------*/