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/31 04:13:27 $
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;
1685 module(evalMod).qualImports
1686 = singleton(pair(mkCon(textPrelude),modulePrelude));
1690 static Void local evaluator() { /* evaluate expr and print value */
1693 volatile Kinds ks = NIL;
1694 volatile Module evalMod = allocEvalModule();
1695 volatile Module currMod = currentModule;
1696 setCurrModule(evalMod);
1699 defaultDefns = combined ? stdDefaults : evalDefaults;
1701 setBreakAction ( HugsLongjmpOnBreak );
1702 if (setjmp(catch_error)==0) {
1706 type = typeCheckExp(TRUE);
1708 /* if an exception happens, we arrive here */
1709 setBreakAction ( HugsIgnoreBreak );
1710 goto cleanup_and_return;
1713 setBreakAction ( HugsIgnoreBreak );
1714 if (isPolyType(type)) {
1715 ks = polySigOf(type);
1716 bd = monotypeOf(type);
1721 if (whatIs(bd)==QUAL) {
1722 ERRMSG(0) "Unresolved overloading" ETHEN
1723 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1724 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1727 goto cleanup_and_return;
1731 if (isProgType(ks,bd)) {
1732 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1736 Cell d = provePred(ks,NIL,ap(classShow,bd));
1738 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1739 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1740 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1743 goto cleanup_and_return;
1745 inputExpr = ap2(nameShow, d,inputExpr);
1746 inputExpr = ap (namePutStr, inputExpr);
1747 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1749 evalExp(); printf("\n");
1752 printType(stdout,type);
1759 printf ( "result type is " );
1760 printType ( stdout, type );
1768 setBreakAction ( HugsIgnoreBreak );
1769 nukeModule(evalMod);
1770 setCurrModule(currMod);
1771 setCurrentFile(currMod);
1776 /* --------------------------------------------------------------------------
1777 * Print type of input expression:
1778 * ------------------------------------------------------------------------*/
1780 static Void showtype ( void ) { /* print type of expression (if any)*/
1783 volatile Module evalMod = allocEvalModule();
1784 volatile Module currMod = currentModule;
1785 setCurrModule(evalMod);
1787 if (setjmp(catch_error)==0) {
1791 defaultDefns = evalDefaults;
1792 type = typeCheckExp(FALSE);
1793 printExp(stdout,inputExpr);
1795 printType(stdout,type);
1798 /* if an exception happens, we arrive here */
1801 nukeModule(evalMod);
1802 setCurrModule(currMod);
1806 static Void local browseit(mod,t,all)
1813 Printf("module %s where\n",textToStr(module(mod).text));
1814 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1816 /* only look at things defined in this module,
1817 unless `all' flag is set */
1818 if (all || name(nm).mod == mod) {
1819 /* unwanted artifacts, like lambda lifted values,
1820 are in the list of names, but have no types */
1821 if (nonNull(name(nm).type)) {
1822 printExp(stdout,nm);
1824 printType(stdout,name(nm).type);
1826 Printf(" -- data constructor");
1827 } else if (isMfun(nm)) {
1828 Printf(" -- class member");
1829 } else if (isSfun(nm)) {
1830 Printf(" -- selector function");
1838 Printf("Unknown module %s\n",t);
1843 static Void local browse() { /* browse modules */
1844 Int count = 0; /* or give menu of commands */
1848 for (; (s=readFilename())!=0; count++)
1849 if (strcmp(s,"all") == 0) {
1853 browseit(findModule(findText(s)),s,all);
1855 browseit(currentModule,NULL,all);
1859 #if EXPLAIN_INSTANCE_RESOLUTION
1860 static Void local xplain() { /* print type of expression (if any)*/
1862 Bool sir = showInstRes;
1864 setCurrModule(findEvalModule());
1865 startNewScript(0); /* Enables recovery of storage */
1866 /* allocated during evaluation */
1870 d = provePred(NIL,NIL,hd(inputContext));
1872 fprintf(stdout, "not Sat\n");
1874 fprintf(stdout, "Sat\n");
1880 /* --------------------------------------------------------------------------
1881 * Enhanced help system: print current list of scripts or give information
1883 * ------------------------------------------------------------------------*/
1885 static String local objToStr(m,c)
1888 #if 1 || DISPLAY_QUANTIFIERS
1889 static char newVar[60];
1890 switch (whatIs(c)) {
1891 case NAME : if (m == name(c).mod) {
1892 sprintf(newVar,"%s", textToStr(name(c).text));
1894 sprintf(newVar,"%s.%s",
1895 textToStr(module(name(c).mod).text),
1896 textToStr(name(c).text));
1900 case TYCON : if (m == tycon(c).mod) {
1901 sprintf(newVar,"%s", textToStr(tycon(c).text));
1903 sprintf(newVar,"%s.%s",
1904 textToStr(module(tycon(c).mod).text),
1905 textToStr(tycon(c).text));
1909 case CLASS : if (m == cclass(c).mod) {
1910 sprintf(newVar,"%s", textToStr(cclass(c).text));
1912 sprintf(newVar,"%s.%s",
1913 textToStr(module(cclass(c).mod).text),
1914 textToStr(cclass(c).text));
1918 default : internal("objToStr");
1922 static char newVar[33];
1923 switch (whatIs(c)) {
1924 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1927 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1930 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1933 default : internal("objToStr");
1941 static Void dumpStg ( void )
1947 setCurrModule(findEvalModule());
1952 /* request to locate a symbol by name */
1953 if (s && (*s == '?')) {
1954 Text t = findText(s+1);
1955 locateSymbolByName(t);
1959 /* request to dump a bit of the heap */
1960 if (s && (*s == '-' || isdigit(*s))) {
1967 /* request to dump a symbol table entry */
1969 || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
1970 || !isdigit(s[1])) {
1971 fprintf(stderr, ":d -- bad request `%s'\n", s );
1976 case 't': dumpTycon(i); break;
1977 case 'n': dumpName(i); break;
1978 case 'c': dumpClass(i); break;
1979 case 'i': dumpInst(i); break;
1980 default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
1986 static Void local dumpStg( void ) { /* print STG stuff */
1991 Cell v; /* really StgVar */
1992 setCurrModule(findEvalModule());
1994 for (; (s=readFilename())!=0;) {
1997 /* find the name while ignoring module scopes */
1998 for (i=NAMEMIN; i<nameHw; i++)
1999 if (name(i).text == t) n = i;
2001 /* perhaps it's an "idNNNNNN" thing? */
2004 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2007 while (isdigit(s[i])) {
2008 v = v * 10 + (s[i]-'0');
2012 n = nameFromStgVar(v);
2015 if (isNull(n) && whatIs(v)==STGVAR) {
2016 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2017 printStg(stderr, v );
2020 Printf ( "Unknown reference `%s'\n", s );
2023 Printf ( "Not a Name: `%s'\n", s );
2025 if (isNull(name(n).stgVar)) {
2026 Printf ( "Doesn't have a STG tree: %s\n", s );
2028 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2029 printStg(stderr, name(n).stgVar);
2035 static Void local info() { /* describe objects */
2036 Int count = 0; /* or give menu of commands */
2039 for (; (s=readFilename())!=0; count++) {
2040 describe(findText(s));
2043 /* whatScripts(); */
2048 static Void local describe(t) /* describe an object */
2050 Tycon tc = findTycon(t);
2051 Class cl = findClass(t);
2052 Name nm = findName(t);
2054 if (nonNull(tc)) { /* as a type constructor */
2058 for (i=0; i<tycon(tc).arity; ++i) {
2059 t = ap(t,mkOffset(i));
2061 Printf("-- type constructor");
2063 Printf(" with kind ");
2064 printKind(stdout,tycon(tc).kind);
2067 switch (tycon(tc).what) {
2068 case SYNONYM : Printf("type ");
2069 printType(stdout,t);
2071 printType(stdout,tycon(tc).defn);
2075 case DATATYPE : { List cs = tycon(tc).defn;
2076 if (tycon(tc).what==DATATYPE) {
2081 printType(stdout,t);
2083 mapProc(printSyntax,cs);
2085 Printf("\n-- constructors:");
2087 for (; hasCfun(cs); cs=tl(cs)) {
2089 printExp(stdout,hd(cs));
2091 printType(stdout,name(hd(cs)).type);
2094 Printf("\n-- selectors:");
2096 for (; nonNull(cs); cs=tl(cs)) {
2098 printExp(stdout,hd(cs));
2100 printType(stdout,name(hd(cs)).type);
2105 case RESTRICTSYN : Printf("type ");
2106 printType(stdout,t);
2107 Printf(" = <restricted>");
2111 if (nonNull(in=findFirstInst(tc))) {
2112 Printf("\n-- instances:\n");
2115 in = findNextInst(tc,in);
2116 } while (nonNull(in));
2121 if (nonNull(cl)) { /* as a class */
2122 List ins = cclass(cl).instances;
2123 Kinds ks = cclass(cl).kinds;
2124 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2125 Printf("-- type class");
2127 Printf("-- constructor class");
2129 Printf(" with arity ");
2130 printKinds(stdout,ks);
2134 mapProc(printSyntax,cclass(cl).members);
2136 if (nonNull(cclass(cl).supers)) {
2137 printContext(stdout,cclass(cl).supers);
2140 printPred(stdout,cclass(cl).head);
2142 if (nonNull(cclass(cl).fds)) {
2143 List fds = cclass(cl).fds;
2145 for (; nonNull(fds); fds=tl(fds)) {
2147 printFD(stdout,hd(fds));
2152 if (nonNull(cclass(cl).members)) {
2153 List ms = cclass(cl).members;
2156 Type t = name(hd(ms)).type;
2157 if (isPolyType(t)) {
2161 printExp(stdout,hd(ms));
2163 if (isNull(tl(fst(snd(t))))) {
2166 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2168 printType(stdout,t);
2170 } while (nonNull(ms));
2174 Printf("\n-- instances:\n");
2178 } while (nonNull(ins));
2183 if (nonNull(nm)) { /* as a function/name */
2185 printExp(stdout,nm);
2187 if (nonNull(name(nm).type)) {
2188 printType(stdout,name(nm).type);
2190 Printf("<unknown type>");
2193 Printf(" -- data constructor");
2194 } else if (isMfun(nm)) {
2195 Printf(" -- class member");
2196 } else if (isSfun(nm)) {
2197 Printf(" -- selector function");
2203 if (isNull(tc) && isNull(cl) && isNull(nm)) {
2204 Printf("Unknown reference `%s'\n",textToStr(t));
2208 static Void local printSyntax(nm)
2210 Syntax sy = syntaxOf(nm);
2211 Text t = name(nm).text;
2212 String s = textToStr(t);
2213 if (sy != defaultSyntax(t)) {
2215 switch (assocOf(sy)) {
2216 case LEFT_ASS : Putchar('l'); break;
2217 case RIGHT_ASS : Putchar('r'); break;
2218 case NON_ASS : break;
2220 Printf(" %i ",precOf(sy));
2221 if (isascii((int)(*s)) && isalpha((int)(*s))) {
2230 static Void local showInst(in) /* Display instance decl header */
2232 Printf("instance ");
2233 if (nonNull(inst(in).specifics)) {
2234 printContext(stdout,inst(in).specifics);
2237 printPred(stdout,inst(in).head);
2241 /* --------------------------------------------------------------------------
2242 * List all names currently in scope:
2243 * ------------------------------------------------------------------------*/
2245 static Void local listNames() { /* list names matching optional pat*/
2246 String pat = readFilename();
2248 Int width = getTerminalWidth() - 1;
2251 Module mod = currentModule;
2253 if (pat) { /* First gather names to list */
2255 names = addNamesMatching(pat,names);
2256 } while ((pat=readFilename())!=0);
2258 names = addNamesMatching((String)0,names);
2260 if (isNull(names)) { /* Then print them out */
2261 ERRMSG(0) "No names selected"
2265 for (termPos=0; nonNull(names); names=tl(names)) {
2266 String s = objToStr(mod,hd(names));
2268 if (termPos+1+l>width) {
2271 } else if (termPos>0) {
2279 Printf("\n(%d names listed)\n", count);
2282 /* --------------------------------------------------------------------------
2283 * print a prompt and read a line of input:
2284 * ------------------------------------------------------------------------*/
2286 static Void local promptForInput(moduleName)
2287 String moduleName; {
2288 char promptBuffer[1000];
2290 /* This is portable but could overflow buffer */
2291 sprintf(promptBuffer,prompt,moduleName);
2293 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2294 * promptBuffer instead.
2296 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2297 /* Reset prompt to a safe default to avoid an infinite loop */
2299 prompt = strCopy("? ");
2300 internal("Combined prompt and evaluation module name too long");
2304 stringInput("main\0"); else
2305 consoleInput(promptBuffer);
2308 /* --------------------------------------------------------------------------
2309 * main read-eval-print loop, with error trapping:
2310 * ------------------------------------------------------------------------*/
2312 static Void local interpreter(argc,argv)/* main interpreter loop */
2316 List modConIds; /* :: [CONID] */
2320 setBreakAction ( HugsIgnoreBreak );
2321 modConIds = initialize(argc,argv); /* the initial modules to load */
2322 setBreakAction ( HugsIgnoreBreak );
2323 prelOK = loadThePrelude();
2324 if (combined) everybody(POSTPREL);
2328 fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2330 fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2334 loadActions(modConIds);
2337 for (; nonNull(modConIds); modConIds=tl(modConIds))
2338 if (!elemMG(hd(modConIds))) {
2340 "hugs +Q: compilation failed -- can't run `main'\n" );
2347 /* initialize calls startupHaskell, which trashes our signal handlers */
2348 setBreakAction ( HugsIgnoreBreak );
2353 everybody(RESET); /* reset to sensible initial state */
2355 promptForInput(textToStr(module(currentModule).text));
2357 cmd = readCommand(cmds, (Char)':', (Char)'!');
2359 case EDIT : editor();
2363 case LOAD : modConIds = NIL;
2364 while ((s=readFilename())!=0)
2365 modConIds = cons(mkCon(findText(s)),modConIds);
2366 loadActions(modConIds);
2369 case ALSO : modConIds = NIL;
2370 while ((s=readFilename())!=0)
2371 modConIds = cons(mkCon(findText(s)),modConIds);
2372 addActions(modConIds);
2375 case RELOAD : refreshActions(NIL);
2380 case EVAL : evaluator();
2382 case TYPEOF : showtype();
2384 case BROWSE : browse();
2386 #if EXPLAIN_INSTANCE_RESOLUTION
2387 case XPLAIN : xplain();
2390 case NAMES : listNames();
2394 case BADCMD : guidance();
2399 #ifdef CRUDE_PROFILING
2403 case SYSTEM : if (shellEsc(readLine()))
2404 Printf("Warning: Shell escape terminated abnormally\n");
2406 case CHGDIR : changeDir();
2410 case PNTVER: Printf("-- Hugs Version %s\n",
2413 case DUMP : dumpStg();
2416 case COLLECT: consGC = FALSE;
2419 Printf("Garbage collection recovered %d cells\n",
2425 if (autoMain) break;
2429 /* --------------------------------------------------------------------------
2430 * Display progress towards goal:
2431 * ------------------------------------------------------------------------*/
2433 static Target currTarget;
2434 static Bool aiming = FALSE;
2437 static Int charCount;
2439 Void setGoal(what, t) /* Set goal for what to be t */
2444 #if EXPLAIN_INSTANCE_RESOLUTION
2448 currTarget = (t?t:1);
2451 currPos = strlen(what);
2452 maxPos = getTerminalWidth() - 1;
2456 for (charCount=0; *what; charCount++)
2461 Void soFar(t) /* Indicate progress towards goal */
2462 Target t; { /* has now reached t */
2465 #if EXPLAIN_INSTANCE_RESOLUTION
2470 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2475 if (newPos>currPos) {
2478 while (newPos>++currPos);
2485 Void done() { /* Goal has now been achieved */
2488 #if EXPLAIN_INSTANCE_RESOLUTION
2493 while (maxPos>currPos++)
2498 for (; charCount>0; charCount--) {
2507 static Void local failed() { /* Goal cannot be reached due to */
2508 if (aiming) { /* errors */
2515 /* --------------------------------------------------------------------------
2517 * ------------------------------------------------------------------------*/
2519 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
2520 if (printing) { /* after successful termination or */
2521 printing = FALSE; /* runtime error (e.g. interrupt) */
2524 #define plural(v) v, (v==1?"":"s")
2525 Printf("%lu cell%s",plural(numCells));
2527 Printf(", %u garbage collection%s",plural(numGcs));
2536 Cell errAssert(l) /* message to use when raising asserts, etc */
2541 str = mkStr(findText(currentFile));
2543 str = mkStr(findText(""));
2545 return (ap2(nameTangleMessage,str,mkInt(l)));
2548 Void errHead(l) /* print start of error message */
2550 failed(); /* failed to reach target ... */
2552 FPrintf(errorStream,"ERROR");
2555 FPrintf(errorStream," \"%s\"", currentFile);
2556 setLastEdit(currentFile,l);
2557 if (l) FPrintf(errorStream," (line %d)",l);
2560 FPrintf(errorStream,": ");
2561 FFlush(errorStream);
2564 Void errFail() { /* terminate error message and */
2565 Putc('\n',errorStream); /* produce exception to return to */
2566 FFlush(errorStream); /* main command loop */
2567 longjmp(catch_error,1);
2570 Void errFail_no_longjmp() { /* terminate error message but */
2571 Putc('\n',errorStream); /* don't produce an exception */
2572 FFlush(errorStream);
2575 Void errAbort() { /* altern. form of error handling */
2576 failed(); /* used when suitable error message*/
2577 stopAnyPrinting(); /* has already been printed */
2581 Void internal(msg) /* handle internal error */
2585 Printf("INTERNAL ERROR: %s\n",msg);
2588 longjmp(catch_error,1);
2591 Void fatal(msg) /* handle fatal error */
2594 Printf("\nFATAL ERROR: %s\n",msg);
2600 /* --------------------------------------------------------------------------
2601 * Read value from environment variable or registry:
2602 * ------------------------------------------------------------------------*/
2604 String fromEnv(var,def) /* return value of: */
2605 String var; /* environment variable named by var */
2606 String def; { /* or: default value given by def */
2607 String s = getenv(var);
2608 return (s ? s : def);
2611 /* --------------------------------------------------------------------------
2612 * String manipulation routines:
2613 * ------------------------------------------------------------------------*/
2615 static String local strCopy(s) /* make malloced copy of a string */
2619 if ((t=(char *)malloc(strlen(s)+1))==0) {
2620 ERRMSG(0) "String storage space exhausted"
2623 for (r=t; (*r++ = *s++)!=0; ) {
2630 /* --------------------------------------------------------------------------
2632 * We can redirect compiler output (prompts, error messages, etc) by
2633 * tweaking these functions.
2634 * ------------------------------------------------------------------------*/
2636 /* --------------------------------------------------------------------------
2637 * Send message to each component of system:
2638 * ------------------------------------------------------------------------*/
2640 Void everybody(what) /* send command `what' to each component of*/
2641 Int what; { /* system to respond as appropriate ... */
2643 fprintf ( stderr, "EVERYBODY %d\n", what );
2645 machdep(what); /* The order of calling each component is */
2646 storage(what); /* important for the PREPREL command */
2649 translateControl(what);
2651 staticAnalysis(what);
2652 deriveControl(what);
2658 /*-------------------------------------------------------------------------*/