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/07 16:56:47 $
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");
324 for (i=1; i < argc; ++i) { /* process command line arguments */
325 if (strcmp(argv[i], "--")==0) break;
326 if (strcmp(argv[i],"+")==0 && i+1<argc) {
328 ERRMSG(0) "Multiple project filenames on command line"
333 } else if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
334 && !processOption(argv[i])) {
335 addStackEntry(argv[i]);
341 char exe_name[N_INSTALLDIR + 6];
342 strcpy(exe_name, installDir);
343 strcat(exe_name, "hugs");
344 DEBUG_LoadSymbols(exe_name);
350 if (!scriptName[0]) {
351 Printf("Prelude not found on current path: \"%s\"\n",
352 hugsPath ? hugsPath : "");
353 fatal("Unable to load prelude");
358 Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n");
360 Printf("Hugs mode: Restart with command line option +98 for Haskell 98 mode\n");
364 Printf("Combined mode: Restart with command line -c for standalone mode\n\n" );
366 Printf("Standalone mode: Restart with command line +c for combined mode\n\n" );
371 evalModule = findText(""); /* evaluate wrt last module by default */
375 "\nUsing project file, ignoring additional filenames\n");
377 loadProject(strCopy(proj));
382 /* --------------------------------------------------------------------------
383 * Command line options:
384 * ------------------------------------------------------------------------*/
386 struct options { /* command line option toggles */
387 char c; /* table defined in main app. */
392 extern struct options toggle[];
394 static Void local toggleSet(c,state) /* Set command line toggle */
398 for (i=0; toggle[i].c; ++i)
399 if (toggle[i].c == c) {
400 *toggle[i].flag = state;
403 ERRMSG(0) "Unknown toggle `%c'", c
407 static Void local togglesIn(state) /* Print current list of toggles in*/
408 Bool state; { /* given state */
411 for (i=0; toggle[i].c; ++i)
412 if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
414 Putchar((char)(state ? '+' : '-'));
415 Putchar(toggle[i].c);
422 static Void local optionInfo() { /* Print information about command */
423 static String fmts = "%-5s%s\n"; /* line settings */
424 static String fmtc = "%-5c%s\n";
427 Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
428 for (i=0; toggle[i].c; ++i) {
429 if (!haskell98 || toggle[i].h98) {
430 Printf(fmtc,toggle[i].c,toggle[i].description);
434 Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
435 Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
436 Printf(fmts,"pstr","Set prompt string to str");
437 Printf(fmts,"rstr","Set repeat last expression string to str");
438 Printf(fmts,"Pstr","Set search path for modules to str");
439 Printf(fmts,"Estr","Use editor setting given by str");
440 Printf(fmts,"cnum","Set constraint cutoff limit");
441 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
442 Printf(fmts,"Fstr","Set preprocessor filter to str");
445 Printf("\nCurrent settings: ");
448 Printf("-h%d",heapSize);
452 printString(repeatStr);
453 Printf(" -c%d",cutoff);
454 Printf("\nSearch path : -P");
455 printString(hugsPath);
458 if (projectPath!=NULL) {
459 Printf("\nProject Path : %s",projectPath);
462 Printf("\nEditor setting : -E");
463 printString(hugsEdit);
464 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
465 Printf("\nPreprocessor : -F");
466 printString(preprocessor);
468 Printf("\nCompatibility : %s", haskell98 ? "Haskell 98 (+98)"
469 : "Hugs Extensions (-98)");
473 #if USE_REGISTRY || HUGS_FOR_WINDOWS
481 #define PUTInt(optc,i) \
482 sprintf(next,"-%c%d",optc,i); \
485 #define PUTStr(c,s) \
486 next=PUTStr_aux(next,c,s)
488 static String local PUTStr_aux Args((String,Char, String));
490 static String local PUTStr_aux(next,c,s)
496 sprintf(next,"-%c\"",c);
499 PUTS(unlexChar(*t,'"'));
507 static String local optionsToStr() { /* convert options to string */
508 static char buffer[2000];
509 String next = buffer;
512 for (i=0; toggle[i].c; ++i) {
513 PUTC(*toggle[i].flag ? '+' : '-');
517 PUTS(haskell98 ? "+98 " : "-98 ");
518 PUTInt('h',hpSize); PUTC(' ');
520 PUTStr('r',repeatStr);
521 PUTStr('P',hugsPath);
522 PUTStr('E',hugsEdit);
523 PUTInt('c',cutoff); PUTC(' ');
524 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
525 PUTStr('F',preprocessor);
530 #endif /* USE_REGISTRY */
537 static Void local readOptions(options) /* read options from string */
541 stringInput(options);
542 while ((s=readFilename())!=0) {
543 if (*s && !processOption(s)) {
544 ERRMSG(0) "Option string must begin with `+' or `-'"
551 static Bool local processOption(s) /* process string s for options, */
552 String s; { /* return FALSE if none found. */
564 case 'Q' : break; /* already handled */
566 case 'p' : if (s[1]) {
567 if (prompt) free(prompt);
568 prompt = strCopy(s+1);
572 case 'r' : if (s[1]) {
573 if (repeatStr) free(repeatStr);
574 repeatStr = strCopy(s+1);
579 String p = substPath(s+1,hugsPath ? hugsPath : "");
580 if (hugsPath) free(hugsPath);
585 case 'E' : if (hugsEdit) free(hugsEdit);
586 hugsEdit = strCopy(s+1);
589 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
590 case 'F' : if (preprocessor) free(preprocessor);
591 preprocessor = strCopy(s+1);
595 case 'h' : setHeapSize(s+1);
598 case 'c' : if (heapBuilt()) {
600 "You can't enable/disable combined"
601 " operation inside Hugs\n" );
603 /* don't do anything, since pre-scan of args
604 will have got it already */
608 case 'D' : /* hack */
610 extern void setRtsFlags( int x );
611 setRtsFlags(argToInt(s+1));
615 default : if (strcmp("98",s)==0) {
616 if (heapBuilt() && ((state && !haskell98) ||
617 (!state && haskell98))) {
619 "Haskell 98 compatibility cannot be changed"
620 " while the interpreter is running\n");
633 static Void local setHeapSize(s)
636 hpSize = argToInt(s);
637 if (hpSize < MINIMUMHEAP)
638 hpSize = MINIMUMHEAP;
639 else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
640 hpSize = MAXIMUMHEAP;
641 if (heapBuilt() && hpSize != heapSize) {
642 /* ToDo: should this use a message box in winhugs? */
644 FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
646 FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
654 static Int local argToInt(s) /* read integer from argument str */
659 if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
660 ERRMSG(0) "Missing integer in option setting \"%s\"", t
665 Int d = (*s++) - '0';
666 if (n > ((MAXPOSINT - d)/10)) {
667 ERRMSG(0) "Option setting \"%s\" is too large", t
671 } while (isascii((int)(*s)) && isdigit((int)(*s)));
673 if (*s=='K' || *s=='k') {
674 if (n > (MAXPOSINT/1000)) {
675 ERRMSG(0) "Option setting \"%s\" is too large", t
682 #if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
683 if (*s=='M' || *s=='m') {
684 if (n > (MAXPOSINT/1000000)) {
685 ERRMSG(0) "Option setting \"%s\" is too large", t
693 #if MAXPOSINT > 1000000000
694 if (*s=='G' || *s=='g') {
695 if (n > (MAXPOSINT/1000000000)) {
696 ERRMSG(0) "Option setting \"%s\" is too large", t
705 ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
712 /* --------------------------------------------------------------------------
713 * Print Menu of list of commands:
714 * ------------------------------------------------------------------------*/
716 static struct cmd cmds[] = {
717 {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
718 {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
719 {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
720 {":quit", QUIT}, {":set", SET}, {":find", FIND},
721 {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
722 {":dump", DUMP}, {":ztats", STATS},
723 {":module",SETMODULE},
725 #if EXPLAIN_INSTANCE_RESOLUTION
728 {":version", PNTVER},
733 static Void local menu() {
734 Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
735 Printf("c is the first character in the full name.\n\n");
736 Printf(":load <filenames> load modules from specified files\n");
737 Printf(":load clear all files except prelude\n");
738 Printf(":also <filenames> read additional modules\n");
739 Printf(":reload repeat last load command\n");
740 Printf(":project <filename> use project file\n");
741 Printf(":edit <filename> edit file\n");
742 Printf(":edit edit last module\n");
743 Printf(":module <module> set module for evaluating expressions\n");
744 Printf("<expr> evaluate expression\n");
745 Printf(":type <expr> print type of expression\n");
746 Printf(":? display this list of commands\n");
747 Printf(":set <options> set command line options\n");
748 Printf(":set help on command line options\n");
749 Printf(":names [pat] list names currently in scope\n");
750 Printf(":info <names> describe named objects\n");
751 Printf(":browse <modules> browse names defined in <modules>\n");
752 #if EXPLAIN_INSTANCE_RESOLUTION
753 Printf(":xplain <context> explain instance resolution for <context>\n");
755 Printf(":find <name> edit module containing definition of name\n");
756 Printf(":!command shell escape\n");
757 Printf(":cd dir change directory\n");
758 Printf(":gc force garbage collection\n");
759 Printf(":version print Hugs version\n");
760 Printf(":dump <name> print STG code for named fn\n");
761 #ifdef CRUDE_PROFILING
762 Printf(":ztats <name> print reduction stats\n");
764 Printf(":quit exit Hugs interpreter\n");
767 static Void local guidance() {
768 Printf("Command not recognised. ");
772 static Void local forHelp() {
773 Printf("Type :? for help\n");
776 /* --------------------------------------------------------------------------
777 * Setting of command line options:
778 * ------------------------------------------------------------------------*/
780 struct options toggle[] = { /* List of command line toggles */
781 {'s', 1, "Print no. reductions/cells after eval", &showStats},
782 {'t', 1, "Print type after evaluation", &addType},
783 {'g', 1, "Print no. cells recovered after gc", &gcMessages},
784 {'l', 1, "Literate modules as default", &literateScripts},
785 {'e', 1, "Warn about errors in literate modules", &literateErrors},
786 {'.', 1, "Print dots to show progress", &useDots},
787 {'q', 1, "Print nothing to show progress", &quiet},
788 {'w', 1, "Always show which modules are loaded", &listScripts},
789 {'k', 1, "Show kind errors in full", &kindExpert},
790 {'o', 0, "Allow overlapping instances", &allowOverlap},
794 {'D', 1, "Debug: show generated code", &debugCode},
796 #if EXPLAIN_INSTANCE_RESOLUTION
797 {'x', 1, "Explain instance resolution", &showInstRes},
800 {'m', 0, "Use multi instance resolution", &multiInstRes},
803 {'D', 1, "Debug: show generated G code", &debugCode},
805 {'S', 1, "Debug: show generated SC code", &debugSC},
809 static Void local set() { /* change command line options from*/
810 String s; /* Hugs command line */
812 if ((s=readFilename())!=0) {
814 if (!processOption(s)) {
815 ERRMSG(0) "Option string must begin with `+' or `-'"
818 } while ((s=readFilename())!=0);
820 writeRegString("Options", optionsToStr());
827 /* --------------------------------------------------------------------------
828 * Change directory command:
829 * ------------------------------------------------------------------------*/
831 static Void local changeDir() { /* change directory */
832 String s = readFilename();
834 ERRMSG(0) "Unable to change to directory \"%s\"", s
839 /* --------------------------------------------------------------------------
840 * Loading project and script files:
841 * ------------------------------------------------------------------------*/
843 static Void local loadProject(s) /* Load project file */
847 projInput(currProject);
848 scriptFile = currProject;
849 forgetScriptsFrom(1);
850 while ((s=readFilename())!=0)
853 ERRMSG(0) "Empty project file"
857 projectLoaded = TRUE;
860 static Void local clearProject() { /* clear name for current project */
864 projectLoaded = FALSE;
866 setLastEdit((String)0,0);
872 static Void local makeStackEntry ( ScriptInfo* ent, String iname )
875 Bool sAvail, iAvail, oAvail;
876 Time sTime, iTime, oTime;
877 Long sSize, iSize, oSize;
880 ok = findFilesForModule (
884 &sAvail, &sTime, &sSize,
885 &iAvail, &iTime, &iSize,
886 &oAvail, &oTime, &oSize
890 "Can't find source or object+interface for module \"%s\"",
891 /* "Can't find source for module \"%s\"", */
895 /* findFilesForModule should enforce this */
896 if (!(sAvail || (oAvail && iAvail)))
898 /* Load objects in preference to sources if both are available */
899 /* 11 Oct 99: disable object loading in the interim.
900 Will probably only reinstate when HEP becomes available.
904 ? (oAvail && iAvail && timeEarlier(sTime,oTime))
910 /* ToDo: namesUpto overflow */
911 ent->modName = strCopy(iname);
914 ent->fromSource = !fromObj;
916 ent->postponed = FALSE;
917 ent->lastChange = sTime; /* ToDo: is this right? */
918 ent->size = fromObj ? iSize : sSize;
919 ent->oSize = fromObj ? oSize : 0;
920 ent->objLoaded = FALSE;
925 static Void nukeEnding( String s )
928 if (l > 4 && strncmp(s+l-4,".u_o" ,4)==0) s[l-4] = 0; else
929 if (l > 5 && strncmp(s+l-5,".u_hi",5)==0) s[l-5] = 0; else
930 if (l > 3 && strncmp(s+l-3,".hs" ,3)==0) s[l-3] = 0; else
931 if (l > 4 && strncmp(s+l-4,".lhs" ,4)==0) s[l-4] = 0; else
932 if (l > 4 && strncmp(s+l-4,".dll" ,4)==0) s[l-4] = 0; else
933 if (l > 4 && strncmp(s+l-4,".DLL" ,4)==0) s[l-4] = 0;
936 static Void local addStackEntry(s) /* Add script to list of scripts */
937 String s; { /* to be read in ... */
942 if (namesUpto>=NUM_SCRIPTS) {
943 ERRMSG(0) "Too many module files (maximum of %d allowed)",
950 for (s2 = s; *s2; s2++)
951 if (*s2 == SLASH && *(s2+1)) s = s2+1;
954 for (i = 0; i < namesUpto; i++)
955 if (strcmp(scriptInfo[i].modName,s)==0)
959 makeStackEntry ( &scriptInfo[namesUpto], strCopy(s) );
965 /* Return TRUE if no imports were needed; FALSE otherwise. */
966 static Bool local addScript(stacknum) /* read single file */
969 static char name[FILENAME_MAX+1];
970 Int len = scriptInfo[stacknum].size;
972 #if HUGS_FOR_WINDOWS /* Set clock cursor while loading */
974 SetCursor(LoadCursor(NULL, IDC_WAIT));
977 // setLastEdit(name,0);
979 strcpy(name, scriptInfo[stacknum].path);
980 strcat(name, scriptInfo[stacknum].modName);
981 if (scriptInfo[stacknum].fromSource)
982 strcat(name, scriptInfo[stacknum].srcExt); else
983 strcat(name, ".u_hi");
987 if (scriptInfo[stacknum].fromSource) {
989 didPrelude = processInterfaces();
991 preludeLoaded = TRUE;
995 lastWasObject = FALSE;
996 Printf("Reading script \"%s\":\n",name);
997 needsImports = FALSE;
998 parseScript(name,len);
999 if (needsImports) return FALSE;
1007 char nameObj[FILENAME_MAX+1];
1010 Printf("Reading iface \"%s\":\n", name);
1012 needsImports = FALSE;
1014 // set nameObj for the benefit of openGHCIface
1015 strcpy(nameObj, scriptInfo[stacknum].path);
1016 strcat(nameObj, scriptInfo[stacknum].modName);
1017 strcat(nameObj, DLL_ENDING);
1018 sizeObj = scriptInfo[stacknum].oSize;
1020 iface = readInterface(name,len);
1021 imports = zsnd(iface); iface = zfst(iface);
1023 if (nonNull(imports)) chase(imports);
1025 lastWasObject = TRUE;
1027 iface_info = ztriple(iface, findText(nameObj), mkInt(sizeObj) );
1028 ifaces_outstanding = cons(iface_info,ifaces_outstanding);
1030 if (needsImports) return FALSE;
1039 Bool chase(imps) /* Process list of import requests */
1043 Int origPos = numScripts; /* keep track of original position */
1044 String origName = scriptInfo[origPos].modName;
1045 for (; nonNull(imps); imps=tl(imps)) {
1046 String iname = textToStr(textOf(hd(imps)));
1048 for (; i<namesUpto; i++)
1049 if (strcmp(scriptInfo[i].modName,iname)==0)
1051 //fprintf(stderr, "import name = %s num = %d\n", iname, i );
1054 /* We should have filled in the details of each module
1055 the first time we hear about it.
1057 assert(scriptInfo[i].details);
1060 if (i>=origPos) { /* Neither loaded or queued */
1066 needsImports = TRUE;
1067 if (scriptInfo[origPos].fromSource)
1068 scriptInfo[origPos].postponed = TRUE;
1070 if (i==namesUpto) { /* Name not found (i==namesUpto) */
1071 /* Find out where it lives, whether source or object, etc */
1072 makeStackEntry ( &scriptInfo[i], iname );
1076 if (scriptInfo[i].postponed && scriptInfo[i].fromSource) {
1077 /* Check for recursive dependency */
1079 "Recursive import dependency between \"%s\" and \"%s\"",
1080 scriptInfo[origPos].modName, iname
1083 /* Move stack entry i to somewhere below origPos. If i denotes
1084 * an object, destination is immediately below origPos.
1085 * Otherwise, it's underneath the queue of objects below origPos.
1087 dstPosn = origPos-1;
1088 if (scriptInfo[i].fromSource)
1089 while (!scriptInfo[dstPosn].fromSource && dstPosn > 0)
1093 tmp = scriptInfo[i];
1094 for (; i > dstPosn; i--) scriptInfo[i] = scriptInfo[i-1];
1095 scriptInfo[dstPosn] = tmp;
1096 if (dstPosn < nextNumScripts) nextNumScripts = dstPosn;
1100 return needsImports;
1103 static Void local forgetScriptsFrom(scno)/* remove scripts from system */
1107 for (i=scno; i<namesUpto; ++i)
1109 free(scriptName[i]);
1111 dropScriptsFrom(scno-1);
1113 if (numScripts>namesUpto)
1117 /* --------------------------------------------------------------------------
1118 * Commands for loading and removing script files:
1119 * ------------------------------------------------------------------------*/
1121 static Void local load() { /* read filenames from command line */
1122 String s; /* and add to list of scripts waiting */
1124 while ((s=readFilename())!=0)
1129 static Void local project() { /* read list of script names from */
1130 String s; /* project file */
1132 if ((s=readFilename()) || currProject) {
1134 s = strCopy(currProject);
1135 else if (readFilename()) {
1136 ERRMSG(0) "Too many project files"
1143 ERRMSG(0) "No project filename specified"
1150 static Void local readScripts(n) /* Reread current list of scripts, */
1151 Int n; { /* loading everything after and */
1152 Time timeStamp; /* including the first script which*/
1153 Long fileSize; /* has been either changed or added*/
1154 static char name[FILENAME_MAX+1];
1157 lastWasObject = FALSE;
1158 ppSmStack("readscripts-begin");
1159 #if HUGS_FOR_WINDOWS
1160 SetCursor(LoadCursor(NULL, IDC_WAIT));
1164 for (; n<numScripts; n++) { /* Scan previously loaded scripts */
1165 ppSmStack("readscripts-loop1");
1166 getFileInfo(scriptName[n], &timeStamp, &fileSize);
1167 if (timeChanged(timeStamp,lastChange[n])) {
1168 dropScriptsFrom(n-1);
1173 for (; n<NUM_SCRIPTS; n++) /* No scripts have been postponed */
1174 postponed[n] = FALSE; /* at this stage */
1177 while (numScripts<namesUpto) { /* Process any remaining scripts */
1178 ppSmStack("readscripts-loop2");
1179 getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
1180 timeSet(lastChange[numScripts],timeStamp);
1181 if (numScripts>0) /* no new script for prelude */
1182 startNewScript(scriptName[numScripts]);
1183 if (addScript(scriptName[numScripts],fileSize))
1186 dropScriptsFrom(numScripts-1);
1192 for (; n<numScripts; n++) {
1193 ppSmStack("readscripts-loop2");
1194 strcpy(name, scriptInfo[n].path);
1195 strcat(name, scriptInfo[n].modName);
1196 if (scriptInfo[n].fromSource)
1197 strcat(name, scriptInfo[n].srcExt); else
1198 strcat(name, ".u_hi"); //ToDo: should be .o
1199 getFileInfo(name,&timeStamp, &fileSize);
1200 if (timeChanged(timeStamp,scriptInfo[n].lastChange)) {
1201 dropScriptsFrom(n-1);
1206 for (; n<NUM_SCRIPTS; n++)
1207 scriptInfo[n].postponed = FALSE;
1211 while (numScripts < namesUpto) {
1212 ppSmStack ( "readscripts-loop2" );
1214 if (scriptInfo[numScripts].fromSource) {
1217 startNewScript(scriptInfo[numScripts].modName);
1218 nextNumScripts = NUM_SCRIPTS; //bogus initialisation
1219 if (addScript(numScripts)) {
1221 assert(nextNumScripts==NUM_SCRIPTS);
1224 dropScriptsFrom(numScripts-1);
1228 if (scriptInfo[numScripts].objLoaded) {
1231 scriptInfo[numScripts].objLoaded = TRUE;
1234 startNewScript(scriptInfo[numScripts].modName);
1236 nextNumScripts = NUM_SCRIPTS;
1237 if (addScript(numScripts)) {
1239 assert(nextNumScripts==NUM_SCRIPTS);
1241 //while (!scriptInfo[numScripts].fromSource && numScripts > 0)
1243 //if (scriptInfo[numScripts].fromSource)
1245 numScripts = nextNumScripts;
1246 assert(nextNumScripts<NUM_SCRIPTS);
1250 if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
1253 didPrelude = processInterfaces();
1255 preludeLoaded = TRUE;
1256 everybody(POSTPREL);
1260 { Int m = namesUpto-1;
1261 Text mtext = findText(scriptInfo[m].modName);
1262 /* Commented out till we understand what
1263 * this is trying to do.
1264 * Problem, you cant find a module till later.
1267 setCurrModule(findModule(mtext));
1277 setLastEdit((String)0, 0);
1278 ppSmStack("readscripts-end ");
1281 static Void local whatScripts() { /* list scripts in current session */
1283 Printf("\nHugs session for:");
1285 Printf(" (project: %s)",currProject);
1286 for (i=0; i<numScripts; ++i)
1287 Printf("\n%s%s",scriptInfo[i].path, scriptInfo[i].modName);
1291 /* --------------------------------------------------------------------------
1292 * Access to external editor:
1293 * ------------------------------------------------------------------------*/
1295 static Void local editor() { /* interpreter-editor interface */
1296 String newFile = readFilename();
1298 setLastEdit(newFile,0);
1299 if (readFilename()) {
1300 ERRMSG(0) "Multiple filenames not permitted"
1307 static Void local find() { /* edit file containing definition */
1309 This just plain wont work no more.
1311 String nm = readFilename(); /* of specified name */
1313 ERRMSG(0) "No name specified"
1316 else if (readFilename()) {
1317 ERRMSG(0) "Multiple names not permitted"
1323 setCurrModule(findEvalModule());
1325 if (nonNull(c=findTycon(t=findText(nm)))) {
1326 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1329 } else if (nonNull(c=findName(t))) {
1330 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1334 ERRMSG(0) "No current definition for name \"%s\"", nm
1341 static Void local runEditor() { /* run editor on script lastEdit */
1342 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1346 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1351 lastEdit = strCopy(fname);
1353 #if HUGS_FOR_WINDOWS
1354 DrawStatusLine(hWndMain); /* Redo status line */
1358 /* --------------------------------------------------------------------------
1359 * Read and evaluate an expression:
1360 * ------------------------------------------------------------------------*/
1362 static Void local setModule(){/*set module in which to evaluate expressions*/
1363 String s = readFilename();
1364 if (!s) s = ""; /* :m clears the current module selection */
1365 evalModule = findText(s);
1366 setLastEdit(fileOfModule(findEvalModule()),0);
1369 static Module local findEvalModule() { /*Module in which to eval expressions*/
1370 Module m = findModule(evalModule);
1376 static Void local evaluator() { /* evaluate expr and print value */
1380 setCurrModule(findEvalModule());
1382 startNewScript(0); /* Enables recovery of storage */
1383 /* allocated during evaluation */
1386 defaultDefns = evalDefaults;
1387 type = typeCheckExp(TRUE);
1388 if (isPolyType(type)) {
1389 ks = polySigOf(type);
1390 bd = monotypeOf(type);
1395 if (whatIs(bd)==QUAL) {
1396 ERRMSG(0) "Unresolved overloading" ETHEN
1397 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1398 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1408 if (isProgType(ks,bd)) {
1409 inputExpr = ap(nameRunIO,inputExpr);
1413 Cell d = provePred(ks,NIL,ap(classShow,bd));
1415 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1416 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1417 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1421 inputExpr = ap2(findName(findText("show")),d,inputExpr);
1422 inputExpr = ap(findName(findText("putStr")), inputExpr);
1423 inputExpr = ap(nameRunIO, inputExpr);
1425 evalExp(); printf("\n");
1428 printType(stdout,type);
1435 printf ( "result type is " );
1436 printType ( stdout, type );
1445 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
1446 if (printing) { /* after successful termination or */
1447 printing = FALSE; /* runtime error (e.g. interrupt) */
1450 #define plural(v) v, (v==1?"":"s")
1451 Printf("%lu cell%s",plural(numCells));
1453 Printf(", %u garbage collection%s",plural(numGcs));
1462 /* --------------------------------------------------------------------------
1463 * Print type of input expression:
1464 * ------------------------------------------------------------------------*/
1466 static Void local showtype() { /* print type of expression (if any)*/
1469 setCurrModule(findEvalModule());
1470 startNewScript(0); /* Enables recovery of storage */
1471 /* allocated during evaluation */
1474 defaultDefns = evalDefaults;
1475 type = typeCheckExp(FALSE);
1476 printExp(stdout,inputExpr);
1478 printType(stdout,type);
1483 static Void local browseit(mod,t,all)
1490 Printf("module %s where\n",textToStr(module(mod).text));
1491 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1493 /* only look at things defined in this module,
1494 unless `all' flag is set */
1495 if (all || name(nm).mod == mod) {
1496 /* unwanted artifacts, like lambda lifted values,
1497 are in the list of names, but have no types */
1498 if (nonNull(name(nm).type)) {
1499 printExp(stdout,nm);
1501 printType(stdout,name(nm).type);
1503 Printf(" -- data constructor");
1504 } else if (isMfun(nm)) {
1505 Printf(" -- class member");
1506 } else if (isSfun(nm)) {
1507 Printf(" -- selector function");
1515 Printf("Unknown module %s\n",t);
1520 static Void local browse() { /* browse modules */
1521 Int count = 0; /* or give menu of commands */
1525 setCurrModule(findEvalModule());
1526 startNewScript(0); /* for recovery of storage */
1527 for (; (s=readFilename())!=0; count++)
1528 if (strcmp(s,"all") == 0) {
1532 browseit(findModule(findText(s)),s,all);
1534 browseit(findEvalModule(),NULL,all);
1538 #if EXPLAIN_INSTANCE_RESOLUTION
1539 static Void local xplain() { /* print type of expression (if any)*/
1541 Bool sir = showInstRes;
1543 setCurrModule(findEvalModule());
1544 startNewScript(0); /* Enables recovery of storage */
1545 /* allocated during evaluation */
1549 d = provePred(NIL,NIL,hd(inputContext));
1551 fprintf(stdout, "not Sat\n");
1553 fprintf(stdout, "Sat\n");
1559 /* --------------------------------------------------------------------------
1560 * Enhanced help system: print current list of scripts or give information
1562 * ------------------------------------------------------------------------*/
1564 static String local objToStr(m,c)
1567 #if 1 || DISPLAY_QUANTIFIERS
1568 static char newVar[60];
1569 switch (whatIs(c)) {
1570 case NAME : if (m == name(c).mod) {
1571 sprintf(newVar,"%s", textToStr(name(c).text));
1573 sprintf(newVar,"%s.%s",
1574 textToStr(module(name(c).mod).text),
1575 textToStr(name(c).text));
1579 case TYCON : if (m == tycon(c).mod) {
1580 sprintf(newVar,"%s", textToStr(tycon(c).text));
1582 sprintf(newVar,"%s.%s",
1583 textToStr(module(tycon(c).mod).text),
1584 textToStr(tycon(c).text));
1588 case CLASS : if (m == cclass(c).mod) {
1589 sprintf(newVar,"%s", textToStr(cclass(c).text));
1591 sprintf(newVar,"%s.%s",
1592 textToStr(module(cclass(c).mod).text),
1593 textToStr(cclass(c).text));
1597 default : internal("objToStr");
1601 static char newVar[33];
1602 switch (whatIs(c)) {
1603 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1606 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1609 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1612 default : internal("objToStr");
1620 static Void local dumpStg( void ) { /* print STG stuff */
1625 Cell v; /* really StgVar */
1626 setCurrModule(findEvalModule());
1628 for (; (s=readFilename())!=0;) {
1631 /* find the name while ignoring module scopes */
1632 for (i=NAMEMIN; i<nameHw; i++)
1633 if (name(i).text == t) n = i;
1635 /* perhaps it's an "idNNNNNN" thing? */
1638 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
1641 while (isdigit(s[i])) {
1642 v = v * 10 + (s[i]-'0');
1646 n = nameFromStgVar(v);
1649 if (isNull(n) && whatIs(v)==STGVAR) {
1650 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
1651 printStg(stderr, v );
1654 Printf ( "Unknown reference `%s'\n", s );
1657 Printf ( "Not a Name: `%s'\n", s );
1659 if (isNull(name(n).stgVar)) {
1660 Printf ( "Doesn't have a STG tree: %s\n", s );
1662 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
1663 printStg(stderr, name(n).stgVar);
1668 static Void local info() { /* describe objects */
1669 Int count = 0; /* or give menu of commands */
1672 setCurrModule(findEvalModule());
1673 startNewScript(0); /* for recovery of storage */
1674 for (; (s=readFilename())!=0; count++) {
1675 describe(findText(s));
1683 static Void local describe(t) /* describe an object */
1685 Tycon tc = findTycon(t);
1686 Class cl = findClass(t);
1687 Name nm = findName(t);
1689 if (nonNull(tc)) { /* as a type constructor */
1693 for (i=0; i<tycon(tc).arity; ++i) {
1694 t = ap(t,mkOffset(i));
1696 Printf("-- type constructor");
1698 Printf(" with kind ");
1699 printKind(stdout,tycon(tc).kind);
1702 switch (tycon(tc).what) {
1703 case SYNONYM : Printf("type ");
1704 printType(stdout,t);
1706 printType(stdout,tycon(tc).defn);
1710 case DATATYPE : { List cs = tycon(tc).defn;
1711 if (tycon(tc).what==DATATYPE) {
1716 printType(stdout,t);
1718 mapProc(printSyntax,cs);
1720 Printf("\n-- constructors:");
1722 for (; hasCfun(cs); cs=tl(cs)) {
1724 printExp(stdout,hd(cs));
1726 printType(stdout,name(hd(cs)).type);
1729 Printf("\n-- selectors:");
1731 for (; nonNull(cs); cs=tl(cs)) {
1733 printExp(stdout,hd(cs));
1735 printType(stdout,name(hd(cs)).type);
1740 case RESTRICTSYN : Printf("type ");
1741 printType(stdout,t);
1742 Printf(" = <restricted>");
1746 if (nonNull(in=findFirstInst(tc))) {
1747 Printf("\n-- instances:\n");
1750 in = findNextInst(tc,in);
1751 } while (nonNull(in));
1756 if (nonNull(cl)) { /* as a class */
1757 List ins = cclass(cl).instances;
1758 Kinds ks = cclass(cl).kinds;
1759 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
1760 Printf("-- type class");
1762 Printf("-- constructor class");
1764 Printf(" with arity ");
1765 printKinds(stdout,ks);
1769 mapProc(printSyntax,cclass(cl).members);
1771 if (nonNull(cclass(cl).supers)) {
1772 printContext(stdout,cclass(cl).supers);
1775 printPred(stdout,cclass(cl).head);
1777 if (nonNull(cclass(cl).fds)) {
1778 List fds = cclass(cl).fds;
1780 for (; nonNull(fds); fds=tl(fds)) {
1782 printFD(stdout,hd(fds));
1787 if (nonNull(cclass(cl).members)) {
1788 List ms = cclass(cl).members;
1791 Type t = name(hd(ms)).type;
1792 if (isPolyType(t)) {
1796 printExp(stdout,hd(ms));
1798 if (isNull(tl(fst(snd(t))))) {
1801 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
1803 printType(stdout,t);
1805 } while (nonNull(ms));
1809 Printf("\n-- instances:\n");
1813 } while (nonNull(ins));
1818 if (nonNull(nm)) { /* as a function/name */
1820 printExp(stdout,nm);
1822 if (nonNull(name(nm).type)) {
1823 printType(stdout,name(nm).type);
1825 Printf("<unknown type>");
1827 printf("\n");print(name(nm).type,10);printf("\n");
1829 Printf(" -- data constructor");
1830 } else if (isMfun(nm)) {
1831 Printf(" -- class member");
1832 } else if (isSfun(nm)) {
1833 Printf(" -- selector function");
1839 if (isNull(tc) && isNull(cl) && isNull(nm)) {
1840 Printf("Unknown reference `%s'\n",textToStr(t));
1844 static Void local printSyntax(nm)
1846 Syntax sy = syntaxOf(nm);
1847 Text t = name(nm).text;
1848 String s = textToStr(t);
1849 if (sy != defaultSyntax(t)) {
1851 switch (assocOf(sy)) {
1852 case LEFT_ASS : Putchar('l'); break;
1853 case RIGHT_ASS : Putchar('r'); break;
1854 case NON_ASS : break;
1856 Printf(" %i ",precOf(sy));
1857 if (isascii((int)(*s)) && isalpha((int)(*s))) {
1866 static Void local showInst(in) /* Display instance decl header */
1868 Printf("instance ");
1869 if (nonNull(inst(in).specifics)) {
1870 printContext(stdout,inst(in).specifics);
1873 printPred(stdout,inst(in).head);
1877 /* --------------------------------------------------------------------------
1878 * List all names currently in scope:
1879 * ------------------------------------------------------------------------*/
1881 static Void local listNames() { /* list names matching optional pat*/
1882 String pat = readFilename();
1884 Int width = getTerminalWidth() - 1;
1887 Module mod = findEvalModule();
1889 if (pat) { /* First gather names to list */
1891 names = addNamesMatching(pat,names);
1892 } while ((pat=readFilename())!=0);
1894 names = addNamesMatching((String)0,names);
1896 if (isNull(names)) { /* Then print them out */
1897 ERRMSG(0) "No names selected"
1900 for (termPos=0; nonNull(names); names=tl(names)) {
1901 String s = objToStr(mod,hd(names));
1903 if (termPos+1+l>width) {
1906 } else if (termPos>0) {
1914 Printf("\n(%d names listed)\n", count);
1917 /* --------------------------------------------------------------------------
1918 * print a prompt and read a line of input:
1919 * ------------------------------------------------------------------------*/
1921 static Void local promptForInput(moduleName)
1922 String moduleName; {
1923 char promptBuffer[1000];
1925 /* This is portable but could overflow buffer */
1926 sprintf(promptBuffer,prompt,moduleName);
1928 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
1929 * promptBuffer instead.
1931 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
1932 /* Reset prompt to a safe default to avoid an infinite loop */
1934 prompt = strCopy("? ");
1935 internal("Combined prompt and evaluation module name too long");
1939 stringInput("main\0"); else
1940 consoleInput(promptBuffer);
1943 /* --------------------------------------------------------------------------
1944 * main read-eval-print loop, with error trapping:
1945 * ------------------------------------------------------------------------*/
1947 static jmp_buf catch_error; /* jump buffer for error trapping */
1949 static Void local interpreter(argc,argv)/* main interpreter loop */
1952 Int errorNumber = setjmp(catch_error);
1954 if (errorNumber && autoMain) {
1955 fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" );
1959 breakOn(TRUE); /* enable break trapping */
1960 if (numScripts==0) { /* only succeeds on first time, */
1961 if (errorNumber) /* before prelude has been loaded */
1962 fatal("Unable to load prelude");
1963 initialize(argc,argv);
1967 /* initialize calls startupHaskell, which trashes our signal handlers */
1972 everybody(RESET); /* reset to sensible initial state */
1973 dropScriptsFrom(numScripts-1); /* remove partially loaded scripts */
1974 /* not counting prelude as a script*/
1976 promptForInput(textToStr(module(findEvalModule()).text));
1978 cmd = readCommand(cmds, (Char)':', (Char)'!');
1983 case EDIT : editor();
1987 case LOAD : clearProject();
1988 forgetScriptsFrom(1);
1991 case ALSO : clearProject();
1992 forgetScriptsFrom(numScripts);
1995 case RELOAD : readScripts(1);
1997 case PROJECT: project();
2002 case EVAL : evaluator();
2004 case TYPEOF : showtype();
2006 case BROWSE : browse();
2008 #if EXPLAIN_INSTANCE_RESOLUTION
2009 case XPLAIN : xplain();
2012 case NAMES : listNames();
2016 case BADCMD : guidance();
2021 #ifdef CRUDE_PROFILING
2025 case SYSTEM : if (shellEsc(readLine()))
2026 Printf("Warning: Shell escape terminated abnormally\n");
2028 case CHGDIR : changeDir();
2032 case PNTVER: Printf("-- Hugs Version %s\n",
2035 case DUMP : dumpStg();
2038 case COLLECT: consGC = FALSE;
2041 Printf("Garbage collection recovered %d cells\n",
2048 Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
2049 millisecs(userElapsed), millisecs(systElapsed));
2051 if (autoMain) break;
2056 /* --------------------------------------------------------------------------
2057 * Display progress towards goal:
2058 * ------------------------------------------------------------------------*/
2060 static Target currTarget;
2061 static Bool aiming = FALSE;
2064 static Int charCount;
2066 Void setGoal(what, t) /* Set goal for what to be t */
2071 #if EXPLAIN_INSTANCE_RESOLUTION
2075 currTarget = (t?t:1);
2078 currPos = strlen(what);
2079 maxPos = getTerminalWidth() - 1;
2083 for (charCount=0; *what; charCount++)
2088 Void soFar(t) /* Indicate progress towards goal */
2089 Target t; { /* has now reached t */
2092 #if EXPLAIN_INSTANCE_RESOLUTION
2097 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2102 if (newPos>currPos) {
2105 while (newPos>++currPos);
2112 Void done() { /* Goal has now been achieved */
2115 #if EXPLAIN_INSTANCE_RESOLUTION
2120 while (maxPos>currPos++)
2125 for (; charCount>0; charCount--) {
2134 static Void local failed() { /* Goal cannot be reached due to */
2135 if (aiming) { /* errors */
2142 /* --------------------------------------------------------------------------
2144 * ------------------------------------------------------------------------*/
2146 Void errHead(l) /* print start of error message */
2148 failed(); /* failed to reach target ... */
2150 FPrintf(errorStream,"ERROR");
2153 FPrintf(errorStream," \"%s\"", scriptFile);
2154 setLastEdit(scriptFile,l);
2155 if (l) FPrintf(errorStream," (line %d)",l);
2158 FPrintf(errorStream,": ");
2159 FFlush(errorStream);
2162 Void errFail() { /* terminate error message and */
2163 Putc('\n',errorStream); /* produce exception to return to */
2164 FFlush(errorStream); /* main command loop */
2165 longjmp(catch_error,1);
2168 Void errAbort() { /* altern. form of error handling */
2169 failed(); /* used when suitable error message*/
2170 stopAnyPrinting(); /* has already been printed */
2174 Void internal(msg) /* handle internal error */
2176 #if HUGS_FOR_WINDOWS
2178 wsprintf(buf,"INTERNAL ERROR: %s",msg);
2179 MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2183 Printf("INTERNAL ERROR: %s\n",msg);
2185 longjmp(catch_error,1);
2188 Void fatal(msg) /* handle fatal error */
2190 #if HUGS_FOR_WINDOWS
2192 wsprintf(buf,"FATAL ERROR: %s",msg);
2193 MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2196 Printf("\nFATAL ERROR: %s\n",msg);
2201 sigHandler(breakHandler) { /* respond to break interrupt */
2202 #if HUGS_FOR_WINDOWS
2203 MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
2206 Printf("{Interrupted!}\n");
2208 breakOn(TRUE); /* reinstall signal handler - redundant on BSD systems */
2209 /* but essential on POSIX (and other?) systems */
2215 longjmp(catch_error,1);
2216 sigResume;/*NOTREACHED*/
2219 /* --------------------------------------------------------------------------
2220 * Read value from environment variable or registry:
2221 * ------------------------------------------------------------------------*/
2223 String fromEnv(var,def) /* return value of: */
2224 String var; /* environment variable named by var */
2225 String def; { /* or: default value given by def */
2226 String s = getenv(var);
2227 return (s ? s : def);
2230 /* --------------------------------------------------------------------------
2231 * String manipulation routines:
2232 * ------------------------------------------------------------------------*/
2234 static String local strCopy(s) /* make malloced copy of a string */
2238 if ((t=(char *)malloc(strlen(s)+1))==0) {
2239 ERRMSG(0) "String storage space exhausted"
2242 for (r=t; (*r++ = *s++)!=0; ) {
2249 /* --------------------------------------------------------------------------
2251 * We can redirect compiler output (prompts, error messages, etc) by
2252 * tweaking these functions.
2253 * ------------------------------------------------------------------------*/
2255 #if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
2257 #ifdef HAVE_STDARG_H
2260 #include <varargs.h>
2263 /* ----------------------------------------------------------------------- */
2265 #define BufferSize 10000 /* size of redirected output buffer */
2267 typedef struct _HugsStream {
2268 char buffer[BufferSize]; /* buffer for redirected output */
2269 Int next; /* next space in buffer */
2272 static Void local vBufferedPrintf Args((HugsStream*, const char*, va_list));
2273 static Void local bufferedPutchar Args((HugsStream*, Char));
2274 static String local bufferClear Args((HugsStream *stream));
2276 static Void local vBufferedPrintf(stream, fmt, ap)
2280 Int spaceLeft = BufferSize - stream->next;
2281 char* p = &stream->buffer[stream->next];
2282 Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
2283 if (0 <= charsAdded && charsAdded < spaceLeft)
2284 stream->next += charsAdded;
2285 #if 1 /* we can either buffer the first n chars or buffer the last n chars */
2291 static Void local bufferedPutchar(stream, c)
2294 if (BufferSize - stream->next >= 2) {
2295 stream->buffer[stream->next++] = c;
2296 stream->buffer[stream->next] = '\0';
2300 static String local bufferClear(stream)
2301 HugsStream *stream; {
2302 if (stream->next == 0) {
2306 return stream->buffer;
2310 /* ----------------------------------------------------------------------- */
2312 static HugsStream outputStreamH;
2314 * We rely on standard C semantics to initialise outputStreamH.next to 0.
2317 Void hugsEnableOutput(f)
2322 String hugsClearOutputBuffer() {
2323 return bufferClear(&outputStreamH);
2326 #ifdef HAVE_STDARG_H
2327 Void hugsPrintf(const char *fmt, ...) {
2328 va_list ap; /* pointer into argument list */
2329 va_start(ap, fmt); /* make ap point to first arg after fmt */
2330 if (!disableOutput) {
2333 vBufferedPrintf(&outputStreamH, fmt, ap);
2335 va_end(ap); /* clean up */
2338 Void hugsPrintf(fmt, va_alist)
2341 va_list ap; /* pointer into argument list */
2342 va_start(ap); /* make ap point to first arg after fmt */
2343 if (!disableOutput) {
2346 vBufferedPrintf(&outputStreamH, fmt, ap);
2348 va_end(ap); /* clean up */
2354 if (!disableOutput) {
2357 bufferedPutchar(&outputStreamH, c);
2361 Void hugsFlushStdout() {
2362 if (!disableOutput) {
2369 if (!disableOutput) {
2374 #ifdef HAVE_STDARG_H
2375 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2378 if (!disableOutput) {
2379 vfprintf(fp, fmt, ap);
2381 vBufferedPrintf(&outputStreamH, fmt, ap);
2386 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2392 if (!disableOutput) {
2393 vfprintf(fp, fmt, ap);
2395 vBufferedPrintf(&outputStreamH, fmt, ap);
2401 Void hugsPutc(c, fp)
2404 if (!disableOutput) {
2407 bufferedPutchar(&outputStreamH, c);
2411 #endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
2412 /* --------------------------------------------------------------------------
2413 * Send message to each component of system:
2414 * ------------------------------------------------------------------------*/
2416 Void everybody(what) /* send command `what' to each component of*/
2417 Int what; { /* system to respond as appropriate ... */
2419 fprintf ( stderr, "EVERYBODY %d\n", what );
2421 machdep(what); /* The order of calling each component is */
2422 storage(what); /* important for the PREPREL command */
2425 translateControl(what);
2427 staticAnalysis(what);
2428 deriveControl(what);
2434 /* --------------------------------------------------------------------------
2435 * Hugs for Windows code (WinMain and related functions)
2436 * ------------------------------------------------------------------------*/
2438 #if HUGS_FOR_WINDOWS
2439 #include "winhugs.c"