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/02/03 13:55:21 $
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);
1264 /* Hack to avoid starting up in PrelHugs */
1265 if (mtext == findText("PrelHugs")) mtext = findText("Prelude");
1268 /* Commented out till we understand what
1269 * this is trying to do.
1270 * Problem, you cant find a module till later.
1273 setCurrModule(findModule(mtext));
1283 setLastEdit((String)0, 0);
1284 ppSmStack("readscripts-end ");
1287 static Void local whatScripts() { /* list scripts in current session */
1289 Printf("\nHugs session for:");
1291 Printf(" (project: %s)",currProject);
1292 for (i=0; i<numScripts; ++i)
1293 Printf("\n%s%s",scriptInfo[i].path, scriptInfo[i].modName);
1297 /* --------------------------------------------------------------------------
1298 * Access to external editor:
1299 * ------------------------------------------------------------------------*/
1301 static Void local editor() { /* interpreter-editor interface */
1302 String newFile = readFilename();
1304 setLastEdit(newFile,0);
1305 if (readFilename()) {
1306 ERRMSG(0) "Multiple filenames not permitted"
1313 static Void local find() { /* edit file containing definition */
1315 This just plain wont work no more.
1317 String nm = readFilename(); /* of specified name */
1319 ERRMSG(0) "No name specified"
1322 else if (readFilename()) {
1323 ERRMSG(0) "Multiple names not permitted"
1329 setCurrModule(findEvalModule());
1331 if (nonNull(c=findTycon(t=findText(nm)))) {
1332 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1335 } else if (nonNull(c=findName(t))) {
1336 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1340 ERRMSG(0) "No current definition for name \"%s\"", nm
1347 static Void local runEditor() { /* run editor on script lastEdit */
1348 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1352 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1357 lastEdit = strCopy(fname);
1359 #if HUGS_FOR_WINDOWS
1360 DrawStatusLine(hWndMain); /* Redo status line */
1364 /* --------------------------------------------------------------------------
1365 * Read and evaluate an expression:
1366 * ------------------------------------------------------------------------*/
1368 static Void local setModule(){/*set module in which to evaluate expressions*/
1369 String s = readFilename();
1370 if (!s) s = ""; /* :m clears the current module selection */
1371 evalModule = findText(s);
1372 setLastEdit(fileOfModule(findEvalModule()),0);
1375 static Module local findEvalModule() { /*Module in which to eval expressions*/
1376 Module m = findModule(evalModule);
1382 static Void local evaluator() { /* evaluate expr and print value */
1386 setCurrModule(findEvalModule());
1388 startNewScript(0); /* Enables recovery of storage */
1389 /* allocated during evaluation */
1392 defaultDefns = combined ? stdDefaults : evalDefaults;
1393 type = typeCheckExp(TRUE);
1395 if (isPolyType(type)) {
1396 ks = polySigOf(type);
1397 bd = monotypeOf(type);
1402 if (whatIs(bd)==QUAL) {
1403 ERRMSG(0) "Unresolved overloading" ETHEN
1404 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1405 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1415 if (isProgType(ks,bd)) {
1416 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1420 Cell d = provePred(ks,NIL,ap(classShow,bd));
1422 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1423 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1424 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1428 inputExpr = ap2(nameShow, d,inputExpr);
1429 inputExpr = ap (namePutStr, inputExpr);
1430 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1432 evalExp(); printf("\n");
1435 printType(stdout,type);
1442 printf ( "result type is " );
1443 printType ( stdout, type );
1452 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
1453 if (printing) { /* after successful termination or */
1454 printing = FALSE; /* runtime error (e.g. interrupt) */
1457 #define plural(v) v, (v==1?"":"s")
1458 Printf("%lu cell%s",plural(numCells));
1460 Printf(", %u garbage collection%s",plural(numGcs));
1469 /* --------------------------------------------------------------------------
1470 * Print type of input expression:
1471 * ------------------------------------------------------------------------*/
1473 static Void local showtype() { /* print type of expression (if any)*/
1476 setCurrModule(findEvalModule());
1477 startNewScript(0); /* Enables recovery of storage */
1478 /* allocated during evaluation */
1481 defaultDefns = evalDefaults;
1482 type = typeCheckExp(FALSE);
1483 printExp(stdout,inputExpr);
1485 printType(stdout,type);
1490 static Void local browseit(mod,t,all)
1497 Printf("module %s where\n",textToStr(module(mod).text));
1498 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1500 /* only look at things defined in this module,
1501 unless `all' flag is set */
1502 if (all || name(nm).mod == mod) {
1503 /* unwanted artifacts, like lambda lifted values,
1504 are in the list of names, but have no types */
1505 if (nonNull(name(nm).type)) {
1506 printExp(stdout,nm);
1508 printType(stdout,name(nm).type);
1510 Printf(" -- data constructor");
1511 } else if (isMfun(nm)) {
1512 Printf(" -- class member");
1513 } else if (isSfun(nm)) {
1514 Printf(" -- selector function");
1522 Printf("Unknown module %s\n",t);
1527 static Void local browse() { /* browse modules */
1528 Int count = 0; /* or give menu of commands */
1532 setCurrModule(findEvalModule());
1533 startNewScript(0); /* for recovery of storage */
1534 for (; (s=readFilename())!=0; count++)
1535 if (strcmp(s,"all") == 0) {
1539 browseit(findModule(findText(s)),s,all);
1541 browseit(findEvalModule(),NULL,all);
1545 #if EXPLAIN_INSTANCE_RESOLUTION
1546 static Void local xplain() { /* print type of expression (if any)*/
1548 Bool sir = showInstRes;
1550 setCurrModule(findEvalModule());
1551 startNewScript(0); /* Enables recovery of storage */
1552 /* allocated during evaluation */
1556 d = provePred(NIL,NIL,hd(inputContext));
1558 fprintf(stdout, "not Sat\n");
1560 fprintf(stdout, "Sat\n");
1566 /* --------------------------------------------------------------------------
1567 * Enhanced help system: print current list of scripts or give information
1569 * ------------------------------------------------------------------------*/
1571 static String local objToStr(m,c)
1574 #if 1 || DISPLAY_QUANTIFIERS
1575 static char newVar[60];
1576 switch (whatIs(c)) {
1577 case NAME : if (m == name(c).mod) {
1578 sprintf(newVar,"%s", textToStr(name(c).text));
1580 sprintf(newVar,"%s.%s",
1581 textToStr(module(name(c).mod).text),
1582 textToStr(name(c).text));
1586 case TYCON : if (m == tycon(c).mod) {
1587 sprintf(newVar,"%s", textToStr(tycon(c).text));
1589 sprintf(newVar,"%s.%s",
1590 textToStr(module(tycon(c).mod).text),
1591 textToStr(tycon(c).text));
1595 case CLASS : if (m == cclass(c).mod) {
1596 sprintf(newVar,"%s", textToStr(cclass(c).text));
1598 sprintf(newVar,"%s.%s",
1599 textToStr(module(cclass(c).mod).text),
1600 textToStr(cclass(c).text));
1604 default : internal("objToStr");
1608 static char newVar[33];
1609 switch (whatIs(c)) {
1610 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1613 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1616 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1619 default : internal("objToStr");
1627 static Void local dumpStg( void ) { /* print STG stuff */
1632 Cell v; /* really StgVar */
1633 setCurrModule(findEvalModule());
1635 for (; (s=readFilename())!=0;) {
1638 /* find the name while ignoring module scopes */
1639 for (i=NAMEMIN; i<nameHw; i++)
1640 if (name(i).text == t) n = i;
1642 /* perhaps it's an "idNNNNNN" thing? */
1645 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
1648 while (isdigit(s[i])) {
1649 v = v * 10 + (s[i]-'0');
1653 n = nameFromStgVar(v);
1656 if (isNull(n) && whatIs(v)==STGVAR) {
1657 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
1658 printStg(stderr, v );
1661 Printf ( "Unknown reference `%s'\n", s );
1664 Printf ( "Not a Name: `%s'\n", s );
1666 if (isNull(name(n).stgVar)) {
1667 Printf ( "Doesn't have a STG tree: %s\n", s );
1669 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
1670 printStg(stderr, name(n).stgVar);
1675 static Void local info() { /* describe objects */
1676 Int count = 0; /* or give menu of commands */
1679 setCurrModule(findEvalModule());
1680 startNewScript(0); /* for recovery of storage */
1681 for (; (s=readFilename())!=0; count++) {
1682 describe(findText(s));
1690 static Void local describe(t) /* describe an object */
1692 Tycon tc = findTycon(t);
1693 Class cl = findClass(t);
1694 Name nm = findName(t);
1696 if (nonNull(tc)) { /* as a type constructor */
1700 for (i=0; i<tycon(tc).arity; ++i) {
1701 t = ap(t,mkOffset(i));
1703 Printf("-- type constructor");
1705 Printf(" with kind ");
1706 printKind(stdout,tycon(tc).kind);
1709 switch (tycon(tc).what) {
1710 case SYNONYM : Printf("type ");
1711 printType(stdout,t);
1713 printType(stdout,tycon(tc).defn);
1717 case DATATYPE : { List cs = tycon(tc).defn;
1718 if (tycon(tc).what==DATATYPE) {
1723 printType(stdout,t);
1725 mapProc(printSyntax,cs);
1727 Printf("\n-- constructors:");
1729 for (; hasCfun(cs); cs=tl(cs)) {
1731 printExp(stdout,hd(cs));
1733 printType(stdout,name(hd(cs)).type);
1736 Printf("\n-- selectors:");
1738 for (; nonNull(cs); cs=tl(cs)) {
1740 printExp(stdout,hd(cs));
1742 printType(stdout,name(hd(cs)).type);
1747 case RESTRICTSYN : Printf("type ");
1748 printType(stdout,t);
1749 Printf(" = <restricted>");
1753 if (nonNull(in=findFirstInst(tc))) {
1754 Printf("\n-- instances:\n");
1757 in = findNextInst(tc,in);
1758 } while (nonNull(in));
1763 if (nonNull(cl)) { /* as a class */
1764 List ins = cclass(cl).instances;
1765 Kinds ks = cclass(cl).kinds;
1766 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
1767 Printf("-- type class");
1769 Printf("-- constructor class");
1771 Printf(" with arity ");
1772 printKinds(stdout,ks);
1776 mapProc(printSyntax,cclass(cl).members);
1778 if (nonNull(cclass(cl).supers)) {
1779 printContext(stdout,cclass(cl).supers);
1782 printPred(stdout,cclass(cl).head);
1784 if (nonNull(cclass(cl).fds)) {
1785 List fds = cclass(cl).fds;
1787 for (; nonNull(fds); fds=tl(fds)) {
1789 printFD(stdout,hd(fds));
1794 if (nonNull(cclass(cl).members)) {
1795 List ms = cclass(cl).members;
1798 Type t = name(hd(ms)).type;
1799 if (isPolyType(t)) {
1803 printExp(stdout,hd(ms));
1805 if (isNull(tl(fst(snd(t))))) {
1808 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
1810 printType(stdout,t);
1812 } while (nonNull(ms));
1816 Printf("\n-- instances:\n");
1820 } while (nonNull(ins));
1825 if (nonNull(nm)) { /* as a function/name */
1827 printExp(stdout,nm);
1829 if (nonNull(name(nm).type)) {
1830 printType(stdout,name(nm).type);
1832 Printf("<unknown type>");
1834 printf("\n");print(name(nm).type,10);printf("\n");
1836 Printf(" -- data constructor");
1837 } else if (isMfun(nm)) {
1838 Printf(" -- class member");
1839 } else if (isSfun(nm)) {
1840 Printf(" -- selector function");
1846 if (isNull(tc) && isNull(cl) && isNull(nm)) {
1847 Printf("Unknown reference `%s'\n",textToStr(t));
1851 static Void local printSyntax(nm)
1853 Syntax sy = syntaxOf(nm);
1854 Text t = name(nm).text;
1855 String s = textToStr(t);
1856 if (sy != defaultSyntax(t)) {
1858 switch (assocOf(sy)) {
1859 case LEFT_ASS : Putchar('l'); break;
1860 case RIGHT_ASS : Putchar('r'); break;
1861 case NON_ASS : break;
1863 Printf(" %i ",precOf(sy));
1864 if (isascii((int)(*s)) && isalpha((int)(*s))) {
1873 static Void local showInst(in) /* Display instance decl header */
1875 Printf("instance ");
1876 if (nonNull(inst(in).specifics)) {
1877 printContext(stdout,inst(in).specifics);
1880 printPred(stdout,inst(in).head);
1884 /* --------------------------------------------------------------------------
1885 * List all names currently in scope:
1886 * ------------------------------------------------------------------------*/
1888 static Void local listNames() { /* list names matching optional pat*/
1889 String pat = readFilename();
1891 Int width = getTerminalWidth() - 1;
1894 Module mod = findEvalModule();
1896 if (pat) { /* First gather names to list */
1898 names = addNamesMatching(pat,names);
1899 } while ((pat=readFilename())!=0);
1901 names = addNamesMatching((String)0,names);
1903 if (isNull(names)) { /* Then print them out */
1904 ERRMSG(0) "No names selected"
1907 for (termPos=0; nonNull(names); names=tl(names)) {
1908 String s = objToStr(mod,hd(names));
1910 if (termPos+1+l>width) {
1913 } else if (termPos>0) {
1921 Printf("\n(%d names listed)\n", count);
1924 /* --------------------------------------------------------------------------
1925 * print a prompt and read a line of input:
1926 * ------------------------------------------------------------------------*/
1928 static Void local promptForInput(moduleName)
1929 String moduleName; {
1930 char promptBuffer[1000];
1932 /* This is portable but could overflow buffer */
1933 sprintf(promptBuffer,prompt,moduleName);
1935 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
1936 * promptBuffer instead.
1938 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
1939 /* Reset prompt to a safe default to avoid an infinite loop */
1941 prompt = strCopy("? ");
1942 internal("Combined prompt and evaluation module name too long");
1946 stringInput("main\0"); else
1947 consoleInput(promptBuffer);
1950 /* --------------------------------------------------------------------------
1951 * main read-eval-print loop, with error trapping:
1952 * ------------------------------------------------------------------------*/
1954 static jmp_buf catch_error; /* jump buffer for error trapping */
1956 static Void local interpreter(argc,argv)/* main interpreter loop */
1959 Int errorNumber = setjmp(catch_error);
1961 if (errorNumber && autoMain) {
1962 fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" );
1966 breakOn(TRUE); /* enable break trapping */
1967 if (numScripts==0) { /* only succeeds on first time, */
1968 if (errorNumber) /* before prelude has been loaded */
1969 fatal("Unable to load prelude");
1970 initialize(argc,argv);
1974 /* initialize calls startupHaskell, which trashes our signal handlers */
1979 everybody(RESET); /* reset to sensible initial state */
1980 dropScriptsFrom(numScripts-1); /* remove partially loaded scripts */
1981 /* not counting prelude as a script*/
1983 promptForInput(textToStr(module(findEvalModule()).text));
1985 cmd = readCommand(cmds, (Char)':', (Char)'!');
1990 case EDIT : editor();
1994 case LOAD : clearProject();
1995 forgetScriptsFrom(1);
1998 case ALSO : clearProject();
1999 forgetScriptsFrom(numScripts);
2002 case RELOAD : readScripts(1);
2004 case PROJECT: project();
2009 case EVAL : evaluator();
2011 case TYPEOF : showtype();
2013 case BROWSE : browse();
2015 #if EXPLAIN_INSTANCE_RESOLUTION
2016 case XPLAIN : xplain();
2019 case NAMES : listNames();
2023 case BADCMD : guidance();
2028 #ifdef CRUDE_PROFILING
2032 case SYSTEM : if (shellEsc(readLine()))
2033 Printf("Warning: Shell escape terminated abnormally\n");
2035 case CHGDIR : changeDir();
2039 case PNTVER: Printf("-- Hugs Version %s\n",
2042 case DUMP : dumpStg();
2045 case COLLECT: consGC = FALSE;
2048 Printf("Garbage collection recovered %d cells\n",
2055 Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
2056 millisecs(userElapsed), millisecs(systElapsed));
2058 if (autoMain) break;
2063 /* --------------------------------------------------------------------------
2064 * Display progress towards goal:
2065 * ------------------------------------------------------------------------*/
2067 static Target currTarget;
2068 static Bool aiming = FALSE;
2071 static Int charCount;
2073 Void setGoal(what, t) /* Set goal for what to be t */
2078 #if EXPLAIN_INSTANCE_RESOLUTION
2082 currTarget = (t?t:1);
2085 currPos = strlen(what);
2086 maxPos = getTerminalWidth() - 1;
2090 for (charCount=0; *what; charCount++)
2095 Void soFar(t) /* Indicate progress towards goal */
2096 Target t; { /* has now reached t */
2099 #if EXPLAIN_INSTANCE_RESOLUTION
2104 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2109 if (newPos>currPos) {
2112 while (newPos>++currPos);
2119 Void done() { /* Goal has now been achieved */
2122 #if EXPLAIN_INSTANCE_RESOLUTION
2127 while (maxPos>currPos++)
2132 for (; charCount>0; charCount--) {
2141 static Void local failed() { /* Goal cannot be reached due to */
2142 if (aiming) { /* errors */
2149 /* --------------------------------------------------------------------------
2151 * ------------------------------------------------------------------------*/
2153 Void errHead(l) /* print start of error message */
2155 failed(); /* failed to reach target ... */
2157 FPrintf(errorStream,"ERROR");
2160 FPrintf(errorStream," \"%s\"", scriptFile);
2161 setLastEdit(scriptFile,l);
2162 if (l) FPrintf(errorStream," (line %d)",l);
2165 FPrintf(errorStream,": ");
2166 FFlush(errorStream);
2169 Void errFail() { /* terminate error message and */
2170 Putc('\n',errorStream); /* produce exception to return to */
2171 FFlush(errorStream); /* main command loop */
2172 longjmp(catch_error,1);
2175 Void errAbort() { /* altern. form of error handling */
2176 failed(); /* used when suitable error message*/
2177 stopAnyPrinting(); /* has already been printed */
2181 Void internal(msg) /* handle internal error */
2183 #if HUGS_FOR_WINDOWS
2185 wsprintf(buf,"INTERNAL ERROR: %s",msg);
2186 MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2190 Printf("INTERNAL ERROR: %s\n",msg);
2192 longjmp(catch_error,1);
2195 Void fatal(msg) /* handle fatal error */
2197 #if HUGS_FOR_WINDOWS
2199 wsprintf(buf,"FATAL ERROR: %s",msg);
2200 MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2203 Printf("\nFATAL ERROR: %s\n",msg);
2208 sigHandler(breakHandler) { /* respond to break interrupt */
2209 #if HUGS_FOR_WINDOWS
2210 MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
2213 Printf("{Interrupted!}\n");
2215 breakOn(TRUE); /* reinstall signal handler - redundant on BSD systems */
2216 /* but essential on POSIX (and other?) systems */
2222 longjmp(catch_error,1);
2223 sigResume;/*NOTREACHED*/
2226 /* --------------------------------------------------------------------------
2227 * Read value from environment variable or registry:
2228 * ------------------------------------------------------------------------*/
2230 String fromEnv(var,def) /* return value of: */
2231 String var; /* environment variable named by var */
2232 String def; { /* or: default value given by def */
2233 String s = getenv(var);
2234 return (s ? s : def);
2237 /* --------------------------------------------------------------------------
2238 * String manipulation routines:
2239 * ------------------------------------------------------------------------*/
2241 static String local strCopy(s) /* make malloced copy of a string */
2245 if ((t=(char *)malloc(strlen(s)+1))==0) {
2246 ERRMSG(0) "String storage space exhausted"
2249 for (r=t; (*r++ = *s++)!=0; ) {
2256 /* --------------------------------------------------------------------------
2258 * We can redirect compiler output (prompts, error messages, etc) by
2259 * tweaking these functions.
2260 * ------------------------------------------------------------------------*/
2262 #if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
2264 #ifdef HAVE_STDARG_H
2267 #include <varargs.h>
2270 /* ----------------------------------------------------------------------- */
2272 #define BufferSize 10000 /* size of redirected output buffer */
2274 typedef struct _HugsStream {
2275 char buffer[BufferSize]; /* buffer for redirected output */
2276 Int next; /* next space in buffer */
2279 static Void local vBufferedPrintf Args((HugsStream*, const char*, va_list));
2280 static Void local bufferedPutchar Args((HugsStream*, Char));
2281 static String local bufferClear Args((HugsStream *stream));
2283 static Void local vBufferedPrintf(stream, fmt, ap)
2287 Int spaceLeft = BufferSize - stream->next;
2288 char* p = &stream->buffer[stream->next];
2289 Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
2290 if (0 <= charsAdded && charsAdded < spaceLeft)
2291 stream->next += charsAdded;
2292 #if 1 /* we can either buffer the first n chars or buffer the last n chars */
2298 static Void local bufferedPutchar(stream, c)
2301 if (BufferSize - stream->next >= 2) {
2302 stream->buffer[stream->next++] = c;
2303 stream->buffer[stream->next] = '\0';
2307 static String local bufferClear(stream)
2308 HugsStream *stream; {
2309 if (stream->next == 0) {
2313 return stream->buffer;
2317 /* ----------------------------------------------------------------------- */
2319 static HugsStream outputStreamH;
2321 * We rely on standard C semantics to initialise outputStreamH.next to 0.
2324 Void hugsEnableOutput(f)
2329 String hugsClearOutputBuffer() {
2330 return bufferClear(&outputStreamH);
2333 #ifdef HAVE_STDARG_H
2334 Void hugsPrintf(const char *fmt, ...) {
2335 va_list ap; /* pointer into argument list */
2336 va_start(ap, fmt); /* make ap point to first arg after fmt */
2337 if (!disableOutput) {
2340 vBufferedPrintf(&outputStreamH, fmt, ap);
2342 va_end(ap); /* clean up */
2345 Void hugsPrintf(fmt, va_alist)
2348 va_list ap; /* pointer into argument list */
2349 va_start(ap); /* make ap point to first arg after fmt */
2350 if (!disableOutput) {
2353 vBufferedPrintf(&outputStreamH, fmt, ap);
2355 va_end(ap); /* clean up */
2361 if (!disableOutput) {
2364 bufferedPutchar(&outputStreamH, c);
2368 Void hugsFlushStdout() {
2369 if (!disableOutput) {
2376 if (!disableOutput) {
2381 #ifdef HAVE_STDARG_H
2382 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2385 if (!disableOutput) {
2386 vfprintf(fp, fmt, ap);
2388 vBufferedPrintf(&outputStreamH, fmt, ap);
2393 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2399 if (!disableOutput) {
2400 vfprintf(fp, fmt, ap);
2402 vBufferedPrintf(&outputStreamH, fmt, ap);
2408 Void hugsPutc(c, fp)
2411 if (!disableOutput) {
2414 bufferedPutchar(&outputStreamH, c);
2418 #endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
2419 /* --------------------------------------------------------------------------
2420 * Send message to each component of system:
2421 * ------------------------------------------------------------------------*/
2423 Void everybody(what) /* send command `what' to each component of*/
2424 Int what; { /* system to respond as appropriate ... */
2426 fprintf ( stderr, "EVERYBODY %d\n", what );
2428 machdep(what); /* The order of calling each component is */
2429 storage(what); /* important for the PREPREL command */
2432 translateControl(what);
2434 staticAnalysis(what);
2435 deriveControl(what);
2441 /* --------------------------------------------------------------------------
2442 * Hugs for Windows code (WinMain and related functions)
2443 * ------------------------------------------------------------------------*/
2445 #if HUGS_FOR_WINDOWS
2446 #include "winhugs.c"