2 /* --------------------------------------------------------------------------
5 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
6 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
7 * Technology, 1994-1999, All rights reserved. It is distributed as
8 * free software under the license in the file "License", which is
9 * included in the distribution.
11 * $RCSfile: hugs.c,v $
13 * $Date: 2000/03/24 14:32:03 $
14 * ------------------------------------------------------------------------*/
20 #include "hugsbasictypes.h"
29 #include "Assembler.h" /* DEBUG_LoadSymbols */
31 Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
33 #if EXPLAIN_INSTANCE_RESOLUTION
34 Bool showInstRes = FALSE;
37 Bool multiInstRes = FALSE;
40 /* --------------------------------------------------------------------------
41 * Local function prototypes:
42 * ------------------------------------------------------------------------*/
44 static List local initialize ( Int,String [] );
45 static Void local promptForInput ( String );
46 static Void local interpreter ( Int,String [] );
47 static Void local menu ( Void );
48 static Void local guidance ( Void );
49 static Void local forHelp ( Void );
50 static Void local set ( Void );
51 static Void local changeDir ( Void );
52 static Void local load ( Void );
53 static Void local project ( Void );
54 static Void local editor ( Void );
55 static Void local find ( Void );
56 static Bool local startEdit ( Int,String );
57 static Void local runEditor ( Void );
58 static Void local setModule ( Void );
59 static Void local evaluator ( Void );
60 static Void local stopAnyPrinting ( Void );
61 static Void local showtype ( Void );
62 static String local objToStr ( Module, Cell );
63 static Void local info ( Void );
64 static Void local printSyntax ( Name );
65 static Void local showInst ( Inst );
66 static Void local describe ( Text );
67 static Void local listNames ( Void );
69 static Void local toggleSet ( Char,Bool );
70 static Void local togglesIn ( Bool );
71 static Void local optionInfo ( Void );
73 static String local optionsToStr ( Void );
75 static Void local readOptions ( String );
76 static Bool local processOption ( String );
77 static Void local setHeapSize ( String );
78 static Int local argToInt ( String );
80 static Void local setLastEdit ( String,Int );
81 static Void local failed ( Void );
82 static String local strCopy ( String );
83 static Void local browseit ( Module,String,Bool );
84 static Void local browse ( Void );
86 /* --------------------------------------------------------------------------
87 * Machine dependent code for Hugs interpreter:
88 * ------------------------------------------------------------------------*/
92 /* --------------------------------------------------------------------------
94 * ------------------------------------------------------------------------*/
96 static Bool printing = FALSE; /* TRUE => currently printing value*/
97 static Bool showStats = FALSE; /* TRUE => print stats after eval */
98 static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
99 static Bool addType = FALSE; /* TRUE => print type with value */
100 static Bool useDots = RISCOS; /* TRUE => use dots in progress */
101 static Bool quiet = FALSE; /* TRUE => don't show progress */
102 static Bool lastWasObject = FALSE;
104 Bool flagAssert = FALSE; /* TRUE => assert False <e> causes
105 an assertion failure */
106 Bool preludeLoaded = FALSE;
107 Bool debugSC = FALSE;
108 Bool combined = FALSE;
110 char* currentFile; /* Name of current file, or NULL */
111 static char currentFileName[1000]; /* name is stored here if it exists*/
115 static Text evalModule = 0; /* Name of module we eval exprs in */
116 static String currProject = 0; /* Name of current project file */
117 static Bool projectLoaded = FALSE; /* TRUE => project file loaded */
119 static Bool autoMain = FALSE;
120 static String lastEdit = 0; /* Name of script to edit (if any) */
121 static Int lastEdLine = 0; /* Editor line number (if possible)*/
122 static String prompt = 0; /* Prompt string */
123 static Int hpSize = DEFAULTHEAP; /* Desired heap size */
124 String hugsEdit = 0; /* String for editor command */
125 String hugsPath = 0; /* String for file search path */
127 List ifaces_outstanding = NIL;
130 /* --------------------------------------------------------------------------
132 * ------------------------------------------------------------------------*/
134 #ifndef NO_MAIN /* we omit main when building the "Hugs server" */
136 Main main ( Int, String [] ); /* now every func has a prototype */
141 #ifdef HAVE_CONSOLE_H /* Macintosh port */
143 _fcreator = 'R*ch'; /* // 'KAHL'; //'*TEX'; //'ttxt'; */
145 console_options.top = 50;
146 console_options.left = 20;
148 console_options.nrows = 32;
149 console_options.ncols = 80;
151 console_options.pause_atexit = 1;
152 console_options.title = "\pHugs";
154 console_options.procID = 5;
155 argc = ccommand(&argv);
158 CStackBase = &argc; /* Save stack base for use in gc */
162 checkBytecodeCount(); /* check for too many bytecodes */
166 /* If first arg is +Q or -Q, be entirely silent, and automatically run
167 main after loading scripts. Useful for running the nofib suite. */
168 if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
170 if (strcmp(argv[1],"-Q") == 0) {
175 Printf("__ __ __ __ ____ ___ _________________________________________\n");
176 Printf("|| || || || || || ||__ STGHugs: Based on the Haskell 98 standard\n");
177 Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n");
178 Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
179 Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
180 Printf("|| || Version: %s _________________________________________\n\n",HUGS_VERSION);
182 /* Get the absolute path to the directory containing the hugs
183 executable, so that we know where the Prelude and nHandle.so/.dll are.
184 We do this by reading env var STGHUGSDIR. This needs to succeed, so
185 setInstallDir won't return unless it succeeds.
187 setInstallDir ( argv[0] );
190 Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
193 interpreter(argc,argv);
194 Printf("[Leaving Hugs]\n");
205 /* --------------------------------------------------------------------------
206 * Initialization, interpret command line args and read prelude:
207 * ------------------------------------------------------------------------*/
209 static List /*CONID*/ initialize(argc,argv) /* Interpreter initialization */
214 char argv_0_orig[1000];
217 setLastEdit((String)0,0);
224 hugsEdit = strCopy(fromEnv("EDITOR",NULL));
226 hugsPath = strCopy(HUGSPATH);
227 readOptions("-p\"%s> \" -r$$");
229 projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
230 "HUGSPATH", PATHSEP, ""));
231 readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
232 readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
233 #endif /* USE_REGISTRY */
234 readOptions(fromEnv("STGHUGSFLAGS",""));
236 strncpy(argv_0_orig,argv[0],1000); /* startupHaskell mangles argv[0] */
237 startupHaskell (argc,argv);
243 char exe_name[N_INSTALLDIR + 6];
244 strcpy(exe_name, installDir);
245 strcat(exe_name, "hugs");
246 DEBUG_LoadSymbols(exe_name);
250 /* Find out early on if we're in combined mode or not.
251 everybody(PREPREL) needs to know this.
253 for (i=1; i < argc; ++i) {
254 if (strcmp(argv[i], "--")==0) break;
255 if (strcmp(argv[i], "-c")==0) combined = FALSE;
256 if (strcmp(argv[i], "+c")==0) combined = TRUE;
260 initialModules = NIL;
262 for (i=1; i < argc; ++i) { /* process command line arguments */
263 if (strcmp(argv[i], "--")==0) break;
264 if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
265 && !processOption(argv[i])) {
267 = cons ( mkCon(findText(argv[i])), initialModules );
272 Printf("Haskell 98 mode: Restart with command line option -98"
273 " to enable extensions\n");
275 Printf("Hugs mode: Restart with command line option +98 for"
276 " Haskell 98 mode\n");
280 Printf("Combined mode: Restart with command line -c for"
281 " standalone mode\n\n" );
283 Printf("Standalone mode: Restart with command line +c for"
284 " combined mode\n\n" );
287 return initialModules;
290 /* --------------------------------------------------------------------------
291 * Command line options:
292 * ------------------------------------------------------------------------*/
294 struct options { /* command line option toggles */
295 char c; /* table defined in main app. */
300 extern struct options toggle[];
302 static Void local toggleSet(c,state) /* Set command line toggle */
306 for (i=0; toggle[i].c; ++i)
307 if (toggle[i].c == c) {
308 *toggle[i].flag = state;
311 ERRMSG(0) "Unknown toggle `%c'", c
315 static Void local togglesIn(state) /* Print current list of toggles in*/
316 Bool state; { /* given state */
319 for (i=0; toggle[i].c; ++i)
320 if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
322 Putchar((char)(state ? '+' : '-'));
323 Putchar(toggle[i].c);
330 static Void local optionInfo() { /* Print information about command */
331 static String fmts = "%-5s%s\n"; /* line settings */
332 static String fmtc = "%-5c%s\n";
335 Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
336 for (i=0; toggle[i].c; ++i) {
337 if (!haskell98 || toggle[i].h98) {
338 Printf(fmtc,toggle[i].c,toggle[i].description);
342 Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
343 Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
344 Printf(fmts,"pstr","Set prompt string to str");
345 Printf(fmts,"rstr","Set repeat last expression string to str");
346 Printf(fmts,"Pstr","Set search path for modules to str");
347 Printf(fmts,"Estr","Use editor setting given by str");
348 Printf(fmts,"cnum","Set constraint cutoff limit");
349 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
350 Printf(fmts,"Fstr","Set preprocessor filter to str");
353 Printf("\nCurrent settings: ");
356 Printf("-h%d",heapSize);
360 printString(repeatStr);
361 Printf(" -c%d",cutoff);
362 Printf("\nSearch path : -P");
363 printString(hugsPath);
366 if (projectPath!=NULL) {
367 Printf("\nProject Path : %s",projectPath);
370 Printf("\nEditor setting : -E");
371 printString(hugsEdit);
372 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
373 Printf("\nPreprocessor : -F");
374 printString(preprocessor);
376 Printf("\nCompatibility : %s", haskell98 ? "Haskell 98 (+98)"
377 : "Hugs Extensions (-98)");
389 #define PUTInt(optc,i) \
390 sprintf(next,"-%c%d",optc,i); \
393 #define PUTStr(c,s) \
394 next=PUTStr_aux(next,c,s)
396 static String local PUTStr_aux ( String,Char, String));
398 static String local PUTStr_aux(next,c,s)
404 sprintf(next,"-%c\"",c);
407 PUTS(unlexChar(*t,'"'));
415 static String local optionsToStr() { /* convert options to string */
416 static char buffer[2000];
417 String next = buffer;
420 for (i=0; toggle[i].c; ++i) {
421 PUTC(*toggle[i].flag ? '+' : '-');
425 PUTS(haskell98 ? "+98 " : "-98 ");
426 PUTInt('h',hpSize); PUTC(' ');
428 PUTStr('r',repeatStr);
429 PUTStr('P',hugsPath);
430 PUTStr('E',hugsEdit);
431 PUTInt('c',cutoff); PUTC(' ');
432 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
433 PUTStr('F',preprocessor);
438 #endif /* USE_REGISTRY */
445 static Void local readOptions(options) /* read options from string */
449 stringInput(options);
450 while ((s=readFilename())!=0) {
451 if (*s && !processOption(s)) {
452 ERRMSG(0) "Option string must begin with `+' or `-'"
459 static Bool local processOption(s) /* process string s for options, */
460 String s; { /* return FALSE if none found. */
472 case 'Q' : break; /* already handled */
474 case 'p' : if (s[1]) {
475 if (prompt) free(prompt);
476 prompt = strCopy(s+1);
480 case 'r' : if (s[1]) {
481 if (repeatStr) free(repeatStr);
482 repeatStr = strCopy(s+1);
487 String p = substPath(s+1,hugsPath ? hugsPath : "");
488 if (hugsPath) free(hugsPath);
493 case 'E' : if (hugsEdit) free(hugsEdit);
494 hugsEdit = strCopy(s+1);
497 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
498 case 'F' : if (preprocessor) free(preprocessor);
499 preprocessor = strCopy(s+1);
503 case 'h' : setHeapSize(s+1);
506 case 'c' : /* don't do anything, since pre-scan of args
507 will have got it already */
510 case 'D' : /* hack */
512 extern void setRtsFlags( int x );
513 setRtsFlags(argToInt(s+1));
517 default : if (strcmp("98",s)==0) {
518 if (heapBuilt() && ((state && !haskell98) ||
519 (!state && haskell98))) {
521 "Haskell 98 compatibility cannot be changed"
522 " while the interpreter is running\n");
535 static Void local setHeapSize(s)
538 hpSize = argToInt(s);
539 if (hpSize < MINIMUMHEAP)
540 hpSize = MINIMUMHEAP;
541 else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
542 hpSize = MAXIMUMHEAP;
543 if (heapBuilt() && hpSize != heapSize) {
544 /* ToDo: should this use a message box in winhugs? */
546 FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
548 FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
556 static Int local argToInt(s) /* read integer from argument str */
561 if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
562 ERRMSG(0) "Missing integer in option setting \"%s\"", t
567 Int d = (*s++) - '0';
568 if (n > ((MAXPOSINT - d)/10)) {
569 ERRMSG(0) "Option setting \"%s\" is too large", t
573 } while (isascii((int)(*s)) && isdigit((int)(*s)));
575 if (*s=='K' || *s=='k') {
576 if (n > (MAXPOSINT/1000)) {
577 ERRMSG(0) "Option setting \"%s\" is too large", t
584 #if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
585 if (*s=='M' || *s=='m') {
586 if (n > (MAXPOSINT/1000000)) {
587 ERRMSG(0) "Option setting \"%s\" is too large", t
595 #if MAXPOSINT > 1000000000
596 if (*s=='G' || *s=='g') {
597 if (n > (MAXPOSINT/1000000000)) {
598 ERRMSG(0) "Option setting \"%s\" is too large", t
607 ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
614 /* --------------------------------------------------------------------------
615 * Print Menu of list of commands:
616 * ------------------------------------------------------------------------*/
618 static struct cmd cmds[] = {
619 {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
620 {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
621 {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
622 {":quit", QUIT}, {":set", SET}, {":find", FIND},
623 {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
624 {":dump", DUMP}, {":ztats", STATS},
625 {":module",SETMODULE},
627 #if EXPLAIN_INSTANCE_RESOLUTION
630 {":version", PNTVER},
635 static Void local menu() {
636 Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
637 Printf("c is the first character in the full name.\n\n");
638 Printf(":load <filenames> load modules from specified files\n");
639 Printf(":load clear all files except prelude\n");
640 Printf(":also <filenames> read additional modules\n");
641 Printf(":reload repeat last load command\n");
642 Printf(":project <filename> use project file\n");
643 Printf(":edit <filename> edit file\n");
644 Printf(":edit edit last module\n");
645 Printf(":module <module> set module for evaluating expressions\n");
646 Printf("<expr> evaluate expression\n");
647 Printf(":type <expr> print type of expression\n");
648 Printf(":? display this list of commands\n");
649 Printf(":set <options> set command line options\n");
650 Printf(":set help on command line options\n");
651 Printf(":names [pat] list names currently in scope\n");
652 Printf(":info <names> describe named objects\n");
653 Printf(":browse <modules> browse names defined in <modules>\n");
654 #if EXPLAIN_INSTANCE_RESOLUTION
655 Printf(":xplain <context> explain instance resolution for <context>\n");
657 Printf(":find <name> edit module containing definition of name\n");
658 Printf(":!command shell escape\n");
659 Printf(":cd dir change directory\n");
660 Printf(":gc force garbage collection\n");
661 Printf(":version print Hugs version\n");
662 Printf(":dump <name> print STG code for named fn\n");
663 #ifdef CRUDE_PROFILING
664 Printf(":ztats <name> print reduction stats\n");
666 Printf(":quit exit Hugs interpreter\n");
669 static Void local guidance() {
670 Printf("Command not recognised. ");
674 static Void local forHelp() {
675 Printf("Type :? for help\n");
678 /* --------------------------------------------------------------------------
679 * Setting of command line options:
680 * ------------------------------------------------------------------------*/
682 struct options toggle[] = { /* List of command line toggles */
683 {'s', 1, "Print no. reductions/cells after eval", &showStats},
684 {'t', 1, "Print type after evaluation", &addType},
685 {'g', 1, "Print no. cells recovered after gc", &gcMessages},
686 {'l', 1, "Literate modules as default", &literateScripts},
687 {'e', 1, "Warn about errors in literate modules", &literateErrors},
688 {'.', 1, "Print dots to show progress", &useDots},
689 {'q', 1, "Print nothing to show progress", &quiet},
690 {'w', 1, "Always show which modules are loaded", &listScripts},
691 {'k', 1, "Show kind errors in full", &kindExpert},
692 {'o', 0, "Allow overlapping instances", &allowOverlap},
693 {'S', 1, "Debug: show generated SC code", &debugSC},
694 {'a', 1, "Raise exception on assert failure", &flagAssert},
695 #if EXPLAIN_INSTANCE_RESOLUTION
696 {'x', 1, "Explain instance resolution", &showInstRes},
699 {'m', 0, "Use multi instance resolution", &multiInstRes},
704 static Void local set() { /* change command line options from*/
705 String s; /* Hugs command line */
707 if ((s=readFilename())!=0) {
709 if (!processOption(s)) {
710 ERRMSG(0) "Option string must begin with `+' or `-'"
713 } while ((s=readFilename())!=0);
715 writeRegString("Options", optionsToStr());
722 /* --------------------------------------------------------------------------
723 * Change directory command:
724 * ------------------------------------------------------------------------*/
726 static Void local changeDir() { /* change directory */
727 String s = readFilename();
729 ERRMSG(0) "Unable to change to directory \"%s\"", s
735 /* --------------------------------------------------------------------------
737 * ------------------------------------------------------------------------*/
739 static jmp_buf catch_error; /* jump buffer for error trapping */
741 HugsBreakAction currentBreakAction = HugsIgnoreBreak;
743 static void handler_IgnoreBreak ( int sig )
745 setHandler ( handler_IgnoreBreak );
748 static void handler_LongjmpOnBreak ( int sig )
750 setHandler ( handler_LongjmpOnBreak );
751 Printf("{Interrupted!}\n");
752 longjmp(catch_error,1);
755 static void handler_RtsInterrupt ( int sig )
757 setHandler ( handler_RtsInterrupt );
761 HugsBreakAction setBreakAction ( HugsBreakAction newAction )
763 HugsBreakAction tmp = currentBreakAction;
764 currentBreakAction = newAction;
766 case HugsIgnoreBreak:
767 setHandler ( handler_IgnoreBreak ); break;
768 case HugsLongjmpOnBreak:
769 setHandler ( handler_LongjmpOnBreak ); break;
770 case HugsRtsInterrupt:
771 setHandler ( handler_RtsInterrupt ); break;
773 internal("setBreakAction");
779 /* --------------------------------------------------------------------------
780 * The new module chaser, loader, etc
781 * ------------------------------------------------------------------------*/
783 List moduleGraph = NIL;
784 List prelModules = NIL;
785 List targetModules = NIL;
787 static void setCurrentFile ( Module mod )
789 assert(isModule(mod));
790 strncpy(currentFileName, textToStr(module(mod).text), 990);
791 strcat(currentFileName, textToStr(module(mod).srcExt));
792 currentFile = currentFileName;
795 static void ppMG ( void )
798 for (t = moduleGraph; nonNull(t); t=tl(t)) {
802 fprintf ( stderr, " %s\n", textToStr(textOf(snd(u))));
805 fprintf ( stderr, " {" );
806 for (v = snd(u); nonNull(v); v=tl(v))
807 fprintf ( stderr, "%s ", textToStr(textOf(hd(v))) );
808 fprintf ( stderr, "}\n" );
817 static Bool elemMG ( ConId mod )
820 for (gs = moduleGraph; nonNull(gs); gs=tl(gs))
821 switch (whatIs(hd(gs))) {
823 if (textOf(mod)==textOf(snd(hd(gs)))) return TRUE;
826 if (varIsMember(textOf(mod),snd(hd(gs)))) return TRUE;
835 static ConId selectArbitrarilyFromGroup ( Cell group )
837 switch (whatIs(group)) {
838 case GRP_NONREC: return snd(group);
839 case GRP_REC: return hd(snd(group));
840 default: internal("selectArbitrarilyFromGroup");
844 static ConId selectLatestMG ( void )
846 List gs = moduleGraph;
847 if (isNull(gs)) internal("selectLatestMG(1)");
848 while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs);
849 return selectArbitrarilyFromGroup(hd(gs));
853 static List /* of CONID */ listFromSpecifiedMG ( List mg )
857 for (gs = mg; nonNull(gs); gs=tl(gs)) {
858 switch (whatIs(hd(gs))) {
859 case GRP_REC: cs = appendOnto(cs,snd(hd(gs))); break;
860 case GRP_NONREC: cs = cons(snd(hd(gs)),cs); break;
861 default: internal("listFromSpecifiedMG");
867 static List /* of CONID */ listFromMG ( void )
869 return listFromSpecifiedMG ( moduleGraph );
873 /* Calculate the strongly connected components of modgList
874 and assign them to moduleGraph. Uses the .uses field of
875 each of the modules to build the graph structure.
877 #define SCC modScc /* make scc algorithm for StgVars */
878 #define LOWLINK modLowlink
879 #define DEPENDS(t) snd(t)
880 #define SETDEPENDS(c,v) snd(c)=v
887 static void mgFromList ( List /* of CONID */ modgList )
893 List adjList; /* :: [ (Text, [Text]) ] */
899 for (t = modgList; nonNull(t); t=tl(t)) {
901 mod = findModule(mT);
902 assert(nonNull(mod));
904 for (u = module(mod).uses; nonNull(u); u=tl(u))
905 usesT = cons(textOf(hd(u)),usesT);
906 /* artifically give all modules a dependency on Prelude */
907 if (mT != textPrelude)
908 usesT = cons(textPrelude,usesT);
909 adjList = cons(pair(mT,usesT),adjList);
912 /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
913 Modify this so that the adjacency list is a list of pointers
914 back to bits of adjList -- that's what modScc needs.
916 for (t = adjList; nonNull(t); t=tl(t)) {
918 /* for each elem of the adjacency list ... */
919 for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
922 /* find the element of adjList whose fst is a */
923 for (v = adjList; nonNull(v); v=tl(v)) {
925 assert(isText(fst(hd(v))));
926 if (fst(hd(v))==a) break;
928 if (isNull(v)) internal("mgFromList");
929 adj = cons(hd(v),adj);
934 adjList = modScc ( adjList );
935 /* adjList is now [ [(module-text, aux-info-field)] ] */
939 for (t = adjList; nonNull(t); t=tl(t)) {
942 /* scc :: [ (module-text, aux-info-field) ] */
943 for (u = scc; nonNull(u); u=tl(u))
944 hd(u) = mkCon(fst(hd(u)));
947 if (length(scc) > 1) {
950 /* singleton module in scc; does it import itself? */
951 mod = findModule ( textOf(hd(scc)) );
952 assert(nonNull(mod));
954 for (u = module(mod).uses; nonNull(u); u=tl(u))
955 if (textOf(hd(u))==textOf(hd(scc)))
960 moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
961 moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
963 moduleGraph = reverse(moduleGraph);
967 static List /* of CONID */ getModuleImports ( Cell tree )
973 for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
977 use = zfst(unap(M_IMPORT_Q,te));
979 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
982 use = zfst(unap(M_IMPORT_UNQ,te));
984 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
994 static void processModule ( Module m )
1010 unqualImports = NIL;
1011 foreignImports = NIL;
1012 foreignExports = NIL;
1019 tree = unap(M_MODULE,module(m).tree);
1020 modNm = zfst3(tree);
1021 assert(textOf(modNm)==module(m).text); /* wrong, but ... */
1022 setExportList(zsnd3(tree));
1023 topEnts = zthd3(tree);
1025 for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
1027 assert(isGenPair(te));
1029 switch(whatIs(te)) {
1031 addQualImport(zfst(te2),zsnd(te2));
1034 addUnqualImport(zfst(te2),zsnd(te2));
1037 tyconDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
1040 classDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
1043 instDefn(zfst3(te2),zsnd3(te2),zthd3(te2));
1046 defaultDefn(zfst(te2),zsnd(te2));
1049 foreignImport(zsel15(te2),zsel25(te2),zsel35(te2),
1050 zsel45(te2),zsel55(te2));
1053 foreignExport(zsel15(te2),zsel25(te2),zsel35(te2),
1054 zsel45(te2),zsel55(te2));
1056 valDefns = cons(te2,valDefns);
1059 internal("processModule");
1068 static Module parseModuleOrInterface ( ConId mc,
1069 List renewFromSource,
1070 List renewFromObject )
1072 /* Allocate a module-table entry. */
1073 /* Parse the entity and fill in the .tree and .uses entries. */
1076 Bool sAvail; Time sTime; Long sSize;
1077 Bool iAvail; Time iTime; Long iSize;
1078 Bool oAvail; Time oTime; Long oSize;
1083 Text mt = textOf(mc);
1084 Module mod = findModule ( mt );
1086 /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
1087 textToStr(mt),mod); */
1088 if (nonNull(mod) && !module(mod).fake)
1089 internal("parseModuleOrInterface");
1091 module(mod).fake = FALSE;
1094 mod = newModule(mt);
1096 /* This call malloc-ates path; we should deallocate it. */
1097 ok = findFilesForModule (
1098 textToStr(module(mod).text),
1101 &sAvail, &sTime, &sSize,
1102 &iAvail, &iTime, &iSize,
1103 &oAvail, &oTime, &oSize
1106 if (!ok) goto cant_find;
1107 if (!sAvail && !(iAvail && oAvail)) goto cant_find;
1109 /* Find out whether to use source or object. */
1110 if (varIsMember(mt,renewFromSource)) {
1111 if (!sAvail) goto cant_find;
1114 if (varIsMember(mt,renewFromObject)) {
1115 if (!(oAvail && iAvail)) goto cant_find;
1118 if (sAvail && !(iAvail && oAvail)) {
1121 if (!sAvail && (iAvail && oAvail)) {
1124 useSource = firstTimeIsLater(sTime,whicheverIsLater(oTime,iTime));
1127 if (!combined && !sAvail) goto cant_find;
1128 if (!combined) useSource = TRUE;
1130 module(mod).srcExt = findText(sExt);
1131 setCurrentFile(mod);
1133 /* Actually do the parsing. */
1136 strcat(name, textToStr(mt));
1138 module(mod).tree = parseModule(name,sSize);
1139 module(mod).uses = getModuleImports(module(mod).tree);
1140 module(mod).fromSrc = TRUE;
1141 module(mod).lastStamp = sTime;
1144 strcat(name, textToStr(mt));
1145 strcat(name, DLL_ENDING);
1146 module(mod).objName = findText(name);
1147 module(mod).objSize = oSize;
1149 strcat(name, textToStr(mt));
1150 strcat(name, ".u_hi");
1151 module(mod).tree = parseInterface(name,iSize);
1152 module(mod).uses = getInterfaceImports(module(mod).tree);
1153 module(mod).fromSrc = FALSE;
1154 module(mod).lastStamp = whicheverIsLater(oTime,iTime);
1157 if (path) free(path);
1161 if (path) free(path);
1163 "Can't find source or object+interface for module \"%s\"",
1169 static void tryLoadGroup ( Cell grp )
1173 switch (whatIs(grp)) {
1175 m = findModule(textOf(snd(grp)));
1177 if (module(m).fromSrc) {
1178 processModule ( m );
1180 processInterfaces ( singleton(snd(grp)) );
1184 for (t = snd(grp); nonNull(t); t=tl(t)) {
1185 m = findModule(textOf(hd(t)));
1187 if (module(m).fromSrc) {
1188 ERRMSG(0) "Source module \"%s\" imports itself recursively",
1189 textToStr(textOf(hd(t)))
1193 processInterfaces ( snd(grp) );
1196 internal("tryLoadGroup");
1201 static void fallBackToPrelModules ( void )
1204 for (m = MODULE_BASE_ADDR;
1205 m < MODULE_BASE_ADDR+tabModuleSz; m++)
1207 && !varIsMember(module(m).text, prelModules))
1212 /* This function catches exceptions in most of the system.
1213 So it's only ok for procedures called from this one
1214 to do EENDs (ie, write error messages). Others should use
1217 static void achieveTargetModules ( void )
1220 volatile List modgList;
1221 volatile List renewFromSource;
1222 volatile List renewFromObject;
1224 volatile Module mod;
1229 Bool sAvail; Time sTime; Long sSize;
1230 Bool iAvail; Time iTime; Long iSize;
1231 Bool oAvail; Time oTime; Long oSize;
1233 volatile Time oisTime;
1234 volatile Time oiTime;
1235 volatile Bool sourceIsLatest;
1236 volatile Bool out_of_date;
1237 volatile List ood_new;
1239 volatile List modgList_new;
1240 volatile List parsedButNotLoaded;
1241 volatile List toChase;
1242 volatile List trans_cl;
1243 volatile List trans_cl_new;
1248 volatile List badMods;
1250 setBreakAction ( HugsIgnoreBreak );
1252 /* First, examine timestamps to find out which modules are
1253 out of date with respect to the source/interface/object files.
1256 modgList = listFromMG();
1258 renewFromSource = renewFromObject = NIL;
1260 for (t = modgList; nonNull(t); t=tl(t)) {
1262 if (varIsMember(textOf(hd(t)),prelModules))
1265 mod = findModule(textOf(hd(t)));
1266 if (isNull(mod)) internal("achieveTargetSet(1)");
1268 ok = findFilesForModule (
1269 textToStr(module(mod).text),
1272 &sAvail, &sTime, &sSize,
1273 &iAvail, &iTime, &iSize,
1274 &oAvail, &oTime, &oSize
1276 if (!combined && !sAvail) ok = FALSE;
1278 fallBackToPrelModules();
1280 "Can't find source or object+interface for module \"%s\"",
1281 textToStr(module(mod).text)
1283 if (path) free(path);
1286 /* findFilesForModule should enforce this */
1287 if (!(sAvail || (oAvail && iAvail)))
1288 internal("achieveTargetSet(2)");
1292 sourceIsLatest = TRUE;
1294 if (sAvail && !(oAvail && iAvail)) {
1296 sourceIsLatest = TRUE;
1298 if (!sAvail && (oAvail && iAvail)) {
1299 oisTime = whicheverIsLater(oTime,iTime);
1300 sourceIsLatest = FALSE;
1302 if (sAvail && (oAvail && iAvail)) {
1303 oisTime = whicheverIsLater(oTime,iTime);
1304 if (firstTimeIsLater(sTime,oisTime)) {
1306 sourceIsLatest = TRUE;
1308 sourceIsLatest = FALSE;
1311 internal("achieveTargetSet(1a)");
1315 out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
1317 assert(!varIsMember(textOf(hd(t)),ood));
1318 ood = cons(hd(t),ood);
1320 renewFromSource = cons(hd(t),renewFromSource); else
1321 renewFromObject = cons(hd(t),renewFromObject);
1324 if (path) { free(path); path = NULL; };
1327 /* Second, form a simplistic transitive closure of the out-of-date
1328 modules: a module is out of date if it imports an out-of-date
1333 for (t = modgList; nonNull(t); t=tl(t)) {
1334 mod = findModule(textOf(hd(t)));
1335 assert(nonNull(mod));
1336 for (us = module(mod).uses; nonNull(us); us=tl(us))
1337 if (varIsMember(textOf(hd(us)),ood))
1340 if (varIsMember(textOf(hd(t)),prelModules))
1341 Printf ( "warning: prelude module \"%s\" is out-of-date\n",
1342 textToStr(textOf(hd(t))) );
1344 if (!varIsMember(textOf(hd(t)),ood_new) &&
1345 !varIsMember(textOf(hd(t)),ood))
1346 ood_new = cons(hd(t),ood_new);
1349 if (isNull(ood_new)) break;
1350 ood = appendOnto(ood_new,ood);
1353 /* Now ood holds the entire set of modules which are out-of-date.
1354 Throw them out of the system, yielding a "reduced system",
1355 in which the remaining modules are in-date.
1357 for (t = ood; nonNull(t); t=tl(t)) {
1358 mod = findModule(textOf(hd(t)));
1359 assert(nonNull(mod));
1363 for (t = modgList; nonNull(t); t=tl(t))
1364 if (!varIsMember(textOf(hd(t)),ood))
1365 modgList_new = cons(hd(t),modgList_new);
1366 modgList = modgList_new;
1368 /* Update the module group list to reflect the reduced system.
1369 We do this so that if the following parsing phases fail, we can
1370 safely fall back to the reduced system.
1372 mgFromList ( modgList );
1374 /* Parse modules/interfaces, collecting parse trees and chasing
1375 imports, starting from the target set.
1377 parsedButNotLoaded = NIL;
1378 toChase = dupList(targetModules);
1380 while (nonNull(toChase)) {
1381 ConId mc = hd(toChase);
1382 toChase = tl(toChase);
1383 if (!varIsMember(textOf(mc),modgList)
1384 && !varIsMember(textOf(mc),parsedButNotLoaded)) {
1386 setBreakAction ( HugsLongjmpOnBreak );
1387 if (setjmp(catch_error)==0) {
1388 /* try this; it may throw an exception */
1389 mod = parseModuleOrInterface (
1390 mc, renewFromSource, renewFromObject );
1392 /* here's the exception handler, if parsing fails */
1393 /* A parse error (or similar). Clean up and abort. */
1394 setBreakAction ( HugsIgnoreBreak );
1395 mod = findModule(textOf(mc));
1396 if (nonNull(mod)) nukeModule(mod);
1397 for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
1398 mod = findModule(textOf(hd(t)));
1399 assert(nonNull(mod));
1400 if (nonNull(mod)) nukeModule(mod);
1403 /* end of the exception handler */
1405 setBreakAction ( HugsIgnoreBreak );
1407 parsedButNotLoaded = cons(mc, parsedButNotLoaded);
1408 toChase = dupOnto(module(mod).uses,toChase);
1412 modgList = dupOnto(parsedButNotLoaded, modgList);
1414 /* We successfully parsed all modules reachable from the target
1415 set which were not part of the reduced system. However, there
1416 may be modules in the reduced system which are not reachable from
1417 the target set. We detect these now by building the transitive
1418 closure of the target set, and nuking modules in the reduced
1419 system which are not part of that closure.
1421 trans_cl = dupList(targetModules);
1424 for (t = trans_cl; nonNull(t); t=tl(t)) {
1425 mod = findModule(textOf(hd(t)));
1426 assert(nonNull(mod));
1427 for (u = module(mod).uses; nonNull(u); u=tl(u))
1428 if (!varIsMember(textOf(hd(u)),trans_cl)
1429 && !varIsMember(textOf(hd(u)),trans_cl_new)
1430 && !varIsMember(textOf(hd(u)),prelModules))
1431 trans_cl_new = cons(hd(u),trans_cl_new);
1433 if (isNull(trans_cl_new)) break;
1434 trans_cl = appendOnto(trans_cl_new,trans_cl);
1437 for (t = modgList; nonNull(t); t=tl(t)) {
1438 if (varIsMember(textOf(hd(t)),trans_cl)) {
1439 modgList_new = cons(hd(t),modgList_new);
1441 mod = findModule(textOf(hd(t)));
1442 assert(nonNull(mod));
1446 modgList = modgList_new;
1448 /* Now, the module symbol tables hold exactly the set of
1449 modules reachable from the target set, and modgList holds
1450 their names. Calculate the scc-ified module graph,
1451 since we need that to guide the next stage, that of
1452 Actually Loading the modules.
1454 If no errors occur, moduleGraph will reflect the final graph
1455 loaded. If an error occurs loading a group, we nuke
1456 that group, truncate the moduleGraph just prior to that
1457 group, and exit. That leaves the system having successfully
1458 loaded all groups prior to the one which failed.
1460 mgFromList ( modgList );
1462 for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
1465 if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
1466 parsedButNotLoaded)) continue;
1468 setBreakAction ( HugsLongjmpOnBreak );
1469 if (setjmp(catch_error)==0) {
1470 /* try this; it may throw an exception */
1473 /* here's the exception handler, if static/typecheck etc fails */
1474 /* nuke the entire rest (ie, the unloaded part)
1475 of the module graph */
1476 setBreakAction ( HugsIgnoreBreak );
1477 badMods = listFromSpecifiedMG ( mg );
1478 for (t = badMods; nonNull(t); t=tl(t)) {
1479 mod = findModule(textOf(hd(t)));
1480 if (nonNull(mod)) nukeModule(mod);
1482 /* truncate the module graph just prior to this group. */
1486 if (isNull(mg)) break;
1487 if (hd(mg) == grp) break;
1488 mg2 = cons ( hd(mg), mg2 );
1491 moduleGraph = reverse(mg2);
1493 /* end of the exception handler */
1495 setBreakAction ( HugsIgnoreBreak );
1498 /* Err .. I think that's it. If we get here, we've successfully
1499 achieved the target set. Phew!
1501 setBreakAction ( HugsIgnoreBreak );
1505 static Bool loadThePrelude ( void )
1510 moduleGraph = prelModules = NIL;
1513 conPrelude = mkCon(findText("Prelude"));
1514 conPrelHugs = mkCon(findText("PrelHugs"));
1515 targetModules = doubleton(conPrelude,conPrelHugs);
1516 achieveTargetModules();
1517 ok = elemMG(conPrelude) && elemMG(conPrelHugs);
1519 conPrelude = mkCon(findText("Prelude"));
1520 targetModules = singleton(conPrelude);
1521 achieveTargetModules();
1522 ok = elemMG(conPrelude);
1525 if (ok) prelModules = listFromMG();
1530 static void refreshActions ( ConId nextCurrMod )
1532 ConId tryFor = mkCon(module(currentModule).text);
1533 achieveTargetModules();
1534 if (nonNull(nextCurrMod))
1535 tryFor = nextCurrMod;
1536 if (!elemMG(tryFor))
1537 tryFor = selectLatestMG();
1538 /* combined mode kludge, to get Prelude rather than PrelHugs */
1539 if (combined && textOf(tryFor)==findText("PrelHugs"))
1540 tryFor = mkCon(findText("Prelude"));
1542 setCurrModule ( findModule(textOf(tryFor)) );
1543 Printf("Hugs session for:\n");
1548 static void addActions ( List extraModules /* :: [CONID] */ )
1551 for (t = extraModules; nonNull(t); t=tl(t)) {
1552 ConId extra = hd(t);
1553 if (!varIsMember(textOf(extra),targetModules))
1554 targetModules = cons(extra,targetModules);
1556 refreshActions ( isNull(extraModules)
1558 : hd(reverse(extraModules))
1563 static void loadActions ( List loadModules /* :: [CONID] */ )
1566 targetModules = dupList ( prelModules );
1568 for (t = loadModules; nonNull(t); t=tl(t)) {
1570 if (!varIsMember(textOf(load),targetModules))
1571 targetModules = cons(load,targetModules);
1573 refreshActions ( isNull(loadModules)
1575 : hd(reverse(loadModules))
1580 /* --------------------------------------------------------------------------
1581 * Access to external editor:
1582 * ------------------------------------------------------------------------*/
1584 /* ToDo: All this editor stuff needs fixing. */
1586 static Void local editor() { /* interpreter-editor interface */
1588 String newFile = readFilename();
1590 setLastEdit(newFile,0);
1591 if (readFilename()) {
1592 ERRMSG(0) "Multiple filenames not permitted"
1600 static Void local find() { /* edit file containing definition */
1603 String nm = readFilename(); /* of specified name */
1605 ERRMSG(0) "No name specified"
1608 else if (readFilename()) {
1609 ERRMSG(0) "Multiple names not permitted"
1615 setCurrModule(findEvalModule());
1617 if (nonNull(c=findTycon(t=findText(nm)))) {
1618 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1619 readScripts(N_PRELUDE_SCRIPTS);
1621 } else if (nonNull(c=findName(t))) {
1622 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1623 readScripts(N_PRELUDE_SCRIPTS);
1626 ERRMSG(0) "No current definition for name \"%s\"", nm
1633 static Void local runEditor() { /* run editor on script lastEdit */
1635 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1636 readScripts(N_PRELUDE_SCRIPTS);
1640 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1646 lastEdit = strCopy(fname);
1651 /* --------------------------------------------------------------------------
1652 * Read and evaluate an expression:
1653 * ------------------------------------------------------------------------*/
1655 static Void setModule ( void ) {
1656 /*set module in which to evaluate expressions*/
1659 String s = readFilename();
1661 mc = selectLatestMG();
1662 if (combined && textOf(mc)==findText("PrelHugs"))
1663 mc = mkCon(findText("Prelude"));
1664 m = findModule(textOf(mc));
1667 m = findModule(findText(s));
1669 ERRMSG(0) "Cannot find module \"%s\"", s
1677 static Module allocEvalModule ( void )
1679 Module evalMod = newModule( findText("_Eval_Module_") );
1680 module(evalMod).names = module(currentModule).names;
1681 module(evalMod).tycons = module(currentModule).tycons;
1682 module(evalMod).classes = module(currentModule).classes;
1686 static Void local evaluator() { /* evaluate expr and print value */
1689 volatile Kinds ks = NIL;
1690 volatile Module evalMod = allocEvalModule();
1691 volatile Module currMod = currentModule;
1692 setCurrModule(evalMod);
1695 defaultDefns = combined ? stdDefaults : evalDefaults;
1697 setBreakAction ( HugsLongjmpOnBreak );
1698 if (setjmp(catch_error)==0) {
1702 type = typeCheckExp(TRUE);
1704 /* if an exception happens, we arrive here */
1705 setBreakAction ( HugsIgnoreBreak );
1706 goto cleanup_and_return;
1709 setBreakAction ( HugsIgnoreBreak );
1710 if (isPolyType(type)) {
1711 ks = polySigOf(type);
1712 bd = monotypeOf(type);
1717 if (whatIs(bd)==QUAL) {
1718 ERRMSG(0) "Unresolved overloading" ETHEN
1719 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1720 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1723 goto cleanup_and_return;
1727 if (isProgType(ks,bd)) {
1728 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1732 Cell d = provePred(ks,NIL,ap(classShow,bd));
1734 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1735 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1736 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1739 goto cleanup_and_return;
1741 inputExpr = ap2(nameShow, d,inputExpr);
1742 inputExpr = ap (namePutStr, inputExpr);
1743 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1745 evalExp(); printf("\n");
1748 printType(stdout,type);
1755 printf ( "result type is " );
1756 printType ( stdout, type );
1764 setBreakAction ( HugsIgnoreBreak );
1765 nukeModule(evalMod);
1766 setCurrModule(currMod);
1767 setCurrentFile(currMod);
1772 /* --------------------------------------------------------------------------
1773 * Print type of input expression:
1774 * ------------------------------------------------------------------------*/
1776 static Void showtype ( void ) { /* print type of expression (if any)*/
1779 volatile Module evalMod = allocEvalModule();
1780 volatile Module currMod = currentModule;
1781 setCurrModule(evalMod);
1783 if (setjmp(catch_error)==0) {
1787 defaultDefns = evalDefaults;
1788 type = typeCheckExp(FALSE);
1789 printExp(stdout,inputExpr);
1791 printType(stdout,type);
1794 /* if an exception happens, we arrive here */
1797 nukeModule(evalMod);
1798 setCurrModule(currMod);
1802 static Void local browseit(mod,t,all)
1809 Printf("module %s where\n",textToStr(module(mod).text));
1810 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1812 /* only look at things defined in this module,
1813 unless `all' flag is set */
1814 if (all || name(nm).mod == mod) {
1815 /* unwanted artifacts, like lambda lifted values,
1816 are in the list of names, but have no types */
1817 if (nonNull(name(nm).type)) {
1818 printExp(stdout,nm);
1820 printType(stdout,name(nm).type);
1822 Printf(" -- data constructor");
1823 } else if (isMfun(nm)) {
1824 Printf(" -- class member");
1825 } else if (isSfun(nm)) {
1826 Printf(" -- selector function");
1834 Printf("Unknown module %s\n",t);
1839 static Void local browse() { /* browse modules */
1840 Int count = 0; /* or give menu of commands */
1844 for (; (s=readFilename())!=0; count++)
1845 if (strcmp(s,"all") == 0) {
1849 browseit(findModule(findText(s)),s,all);
1851 browseit(currentModule,NULL,all);
1855 #if EXPLAIN_INSTANCE_RESOLUTION
1856 static Void local xplain() { /* print type of expression (if any)*/
1858 Bool sir = showInstRes;
1860 setCurrModule(findEvalModule());
1861 startNewScript(0); /* Enables recovery of storage */
1862 /* allocated during evaluation */
1866 d = provePred(NIL,NIL,hd(inputContext));
1868 fprintf(stdout, "not Sat\n");
1870 fprintf(stdout, "Sat\n");
1876 /* --------------------------------------------------------------------------
1877 * Enhanced help system: print current list of scripts or give information
1879 * ------------------------------------------------------------------------*/
1881 static String local objToStr(m,c)
1884 #if 1 || DISPLAY_QUANTIFIERS
1885 static char newVar[60];
1886 switch (whatIs(c)) {
1887 case NAME : if (m == name(c).mod) {
1888 sprintf(newVar,"%s", textToStr(name(c).text));
1890 sprintf(newVar,"%s.%s",
1891 textToStr(module(name(c).mod).text),
1892 textToStr(name(c).text));
1896 case TYCON : if (m == tycon(c).mod) {
1897 sprintf(newVar,"%s", textToStr(tycon(c).text));
1899 sprintf(newVar,"%s.%s",
1900 textToStr(module(tycon(c).mod).text),
1901 textToStr(tycon(c).text));
1905 case CLASS : if (m == cclass(c).mod) {
1906 sprintf(newVar,"%s", textToStr(cclass(c).text));
1908 sprintf(newVar,"%s.%s",
1909 textToStr(module(cclass(c).mod).text),
1910 textToStr(cclass(c).text));
1914 default : internal("objToStr");
1918 static char newVar[33];
1919 switch (whatIs(c)) {
1920 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1923 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1926 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1929 default : internal("objToStr");
1937 static Void dumpStg ( void )
1943 setCurrModule(findEvalModule());
1948 /* request to locate a symbol by name */
1949 if (s && (*s == '?')) {
1950 Text t = findText(s+1);
1951 locateSymbolByName(t);
1955 /* request to dump a bit of the heap */
1956 if (s && (*s == '-' || isdigit(*s))) {
1963 /* request to dump a symbol table entry */
1965 || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
1966 || !isdigit(s[1])) {
1967 fprintf(stderr, ":d -- bad request `%s'\n", s );
1972 case 't': dumpTycon(i); break;
1973 case 'n': dumpName(i); break;
1974 case 'c': dumpClass(i); break;
1975 case 'i': dumpInst(i); break;
1976 default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
1982 static Void local dumpStg( void ) { /* print STG stuff */
1987 Cell v; /* really StgVar */
1988 setCurrModule(findEvalModule());
1990 for (; (s=readFilename())!=0;) {
1993 /* find the name while ignoring module scopes */
1994 for (i=NAMEMIN; i<nameHw; i++)
1995 if (name(i).text == t) n = i;
1997 /* perhaps it's an "idNNNNNN" thing? */
2000 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2003 while (isdigit(s[i])) {
2004 v = v * 10 + (s[i]-'0');
2008 n = nameFromStgVar(v);
2011 if (isNull(n) && whatIs(v)==STGVAR) {
2012 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2013 printStg(stderr, v );
2016 Printf ( "Unknown reference `%s'\n", s );
2019 Printf ( "Not a Name: `%s'\n", s );
2021 if (isNull(name(n).stgVar)) {
2022 Printf ( "Doesn't have a STG tree: %s\n", s );
2024 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2025 printStg(stderr, name(n).stgVar);
2031 static Void local info() { /* describe objects */
2032 Int count = 0; /* or give menu of commands */
2035 for (; (s=readFilename())!=0; count++) {
2036 describe(findText(s));
2039 /* whatScripts(); */
2044 static Void local describe(t) /* describe an object */
2046 Tycon tc = findTycon(t);
2047 Class cl = findClass(t);
2048 Name nm = findName(t);
2050 if (nonNull(tc)) { /* as a type constructor */
2054 for (i=0; i<tycon(tc).arity; ++i) {
2055 t = ap(t,mkOffset(i));
2057 Printf("-- type constructor");
2059 Printf(" with kind ");
2060 printKind(stdout,tycon(tc).kind);
2063 switch (tycon(tc).what) {
2064 case SYNONYM : Printf("type ");
2065 printType(stdout,t);
2067 printType(stdout,tycon(tc).defn);
2071 case DATATYPE : { List cs = tycon(tc).defn;
2072 if (tycon(tc).what==DATATYPE) {
2077 printType(stdout,t);
2079 mapProc(printSyntax,cs);
2081 Printf("\n-- constructors:");
2083 for (; hasCfun(cs); cs=tl(cs)) {
2085 printExp(stdout,hd(cs));
2087 printType(stdout,name(hd(cs)).type);
2090 Printf("\n-- selectors:");
2092 for (; nonNull(cs); cs=tl(cs)) {
2094 printExp(stdout,hd(cs));
2096 printType(stdout,name(hd(cs)).type);
2101 case RESTRICTSYN : Printf("type ");
2102 printType(stdout,t);
2103 Printf(" = <restricted>");
2107 if (nonNull(in=findFirstInst(tc))) {
2108 Printf("\n-- instances:\n");
2111 in = findNextInst(tc,in);
2112 } while (nonNull(in));
2117 if (nonNull(cl)) { /* as a class */
2118 List ins = cclass(cl).instances;
2119 Kinds ks = cclass(cl).kinds;
2120 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2121 Printf("-- type class");
2123 Printf("-- constructor class");
2125 Printf(" with arity ");
2126 printKinds(stdout,ks);
2130 mapProc(printSyntax,cclass(cl).members);
2132 if (nonNull(cclass(cl).supers)) {
2133 printContext(stdout,cclass(cl).supers);
2136 printPred(stdout,cclass(cl).head);
2138 if (nonNull(cclass(cl).fds)) {
2139 List fds = cclass(cl).fds;
2141 for (; nonNull(fds); fds=tl(fds)) {
2143 printFD(stdout,hd(fds));
2148 if (nonNull(cclass(cl).members)) {
2149 List ms = cclass(cl).members;
2152 Type t = name(hd(ms)).type;
2153 if (isPolyType(t)) {
2157 printExp(stdout,hd(ms));
2159 if (isNull(tl(fst(snd(t))))) {
2162 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2164 printType(stdout,t);
2166 } while (nonNull(ms));
2170 Printf("\n-- instances:\n");
2174 } while (nonNull(ins));
2179 if (nonNull(nm)) { /* as a function/name */
2181 printExp(stdout,nm);
2183 if (nonNull(name(nm).type)) {
2184 printType(stdout,name(nm).type);
2186 Printf("<unknown type>");
2189 Printf(" -- data constructor");
2190 } else if (isMfun(nm)) {
2191 Printf(" -- class member");
2192 } else if (isSfun(nm)) {
2193 Printf(" -- selector function");
2199 if (isNull(tc) && isNull(cl) && isNull(nm)) {
2200 Printf("Unknown reference `%s'\n",textToStr(t));
2204 static Void local printSyntax(nm)
2206 Syntax sy = syntaxOf(nm);
2207 Text t = name(nm).text;
2208 String s = textToStr(t);
2209 if (sy != defaultSyntax(t)) {
2211 switch (assocOf(sy)) {
2212 case LEFT_ASS : Putchar('l'); break;
2213 case RIGHT_ASS : Putchar('r'); break;
2214 case NON_ASS : break;
2216 Printf(" %i ",precOf(sy));
2217 if (isascii((int)(*s)) && isalpha((int)(*s))) {
2226 static Void local showInst(in) /* Display instance decl header */
2228 Printf("instance ");
2229 if (nonNull(inst(in).specifics)) {
2230 printContext(stdout,inst(in).specifics);
2233 printPred(stdout,inst(in).head);
2237 /* --------------------------------------------------------------------------
2238 * List all names currently in scope:
2239 * ------------------------------------------------------------------------*/
2241 static Void local listNames() { /* list names matching optional pat*/
2242 String pat = readFilename();
2244 Int width = getTerminalWidth() - 1;
2247 Module mod = currentModule;
2249 if (pat) { /* First gather names to list */
2251 names = addNamesMatching(pat,names);
2252 } while ((pat=readFilename())!=0);
2254 names = addNamesMatching((String)0,names);
2256 if (isNull(names)) { /* Then print them out */
2257 ERRMSG(0) "No names selected"
2261 for (termPos=0; nonNull(names); names=tl(names)) {
2262 String s = objToStr(mod,hd(names));
2264 if (termPos+1+l>width) {
2267 } else if (termPos>0) {
2275 Printf("\n(%d names listed)\n", count);
2278 /* --------------------------------------------------------------------------
2279 * print a prompt and read a line of input:
2280 * ------------------------------------------------------------------------*/
2282 static Void local promptForInput(moduleName)
2283 String moduleName; {
2284 char promptBuffer[1000];
2286 /* This is portable but could overflow buffer */
2287 sprintf(promptBuffer,prompt,moduleName);
2289 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2290 * promptBuffer instead.
2292 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2293 /* Reset prompt to a safe default to avoid an infinite loop */
2295 prompt = strCopy("? ");
2296 internal("Combined prompt and evaluation module name too long");
2300 stringInput("main\0"); else
2301 consoleInput(promptBuffer);
2304 /* --------------------------------------------------------------------------
2305 * main read-eval-print loop, with error trapping:
2306 * ------------------------------------------------------------------------*/
2308 static Void local interpreter(argc,argv)/* main interpreter loop */
2312 List modConIds; /* :: [CONID] */
2316 setBreakAction ( HugsIgnoreBreak );
2317 modConIds = initialize(argc,argv); /* the initial modules to load */
2318 setBreakAction ( HugsIgnoreBreak );
2319 prelOK = loadThePrelude();
2320 if (combined) everybody(POSTPREL);
2324 fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2326 fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2330 loadActions(modConIds);
2333 for (; nonNull(modConIds); modConIds=tl(modConIds))
2334 if (!elemMG(hd(modConIds))) {
2336 "hugs +Q: compilation failed -- can't run `main'\n" );
2343 /* initialize calls startupHaskell, which trashes our signal handlers */
2344 setBreakAction ( HugsIgnoreBreak );
2349 everybody(RESET); /* reset to sensible initial state */
2351 promptForInput(textToStr(module(currentModule).text));
2353 cmd = readCommand(cmds, (Char)':', (Char)'!');
2355 case EDIT : editor();
2359 case LOAD : modConIds = NIL;
2360 while ((s=readFilename())!=0)
2361 modConIds = cons(mkCon(findText(s)),modConIds);
2362 loadActions(modConIds);
2365 case ALSO : modConIds = NIL;
2366 while ((s=readFilename())!=0)
2367 modConIds = cons(mkCon(findText(s)),modConIds);
2368 addActions(modConIds);
2371 case RELOAD : refreshActions(NIL);
2376 case EVAL : evaluator();
2378 case TYPEOF : showtype();
2380 case BROWSE : browse();
2382 #if EXPLAIN_INSTANCE_RESOLUTION
2383 case XPLAIN : xplain();
2386 case NAMES : listNames();
2390 case BADCMD : guidance();
2395 #ifdef CRUDE_PROFILING
2399 case SYSTEM : if (shellEsc(readLine()))
2400 Printf("Warning: Shell escape terminated abnormally\n");
2402 case CHGDIR : changeDir();
2406 case PNTVER: Printf("-- Hugs Version %s\n",
2409 case DUMP : dumpStg();
2412 case COLLECT: consGC = FALSE;
2415 Printf("Garbage collection recovered %d cells\n",
2421 if (autoMain) break;
2425 /* --------------------------------------------------------------------------
2426 * Display progress towards goal:
2427 * ------------------------------------------------------------------------*/
2429 static Target currTarget;
2430 static Bool aiming = FALSE;
2433 static Int charCount;
2435 Void setGoal(what, t) /* Set goal for what to be t */
2440 #if EXPLAIN_INSTANCE_RESOLUTION
2444 currTarget = (t?t:1);
2447 currPos = strlen(what);
2448 maxPos = getTerminalWidth() - 1;
2452 for (charCount=0; *what; charCount++)
2457 Void soFar(t) /* Indicate progress towards goal */
2458 Target t; { /* has now reached t */
2461 #if EXPLAIN_INSTANCE_RESOLUTION
2466 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2471 if (newPos>currPos) {
2474 while (newPos>++currPos);
2481 Void done() { /* Goal has now been achieved */
2484 #if EXPLAIN_INSTANCE_RESOLUTION
2489 while (maxPos>currPos++)
2494 for (; charCount>0; charCount--) {
2503 static Void local failed() { /* Goal cannot be reached due to */
2504 if (aiming) { /* errors */
2511 /* --------------------------------------------------------------------------
2513 * ------------------------------------------------------------------------*/
2515 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
2516 if (printing) { /* after successful termination or */
2517 printing = FALSE; /* runtime error (e.g. interrupt) */
2520 #define plural(v) v, (v==1?"":"s")
2521 Printf("%lu cell%s",plural(numCells));
2523 Printf(", %u garbage collection%s",plural(numGcs));
2532 Cell errAssert(l) /* message to use when raising asserts, etc */
2537 str = mkStr(findText(currentFile));
2539 str = mkStr(findText(""));
2541 return (ap2(nameTangleMessage,str,mkInt(l)));
2544 Void errHead(l) /* print start of error message */
2546 failed(); /* failed to reach target ... */
2548 FPrintf(errorStream,"ERROR");
2551 FPrintf(errorStream," \"%s\"", currentFile);
2552 setLastEdit(currentFile,l);
2553 if (l) FPrintf(errorStream," (line %d)",l);
2556 FPrintf(errorStream,": ");
2557 FFlush(errorStream);
2560 Void errFail() { /* terminate error message and */
2561 Putc('\n',errorStream); /* produce exception to return to */
2562 FFlush(errorStream); /* main command loop */
2563 longjmp(catch_error,1);
2566 Void errFail_no_longjmp() { /* terminate error message but */
2567 Putc('\n',errorStream); /* don't produce an exception */
2568 FFlush(errorStream);
2571 Void errAbort() { /* altern. form of error handling */
2572 failed(); /* used when suitable error message*/
2573 stopAnyPrinting(); /* has already been printed */
2577 Void internal(msg) /* handle internal error */
2581 Printf("INTERNAL ERROR: %s\n",msg);
2584 longjmp(catch_error,1);
2587 Void fatal(msg) /* handle fatal error */
2590 Printf("\nFATAL ERROR: %s\n",msg);
2596 /* --------------------------------------------------------------------------
2597 * Read value from environment variable or registry:
2598 * ------------------------------------------------------------------------*/
2600 String fromEnv(var,def) /* return value of: */
2601 String var; /* environment variable named by var */
2602 String def; { /* or: default value given by def */
2603 String s = getenv(var);
2604 return (s ? s : def);
2607 /* --------------------------------------------------------------------------
2608 * String manipulation routines:
2609 * ------------------------------------------------------------------------*/
2611 static String local strCopy(s) /* make malloced copy of a string */
2615 if ((t=(char *)malloc(strlen(s)+1))==0) {
2616 ERRMSG(0) "String storage space exhausted"
2619 for (r=t; (*r++ = *s++)!=0; ) {
2626 /* --------------------------------------------------------------------------
2628 * We can redirect compiler output (prompts, error messages, etc) by
2629 * tweaking these functions.
2630 * ------------------------------------------------------------------------*/
2632 /* --------------------------------------------------------------------------
2633 * Send message to each component of system:
2634 * ------------------------------------------------------------------------*/
2636 Void everybody(what) /* send command `what' to each component of*/
2637 Int what; { /* system to respond as appropriate ... */
2639 fprintf ( stderr, "EVERYBODY %d\n", what );
2641 machdep(what); /* The order of calling each component is */
2642 storage(what); /* important for the PREPREL command */
2645 translateControl(what);
2647 staticAnalysis(what);
2648 deriveControl(what);
2654 /*-------------------------------------------------------------------------*/