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/04 01:19:07 $
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 char* currentFile; /* Name of current file, or NULL */
112 static char currentFileName[1000]; /* name is stored here if it exists*/
116 static Text evalModule = 0; /* Name of module we eval exprs in */
117 static String currProject = 0; /* Name of current project file */
118 static Bool projectLoaded = FALSE; /* TRUE => project file loaded */
120 static Bool autoMain = FALSE;
121 static String lastEdit = 0; /* Name of script to edit (if any) */
122 static Int lastEdLine = 0; /* Editor line number (if possible)*/
123 static String prompt = 0; /* Prompt string */
124 static Int hpSize = DEFAULTHEAP; /* Desired heap size */
125 String hugsEdit = 0; /* String for editor command */
126 String hugsPath = 0; /* String for file search path */
128 List ifaces_outstanding = NIL;
131 /* --------------------------------------------------------------------------
133 * ------------------------------------------------------------------------*/
135 #ifndef NO_MAIN /* we omit main when building the "Hugs server" */
137 Main main ( Int, String [] ); /* now every func has a prototype */
142 #ifdef HAVE_CONSOLE_H /* Macintosh port */
144 _fcreator = 'R*ch'; /* // 'KAHL'; //'*TEX'; //'ttxt'; */
146 console_options.top = 50;
147 console_options.left = 20;
149 console_options.nrows = 32;
150 console_options.ncols = 80;
152 console_options.pause_atexit = 1;
153 console_options.title = "\pHugs";
155 console_options.procID = 5;
156 argc = ccommand(&argv);
159 CStackBase = &argc; /* Save stack base for use in gc */
163 checkBytecodeCount(); /* check for too many bytecodes */
167 /* If first arg is +Q or -Q, be entirely silent, and automatically run
168 main after loading scripts. Useful for running the nofib suite. */
169 if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
171 if (strcmp(argv[1],"-Q") == 0) {
176 Printf("__ __ __ __ ____ ___ _________________________________________\n");
177 Printf("|| || || || || || ||__ STGHugs: Based on the Haskell 98 standard\n");
178 Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n");
179 Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
180 Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
181 Printf("|| || Version: %s _________________________________________\n\n",HUGS_VERSION);
183 /* Get the absolute path to the directory containing the hugs
184 executable, so that we know where the Prelude and nHandle.so/.dll are.
185 We do this by reading env var STGHUGSDIR. This needs to succeed, so
186 setInstallDir won't return unless it succeeds.
188 setInstallDir ( argv[0] );
191 Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
194 interpreter(argc,argv);
195 Printf("[Leaving Hugs]\n");
206 /* --------------------------------------------------------------------------
207 * Initialization, interpret command line args and read prelude:
208 * ------------------------------------------------------------------------*/
210 static List /*CONID*/ initialize(argc,argv) /* Interpreter initialization */
215 char argv_0_orig[1000];
218 setLastEdit((String)0,0);
225 hugsEdit = strCopy(fromEnv("EDITOR",NULL));
227 hugsPath = strCopy(HUGSPATH);
228 readOptions("-p\"%s> \" -r$$");
230 projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
231 "HUGSPATH", PATHSEP, ""));
232 readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
233 readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
234 #endif /* USE_REGISTRY */
235 readOptions(fromEnv("STGHUGSFLAGS",""));
237 strncpy(argv_0_orig,argv[0],1000); /* startupHaskell mangles argv[0] */
238 startupHaskell (argc,argv,NULL);
244 char exe_name[N_INSTALLDIR + 6];
245 strcpy(exe_name, installDir);
246 strcat(exe_name, "hugs");
247 DEBUG_LoadSymbols(exe_name);
251 /* Find out early on if we're in combined mode or not.
252 everybody(PREPREL) needs to know this.
254 for (i=1; i < argc; ++i) {
255 if (strcmp(argv[i], "--")==0) break;
256 if (strcmp(argv[i], "-c")==0) combined = FALSE;
257 if (strcmp(argv[i], "+c")==0) combined = TRUE;
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' : setHeapSize(s+1);
508 case 'c' : /* don't do anything, since pre-scan of args
509 will have got it already */
512 case 'D' : /* hack */
514 extern void setRtsFlags( int x );
515 setRtsFlags(argToInt(s+1));
519 default : if (strcmp("98",s)==0) {
520 if (initDone && ((state && !haskell98) ||
521 (!state && haskell98))) {
523 "Haskell 98 compatibility cannot be changed"
524 " while the interpreter is running\n");
537 static Void local setHeapSize(s)
540 hpSize = argToInt(s);
541 if (hpSize < MINIMUMHEAP)
542 hpSize = MINIMUMHEAP;
543 else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
544 hpSize = MAXIMUMHEAP;
545 if (initDone && hpSize != heapSize) {
546 /* ToDo: should this use a message box in winhugs? */
548 FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
550 FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
558 static Int local argToInt(s) /* read integer from argument str */
563 if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
564 ERRMSG(0) "Missing integer in option setting \"%s\"", t
569 Int d = (*s++) - '0';
570 if (n > ((MAXPOSINT - d)/10)) {
571 ERRMSG(0) "Option setting \"%s\" is too large", t
575 } while (isascii((int)(*s)) && isdigit((int)(*s)));
577 if (*s=='K' || *s=='k') {
578 if (n > (MAXPOSINT/1000)) {
579 ERRMSG(0) "Option setting \"%s\" is too large", t
586 #if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
587 if (*s=='M' || *s=='m') {
588 if (n > (MAXPOSINT/1000000)) {
589 ERRMSG(0) "Option setting \"%s\" is too large", t
597 #if MAXPOSINT > 1000000000
598 if (*s=='G' || *s=='g') {
599 if (n > (MAXPOSINT/1000000000)) {
600 ERRMSG(0) "Option setting \"%s\" is too large", t
609 ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
616 /* --------------------------------------------------------------------------
617 * Print Menu of list of commands:
618 * ------------------------------------------------------------------------*/
620 static struct cmd cmds[] = {
621 {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
622 {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
623 {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
624 {":quit", QUIT}, {":set", SET}, {":find", FIND},
625 {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
626 {":dump", DUMP}, {":ztats", STATS},
627 {":module",SETMODULE},
629 #if EXPLAIN_INSTANCE_RESOLUTION
632 {":version", PNTVER},
637 static Void local menu() {
638 Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
639 Printf("c is the first character in the full name.\n\n");
640 Printf(":load <filenames> load modules from specified files\n");
641 Printf(":load clear all files except prelude\n");
642 Printf(":also <filenames> read additional modules\n");
643 Printf(":reload repeat last load command\n");
644 Printf(":project <filename> use project file\n");
645 Printf(":edit <filename> edit file\n");
646 Printf(":edit edit last module\n");
647 Printf(":module <module> set module for evaluating expressions\n");
648 Printf("<expr> evaluate expression\n");
649 Printf(":type <expr> print type of expression\n");
650 Printf(":? display this list of commands\n");
651 Printf(":set <options> set command line options\n");
652 Printf(":set help on command line options\n");
653 Printf(":names [pat] list names currently in scope\n");
654 Printf(":info <names> describe named objects\n");
655 Printf(":browse <modules> browse names defined in <modules>\n");
656 #if EXPLAIN_INSTANCE_RESOLUTION
657 Printf(":xplain <context> explain instance resolution for <context>\n");
659 Printf(":find <name> edit module containing definition of name\n");
660 Printf(":!command shell escape\n");
661 Printf(":cd dir change directory\n");
662 Printf(":gc force garbage collection\n");
663 Printf(":version print Hugs version\n");
664 Printf(":dump <name> print STG code for named fn\n");
665 #ifdef CRUDE_PROFILING
666 Printf(":ztats <name> print reduction stats\n");
668 Printf(":quit exit Hugs interpreter\n");
671 static Void local guidance() {
672 Printf("Command not recognised. ");
676 static Void local forHelp() {
677 Printf("Type :? for help\n");
680 /* --------------------------------------------------------------------------
681 * Setting of command line options:
682 * ------------------------------------------------------------------------*/
684 struct options toggle[] = { /* List of command line toggles */
685 {'s', 1, "Print no. reductions/cells after eval", &showStats},
686 {'t', 1, "Print type after evaluation", &addType},
687 {'g', 1, "Print no. cells recovered after gc", &gcMessages},
688 {'l', 1, "Literate modules as default", &literateScripts},
689 {'e', 1, "Warn about errors in literate modules", &literateErrors},
690 {'.', 1, "Print dots to show progress", &useDots},
691 {'q', 1, "Print nothing to show progress", &quiet},
692 {'w', 1, "Always show which modules are loaded", &listScripts},
693 {'k', 1, "Show kind errors in full", &kindExpert},
694 {'o', 0, "Allow overlapping instances", &allowOverlap},
695 {'S', 1, "Debug: show generated SC code", &debugSC},
696 {'a', 1, "Raise exception on assert failure", &flagAssert},
697 #if EXPLAIN_INSTANCE_RESOLUTION
698 {'x', 1, "Explain instance resolution", &showInstRes},
701 {'m', 0, "Use multi instance resolution", &multiInstRes},
706 static Void local set() { /* change command line options from*/
707 String s; /* Hugs command line */
709 if ((s=readFilename())!=0) {
711 if (!processOption(s)) {
712 ERRMSG(0) "Option string must begin with `+' or `-'"
715 } while ((s=readFilename())!=0);
717 writeRegString("Options", optionsToStr());
724 /* --------------------------------------------------------------------------
725 * Change directory command:
726 * ------------------------------------------------------------------------*/
728 static Void local changeDir() { /* change directory */
729 String s = readFilename();
731 ERRMSG(0) "Unable to change to directory \"%s\"", s
737 /* --------------------------------------------------------------------------
739 * ------------------------------------------------------------------------*/
741 static jmp_buf catch_error; /* jump buffer for error trapping */
743 HugsBreakAction currentBreakAction = HugsIgnoreBreak;
745 static void handler_IgnoreBreak ( int sig )
747 setHandler ( handler_IgnoreBreak );
750 static void handler_LongjmpOnBreak ( int sig )
752 setHandler ( handler_LongjmpOnBreak );
753 Printf("{Interrupted!}\n");
754 longjmp(catch_error,1);
757 static void handler_RtsInterrupt ( int sig )
759 setHandler ( handler_RtsInterrupt );
763 HugsBreakAction setBreakAction ( HugsBreakAction newAction )
765 HugsBreakAction tmp = currentBreakAction;
766 currentBreakAction = newAction;
768 case HugsIgnoreBreak:
769 setHandler ( handler_IgnoreBreak ); break;
770 case HugsLongjmpOnBreak:
771 setHandler ( handler_LongjmpOnBreak ); break;
772 case HugsRtsInterrupt:
773 setHandler ( handler_RtsInterrupt ); break;
775 internal("setBreakAction");
781 /* --------------------------------------------------------------------------
782 * The new module chaser, loader, etc
783 * ------------------------------------------------------------------------*/
785 List moduleGraph = NIL;
786 List prelModules = NIL;
787 List targetModules = NIL;
789 static void setCurrentFile ( Module mod )
791 assert(isModule(mod));
792 strncpy(currentFileName, textToStr(module(mod).text), 990);
793 strcat(currentFileName, textToStr(module(mod).srcExt));
794 currentFile = currentFileName;
797 static void ppMG ( void )
800 for (t = moduleGraph; nonNull(t); t=tl(t)) {
804 fprintf ( stderr, " %s\n", textToStr(textOf(snd(u))));
807 fprintf ( stderr, " {" );
808 for (v = snd(u); nonNull(v); v=tl(v))
809 fprintf ( stderr, "%s ", textToStr(textOf(hd(v))) );
810 fprintf ( stderr, "}\n" );
819 static Bool elemMG ( ConId mod )
822 for (gs = moduleGraph; nonNull(gs); gs=tl(gs))
823 switch (whatIs(hd(gs))) {
825 if (textOf(mod)==textOf(snd(hd(gs)))) return TRUE;
828 if (varIsMember(textOf(mod),snd(hd(gs)))) return TRUE;
837 static ConId selectArbitrarilyFromGroup ( Cell group )
839 switch (whatIs(group)) {
840 case GRP_NONREC: return snd(group);
841 case GRP_REC: return hd(snd(group));
842 default: internal("selectArbitrarilyFromGroup");
846 static ConId selectLatestMG ( void )
848 List gs = moduleGraph;
849 if (isNull(gs)) internal("selectLatestMG(1)");
850 while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs);
851 return selectArbitrarilyFromGroup(hd(gs));
855 static List /* of CONID */ listFromSpecifiedMG ( List mg )
859 for (gs = mg; nonNull(gs); gs=tl(gs)) {
860 switch (whatIs(hd(gs))) {
861 case GRP_REC: cs = appendOnto(cs,snd(hd(gs))); break;
862 case GRP_NONREC: cs = cons(snd(hd(gs)),cs); break;
863 default: internal("listFromSpecifiedMG");
869 static List /* of CONID */ listFromMG ( void )
871 return listFromSpecifiedMG ( moduleGraph );
875 /* Calculate the strongly connected components of modgList
876 and assign them to moduleGraph. Uses the .uses field of
877 each of the modules to build the graph structure.
879 #define SCC modScc /* make scc algorithm for StgVars */
880 #define LOWLINK modLowlink
881 #define DEPENDS(t) snd(t)
882 #define SETDEPENDS(c,v) snd(c)=v
889 static void mgFromList ( List /* of CONID */ modgList )
895 List adjList; /* :: [ (Text, [Text]) ] */
901 for (t = modgList; nonNull(t); t=tl(t)) {
903 mod = findModule(mT);
904 assert(nonNull(mod));
906 for (u = module(mod).uses; nonNull(u); u=tl(u))
907 usesT = cons(textOf(hd(u)),usesT);
908 /* artifically give all modules a dependency on Prelude */
910 if (mT != textPrelude && mT != textPrimPrel)
911 usesT = cons(textPrelude,usesT);
913 adjList = cons(pair(mT,usesT),adjList);
916 /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
917 Modify this so that the adjacency list is a list of pointers
918 back to bits of adjList -- that's what modScc needs.
920 for (t = adjList; nonNull(t); t=tl(t)) {
922 /* for each elem of the adjacency list ... */
923 for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
926 /* find the element of adjList whose fst is a */
927 for (v = adjList; nonNull(v); v=tl(v)) {
929 assert(isText(fst(hd(v))));
930 if (fst(hd(v))==a) break;
932 if (isNull(v)) internal("mgFromList");
933 adj = cons(hd(v),adj);
938 adjList = modScc ( adjList );
939 /* adjList is now [ [(module-text, aux-info-field)] ] */
943 for (t = adjList; nonNull(t); t=tl(t)) {
946 /* scc :: [ (module-text, aux-info-field) ] */
947 for (u = scc; nonNull(u); u=tl(u))
948 hd(u) = mkCon(fst(hd(u)));
951 if (length(scc) > 1) {
954 /* singleton module in scc; does it import itself? */
955 mod = findModule ( textOf(hd(scc)) );
956 assert(nonNull(mod));
958 for (u = module(mod).uses; nonNull(u); u=tl(u))
959 if (textOf(hd(u))==textOf(hd(scc)))
964 moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
965 moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
967 moduleGraph = reverse(moduleGraph);
971 static List /* of CONID */ getModuleImports ( Cell tree )
977 for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
981 use = zfst(unap(M_IMPORT_Q,te));
983 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
986 use = zfst(unap(M_IMPORT_UNQ,te));
988 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
998 static void processModule ( Module m )
1014 unqualImports = NIL;
1015 foreignImports = NIL;
1016 foreignExports = NIL;
1023 tree = unap(M_MODULE,module(m).tree);
1024 modNm = zfst3(tree);
1025 assert(textOf(modNm)==module(m).text); /* wrong, but ... */
1026 setExportList(zsnd3(tree));
1027 topEnts = zthd3(tree);
1029 for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
1031 assert(isGenPair(te));
1033 switch(whatIs(te)) {
1035 addQualImport(zfst(te2),zsnd(te2));
1038 addUnqualImport(zfst(te2),zsnd(te2));
1041 tyconDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
1044 classDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
1047 instDefn(zfst3(te2),zsnd3(te2),zthd3(te2));
1050 defaultDefn(zfst(te2),zsnd(te2));
1053 foreignImport(zsel15(te2),zsel25(te2),zsel35(te2),
1054 zsel45(te2),zsel55(te2));
1057 foreignExport(zsel15(te2),zsel25(te2),zsel35(te2),
1058 zsel45(te2),zsel55(te2));
1060 valDefns = cons(te2,valDefns);
1063 internal("processModule");
1072 static Module parseModuleOrInterface ( ConId mc,
1073 List renewFromSource,
1074 List renewFromObject )
1076 /* Allocate a module-table entry. */
1077 /* Parse the entity and fill in the .tree and .uses entries. */
1080 Bool sAvail; Time sTime; Long sSize;
1081 Bool iAvail; Time iTime; Long iSize;
1082 Bool oAvail; Time oTime; Long oSize;
1087 Text mt = textOf(mc);
1088 Module mod = findModule ( mt );
1090 /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
1091 textToStr(mt),mod); */
1092 if (nonNull(mod) && !module(mod).fake)
1093 internal("parseModuleOrInterface");
1095 module(mod).fake = FALSE;
1098 mod = newModule(mt);
1100 /* This call malloc-ates path; we should deallocate it. */
1101 ok = findFilesForModule (
1102 textToStr(module(mod).text),
1105 &sAvail, &sTime, &sSize,
1106 &iAvail, &iTime, &iSize,
1107 &oAvail, &oTime, &oSize
1110 if (!ok) goto cant_find;
1111 if (!sAvail && !(iAvail && oAvail)) goto cant_find;
1113 /* Find out whether to use source or object. */
1114 if (varIsMember(mt,renewFromSource)) {
1115 if (!sAvail) goto cant_find;
1118 if (varIsMember(mt,renewFromObject)) {
1119 if (!(oAvail && iAvail)) goto cant_find;
1122 if (sAvail && !(iAvail && oAvail)) {
1125 if (!sAvail && (iAvail && oAvail)) {
1128 useSource = firstTimeIsLater(sTime,whicheverIsLater(oTime,iTime));
1131 if (!combined && !sAvail) goto cant_find;
1132 if (!combined) useSource = TRUE;
1134 module(mod).srcExt = findText(sExt);
1135 setCurrentFile(mod);
1137 /* Actually do the parsing. */
1140 strcat(name, textToStr(mt));
1142 module(mod).tree = parseModule(name,sSize);
1143 module(mod).uses = getModuleImports(module(mod).tree);
1144 module(mod).fromSrc = TRUE;
1145 module(mod).lastStamp = sTime;
1148 strcat(name, textToStr(mt));
1149 strcat(name, DLL_ENDING);
1150 module(mod).objName = findText(name);
1151 module(mod).objSize = oSize;
1153 strcat(name, textToStr(mt));
1154 strcat(name, ".u_hi");
1155 module(mod).tree = parseInterface(name,iSize);
1156 module(mod).uses = getInterfaceImports(module(mod).tree);
1157 module(mod).fromSrc = FALSE;
1158 module(mod).lastStamp = whicheverIsLater(oTime,iTime);
1161 if (path) free(path);
1165 if (path) free(path);
1167 "Can't find source or object+interface for module \"%s\"",
1173 static void tryLoadGroup ( Cell grp )
1177 switch (whatIs(grp)) {
1179 m = findModule(textOf(snd(grp)));
1181 if (module(m).fromSrc) {
1182 processModule ( m );
1184 processInterfaces ( singleton(snd(grp)) );
1188 for (t = snd(grp); nonNull(t); t=tl(t)) {
1189 m = findModule(textOf(hd(t)));
1191 if (module(m).fromSrc) {
1192 ERRMSG(0) "Source module \"%s\" imports itself recursively",
1193 textToStr(textOf(hd(t)))
1197 processInterfaces ( snd(grp) );
1200 internal("tryLoadGroup");
1205 static void fallBackToPrelModules ( void )
1208 for (m = MODULE_BASE_ADDR;
1209 m < MODULE_BASE_ADDR+tabModuleSz; m++)
1211 && !varIsMember(module(m).text, prelModules))
1216 /* This function catches exceptions in most of the system.
1217 So it's only ok for procedures called from this one
1218 to do EENDs (ie, write error messages). Others should use
1221 static void achieveTargetModules ( void )
1224 volatile List modgList;
1225 volatile List renewFromSource;
1226 volatile List renewFromObject;
1228 volatile Module mod;
1233 Bool sAvail; Time sTime; Long sSize;
1234 Bool iAvail; Time iTime; Long iSize;
1235 Bool oAvail; Time oTime; Long oSize;
1237 volatile Time oisTime;
1238 volatile Time oiTime;
1239 volatile Bool sourceIsLatest;
1240 volatile Bool out_of_date;
1241 volatile List ood_new;
1243 volatile List modgList_new;
1244 volatile List parsedButNotLoaded;
1245 volatile List toChase;
1246 volatile List trans_cl;
1247 volatile List trans_cl_new;
1252 volatile List badMods;
1254 setBreakAction ( HugsIgnoreBreak );
1256 /* First, examine timestamps to find out which modules are
1257 out of date with respect to the source/interface/object files.
1260 modgList = listFromMG();
1262 renewFromSource = renewFromObject = NIL;
1264 for (t = modgList; nonNull(t); t=tl(t)) {
1266 if (varIsMember(textOf(hd(t)),prelModules))
1269 mod = findModule(textOf(hd(t)));
1270 if (isNull(mod)) internal("achieveTargetSet(1)");
1272 ok = findFilesForModule (
1273 textToStr(module(mod).text),
1276 &sAvail, &sTime, &sSize,
1277 &iAvail, &iTime, &iSize,
1278 &oAvail, &oTime, &oSize
1280 if (!combined && !sAvail) ok = FALSE;
1282 fallBackToPrelModules();
1284 "Can't find source or object+interface for module \"%s\"",
1285 textToStr(module(mod).text)
1287 if (path) free(path);
1290 /* findFilesForModule should enforce this */
1291 if (!(sAvail || (oAvail && iAvail)))
1292 internal("achieveTargetSet(2)");
1296 sourceIsLatest = TRUE;
1298 if (sAvail && !(oAvail && iAvail)) {
1300 sourceIsLatest = TRUE;
1302 if (!sAvail && (oAvail && iAvail)) {
1303 oisTime = whicheverIsLater(oTime,iTime);
1304 sourceIsLatest = FALSE;
1306 if (sAvail && (oAvail && iAvail)) {
1307 oisTime = whicheverIsLater(oTime,iTime);
1308 if (firstTimeIsLater(sTime,oisTime)) {
1310 sourceIsLatest = TRUE;
1312 sourceIsLatest = FALSE;
1315 internal("achieveTargetSet(1a)");
1319 out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
1321 assert(!varIsMember(textOf(hd(t)),ood));
1322 ood = cons(hd(t),ood);
1324 renewFromSource = cons(hd(t),renewFromSource); else
1325 renewFromObject = cons(hd(t),renewFromObject);
1328 if (path) { free(path); path = NULL; };
1331 /* Second, form a simplistic transitive closure of the out-of-date
1332 modules: a module is out of date if it imports an out-of-date
1337 for (t = modgList; nonNull(t); t=tl(t)) {
1338 mod = findModule(textOf(hd(t)));
1339 assert(nonNull(mod));
1340 for (us = module(mod).uses; nonNull(us); us=tl(us))
1341 if (varIsMember(textOf(hd(us)),ood))
1344 if (varIsMember(textOf(hd(t)),prelModules))
1345 Printf ( "warning: prelude module \"%s\" is out-of-date\n",
1346 textToStr(textOf(hd(t))) );
1348 if (!varIsMember(textOf(hd(t)),ood_new) &&
1349 !varIsMember(textOf(hd(t)),ood))
1350 ood_new = cons(hd(t),ood_new);
1353 if (isNull(ood_new)) break;
1354 ood = appendOnto(ood_new,ood);
1357 /* Now ood holds the entire set of modules which are out-of-date.
1358 Throw them out of the system, yielding a "reduced system",
1359 in which the remaining modules are in-date.
1361 for (t = ood; nonNull(t); t=tl(t)) {
1362 mod = findModule(textOf(hd(t)));
1363 assert(nonNull(mod));
1367 for (t = modgList; nonNull(t); t=tl(t))
1368 if (!varIsMember(textOf(hd(t)),ood))
1369 modgList_new = cons(hd(t),modgList_new);
1370 modgList = modgList_new;
1372 /* Update the module group list to reflect the reduced system.
1373 We do this so that if the following parsing phases fail, we can
1374 safely fall back to the reduced system.
1376 mgFromList ( modgList );
1378 /* Parse modules/interfaces, collecting parse trees and chasing
1379 imports, starting from the target set.
1381 parsedButNotLoaded = NIL;
1382 toChase = dupList(targetModules);
1384 while (nonNull(toChase)) {
1385 ConId mc = hd(toChase);
1386 toChase = tl(toChase);
1387 if (!varIsMember(textOf(mc),modgList)
1388 && !varIsMember(textOf(mc),parsedButNotLoaded)) {
1390 setBreakAction ( HugsLongjmpOnBreak );
1391 if (setjmp(catch_error)==0) {
1392 /* try this; it may throw an exception */
1393 mod = parseModuleOrInterface (
1394 mc, renewFromSource, renewFromObject );
1396 /* here's the exception handler, if parsing fails */
1397 /* A parse error (or similar). Clean up and abort. */
1398 setBreakAction ( HugsIgnoreBreak );
1399 mod = findModule(textOf(mc));
1400 if (nonNull(mod)) nukeModule(mod);
1401 for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
1402 mod = findModule(textOf(hd(t)));
1403 assert(nonNull(mod));
1404 if (nonNull(mod)) nukeModule(mod);
1407 /* end of the exception handler */
1409 setBreakAction ( HugsIgnoreBreak );
1411 parsedButNotLoaded = cons(mc, parsedButNotLoaded);
1412 toChase = dupOnto(module(mod).uses,toChase);
1416 modgList = dupOnto(parsedButNotLoaded, modgList);
1418 /* We successfully parsed all modules reachable from the target
1419 set which were not part of the reduced system. However, there
1420 may be modules in the reduced system which are not reachable from
1421 the target set. We detect these now by building the transitive
1422 closure of the target set, and nuking modules in the reduced
1423 system which are not part of that closure.
1425 trans_cl = dupList(targetModules);
1428 for (t = trans_cl; nonNull(t); t=tl(t)) {
1429 mod = findModule(textOf(hd(t)));
1430 assert(nonNull(mod));
1431 for (u = module(mod).uses; nonNull(u); u=tl(u))
1432 if (!varIsMember(textOf(hd(u)),trans_cl)
1433 && !varIsMember(textOf(hd(u)),trans_cl_new)
1434 && !varIsMember(textOf(hd(u)),prelModules))
1435 trans_cl_new = cons(hd(u),trans_cl_new);
1437 if (isNull(trans_cl_new)) break;
1438 trans_cl = appendOnto(trans_cl_new,trans_cl);
1441 for (t = modgList; nonNull(t); t=tl(t)) {
1442 if (varIsMember(textOf(hd(t)),trans_cl)) {
1443 modgList_new = cons(hd(t),modgList_new);
1445 mod = findModule(textOf(hd(t)));
1446 assert(nonNull(mod));
1450 modgList = modgList_new;
1452 /* Now, the module symbol tables hold exactly the set of
1453 modules reachable from the target set, and modgList holds
1454 their names. Calculate the scc-ified module graph,
1455 since we need that to guide the next stage, that of
1456 Actually Loading the modules.
1458 If no errors occur, moduleGraph will reflect the final graph
1459 loaded. If an error occurs loading a group, we nuke
1460 that group, truncate the moduleGraph just prior to that
1461 group, and exit. That leaves the system having successfully
1462 loaded all groups prior to the one which failed.
1464 mgFromList ( modgList );
1466 for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
1469 if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
1470 parsedButNotLoaded)) continue;
1472 setBreakAction ( HugsLongjmpOnBreak );
1473 if (setjmp(catch_error)==0) {
1474 /* try this; it may throw an exception */
1477 /* here's the exception handler, if static/typecheck etc fails */
1478 /* nuke the entire rest (ie, the unloaded part)
1479 of the module graph */
1480 setBreakAction ( HugsIgnoreBreak );
1481 badMods = listFromSpecifiedMG ( mg );
1482 for (t = badMods; nonNull(t); t=tl(t)) {
1483 mod = findModule(textOf(hd(t)));
1484 if (nonNull(mod)) nukeModule(mod);
1486 /* truncate the module graph just prior to this group. */
1490 if (isNull(mg)) break;
1491 if (hd(mg) == grp) break;
1492 mg2 = cons ( hd(mg), mg2 );
1495 moduleGraph = reverse(mg2);
1497 /* end of the exception handler */
1499 setBreakAction ( HugsIgnoreBreak );
1502 /* Err .. I think that's it. If we get here, we've successfully
1503 achieved the target set. Phew!
1505 setBreakAction ( HugsIgnoreBreak );
1509 static Bool loadThePrelude ( void )
1514 moduleGraph = prelModules = NIL;
1517 conPrelude = mkCon(findText("Prelude"));
1518 conPrelHugs = mkCon(findText("PrelHugs"));
1519 targetModules = doubleton(conPrelude,conPrelHugs);
1520 achieveTargetModules();
1521 ok = elemMG(conPrelude) && elemMG(conPrelHugs);
1523 conPrelude = mkCon(findText("PrimPrel"));
1524 conPrelHugs = mkCon(findText("Prelude"));
1525 targetModules = doubleton(conPrelude,conPrelHugs);
1526 achieveTargetModules();
1527 ok = elemMG(conPrelude);
1530 if (ok) prelModules = listFromMG();
1535 static void refreshActions ( ConId nextCurrMod )
1537 ConId tryFor = mkCon(module(currentModule).text);
1538 achieveTargetModules();
1539 if (nonNull(nextCurrMod))
1540 tryFor = nextCurrMod;
1541 if (!elemMG(tryFor))
1542 tryFor = selectLatestMG();
1543 /* combined mode kludge, to get Prelude rather than PrelHugs */
1544 if (combined && textOf(tryFor)==findText("PrelHugs"))
1545 tryFor = mkCon(findText("Prelude"));
1547 setCurrModule ( findModule(textOf(tryFor)) );
1548 Printf("Hugs session for:\n");
1553 static void addActions ( List extraModules /* :: [CONID] */ )
1556 for (t = extraModules; nonNull(t); t=tl(t)) {
1557 ConId extra = hd(t);
1558 if (!varIsMember(textOf(extra),targetModules))
1559 targetModules = cons(extra,targetModules);
1561 refreshActions ( isNull(extraModules)
1563 : hd(reverse(extraModules))
1568 static void loadActions ( List loadModules /* :: [CONID] */ )
1571 targetModules = dupList ( prelModules );
1573 for (t = loadModules; nonNull(t); t=tl(t)) {
1575 if (!varIsMember(textOf(load),targetModules))
1576 targetModules = cons(load,targetModules);
1578 refreshActions ( isNull(loadModules)
1580 : hd(reverse(loadModules))
1585 /* --------------------------------------------------------------------------
1586 * Access to external editor:
1587 * ------------------------------------------------------------------------*/
1589 /* ToDo: All this editor stuff needs fixing. */
1591 static Void local editor() { /* interpreter-editor interface */
1593 String newFile = readFilename();
1595 setLastEdit(newFile,0);
1596 if (readFilename()) {
1597 ERRMSG(0) "Multiple filenames not permitted"
1605 static Void local find() { /* edit file containing definition */
1608 String nm = readFilename(); /* of specified name */
1610 ERRMSG(0) "No name specified"
1613 else if (readFilename()) {
1614 ERRMSG(0) "Multiple names not permitted"
1620 setCurrModule(findEvalModule());
1622 if (nonNull(c=findTycon(t=findText(nm)))) {
1623 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1624 readScripts(N_PRELUDE_SCRIPTS);
1626 } else if (nonNull(c=findName(t))) {
1627 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1628 readScripts(N_PRELUDE_SCRIPTS);
1631 ERRMSG(0) "No current definition for name \"%s\"", nm
1638 static Void local runEditor() { /* run editor on script lastEdit */
1640 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1641 readScripts(N_PRELUDE_SCRIPTS);
1645 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1651 lastEdit = strCopy(fname);
1656 /* --------------------------------------------------------------------------
1657 * Read and evaluate an expression:
1658 * ------------------------------------------------------------------------*/
1660 static Void setModule ( void ) {
1661 /*set module in which to evaluate expressions*/
1664 String s = readFilename();
1666 mc = selectLatestMG();
1667 if (combined && textOf(mc)==findText("PrelHugs"))
1668 mc = mkCon(findText("Prelude"));
1669 m = findModule(textOf(mc));
1672 m = findModule(findText(s));
1674 ERRMSG(0) "Cannot find module \"%s\"", s
1682 static Module allocEvalModule ( void )
1684 Module evalMod = newModule( findText("_Eval_Module_") );
1685 module(evalMod).names = module(currentModule).names;
1686 module(evalMod).tycons = module(currentModule).tycons;
1687 module(evalMod).classes = module(currentModule).classes;
1688 module(evalMod).qualImports
1689 = singleton(pair(mkCon(textPrelude),modulePrelude));
1693 static Void local evaluator() { /* evaluate expr and print value */
1696 volatile Kinds ks = NIL;
1697 volatile Module evalMod = allocEvalModule();
1698 volatile Module currMod = currentModule;
1699 setCurrModule(evalMod);
1702 defaultDefns = combined ? stdDefaults : evalDefaults;
1704 setBreakAction ( HugsLongjmpOnBreak );
1705 if (setjmp(catch_error)==0) {
1709 type = typeCheckExp(TRUE);
1711 /* if an exception happens, we arrive here */
1712 setBreakAction ( HugsIgnoreBreak );
1713 goto cleanup_and_return;
1716 setBreakAction ( HugsIgnoreBreak );
1717 if (isPolyType(type)) {
1718 ks = polySigOf(type);
1719 bd = monotypeOf(type);
1724 if (whatIs(bd)==QUAL) {
1725 ERRMSG(0) "Unresolved overloading" ETHEN
1726 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1727 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1730 goto cleanup_and_return;
1734 if (isProgType(ks,bd)) {
1735 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1739 Cell d = provePred(ks,NIL,ap(classShow,bd));
1741 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1742 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1743 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1746 goto cleanup_and_return;
1748 inputExpr = ap2(nameShow, d,inputExpr);
1749 inputExpr = ap (namePutStr, inputExpr);
1750 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1752 evalExp(); printf("\n");
1755 printType(stdout,type);
1762 printf ( "result type is " );
1763 printType ( stdout, type );
1771 setBreakAction ( HugsIgnoreBreak );
1772 nukeModule(evalMod);
1773 setCurrModule(currMod);
1774 setCurrentFile(currMod);
1779 /* --------------------------------------------------------------------------
1780 * Print type of input expression:
1781 * ------------------------------------------------------------------------*/
1783 static Void showtype ( void ) { /* print type of expression (if any)*/
1786 volatile Module evalMod = allocEvalModule();
1787 volatile Module currMod = currentModule;
1788 setCurrModule(evalMod);
1790 if (setjmp(catch_error)==0) {
1794 defaultDefns = evalDefaults;
1795 type = typeCheckExp(FALSE);
1796 printExp(stdout,inputExpr);
1798 printType(stdout,type);
1801 /* if an exception happens, we arrive here */
1804 nukeModule(evalMod);
1805 setCurrModule(currMod);
1809 static Void local browseit(mod,t,all)
1816 Printf("module %s where\n",textToStr(module(mod).text));
1817 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1819 /* only look at things defined in this module,
1820 unless `all' flag is set */
1821 if (all || name(nm).mod == mod) {
1822 /* unwanted artifacts, like lambda lifted values,
1823 are in the list of names, but have no types */
1824 if (nonNull(name(nm).type)) {
1825 printExp(stdout,nm);
1827 printType(stdout,name(nm).type);
1829 Printf(" -- data constructor");
1830 } else if (isMfun(nm)) {
1831 Printf(" -- class member");
1832 } else if (isSfun(nm)) {
1833 Printf(" -- selector function");
1841 Printf("Unknown module %s\n",t);
1846 static Void local browse() { /* browse modules */
1847 Int count = 0; /* or give menu of commands */
1851 for (; (s=readFilename())!=0; count++)
1852 if (strcmp(s,"all") == 0) {
1856 browseit(findModule(findText(s)),s,all);
1858 browseit(currentModule,NULL,all);
1862 #if EXPLAIN_INSTANCE_RESOLUTION
1863 static Void local xplain() { /* print type of expression (if any)*/
1865 Bool sir = showInstRes;
1867 setCurrModule(findEvalModule());
1868 startNewScript(0); /* Enables recovery of storage */
1869 /* allocated during evaluation */
1873 d = provePred(NIL,NIL,hd(inputContext));
1875 fprintf(stdout, "not Sat\n");
1877 fprintf(stdout, "Sat\n");
1883 /* --------------------------------------------------------------------------
1884 * Enhanced help system: print current list of scripts or give information
1886 * ------------------------------------------------------------------------*/
1888 static String local objToStr(m,c)
1891 #if 1 || DISPLAY_QUANTIFIERS
1892 static char newVar[60];
1893 switch (whatIs(c)) {
1894 case NAME : if (m == name(c).mod) {
1895 sprintf(newVar,"%s", textToStr(name(c).text));
1897 sprintf(newVar,"%s.%s",
1898 textToStr(module(name(c).mod).text),
1899 textToStr(name(c).text));
1903 case TYCON : if (m == tycon(c).mod) {
1904 sprintf(newVar,"%s", textToStr(tycon(c).text));
1906 sprintf(newVar,"%s.%s",
1907 textToStr(module(tycon(c).mod).text),
1908 textToStr(tycon(c).text));
1912 case CLASS : if (m == cclass(c).mod) {
1913 sprintf(newVar,"%s", textToStr(cclass(c).text));
1915 sprintf(newVar,"%s.%s",
1916 textToStr(module(cclass(c).mod).text),
1917 textToStr(cclass(c).text));
1921 default : internal("objToStr");
1925 static char newVar[33];
1926 switch (whatIs(c)) {
1927 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1930 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1933 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1936 default : internal("objToStr");
1944 static Void dumpStg ( void )
1950 setCurrModule(findEvalModule());
1955 /* request to locate a symbol by name */
1956 if (s && (*s == '?')) {
1957 Text t = findText(s+1);
1958 locateSymbolByName(t);
1962 /* request to dump a bit of the heap */
1963 if (s && (*s == '-' || isdigit(*s))) {
1970 /* request to dump a symbol table entry */
1972 || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
1973 || !isdigit(s[1])) {
1974 fprintf(stderr, ":d -- bad request `%s'\n", s );
1979 case 't': dumpTycon(i); break;
1980 case 'n': dumpName(i); break;
1981 case 'c': dumpClass(i); break;
1982 case 'i': dumpInst(i); break;
1983 default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
1989 static Void local dumpStg( void ) { /* print STG stuff */
1994 Cell v; /* really StgVar */
1995 setCurrModule(findEvalModule());
1997 for (; (s=readFilename())!=0;) {
2000 /* find the name while ignoring module scopes */
2001 for (i=NAMEMIN; i<nameHw; i++)
2002 if (name(i).text == t) n = i;
2004 /* perhaps it's an "idNNNNNN" thing? */
2007 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2010 while (isdigit(s[i])) {
2011 v = v * 10 + (s[i]-'0');
2015 n = nameFromStgVar(v);
2018 if (isNull(n) && whatIs(v)==STGVAR) {
2019 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2020 printStg(stderr, v );
2023 Printf ( "Unknown reference `%s'\n", s );
2026 Printf ( "Not a Name: `%s'\n", s );
2028 if (isNull(name(n).stgVar)) {
2029 Printf ( "Doesn't have a STG tree: %s\n", s );
2031 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2032 printStg(stderr, name(n).stgVar);
2038 static Void local info() { /* describe objects */
2039 Int count = 0; /* or give menu of commands */
2042 for (; (s=readFilename())!=0; count++) {
2043 describe(findText(s));
2046 /* whatScripts(); */
2051 static Void local describe(t) /* describe an object */
2053 Tycon tc = findTycon(t);
2054 Class cl = findClass(t);
2055 Name nm = findName(t);
2057 if (nonNull(tc)) { /* as a type constructor */
2061 for (i=0; i<tycon(tc).arity; ++i) {
2062 t = ap(t,mkOffset(i));
2064 Printf("-- type constructor");
2066 Printf(" with kind ");
2067 printKind(stdout,tycon(tc).kind);
2070 switch (tycon(tc).what) {
2071 case SYNONYM : Printf("type ");
2072 printType(stdout,t);
2074 printType(stdout,tycon(tc).defn);
2078 case DATATYPE : { List cs = tycon(tc).defn;
2079 if (tycon(tc).what==DATATYPE) {
2084 printType(stdout,t);
2086 mapProc(printSyntax,cs);
2088 Printf("\n-- constructors:");
2090 for (; hasCfun(cs); cs=tl(cs)) {
2092 printExp(stdout,hd(cs));
2094 printType(stdout,name(hd(cs)).type);
2097 Printf("\n-- selectors:");
2099 for (; nonNull(cs); cs=tl(cs)) {
2101 printExp(stdout,hd(cs));
2103 printType(stdout,name(hd(cs)).type);
2108 case RESTRICTSYN : Printf("type ");
2109 printType(stdout,t);
2110 Printf(" = <restricted>");
2114 if (nonNull(in=findFirstInst(tc))) {
2115 Printf("\n-- instances:\n");
2118 in = findNextInst(tc,in);
2119 } while (nonNull(in));
2124 if (nonNull(cl)) { /* as a class */
2125 List ins = cclass(cl).instances;
2126 Kinds ks = cclass(cl).kinds;
2127 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2128 Printf("-- type class");
2130 Printf("-- constructor class");
2132 Printf(" with arity ");
2133 printKinds(stdout,ks);
2137 mapProc(printSyntax,cclass(cl).members);
2139 if (nonNull(cclass(cl).supers)) {
2140 printContext(stdout,cclass(cl).supers);
2143 printPred(stdout,cclass(cl).head);
2145 if (nonNull(cclass(cl).fds)) {
2146 List fds = cclass(cl).fds;
2148 for (; nonNull(fds); fds=tl(fds)) {
2150 printFD(stdout,hd(fds));
2155 if (nonNull(cclass(cl).members)) {
2156 List ms = cclass(cl).members;
2159 Type t = name(hd(ms)).type;
2160 if (isPolyType(t)) {
2164 printExp(stdout,hd(ms));
2166 if (isNull(tl(fst(snd(t))))) {
2169 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2171 printType(stdout,t);
2173 } while (nonNull(ms));
2177 Printf("\n-- instances:\n");
2181 } while (nonNull(ins));
2186 if (nonNull(nm)) { /* as a function/name */
2188 printExp(stdout,nm);
2190 if (nonNull(name(nm).type)) {
2191 printType(stdout,name(nm).type);
2193 Printf("<unknown type>");
2196 Printf(" -- data constructor");
2197 } else if (isMfun(nm)) {
2198 Printf(" -- class member");
2199 } else if (isSfun(nm)) {
2200 Printf(" -- selector function");
2206 if (isNull(tc) && isNull(cl) && isNull(nm)) {
2207 Printf("Unknown reference `%s'\n",textToStr(t));
2211 static Void local printSyntax(nm)
2213 Syntax sy = syntaxOf(nm);
2214 Text t = name(nm).text;
2215 String s = textToStr(t);
2216 if (sy != defaultSyntax(t)) {
2218 switch (assocOf(sy)) {
2219 case LEFT_ASS : Putchar('l'); break;
2220 case RIGHT_ASS : Putchar('r'); break;
2221 case NON_ASS : break;
2223 Printf(" %i ",precOf(sy));
2224 if (isascii((int)(*s)) && isalpha((int)(*s))) {
2233 static Void local showInst(in) /* Display instance decl header */
2235 Printf("instance ");
2236 if (nonNull(inst(in).specifics)) {
2237 printContext(stdout,inst(in).specifics);
2240 printPred(stdout,inst(in).head);
2244 /* --------------------------------------------------------------------------
2245 * List all names currently in scope:
2246 * ------------------------------------------------------------------------*/
2248 static Void local listNames() { /* list names matching optional pat*/
2249 String pat = readFilename();
2251 Int width = getTerminalWidth() - 1;
2254 Module mod = currentModule;
2256 if (pat) { /* First gather names to list */
2258 names = addNamesMatching(pat,names);
2259 } while ((pat=readFilename())!=0);
2261 names = addNamesMatching((String)0,names);
2263 if (isNull(names)) { /* Then print them out */
2264 ERRMSG(0) "No names selected"
2268 for (termPos=0; nonNull(names); names=tl(names)) {
2269 String s = objToStr(mod,hd(names));
2271 if (termPos+1+l>width) {
2274 } else if (termPos>0) {
2282 Printf("\n(%d names listed)\n", count);
2285 /* --------------------------------------------------------------------------
2286 * print a prompt and read a line of input:
2287 * ------------------------------------------------------------------------*/
2289 static Void local promptForInput(moduleName)
2290 String moduleName; {
2291 char promptBuffer[1000];
2293 /* This is portable but could overflow buffer */
2294 sprintf(promptBuffer,prompt,moduleName);
2296 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2297 * promptBuffer instead.
2299 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2300 /* Reset prompt to a safe default to avoid an infinite loop */
2302 prompt = strCopy("? ");
2303 internal("Combined prompt and evaluation module name too long");
2307 stringInput("main\0"); else
2308 consoleInput(promptBuffer);
2311 /* --------------------------------------------------------------------------
2312 * main read-eval-print loop, with error trapping:
2313 * ------------------------------------------------------------------------*/
2315 static Void local interpreter(argc,argv)/* main interpreter loop */
2319 List modConIds; /* :: [CONID] */
2323 setBreakAction ( HugsIgnoreBreak );
2324 modConIds = initialize(argc,argv); /* the initial modules to load */
2325 setBreakAction ( HugsIgnoreBreak );
2326 prelOK = loadThePrelude();
2327 if (combined) everybody(POSTPREL);
2331 fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2333 fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2337 loadActions(modConIds);
2340 for (; nonNull(modConIds); modConIds=tl(modConIds))
2341 if (!elemMG(hd(modConIds))) {
2343 "hugs +Q: compilation failed -- can't run `main'\n" );
2350 /* initialize calls startupHaskell, which trashes our signal handlers */
2351 setBreakAction ( HugsIgnoreBreak );
2356 everybody(RESET); /* reset to sensible initial state */
2358 promptForInput(textToStr(module(currentModule).text));
2360 cmd = readCommand(cmds, (Char)':', (Char)'!');
2362 case EDIT : editor();
2366 case LOAD : modConIds = NIL;
2367 while ((s=readFilename())!=0)
2368 modConIds = cons(mkCon(findText(s)),modConIds);
2369 loadActions(modConIds);
2372 case ALSO : modConIds = NIL;
2373 while ((s=readFilename())!=0)
2374 modConIds = cons(mkCon(findText(s)),modConIds);
2375 addActions(modConIds);
2378 case RELOAD : refreshActions(NIL);
2383 case EVAL : evaluator();
2385 case TYPEOF : showtype();
2387 case BROWSE : browse();
2389 #if EXPLAIN_INSTANCE_RESOLUTION
2390 case XPLAIN : xplain();
2393 case NAMES : listNames();
2397 case BADCMD : guidance();
2402 #ifdef CRUDE_PROFILING
2406 case SYSTEM : if (shellEsc(readLine()))
2407 Printf("Warning: Shell escape terminated abnormally\n");
2409 case CHGDIR : changeDir();
2413 case PNTVER: Printf("-- Hugs Version %s\n",
2416 case DUMP : dumpStg();
2419 case COLLECT: consGC = FALSE;
2422 Printf("Garbage collection recovered %d cells\n",
2428 if (autoMain) break;
2432 /* --------------------------------------------------------------------------
2433 * Display progress towards goal:
2434 * ------------------------------------------------------------------------*/
2436 static Target currTarget;
2437 static Bool aiming = FALSE;
2440 static Int charCount;
2442 Void setGoal(what, t) /* Set goal for what to be t */
2447 #if EXPLAIN_INSTANCE_RESOLUTION
2451 currTarget = (t?t:1);
2454 currPos = strlen(what);
2455 maxPos = getTerminalWidth() - 1;
2459 for (charCount=0; *what; charCount++)
2464 Void soFar(t) /* Indicate progress towards goal */
2465 Target t; { /* has now reached t */
2468 #if EXPLAIN_INSTANCE_RESOLUTION
2473 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2478 if (newPos>currPos) {
2481 while (newPos>++currPos);
2488 Void done() { /* Goal has now been achieved */
2491 #if EXPLAIN_INSTANCE_RESOLUTION
2496 while (maxPos>currPos++)
2501 for (; charCount>0; charCount--) {
2510 static Void local failed() { /* Goal cannot be reached due to */
2511 if (aiming) { /* errors */
2518 /* --------------------------------------------------------------------------
2520 * ------------------------------------------------------------------------*/
2522 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
2523 if (printing) { /* after successful termination or */
2524 printing = FALSE; /* runtime error (e.g. interrupt) */
2527 #define plural(v) v, (v==1?"":"s")
2528 Printf("%lu cell%s",plural(numCells));
2530 Printf(", %u garbage collection%s",plural(numGcs));
2539 Cell errAssert(l) /* message to use when raising asserts, etc */
2544 str = mkStr(findText(currentFile));
2546 str = mkStr(findText(""));
2548 return (ap2(nameTangleMessage,str,mkInt(l)));
2551 Void errHead(l) /* print start of error message */
2553 failed(); /* failed to reach target ... */
2555 FPrintf(errorStream,"ERROR");
2558 FPrintf(errorStream," \"%s\"", currentFile);
2559 setLastEdit(currentFile,l);
2560 if (l) FPrintf(errorStream," (line %d)",l);
2563 FPrintf(errorStream,": ");
2564 FFlush(errorStream);
2567 Void errFail() { /* terminate error message and */
2568 Putc('\n',errorStream); /* produce exception to return to */
2569 FFlush(errorStream); /* main command loop */
2570 longjmp(catch_error,1);
2573 Void errFail_no_longjmp() { /* terminate error message but */
2574 Putc('\n',errorStream); /* don't produce an exception */
2575 FFlush(errorStream);
2578 Void errAbort() { /* altern. form of error handling */
2579 failed(); /* used when suitable error message*/
2580 stopAnyPrinting(); /* has already been printed */
2584 Void internal(msg) /* handle internal error */
2588 Printf("INTERNAL ERROR: %s\n",msg);
2591 longjmp(catch_error,1);
2594 Void fatal(msg) /* handle fatal error */
2597 Printf("\nFATAL ERROR: %s\n",msg);
2603 /* --------------------------------------------------------------------------
2604 * Read value from environment variable or registry:
2605 * ------------------------------------------------------------------------*/
2607 String fromEnv(var,def) /* return value of: */
2608 String var; /* environment variable named by var */
2609 String def; { /* or: default value given by def */
2610 String s = getenv(var);
2611 return (s ? s : def);
2614 /* --------------------------------------------------------------------------
2615 * String manipulation routines:
2616 * ------------------------------------------------------------------------*/
2618 static String local strCopy(s) /* make malloced copy of a string */
2622 if ((t=(char *)malloc(strlen(s)+1))==0) {
2623 ERRMSG(0) "String storage space exhausted"
2626 for (r=t; (*r++ = *s++)!=0; ) {
2633 /* --------------------------------------------------------------------------
2635 * We can redirect compiler output (prompts, error messages, etc) by
2636 * tweaking these functions.
2637 * ------------------------------------------------------------------------*/
2639 /* --------------------------------------------------------------------------
2640 * Send message to each component of system:
2641 * ------------------------------------------------------------------------*/
2643 Void everybody(what) /* send command `what' to each component of*/
2644 Int what; { /* system to respond as appropriate ... */
2646 fprintf ( stderr, "EVERYBODY %d\n", what );
2648 machdep(what); /* The order of calling each component is */
2649 storage(what); /* important for the PREPREL command */
2652 translateControl(what);
2654 staticAnalysis(what);
2655 deriveControl(what);
2661 /*-------------------------------------------------------------------------*/