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/01/11 14:21:43 $
14 * ------------------------------------------------------------------------*/
32 #include "Assembler.h" /* DEBUG_LoadSymbols */
34 Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
36 #if EXPLAIN_INSTANCE_RESOLUTION
37 Bool showInstRes = FALSE;
40 Bool multiInstRes = FALSE;
43 /* --------------------------------------------------------------------------
44 * Local function prototypes:
45 * ------------------------------------------------------------------------*/
47 static Void local initialize Args((Int,String []));
48 static Void local promptForInput Args((String));
49 static Void local interpreter Args((Int,String []));
50 static Void local menu Args((Void));
51 static Void local guidance Args((Void));
52 static Void local forHelp Args((Void));
53 static Void local set Args((Void));
54 static Void local changeDir Args((Void));
55 static Void local load Args((Void));
56 static Void local project Args((Void));
57 static Void local readScripts Args((Int));
58 static Void local whatScripts Args((Void));
59 static Void local editor Args((Void));
60 static Void local find Args((Void));
61 static Bool local startEdit Args((Int,String));
62 static Void local runEditor Args((Void));
63 static Void local setModule Args((Void));
64 static Module local findEvalModule Args((Void));
65 static Void local evaluator Args((Void));
66 static Void local stopAnyPrinting Args((Void));
67 static Void local showtype Args((Void));
68 static String local objToStr Args((Module, Cell));
69 static Void local info Args((Void));
70 static Void local printSyntax Args((Name));
71 static Void local showInst Args((Inst));
72 static Void local describe Args((Text));
73 static Void local listNames Args((Void));
75 static Void local toggleSet Args((Char,Bool));
76 static Void local togglesIn Args((Bool));
77 static Void local optionInfo Args((Void));
78 #if USE_REGISTRY || HUGS_FOR_WINDOWS
79 static String local optionsToStr Args((Void));
81 static Void local readOptions Args((String));
82 static Bool local processOption Args((String));
83 static Void local setHeapSize Args((String));
84 static Int local argToInt Args((String));
86 static Void local loadProject Args((String));
87 static Void local clearProject Args((Void));
88 static Bool local addScript Args((Int));
89 static Void local forgetScriptsFrom Args((Script));
90 static Void local setLastEdit Args((String,Int));
91 static Void local failed Args((Void));
92 static String local strCopy Args((String));
93 static Void local browseit Args((Module,String,Bool));
94 static Void local browse Args((Void));
96 /* --------------------------------------------------------------------------
97 * Machine dependent code for Hugs interpreter:
98 * ------------------------------------------------------------------------*/
100 Bool combined = TRUE;
107 /* --------------------------------------------------------------------------
109 * ------------------------------------------------------------------------*/
111 static Bool printing = FALSE; /* TRUE => currently printing value*/
112 static Bool showStats = FALSE; /* TRUE => print stats after eval */
113 static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
114 static Bool addType = FALSE; /* TRUE => print type with value */
115 static Bool useDots = RISCOS; /* TRUE => use dots in progress */
116 static Bool quiet = FALSE; /* TRUE => don't show progress */
117 static Bool lastWasObject = FALSE;
118 Bool preludeLoaded = FALSE;
119 Bool debugSC = FALSE;
123 String modName; /* Module name */
124 Bool details; /* FALSE => remaining fields are invalid */
125 String path; /* Path to module */
126 String srcExt; /* ".hs" or ".lhs" if fromSource */
127 Time lastChange; /* Time of last change to script */
128 Bool fromSource; /* FALSE => load object code */
129 Bool postponed; /* Indicates postponed load */
136 static Void local makeStackEntry Args((ScriptInfo*,String));
137 static Void local addStackEntry Args((String));
139 static ScriptInfo scriptInfo[NUM_SCRIPTS];
141 static Int numScripts; /* Number of scripts loaded */
142 static Int nextNumScripts;
143 static Int namesUpto; /* Number of script names set */
144 static Bool needsImports; /* set to TRUE if imports required */
145 String scriptFile; /* Name of current script (if any) */
149 static Text evalModule = 0; /* Name of module we eval exprs in */
150 static String currProject = 0; /* Name of current project file */
151 static Bool projectLoaded = FALSE; /* TRUE => project file loaded */
153 static Bool autoMain = FALSE;
154 static String lastEdit = 0; /* Name of script to edit (if any) */
155 static Int lastEdLine = 0; /* Editor line number (if possible)*/
156 static String prompt = 0; /* Prompt string */
157 static Int hpSize = DEFAULTHEAP; /* Desired heap size */
158 String hugsEdit = 0; /* String for editor command */
159 String hugsPath = 0; /* String for file search path */
161 List ifaces_outstanding = NIL;
164 static Bool disableOutput = FALSE; /* redirect output to buffer? */
167 String bool2str ( Bool b )
169 if (b) return "Yes"; else return "No ";
172 void ppSmStack ( String who )
176 fflush(stdout);fflush(stderr);
178 printf ( "ppSmStack %s: numScripts = %d namesUpto = %d needsImports = %s\n",
179 who, numScripts, namesUpto, bool2str(needsImports) );
180 assert (namesUpto >= numScripts);
181 printf ( " Det FrS Pst ObL Module Ext Size ModTime Path\n" );
182 for (i = namesUpto-1; i >= 0; i--) {
183 printf ( "%c%2d: %3s %3s %3s %3s %16s %-4s %5ld %8lx %s\n",
184 (i==numScripts ? '*' : ' '),
185 i, bool2str(scriptInfo[i].details),
186 bool2str(scriptInfo[i].fromSource),
187 bool2str(scriptInfo[i].postponed),
188 bool2str(scriptInfo[i].objLoaded),
189 scriptInfo[i].modName,
190 scriptInfo[i].fromSource ? scriptInfo[i].srcExt : "",
192 scriptInfo[i].lastChange,
196 fflush(stdout);fflush(stderr);
202 /* --------------------------------------------------------------------------
204 * ------------------------------------------------------------------------*/
206 #ifndef NO_MAIN /* we omit main when building the "Hugs server" */
208 Main main Args((Int, String [])); /* now every func has a prototype */
213 #ifdef HAVE_CONSOLE_H /* Macintosh port */
215 _fcreator = 'R*ch'; /* // 'KAHL'; //'*TEX'; //'ttxt'; */
217 console_options.top = 50;
218 console_options.left = 20;
220 console_options.nrows = 32;
221 console_options.ncols = 80;
223 console_options.pause_atexit = 1;
224 console_options.title = "\pHugs";
226 console_options.procID = 5;
227 argc = ccommand(&argv);
230 CStackBase = &argc; /* Save stack base for use in gc */
232 /* If first arg is +Q or -Q, be entirely silent, and automatically run
233 main after loading scripts. Useful for running the nofib suite. */
234 if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
236 if (strcmp(argv[1],"-Q") == 0) {
241 Printf("__ __ __ __ ____ ___ _________________________________________\n");
242 Printf("|| || || || || || ||__ STGHugs: Based on the Haskell 98 standard\n");
243 Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n");
244 Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
245 Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
246 Printf("|| || Version: %s _________________________________________\n\n",HUGS_VERSION);
248 /* Get the absolute path to the directory containing the hugs
249 executable, so that we know where the Prelude and nHandle.so/.dll are.
250 We do this by reading env var STGHUGSDIR. This needs to succeed, so
251 setInstallDir won't return unless it succeeds.
253 setInstallDir ( argv[0] );
256 Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
259 interpreter(argc,argv);
260 Printf("[Leaving Hugs]\n");
271 /* --------------------------------------------------------------------------
272 * Initialization, interpret command line args and read prelude:
273 * ------------------------------------------------------------------------*/
275 static Void local initialize(argc,argv)/* Interpreter initialization */
280 char argv_0_orig[1000];
282 setLastEdit((String)0,0);
289 hugsEdit = strCopy(fromEnv("EDITOR","c:\\windows\\notepad.exe"));
293 hugsEdit = strCopy(fromEnv("EDITOR",NULL));
295 hugsPath = strCopy(HUGSPATH);
296 readOptions("-p\"%s> \" -r$$");
298 projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
299 "HUGSPATH", PATHSEP, ""));
300 readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
301 readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
302 #endif /* USE_REGISTRY */
303 readOptions(fromEnv("STGHUGSFLAGS",""));
305 strncpy(argv_0_orig,argv[0],1000); /* startupHaskell mangles argv[0] */
306 startupHaskell (argc,argv);
307 argc = prog_argc; argv = prog_argv;
309 namesUpto = numScripts = 0;
311 /* Pre-scan flags to see if -c or +c is present. This needs to
312 precede adding the stack entry for Prelude. On the other hand,
313 that stack entry needs to be made before the cmd line args are
314 properly examined. Hence the following pre-scan of them.
316 for (i=1; i < argc; ++i) {
317 if (strcmp(argv[i], "--")==0) break;
318 if (strcmp(argv[i], "-c")==0) combined = FALSE;
319 if (strcmp(argv[i], "+c")==0) combined = TRUE;
322 addStackEntry("Prelude");
323 if (combined) addStackEntry("PrelHugs");
325 for (i=1; i < argc; ++i) { /* process command line arguments */
326 if (strcmp(argv[i], "--")==0) break;
327 if (strcmp(argv[i],"+")==0 && i+1<argc) {
329 ERRMSG(0) "Multiple project filenames on command line"
334 } else if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
335 && !processOption(argv[i])) {
336 addStackEntry(argv[i]);
342 char exe_name[N_INSTALLDIR + 6];
343 strcpy(exe_name, installDir);
344 strcat(exe_name, "hugs");
345 DEBUG_LoadSymbols(exe_name);
351 if (!scriptName[0]) {
352 Printf("Prelude not found on current path: \"%s\"\n",
353 hugsPath ? hugsPath : "");
354 fatal("Unable to load prelude");
359 Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n");
361 Printf("Hugs mode: Restart with command line option +98 for Haskell 98 mode\n");
365 Printf("Combined mode: Restart with command line -c for standalone mode\n\n" );
367 Printf("Standalone mode: Restart with command line +c for combined mode\n\n" );
372 evalModule = findText(""); /* evaluate wrt last module by default */
376 "\nUsing project file, ignoring additional filenames\n");
378 loadProject(strCopy(proj));
383 /* --------------------------------------------------------------------------
384 * Command line options:
385 * ------------------------------------------------------------------------*/
387 struct options { /* command line option toggles */
388 char c; /* table defined in main app. */
393 extern struct options toggle[];
395 static Void local toggleSet(c,state) /* Set command line toggle */
399 for (i=0; toggle[i].c; ++i)
400 if (toggle[i].c == c) {
401 *toggle[i].flag = state;
404 ERRMSG(0) "Unknown toggle `%c'", c
408 static Void local togglesIn(state) /* Print current list of toggles in*/
409 Bool state; { /* given state */
412 for (i=0; toggle[i].c; ++i)
413 if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
415 Putchar((char)(state ? '+' : '-'));
416 Putchar(toggle[i].c);
423 static Void local optionInfo() { /* Print information about command */
424 static String fmts = "%-5s%s\n"; /* line settings */
425 static String fmtc = "%-5c%s\n";
428 Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
429 for (i=0; toggle[i].c; ++i) {
430 if (!haskell98 || toggle[i].h98) {
431 Printf(fmtc,toggle[i].c,toggle[i].description);
435 Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
436 Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
437 Printf(fmts,"pstr","Set prompt string to str");
438 Printf(fmts,"rstr","Set repeat last expression string to str");
439 Printf(fmts,"Pstr","Set search path for modules to str");
440 Printf(fmts,"Estr","Use editor setting given by str");
441 Printf(fmts,"cnum","Set constraint cutoff limit");
442 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
443 Printf(fmts,"Fstr","Set preprocessor filter to str");
446 Printf("\nCurrent settings: ");
449 Printf("-h%d",heapSize);
453 printString(repeatStr);
454 Printf(" -c%d",cutoff);
455 Printf("\nSearch path : -P");
456 printString(hugsPath);
459 if (projectPath!=NULL) {
460 Printf("\nProject Path : %s",projectPath);
463 Printf("\nEditor setting : -E");
464 printString(hugsEdit);
465 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
466 Printf("\nPreprocessor : -F");
467 printString(preprocessor);
469 Printf("\nCompatibility : %s", haskell98 ? "Haskell 98 (+98)"
470 : "Hugs Extensions (-98)");
474 #if USE_REGISTRY || HUGS_FOR_WINDOWS
482 #define PUTInt(optc,i) \
483 sprintf(next,"-%c%d",optc,i); \
486 #define PUTStr(c,s) \
487 next=PUTStr_aux(next,c,s)
489 static String local PUTStr_aux Args((String,Char, String));
491 static String local PUTStr_aux(next,c,s)
497 sprintf(next,"-%c\"",c);
500 PUTS(unlexChar(*t,'"'));
508 static String local optionsToStr() { /* convert options to string */
509 static char buffer[2000];
510 String next = buffer;
513 for (i=0; toggle[i].c; ++i) {
514 PUTC(*toggle[i].flag ? '+' : '-');
518 PUTS(haskell98 ? "+98 " : "-98 ");
519 PUTInt('h',hpSize); PUTC(' ');
521 PUTStr('r',repeatStr);
522 PUTStr('P',hugsPath);
523 PUTStr('E',hugsEdit);
524 PUTInt('c',cutoff); PUTC(' ');
525 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
526 PUTStr('F',preprocessor);
531 #endif /* USE_REGISTRY */
538 static Void local readOptions(options) /* read options from string */
542 stringInput(options);
543 while ((s=readFilename())!=0) {
544 if (*s && !processOption(s)) {
545 ERRMSG(0) "Option string must begin with `+' or `-'"
552 static Bool local processOption(s) /* process string s for options, */
553 String s; { /* return FALSE if none found. */
565 case 'Q' : break; /* already handled */
567 case 'p' : if (s[1]) {
568 if (prompt) free(prompt);
569 prompt = strCopy(s+1);
573 case 'r' : if (s[1]) {
574 if (repeatStr) free(repeatStr);
575 repeatStr = strCopy(s+1);
580 String p = substPath(s+1,hugsPath ? hugsPath : "");
581 if (hugsPath) free(hugsPath);
586 case 'E' : if (hugsEdit) free(hugsEdit);
587 hugsEdit = strCopy(s+1);
590 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
591 case 'F' : if (preprocessor) free(preprocessor);
592 preprocessor = strCopy(s+1);
596 case 'h' : setHeapSize(s+1);
599 case 'c' : if (heapBuilt()) {
601 "You can't enable/disable combined"
602 " operation inside Hugs\n" );
604 /* don't do anything, since pre-scan of args
605 will have got it already */
609 case 'D' : /* hack */
611 extern void setRtsFlags( int x );
612 setRtsFlags(argToInt(s+1));
616 default : if (strcmp("98",s)==0) {
617 if (heapBuilt() && ((state && !haskell98) ||
618 (!state && haskell98))) {
620 "Haskell 98 compatibility cannot be changed"
621 " while the interpreter is running\n");
634 static Void local setHeapSize(s)
637 hpSize = argToInt(s);
638 if (hpSize < MINIMUMHEAP)
639 hpSize = MINIMUMHEAP;
640 else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
641 hpSize = MAXIMUMHEAP;
642 if (heapBuilt() && hpSize != heapSize) {
643 /* ToDo: should this use a message box in winhugs? */
645 FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
647 FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
655 static Int local argToInt(s) /* read integer from argument str */
660 if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
661 ERRMSG(0) "Missing integer in option setting \"%s\"", t
666 Int d = (*s++) - '0';
667 if (n > ((MAXPOSINT - d)/10)) {
668 ERRMSG(0) "Option setting \"%s\" is too large", t
672 } while (isascii((int)(*s)) && isdigit((int)(*s)));
674 if (*s=='K' || *s=='k') {
675 if (n > (MAXPOSINT/1000)) {
676 ERRMSG(0) "Option setting \"%s\" is too large", t
683 #if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
684 if (*s=='M' || *s=='m') {
685 if (n > (MAXPOSINT/1000000)) {
686 ERRMSG(0) "Option setting \"%s\" is too large", t
694 #if MAXPOSINT > 1000000000
695 if (*s=='G' || *s=='g') {
696 if (n > (MAXPOSINT/1000000000)) {
697 ERRMSG(0) "Option setting \"%s\" is too large", t
706 ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
713 /* --------------------------------------------------------------------------
714 * Print Menu of list of commands:
715 * ------------------------------------------------------------------------*/
717 static struct cmd cmds[] = {
718 {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
719 {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
720 {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
721 {":quit", QUIT}, {":set", SET}, {":find", FIND},
722 {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
723 {":dump", DUMP}, {":ztats", STATS},
724 {":module",SETMODULE},
726 #if EXPLAIN_INSTANCE_RESOLUTION
729 {":version", PNTVER},
734 static Void local menu() {
735 Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
736 Printf("c is the first character in the full name.\n\n");
737 Printf(":load <filenames> load modules from specified files\n");
738 Printf(":load clear all files except prelude\n");
739 Printf(":also <filenames> read additional modules\n");
740 Printf(":reload repeat last load command\n");
741 Printf(":project <filename> use project file\n");
742 Printf(":edit <filename> edit file\n");
743 Printf(":edit edit last module\n");
744 Printf(":module <module> set module for evaluating expressions\n");
745 Printf("<expr> evaluate expression\n");
746 Printf(":type <expr> print type of expression\n");
747 Printf(":? display this list of commands\n");
748 Printf(":set <options> set command line options\n");
749 Printf(":set help on command line options\n");
750 Printf(":names [pat] list names currently in scope\n");
751 Printf(":info <names> describe named objects\n");
752 Printf(":browse <modules> browse names defined in <modules>\n");
753 #if EXPLAIN_INSTANCE_RESOLUTION
754 Printf(":xplain <context> explain instance resolution for <context>\n");
756 Printf(":find <name> edit module containing definition of name\n");
757 Printf(":!command shell escape\n");
758 Printf(":cd dir change directory\n");
759 Printf(":gc force garbage collection\n");
760 Printf(":version print Hugs version\n");
761 Printf(":dump <name> print STG code for named fn\n");
762 #ifdef CRUDE_PROFILING
763 Printf(":ztats <name> print reduction stats\n");
765 Printf(":quit exit Hugs interpreter\n");
768 static Void local guidance() {
769 Printf("Command not recognised. ");
773 static Void local forHelp() {
774 Printf("Type :? for help\n");
777 /* --------------------------------------------------------------------------
778 * Setting of command line options:
779 * ------------------------------------------------------------------------*/
781 struct options toggle[] = { /* List of command line toggles */
782 {'s', 1, "Print no. reductions/cells after eval", &showStats},
783 {'t', 1, "Print type after evaluation", &addType},
784 {'g', 1, "Print no. cells recovered after gc", &gcMessages},
785 {'l', 1, "Literate modules as default", &literateScripts},
786 {'e', 1, "Warn about errors in literate modules", &literateErrors},
787 {'.', 1, "Print dots to show progress", &useDots},
788 {'q', 1, "Print nothing to show progress", &quiet},
789 {'w', 1, "Always show which modules are loaded", &listScripts},
790 {'k', 1, "Show kind errors in full", &kindExpert},
791 {'o', 0, "Allow overlapping instances", &allowOverlap},
795 {'D', 1, "Debug: show generated code", &debugCode},
797 #if EXPLAIN_INSTANCE_RESOLUTION
798 {'x', 1, "Explain instance resolution", &showInstRes},
801 {'m', 0, "Use multi instance resolution", &multiInstRes},
804 {'D', 1, "Debug: show generated G code", &debugCode},
806 {'S', 1, "Debug: show generated SC code", &debugSC},
810 static Void local set() { /* change command line options from*/
811 String s; /* Hugs command line */
813 if ((s=readFilename())!=0) {
815 if (!processOption(s)) {
816 ERRMSG(0) "Option string must begin with `+' or `-'"
819 } while ((s=readFilename())!=0);
821 writeRegString("Options", optionsToStr());
828 /* --------------------------------------------------------------------------
829 * Change directory command:
830 * ------------------------------------------------------------------------*/
832 static Void local changeDir() { /* change directory */
833 String s = readFilename();
835 ERRMSG(0) "Unable to change to directory \"%s\"", s
840 /* --------------------------------------------------------------------------
841 * Loading project and script files:
842 * ------------------------------------------------------------------------*/
844 static Void local loadProject(s) /* Load project file */
848 projInput(currProject);
849 scriptFile = currProject;
850 forgetScriptsFrom(1);
851 while ((s=readFilename())!=0)
854 ERRMSG(0) "Empty project file"
858 projectLoaded = TRUE;
861 static Void local clearProject() { /* clear name for current project */
865 projectLoaded = FALSE;
867 setLastEdit((String)0,0);
873 static Void local makeStackEntry ( ScriptInfo* ent, String iname )
876 Bool sAvail, iAvail, oAvail;
877 Time sTime, iTime, oTime;
878 Long sSize, iSize, oSize;
881 ok = findFilesForModule (
885 &sAvail, &sTime, &sSize,
886 &iAvail, &iTime, &iSize,
887 &oAvail, &oTime, &oSize
891 "Can't find source or object+interface for module \"%s\"",
892 /* "Can't find source for module \"%s\"", */
896 /* findFilesForModule should enforce this */
897 if (!(sAvail || (oAvail && iAvail)))
899 /* Load objects in preference to sources if both are available */
900 /* 11 Oct 99: disable object loading in the interim.
901 Will probably only reinstate when HEP becomes available.
905 ? (oAvail && iAvail && timeEarlier(sTime,oTime))
911 /* ToDo: namesUpto overflow */
912 ent->modName = strCopy(iname);
915 ent->fromSource = !fromObj;
917 ent->postponed = FALSE;
918 ent->lastChange = sTime; /* ToDo: is this right? */
919 ent->size = fromObj ? iSize : sSize;
920 ent->oSize = fromObj ? oSize : 0;
921 ent->objLoaded = FALSE;
926 static Void nukeEnding( String s )
929 if (l > 4 && strncmp(s+l-4,".u_o" ,4)==0) s[l-4] = 0; else
930 if (l > 5 && strncmp(s+l-5,".u_hi",5)==0) s[l-5] = 0; else
931 if (l > 3 && strncmp(s+l-3,".hs" ,3)==0) s[l-3] = 0; else
932 if (l > 4 && strncmp(s+l-4,".lhs" ,4)==0) s[l-4] = 0; else
933 if (l > 4 && strncmp(s+l-4,".dll" ,4)==0) s[l-4] = 0; else
934 if (l > 4 && strncmp(s+l-4,".DLL" ,4)==0) s[l-4] = 0;
937 static Void local addStackEntry(s) /* Add script to list of scripts */
938 String s; { /* to be read in ... */
943 if (namesUpto>=NUM_SCRIPTS) {
944 ERRMSG(0) "Too many module files (maximum of %d allowed)",
951 for (s2 = s; *s2; s2++)
952 if (*s2 == SLASH && *(s2+1)) s = s2+1;
955 for (i = 0; i < namesUpto; i++)
956 if (strcmp(scriptInfo[i].modName,s)==0)
960 makeStackEntry ( &scriptInfo[namesUpto], strCopy(s) );
966 /* Return TRUE if no imports were needed; FALSE otherwise. */
967 static Bool local addScript(stacknum) /* read single file */
970 static char name[FILENAME_MAX+1];
971 Int len = scriptInfo[stacknum].size;
973 #if HUGS_FOR_WINDOWS /* Set clock cursor while loading */
975 SetCursor(LoadCursor(NULL, IDC_WAIT));
978 // setLastEdit(name,0);
980 strcpy(name, scriptInfo[stacknum].path);
981 strcat(name, scriptInfo[stacknum].modName);
982 if (scriptInfo[stacknum].fromSource)
983 strcat(name, scriptInfo[stacknum].srcExt); else
984 strcat(name, ".u_hi");
988 if (scriptInfo[stacknum].fromSource) {
990 didPrelude = processInterfaces();
992 preludeLoaded = TRUE;
996 lastWasObject = FALSE;
997 Printf("Reading script \"%s\":\n",name);
998 needsImports = FALSE;
999 parseScript(name,len);
1000 if (needsImports) return FALSE;
1008 char nameObj[FILENAME_MAX+1];
1011 Printf("Reading iface \"%s\":\n", name);
1013 needsImports = FALSE;
1015 // set nameObj for the benefit of openGHCIface
1016 strcpy(nameObj, scriptInfo[stacknum].path);
1017 strcat(nameObj, scriptInfo[stacknum].modName);
1018 strcat(nameObj, DLL_ENDING);
1019 sizeObj = scriptInfo[stacknum].oSize;
1021 iface = readInterface(name,len);
1022 imports = zsnd(iface); iface = zfst(iface);
1024 if (nonNull(imports)) chase(imports);
1026 lastWasObject = TRUE;
1028 iface_info = ztriple(iface, findText(nameObj), mkInt(sizeObj) );
1029 ifaces_outstanding = cons(iface_info,ifaces_outstanding);
1031 if (needsImports) return FALSE;
1040 Bool chase(imps) /* Process list of import requests */
1044 Int origPos = numScripts; /* keep track of original position */
1045 String origName = scriptInfo[origPos].modName;
1046 for (; nonNull(imps); imps=tl(imps)) {
1047 String iname = textToStr(textOf(hd(imps)));
1049 for (; i<namesUpto; i++)
1050 if (strcmp(scriptInfo[i].modName,iname)==0)
1052 //fprintf(stderr, "import name = %s num = %d\n", iname, i );
1055 /* We should have filled in the details of each module
1056 the first time we hear about it.
1058 assert(scriptInfo[i].details);
1061 if (i>=origPos) { /* Neither loaded or queued */
1067 needsImports = TRUE;
1068 if (scriptInfo[origPos].fromSource)
1069 scriptInfo[origPos].postponed = TRUE;
1071 if (i==namesUpto) { /* Name not found (i==namesUpto) */
1072 /* Find out where it lives, whether source or object, etc */
1073 makeStackEntry ( &scriptInfo[i], iname );
1077 if (scriptInfo[i].postponed && scriptInfo[i].fromSource) {
1078 /* Check for recursive dependency */
1080 "Recursive import dependency between \"%s\" and \"%s\"",
1081 scriptInfo[origPos].modName, iname
1084 /* Move stack entry i to somewhere below origPos. If i denotes
1085 * an object, destination is immediately below origPos.
1086 * Otherwise, it's underneath the queue of objects below origPos.
1088 dstPosn = origPos-1;
1089 if (scriptInfo[i].fromSource)
1090 while (!scriptInfo[dstPosn].fromSource && dstPosn > 0)
1094 tmp = scriptInfo[i];
1095 for (; i > dstPosn; i--) scriptInfo[i] = scriptInfo[i-1];
1096 scriptInfo[dstPosn] = tmp;
1097 if (dstPosn < nextNumScripts) nextNumScripts = dstPosn;
1101 return needsImports;
1104 static Void local forgetScriptsFrom(scno)/* remove scripts from system */
1108 for (i=scno; i<namesUpto; ++i)
1110 free(scriptName[i]);
1112 dropScriptsFrom(scno-1);
1114 if (numScripts>namesUpto)
1118 /* --------------------------------------------------------------------------
1119 * Commands for loading and removing script files:
1120 * ------------------------------------------------------------------------*/
1122 static Void local load() { /* read filenames from command line */
1123 String s; /* and add to list of scripts waiting */
1125 while ((s=readFilename())!=0)
1130 static Void local project() { /* read list of script names from */
1131 String s; /* project file */
1133 if ((s=readFilename()) || currProject) {
1135 s = strCopy(currProject);
1136 else if (readFilename()) {
1137 ERRMSG(0) "Too many project files"
1144 ERRMSG(0) "No project filename specified"
1151 static Void local readScripts(n) /* Reread current list of scripts, */
1152 Int n; { /* loading everything after and */
1153 Time timeStamp; /* including the first script which*/
1154 Long fileSize; /* has been either changed or added*/
1155 static char name[FILENAME_MAX+1];
1158 lastWasObject = FALSE;
1159 ppSmStack("readscripts-begin");
1160 #if HUGS_FOR_WINDOWS
1161 SetCursor(LoadCursor(NULL, IDC_WAIT));
1165 for (; n<numScripts; n++) { /* Scan previously loaded scripts */
1166 ppSmStack("readscripts-loop1");
1167 getFileInfo(scriptName[n], &timeStamp, &fileSize);
1168 if (timeChanged(timeStamp,lastChange[n])) {
1169 dropScriptsFrom(n-1);
1174 for (; n<NUM_SCRIPTS; n++) /* No scripts have been postponed */
1175 postponed[n] = FALSE; /* at this stage */
1178 while (numScripts<namesUpto) { /* Process any remaining scripts */
1179 ppSmStack("readscripts-loop2");
1180 getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
1181 timeSet(lastChange[numScripts],timeStamp);
1182 if (numScripts>0) /* no new script for prelude */
1183 startNewScript(scriptName[numScripts]);
1184 if (addScript(scriptName[numScripts],fileSize))
1187 dropScriptsFrom(numScripts-1);
1193 for (; n<numScripts; n++) {
1194 ppSmStack("readscripts-loop2");
1195 strcpy(name, scriptInfo[n].path);
1196 strcat(name, scriptInfo[n].modName);
1197 if (scriptInfo[n].fromSource)
1198 strcat(name, scriptInfo[n].srcExt); else
1199 strcat(name, ".u_hi"); //ToDo: should be .o
1200 getFileInfo(name,&timeStamp, &fileSize);
1201 if (timeChanged(timeStamp,scriptInfo[n].lastChange)) {
1202 dropScriptsFrom(n-1);
1207 for (; n<NUM_SCRIPTS; n++)
1208 scriptInfo[n].postponed = FALSE;
1212 while (numScripts < namesUpto) {
1213 ppSmStack ( "readscripts-loop2" );
1215 if (scriptInfo[numScripts].fromSource) {
1218 startNewScript(scriptInfo[numScripts].modName);
1219 nextNumScripts = NUM_SCRIPTS; //bogus initialisation
1220 if (addScript(numScripts)) {
1222 assert(nextNumScripts==NUM_SCRIPTS);
1225 dropScriptsFrom(numScripts-1);
1229 if (scriptInfo[numScripts].objLoaded) {
1232 scriptInfo[numScripts].objLoaded = TRUE;
1235 startNewScript(scriptInfo[numScripts].modName);
1237 nextNumScripts = NUM_SCRIPTS;
1238 if (addScript(numScripts)) {
1240 assert(nextNumScripts==NUM_SCRIPTS);
1242 //while (!scriptInfo[numScripts].fromSource && numScripts > 0)
1244 //if (scriptInfo[numScripts].fromSource)
1246 numScripts = nextNumScripts;
1247 assert(nextNumScripts<NUM_SCRIPTS);
1251 if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
1254 didPrelude = processInterfaces();
1256 preludeLoaded = TRUE;
1257 everybody(POSTPREL);
1261 { Int m = namesUpto-1;
1262 Text mtext = findText(scriptInfo[m].modName);
1263 /* Commented out till we understand what
1264 * this is trying to do.
1265 * Problem, you cant find a module till later.
1268 setCurrModule(findModule(mtext));
1278 setLastEdit((String)0, 0);
1279 ppSmStack("readscripts-end ");
1282 static Void local whatScripts() { /* list scripts in current session */
1284 Printf("\nHugs session for:");
1286 Printf(" (project: %s)",currProject);
1287 for (i=0; i<numScripts; ++i)
1288 Printf("\n%s%s",scriptInfo[i].path, scriptInfo[i].modName);
1292 /* --------------------------------------------------------------------------
1293 * Access to external editor:
1294 * ------------------------------------------------------------------------*/
1296 static Void local editor() { /* interpreter-editor interface */
1297 String newFile = readFilename();
1299 setLastEdit(newFile,0);
1300 if (readFilename()) {
1301 ERRMSG(0) "Multiple filenames not permitted"
1308 static Void local find() { /* edit file containing definition */
1310 This just plain wont work no more.
1312 String nm = readFilename(); /* of specified name */
1314 ERRMSG(0) "No name specified"
1317 else if (readFilename()) {
1318 ERRMSG(0) "Multiple names not permitted"
1324 setCurrModule(findEvalModule());
1326 if (nonNull(c=findTycon(t=findText(nm)))) {
1327 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1330 } else if (nonNull(c=findName(t))) {
1331 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1335 ERRMSG(0) "No current definition for name \"%s\"", nm
1342 static Void local runEditor() { /* run editor on script lastEdit */
1343 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1347 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1352 lastEdit = strCopy(fname);
1354 #if HUGS_FOR_WINDOWS
1355 DrawStatusLine(hWndMain); /* Redo status line */
1359 /* --------------------------------------------------------------------------
1360 * Read and evaluate an expression:
1361 * ------------------------------------------------------------------------*/
1363 static Void local setModule(){/*set module in which to evaluate expressions*/
1364 String s = readFilename();
1365 if (!s) s = ""; /* :m clears the current module selection */
1366 evalModule = findText(s);
1367 setLastEdit(fileOfModule(findEvalModule()),0);
1370 static Module local findEvalModule() { /*Module in which to eval expressions*/
1371 Module m = findModule(evalModule);
1377 static Void local evaluator() { /* evaluate expr and print value */
1381 setCurrModule(findEvalModule());
1383 startNewScript(0); /* Enables recovery of storage */
1384 /* allocated during evaluation */
1387 defaultDefns = evalDefaults;
1388 type = typeCheckExp(TRUE);
1390 if (isPolyType(type)) {
1391 ks = polySigOf(type);
1392 bd = monotypeOf(type);
1397 if (whatIs(bd)==QUAL) {
1398 ERRMSG(0) "Unresolved overloading" ETHEN
1399 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1400 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1410 if (isProgType(ks,bd)) {
1411 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1415 Cell d = provePred(ks,NIL,ap(classShow,bd));
1417 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1418 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1419 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1423 inputExpr = ap2(nameShow, d,inputExpr);
1424 inputExpr = ap (namePutStr, inputExpr);
1425 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1427 evalExp(); printf("\n");
1430 printType(stdout,type);
1437 printf ( "result type is " );
1438 printType ( stdout, type );
1447 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
1448 if (printing) { /* after successful termination or */
1449 printing = FALSE; /* runtime error (e.g. interrupt) */
1452 #define plural(v) v, (v==1?"":"s")
1453 Printf("%lu cell%s",plural(numCells));
1455 Printf(", %u garbage collection%s",plural(numGcs));
1464 /* --------------------------------------------------------------------------
1465 * Print type of input expression:
1466 * ------------------------------------------------------------------------*/
1468 static Void local showtype() { /* print type of expression (if any)*/
1471 setCurrModule(findEvalModule());
1472 startNewScript(0); /* Enables recovery of storage */
1473 /* allocated during evaluation */
1476 defaultDefns = evalDefaults;
1477 type = typeCheckExp(FALSE);
1478 printExp(stdout,inputExpr);
1480 printType(stdout,type);
1485 static Void local browseit(mod,t,all)
1492 Printf("module %s where\n",textToStr(module(mod).text));
1493 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1495 /* only look at things defined in this module,
1496 unless `all' flag is set */
1497 if (all || name(nm).mod == mod) {
1498 /* unwanted artifacts, like lambda lifted values,
1499 are in the list of names, but have no types */
1500 if (nonNull(name(nm).type)) {
1501 printExp(stdout,nm);
1503 printType(stdout,name(nm).type);
1505 Printf(" -- data constructor");
1506 } else if (isMfun(nm)) {
1507 Printf(" -- class member");
1508 } else if (isSfun(nm)) {
1509 Printf(" -- selector function");
1517 Printf("Unknown module %s\n",t);
1522 static Void local browse() { /* browse modules */
1523 Int count = 0; /* or give menu of commands */
1527 setCurrModule(findEvalModule());
1528 startNewScript(0); /* for recovery of storage */
1529 for (; (s=readFilename())!=0; count++)
1530 if (strcmp(s,"all") == 0) {
1534 browseit(findModule(findText(s)),s,all);
1536 browseit(findEvalModule(),NULL,all);
1540 #if EXPLAIN_INSTANCE_RESOLUTION
1541 static Void local xplain() { /* print type of expression (if any)*/
1543 Bool sir = showInstRes;
1545 setCurrModule(findEvalModule());
1546 startNewScript(0); /* Enables recovery of storage */
1547 /* allocated during evaluation */
1551 d = provePred(NIL,NIL,hd(inputContext));
1553 fprintf(stdout, "not Sat\n");
1555 fprintf(stdout, "Sat\n");
1561 /* --------------------------------------------------------------------------
1562 * Enhanced help system: print current list of scripts or give information
1564 * ------------------------------------------------------------------------*/
1566 static String local objToStr(m,c)
1569 #if 1 || DISPLAY_QUANTIFIERS
1570 static char newVar[60];
1571 switch (whatIs(c)) {
1572 case NAME : if (m == name(c).mod) {
1573 sprintf(newVar,"%s", textToStr(name(c).text));
1575 sprintf(newVar,"%s.%s",
1576 textToStr(module(name(c).mod).text),
1577 textToStr(name(c).text));
1581 case TYCON : if (m == tycon(c).mod) {
1582 sprintf(newVar,"%s", textToStr(tycon(c).text));
1584 sprintf(newVar,"%s.%s",
1585 textToStr(module(tycon(c).mod).text),
1586 textToStr(tycon(c).text));
1590 case CLASS : if (m == cclass(c).mod) {
1591 sprintf(newVar,"%s", textToStr(cclass(c).text));
1593 sprintf(newVar,"%s.%s",
1594 textToStr(module(cclass(c).mod).text),
1595 textToStr(cclass(c).text));
1599 default : internal("objToStr");
1603 static char newVar[33];
1604 switch (whatIs(c)) {
1605 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1608 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1611 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1614 default : internal("objToStr");
1622 static Void local dumpStg( void ) { /* print STG stuff */
1627 Cell v; /* really StgVar */
1628 setCurrModule(findEvalModule());
1630 for (; (s=readFilename())!=0;) {
1633 /* find the name while ignoring module scopes */
1634 for (i=NAMEMIN; i<nameHw; i++)
1635 if (name(i).text == t) n = i;
1637 /* perhaps it's an "idNNNNNN" thing? */
1640 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
1643 while (isdigit(s[i])) {
1644 v = v * 10 + (s[i]-'0');
1648 n = nameFromStgVar(v);
1651 if (isNull(n) && whatIs(v)==STGVAR) {
1652 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
1653 printStg(stderr, v );
1656 Printf ( "Unknown reference `%s'\n", s );
1659 Printf ( "Not a Name: `%s'\n", s );
1661 if (isNull(name(n).stgVar)) {
1662 Printf ( "Doesn't have a STG tree: %s\n", s );
1664 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
1665 printStg(stderr, name(n).stgVar);
1670 static Void local info() { /* describe objects */
1671 Int count = 0; /* or give menu of commands */
1674 setCurrModule(findEvalModule());
1675 startNewScript(0); /* for recovery of storage */
1676 for (; (s=readFilename())!=0; count++) {
1677 describe(findText(s));
1685 static Void local describe(t) /* describe an object */
1687 Tycon tc = findTycon(t);
1688 Class cl = findClass(t);
1689 Name nm = findName(t);
1691 if (nonNull(tc)) { /* as a type constructor */
1695 for (i=0; i<tycon(tc).arity; ++i) {
1696 t = ap(t,mkOffset(i));
1698 Printf("-- type constructor");
1700 Printf(" with kind ");
1701 printKind(stdout,tycon(tc).kind);
1704 switch (tycon(tc).what) {
1705 case SYNONYM : Printf("type ");
1706 printType(stdout,t);
1708 printType(stdout,tycon(tc).defn);
1712 case DATATYPE : { List cs = tycon(tc).defn;
1713 if (tycon(tc).what==DATATYPE) {
1718 printType(stdout,t);
1720 mapProc(printSyntax,cs);
1722 Printf("\n-- constructors:");
1724 for (; hasCfun(cs); cs=tl(cs)) {
1726 printExp(stdout,hd(cs));
1728 printType(stdout,name(hd(cs)).type);
1731 Printf("\n-- selectors:");
1733 for (; nonNull(cs); cs=tl(cs)) {
1735 printExp(stdout,hd(cs));
1737 printType(stdout,name(hd(cs)).type);
1742 case RESTRICTSYN : Printf("type ");
1743 printType(stdout,t);
1744 Printf(" = <restricted>");
1748 if (nonNull(in=findFirstInst(tc))) {
1749 Printf("\n-- instances:\n");
1752 in = findNextInst(tc,in);
1753 } while (nonNull(in));
1758 if (nonNull(cl)) { /* as a class */
1759 List ins = cclass(cl).instances;
1760 Kinds ks = cclass(cl).kinds;
1761 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
1762 Printf("-- type class");
1764 Printf("-- constructor class");
1766 Printf(" with arity ");
1767 printKinds(stdout,ks);
1771 mapProc(printSyntax,cclass(cl).members);
1773 if (nonNull(cclass(cl).supers)) {
1774 printContext(stdout,cclass(cl).supers);
1777 printPred(stdout,cclass(cl).head);
1779 if (nonNull(cclass(cl).fds)) {
1780 List fds = cclass(cl).fds;
1782 for (; nonNull(fds); fds=tl(fds)) {
1784 printFD(stdout,hd(fds));
1789 if (nonNull(cclass(cl).members)) {
1790 List ms = cclass(cl).members;
1793 Type t = name(hd(ms)).type;
1794 if (isPolyType(t)) {
1798 printExp(stdout,hd(ms));
1800 if (isNull(tl(fst(snd(t))))) {
1803 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
1805 printType(stdout,t);
1807 } while (nonNull(ms));
1811 Printf("\n-- instances:\n");
1815 } while (nonNull(ins));
1820 if (nonNull(nm)) { /* as a function/name */
1822 printExp(stdout,nm);
1824 if (nonNull(name(nm).type)) {
1825 printType(stdout,name(nm).type);
1827 Printf("<unknown type>");
1829 printf("\n");print(name(nm).type,10);printf("\n");
1831 Printf(" -- data constructor");
1832 } else if (isMfun(nm)) {
1833 Printf(" -- class member");
1834 } else if (isSfun(nm)) {
1835 Printf(" -- selector function");
1841 if (isNull(tc) && isNull(cl) && isNull(nm)) {
1842 Printf("Unknown reference `%s'\n",textToStr(t));
1846 static Void local printSyntax(nm)
1848 Syntax sy = syntaxOf(nm);
1849 Text t = name(nm).text;
1850 String s = textToStr(t);
1851 if (sy != defaultSyntax(t)) {
1853 switch (assocOf(sy)) {
1854 case LEFT_ASS : Putchar('l'); break;
1855 case RIGHT_ASS : Putchar('r'); break;
1856 case NON_ASS : break;
1858 Printf(" %i ",precOf(sy));
1859 if (isascii((int)(*s)) && isalpha((int)(*s))) {
1868 static Void local showInst(in) /* Display instance decl header */
1870 Printf("instance ");
1871 if (nonNull(inst(in).specifics)) {
1872 printContext(stdout,inst(in).specifics);
1875 printPred(stdout,inst(in).head);
1879 /* --------------------------------------------------------------------------
1880 * List all names currently in scope:
1881 * ------------------------------------------------------------------------*/
1883 static Void local listNames() { /* list names matching optional pat*/
1884 String pat = readFilename();
1886 Int width = getTerminalWidth() - 1;
1889 Module mod = findEvalModule();
1891 if (pat) { /* First gather names to list */
1893 names = addNamesMatching(pat,names);
1894 } while ((pat=readFilename())!=0);
1896 names = addNamesMatching((String)0,names);
1898 if (isNull(names)) { /* Then print them out */
1899 ERRMSG(0) "No names selected"
1902 for (termPos=0; nonNull(names); names=tl(names)) {
1903 String s = objToStr(mod,hd(names));
1905 if (termPos+1+l>width) {
1908 } else if (termPos>0) {
1916 Printf("\n(%d names listed)\n", count);
1919 /* --------------------------------------------------------------------------
1920 * print a prompt and read a line of input:
1921 * ------------------------------------------------------------------------*/
1923 static Void local promptForInput(moduleName)
1924 String moduleName; {
1925 char promptBuffer[1000];
1927 /* This is portable but could overflow buffer */
1928 sprintf(promptBuffer,prompt,moduleName);
1930 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
1931 * promptBuffer instead.
1933 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
1934 /* Reset prompt to a safe default to avoid an infinite loop */
1936 prompt = strCopy("? ");
1937 internal("Combined prompt and evaluation module name too long");
1941 stringInput("main\0"); else
1942 consoleInput(promptBuffer);
1945 /* --------------------------------------------------------------------------
1946 * main read-eval-print loop, with error trapping:
1947 * ------------------------------------------------------------------------*/
1949 static jmp_buf catch_error; /* jump buffer for error trapping */
1951 static Void local interpreter(argc,argv)/* main interpreter loop */
1954 Int errorNumber = setjmp(catch_error);
1956 if (errorNumber && autoMain) {
1957 fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" );
1961 breakOn(TRUE); /* enable break trapping */
1962 if (numScripts==0) { /* only succeeds on first time, */
1963 if (errorNumber) /* before prelude has been loaded */
1964 fatal("Unable to load prelude");
1965 initialize(argc,argv);
1969 /* initialize calls startupHaskell, which trashes our signal handlers */
1974 everybody(RESET); /* reset to sensible initial state */
1975 dropScriptsFrom(numScripts-1); /* remove partially loaded scripts */
1976 /* not counting prelude as a script*/
1978 promptForInput(textToStr(module(findEvalModule()).text));
1980 cmd = readCommand(cmds, (Char)':', (Char)'!');
1985 case EDIT : editor();
1989 case LOAD : clearProject();
1990 forgetScriptsFrom(1);
1993 case ALSO : clearProject();
1994 forgetScriptsFrom(numScripts);
1997 case RELOAD : readScripts(1);
1999 case PROJECT: project();
2004 case EVAL : evaluator();
2006 case TYPEOF : showtype();
2008 case BROWSE : browse();
2010 #if EXPLAIN_INSTANCE_RESOLUTION
2011 case XPLAIN : xplain();
2014 case NAMES : listNames();
2018 case BADCMD : guidance();
2023 #ifdef CRUDE_PROFILING
2027 case SYSTEM : if (shellEsc(readLine()))
2028 Printf("Warning: Shell escape terminated abnormally\n");
2030 case CHGDIR : changeDir();
2034 case PNTVER: Printf("-- Hugs Version %s\n",
2037 case DUMP : dumpStg();
2040 case COLLECT: consGC = FALSE;
2043 Printf("Garbage collection recovered %d cells\n",
2050 Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
2051 millisecs(userElapsed), millisecs(systElapsed));
2053 if (autoMain) break;
2058 /* --------------------------------------------------------------------------
2059 * Display progress towards goal:
2060 * ------------------------------------------------------------------------*/
2062 static Target currTarget;
2063 static Bool aiming = FALSE;
2066 static Int charCount;
2068 Void setGoal(what, t) /* Set goal for what to be t */
2073 #if EXPLAIN_INSTANCE_RESOLUTION
2077 currTarget = (t?t:1);
2080 currPos = strlen(what);
2081 maxPos = getTerminalWidth() - 1;
2085 for (charCount=0; *what; charCount++)
2090 Void soFar(t) /* Indicate progress towards goal */
2091 Target t; { /* has now reached t */
2094 #if EXPLAIN_INSTANCE_RESOLUTION
2099 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2104 if (newPos>currPos) {
2107 while (newPos>++currPos);
2114 Void done() { /* Goal has now been achieved */
2117 #if EXPLAIN_INSTANCE_RESOLUTION
2122 while (maxPos>currPos++)
2127 for (; charCount>0; charCount--) {
2136 static Void local failed() { /* Goal cannot be reached due to */
2137 if (aiming) { /* errors */
2144 /* --------------------------------------------------------------------------
2146 * ------------------------------------------------------------------------*/
2148 Void errHead(l) /* print start of error message */
2150 failed(); /* failed to reach target ... */
2152 FPrintf(errorStream,"ERROR");
2155 FPrintf(errorStream," \"%s\"", scriptFile);
2156 setLastEdit(scriptFile,l);
2157 if (l) FPrintf(errorStream," (line %d)",l);
2160 FPrintf(errorStream,": ");
2161 FFlush(errorStream);
2164 Void errFail() { /* terminate error message and */
2165 Putc('\n',errorStream); /* produce exception to return to */
2166 FFlush(errorStream); /* main command loop */
2167 longjmp(catch_error,1);
2170 Void errAbort() { /* altern. form of error handling */
2171 failed(); /* used when suitable error message*/
2172 stopAnyPrinting(); /* has already been printed */
2176 Void internal(msg) /* handle internal error */
2178 #if HUGS_FOR_WINDOWS
2180 wsprintf(buf,"INTERNAL ERROR: %s",msg);
2181 MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2185 Printf("INTERNAL ERROR: %s\n",msg);
2187 longjmp(catch_error,1);
2190 Void fatal(msg) /* handle fatal error */
2192 #if HUGS_FOR_WINDOWS
2194 wsprintf(buf,"FATAL ERROR: %s",msg);
2195 MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2198 Printf("\nFATAL ERROR: %s\n",msg);
2203 sigHandler(breakHandler) { /* respond to break interrupt */
2204 #if HUGS_FOR_WINDOWS
2205 MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
2208 Printf("{Interrupted!}\n");
2210 breakOn(TRUE); /* reinstall signal handler - redundant on BSD systems */
2211 /* but essential on POSIX (and other?) systems */
2217 longjmp(catch_error,1);
2218 sigResume;/*NOTREACHED*/
2221 /* --------------------------------------------------------------------------
2222 * Read value from environment variable or registry:
2223 * ------------------------------------------------------------------------*/
2225 String fromEnv(var,def) /* return value of: */
2226 String var; /* environment variable named by var */
2227 String def; { /* or: default value given by def */
2228 String s = getenv(var);
2229 return (s ? s : def);
2232 /* --------------------------------------------------------------------------
2233 * String manipulation routines:
2234 * ------------------------------------------------------------------------*/
2236 static String local strCopy(s) /* make malloced copy of a string */
2240 if ((t=(char *)malloc(strlen(s)+1))==0) {
2241 ERRMSG(0) "String storage space exhausted"
2244 for (r=t; (*r++ = *s++)!=0; ) {
2251 /* --------------------------------------------------------------------------
2253 * We can redirect compiler output (prompts, error messages, etc) by
2254 * tweaking these functions.
2255 * ------------------------------------------------------------------------*/
2257 #if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
2259 #ifdef HAVE_STDARG_H
2262 #include <varargs.h>
2265 /* ----------------------------------------------------------------------- */
2267 #define BufferSize 10000 /* size of redirected output buffer */
2269 typedef struct _HugsStream {
2270 char buffer[BufferSize]; /* buffer for redirected output */
2271 Int next; /* next space in buffer */
2274 static Void local vBufferedPrintf Args((HugsStream*, const char*, va_list));
2275 static Void local bufferedPutchar Args((HugsStream*, Char));
2276 static String local bufferClear Args((HugsStream *stream));
2278 static Void local vBufferedPrintf(stream, fmt, ap)
2282 Int spaceLeft = BufferSize - stream->next;
2283 char* p = &stream->buffer[stream->next];
2284 Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
2285 if (0 <= charsAdded && charsAdded < spaceLeft)
2286 stream->next += charsAdded;
2287 #if 1 /* we can either buffer the first n chars or buffer the last n chars */
2293 static Void local bufferedPutchar(stream, c)
2296 if (BufferSize - stream->next >= 2) {
2297 stream->buffer[stream->next++] = c;
2298 stream->buffer[stream->next] = '\0';
2302 static String local bufferClear(stream)
2303 HugsStream *stream; {
2304 if (stream->next == 0) {
2308 return stream->buffer;
2312 /* ----------------------------------------------------------------------- */
2314 static HugsStream outputStreamH;
2316 * We rely on standard C semantics to initialise outputStreamH.next to 0.
2319 Void hugsEnableOutput(f)
2324 String hugsClearOutputBuffer() {
2325 return bufferClear(&outputStreamH);
2328 #ifdef HAVE_STDARG_H
2329 Void hugsPrintf(const char *fmt, ...) {
2330 va_list ap; /* pointer into argument list */
2331 va_start(ap, fmt); /* make ap point to first arg after fmt */
2332 if (!disableOutput) {
2335 vBufferedPrintf(&outputStreamH, fmt, ap);
2337 va_end(ap); /* clean up */
2340 Void hugsPrintf(fmt, va_alist)
2343 va_list ap; /* pointer into argument list */
2344 va_start(ap); /* make ap point to first arg after fmt */
2345 if (!disableOutput) {
2348 vBufferedPrintf(&outputStreamH, fmt, ap);
2350 va_end(ap); /* clean up */
2356 if (!disableOutput) {
2359 bufferedPutchar(&outputStreamH, c);
2363 Void hugsFlushStdout() {
2364 if (!disableOutput) {
2371 if (!disableOutput) {
2376 #ifdef HAVE_STDARG_H
2377 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2380 if (!disableOutput) {
2381 vfprintf(fp, fmt, ap);
2383 vBufferedPrintf(&outputStreamH, fmt, ap);
2388 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2394 if (!disableOutput) {
2395 vfprintf(fp, fmt, ap);
2397 vBufferedPrintf(&outputStreamH, fmt, ap);
2403 Void hugsPutc(c, fp)
2406 if (!disableOutput) {
2409 bufferedPutchar(&outputStreamH, c);
2413 #endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
2414 /* --------------------------------------------------------------------------
2415 * Send message to each component of system:
2416 * ------------------------------------------------------------------------*/
2418 Void everybody(what) /* send command `what' to each component of*/
2419 Int what; { /* system to respond as appropriate ... */
2421 fprintf ( stderr, "EVERYBODY %d\n", what );
2423 machdep(what); /* The order of calling each component is */
2424 storage(what); /* important for the PREPREL command */
2427 translateControl(what);
2429 staticAnalysis(what);
2430 deriveControl(what);
2436 /* --------------------------------------------------------------------------
2437 * Hugs for Windows code (WinMain and related functions)
2438 * ------------------------------------------------------------------------*/
2440 #if HUGS_FOR_WINDOWS
2441 #include "winhugs.c"