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/20 04:26:23 $
14 * ------------------------------------------------------------------------*/
29 #include "Assembler.h" /* DEBUG_LoadSymbols */
31 Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
33 #if EXPLAIN_INSTANCE_RESOLUTION
34 Bool showInstRes = FALSE;
37 Bool multiInstRes = FALSE;
40 /* --------------------------------------------------------------------------
41 * Local function prototypes:
42 * ------------------------------------------------------------------------*/
44 static Void local initialize ( Int,String [] );
45 static Void local promptForInput ( String );
46 static Void local interpreter ( Int,String [] );
47 static Void local menu ( Void );
48 static Void local guidance ( Void );
49 static Void local forHelp ( Void );
50 static Void local set ( Void );
51 static Void local changeDir ( Void );
52 static Void local load ( Void );
53 static Void local project ( Void );
54 static Void local readScripts ( Int );
55 static Void local whatScripts ( Void );
56 static Void local editor ( Void );
57 static Void local find ( Void );
58 static Bool local startEdit ( Int,String );
59 static Void local runEditor ( Void );
60 static Void local setModule ( Void );
61 static Module local findEvalModule ( Void );
62 static Void local evaluator ( Void );
63 static Void local stopAnyPrinting ( Void );
64 static Void local showtype ( Void );
65 static String local objToStr ( Module, Cell );
66 static Void local info ( Void );
67 static Void local printSyntax ( Name );
68 static Void local showInst ( Inst );
69 static Void local describe ( Text );
70 static Void local listNames ( Void );
72 static Void local toggleSet ( Char,Bool );
73 static Void local togglesIn ( Bool );
74 static Void local optionInfo ( Void );
75 #if USE_REGISTRY || HUGS_FOR_WINDOWS
76 static String local optionsToStr ( Void );
78 static Void local readOptions ( String );
79 static Bool local processOption ( String );
80 static Void local setHeapSize ( String );
81 static Int local argToInt ( String );
83 static Void local loadProject ( String );
84 static Void local clearProject ( Void );
85 static Bool local addScript ( Int );
86 static Void local forgetScriptsFrom ( Script );
87 static Void local setLastEdit ( String,Int );
88 static Void local failed ( Void );
89 static String local strCopy ( String );
90 static Void local browseit ( Module,String,Bool );
91 static Void local browse ( Void );
93 /* --------------------------------------------------------------------------
94 * Machine dependent code for Hugs interpreter:
95 * ------------------------------------------------------------------------*/
102 /* --------------------------------------------------------------------------
104 * ------------------------------------------------------------------------*/
106 static Bool printing = FALSE; /* TRUE => currently printing value*/
107 static Bool showStats = FALSE; /* TRUE => print stats after eval */
108 static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
109 static Bool addType = FALSE; /* TRUE => print type with value */
110 static Bool useDots = RISCOS; /* TRUE => use dots in progress */
111 static Bool quiet = FALSE; /* TRUE => don't show progress */
112 static Bool lastWasObject = FALSE;
114 Bool flagAssert = FALSE; /* TRUE => assert False <e> causes
115 an assertion failure */
116 Bool preludeLoaded = FALSE;
117 Bool debugSC = FALSE;
118 Bool combined = FALSE;
122 String modName; /* Module name */
123 Bool details; /* FALSE => remaining fields are invalid */
124 String path; /* Path to module */
125 String srcExt; /* ".hs" or ".lhs" if fromSource */
126 Time lastChange; /* Time of last change to script */
127 Bool fromSource; /* FALSE => load object code */
128 Bool postponed; /* Indicates postponed load */
135 static Void local makeStackEntry ( ScriptInfo*,String );
136 static Void local addStackEntry ( String );
138 static ScriptInfo scriptInfo[NUM_SCRIPTS];
140 static Int numScripts; /* Number of scripts loaded */
141 static Int nextNumScripts;
142 static Int namesUpto; /* Number of script names set */
143 static Bool needsImports; /* set to TRUE if imports required */
144 String scriptFile; /* Name of current script (if any) */
148 static Text evalModule = 0; /* Name of module we eval exprs in */
149 static String currProject = 0; /* Name of current project file */
150 static Bool projectLoaded = FALSE; /* TRUE => project file loaded */
152 static Bool autoMain = FALSE;
153 static String lastEdit = 0; /* Name of script to edit (if any) */
154 static Int lastEdLine = 0; /* Editor line number (if possible)*/
155 static String prompt = 0; /* Prompt string */
156 static Int hpSize = DEFAULTHEAP; /* Desired heap size */
157 String hugsEdit = 0; /* String for editor command */
158 String hugsPath = 0; /* String for file search path */
160 List ifaces_outstanding = NIL;
163 static Bool disableOutput = FALSE; /* redirect output to buffer? */
166 String bool2str ( Bool b )
168 if (b) return "Yes"; else return "No ";
171 void ppSmStack ( String who )
175 fflush(stdout);fflush(stderr);
177 printf ( "ppSmStack %s: numScripts = %d namesUpto = %d needsImports = %s\n",
178 who, numScripts, namesUpto, bool2str(needsImports) );
179 assert (namesUpto >= numScripts);
180 printf ( " Det FrS Pst ObL Module Ext Size ModTime Path\n" );
181 for (i = namesUpto-1; i >= 0; i--) {
182 printf ( "%c%2d: %3s %3s %3s %3s %16s %-4s %5ld %8lx %s\n",
183 (i==numScripts ? '*' : ' '),
184 i, bool2str(scriptInfo[i].details),
185 bool2str(scriptInfo[i].fromSource),
186 bool2str(scriptInfo[i].postponed),
187 bool2str(scriptInfo[i].objLoaded),
188 scriptInfo[i].modName,
189 scriptInfo[i].fromSource ? scriptInfo[i].srcExt : "",
191 scriptInfo[i].lastChange,
195 fflush(stdout);fflush(stderr);
201 /* --------------------------------------------------------------------------
203 * ------------------------------------------------------------------------*/
205 #ifndef NO_MAIN /* we omit main when building the "Hugs server" */
207 Main main ( Int, String [] ); /* now every func has a prototype */
212 #ifdef HAVE_CONSOLE_H /* Macintosh port */
214 _fcreator = 'R*ch'; /* // 'KAHL'; //'*TEX'; //'ttxt'; */
216 console_options.top = 50;
217 console_options.left = 20;
219 console_options.nrows = 32;
220 console_options.ncols = 80;
222 console_options.pause_atexit = 1;
223 console_options.title = "\pHugs";
225 console_options.procID = 5;
226 argc = ccommand(&argv);
229 CStackBase = &argc; /* Save stack base for use in gc */
232 checkBytecodeCount(); /* check for too many bytecodes */
235 /* If first arg is +Q or -Q, be entirely silent, and automatically run
236 main after loading scripts. Useful for running the nofib suite. */
237 if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
239 if (strcmp(argv[1],"-Q") == 0) {
244 Printf("__ __ __ __ ____ ___ _________________________________________\n");
245 Printf("|| || || || || || ||__ STGHugs: Based on the Haskell 98 standard\n");
246 Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n");
247 Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
248 Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
249 Printf("|| || Version: %s _________________________________________\n\n",HUGS_VERSION);
251 /* Get the absolute path to the directory containing the hugs
252 executable, so that we know where the Prelude and nHandle.so/.dll are.
253 We do this by reading env var STGHUGSDIR. This needs to succeed, so
254 setInstallDir won't return unless it succeeds.
256 setInstallDir ( argv[0] );
259 Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
262 interpreter(argc,argv);
263 Printf("[Leaving Hugs]\n");
274 /* --------------------------------------------------------------------------
275 * Initialization, interpret command line args and read prelude:
276 * ------------------------------------------------------------------------*/
278 static Void local initialize(argc,argv)/* Interpreter initialization */
283 char argv_0_orig[1000];
285 setLastEdit((String)0,0);
292 hugsEdit = strCopy(fromEnv("EDITOR","c:\\windows\\notepad.exe"));
296 hugsEdit = strCopy(fromEnv("EDITOR",NULL));
298 hugsPath = strCopy(HUGSPATH);
299 readOptions("-p\"%s> \" -r$$");
301 projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
302 "HUGSPATH", PATHSEP, ""));
303 readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
304 readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
305 #endif /* USE_REGISTRY */
306 readOptions(fromEnv("STGHUGSFLAGS",""));
308 strncpy(argv_0_orig,argv[0],1000); /* startupHaskell mangles argv[0] */
309 startupHaskell (argc,argv);
310 argc = prog_argc; argv = prog_argv;
312 namesUpto = numScripts = 0;
314 /* Pre-scan flags to see if -c or +c is present. This needs to
315 precede adding the stack entry for Prelude. On the other hand,
316 that stack entry needs to be made before the cmd line args are
317 properly examined. Hence the following pre-scan of them.
319 for (i=1; i < argc; ++i) {
320 if (strcmp(argv[i], "--")==0) break;
321 if (strcmp(argv[i], "-c")==0) combined = FALSE;
322 if (strcmp(argv[i], "+c")==0) combined = TRUE;
325 addStackEntry("Prelude");
326 if (combined) addStackEntry("PrelHugs");
328 for (i=1; i < argc; ++i) { /* process command line arguments */
329 if (strcmp(argv[i], "--")==0) break;
330 if (strcmp(argv[i],"+")==0 && i+1<argc) {
332 ERRMSG(0) "Multiple project filenames on command line"
337 } else if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
338 && !processOption(argv[i])) {
339 addStackEntry(argv[i]);
345 char exe_name[N_INSTALLDIR + 6];
346 strcpy(exe_name, installDir);
347 strcat(exe_name, "hugs");
348 DEBUG_LoadSymbols(exe_name);
354 if (!scriptName[0]) {
355 Printf("Prelude not found on current path: \"%s\"\n",
356 hugsPath ? hugsPath : "");
357 fatal("Unable to load prelude");
362 Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n");
364 Printf("Hugs mode: Restart with command line option +98 for Haskell 98 mode\n");
368 Printf("Combined mode: Restart with command line -c for standalone mode\n\n" );
370 Printf("Standalone mode: Restart with command line +c for combined mode\n\n" );
375 evalModule = findText(""); /* evaluate wrt last module by default */
379 "\nUsing project file, ignoring additional filenames\n");
381 loadProject(strCopy(proj));
386 /* --------------------------------------------------------------------------
387 * Command line options:
388 * ------------------------------------------------------------------------*/
390 struct options { /* command line option toggles */
391 char c; /* table defined in main app. */
396 extern struct options toggle[];
398 static Void local toggleSet(c,state) /* Set command line toggle */
402 for (i=0; toggle[i].c; ++i)
403 if (toggle[i].c == c) {
404 *toggle[i].flag = state;
407 ERRMSG(0) "Unknown toggle `%c'", c
411 static Void local togglesIn(state) /* Print current list of toggles in*/
412 Bool state; { /* given state */
415 for (i=0; toggle[i].c; ++i)
416 if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
418 Putchar((char)(state ? '+' : '-'));
419 Putchar(toggle[i].c);
426 static Void local optionInfo() { /* Print information about command */
427 static String fmts = "%-5s%s\n"; /* line settings */
428 static String fmtc = "%-5c%s\n";
431 Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
432 for (i=0; toggle[i].c; ++i) {
433 if (!haskell98 || toggle[i].h98) {
434 Printf(fmtc,toggle[i].c,toggle[i].description);
438 Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
439 Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
440 Printf(fmts,"pstr","Set prompt string to str");
441 Printf(fmts,"rstr","Set repeat last expression string to str");
442 Printf(fmts,"Pstr","Set search path for modules to str");
443 Printf(fmts,"Estr","Use editor setting given by str");
444 Printf(fmts,"cnum","Set constraint cutoff limit");
445 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
446 Printf(fmts,"Fstr","Set preprocessor filter to str");
449 Printf("\nCurrent settings: ");
452 Printf("-h%d",heapSize);
456 printString(repeatStr);
457 Printf(" -c%d",cutoff);
458 Printf("\nSearch path : -P");
459 printString(hugsPath);
462 if (projectPath!=NULL) {
463 Printf("\nProject Path : %s",projectPath);
466 Printf("\nEditor setting : -E");
467 printString(hugsEdit);
468 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
469 Printf("\nPreprocessor : -F");
470 printString(preprocessor);
472 Printf("\nCompatibility : %s", haskell98 ? "Haskell 98 (+98)"
473 : "Hugs Extensions (-98)");
477 #if USE_REGISTRY || HUGS_FOR_WINDOWS
485 #define PUTInt(optc,i) \
486 sprintf(next,"-%c%d",optc,i); \
489 #define PUTStr(c,s) \
490 next=PUTStr_aux(next,c,s)
492 static String local PUTStr_aux ( String,Char, String));
494 static String local PUTStr_aux(next,c,s)
500 sprintf(next,"-%c\"",c);
503 PUTS(unlexChar(*t,'"'));
511 static String local optionsToStr() { /* convert options to string */
512 static char buffer[2000];
513 String next = buffer;
516 for (i=0; toggle[i].c; ++i) {
517 PUTC(*toggle[i].flag ? '+' : '-');
521 PUTS(haskell98 ? "+98 " : "-98 ");
522 PUTInt('h',hpSize); PUTC(' ');
524 PUTStr('r',repeatStr);
525 PUTStr('P',hugsPath);
526 PUTStr('E',hugsEdit);
527 PUTInt('c',cutoff); PUTC(' ');
528 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
529 PUTStr('F',preprocessor);
534 #endif /* USE_REGISTRY */
541 static Void local readOptions(options) /* read options from string */
545 stringInput(options);
546 while ((s=readFilename())!=0) {
547 if (*s && !processOption(s)) {
548 ERRMSG(0) "Option string must begin with `+' or `-'"
555 static Bool local processOption(s) /* process string s for options, */
556 String s; { /* return FALSE if none found. */
568 case 'Q' : break; /* already handled */
570 case 'p' : if (s[1]) {
571 if (prompt) free(prompt);
572 prompt = strCopy(s+1);
576 case 'r' : if (s[1]) {
577 if (repeatStr) free(repeatStr);
578 repeatStr = strCopy(s+1);
583 String p = substPath(s+1,hugsPath ? hugsPath : "");
584 if (hugsPath) free(hugsPath);
589 case 'E' : if (hugsEdit) free(hugsEdit);
590 hugsEdit = strCopy(s+1);
593 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
594 case 'F' : if (preprocessor) free(preprocessor);
595 preprocessor = strCopy(s+1);
599 case 'h' : setHeapSize(s+1);
602 case 'c' : if (heapBuilt()) {
604 "You can't enable/disable combined"
605 " operation inside Hugs\n" );
607 /* don't do anything, since pre-scan of args
608 will have got it already */
612 case 'D' : /* hack */
614 extern void setRtsFlags( int x );
615 setRtsFlags(argToInt(s+1));
619 default : if (strcmp("98",s)==0) {
620 if (heapBuilt() && ((state && !haskell98) ||
621 (!state && haskell98))) {
623 "Haskell 98 compatibility cannot be changed"
624 " while the interpreter is running\n");
637 static Void local setHeapSize(s)
640 hpSize = argToInt(s);
641 if (hpSize < MINIMUMHEAP)
642 hpSize = MINIMUMHEAP;
643 else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
644 hpSize = MAXIMUMHEAP;
645 if (heapBuilt() && hpSize != heapSize) {
646 /* ToDo: should this use a message box in winhugs? */
648 FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
650 FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
658 static Int local argToInt(s) /* read integer from argument str */
663 if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
664 ERRMSG(0) "Missing integer in option setting \"%s\"", t
669 Int d = (*s++) - '0';
670 if (n > ((MAXPOSINT - d)/10)) {
671 ERRMSG(0) "Option setting \"%s\" is too large", t
675 } while (isascii((int)(*s)) && isdigit((int)(*s)));
677 if (*s=='K' || *s=='k') {
678 if (n > (MAXPOSINT/1000)) {
679 ERRMSG(0) "Option setting \"%s\" is too large", t
686 #if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
687 if (*s=='M' || *s=='m') {
688 if (n > (MAXPOSINT/1000000)) {
689 ERRMSG(0) "Option setting \"%s\" is too large", t
697 #if MAXPOSINT > 1000000000
698 if (*s=='G' || *s=='g') {
699 if (n > (MAXPOSINT/1000000000)) {
700 ERRMSG(0) "Option setting \"%s\" is too large", t
709 ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
716 /* --------------------------------------------------------------------------
717 * Print Menu of list of commands:
718 * ------------------------------------------------------------------------*/
720 static struct cmd cmds[] = {
721 {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
722 {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
723 {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
724 {":quit", QUIT}, {":set", SET}, {":find", FIND},
725 {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
726 {":dump", DUMP}, {":ztats", STATS},
727 {":module",SETMODULE},
729 #if EXPLAIN_INSTANCE_RESOLUTION
732 {":version", PNTVER},
737 static Void local menu() {
738 Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
739 Printf("c is the first character in the full name.\n\n");
740 Printf(":load <filenames> load modules from specified files\n");
741 Printf(":load clear all files except prelude\n");
742 Printf(":also <filenames> read additional modules\n");
743 Printf(":reload repeat last load command\n");
744 Printf(":project <filename> use project file\n");
745 Printf(":edit <filename> edit file\n");
746 Printf(":edit edit last module\n");
747 Printf(":module <module> set module for evaluating expressions\n");
748 Printf("<expr> evaluate expression\n");
749 Printf(":type <expr> print type of expression\n");
750 Printf(":? display this list of commands\n");
751 Printf(":set <options> set command line options\n");
752 Printf(":set help on command line options\n");
753 Printf(":names [pat] list names currently in scope\n");
754 Printf(":info <names> describe named objects\n");
755 Printf(":browse <modules> browse names defined in <modules>\n");
756 #if EXPLAIN_INSTANCE_RESOLUTION
757 Printf(":xplain <context> explain instance resolution for <context>\n");
759 Printf(":find <name> edit module containing definition of name\n");
760 Printf(":!command shell escape\n");
761 Printf(":cd dir change directory\n");
762 Printf(":gc force garbage collection\n");
763 Printf(":version print Hugs version\n");
764 Printf(":dump <name> print STG code for named fn\n");
765 #ifdef CRUDE_PROFILING
766 Printf(":ztats <name> print reduction stats\n");
768 Printf(":quit exit Hugs interpreter\n");
771 static Void local guidance() {
772 Printf("Command not recognised. ");
776 static Void local forHelp() {
777 Printf("Type :? for help\n");
780 /* --------------------------------------------------------------------------
781 * Setting of command line options:
782 * ------------------------------------------------------------------------*/
784 struct options toggle[] = { /* List of command line toggles */
785 {'s', 1, "Print no. reductions/cells after eval", &showStats},
786 {'t', 1, "Print type after evaluation", &addType},
787 {'g', 1, "Print no. cells recovered after gc", &gcMessages},
788 {'l', 1, "Literate modules as default", &literateScripts},
789 {'e', 1, "Warn about errors in literate modules", &literateErrors},
790 {'.', 1, "Print dots to show progress", &useDots},
791 {'q', 1, "Print nothing to show progress", &quiet},
792 {'w', 1, "Always show which modules are loaded", &listScripts},
793 {'k', 1, "Show kind errors in full", &kindExpert},
794 {'o', 0, "Allow overlapping instances", &allowOverlap},
795 {'S', 1, "Debug: show generated SC code", &debugSC},
796 {'a', 1, "Raise exception on assert failure", &flagAssert},
797 #if EXPLAIN_INSTANCE_RESOLUTION
798 {'x', 1, "Explain instance resolution", &showInstRes},
801 {'m', 0, "Use multi instance resolution", &multiInstRes},
806 static Void local set() { /* change command line options from*/
807 String s; /* Hugs command line */
809 if ((s=readFilename())!=0) {
811 if (!processOption(s)) {
812 ERRMSG(0) "Option string must begin with `+' or `-'"
815 } while ((s=readFilename())!=0);
817 writeRegString("Options", optionsToStr());
824 /* --------------------------------------------------------------------------
825 * Change directory command:
826 * ------------------------------------------------------------------------*/
828 static Void local changeDir() { /* change directory */
829 String s = readFilename();
831 ERRMSG(0) "Unable to change to directory \"%s\"", s
836 /* --------------------------------------------------------------------------
837 * Loading project and script files:
838 * ------------------------------------------------------------------------*/
840 static Void local loadProject(s) /* Load project file */
844 projInput(currProject);
845 scriptFile = currProject;
846 forgetScriptsFrom(N_PRELUDE_SCRIPTS);
847 while ((s=readFilename())!=0)
850 ERRMSG(0) "Empty project file"
854 projectLoaded = TRUE;
857 static Void local clearProject() { /* clear name for current project */
861 projectLoaded = FALSE;
863 setLastEdit((String)0,0);
869 static Void local makeStackEntry ( ScriptInfo* ent, String iname )
872 Bool sAvail, iAvail, oAvail;
873 Time sTime, iTime, oTime;
874 Long sSize, iSize, oSize;
877 ok = findFilesForModule (
881 &sAvail, &sTime, &sSize,
882 &iAvail, &iTime, &iSize,
883 &oAvail, &oTime, &oSize
887 "Can't find source or object+interface for module \"%s\"",
888 /* "Can't find source for module \"%s\"", */
892 /* findFilesForModule should enforce this */
893 if (!(sAvail || (oAvail && iAvail)))
895 /* Load objects in preference to sources if both are available */
896 /* 11 Oct 99: disable object loading in the interim.
897 Will probably only reinstate when HEP becomes available.
901 ? (oAvail && iAvail && timeEarlier(sTime,oTime))
907 /* ToDo: namesUpto overflow */
908 ent->modName = strCopy(iname);
911 ent->fromSource = !fromObj;
913 ent->postponed = FALSE;
914 ent->lastChange = sTime; /* ToDo: is this right? */
915 ent->size = fromObj ? iSize : sSize;
916 ent->oSize = fromObj ? oSize : 0;
917 ent->objLoaded = FALSE;
922 static Void nukeEnding( String s )
925 if (l > 4 && strncmp(s+l-4,".u_o" ,4)==0) s[l-4] = 0; else
926 if (l > 5 && strncmp(s+l-5,".u_hi",5)==0) s[l-5] = 0; else
927 if (l > 3 && strncmp(s+l-3,".hs" ,3)==0) s[l-3] = 0; else
928 if (l > 4 && strncmp(s+l-4,".lhs" ,4)==0) s[l-4] = 0; else
929 if (l > 4 && strncmp(s+l-4,".dll" ,4)==0) s[l-4] = 0; else
930 if (l > 4 && strncmp(s+l-4,".DLL" ,4)==0) s[l-4] = 0;
933 static Void local addStackEntry(s) /* Add script to list of scripts */
934 String s; { /* to be read in ... */
939 if (namesUpto>=NUM_SCRIPTS) {
940 ERRMSG(0) "Too many module files (maximum of %d allowed)",
947 for (s2 = s; *s2; s2++)
948 if (*s2 == SLASH && *(s2+1)) s = s2+1;
951 for (i = 0; i < namesUpto; i++)
952 if (strcmp(scriptInfo[i].modName,s)==0)
956 makeStackEntry ( &scriptInfo[namesUpto], strCopy(s) );
962 /* Return TRUE if no imports were needed; FALSE otherwise. */
963 static Bool local addScript(stacknum) /* read single file */
966 static char name[FILENAME_MAX+1];
967 Int len = scriptInfo[stacknum].size;
969 #if HUGS_FOR_WINDOWS /* Set clock cursor while loading */
971 SetCursor(LoadCursor(NULL, IDC_WAIT));
974 // setLastEdit(name,0);
976 strcpy(name, scriptInfo[stacknum].path);
977 strcat(name, scriptInfo[stacknum].modName);
978 if (scriptInfo[stacknum].fromSource)
979 strcat(name, scriptInfo[stacknum].srcExt); else
980 strcat(name, ".u_hi");
984 if (scriptInfo[stacknum].fromSource) {
986 didPrelude = processInterfaces();
988 preludeLoaded = TRUE;
992 lastWasObject = FALSE;
993 Printf("Reading script \"%s\":\n",name);
994 needsImports = FALSE;
995 parseScript(name,len);
996 if (needsImports) return FALSE;
1004 char nameObj[FILENAME_MAX+1];
1007 Printf("Reading iface \"%s\":\n", name);
1009 needsImports = FALSE;
1011 // set nameObj for the benefit of openGHCIface
1012 strcpy(nameObj, scriptInfo[stacknum].path);
1013 strcat(nameObj, scriptInfo[stacknum].modName);
1014 strcat(nameObj, DLL_ENDING);
1015 sizeObj = scriptInfo[stacknum].oSize;
1017 iface = readInterface(name,len);
1018 imports = zsnd(iface); iface = zfst(iface);
1020 if (nonNull(imports)) chase(imports);
1022 lastWasObject = TRUE;
1024 iface_info = ztriple(iface, findText(nameObj), mkInt(sizeObj) );
1025 ifaces_outstanding = cons(iface_info,ifaces_outstanding);
1027 if (needsImports) return FALSE;
1036 Bool chase(imps) /* Process list of import requests */
1040 Int origPos = numScripts; /* keep track of original position */
1041 String origName = scriptInfo[origPos].modName;
1042 for (; nonNull(imps); imps=tl(imps)) {
1043 String iname = textToStr(textOf(hd(imps)));
1045 for (; i<namesUpto; i++)
1046 if (strcmp(scriptInfo[i].modName,iname)==0)
1048 //fprintf(stderr, "import name = %s num = %d\n", iname, i );
1051 /* We should have filled in the details of each module
1052 the first time we hear about it.
1054 assert(scriptInfo[i].details);
1057 if (i>=origPos) { /* Neither loaded or queued */
1063 needsImports = TRUE;
1064 if (scriptInfo[origPos].fromSource)
1065 scriptInfo[origPos].postponed = TRUE;
1067 if (i==namesUpto) { /* Name not found (i==namesUpto) */
1068 /* Find out where it lives, whether source or object, etc */
1069 makeStackEntry ( &scriptInfo[i], iname );
1073 if (scriptInfo[i].postponed && scriptInfo[i].fromSource) {
1074 /* Check for recursive dependency */
1076 "Recursive import dependency between \"%s\" and \"%s\"",
1077 scriptInfo[origPos].modName, iname
1080 /* Move stack entry i to somewhere below origPos. If i denotes
1081 * an object, destination is immediately below origPos.
1082 * Otherwise, it's underneath the queue of objects below origPos.
1084 dstPosn = origPos-1;
1085 if (scriptInfo[i].fromSource)
1086 while (!scriptInfo[dstPosn].fromSource && dstPosn > 0)
1090 tmp = scriptInfo[i];
1091 for (; i > dstPosn; i--) scriptInfo[i] = scriptInfo[i-1];
1092 scriptInfo[dstPosn] = tmp;
1093 if (dstPosn < nextNumScripts) nextNumScripts = dstPosn;
1097 return needsImports;
1100 static Void local forgetScriptsFrom(scno)/* remove scripts from system */
1104 for (i=scno; i<namesUpto; ++i)
1106 free(scriptName[i]);
1108 dropScriptsFrom(scno-1);
1110 if (numScripts>namesUpto)
1114 /* --------------------------------------------------------------------------
1115 * Commands for loading and removing script files:
1116 * ------------------------------------------------------------------------*/
1118 static Void local load() { /* read filenames from command line */
1119 String s; /* and add to list of scripts waiting */
1121 while ((s=readFilename())!=0)
1123 readScripts(N_PRELUDE_SCRIPTS);
1126 static Void local project() { /* read list of script names from */
1127 String s; /* project file */
1129 if ((s=readFilename()) || currProject) {
1131 s = strCopy(currProject);
1132 else if (readFilename()) {
1133 ERRMSG(0) "Too many project files"
1140 ERRMSG(0) "No project filename specified"
1144 readScripts(N_PRELUDE_SCRIPTS);
1147 static Void local readScripts(n) /* Reread current list of scripts, */
1148 Int n; { /* loading everything after and */
1149 Time timeStamp; /* including the first script which*/
1150 Long fileSize; /* has been either changed or added*/
1151 static char name[FILENAME_MAX+1];
1154 lastWasObject = FALSE;
1155 ppSmStack("readscripts-begin");
1156 #if HUGS_FOR_WINDOWS
1157 SetCursor(LoadCursor(NULL, IDC_WAIT));
1161 for (; n<numScripts; n++) { /* Scan previously loaded scripts */
1162 ppSmStack("readscripts-loop1");
1163 getFileInfo(scriptName[n], &timeStamp, &fileSize);
1164 if (timeChanged(timeStamp,lastChange[n])) {
1165 dropScriptsFrom(n-1);
1170 for (; n<NUM_SCRIPTS; n++) /* No scripts have been postponed */
1171 postponed[n] = FALSE; /* at this stage */
1174 while (numScripts<namesUpto) { /* Process any remaining scripts */
1175 ppSmStack("readscripts-loop2");
1176 getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
1177 timeSet(lastChange[numScripts],timeStamp);
1178 if (numScripts>0) /* no new script for prelude */
1179 startNewScript(scriptName[numScripts]);
1180 if (addScript(scriptName[numScripts],fileSize))
1183 dropScriptsFrom(numScripts-1);
1189 for (; n<numScripts; n++) {
1190 ppSmStack("readscripts-loop2");
1191 strcpy(name, scriptInfo[n].path);
1192 strcat(name, scriptInfo[n].modName);
1193 if (scriptInfo[n].fromSource)
1194 strcat(name, scriptInfo[n].srcExt); else
1195 strcat(name, ".u_hi"); //ToDo: should be .o
1196 getFileInfo(name,&timeStamp, &fileSize);
1197 if (timeChanged(timeStamp,scriptInfo[n].lastChange)) {
1198 dropScriptsFrom(n-1);
1203 for (; n<NUM_SCRIPTS; n++)
1204 scriptInfo[n].postponed = FALSE;
1208 while (numScripts < namesUpto) {
1209 ppSmStack ( "readscripts-loop2" );
1211 if (scriptInfo[numScripts].fromSource) {
1214 startNewScript(scriptInfo[numScripts].modName);
1215 nextNumScripts = NUM_SCRIPTS; //bogus initialisation
1216 if (addScript(numScripts)) {
1218 assert(nextNumScripts==NUM_SCRIPTS);
1221 dropScriptsFrom(numScripts-1);
1225 if (scriptInfo[numScripts].objLoaded) {
1228 scriptInfo[numScripts].objLoaded = TRUE;
1231 startNewScript(scriptInfo[numScripts].modName);
1233 nextNumScripts = NUM_SCRIPTS;
1234 if (addScript(numScripts)) {
1236 assert(nextNumScripts==NUM_SCRIPTS);
1238 //while (!scriptInfo[numScripts].fromSource && numScripts > 0)
1240 //if (scriptInfo[numScripts].fromSource)
1242 numScripts = nextNumScripts;
1243 assert(nextNumScripts<NUM_SCRIPTS);
1247 if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
1250 didPrelude = processInterfaces();
1252 preludeLoaded = TRUE;
1253 everybody(POSTPREL);
1257 { Int m = namesUpto-1;
1258 Text mtext = findText(scriptInfo[m].modName);
1260 /* Hack to avoid starting up in PrelHugs */
1261 if (mtext == findText("PrelHugs")) mtext = findText("Prelude");
1264 /* Commented out till we understand what
1265 * this is trying to do.
1266 * Problem, you cant find a module till later.
1269 setCurrModule(findModule(mtext));
1279 setLastEdit((String)0, 0);
1280 ppSmStack("readscripts-end ");
1283 static Void local whatScripts() { /* list scripts in current session */
1285 Printf("\nHugs session for:");
1287 Printf(" (project: %s)",currProject);
1288 for (i=0; i<numScripts; ++i)
1289 Printf("\n%s%s",scriptInfo[i].path, scriptInfo[i].modName);
1293 /* --------------------------------------------------------------------------
1294 * Access to external editor:
1295 * ------------------------------------------------------------------------*/
1297 static Void local editor() { /* interpreter-editor interface */
1298 String newFile = readFilename();
1300 setLastEdit(newFile,0);
1301 if (readFilename()) {
1302 ERRMSG(0) "Multiple filenames not permitted"
1309 static Void local find() { /* edit file containing definition */
1311 This just plain wont work no more.
1313 String nm = readFilename(); /* of specified name */
1315 ERRMSG(0) "No name specified"
1318 else if (readFilename()) {
1319 ERRMSG(0) "Multiple names not permitted"
1325 setCurrModule(findEvalModule());
1327 if (nonNull(c=findTycon(t=findText(nm)))) {
1328 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1329 readScripts(N_PRELUDE_SCRIPTS);
1331 } else if (nonNull(c=findName(t))) {
1332 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1333 readScripts(N_PRELUDE_SCRIPTS);
1336 ERRMSG(0) "No current definition for name \"%s\"", nm
1343 static Void local runEditor() { /* run editor on script lastEdit */
1344 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1345 readScripts(N_PRELUDE_SCRIPTS);
1348 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1353 lastEdit = strCopy(fname);
1355 #if HUGS_FOR_WINDOWS
1356 DrawStatusLine(hWndMain); /* Redo status line */
1360 /* --------------------------------------------------------------------------
1361 * Read and evaluate an expression:
1362 * ------------------------------------------------------------------------*/
1364 static Void local setModule(){/*set module in which to evaluate expressions*/
1365 String s = readFilename();
1366 if (!s) s = ""; /* :m clears the current module selection */
1367 evalModule = findText(s);
1368 setLastEdit(fileOfModule(findEvalModule()),0);
1371 static Module local findEvalModule() { /*Module in which to eval expressions*/
1372 Module m = findModule(evalModule);
1378 static Void local evaluator() { /* evaluate expr and print value */
1382 setCurrModule(findEvalModule());
1384 startNewScript(0); /* Enables recovery of storage */
1385 /* allocated during evaluation */
1388 defaultDefns = combined ? stdDefaults : evalDefaults;
1389 type = typeCheckExp(TRUE);
1391 if (isPolyType(type)) {
1392 ks = polySigOf(type);
1393 bd = monotypeOf(type);
1398 if (whatIs(bd)==QUAL) {
1399 ERRMSG(0) "Unresolved overloading" ETHEN
1400 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1401 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1411 if (isProgType(ks,bd)) {
1412 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1416 Cell d = provePred(ks,NIL,ap(classShow,bd));
1418 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1419 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1420 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1424 inputExpr = ap2(nameShow, d,inputExpr);
1425 inputExpr = ap (namePutStr, inputExpr);
1426 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1428 evalExp(); printf("\n");
1431 printType(stdout,type);
1438 printf ( "result type is " );
1439 printType ( stdout, type );
1448 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
1449 if (printing) { /* after successful termination or */
1450 printing = FALSE; /* runtime error (e.g. interrupt) */
1453 #define plural(v) v, (v==1?"":"s")
1454 Printf("%lu cell%s",plural(numCells));
1456 Printf(", %u garbage collection%s",plural(numGcs));
1465 /* --------------------------------------------------------------------------
1466 * Print type of input expression:
1467 * ------------------------------------------------------------------------*/
1469 static Void local showtype() { /* print type of expression (if any)*/
1472 setCurrModule(findEvalModule());
1473 startNewScript(0); /* Enables recovery of storage */
1474 /* allocated during evaluation */
1477 defaultDefns = evalDefaults;
1478 type = typeCheckExp(FALSE);
1479 printExp(stdout,inputExpr);
1481 printType(stdout,type);
1486 static Void local browseit(mod,t,all)
1493 Printf("module %s where\n",textToStr(module(mod).text));
1494 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1496 /* only look at things defined in this module,
1497 unless `all' flag is set */
1498 if (all || name(nm).mod == mod) {
1499 /* unwanted artifacts, like lambda lifted values,
1500 are in the list of names, but have no types */
1501 if (nonNull(name(nm).type)) {
1502 printExp(stdout,nm);
1504 printType(stdout,name(nm).type);
1506 Printf(" -- data constructor");
1507 } else if (isMfun(nm)) {
1508 Printf(" -- class member");
1509 } else if (isSfun(nm)) {
1510 Printf(" -- selector function");
1518 Printf("Unknown module %s\n",t);
1523 static Void local browse() { /* browse modules */
1524 Int count = 0; /* or give menu of commands */
1528 setCurrModule(findEvalModule());
1529 startNewScript(0); /* for recovery of storage */
1530 for (; (s=readFilename())!=0; count++)
1531 if (strcmp(s,"all") == 0) {
1535 browseit(findModule(findText(s)),s,all);
1537 browseit(findEvalModule(),NULL,all);
1541 #if EXPLAIN_INSTANCE_RESOLUTION
1542 static Void local xplain() { /* print type of expression (if any)*/
1544 Bool sir = showInstRes;
1546 setCurrModule(findEvalModule());
1547 startNewScript(0); /* Enables recovery of storage */
1548 /* allocated during evaluation */
1552 d = provePred(NIL,NIL,hd(inputContext));
1554 fprintf(stdout, "not Sat\n");
1556 fprintf(stdout, "Sat\n");
1562 /* --------------------------------------------------------------------------
1563 * Enhanced help system: print current list of scripts or give information
1565 * ------------------------------------------------------------------------*/
1567 static String local objToStr(m,c)
1570 #if 1 || DISPLAY_QUANTIFIERS
1571 static char newVar[60];
1572 switch (whatIs(c)) {
1573 case NAME : if (m == name(c).mod) {
1574 sprintf(newVar,"%s", textToStr(name(c).text));
1576 sprintf(newVar,"%s.%s",
1577 textToStr(module(name(c).mod).text),
1578 textToStr(name(c).text));
1582 case TYCON : if (m == tycon(c).mod) {
1583 sprintf(newVar,"%s", textToStr(tycon(c).text));
1585 sprintf(newVar,"%s.%s",
1586 textToStr(module(tycon(c).mod).text),
1587 textToStr(tycon(c).text));
1591 case CLASS : if (m == cclass(c).mod) {
1592 sprintf(newVar,"%s", textToStr(cclass(c).text));
1594 sprintf(newVar,"%s.%s",
1595 textToStr(module(cclass(c).mod).text),
1596 textToStr(cclass(c).text));
1600 default : internal("objToStr");
1604 static char newVar[33];
1605 switch (whatIs(c)) {
1606 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1609 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1612 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1615 default : internal("objToStr");
1623 static Void dumpStg ( void )
1627 setCurrModule(findEvalModule());
1631 /* request to locate a symbol by name */
1632 if (s && (*s == '?')) {
1633 Text t = findText(s+1);
1634 locateSymbolByName(t);
1638 /* request to dump a bit of the heap */
1639 if (s && (*s == '-' || isdigit(*s))) {
1646 /* request to dump a symbol table entry */
1648 || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
1649 || !isdigit(s[1])) {
1650 fprintf(stderr, ":d -- bad request `%s'\n", s );
1655 case 't': dumpTycon(i); break;
1656 case 'n': dumpName(i); break;
1657 case 'c': dumpClass(i); break;
1658 case 'i': dumpInst(i); break;
1659 default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
1665 static Void local dumpStg( void ) { /* print STG stuff */
1670 Cell v; /* really StgVar */
1671 setCurrModule(findEvalModule());
1673 for (; (s=readFilename())!=0;) {
1676 /* find the name while ignoring module scopes */
1677 for (i=NAMEMIN; i<nameHw; i++)
1678 if (name(i).text == t) n = i;
1680 /* perhaps it's an "idNNNNNN" thing? */
1683 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
1686 while (isdigit(s[i])) {
1687 v = v * 10 + (s[i]-'0');
1691 n = nameFromStgVar(v);
1694 if (isNull(n) && whatIs(v)==STGVAR) {
1695 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
1696 printStg(stderr, v );
1699 Printf ( "Unknown reference `%s'\n", s );
1702 Printf ( "Not a Name: `%s'\n", s );
1704 if (isNull(name(n).stgVar)) {
1705 Printf ( "Doesn't have a STG tree: %s\n", s );
1707 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
1708 printStg(stderr, name(n).stgVar);
1714 static Void local info() { /* describe objects */
1715 Int count = 0; /* or give menu of commands */
1718 setCurrModule(findEvalModule());
1719 startNewScript(0); /* for recovery of storage */
1720 for (; (s=readFilename())!=0; count++) {
1721 describe(findText(s));
1729 static Void local describe(t) /* describe an object */
1731 Tycon tc = findTycon(t);
1732 Class cl = findClass(t);
1733 Name nm = findName(t);
1735 if (nonNull(tc)) { /* as a type constructor */
1739 for (i=0; i<tycon(tc).arity; ++i) {
1740 t = ap(t,mkOffset(i));
1742 Printf("-- type constructor");
1744 Printf(" with kind ");
1745 printKind(stdout,tycon(tc).kind);
1748 switch (tycon(tc).what) {
1749 case SYNONYM : Printf("type ");
1750 printType(stdout,t);
1752 printType(stdout,tycon(tc).defn);
1756 case DATATYPE : { List cs = tycon(tc).defn;
1757 if (tycon(tc).what==DATATYPE) {
1762 printType(stdout,t);
1764 mapProc(printSyntax,cs);
1766 Printf("\n-- constructors:");
1768 for (; hasCfun(cs); cs=tl(cs)) {
1770 printExp(stdout,hd(cs));
1772 printType(stdout,name(hd(cs)).type);
1775 Printf("\n-- selectors:");
1777 for (; nonNull(cs); cs=tl(cs)) {
1779 printExp(stdout,hd(cs));
1781 printType(stdout,name(hd(cs)).type);
1786 case RESTRICTSYN : Printf("type ");
1787 printType(stdout,t);
1788 Printf(" = <restricted>");
1792 if (nonNull(in=findFirstInst(tc))) {
1793 Printf("\n-- instances:\n");
1796 in = findNextInst(tc,in);
1797 } while (nonNull(in));
1802 if (nonNull(cl)) { /* as a class */
1803 List ins = cclass(cl).instances;
1804 Kinds ks = cclass(cl).kinds;
1805 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
1806 Printf("-- type class");
1808 Printf("-- constructor class");
1810 Printf(" with arity ");
1811 printKinds(stdout,ks);
1815 mapProc(printSyntax,cclass(cl).members);
1817 if (nonNull(cclass(cl).supers)) {
1818 printContext(stdout,cclass(cl).supers);
1821 printPred(stdout,cclass(cl).head);
1823 if (nonNull(cclass(cl).fds)) {
1824 List fds = cclass(cl).fds;
1826 for (; nonNull(fds); fds=tl(fds)) {
1828 printFD(stdout,hd(fds));
1833 if (nonNull(cclass(cl).members)) {
1834 List ms = cclass(cl).members;
1837 Type t = name(hd(ms)).type;
1838 if (isPolyType(t)) {
1842 printExp(stdout,hd(ms));
1844 if (isNull(tl(fst(snd(t))))) {
1847 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
1849 printType(stdout,t);
1851 } while (nonNull(ms));
1855 Printf("\n-- instances:\n");
1859 } while (nonNull(ins));
1864 if (nonNull(nm)) { /* as a function/name */
1866 printExp(stdout,nm);
1868 if (nonNull(name(nm).type)) {
1869 printType(stdout,name(nm).type);
1871 Printf("<unknown type>");
1874 Printf(" -- data constructor");
1875 } else if (isMfun(nm)) {
1876 Printf(" -- class member");
1877 } else if (isSfun(nm)) {
1878 Printf(" -- selector function");
1884 if (isNull(tc) && isNull(cl) && isNull(nm)) {
1885 Printf("Unknown reference `%s'\n",textToStr(t));
1889 static Void local printSyntax(nm)
1891 Syntax sy = syntaxOf(nm);
1892 Text t = name(nm).text;
1893 String s = textToStr(t);
1894 if (sy != defaultSyntax(t)) {
1896 switch (assocOf(sy)) {
1897 case LEFT_ASS : Putchar('l'); break;
1898 case RIGHT_ASS : Putchar('r'); break;
1899 case NON_ASS : break;
1901 Printf(" %i ",precOf(sy));
1902 if (isascii((int)(*s)) && isalpha((int)(*s))) {
1911 static Void local showInst(in) /* Display instance decl header */
1913 Printf("instance ");
1914 if (nonNull(inst(in).specifics)) {
1915 printContext(stdout,inst(in).specifics);
1918 printPred(stdout,inst(in).head);
1922 /* --------------------------------------------------------------------------
1923 * List all names currently in scope:
1924 * ------------------------------------------------------------------------*/
1926 static Void local listNames() { /* list names matching optional pat*/
1927 String pat = readFilename();
1929 Int width = getTerminalWidth() - 1;
1932 Module mod = findEvalModule();
1934 if (pat) { /* First gather names to list */
1936 names = addNamesMatching(pat,names);
1937 } while ((pat=readFilename())!=0);
1939 names = addNamesMatching((String)0,names);
1941 if (isNull(names)) { /* Then print them out */
1942 ERRMSG(0) "No names selected"
1945 for (termPos=0; nonNull(names); names=tl(names)) {
1946 String s = objToStr(mod,hd(names));
1948 if (termPos+1+l>width) {
1951 } else if (termPos>0) {
1959 Printf("\n(%d names listed)\n", count);
1962 /* --------------------------------------------------------------------------
1963 * print a prompt and read a line of input:
1964 * ------------------------------------------------------------------------*/
1966 static Void local promptForInput(moduleName)
1967 String moduleName; {
1968 char promptBuffer[1000];
1970 /* This is portable but could overflow buffer */
1971 sprintf(promptBuffer,prompt,moduleName);
1973 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
1974 * promptBuffer instead.
1976 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
1977 /* Reset prompt to a safe default to avoid an infinite loop */
1979 prompt = strCopy("? ");
1980 internal("Combined prompt and evaluation module name too long");
1984 stringInput("main\0"); else
1985 consoleInput(promptBuffer);
1988 /* --------------------------------------------------------------------------
1989 * main read-eval-print loop, with error trapping:
1990 * ------------------------------------------------------------------------*/
1992 static jmp_buf catch_error; /* jump buffer for error trapping */
1994 static Void local interpreter(argc,argv)/* main interpreter loop */
1997 Int errorNumber = setjmp(catch_error);
1999 if (errorNumber && autoMain) {
2000 fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" );
2004 breakOn(TRUE); /* enable break trapping */
2005 if (numScripts==0) { /* only succeeds on first time, */
2006 if (errorNumber) /* before prelude has been loaded */
2007 fatal("Unable to load prelude");
2008 initialize(argc,argv);
2012 /* initialize calls startupHaskell, which trashes our signal handlers */
2017 everybody(RESET); /* reset to sensible initial state */
2018 dropScriptsFrom(numScripts-1); /* remove partially loaded scripts */
2019 /* not counting prelude as a script*/
2021 promptForInput(textToStr(module(findEvalModule()).text));
2023 cmd = readCommand(cmds, (Char)':', (Char)'!');
2028 case EDIT : editor();
2032 case LOAD : clearProject();
2033 forgetScriptsFrom(N_PRELUDE_SCRIPTS);
2036 case ALSO : clearProject();
2037 forgetScriptsFrom(numScripts);
2040 case RELOAD : readScripts(N_PRELUDE_SCRIPTS);
2042 case PROJECT: project();
2047 case EVAL : evaluator();
2049 case TYPEOF : showtype();
2051 case BROWSE : browse();
2053 #if EXPLAIN_INSTANCE_RESOLUTION
2054 case XPLAIN : xplain();
2057 case NAMES : listNames();
2061 case BADCMD : guidance();
2066 #ifdef CRUDE_PROFILING
2070 case SYSTEM : if (shellEsc(readLine()))
2071 Printf("Warning: Shell escape terminated abnormally\n");
2073 case CHGDIR : changeDir();
2077 case PNTVER: Printf("-- Hugs Version %s\n",
2080 case DUMP : dumpStg();
2083 case COLLECT: consGC = FALSE;
2086 Printf("Garbage collection recovered %d cells\n",
2093 Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
2094 millisecs(userElapsed), millisecs(systElapsed));
2096 if (autoMain) break;
2101 /* --------------------------------------------------------------------------
2102 * Display progress towards goal:
2103 * ------------------------------------------------------------------------*/
2105 static Target currTarget;
2106 static Bool aiming = FALSE;
2109 static Int charCount;
2111 Void setGoal(what, t) /* Set goal for what to be t */
2116 #if EXPLAIN_INSTANCE_RESOLUTION
2120 currTarget = (t?t:1);
2123 currPos = strlen(what);
2124 maxPos = getTerminalWidth() - 1;
2128 for (charCount=0; *what; charCount++)
2133 Void soFar(t) /* Indicate progress towards goal */
2134 Target t; { /* has now reached t */
2137 #if EXPLAIN_INSTANCE_RESOLUTION
2142 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2147 if (newPos>currPos) {
2150 while (newPos>++currPos);
2157 Void done() { /* Goal has now been achieved */
2160 #if EXPLAIN_INSTANCE_RESOLUTION
2165 while (maxPos>currPos++)
2170 for (; charCount>0; charCount--) {
2179 static Void local failed() { /* Goal cannot be reached due to */
2180 if (aiming) { /* errors */
2187 /* --------------------------------------------------------------------------
2189 * ------------------------------------------------------------------------*/
2191 Cell errAssert(l) /* message to use when raising asserts, etc */
2196 str = mkStr(findText(scriptFile));
2198 str = mkStr(findText(""));
2200 return (ap2(nameTangleMessage,str,mkInt(l)));
2204 Void errHead(l) /* print start of error message */
2206 failed(); /* failed to reach target ... */
2208 FPrintf(errorStream,"ERROR");
2211 FPrintf(errorStream," \"%s\"", scriptFile);
2212 setLastEdit(scriptFile,l);
2213 if (l) FPrintf(errorStream," (line %d)",l);
2216 FPrintf(errorStream,": ");
2217 FFlush(errorStream);
2220 Void errFail() { /* terminate error message and */
2221 Putc('\n',errorStream); /* produce exception to return to */
2222 FFlush(errorStream); /* main command loop */
2223 longjmp(catch_error,1);
2226 Void errAbort() { /* altern. form of error handling */
2227 failed(); /* used when suitable error message*/
2228 stopAnyPrinting(); /* has already been printed */
2232 Void internal(msg) /* handle internal error */
2234 #if HUGS_FOR_WINDOWS
2236 wsprintf(buf,"INTERNAL ERROR: %s",msg);
2237 MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2241 Printf("INTERNAL ERROR: %s\n",msg);
2243 longjmp(catch_error,1);
2246 Void fatal(msg) /* handle fatal error */
2248 #if HUGS_FOR_WINDOWS
2250 wsprintf(buf,"FATAL ERROR: %s",msg);
2251 MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2254 Printf("\nFATAL ERROR: %s\n",msg);
2259 sigHandler(breakHandler) { /* respond to break interrupt */
2260 #if HUGS_FOR_WINDOWS
2261 MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
2264 Printf("{Interrupted!}\n");
2266 breakOn(TRUE); /* reinstall signal handler - redundant on BSD systems */
2267 /* but essential on POSIX (and other?) systems */
2273 longjmp(catch_error,1);
2274 sigResume;/*NOTREACHED*/
2277 /* --------------------------------------------------------------------------
2278 * Read value from environment variable or registry:
2279 * ------------------------------------------------------------------------*/
2281 String fromEnv(var,def) /* return value of: */
2282 String var; /* environment variable named by var */
2283 String def; { /* or: default value given by def */
2284 String s = getenv(var);
2285 return (s ? s : def);
2288 /* --------------------------------------------------------------------------
2289 * String manipulation routines:
2290 * ------------------------------------------------------------------------*/
2292 static String local strCopy(s) /* make malloced copy of a string */
2296 if ((t=(char *)malloc(strlen(s)+1))==0) {
2297 ERRMSG(0) "String storage space exhausted"
2300 for (r=t; (*r++ = *s++)!=0; ) {
2307 /* --------------------------------------------------------------------------
2309 * We can redirect compiler output (prompts, error messages, etc) by
2310 * tweaking these functions.
2311 * ------------------------------------------------------------------------*/
2313 #if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
2315 #ifdef HAVE_STDARG_H
2318 #include <varargs.h>
2321 /* ----------------------------------------------------------------------- */
2323 #define BufferSize 10000 /* size of redirected output buffer */
2325 typedef struct _HugsStream {
2326 char buffer[BufferSize]; /* buffer for redirected output */
2327 Int next; /* next space in buffer */
2330 static Void local vBufferedPrintf ( HugsStream*, const char*, va_list );
2331 static Void local bufferedPutchar ( HugsStream*, Char );
2332 static String local bufferClear ( HugsStream *stream );
2334 static Void local vBufferedPrintf(stream, fmt, ap)
2338 Int spaceLeft = BufferSize - stream->next;
2339 char* p = &stream->buffer[stream->next];
2340 Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
2341 if (0 <= charsAdded && charsAdded < spaceLeft)
2342 stream->next += charsAdded;
2343 #if 1 /* we can either buffer the first n chars or buffer the last n chars */
2349 static Void local bufferedPutchar(stream, c)
2352 if (BufferSize - stream->next >= 2) {
2353 stream->buffer[stream->next++] = c;
2354 stream->buffer[stream->next] = '\0';
2358 static String local bufferClear(stream)
2359 HugsStream *stream; {
2360 if (stream->next == 0) {
2364 return stream->buffer;
2368 /* ----------------------------------------------------------------------- */
2370 static HugsStream outputStreamH;
2372 * We rely on standard C semantics to initialise outputStreamH.next to 0.
2375 Void hugsEnableOutput(f)
2380 String hugsClearOutputBuffer() {
2381 return bufferClear(&outputStreamH);
2384 #ifdef HAVE_STDARG_H
2385 Void hugsPrintf(const char *fmt, ...) {
2386 va_list ap; /* pointer into argument list */
2387 va_start(ap, fmt); /* make ap point to first arg after fmt */
2388 if (!disableOutput) {
2391 vBufferedPrintf(&outputStreamH, fmt, ap);
2393 va_end(ap); /* clean up */
2396 Void hugsPrintf(fmt, va_alist)
2399 va_list ap; /* pointer into argument list */
2400 va_start(ap); /* make ap point to first arg after fmt */
2401 if (!disableOutput) {
2404 vBufferedPrintf(&outputStreamH, fmt, ap);
2406 va_end(ap); /* clean up */
2412 if (!disableOutput) {
2415 bufferedPutchar(&outputStreamH, c);
2419 Void hugsFlushStdout() {
2420 if (!disableOutput) {
2427 if (!disableOutput) {
2432 #ifdef HAVE_STDARG_H
2433 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2436 if (!disableOutput) {
2437 vfprintf(fp, fmt, ap);
2439 vBufferedPrintf(&outputStreamH, fmt, ap);
2444 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2450 if (!disableOutput) {
2451 vfprintf(fp, fmt, ap);
2453 vBufferedPrintf(&outputStreamH, fmt, ap);
2459 Void hugsPutc(c, fp)
2462 if (!disableOutput) {
2465 bufferedPutchar(&outputStreamH, c);
2469 #endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
2470 /* --------------------------------------------------------------------------
2471 * Send message to each component of system:
2472 * ------------------------------------------------------------------------*/
2474 Void everybody(what) /* send command `what' to each component of*/
2475 Int what; { /* system to respond as appropriate ... */
2477 fprintf ( stderr, "EVERYBODY %d\n", what );
2479 machdep(what); /* The order of calling each component is */
2480 storage(what); /* important for the PREPREL command */
2483 translateControl(what);
2485 staticAnalysis(what);
2486 deriveControl(what);
2492 /* --------------------------------------------------------------------------
2493 * Hugs for Windows code (WinMain and related functions)
2494 * ------------------------------------------------------------------------*/
2496 #if HUGS_FOR_WINDOWS
2497 #include "winhugs.c"