2 /* --------------------------------------------------------------------------
5 * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
6 * Haskell Group 1994-99, and is distributed as Open Source software
7 * under the Artistic License; see the file "Artistic" that is included
8 * in the distribution for details.
10 * $RCSfile: hugs.c,v $
12 * $Date: 1999/04/27 10:06:52 $
13 * ------------------------------------------------------------------------*/
33 Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
35 /* --------------------------------------------------------------------------
36 * Local function prototypes:
37 * ------------------------------------------------------------------------*/
39 static Void local initialize Args((Int,String []));
40 static Void local promptForInput Args((String));
41 static Void local interpreter Args((Int,String []));
42 static Void local menu Args((Void));
43 static Void local guidance Args((Void));
44 static Void local forHelp Args((Void));
45 static Void local set Args((Void));
46 static Void local changeDir Args((Void));
47 static Void local load Args((Void));
48 static Void local project Args((Void));
49 static Void local readScripts Args((Int));
50 static Void local whatScripts Args((Void));
51 static Void local editor Args((Void));
52 static Void local find Args((Void));
53 static Bool local startEdit Args((Int,String));
54 static Void local runEditor Args((Void));
55 static Void local setModule Args((Void));
56 static Module local findEvalModule Args((Void));
57 static Void local evaluator Args((Void));
58 static Void local stopAnyPrinting Args((Void));
59 static Void local showtype Args((Void));
60 static String local objToStr Args((Module, Cell));
61 static Void local info Args((Void));
62 static Void local printSyntax Args((Name));
63 static Void local showInst Args((Inst));
64 static Void local describe Args((Text));
65 static Void local listNames Args((Void));
67 static Void local toggleSet Args((Char,Bool));
68 static Void local togglesIn Args((Bool));
69 static Void local optionInfo Args((Void));
70 #if USE_REGISTRY || HUGS_FOR_WINDOWS
71 static String local optionsToStr Args((Void));
73 static Void local readOptions Args((String));
74 static Bool local processOption Args((String));
75 static Void local setHeapSize Args((String));
76 static Int local argToInt Args((String));
78 static Void local loadProject Args((String));
79 static Void local clearProject Args((Void));
80 static Void local addScriptName Args((String,Bool));
81 static Bool local addScript Args((String,Long));
82 static Void local forgetScriptsFrom Args((Script));
83 static Void local setLastEdit Args((String,Int));
84 static Void local failed Args((Void));
85 static String local strCopy Args((String));
87 /* --------------------------------------------------------------------------
88 * Machine dependent code for Hugs interpreter:
89 * ------------------------------------------------------------------------*/
96 /* --------------------------------------------------------------------------
98 * ------------------------------------------------------------------------*/
100 static Bool printing = FALSE; /* TRUE => currently printing value*/
101 static Bool showStats = FALSE; /* TRUE => print stats after eval */
102 static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
103 static Bool addType = FALSE; /* TRUE => print type with value */
104 static Bool chaseImports = TRUE; /* TRUE => chase imports on load */
105 static Bool useDots = RISCOS; /* TRUE => use dots in progress */
106 static Bool quiet = FALSE; /* TRUE => don't show progress */
107 Bool preludeLoaded = FALSE;
108 Bool optimise = TRUE;
110 static String scriptName[NUM_SCRIPTS]; /* Script file names */
111 static Time lastChange[NUM_SCRIPTS]; /* Time of last change to script */
112 static Bool postponed[NUM_SCRIPTS]; /* Indicates postponed load */
113 static Int numScripts; /* Number of scripts loaded */
114 static Int namesUpto; /* Number of script names set */
115 static Bool needsImports; /* set to TRUE if imports required */
116 String scriptFile; /* Name of current script (if any) */
118 static Text evalModule = 0; /* Name of module we eval exprs in */
119 static String currProject = 0; /* Name of current project file */
120 static Bool projectLoaded = FALSE; /* TRUE => project file loaded */
122 static Bool autoMain = FALSE;
123 static String lastEdit = 0; /* Name of script to edit (if any) */
124 static Int lastEdLine = 0; /* Editor line number (if possible)*/
125 static String prompt = 0; /* Prompt string */
126 static Int hpSize = DEFAULTHEAP; /* Desired heap size */
127 String hugsEdit = 0; /* String for editor command */
128 String hugsPath = 0; /* String for file search path */
131 static Bool disableOutput = FALSE; /* redirect output to buffer? */
134 /* --------------------------------------------------------------------------
136 * ------------------------------------------------------------------------*/
138 #ifndef NO_MAIN /* we omit main when building the "Hugs server" */
140 Main main Args((Int, String [])); /* now every func has a prototype */
145 #ifdef HAVE_CONSOLE_H /* Macintosh port */
147 _fcreator = 'R*ch'; /* // 'KAHL'; //'*TEX'; //'ttxt'; */
149 console_options.top = 50;
150 console_options.left = 20;
152 console_options.nrows = 32;
153 console_options.ncols = 80;
155 console_options.pause_atexit = 1;
156 console_options.title = "\pHugs";
158 console_options.procID = 5;
159 argc = ccommand(&argv);
162 CStackBase = &argc; /* Save stack base for use in gc */
164 /* If first arg is +Q or -Q, be entirely silent, and automatically run
165 main after loading scripts. Useful for running the nofib suite. */
166 if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
171 Printf("__ __ __ __ ____ ___ _______________________________________________\n");
172 Printf("|| || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system\n");
173 Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n");
174 Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
175 Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
176 Printf("|| || Version: %s _______________________________________________\n\n",HUGS_VERSION);
179 Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
182 interpreter(argc,argv);
183 Printf("[Leaving Hugs]\n");
194 /* --------------------------------------------------------------------------
195 * Initialization, interpret command line args and read prelude:
196 * ------------------------------------------------------------------------*/
198 static Void local initialize(argc,argv)/* Interpreter initialization */
203 char argv_0_orig[1000];
205 setLastEdit((String)0,0);
212 hugsEdit = strCopy(fromEnv("EDITOR","c:\\windows\notepad.exe"));
216 hugsEdit = strCopy(fromEnv("EDITOR",NULL));
218 hugsPath = strCopy(HUGSPATH); readOptions("-p\"%s> \" -r$$");
220 projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
221 "HUGSPATH", PATHSEP, ""));
222 readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
223 readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
224 #endif /* USE_REGISTRY */
225 readOptions(fromEnv("STGHUGSFLAGS",""));
227 strncpy(argv_0_orig,argv[0],1000); /* startupHaskell mangles argv[0] */
228 startupHaskell (argc,argv);
229 argc = prog_argc; argv = prog_argv;
231 for (i=1; i<argc; ++i) { /* process command line arguments */
232 if (strcmp(argv[i], "--")==0) break;
233 if (strcmp(argv[i],"+")==0 && i+1<argc) {
235 ERRMSG(0) "Multiple project filenames on command line"
240 } else if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
241 && !processOption(argv[i])) {
242 addScriptName(argv[i],TRUE);
247 DEBUG_LoadSymbols(argv_0_orig);
250 scriptName[0] = strCopy(findMPathname(NULL,STD_PRELUDE,hugsPath));
251 if (!scriptName[0]) {
252 Printf("Prelude not found on current path: \"%s\"\n",
253 hugsPath ? hugsPath : "");
254 fatal("Unable to load prelude");
258 Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n\n");
260 Printf("Hugs mode: Restart with command line option +98 for Haskell 98 mode\n\n");
264 evalModule = findText(""); /* evaluate wrt last module by default */
268 "\nUsing project file, ignoring additional filenames\n");
270 loadProject(strCopy(proj));
275 /* --------------------------------------------------------------------------
276 * Command line options:
277 * ------------------------------------------------------------------------*/
279 struct options { /* command line option toggles */
280 char c; /* table defined in main app. */
284 extern struct options toggle[];
286 static Void local toggleSet(c,state) /* Set command line toggle */
290 for (i=0; toggle[i].c; ++i)
291 if (toggle[i].c == c) {
292 *toggle[i].flag = state;
295 ERRMSG(0) "Unknown toggle `%c'", c
299 static Void local togglesIn(state) /* Print current list of toggles in*/
300 Bool state; { /* given state */
303 for (i=0; toggle[i].c; ++i)
304 if (*toggle[i].flag == state) {
306 Putchar((char)(state ? '+' : '-'));
307 Putchar(toggle[i].c);
314 static Void local optionInfo() { /* Print information about command */
315 static String fmts = "%-5s%s\n"; /* line settings */
316 static String fmtc = "%-5c%s\n";
319 Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
320 for (i=0; toggle[i].c; ++i)
321 Printf(fmtc,toggle[i].c,toggle[i].description);
323 Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
324 Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
325 Printf(fmts,"pstr","Set prompt string to str");
326 Printf(fmts,"rstr","Set repeat last expression string to str");
327 Printf(fmts,"Pstr","Set search path for modules to str");
328 Printf(fmts,"Estr","Use editor setting given by str");
329 Printf(fmts,"cnum","Set constraint cutoff limit");
330 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
331 Printf(fmts,"Fstr","Set preprocessor filter to str");
334 Printf("\nCurrent settings: ");
337 Printf("-h%d",heapSize);
341 printString(repeatStr);
342 Printf(" -c%d",cutoff);
343 Printf("\nSearch path : -P");
344 printString(hugsPath);
347 if (projectPath!=NULL) {
348 Printf("\nProject Path : %s",projectPath);
351 Printf("\nEditor setting : -E");
352 printString(hugsEdit);
353 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
354 Printf("\nPreprocessor : -F");
355 printString(preprocessor);
357 Printf("\nCompatibility : %s", haskell98 ? "Haskell 98"
358 : "Hugs Extensions");
362 #if USE_REGISTRY || HUGS_FOR_WINDOWS
370 #define PUTInt(optc,i) \
371 sprintf(next,"-%c%d",optc,i); \
374 #define PUTStr(c,s) \
375 next=PUTStr_aux(next,c,s)
377 static String local PUTStr_aux Args((String,Char, String));
379 static String local PUTStr_aux(next,c,s)
385 sprintf(next,"-%c\"",c);
388 PUTS(unlexChar(*t,'"'));
396 static String local optionsToStr() { /* convert options to string */
397 static char buffer[2000];
398 String next = buffer;
401 for (i=0; toggle[i].c; ++i) {
402 PUTC(*toggle[i].flag ? '+' : '-');
406 PUTInt('h',hpSize); PUTC(' ');
408 PUTStr('r',repeatStr);
409 PUTStr('P',hugsPath);
410 PUTStr('E',hugsEdit);
411 PUTInt('c',cutoff); PUTC(' ');
412 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
413 PUTStr('F',preprocessor);
418 #endif /* USE_REGISTRY */
425 static Void local readOptions(options) /* read options from string */
429 stringInput(options);
430 while ((s=readFilename())!=0) {
431 if (*s && !processOption(s)) {
432 ERRMSG(0) "Option string must begin with `+' or `-'"
439 static Bool local processOption(s) /* process string s for options, */
440 String s; { /* return FALSE if none found. */
452 case 'Q' : break; /* already handled */
454 case 'p' : if (s[1]) {
455 if (prompt) free(prompt);
456 prompt = strCopy(s+1);
460 case 'r' : if (s[1]) {
461 if (repeatStr) free(repeatStr);
462 repeatStr = strCopy(s+1);
467 String p = substPath(s+1,hugsPath ? hugsPath : "");
468 if (hugsPath) free(hugsPath);
473 case 'E' : if (hugsEdit) free(hugsEdit);
474 hugsEdit = strCopy(s+1);
477 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
478 case 'F' : if (preprocessor) free(preprocessor);
479 preprocessor = strCopy(s+1);
483 case 'h' : setHeapSize(s+1);
486 case 'D' : /* hack */
488 extern void setRtsFlags( int x );
489 setRtsFlags(argToInt(s+1));
493 default : if (strcmp("98",s)==0) {
494 if (heapBuilt() && ((state && !haskell98) ||
495 (!state && haskell98))) {
496 FPrintf(stderr,"Haskell 98 compatibility cannot be changed while the interpreter is running\n");
509 static Void local setHeapSize(s)
512 hpSize = argToInt(s);
513 if (hpSize < MINIMUMHEAP)
514 hpSize = MINIMUMHEAP;
515 else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
516 hpSize = MAXIMUMHEAP;
517 if (heapBuilt() && hpSize != heapSize) {
518 /* ToDo: should this use a message box in winhugs? */
520 FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
522 FPrintf(stderr,"Cannot change heap size\n");
530 static Int local argToInt(s) /* read integer from argument str */
535 if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
536 ERRMSG(0) "Missing integer in option setting \"%s\"", t
541 Int d = (*s++) - '0';
542 if (n > ((MAXPOSINT - d)/10)) {
543 ERRMSG(0) "Option setting \"%s\" is too large", t
547 } while (isascii((int)(*s)) && isdigit((int)(*s)));
549 if (*s=='K' || *s=='k') {
550 if (n > (MAXPOSINT/1000)) {
551 ERRMSG(0) "Option setting \"%s\" is too large", t
558 #if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
559 if (*s=='M' || *s=='m') {
560 if (n > (MAXPOSINT/1000000)) {
561 ERRMSG(0) "Option setting \"%s\" is too large", t
569 #if MAXPOSINT > 1000000000
570 if (*s=='G' || *s=='g') {
571 if (n > (MAXPOSINT/1000000000)) {
572 ERRMSG(0) "Option setting \"%s\" is too large", t
581 ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
588 /* --------------------------------------------------------------------------
589 * Print Menu of list of commands:
590 * ------------------------------------------------------------------------*/
592 static struct cmd cmds[] = {
593 {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
594 {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
595 {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
596 {":quit", QUIT}, {":set", SET}, {":find", FIND},
597 {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
598 {":dump", DUMP}, {":ztats", STATS},
599 {":module",SETMODULE},
604 static Void local menu() {
605 Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
606 Printf("c is the first character in the full name.\n\n");
607 Printf(":load <filenames> load modules from specified files\n");
608 Printf(":load clear all files except prelude\n");
609 Printf(":also <filenames> read additional modules\n");
610 Printf(":reload repeat last load command\n");
611 Printf(":project <filename> use project file\n");
612 Printf(":edit <filename> edit file\n");
613 Printf(":edit edit last module\n");
614 Printf(":module <module> set module for evaluating expressions\n");
615 Printf("<expr> evaluate expression\n");
616 Printf(":type <expr> print type of expression\n");
617 Printf(":? display this list of commands\n");
618 Printf(":set <options> set command line options\n");
619 Printf(":set help on command line options\n");
620 Printf(":names [pat] list names currently in scope\n");
621 Printf(":info <names> describe named objects\n");
622 Printf(":find <name> edit module containing definition of name\n");
623 Printf(":!command shell escape\n");
624 Printf(":cd dir change directory\n");
625 Printf(":gc force garbage collection\n");
626 Printf(":dump <name> print STG code for named fn\n");
627 #ifdef CRUDE_PROFILING
628 Printf(":ztats <name> print reduction stats\n");
630 Printf(":quit exit Hugs interpreter\n");
633 static Void local guidance() {
634 Printf("Command not recognised. ");
638 static Void local forHelp() {
639 Printf("Type :? for help\n");
642 /* --------------------------------------------------------------------------
643 * Setting of command line options:
644 * ------------------------------------------------------------------------*/
646 struct options toggle[] = { /* List of command line toggles */
647 {'s', "Print no. reductions/cells after eval", &showStats},
648 {'t', "Print type after evaluation", &addType},
649 /*ToDo?? {'f', "Terminate evaluation on first error", &failOnError},*/
650 {'g', "Print no. cells recovered after gc", &gcMessages},
651 {'l', "Literate modules as default", &literateScripts},
652 {'e', "Warn about errors in literate modules", &literateErrors},
653 {'.', "Print dots to show progress", &useDots},
654 {'q', "Print nothing to show progress", &quiet},
655 {'w', "Always show which modules are loaded", &listScripts},
656 {'k', "Show kind errors in full", &kindExpert},
657 {'o', "Allow overlapping instances", &allowOverlap},
658 {'i', "Chase imports while loading modules", &chaseImports},
659 {'O', "Optimise (improve?) generated code", &optimise},
661 {'D', "Debug: show generated code", &debugCode},
666 static Void local set() { /* change command line options from*/
667 String s; /* Hugs command line */
669 if ((s=readFilename())!=0) {
671 if (!processOption(s)) {
672 ERRMSG(0) "Option string must begin with `+' or `-'"
675 } while ((s=readFilename())!=0);
677 writeRegString("Options", optionsToStr());
684 /* --------------------------------------------------------------------------
685 * Change directory command:
686 * ------------------------------------------------------------------------*/
688 static Void local changeDir() { /* change directory */
689 String s = readFilename();
691 ERRMSG(0) "Unable to change to directory \"%s\"", s
696 /* --------------------------------------------------------------------------
697 * Loading project and script files:
698 * ------------------------------------------------------------------------*/
700 static Void local loadProject(s) /* Load project file */
704 projInput(currProject);
705 scriptFile = currProject;
706 forgetScriptsFrom(1);
707 while ((s=readFilename())!=0)
708 addScriptName(s,TRUE);
710 ERRMSG(0) "Empty project file"
714 projectLoaded = TRUE;
717 static Void local clearProject() { /* clear name for current project */
721 projectLoaded = FALSE;
723 setLastEdit((String)0,0);
727 static Void local addScriptName(s,sch) /* Add script to list of scripts */
728 String s; /* to be read in ... */
729 Bool sch; { /* TRUE => requires pathname search*/
730 if (namesUpto>=NUM_SCRIPTS) {
731 ERRMSG(0) "Too many module files (maximum of %d allowed)",
736 scriptName[namesUpto++] = strCopy(sch ? findPathname(NULL,s) : s);
739 static Bool local addScript(fname,len) /* read single script file */
740 String fname; /* name of script file */
741 Long len; { /* length of script file */
744 #if HUGS_FOR_WINDOWS /* Set clock cursor while loading */
746 SetCursor(LoadCursor(NULL, IDC_WAIT));
749 Printf("Reading file \"%s\":\n",fname);
750 setLastEdit(fname,0);
754 if (isInterfaceFile(fname)) {
755 loadInterface(fname);
759 needsImports = FALSE;
760 parseScript(fname,len); /* process script file */
769 preludeLoaded = TRUE;
773 Bool chase(imps) /* Process list of import requests */
776 Int origPos = numScripts; /* keep track of original position */
777 String origName = scriptName[origPos];
778 for (; nonNull(imps); imps=tl(imps)) {
779 String iname = findPathname(origName,textToStr(textOf(hd(imps))));
781 for (; i<namesUpto; i++)
782 if (pathCmp(scriptName[i],iname)==0)
784 if (i>=origPos) { /* Neither loaded or queued */
789 postponed[origPos] = TRUE;
792 if (i>=namesUpto) /* Name not found (i==namesUpto) */
793 addScriptName(iname,FALSE);
794 else if (postponed[i]) {/* Check for recursive dependency */
796 "Recursive import dependency between \"%s\" and \"%s\"",
797 scriptName[origPos], iname
800 /* Right rotate section of tables between numScripts and i so
801 * that i ends up with other imports in front of orig. script
803 theName = scriptName[i];
804 thePost = postponed[i];
805 timeSet(theTime,lastChange[i]);
806 for (; i>numScripts; i--) {
807 scriptName[i] = scriptName[i-1];
808 postponed[i] = postponed[i-1];
809 timeSet(lastChange[i],lastChange[i-1]);
811 scriptName[numScripts] = theName;
812 postponed[numScripts] = thePost;
813 timeSet(lastChange[numScripts],theTime);
822 static Void local forgetScriptsFrom(scno)/* remove scripts from system */
825 for (i=scno; i<namesUpto; ++i)
828 dropScriptsFrom(scno-1);
830 if (numScripts>namesUpto)
834 /* --------------------------------------------------------------------------
835 * Commands for loading and removing script files:
836 * ------------------------------------------------------------------------*/
838 static Void local load() { /* read filenames from command line */
839 String s; /* and add to list of scripts waiting */
841 while ((s=readFilename())!=0)
842 addScriptName(s,TRUE);
846 static Void local project() { /* read list of script names from */
847 String s; /* project file */
849 if ((s=readFilename()) || currProject) {
851 s = strCopy(currProject);
852 else if (readFilename()) {
853 ERRMSG(0) "Too many project files"
860 ERRMSG(0) "No project filename specified"
867 static Void local readScripts(n) /* Reread current list of scripts, */
868 Int n; { /* loading everything after and */
869 Time timeStamp; /* including the first script which*/
870 Long fileSize; /* has been either changed or added*/
873 SetCursor(LoadCursor(NULL, IDC_WAIT));
876 for (; n<numScripts; n++) { /* Scan previously loaded scripts */
877 getFileInfo(scriptName[n], &timeStamp, &fileSize);
878 if (timeChanged(timeStamp,lastChange[n])) {
879 dropScriptsFrom(n-1);
884 for (; n<NUM_SCRIPTS; n++) /* No scripts have been postponed */
885 postponed[n] = FALSE; /* at this stage */
887 while (numScripts<namesUpto) { /* Process any remaining scripts */
888 getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
889 timeSet(lastChange[numScripts],timeStamp);
890 if (numScripts>0) /* no new script for prelude */
891 startNewScript(scriptName[numScripts]);
892 if (addScript(scriptName[numScripts],fileSize))
895 dropScriptsFrom(numScripts-1);
901 setLastEdit((String)0, 0);
904 static Void local whatScripts() { /* list scripts in current session */
906 Printf("\nHugs session for:");
908 Printf(" (project: %s)",currProject);
909 for (i=0; i<numScripts; ++i)
910 Printf("\n%s",scriptName[i]);
914 /* --------------------------------------------------------------------------
915 * Access to external editor:
916 * ------------------------------------------------------------------------*/
918 static Void local editor() { /* interpreter-editor interface */
919 String newFile = readFilename();
921 setLastEdit(newFile,0);
922 if (readFilename()) {
923 ERRMSG(0) "Multiple filenames not permitted"
930 static Void local find() { /* edit file containing definition */
931 String nm = readFilename(); /* of specified name */
933 ERRMSG(0) "No name specified"
936 else if (readFilename()) {
937 ERRMSG(0) "Multiple names not permitted"
943 setCurrModule(findEvalModule());
945 if (nonNull(c=findTycon(t=findText(nm)))) {
946 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
949 } else if (nonNull(c=findName(t))) {
950 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
954 ERRMSG(0) "No current definition for name \"%s\"", nm
960 static Void local runEditor() { /* run editor on script lastEdit */
961 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
965 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
970 lastEdit = strCopy(fname);
973 DrawStatusLine(hWndMain); /* Redo status line */
977 /* --------------------------------------------------------------------------
978 * Read and evaluate an expression:
979 * ------------------------------------------------------------------------*/
981 static Void local setModule(){/*set module in which to evaluate expressions*/
982 String s = readFilename();
983 if (!s) s = ""; /* :m clears the current module selection */
984 evalModule = findText(s);
985 setLastEdit(fileOfModule(findEvalModule()),0);
988 static Module local findEvalModule() { /*Module in which to eval expressions*/
989 Module m = findModule(evalModule);
995 static Void local evaluator() { /* evaluate expr and print value */
999 setCurrModule(findEvalModule());
1001 startNewScript(0); /* Enables recovery of storage */
1002 /* allocated during evaluation */
1005 defaultDefns = evalDefaults;
1006 type = typeCheckExp(TRUE);
1007 if (isPolyType(type)) {
1008 ks = polySigOf(type);
1009 bd = monotypeOf(type);
1014 if (whatIs(bd)==QUAL) {
1015 ERRMSG(0) "Unresolved overloading" ETHEN
1016 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1017 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1027 if (typeMatches(type,ap(typeIO,typeUnit))) {
1028 inputExpr = ap(nameRunIO,inputExpr);
1032 Cell d = provePred(ks,NIL,ap(classShow,bd));
1034 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1035 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1036 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1040 inputExpr = ap2(findName(findText("show")),d,inputExpr);
1041 inputExpr = ap(findName(findText("putStr")), inputExpr);
1042 inputExpr = ap(nameRunIO, inputExpr);
1044 evalExp(); printf("\n");
1047 printType(stdout,type);
1054 printf ( "result type is " );
1055 printType ( stdout, type );
1063 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
1064 if (printing) { /* after successful termination or */
1065 printing = FALSE; /* runtime error (e.g. interrupt) */
1068 #define plural(v) v, (v==1?"":"s")
1069 Printf("%lu cell%s",plural(numCells));
1071 Printf(", %u garbage collection%s",plural(numGcs));
1080 /* --------------------------------------------------------------------------
1081 * Print type of input expression:
1082 * ------------------------------------------------------------------------*/
1084 static Void local showtype() { /* print type of expression (if any)*/
1087 setCurrModule(findEvalModule());
1088 startNewScript(0); /* Enables recovery of storage */
1089 /* allocated during evaluation */
1092 defaultDefns = evalDefaults;
1093 type = typeCheckExp(FALSE);
1094 printExp(stdout,inputExpr);
1096 printType(stdout,type);
1100 /* --------------------------------------------------------------------------
1101 * Enhanced help system: print current list of scripts or give information
1103 * ------------------------------------------------------------------------*/
1105 static String local objToStr(m,c)
1108 #if 1 || DISPLAY_QUANTIFIERS
1109 static char newVar[60];
1110 switch (whatIs(c)) {
1111 case NAME : if (m == name(c).mod) {
1112 sprintf(newVar,"%s", textToStr(name(c).text));
1114 sprintf(newVar,"%s.%s",
1115 textToStr(module(name(c).mod).text),
1116 textToStr(name(c).text));
1120 case TYCON : if (m == tycon(c).mod) {
1121 sprintf(newVar,"%s", textToStr(tycon(c).text));
1123 sprintf(newVar,"%s.%s",
1124 textToStr(module(tycon(c).mod).text),
1125 textToStr(tycon(c).text));
1129 case CLASS : if (m == cclass(c).mod) {
1130 sprintf(newVar,"%s", textToStr(cclass(c).text));
1132 sprintf(newVar,"%s.%s",
1133 textToStr(module(cclass(c).mod).text),
1134 textToStr(cclass(c).text));
1138 default : internal("objToStr");
1142 static char newVar[33];
1143 switch (whatIs(c)) {
1144 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1147 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1150 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1153 default : internal("objToStr");
1161 static Void local dumpStg() { /* print STG stuff */
1166 Cell v; /* really StgVar */
1167 setCurrModule(findEvalModule());
1169 for (; (s=readFilename())!=0;) {
1172 /* find the name while ignoring module scopes */
1173 for (i=NAMEMIN; i<nameHw; i++)
1174 if (name(i).text == t) n = i;
1176 /* perhaps it's an "idNNNNNN" thing? */
1179 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
1182 while (isdigit(s[i])) {
1183 v = v * 10 + (s[i]-'0');
1187 n = nameFromStgVar(v);
1190 if (isNull(n) && whatIs(v)==STGVAR) {
1191 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
1192 Printf ( "{- stgSize of body is %d -}\n\n", stgSize(stgVarBody(v)));
1193 printStg(stderr, v );
1196 Printf ( "Unknown reference `%s'\n", s );
1199 Printf ( "Not a Name: `%s'\n", s );
1201 if (isNull(name(n).stgVar)) {
1202 Printf ( "Doesn't have a STG tree: %s\n", s );
1204 printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
1205 Printf ( "{- stgSize of body is %d -}\n\n", stgSize(stgVarBody(name(n).stgVar)));
1206 printStg(stderr, name(n).stgVar);
1211 static Void local info() { /* describe objects */
1212 Int count = 0; /* or give menu of commands */
1215 setCurrModule(findEvalModule());
1216 startNewScript(0); /* for recovery of storage */
1217 for (; (s=readFilename())!=0; count++) {
1218 describe(findText(s));
1225 static Void local describe(t) /* describe an object */
1227 Tycon tc = findTycon(t);
1228 Class cl = findClass(t);
1229 Name nm = findName(t);
1230 //Module mod = findEvalModule();
1232 if (nonNull(tc)) { /* as a type constructor */
1236 for (i=0; i<tycon(tc).arity; ++i) {
1237 t = ap(t,mkOffset(i));
1239 Printf("-- type constructor");
1241 Printf(" with kind ");
1242 printKind(stdout,tycon(tc).kind);
1245 switch (tycon(tc).what) {
1246 case SYNONYM : Printf("type ");
1247 printType(stdout,t);
1249 printType(stdout,tycon(tc).defn);
1253 case DATATYPE : { List cs = tycon(tc).defn;
1254 if (tycon(tc).what==DATATYPE) {
1259 printType(stdout,t);
1261 mapProc(printSyntax,cs);
1263 Printf("\n-- constructors:");
1265 for (; hasCfun(cs); cs=tl(cs)) {
1267 printExp(stdout,hd(cs));
1269 printType(stdout,name(hd(cs)).type);
1272 Printf("\n-- selectors:");
1274 for (; nonNull(cs); cs=tl(cs)) {
1276 printExp(stdout,hd(cs));
1278 printType(stdout,name(hd(cs)).type);
1283 case RESTRICTSYN : Printf("type ");
1284 printType(stdout,t);
1285 Printf(" = <restricted>");
1289 if (nonNull(in=findFirstInst(tc))) {
1290 Printf("\n-- instances:\n");
1293 in = findNextInst(tc,in);
1294 } while (nonNull(in));
1299 if (nonNull(cl)) { /* as a class */
1300 List ins = cclass(cl).instances;
1301 Kinds ks = cclass(cl).kinds;
1302 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
1303 Printf("-- type class");
1305 Printf("-- constructor class");
1307 Printf(" with arity ");
1308 printKinds(stdout,ks);
1312 mapProc(printSyntax,cclass(cl).members);
1314 if (nonNull(cclass(cl).supers)) {
1315 printContext(stdout,cclass(cl).supers);
1318 printPred(stdout,cclass(cl).head);
1319 if (nonNull(cclass(cl).members)) {
1320 List ms = cclass(cl).members;
1323 Type t = monotypeOf(name(hd(ms)).type);
1325 printExp(stdout,hd(ms));
1327 if (isNull(tl(fst(snd(t))))) {
1330 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
1332 printType(stdout,t);
1334 } while (nonNull(ms));
1338 Printf("\n-- instances:\n");
1342 } while (nonNull(ins));
1347 if (nonNull(nm)) { /* as a function/name */
1349 printExp(stdout,nm);
1351 if (nonNull(name(nm).type)) {
1352 printType(stdout,name(nm).type);
1354 Printf("<unknown type>");
1358 Printf(" -- data constructor");
1359 } else if (isMfun(nm)) {
1360 Printf(" -- class member");
1361 } else if (isSfun(nm)) {
1362 Printf(" -- selector function");
1366 if (name(nm).primDef) {
1367 Printf(" -- primitive");
1373 if (isNull(tc) && isNull(cl) && isNull(nm)) {
1374 Printf("Unknown reference `%s'\n",textToStr(t));
1378 static Void local printSyntax(nm)
1380 Syntax sy = syntaxOf(nm);
1381 Text t = name(nm).text;
1382 String s = textToStr(t);
1383 if (sy != defaultSyntax(t)) {
1385 switch (assocOf(sy)) {
1386 case LEFT_ASS : Putchar('l'); break;
1387 case RIGHT_ASS : Putchar('r'); break;
1388 case NON_ASS : break;
1390 Printf(" %i ",precOf(sy));
1391 if (isascii((int)(*s)) && isalpha((int)(*s))) {
1400 static Void local showInst(in) /* Display instance decl header */
1402 Printf("instance ");
1403 if (nonNull(inst(in).specifics)) {
1404 printContext(stdout,inst(in).specifics);
1407 printPred(stdout,inst(in).head);
1411 /* --------------------------------------------------------------------------
1412 * List all names currently in scope:
1413 * ------------------------------------------------------------------------*/
1415 static Void local listNames() { /* list names matching optional pat*/
1416 String pat = readFilename();
1418 Int width = getTerminalWidth() - 1;
1421 Module mod = findEvalModule();
1423 if (pat) { /* First gather names to list */
1425 names = addNamesMatching(pat,names);
1426 } while ((pat=readFilename())!=0);
1428 names = addNamesMatching((String)0,names);
1430 if (isNull(names)) { /* Then print them out */
1431 ERRMSG(0) "No names selected"
1434 for (termPos=0; nonNull(names); names=tl(names)) {
1435 String s = objToStr(mod,hd(names));
1437 if (termPos+1+l>width) {
1440 } else if (termPos>0) {
1448 Printf("\n(%d names listed)\n", count);
1451 /* --------------------------------------------------------------------------
1452 * print a prompt and read a line of input:
1453 * ------------------------------------------------------------------------*/
1455 static Void local promptForInput(moduleName)
1456 String moduleName; {
1457 char promptBuffer[1000];
1459 /* This is portable but could overflow buffer */
1460 sprintf(promptBuffer,prompt,moduleName);
1462 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
1463 * promptBuffer instead.
1465 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
1466 /* Reset prompt to a safe default to avoid an infinite loop */
1468 prompt = strCopy("? ");
1469 internal("Combined prompt and evaluation module name too long");
1473 stringInput("main\0"); else
1474 consoleInput(promptBuffer);
1477 /* --------------------------------------------------------------------------
1478 * main read-eval-print loop, with error trapping:
1479 * ------------------------------------------------------------------------*/
1481 static jmp_buf catch_error; /* jump buffer for error trapping */
1483 static Void local interpreter(argc,argv)/* main interpreter loop */
1486 Int errorNumber = setjmp(catch_error);
1488 if (errorNumber && autoMain) {
1489 fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" );
1493 breakOn(TRUE); /* enable break trapping */
1494 if (numScripts==0) { /* only succeeds on first time, */
1495 if (errorNumber) /* before prelude has been loaded */
1496 fatal("Unable to load prelude");
1497 initialize(argc,argv);
1503 everybody(RESET); /* reset to sensible initial state */
1504 dropScriptsFrom(numScripts-1); /* remove partially loaded scripts */
1505 /* not counting prelude as a script*/
1507 promptForInput(textToStr(module(findEvalModule()).text));
1509 cmd = readCommand(cmds, (Char)':', (Char)'!');
1514 case EDIT : editor();
1518 case LOAD : clearProject();
1519 forgetScriptsFrom(1);
1522 case ALSO : clearProject();
1523 forgetScriptsFrom(numScripts);
1526 case RELOAD : readScripts(1);
1528 case PROJECT: project();
1533 case EVAL : evaluator();
1535 case TYPEOF : showtype();
1537 case NAMES : listNames();
1541 case BADCMD : guidance();
1546 #ifdef CRUDE_PROFILING
1550 case SYSTEM : if (shellEsc(readLine()))
1551 Printf("Warning: Shell escape terminated abnormally\n");
1553 case CHGDIR : changeDir();
1557 case DUMP : dumpStg();
1560 case COLLECT: consGC = FALSE;
1563 Printf("Garbage collection recovered %d cells\n",
1570 Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
1571 millisecs(userElapsed), millisecs(systElapsed));
1573 if (autoMain) break;
1578 /* --------------------------------------------------------------------------
1579 * Display progress towards goal:
1580 * ------------------------------------------------------------------------*/
1582 static Target currTarget;
1583 static Bool aiming = FALSE;
1586 static Int charCount;
1588 Void setGoal(what, t) /* Set goal for what to be t */
1592 currTarget = (t?t:1);
1595 currPos = strlen(what);
1596 maxPos = getTerminalWidth() - 1;
1600 for (charCount=0; *what; charCount++)
1605 Void soFar(t) /* Indicate progress towards goal */
1606 Target t; { /* has now reached t */
1609 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
1614 if (newPos>currPos) {
1617 while (newPos>++currPos);
1624 Void done() { /* Goal has now been achieved */
1627 while (maxPos>currPos++)
1632 for (; charCount>0; charCount--) {
1641 static Void local failed() { /* Goal cannot be reached due to */
1642 if (aiming) { /* errors */
1649 /* --------------------------------------------------------------------------
1651 * ------------------------------------------------------------------------*/
1653 Void errHead(l) /* print start of error message */
1655 failed(); /* failed to reach target ... */
1657 FPrintf(errorStream,"ERROR");
1660 FPrintf(errorStream," \"%s\"", scriptFile);
1661 setLastEdit(scriptFile,l);
1662 if (l) FPrintf(errorStream," (line %d)",l);
1665 FPrintf(errorStream,": ");
1666 FFlush(errorStream);
1669 Void errFail() { /* terminate error message and */
1670 Putc('\n',errorStream); /* produce exception to return to */
1671 FFlush(errorStream); /* main command loop */
1672 longjmp(catch_error,1);
1675 Void errAbort() { /* altern. form of error handling */
1676 failed(); /* used when suitable error message*/
1677 stopAnyPrinting(); /* has already been printed */
1681 Void internal(msg) /* handle internal error */
1683 #if HUGS_FOR_WINDOWS
1685 wsprintf(buf,"INTERNAL ERROR: %s",msg);
1686 MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
1690 Printf("INTERNAL ERROR: %s\n",msg);
1692 longjmp(catch_error,1);
1695 Void fatal(msg) /* handle fatal error */
1697 #if HUGS_FOR_WINDOWS
1699 wsprintf(buf,"FATAL ERROR: %s",msg);
1700 MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
1703 Printf("\nFATAL ERROR: %s\n",msg);
1708 sigHandler(breakHandler) { /* respond to break interrupt */
1709 #if HUGS_FOR_WINDOWS
1710 MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
1713 Printf("{Interrupted!}\n");
1715 breakOn(TRUE); /* reinstall signal handler - redundant on BSD systems */
1716 /* but essential on POSIX (and other?) systems */
1722 longjmp(catch_error,1);
1723 sigResume;/*NOTREACHED*/
1726 /* --------------------------------------------------------------------------
1727 * Read value from environment variable or registry:
1728 * ------------------------------------------------------------------------*/
1730 String fromEnv(var,def) /* return value of: */
1731 String var; /* environment variable named by var */
1732 String def; { /* or: default value given by def */
1733 String s = getenv(var);
1734 return (s ? s : def);
1737 /* --------------------------------------------------------------------------
1738 * String manipulation routines:
1739 * ------------------------------------------------------------------------*/
1741 static String local strCopy(s) /* make malloced copy of a string */
1745 if ((t=(char *)malloc(strlen(s)+1))==0) {
1746 ERRMSG(0) "String storage space exhausted"
1749 for (r=t; (*r++ = *s++)!=0; ) {
1756 /* --------------------------------------------------------------------------
1758 * We can redirect compiler output (prompts, error messages, etc) by
1759 * tweaking these functions.
1760 * ------------------------------------------------------------------------*/
1762 #if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
1764 #ifdef HAVE_STDARG_H
1767 #include <varargs.h>
1770 /* ----------------------------------------------------------------------- */
1772 #define BufferSize 5000 /* size of redirected output buffer */
1774 typedef struct _HugsStream {
1775 char buffer[BufferSize]; /* buffer for redirected output */
1776 Int next; /* next space in buffer */
1779 static Void local vBufferedPrintf Args((HugsStream*, const char*, va_list));
1780 static Void local bufferedPutchar Args((HugsStream*, Char));
1781 static String local bufferClear Args((HugsStream *stream));
1783 static Void local vBufferedPrintf(stream, fmt, ap)
1787 Int spaceLeft = BufferSize - stream->next;
1788 char* p = &stream->buffer[stream->next];
1789 Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
1790 if (0 <= charsAdded && charsAdded < spaceLeft)
1791 stream->next += charsAdded;
1792 #if 1 /* we can either buffer the first n chars or buffer the last n chars */
1798 static Void local bufferedPutchar(stream, c)
1801 if (BufferSize - stream->next >= 2) {
1802 stream->buffer[stream->next++] = c;
1803 stream->buffer[stream->next] = '\0';
1807 static String local bufferClear(stream)
1808 HugsStream *stream; {
1809 if (stream->next == 0) {
1813 return stream->buffer;
1817 /* ----------------------------------------------------------------------- */
1819 static HugsStream outputStreamH;
1821 * We rely on standard C semantics to initialise outputStreamH.next to 0.
1824 Void hugsEnableOutput(f)
1829 String hugsClearOutputBuffer() {
1830 return bufferClear(&outputStreamH);
1833 #ifdef HAVE_STDARG_H
1834 Void hugsPrintf(const char *fmt, ...) {
1835 va_list ap; /* pointer into argument list */
1836 va_start(ap, fmt); /* make ap point to first arg after fmt */
1837 if (!disableOutput) {
1840 vBufferedPrintf(&outputStreamH, fmt, ap);
1842 va_end(ap); /* clean up */
1845 Void hugsPrintf(fmt, va_alist)
1848 va_list ap; /* pointer into argument list */
1849 va_start(ap); /* make ap point to first arg after fmt */
1850 if (!disableOutput) {
1853 vBufferedPrintf(&outputStreamH, fmt, ap);
1855 va_end(ap); /* clean up */
1861 if (!disableOutput) {
1864 bufferedPutchar(&outputStreamH, c);
1868 Void hugsFlushStdout() {
1869 if (!disableOutput) {
1876 if (!disableOutput) {
1881 #ifdef HAVE_STDARG_H
1882 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
1885 if (!disableOutput) {
1886 vfprintf(fp, fmt, ap);
1888 vBufferedPrintf(&outputStreamH, fmt, ap);
1893 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
1899 if (!disableOutput) {
1900 vfprintf(fp, fmt, ap);
1902 vBufferedPrintf(&outputStreamH, fmt, ap);
1908 Void hugsPutc(c, fp)
1911 if (!disableOutput) {
1914 bufferedPutchar(&outputStreamH, c);
1918 #endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
1919 /* --------------------------------------------------------------------------
1920 * Send message to each component of system:
1921 * ------------------------------------------------------------------------*/
1923 Void everybody(what) /* send command `what' to each component of*/
1924 Int what; { /* system to respond as appropriate ... */
1925 machdep(what); /* The order of calling each component is */
1926 storage(what); /* important for the INSTALL command */
1929 translateControl(what);
1931 staticAnalysis(what);
1932 deriveControl(what);
1939 /* --------------------------------------------------------------------------
1940 * Hugs for Windows code (WinMain and related functions)
1941 * ------------------------------------------------------------------------*/
1943 #if HUGS_FOR_WINDOWS
1944 #include "winhugs.c"