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/30 12:04:13 $
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 */
909 if (mT != textPrelude)
910 usesT = cons(textPrelude,usesT);
911 adjList = cons(pair(mT,usesT),adjList);
914 /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
915 Modify this so that the adjacency list is a list of pointers
916 back to bits of adjList -- that's what modScc needs.
918 for (t = adjList; nonNull(t); t=tl(t)) {
920 /* for each elem of the adjacency list ... */
921 for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
924 /* find the element of adjList whose fst is a */
925 for (v = adjList; nonNull(v); v=tl(v)) {
927 assert(isText(fst(hd(v))));
928 if (fst(hd(v))==a) break;
930 if (isNull(v)) internal("mgFromList");
931 adj = cons(hd(v),adj);
936 adjList = modScc ( adjList );
937 /* adjList is now [ [(module-text, aux-info-field)] ] */
941 for (t = adjList; nonNull(t); t=tl(t)) {
944 /* scc :: [ (module-text, aux-info-field) ] */
945 for (u = scc; nonNull(u); u=tl(u))
946 hd(u) = mkCon(fst(hd(u)));
949 if (length(scc) > 1) {
952 /* singleton module in scc; does it import itself? */
953 mod = findModule ( textOf(hd(scc)) );
954 assert(nonNull(mod));
956 for (u = module(mod).uses; nonNull(u); u=tl(u))
957 if (textOf(hd(u))==textOf(hd(scc)))
962 moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
963 moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
965 moduleGraph = reverse(moduleGraph);
969 static List /* of CONID */ getModuleImports ( Cell tree )
975 for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
979 use = zfst(unap(M_IMPORT_Q,te));
981 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
984 use = zfst(unap(M_IMPORT_UNQ,te));
986 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
996 static void processModule ( Module m )
1012 unqualImports = NIL;
1013 foreignImports = NIL;
1014 foreignExports = NIL;
1021 tree = unap(M_MODULE,module(m).tree);
1022 modNm = zfst3(tree);
1023 assert(textOf(modNm)==module(m).text); /* wrong, but ... */
1024 setExportList(zsnd3(tree));
1025 topEnts = zthd3(tree);
1027 for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
1029 assert(isGenPair(te));
1031 switch(whatIs(te)) {
1033 addQualImport(zfst(te2),zsnd(te2));
1036 addUnqualImport(zfst(te2),zsnd(te2));
1039 tyconDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
1042 classDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
1045 instDefn(zfst3(te2),zsnd3(te2),zthd3(te2));
1048 defaultDefn(zfst(te2),zsnd(te2));
1051 foreignImport(zsel15(te2),zsel25(te2),zsel35(te2),
1052 zsel45(te2),zsel55(te2));
1055 foreignExport(zsel15(te2),zsel25(te2),zsel35(te2),
1056 zsel45(te2),zsel55(te2));
1058 valDefns = cons(te2,valDefns);
1061 internal("processModule");
1070 static Module parseModuleOrInterface ( ConId mc,
1071 List renewFromSource,
1072 List renewFromObject )
1074 /* Allocate a module-table entry. */
1075 /* Parse the entity and fill in the .tree and .uses entries. */
1078 Bool sAvail; Time sTime; Long sSize;
1079 Bool iAvail; Time iTime; Long iSize;
1080 Bool oAvail; Time oTime; Long oSize;
1085 Text mt = textOf(mc);
1086 Module mod = findModule ( mt );
1088 /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
1089 textToStr(mt),mod); */
1090 if (nonNull(mod) && !module(mod).fake)
1091 internal("parseModuleOrInterface");
1093 module(mod).fake = FALSE;
1096 mod = newModule(mt);
1098 /* This call malloc-ates path; we should deallocate it. */
1099 ok = findFilesForModule (
1100 textToStr(module(mod).text),
1103 &sAvail, &sTime, &sSize,
1104 &iAvail, &iTime, &iSize,
1105 &oAvail, &oTime, &oSize
1108 if (!ok) goto cant_find;
1109 if (!sAvail && !(iAvail && oAvail)) goto cant_find;
1111 /* Find out whether to use source or object. */
1112 if (varIsMember(mt,renewFromSource)) {
1113 if (!sAvail) goto cant_find;
1116 if (varIsMember(mt,renewFromObject)) {
1117 if (!(oAvail && iAvail)) goto cant_find;
1120 if (sAvail && !(iAvail && oAvail)) {
1123 if (!sAvail && (iAvail && oAvail)) {
1126 useSource = firstTimeIsLater(sTime,whicheverIsLater(oTime,iTime));
1129 if (!combined && !sAvail) goto cant_find;
1130 if (!combined) useSource = TRUE;
1132 module(mod).srcExt = findText(sExt);
1133 setCurrentFile(mod);
1135 /* Actually do the parsing. */
1138 strcat(name, textToStr(mt));
1140 module(mod).tree = parseModule(name,sSize);
1141 module(mod).uses = getModuleImports(module(mod).tree);
1142 module(mod).fromSrc = TRUE;
1143 module(mod).lastStamp = sTime;
1146 strcat(name, textToStr(mt));
1147 strcat(name, DLL_ENDING);
1148 module(mod).objName = findText(name);
1149 module(mod).objSize = oSize;
1151 strcat(name, textToStr(mt));
1152 strcat(name, ".u_hi");
1153 module(mod).tree = parseInterface(name,iSize);
1154 module(mod).uses = getInterfaceImports(module(mod).tree);
1155 module(mod).fromSrc = FALSE;
1156 module(mod).lastStamp = whicheverIsLater(oTime,iTime);
1159 if (path) free(path);
1163 if (path) free(path);
1165 "Can't find source or object+interface for module \"%s\"",
1171 static void tryLoadGroup ( Cell grp )
1175 switch (whatIs(grp)) {
1177 m = findModule(textOf(snd(grp)));
1179 if (module(m).fromSrc) {
1180 processModule ( m );
1182 processInterfaces ( singleton(snd(grp)) );
1186 for (t = snd(grp); nonNull(t); t=tl(t)) {
1187 m = findModule(textOf(hd(t)));
1189 if (module(m).fromSrc) {
1190 ERRMSG(0) "Source module \"%s\" imports itself recursively",
1191 textToStr(textOf(hd(t)))
1195 processInterfaces ( snd(grp) );
1198 internal("tryLoadGroup");
1203 static void fallBackToPrelModules ( void )
1206 for (m = MODULE_BASE_ADDR;
1207 m < MODULE_BASE_ADDR+tabModuleSz; m++)
1209 && !varIsMember(module(m).text, prelModules))
1214 /* This function catches exceptions in most of the system.
1215 So it's only ok for procedures called from this one
1216 to do EENDs (ie, write error messages). Others should use
1219 static void achieveTargetModules ( void )
1222 volatile List modgList;
1223 volatile List renewFromSource;
1224 volatile List renewFromObject;
1226 volatile Module mod;
1231 Bool sAvail; Time sTime; Long sSize;
1232 Bool iAvail; Time iTime; Long iSize;
1233 Bool oAvail; Time oTime; Long oSize;
1235 volatile Time oisTime;
1236 volatile Time oiTime;
1237 volatile Bool sourceIsLatest;
1238 volatile Bool out_of_date;
1239 volatile List ood_new;
1241 volatile List modgList_new;
1242 volatile List parsedButNotLoaded;
1243 volatile List toChase;
1244 volatile List trans_cl;
1245 volatile List trans_cl_new;
1250 volatile List badMods;
1252 setBreakAction ( HugsIgnoreBreak );
1254 /* First, examine timestamps to find out which modules are
1255 out of date with respect to the source/interface/object files.
1258 modgList = listFromMG();
1260 renewFromSource = renewFromObject = NIL;
1262 for (t = modgList; nonNull(t); t=tl(t)) {
1264 if (varIsMember(textOf(hd(t)),prelModules))
1267 mod = findModule(textOf(hd(t)));
1268 if (isNull(mod)) internal("achieveTargetSet(1)");
1270 ok = findFilesForModule (
1271 textToStr(module(mod).text),
1274 &sAvail, &sTime, &sSize,
1275 &iAvail, &iTime, &iSize,
1276 &oAvail, &oTime, &oSize
1278 if (!combined && !sAvail) ok = FALSE;
1280 fallBackToPrelModules();
1282 "Can't find source or object+interface for module \"%s\"",
1283 textToStr(module(mod).text)
1285 if (path) free(path);
1288 /* findFilesForModule should enforce this */
1289 if (!(sAvail || (oAvail && iAvail)))
1290 internal("achieveTargetSet(2)");
1294 sourceIsLatest = TRUE;
1296 if (sAvail && !(oAvail && iAvail)) {
1298 sourceIsLatest = TRUE;
1300 if (!sAvail && (oAvail && iAvail)) {
1301 oisTime = whicheverIsLater(oTime,iTime);
1302 sourceIsLatest = FALSE;
1304 if (sAvail && (oAvail && iAvail)) {
1305 oisTime = whicheverIsLater(oTime,iTime);
1306 if (firstTimeIsLater(sTime,oisTime)) {
1308 sourceIsLatest = TRUE;
1310 sourceIsLatest = FALSE;
1313 internal("achieveTargetSet(1a)");
1317 out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
1319 assert(!varIsMember(textOf(hd(t)),ood));
1320 ood = cons(hd(t),ood);
1322 renewFromSource = cons(hd(t),renewFromSource); else
1323 renewFromObject = cons(hd(t),renewFromObject);
1326 if (path) { free(path); path = NULL; };
1329 /* Second, form a simplistic transitive closure of the out-of-date
1330 modules: a module is out of date if it imports an out-of-date
1335 for (t = modgList; nonNull(t); t=tl(t)) {
1336 mod = findModule(textOf(hd(t)));
1337 assert(nonNull(mod));
1338 for (us = module(mod).uses; nonNull(us); us=tl(us))
1339 if (varIsMember(textOf(hd(us)),ood))
1342 if (varIsMember(textOf(hd(t)),prelModules))
1343 Printf ( "warning: prelude module \"%s\" is out-of-date\n",
1344 textToStr(textOf(hd(t))) );
1346 if (!varIsMember(textOf(hd(t)),ood_new) &&
1347 !varIsMember(textOf(hd(t)),ood))
1348 ood_new = cons(hd(t),ood_new);
1351 if (isNull(ood_new)) break;
1352 ood = appendOnto(ood_new,ood);
1355 /* Now ood holds the entire set of modules which are out-of-date.
1356 Throw them out of the system, yielding a "reduced system",
1357 in which the remaining modules are in-date.
1359 for (t = ood; nonNull(t); t=tl(t)) {
1360 mod = findModule(textOf(hd(t)));
1361 assert(nonNull(mod));
1365 for (t = modgList; nonNull(t); t=tl(t))
1366 if (!varIsMember(textOf(hd(t)),ood))
1367 modgList_new = cons(hd(t),modgList_new);
1368 modgList = modgList_new;
1370 /* Update the module group list to reflect the reduced system.
1371 We do this so that if the following parsing phases fail, we can
1372 safely fall back to the reduced system.
1374 mgFromList ( modgList );
1376 /* Parse modules/interfaces, collecting parse trees and chasing
1377 imports, starting from the target set.
1379 parsedButNotLoaded = NIL;
1380 toChase = dupList(targetModules);
1382 while (nonNull(toChase)) {
1383 ConId mc = hd(toChase);
1384 toChase = tl(toChase);
1385 if (!varIsMember(textOf(mc),modgList)
1386 && !varIsMember(textOf(mc),parsedButNotLoaded)) {
1388 setBreakAction ( HugsLongjmpOnBreak );
1389 if (setjmp(catch_error)==0) {
1390 /* try this; it may throw an exception */
1391 mod = parseModuleOrInterface (
1392 mc, renewFromSource, renewFromObject );
1394 /* here's the exception handler, if parsing fails */
1395 /* A parse error (or similar). Clean up and abort. */
1396 setBreakAction ( HugsIgnoreBreak );
1397 mod = findModule(textOf(mc));
1398 if (nonNull(mod)) nukeModule(mod);
1399 for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
1400 mod = findModule(textOf(hd(t)));
1401 assert(nonNull(mod));
1402 if (nonNull(mod)) nukeModule(mod);
1405 /* end of the exception handler */
1407 setBreakAction ( HugsIgnoreBreak );
1409 parsedButNotLoaded = cons(mc, parsedButNotLoaded);
1410 toChase = dupOnto(module(mod).uses,toChase);
1414 modgList = dupOnto(parsedButNotLoaded, modgList);
1416 /* We successfully parsed all modules reachable from the target
1417 set which were not part of the reduced system. However, there
1418 may be modules in the reduced system which are not reachable from
1419 the target set. We detect these now by building the transitive
1420 closure of the target set, and nuking modules in the reduced
1421 system which are not part of that closure.
1423 trans_cl = dupList(targetModules);
1426 for (t = trans_cl; nonNull(t); t=tl(t)) {
1427 mod = findModule(textOf(hd(t)));
1428 assert(nonNull(mod));
1429 for (u = module(mod).uses; nonNull(u); u=tl(u))
1430 if (!varIsMember(textOf(hd(u)),trans_cl)
1431 && !varIsMember(textOf(hd(u)),trans_cl_new)
1432 && !varIsMember(textOf(hd(u)),prelModules))
1433 trans_cl_new = cons(hd(u),trans_cl_new);
1435 if (isNull(trans_cl_new)) break;
1436 trans_cl = appendOnto(trans_cl_new,trans_cl);
1439 for (t = modgList; nonNull(t); t=tl(t)) {
1440 if (varIsMember(textOf(hd(t)),trans_cl)) {
1441 modgList_new = cons(hd(t),modgList_new);
1443 mod = findModule(textOf(hd(t)));
1444 assert(nonNull(mod));
1448 modgList = modgList_new;
1450 /* Now, the module symbol tables hold exactly the set of
1451 modules reachable from the target set, and modgList holds
1452 their names. Calculate the scc-ified module graph,
1453 since we need that to guide the next stage, that of
1454 Actually Loading the modules.
1456 If no errors occur, moduleGraph will reflect the final graph
1457 loaded. If an error occurs loading a group, we nuke
1458 that group, truncate the moduleGraph just prior to that
1459 group, and exit. That leaves the system having successfully
1460 loaded all groups prior to the one which failed.
1462 mgFromList ( modgList );
1464 for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
1467 if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
1468 parsedButNotLoaded)) continue;
1470 setBreakAction ( HugsLongjmpOnBreak );
1471 if (setjmp(catch_error)==0) {
1472 /* try this; it may throw an exception */
1475 /* here's the exception handler, if static/typecheck etc fails */
1476 /* nuke the entire rest (ie, the unloaded part)
1477 of the module graph */
1478 setBreakAction ( HugsIgnoreBreak );
1479 badMods = listFromSpecifiedMG ( mg );
1480 for (t = badMods; nonNull(t); t=tl(t)) {
1481 mod = findModule(textOf(hd(t)));
1482 if (nonNull(mod)) nukeModule(mod);
1484 /* truncate the module graph just prior to this group. */
1488 if (isNull(mg)) break;
1489 if (hd(mg) == grp) break;
1490 mg2 = cons ( hd(mg), mg2 );
1493 moduleGraph = reverse(mg2);
1495 /* end of the exception handler */
1497 setBreakAction ( HugsIgnoreBreak );
1500 /* Err .. I think that's it. If we get here, we've successfully
1501 achieved the target set. Phew!
1503 setBreakAction ( HugsIgnoreBreak );
1507 static Bool loadThePrelude ( void )
1512 moduleGraph = prelModules = NIL;
1515 conPrelude = mkCon(findText("Prelude"));
1516 conPrelHugs = mkCon(findText("PrelHugs"));
1517 targetModules = doubleton(conPrelude,conPrelHugs);
1518 achieveTargetModules();
1519 ok = elemMG(conPrelude) && elemMG(conPrelHugs);
1521 conPrelude = mkCon(findText("Prelude"));
1522 targetModules = singleton(conPrelude);
1523 achieveTargetModules();
1524 ok = elemMG(conPrelude);
1527 if (ok) prelModules = listFromMG();
1532 static void refreshActions ( ConId nextCurrMod )
1534 ConId tryFor = mkCon(module(currentModule).text);
1535 achieveTargetModules();
1536 if (nonNull(nextCurrMod))
1537 tryFor = nextCurrMod;
1538 if (!elemMG(tryFor))
1539 tryFor = selectLatestMG();
1540 /* combined mode kludge, to get Prelude rather than PrelHugs */
1541 if (combined && textOf(tryFor)==findText("PrelHugs"))
1542 tryFor = mkCon(findText("Prelude"));
1544 setCurrModule ( findModule(textOf(tryFor)) );
1545 Printf("Hugs session for:\n");
1550 static void addActions ( List extraModules /* :: [CONID] */ )
1553 for (t = extraModules; nonNull(t); t=tl(t)) {
1554 ConId extra = hd(t);
1555 if (!varIsMember(textOf(extra),targetModules))
1556 targetModules = cons(extra,targetModules);
1558 refreshActions ( isNull(extraModules)
1560 : hd(reverse(extraModules))
1565 static void loadActions ( List loadModules /* :: [CONID] */ )
1568 targetModules = dupList ( prelModules );
1570 for (t = loadModules; nonNull(t); t=tl(t)) {
1572 if (!varIsMember(textOf(load),targetModules))
1573 targetModules = cons(load,targetModules);
1575 refreshActions ( isNull(loadModules)
1577 : hd(reverse(loadModules))
1582 /* --------------------------------------------------------------------------
1583 * Access to external editor:
1584 * ------------------------------------------------------------------------*/
1586 /* ToDo: All this editor stuff needs fixing. */
1588 static Void local editor() { /* interpreter-editor interface */
1590 String newFile = readFilename();
1592 setLastEdit(newFile,0);
1593 if (readFilename()) {
1594 ERRMSG(0) "Multiple filenames not permitted"
1602 static Void local find() { /* edit file containing definition */
1605 String nm = readFilename(); /* of specified name */
1607 ERRMSG(0) "No name specified"
1610 else if (readFilename()) {
1611 ERRMSG(0) "Multiple names not permitted"
1617 setCurrModule(findEvalModule());
1619 if (nonNull(c=findTycon(t=findText(nm)))) {
1620 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1621 readScripts(N_PRELUDE_SCRIPTS);
1623 } else if (nonNull(c=findName(t))) {
1624 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1625 readScripts(N_PRELUDE_SCRIPTS);
1628 ERRMSG(0) "No current definition for name \"%s\"", nm
1635 static Void local runEditor() { /* run editor on script lastEdit */
1637 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1638 readScripts(N_PRELUDE_SCRIPTS);
1642 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1648 lastEdit = strCopy(fname);
1653 /* --------------------------------------------------------------------------
1654 * Read and evaluate an expression:
1655 * ------------------------------------------------------------------------*/
1657 static Void setModule ( void ) {
1658 /*set module in which to evaluate expressions*/
1661 String s = readFilename();
1663 mc = selectLatestMG();
1664 if (combined && textOf(mc)==findText("PrelHugs"))
1665 mc = mkCon(findText("Prelude"));
1666 m = findModule(textOf(mc));
1669 m = findModule(findText(s));
1671 ERRMSG(0) "Cannot find module \"%s\"", s
1679 static Module allocEvalModule ( void )
1681 Module evalMod = newModule( findText("_Eval_Module_") );
1682 module(evalMod).names = module(currentModule).names;
1683 module(evalMod).tycons = module(currentModule).tycons;
1684 module(evalMod).classes = module(currentModule).classes;
1688 static Void local evaluator() { /* evaluate expr and print value */
1691 volatile Kinds ks = NIL;
1692 volatile Module evalMod = allocEvalModule();
1693 volatile Module currMod = currentModule;
1694 setCurrModule(evalMod);
1697 defaultDefns = combined ? stdDefaults : evalDefaults;
1699 setBreakAction ( HugsLongjmpOnBreak );
1700 if (setjmp(catch_error)==0) {
1704 type = typeCheckExp(TRUE);
1706 /* if an exception happens, we arrive here */
1707 setBreakAction ( HugsIgnoreBreak );
1708 goto cleanup_and_return;
1711 setBreakAction ( HugsIgnoreBreak );
1712 if (isPolyType(type)) {
1713 ks = polySigOf(type);
1714 bd = monotypeOf(type);
1719 if (whatIs(bd)==QUAL) {
1720 ERRMSG(0) "Unresolved overloading" ETHEN
1721 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1722 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1725 goto cleanup_and_return;
1729 if (isProgType(ks,bd)) {
1730 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1734 Cell d = provePred(ks,NIL,ap(classShow,bd));
1736 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1737 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1738 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1741 goto cleanup_and_return;
1743 inputExpr = ap2(nameShow, d,inputExpr);
1744 inputExpr = ap (namePutStr, inputExpr);
1745 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1747 evalExp(); printf("\n");
1750 printType(stdout,type);
1757 printf ( "result type is " );
1758 printType ( stdout, type );
1766 setBreakAction ( HugsIgnoreBreak );
1767 nukeModule(evalMod);
1768 setCurrModule(currMod);
1769 setCurrentFile(currMod);
1774 /* --------------------------------------------------------------------------
1775 * Print type of input expression:
1776 * ------------------------------------------------------------------------*/
1778 static Void showtype ( void ) { /* print type of expression (if any)*/
1781 volatile Module evalMod = allocEvalModule();
1782 volatile Module currMod = currentModule;
1783 setCurrModule(evalMod);
1785 if (setjmp(catch_error)==0) {
1789 defaultDefns = evalDefaults;
1790 type = typeCheckExp(FALSE);
1791 printExp(stdout,inputExpr);
1793 printType(stdout,type);
1796 /* if an exception happens, we arrive here */
1799 nukeModule(evalMod);
1800 setCurrModule(currMod);
1804 static Void local browseit(mod,t,all)
1811 Printf("module %s where\n",textToStr(module(mod).text));
1812 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1814 /* only look at things defined in this module,
1815 unless `all' flag is set */
1816 if (all || name(nm).mod == mod) {
1817 /* unwanted artifacts, like lambda lifted values,
1818 are in the list of names, but have no types */
1819 if (nonNull(name(nm).type)) {
1820 printExp(stdout,nm);
1822 printType(stdout,name(nm).type);
1824 Printf(" -- data constructor");
1825 } else if (isMfun(nm)) {
1826 Printf(" -- class member");
1827 } else if (isSfun(nm)) {
1828 Printf(" -- selector function");
1836 Printf("Unknown module %s\n",t);
1841 static Void local browse() { /* browse modules */
1842 Int count = 0; /* or give menu of commands */
1846 for (; (s=readFilename())!=0; count++)
1847 if (strcmp(s,"all") == 0) {
1851 browseit(findModule(findText(s)),s,all);
1853 browseit(currentModule,NULL,all);
1857 #if EXPLAIN_INSTANCE_RESOLUTION
1858 static Void local xplain() { /* print type of expression (if any)*/
1860 Bool sir = showInstRes;
1862 setCurrModule(findEvalModule());
1863 startNewScript(0); /* Enables recovery of storage */
1864 /* allocated during evaluation */
1868 d = provePred(NIL,NIL,hd(inputContext));
1870 fprintf(stdout, "not Sat\n");
1872 fprintf(stdout, "Sat\n");
1878 /* --------------------------------------------------------------------------
1879 * Enhanced help system: print current list of scripts or give information
1881 * ------------------------------------------------------------------------*/
1883 static String local objToStr(m,c)
1886 #if 1 || DISPLAY_QUANTIFIERS
1887 static char newVar[60];
1888 switch (whatIs(c)) {
1889 case NAME : if (m == name(c).mod) {
1890 sprintf(newVar,"%s", textToStr(name(c).text));
1892 sprintf(newVar,"%s.%s",
1893 textToStr(module(name(c).mod).text),
1894 textToStr(name(c).text));
1898 case TYCON : if (m == tycon(c).mod) {
1899 sprintf(newVar,"%s", textToStr(tycon(c).text));
1901 sprintf(newVar,"%s.%s",
1902 textToStr(module(tycon(c).mod).text),
1903 textToStr(tycon(c).text));
1907 case CLASS : if (m == cclass(c).mod) {
1908 sprintf(newVar,"%s", textToStr(cclass(c).text));
1910 sprintf(newVar,"%s.%s",
1911 textToStr(module(cclass(c).mod).text),
1912 textToStr(cclass(c).text));
1916 default : internal("objToStr");
1920 static char newVar[33];
1921 switch (whatIs(c)) {
1922 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1925 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1928 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1931 default : internal("objToStr");
1939 static Void dumpStg ( void )
1945 setCurrModule(findEvalModule());
1950 /* request to locate a symbol by name */
1951 if (s && (*s == '?')) {
1952 Text t = findText(s+1);
1953 locateSymbolByName(t);
1957 /* request to dump a bit of the heap */
1958 if (s && (*s == '-' || isdigit(*s))) {
1965 /* request to dump a symbol table entry */
1967 || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
1968 || !isdigit(s[1])) {
1969 fprintf(stderr, ":d -- bad request `%s'\n", s );
1974 case 't': dumpTycon(i); break;
1975 case 'n': dumpName(i); break;
1976 case 'c': dumpClass(i); break;
1977 case 'i': dumpInst(i); break;
1978 default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
1984 static Void local dumpStg( void ) { /* print STG stuff */
1989 Cell v; /* really StgVar */
1990 setCurrModule(findEvalModule());
1992 for (; (s=readFilename())!=0;) {
1995 /* find the name while ignoring module scopes */
1996 for (i=NAMEMIN; i<nameHw; i++)
1997 if (name(i).text == t) n = i;
1999 /* perhaps it's an "idNNNNNN" thing? */
2002 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2005 while (isdigit(s[i])) {
2006 v = v * 10 + (s[i]-'0');
2010 n = nameFromStgVar(v);
2013 if (isNull(n) && whatIs(v)==STGVAR) {
2014 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2015 printStg(stderr, v );
2018 Printf ( "Unknown reference `%s'\n", s );
2021 Printf ( "Not a Name: `%s'\n", s );
2023 if (isNull(name(n).stgVar)) {
2024 Printf ( "Doesn't have a STG tree: %s\n", s );
2026 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2027 printStg(stderr, name(n).stgVar);
2033 static Void local info() { /* describe objects */
2034 Int count = 0; /* or give menu of commands */
2037 for (; (s=readFilename())!=0; count++) {
2038 describe(findText(s));
2041 /* whatScripts(); */
2046 static Void local describe(t) /* describe an object */
2048 Tycon tc = findTycon(t);
2049 Class cl = findClass(t);
2050 Name nm = findName(t);
2052 if (nonNull(tc)) { /* as a type constructor */
2056 for (i=0; i<tycon(tc).arity; ++i) {
2057 t = ap(t,mkOffset(i));
2059 Printf("-- type constructor");
2061 Printf(" with kind ");
2062 printKind(stdout,tycon(tc).kind);
2065 switch (tycon(tc).what) {
2066 case SYNONYM : Printf("type ");
2067 printType(stdout,t);
2069 printType(stdout,tycon(tc).defn);
2073 case DATATYPE : { List cs = tycon(tc).defn;
2074 if (tycon(tc).what==DATATYPE) {
2079 printType(stdout,t);
2081 mapProc(printSyntax,cs);
2083 Printf("\n-- constructors:");
2085 for (; hasCfun(cs); cs=tl(cs)) {
2087 printExp(stdout,hd(cs));
2089 printType(stdout,name(hd(cs)).type);
2092 Printf("\n-- selectors:");
2094 for (; nonNull(cs); cs=tl(cs)) {
2096 printExp(stdout,hd(cs));
2098 printType(stdout,name(hd(cs)).type);
2103 case RESTRICTSYN : Printf("type ");
2104 printType(stdout,t);
2105 Printf(" = <restricted>");
2109 if (nonNull(in=findFirstInst(tc))) {
2110 Printf("\n-- instances:\n");
2113 in = findNextInst(tc,in);
2114 } while (nonNull(in));
2119 if (nonNull(cl)) { /* as a class */
2120 List ins = cclass(cl).instances;
2121 Kinds ks = cclass(cl).kinds;
2122 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2123 Printf("-- type class");
2125 Printf("-- constructor class");
2127 Printf(" with arity ");
2128 printKinds(stdout,ks);
2132 mapProc(printSyntax,cclass(cl).members);
2134 if (nonNull(cclass(cl).supers)) {
2135 printContext(stdout,cclass(cl).supers);
2138 printPred(stdout,cclass(cl).head);
2140 if (nonNull(cclass(cl).fds)) {
2141 List fds = cclass(cl).fds;
2143 for (; nonNull(fds); fds=tl(fds)) {
2145 printFD(stdout,hd(fds));
2150 if (nonNull(cclass(cl).members)) {
2151 List ms = cclass(cl).members;
2154 Type t = name(hd(ms)).type;
2155 if (isPolyType(t)) {
2159 printExp(stdout,hd(ms));
2161 if (isNull(tl(fst(snd(t))))) {
2164 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2166 printType(stdout,t);
2168 } while (nonNull(ms));
2172 Printf("\n-- instances:\n");
2176 } while (nonNull(ins));
2181 if (nonNull(nm)) { /* as a function/name */
2183 printExp(stdout,nm);
2185 if (nonNull(name(nm).type)) {
2186 printType(stdout,name(nm).type);
2188 Printf("<unknown type>");
2191 Printf(" -- data constructor");
2192 } else if (isMfun(nm)) {
2193 Printf(" -- class member");
2194 } else if (isSfun(nm)) {
2195 Printf(" -- selector function");
2201 if (isNull(tc) && isNull(cl) && isNull(nm)) {
2202 Printf("Unknown reference `%s'\n",textToStr(t));
2206 static Void local printSyntax(nm)
2208 Syntax sy = syntaxOf(nm);
2209 Text t = name(nm).text;
2210 String s = textToStr(t);
2211 if (sy != defaultSyntax(t)) {
2213 switch (assocOf(sy)) {
2214 case LEFT_ASS : Putchar('l'); break;
2215 case RIGHT_ASS : Putchar('r'); break;
2216 case NON_ASS : break;
2218 Printf(" %i ",precOf(sy));
2219 if (isascii((int)(*s)) && isalpha((int)(*s))) {
2228 static Void local showInst(in) /* Display instance decl header */
2230 Printf("instance ");
2231 if (nonNull(inst(in).specifics)) {
2232 printContext(stdout,inst(in).specifics);
2235 printPred(stdout,inst(in).head);
2239 /* --------------------------------------------------------------------------
2240 * List all names currently in scope:
2241 * ------------------------------------------------------------------------*/
2243 static Void local listNames() { /* list names matching optional pat*/
2244 String pat = readFilename();
2246 Int width = getTerminalWidth() - 1;
2249 Module mod = currentModule;
2251 if (pat) { /* First gather names to list */
2253 names = addNamesMatching(pat,names);
2254 } while ((pat=readFilename())!=0);
2256 names = addNamesMatching((String)0,names);
2258 if (isNull(names)) { /* Then print them out */
2259 ERRMSG(0) "No names selected"
2263 for (termPos=0; nonNull(names); names=tl(names)) {
2264 String s = objToStr(mod,hd(names));
2266 if (termPos+1+l>width) {
2269 } else if (termPos>0) {
2277 Printf("\n(%d names listed)\n", count);
2280 /* --------------------------------------------------------------------------
2281 * print a prompt and read a line of input:
2282 * ------------------------------------------------------------------------*/
2284 static Void local promptForInput(moduleName)
2285 String moduleName; {
2286 char promptBuffer[1000];
2288 /* This is portable but could overflow buffer */
2289 sprintf(promptBuffer,prompt,moduleName);
2291 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2292 * promptBuffer instead.
2294 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2295 /* Reset prompt to a safe default to avoid an infinite loop */
2297 prompt = strCopy("? ");
2298 internal("Combined prompt and evaluation module name too long");
2302 stringInput("main\0"); else
2303 consoleInput(promptBuffer);
2306 /* --------------------------------------------------------------------------
2307 * main read-eval-print loop, with error trapping:
2308 * ------------------------------------------------------------------------*/
2310 static Void local interpreter(argc,argv)/* main interpreter loop */
2314 List modConIds; /* :: [CONID] */
2318 setBreakAction ( HugsIgnoreBreak );
2319 modConIds = initialize(argc,argv); /* the initial modules to load */
2320 setBreakAction ( HugsIgnoreBreak );
2321 prelOK = loadThePrelude();
2322 if (combined) everybody(POSTPREL);
2326 fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2328 fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2332 loadActions(modConIds);
2335 for (; nonNull(modConIds); modConIds=tl(modConIds))
2336 if (!elemMG(hd(modConIds))) {
2338 "hugs +Q: compilation failed -- can't run `main'\n" );
2345 /* initialize calls startupHaskell, which trashes our signal handlers */
2346 setBreakAction ( HugsIgnoreBreak );
2351 everybody(RESET); /* reset to sensible initial state */
2353 promptForInput(textToStr(module(currentModule).text));
2355 cmd = readCommand(cmds, (Char)':', (Char)'!');
2357 case EDIT : editor();
2361 case LOAD : modConIds = NIL;
2362 while ((s=readFilename())!=0)
2363 modConIds = cons(mkCon(findText(s)),modConIds);
2364 loadActions(modConIds);
2367 case ALSO : modConIds = NIL;
2368 while ((s=readFilename())!=0)
2369 modConIds = cons(mkCon(findText(s)),modConIds);
2370 addActions(modConIds);
2373 case RELOAD : refreshActions(NIL);
2378 case EVAL : evaluator();
2380 case TYPEOF : showtype();
2382 case BROWSE : browse();
2384 #if EXPLAIN_INSTANCE_RESOLUTION
2385 case XPLAIN : xplain();
2388 case NAMES : listNames();
2392 case BADCMD : guidance();
2397 #ifdef CRUDE_PROFILING
2401 case SYSTEM : if (shellEsc(readLine()))
2402 Printf("Warning: Shell escape terminated abnormally\n");
2404 case CHGDIR : changeDir();
2408 case PNTVER: Printf("-- Hugs Version %s\n",
2411 case DUMP : dumpStg();
2414 case COLLECT: consGC = FALSE;
2417 Printf("Garbage collection recovered %d cells\n",
2423 if (autoMain) break;
2427 /* --------------------------------------------------------------------------
2428 * Display progress towards goal:
2429 * ------------------------------------------------------------------------*/
2431 static Target currTarget;
2432 static Bool aiming = FALSE;
2435 static Int charCount;
2437 Void setGoal(what, t) /* Set goal for what to be t */
2442 #if EXPLAIN_INSTANCE_RESOLUTION
2446 currTarget = (t?t:1);
2449 currPos = strlen(what);
2450 maxPos = getTerminalWidth() - 1;
2454 for (charCount=0; *what; charCount++)
2459 Void soFar(t) /* Indicate progress towards goal */
2460 Target t; { /* has now reached t */
2463 #if EXPLAIN_INSTANCE_RESOLUTION
2468 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2473 if (newPos>currPos) {
2476 while (newPos>++currPos);
2483 Void done() { /* Goal has now been achieved */
2486 #if EXPLAIN_INSTANCE_RESOLUTION
2491 while (maxPos>currPos++)
2496 for (; charCount>0; charCount--) {
2505 static Void local failed() { /* Goal cannot be reached due to */
2506 if (aiming) { /* errors */
2513 /* --------------------------------------------------------------------------
2515 * ------------------------------------------------------------------------*/
2517 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
2518 if (printing) { /* after successful termination or */
2519 printing = FALSE; /* runtime error (e.g. interrupt) */
2522 #define plural(v) v, (v==1?"":"s")
2523 Printf("%lu cell%s",plural(numCells));
2525 Printf(", %u garbage collection%s",plural(numGcs));
2534 Cell errAssert(l) /* message to use when raising asserts, etc */
2539 str = mkStr(findText(currentFile));
2541 str = mkStr(findText(""));
2543 return (ap2(nameTangleMessage,str,mkInt(l)));
2546 Void errHead(l) /* print start of error message */
2548 failed(); /* failed to reach target ... */
2550 FPrintf(errorStream,"ERROR");
2553 FPrintf(errorStream," \"%s\"", currentFile);
2554 setLastEdit(currentFile,l);
2555 if (l) FPrintf(errorStream," (line %d)",l);
2558 FPrintf(errorStream,": ");
2559 FFlush(errorStream);
2562 Void errFail() { /* terminate error message and */
2563 Putc('\n',errorStream); /* produce exception to return to */
2564 FFlush(errorStream); /* main command loop */
2565 longjmp(catch_error,1);
2568 Void errFail_no_longjmp() { /* terminate error message but */
2569 Putc('\n',errorStream); /* don't produce an exception */
2570 FFlush(errorStream);
2573 Void errAbort() { /* altern. form of error handling */
2574 failed(); /* used when suitable error message*/
2575 stopAnyPrinting(); /* has already been printed */
2579 Void internal(msg) /* handle internal error */
2583 Printf("INTERNAL ERROR: %s\n",msg);
2586 longjmp(catch_error,1);
2589 Void fatal(msg) /* handle fatal error */
2592 Printf("\nFATAL ERROR: %s\n",msg);
2598 /* --------------------------------------------------------------------------
2599 * Read value from environment variable or registry:
2600 * ------------------------------------------------------------------------*/
2602 String fromEnv(var,def) /* return value of: */
2603 String var; /* environment variable named by var */
2604 String def; { /* or: default value given by def */
2605 String s = getenv(var);
2606 return (s ? s : def);
2609 /* --------------------------------------------------------------------------
2610 * String manipulation routines:
2611 * ------------------------------------------------------------------------*/
2613 static String local strCopy(s) /* make malloced copy of a string */
2617 if ((t=(char *)malloc(strlen(s)+1))==0) {
2618 ERRMSG(0) "String storage space exhausted"
2621 for (r=t; (*r++ = *s++)!=0; ) {
2628 /* --------------------------------------------------------------------------
2630 * We can redirect compiler output (prompts, error messages, etc) by
2631 * tweaking these functions.
2632 * ------------------------------------------------------------------------*/
2634 /* --------------------------------------------------------------------------
2635 * Send message to each component of system:
2636 * ------------------------------------------------------------------------*/
2638 Void everybody(what) /* send command `what' to each component of*/
2639 Int what; { /* system to respond as appropriate ... */
2641 fprintf ( stderr, "EVERYBODY %d\n", what );
2643 machdep(what); /* The order of calling each component is */
2644 storage(what); /* important for the PREPREL command */
2647 translateControl(what);
2649 staticAnalysis(what);
2650 deriveControl(what);
2656 /*-------------------------------------------------------------------------*/