1 /* -*- mode: hugs-c; -*- */
2 /* --------------------------------------------------------------------------
5 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
6 * All rights reserved. See NOTICE for details and conditions of use etc...
7 * Hugs version 1.4, December 1997
11 * $Date: 1998/12/02 13:22:09 $
12 * ------------------------------------------------------------------------*/
22 #include "subst.h" /* for typeMatches */
23 #include "link.h" /* for classShow, nameRunIO and namePrint */
26 #include "interface.h"
36 /* --------------------------------------------------------------------------
37 * Local function prototypes:
38 * ------------------------------------------------------------------------*/
40 static Void local initialize Args((Int,String []));
41 static Void local promptForInput Args((String));
42 static Void local interpreter Args((Int,String []));
43 static Void local menu Args((Void));
44 static Void local guidance Args((Void));
45 static Void local forHelp Args((Void));
46 static Void local set Args((Void));
47 static Void local changeDir Args((Void));
48 static Void local load Args((Void));
49 static Void local project Args((Void));
50 static Void local readScripts Args((Int));
51 static Void local whatScripts Args((Void));
52 static Void local editor Args((Void));
53 static Void local find Args((Void));
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 showtype Args((Void));
59 static Void local info Args((Void));
60 static Void local showInst Args((Inst));
61 static Void local describe Args((Text));
62 static Void local listNames Args((Void));
64 static Void local toggleSet Args((Char,Bool));
65 static Void local togglesIn Args((Bool));
66 static Void local optionInfo Args((Void));
67 #if USE_REGISTRY || HUGS_FOR_WINDOWS
68 static String local optionsToStr Args((Void));
70 static Void local readOptions Args((String));
71 static Bool local processOption Args((String));
72 static Void local setHeapSize Args((String));
73 static Int local argToInt Args((String));
75 static Void local loadProject Args((String));
76 static Void local clearProject Args((Void));
77 static Void local addScriptName Args((String,Bool));
78 static Bool local addScript Args((String,Long));
79 static Void local forgetScriptsFrom Args((Script));
80 static Void local setLastEdit Args((String,Int));
81 static Void local failed Args((Void));
82 static String local strCopy Args((String));
84 /* --------------------------------------------------------------------------
85 * Machine dependent code for Hugs interpreter:
86 * ------------------------------------------------------------------------*/
92 /* --------------------------------------------------------------------------
94 * ------------------------------------------------------------------------*/
96 static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
97 static Bool addType = FALSE; /* TRUE => print type with value */
98 static Bool chaseImports = TRUE; /* TRUE => chase imports on load */
99 static Bool useDots = RISCOS; /* TRUE => use dots in progress */
100 static Bool quiet = FALSE; /* TRUE => don't show progress */
102 static String scriptName[NUM_SCRIPTS]; /* Script file names */
103 static Time lastChange[NUM_SCRIPTS]; /* Time of last change to script */
104 static Bool postponed[NUM_SCRIPTS]; /* Indicates postponed load */
105 static Int scriptBase; /* Number of scripts in Prelude */
106 static Int numScripts; /* Number of scripts loaded */
107 static Int namesUpto; /* Number of script names set */
108 static Bool needsImports; /* set to TRUE if imports required */
109 String scriptFile; /* Name of current script (if any) */
111 static Text evalModule = 0; /* Name of module we eval exprs in */
112 static String currProject = 0; /* Name of current project file */
113 static Bool projectLoaded = FALSE; /* TRUE => project file loaded */
115 static String lastEdit = 0; /* Name of script to edit (if any) */
116 static Int lastLine = 0; /* Editor line number (if possible)*/
117 static String prompt = 0; /* Prompt string */
118 static Int hpSize = DEFAULTHEAP; /* Desired heap size */
119 String hugsEdit = 0; /* String for editor command */
120 String hugsPath = 0; /* String for file search path */
123 static Bool disableOutput = FALSE; /* redirect output to buffer? */
126 /* --------------------------------------------------------------------------
128 * ------------------------------------------------------------------------*/
130 #ifndef NO_MAIN /* we omit main when building the "Hugs server" */
132 Main main Args((Int, String [])); /* now every func has a prototype */
138 #ifdef HAVE_CONSOLE_H /* Macintosh port */
140 _fcreator = 'R*ch'; /* // 'KAHL'; //'*TEX'; //'ttxt'; */
142 console_options.top = 50;
143 console_options.left = 20;
145 console_options.nrows = 32;
146 console_options.ncols = 80;
148 console_options.pause_atexit = 1;
149 console_options.title = "\pHugs";
151 console_options.procID = 5;
152 argc = ccommand(&argv);
155 CStackBase = &argc; /* Save stack base for use in gc */
157 /* The startup banner now includes my name. Hugs is provided free of */
158 /* charge. I ask however that you show your appreciation for the many */
159 /* hours of work involved by retaining my name in the banner. Thanks! */
162 Printf("Hugs 1.4, %s release.\n", HUGS_VERSION);
163 Printf("Copyright (c) The University of Nottingham and Yale University, 1994-1998.\n");
164 Printf("Home page: http://haskell.org/hugs. Bug reports: hugs-bugs@haskell.org.\n");
167 Printf(" ___ ___ ___ ___ __________ __________ \n");
168 Printf(" / / / / / / / / / _______/ / _______/ Hugs 1.4 \n");
169 Printf(" / /___/ / / / / / / / _____ / /______ \n");
170 Printf(" / ____ / / / / / / / /_ / /______ / The Nottingham and Yale\n");
171 Printf(" / / / / / /___/ / / /___/ / _______/ / Haskell User's System \n");
172 Printf(" /__/ /__/ /_________/ /_________/ /_________/ %s\n\n", HUGS_VERSION);
173 Printf("Copyright (c) The University of Nottingham and Yale University, 1994-1998.\n");
174 Printf("Home page: http://haskell.org/hugs. Bug reports: hugs-bugs@haskell.org.\n");
176 /* There is now a new banner, designed to draw attention to the fact */
177 /* that the version of Hugs being used is substantially different from */
178 /* previous releases (and to correct the mistaken view that Hugs is */
179 /* written in capitals). If you really prefer the old style banner, */
180 /* you can still get it by compiling with -DOLD_LOGO. */
182 printf(" __ __ __ __ ____ ___ __________________________________________\n");
183 printf(" || || || || || || ||__ Hugs 1.4: The Haskell User's Gofer System\n");
184 printf(" ||___|| ||__|| ||__|| __|| (c) The University of Nottingham\n");
185 printf(" ||---|| ___|| and Yale University, 1994-1998.\n");
186 printf(" || || Report bugs to hugs-bugs@haskell.org\n");
187 printf(" || || "HUGS_VERSION" __________________________________________\n\n");
191 Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
194 interpreter(argc,argv);
195 Printf("[Leaving Hugs]\n");
205 /* --------------------------------------------------------------------------
206 * Initialization, interpret command line args and read prelude:
207 * ------------------------------------------------------------------------*/
209 static Void local initialize(argc,argv)/* Interpreter initialization */
215 setLastEdit((String)0,0);
223 hugsEdit = strCopy(fromEnv("EDITOR","c:\\windows\notepad.exe"));
227 hugsEdit = strCopy(fromEnv("EDITOR",NULL));
229 hugsPath = strCopy(HUGSPATH);
230 readOptions("-p\"%s> \" -r$$");
232 readOptions(readRegString("Options",""));
234 readOptions(fromEnv("HUGSFLAGS",""));
236 for (i=1; i<argc; ++i) { /* process command line arguments */
237 if (strcmp(argv[i],"+")==0 && i+1<argc) {
239 ERRMSG(0) "Multiple project filenames on command line"
244 } else if (!processOption(argv[i])) {
245 addScriptName(argv[i],TRUE);
248 /* ToDo: clean up this hack */
250 static char* my_argv[] = {"Hugs"};
251 startupHaskell(sizeof(my_argv)/sizeof(char*),my_argv);
254 DEBUG_LoadSymbols(argv[0]);
257 scriptName[0] = strCopy(findMPathname(NULL,STD_PRELUDE));
258 if (!scriptName[0]) {
259 Printf("Prelude not found on current path: \"%s\"\n",
260 hugsPath ? hugsPath : "");
261 fatal("Unable to load prelude");
265 evalModule = findText(""); /* evaluate wrt last module by default */
269 "\nUsing project file, ignoring additional filenames\n");
271 loadProject(strCopy(proj));
274 scriptBase = numScripts;
277 /* --------------------------------------------------------------------------
278 * Command line options:
279 * ------------------------------------------------------------------------*/
281 struct options { /* command line option toggles */
282 char c; /* table defined in main app. */
286 extern struct options toggle[];
288 static Void local toggleSet(c,state) /* Set command line toggle */
292 for (i=0; toggle[i].c; ++i)
293 if (toggle[i].c == c) {
294 *toggle[i].flag = state;
297 ERRMSG(0) "Unknown toggle `%c'", c
301 static Void local togglesIn(state) /* Print current list of toggles in*/
302 Bool state; { /* given state */
305 for (i=0; toggle[i].c; ++i)
306 if (*toggle[i].flag == state) {
308 Putchar((char)(state ? '+' : '-'));
309 Putchar(toggle[i].c);
316 static Void local optionInfo() { /* Print information about command */
317 static String fmts = "%-5s%s\n"; /* line settings */
318 static String fmtc = "%-5c%s\n";
321 Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
322 for (i=0; toggle[i].c; ++i)
323 Printf(fmtc,toggle[i].c,toggle[i].description);
325 Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
326 Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
327 Printf(fmts,"pstr","Set prompt string to str");
328 Printf(fmts,"rstr","Set repeat last expression string to str");
329 Printf(fmts,"Pstr","Set search path for modules to str");
330 Printf(fmts,"Estr","Use editor setting given by str");
331 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
332 Printf(fmts,"Fstr","Set preprocessor filter to str");
335 Printf("\nCurrent settings: ");
338 Printf("-h%d",heapSize);
342 printString(repeatStr);
343 Printf("\nSearch path : -P");
344 printString(hugsPath);
345 Printf("\nEditor setting : -E");
346 printString(hugsEdit);
347 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
348 Printf("\nPreprocessor : -F");
349 printString(preprocessor);
354 #if USE_REGISTRY || HUGS_FOR_WINDOWS
362 #define PUTInt(optc,i) \
363 sprintf(next,"-%c%d",optc,i); \
366 #define PUTStr(c,s) \
367 next=PUTStr_aux(next,c,s)
369 static String local PUTStr_aux Args((String,Char, String));
371 static String local PUTStr_aux(next,c,s)
377 sprintf(next,"-%c\"",c);
380 PUTS(unlexChar(*t,'"'));
388 static String local optionsToStr() { /* convert options to string */
389 static char buffer[2000];
390 String next = buffer;
393 for (i=0; toggle[i].c; ++i) {
394 PUTC(*toggle[i].flag ? '+' : '-');
398 PUTInt('h',hpSize); PUTC(' ');
400 PUTStr('r',repeatStr);
401 PUTStr('P',hugsPath);
402 PUTStr('E',hugsEdit);
403 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
404 PUTStr('F',preprocessor);
409 #endif /* USE_REGISTRY */
416 static Void local readOptions(options) /* read options from string */
420 stringInput(options);
421 while ((s=readFilename())!=0) {
422 if (*s && !processOption(s)) {
423 ERRMSG(0) "Option string must begin with `+' or `-'"
430 static Bool local processOption(s) /* process string s for options, */
431 String s; { /* return FALSE if none found. */
443 case 'p' : if (s[1]) {
444 if (prompt) free(prompt);
445 prompt = strCopy(s+1);
449 case 'r' : if (s[1]) {
450 if (repeatStr) free(repeatStr);
451 repeatStr = strCopy(s+1);
456 String p = substPath(s+1,hugsPath ? hugsPath : "");
457 if (hugsPath) free(hugsPath);
462 case 'E' : if (hugsEdit) free(hugsEdit);
463 hugsEdit = strCopy(s+1);
466 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
467 case 'F' : if (preprocessor) free(preprocessor);
468 preprocessor = strCopy(s+1);
472 case 'h' : setHeapSize(s+1);
475 case 'd' : /* hack */
477 extern void setRtsFlags( int x );
478 setRtsFlags(argToInt(s+1));
482 default : toggleSet(*s,state);
488 static Void local setHeapSize(s)
491 hpSize = argToInt(s);
492 if (hpSize < MINIMUMHEAP)
493 hpSize = MINIMUMHEAP;
494 else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
495 hpSize = MAXIMUMHEAP;
496 if (heapBuilt() && hpSize != heapSize) {
497 /* ToDo: should this use a message box in winhugs? */
499 FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
501 FPrintf(stderr,"Cannot change heap size\n");
509 static Int local argToInt(s) /* read integer from argument str */
514 if (*s=='\0' || !isascii(*s) || !isdigit(*s)) {
515 ERRMSG(0) "Missing integer in option setting \"%s\"", t
520 Int d = (*s++) - '0';
521 if (n > ((MAXPOSINT - d)/10)) {
522 ERRMSG(0) "Option setting \"%s\" is too large", t
526 } while (isascii(*s) && isdigit(*s));
528 if (*s=='K' || *s=='k') {
529 if (n > (MAXPOSINT/1000)) {
530 ERRMSG(0) "Option setting \"%s\" is too large", t
537 #if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
538 if (*s=='M' || *s=='m') {
539 if (n > (MAXPOSINT/1000000)) {
540 ERRMSG(0) "Option setting \"%s\" is too large", t
548 #if MAXPOSINT > 1000000000
549 if (*s=='G' || *s=='g') {
550 if (n > (MAXPOSINT/1000000000)) {
551 ERRMSG(0) "Option setting \"%s\" is too large", t
560 ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
567 /* --------------------------------------------------------------------------
568 * Print Menu of list of commands:
569 * ------------------------------------------------------------------------*/
571 static struct cmd cmds[] = {
572 {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
573 {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
574 {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
575 {":quit", QUIT}, {":set", SET}, {":find", FIND},
576 {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
577 {":module", SETMODULE},
578 {":version", SHOWVERSION},
583 static Void local menu() {
584 Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
585 Printf("c is the first character in the full name.\n\n");
586 Printf(":load <filenames> load modules from specified files\n");
587 Printf(":load clear all files except prelude\n");
588 Printf(":also <filenames> read additional modules\n");
589 Printf(":reload repeat last load command\n");
590 Printf(":project <filename> use project file\n");
591 Printf(":edit <filename> edit file\n");
592 Printf(":edit edit last module\n");
593 Printf(":module <module> set module for evaluating expressions\n");
594 Printf("<expr> evaluate expression\n");
595 Printf(":type <expr> print type of expression\n");
596 Printf(":version show Hugs version\n");
597 Printf(":? display this list of commands\n");
598 Printf(":set <options> set command line options\n");
599 Printf(":set help on command line options\n");
600 Printf(":names [pat] list names currently in scope\n");
601 Printf(":info <names> describe named objects\n");
602 Printf(":find <name> edit module containing definition of name\n");
603 Printf(":!command shell escape\n");
604 Printf(":cd dir change directory\n");
605 Printf(":gc force garbage collection\n");
606 Printf(":quit exit Hugs interpreter\n");
609 static Void local guidance() {
610 Printf("Command not recognised. ");
614 static Void local forHelp() {
615 Printf("Type :? for help\n");
618 /* --------------------------------------------------------------------------
619 * Setting of command line options:
620 * ------------------------------------------------------------------------*/
622 struct options toggle[] = { /* List of command line toggles */
623 {'t', "Print type after evaluation", &addType},
624 {'g', "Print no. cells recovered after gc", &gcMessages},
625 {'l', "Literate modules as default", &literateScripts},
626 {'e', "Warn about errors in literate modules", &literateErrors},
627 {'.', "Print dots to show progress", &useDots},
628 {'q', "Print nothing to show progress", &quiet},
629 {'w', "Always show which modules are loaded", &listScripts},
630 {'k', "Show kind errors in full", &kindExpert},
631 {'o', "Allow overlapping instances", &allowOverlap},
632 {'i', "Chase imports while loading modules", &chaseImports},
634 {'D', "Debug: show generated code", &debugCode},
639 static Void local set() { /* change command line options from*/
640 String s; /* Hugs command line */
642 if ((s=readFilename())!=0) {
644 if (!processOption(s)) {
645 ERRMSG(0) "Option string must begin with `+' or `-'"
648 } while ((s=readFilename())!=0);
650 writeRegString("Options", optionsToStr());
657 /* --------------------------------------------------------------------------
658 * Change directory command:
659 * ------------------------------------------------------------------------*/
661 static Void local changeDir() { /* change directory */
662 String s = readFilename();
664 ERRMSG(0) "Unable to change to directory \"%s\"", s
669 /* --------------------------------------------------------------------------
670 * Loading project and script files:
671 * ------------------------------------------------------------------------*/
673 static Void local loadProject(s) /* Load project file */
677 projInput(currProject);
678 scriptFile = currProject;
679 forgetScriptsFrom(scriptBase);
680 while ((s=readFilename())!=0)
681 addScriptName(s,TRUE);
683 ERRMSG(0) "Empty project file"
687 projectLoaded = TRUE;
690 static Void local clearProject() { /* clear name for current project */
694 projectLoaded = FALSE;
696 setLastEdit((String)0,0);
700 static Void local addScriptName(s,sch) /* Add script to list of scripts */
701 String s; /* to be read in ... */
702 Bool sch; { /* TRUE => requires pathname search*/
703 if (namesUpto>=NUM_SCRIPTS) {
704 ERRMSG(0) "Too many module files (maximum of %d allowed)",
709 scriptName[namesUpto++] = strCopy(sch ? findPathname(NULL,s) : s);
712 static Bool local addScript(fname,len) /* read single script file */
713 String fname; /* name of script file */
714 Long len; { /* length of script file */
717 #if HUGS_FOR_WINDOWS /* Set clock cursor while loading */
719 SetCursor(LoadCursor(NULL, IDC_WAIT));
722 Printf("Reading file \"%s\":\n",fname);
723 setLastEdit(fname,0);
725 if (isInterfaceFile(fname)) {
726 loadInterface(fname);
728 needsImports = FALSE;
729 parseScript(fname,len); /* process script file */
740 Bool chase(imps) /* Process list of import requests */
743 Int origPos = numScripts; /* keep track of original position */
744 String origName = scriptName[origPos];
745 for (; nonNull(imps); imps=tl(imps)) {
746 String iname = findPathname(origName,textToStr(textOf(hd(imps))));
748 for (; i<namesUpto; i++)
749 if (pathCmp(scriptName[i],iname)==0)
751 if (i>=origPos) { /* Neither loaded or queued */
756 postponed[origPos] = TRUE;
759 if (i>=namesUpto) /* Name not found (i==namesUpto) */
760 addScriptName(iname,FALSE);
761 else if (postponed[i]) {/* Check for recursive dependency */
763 "Recursive import dependency between \"%s\" and \"%s\"",
764 scriptName[origPos], iname
767 /* Right rotate section of tables between numScripts and i so
768 * that i ends up with other imports in front of orig. script
770 theName = scriptName[i];
771 thePost = postponed[i];
772 timeSet(theTime,lastChange[i]);
773 for (; i>numScripts; i--) {
774 scriptName[i] = scriptName[i-1];
775 postponed[i] = postponed[i-1];
776 timeSet(lastChange[i],lastChange[i-1]);
778 scriptName[numScripts] = theName;
779 postponed[numScripts] = thePost;
780 timeSet(lastChange[numScripts],theTime);
789 static Void local forgetScriptsFrom(scno)/* remove scripts from system */
792 for (i=scno; i<namesUpto; ++i)
795 dropScriptsFrom(scno);
797 if (numScripts>namesUpto)
801 /* --------------------------------------------------------------------------
802 * Commands for loading and removing script files:
803 * ------------------------------------------------------------------------*/
805 static Void local load() { /* read filenames from command line */
806 String s; /* and add to list of scripts waiting */
808 while ((s=readFilename())!=0)
809 addScriptName(s,TRUE);
810 readScripts(scriptBase);
813 static Void local project() { /* read list of script names from */
814 String s; /* project file */
816 if ((s=readFilename()) || currProject) {
818 s = strCopy(currProject);
819 else if (readFilename()) {
820 ERRMSG(0) "Too many project files"
827 ERRMSG(0) "No project filename specified"
831 readScripts(scriptBase);
834 static Void local readScripts(n) /* Reread current list of scripts, */
835 Int n; { /* loading everything after and */
836 Time timeStamp; /* including the first script which*/
837 Long fileSize; /* has been either changed or added*/
840 SetCursor(LoadCursor(NULL, IDC_WAIT));
843 for (; n<numScripts; n++) { /* Scan previously loaded scripts */
844 getFileInfo(scriptName[n], &timeStamp, &fileSize);
845 if (timeChanged(timeStamp,lastChange[n])) {
851 for (; n<NUM_SCRIPTS; n++) /* No scripts have been postponed */
852 postponed[n] = FALSE; /* at this stage */
854 while (numScripts<namesUpto) { /* Process any remaining scripts */
855 getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
856 timeSet(lastChange[numScripts],timeStamp);
857 startNewScript(scriptName[numScripts]);
858 if (addScript(scriptName[numScripts],fileSize))
861 dropScriptsFrom(numScripts);
866 if (numScripts<=scriptBase)
867 setLastEdit((String)0, 0);
870 static Void local whatScripts() { /* list scripts in current session */
872 Printf("\nHugs session for:");
874 Printf(" (project: %s)",currProject);
875 for (i=0; i<numScripts; ++i)
876 Printf("\n%s",scriptName[i]);
880 /* --------------------------------------------------------------------------
881 * Access to external editor:
882 * ------------------------------------------------------------------------*/
884 static Void local editor() { /* interpreter-editor interface */
885 String newFile = readFilename();
887 setLastEdit(newFile,0);
888 if (readFilename()) {
889 ERRMSG(0) "Multiple filenames not permitted"
896 static Void local find() { /* edit file containing definition */
897 String nm = readFilename(); /* of specified name */
899 ERRMSG(0) "No name specified"
902 else if (readFilename()) {
903 ERRMSG(0) "Multiple names not permitted"
909 setCurrModule(findEvalModule());
911 if (nonNull(c=findTycon(t=findText(nm)))) {
912 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
913 readScripts(scriptBase);
915 } else if (nonNull(c=findName(t))) {
916 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
917 readScripts(scriptBase);
920 ERRMSG(0) "No current definition for name \"%s\"", nm
926 static Void local runEditor() { /* run editor on script lastEdit */
927 if (startEdit(lastLine,lastEdit)) /* at line lastLine */
928 readScripts(scriptBase);
931 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
936 lastEdit = strCopy(fname);
939 DrawStatusLine(hWndMain); /* Redo status line */
943 /* --------------------------------------------------------------------------
944 * Read and evaluate an expression:
945 * ------------------------------------------------------------------------*/
947 static Void local setModule(){/*set module in which to evaluate expressions*/
948 String s = readFilename();
949 if (!s) s = ""; /* :m clears the current module selection */
950 evalModule = findText(s);
951 setLastEdit(fileOfModule(findEvalModule()),0);
954 static Module local findEvalModule() { /*Module in which to eval expressions*/
955 Module m = findModule(evalModule);
962 static Void local evaluator() { /* evaluate expr and print value */
966 setCurrModule(findEvalModule());
968 startNewScript(0); /* Enables recovery of storage */
969 /* allocated during evaluation */
972 defaultDefns = evalDefaults;
973 type = typeCheckExp(TRUE);
974 if (isPolyType(type)) {
975 ks = polySigOf(type);
976 bd = monotypeOf(type);
981 if (whatIs(bd)==QUAL) {
982 ERRMSG(0) "Unresolved overloading" ETHEN
983 ERRTEXT "\n*** type : " ETHEN ERRTYPE(type);
984 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
989 /* ToDo: restore the code to print types, use show, etc */
994 if (typeMatches(type,ap(typeIO,typeUnit))) {
995 inputExpr = ap(nameRunIO,inputExpr);
999 Cell d = provePred(ks,NIL,ap(classShow,bd));
1001 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1002 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1003 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1007 inputExpr = ap2(namePrint,d,inputExpr);
1008 inputExpr = ap(nameRunIO,inputExpr);
1012 printType(stdout,type);
1018 /* --------------------------------------------------------------------------
1019 * Print type of input expression:
1020 * ------------------------------------------------------------------------*/
1022 static Void local showtype() { /* print type of expression (if any)*/
1025 setCurrModule(findEvalModule());
1026 startNewScript(0); /* Enables recovery of storage */
1027 /* allocated during evaluation */
1030 defaultDefns = evalDefaults;
1031 type = typeCheckExp(FALSE);
1032 printExp(stdout,inputExpr);
1034 printType(stdout,type);
1038 /* --------------------------------------------------------------------------
1039 * Enhanced help system: print current list of scripts or give information
1041 * ------------------------------------------------------------------------*/
1043 static String local objToStr Args((Module, Cell));
1045 static String local objToStr(m,c)
1048 #if DISPLAY_QUANTIFIERS
1049 static char newVar[60];
1050 switch (whatIs(c)) {
1051 case NAME : if (m == name(c).mod) {
1052 sprintf(newVar,"%s", textToStr(name(c).text));
1054 sprintf(newVar,"%s.%s",textToStr(module(name(c).mod).text),
1055 textToStr(name(c).text));
1058 case TYCON : if (m == tycon(c).mod) {
1059 sprintf(newVar,"%s", textToStr(tycon(c).text));
1061 sprintf(newVar,"%s.%s",textToStr(module(tycon(c).mod).text),
1062 textToStr(tycon(c).text));
1065 case CLASS : if (m == cclass(c).mod) {
1066 sprintf(newVar,"%s", textToStr(cclass(c).text));
1068 sprintf(newVar,"%s.%s",textToStr(module(cclass(c).mod).text),
1069 textToStr(cclass(c).text));
1072 default : internal("objToStr");
1076 static char newVar[33];
1077 switch (whatIs(c)) {
1078 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1080 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1082 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1083 default : internal("objToStr");
1089 static Void local info() { /* describe objects */
1090 Int count = 0; /* or give menu of commands */
1093 setCurrModule(findEvalModule());
1094 startNewScript(0); /* for recovery of storage */
1095 for (; (s=readFilename())!=0; count++) {
1096 describe(findText(s));
1103 static Void local describe(t) /* describe an object */
1105 Tycon tc = findTycon(t);
1106 Class cl = findClass(t);
1107 Name nm = findName(t);
1108 Module mod = findEvalModule();
1110 if (nonNull(tc)) { /* as a type constructor */
1114 for (i=0; i<tycon(tc).arity; ++i) {
1115 ty = ap(ty,mkOffset(i));
1117 Printf("-- type constructor");
1119 Printf(" with kind ");
1120 printKind(stdout,tycon(tc).kind);
1123 switch (tycon(tc).what) {
1124 case SYNONYM : Printf("type ");
1125 printType(stdout,ty);
1127 printType(stdout,tycon(tc).defn);
1131 case DATATYPE : { List cs = tycon(tc).defn;
1132 if (tycon(tc).what==DATATYPE) {
1137 printType(stdout,ty);
1139 Printf("\n\n-- constructors:");
1141 for (; hasCfun(cs); cs=tl(cs)) {
1143 printExp(stdout,hd(cs));
1145 printType(stdout,name(hd(cs)).type);
1148 Printf("\n\n-- selectors:");
1150 for (; nonNull(cs); cs=tl(cs)) {
1152 printExp(stdout,hd(cs));
1154 printType(stdout,name(hd(cs)).type);
1159 case RESTRICTSYN : Printf("type ");
1160 printType(stdout,ty);
1161 Printf(" = <restricted>");
1165 if (nonNull(in=findFirstInst(tc))) {
1166 Printf("\n-- instances:\n");
1169 in = findNextInst(tc,in);
1170 } while (nonNull(in));
1175 if (nonNull(cl)) { /* as a class */
1176 List ins = cclass(cl).instances;
1177 Kinds ks = cclass(cl).kinds;
1178 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
1179 printf("-- type class");
1181 printf("-- constructor class");
1183 printf(" with arity ");
1184 printKinds(stdout,ks);
1188 if (nonNull(cclass(cl).supers)) {
1189 printContext(stdout,cclass(cl).supers);
1192 printPred(stdout,cclass(cl).head);
1193 if (nonNull(cclass(cl).members)) {
1194 List ms = cclass(cl).members;
1197 Type t = monotypeOf(name(hd(ms)).type);
1199 printExp(stdout,hd(ms));
1201 if (isNull(tl(fst(snd(t))))) {
1204 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
1206 printType(stdout,t);
1208 } while (nonNull(ms));
1212 printf("\n-- instances:\n");
1216 } while (nonNull(ins));
1221 if (nonNull(nm)) { /* as a function/name */
1222 printExp(stdout,nm);
1224 if (nonNull(name(nm).type)) {
1225 printType(stdout,name(nm).type);
1227 printf("<unknown type>");
1231 printf(" -- data constructor");
1232 } else if (isMfun(nm)) {
1233 printf(" -- class member");
1234 } else if (isSfun(nm)) {
1235 printf(" -- selector function");
1237 if (name(nm).primop) {
1238 printf(" -- primitive");
1243 if (isNull(tc) && isNull(cl) && isNull(nm)) {
1244 Printf("Unknown reference `%s'\n",textToStr(t));
1248 static Void local showInst(in) /* Display instance decl header */
1250 printf("instance ");
1251 if (nonNull(inst(in).specifics)) {
1252 printContext(stdout,inst(in).specifics);
1255 printPred(stdout,inst(in).head);
1259 /* --------------------------------------------------------------------------
1260 * List all names currently in scope:
1261 * ------------------------------------------------------------------------*/
1263 static Void local listNames() { /* list names matching optional pat*/
1264 String pat = readFilename();
1266 Int width = getTerminalWidth() - 1;
1269 Module mod = findEvalModule();
1271 if (pat) { /* First gather names to list */
1273 names = addNamesMatching(pat,names);
1274 } while ((pat=readFilename())!=0);
1276 names = addNamesMatching((String)0,names);
1278 if (isNull(names)) { /* Then print them out */
1279 ERRMSG(0) "No names selected"
1282 for (termPos=0; nonNull(names); names=tl(names)) {
1283 String s = objToStr(mod,hd(names));
1285 if (termPos+1+l>width) {
1288 } else if (termPos>0) {
1296 Printf("\n(%d names listed)\n", count);
1299 /* --------------------------------------------------------------------------
1300 * print a prompt and read a line of input:
1301 * ------------------------------------------------------------------------*/
1303 static Void local promptForInput(moduleName)
1304 String moduleName; {
1305 char promptBuffer[1000];
1307 /* This is portable but could overflow buffer */
1308 sprintf(promptBuffer,prompt,moduleName);
1310 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
1311 * promptBuffer instead.
1313 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
1314 /* Reset prompt to a safe default to avoid an infinite loop */
1316 prompt = strCopy("? ");
1317 internal("Combined prompt and evaluation module name too long");
1320 consoleInput(promptBuffer);
1323 /* --------------------------------------------------------------------------
1324 * main read-eval-print loop, with error trapping:
1325 * ------------------------------------------------------------------------*/
1327 static jmp_buf catch_error; /* jump buffer for error trapping */
1329 static Void local interpreter(argc,argv)/* main interpreter loop */
1332 Int errorNumber = setjmp(catch_error);
1334 breakOn(TRUE); /* enable break trapping */
1335 if (numScripts==0) { /* only succeeds on first time, */
1336 if (errorNumber) /* before prelude has been loaded */
1337 fatal("Unable to load prelude");
1338 initialize(argc,argv);
1344 everybody(RESET); /* reset to sensible initial state */
1345 dropScriptsFrom(numScripts); /* remove partially loaded scripts */
1347 promptForInput(textToStr(module(findEvalModule()).text));
1349 cmd = readCommand(cmds, (Char)':', (Char)'!');
1354 case EDIT : editor();
1358 case LOAD : clearProject();
1359 forgetScriptsFrom(scriptBase);
1362 case ALSO : clearProject();
1363 forgetScriptsFrom(numScripts);
1366 case RELOAD : readScripts(scriptBase);
1368 case PROJECT: project();
1374 Printf("Hugs 1.4, %s release.\n", HUGS_VERSION);
1376 case EVAL : evaluator();
1378 case TYPEOF : showtype();
1380 case NAMES : listNames();
1384 case BADCMD : guidance();
1388 case SYSTEM : if (shellEsc(readLine()))
1389 Printf("Warning: Shell escape terminated abnormally\n");
1391 case CHGDIR : changeDir();
1396 case COLLECT: consGC = FALSE;
1399 Printf("Garbage collection recovered %d cells\n",
1406 Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
1407 millisecs(userElapsed), millisecs(systElapsed));
1412 /* --------------------------------------------------------------------------
1413 * Display progress towards goal:
1414 * ------------------------------------------------------------------------*/
1416 static Target currTarget;
1417 static Bool aiming = FALSE;
1420 static Int charCount;
1422 Void setGoal(what, t) /* Set goal for what to be t */
1426 currTarget = (t?t:1);
1429 currPos = strlen(what);
1430 maxPos = getTerminalWidth() - 1;
1434 for (charCount=0; *what; charCount++)
1439 Void soFar(t) /* Indicate progress towards goal */
1440 Target t; { /* has now reached t */
1443 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
1448 if (newPos>currPos) {
1451 while (newPos>++currPos);
1458 Void done() { /* Goal has now been achieved */
1461 while (maxPos>currPos++)
1466 for (; charCount>0; charCount--) {
1475 static Void local failed() { /* Goal cannot be reached due to */
1476 if (aiming) { /* errors */
1483 /* --------------------------------------------------------------------------
1485 * ------------------------------------------------------------------------*/
1487 Void errHead(l) /* print start of error message */
1489 failed(); /* failed to reach target ... */
1490 FPrintf(errorStream,"ERROR");
1493 FPrintf(errorStream," \"%s\"", scriptFile);
1494 setLastEdit(scriptFile,l);
1495 if (l) FPrintf(errorStream," (line %d)",l);
1498 FPrintf(errorStream,": ");
1499 FFlush(errorStream);
1502 Void errFail() { /* terminate error message and */
1503 Putc('\n',errorStream); /* produce exception to return to */
1504 FFlush(errorStream); /* main command loop */
1505 longjmp(catch_error,1);
1508 Void errAbort() { /* altern. form of error handling */
1509 failed(); /* used when suitable error message*/
1510 errFail(); /* has already been printed */
1513 Void internal(msg) /* handle internal error */
1515 #if HUGS_FOR_WINDOWS
1517 wsprintf(buf,"INTERNAL ERROR: %s",msg);
1518 MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
1521 Printf("INTERNAL ERROR: %s\n",msg);
1523 longjmp(catch_error,1);
1526 Void fatal(msg) /* handle fatal error */
1528 #if HUGS_FOR_WINDOWS
1530 wsprintf(buf,"FATAL ERROR: %s",msg);
1531 MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
1534 Printf("\nFATAL ERROR: %s\n",msg);
1539 sigHandler(breakHandler) { /* respond to break interrupt */
1540 #if HUGS_FOR_WINDOWS
1541 MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
1544 Printf("{Interrupted!}\n");
1551 longjmp(catch_error,1);
1552 sigResume;/*NOTREACHED*/
1555 /* --------------------------------------------------------------------------
1556 * Read value from environment variable or registry:
1557 * ------------------------------------------------------------------------*/
1559 String fromEnv(var,def) /* return value of: */
1560 String var; /* environment variable named by var */
1561 String def; { /* or: default value given by def */
1562 String s = getenv(var);
1563 return (s ? s : def);
1566 /* --------------------------------------------------------------------------
1567 * String manipulation routines:
1568 * ------------------------------------------------------------------------*/
1570 static String local strCopy(s) /* make malloced copy of a string */
1574 if ((t=(char *)malloc(strlen(s)+1))==0) {
1575 ERRMSG(0) "String storage space exhausted"
1578 for (r=t; (*r++ = *s++)!=0; ) {
1585 /* --------------------------------------------------------------------------
1587 * We can redirect compiler output (prompts, error messages, etc) by
1588 * tweaking these functions.
1589 * ------------------------------------------------------------------------*/
1591 #if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
1593 #ifdef HAVE_STDARG_H
1596 #include <varargs.h>
1599 /* ----------------------------------------------------------------------- */
1601 #define BufferSize 5000 /* size of redirected output buffer */
1603 typedef struct _HugsStream {
1604 char buffer[BufferSize]; /* buffer for redirected output */
1605 Int next; /* next space in buffer */
1608 static Void local vBufferedPrintf Args((HugsStream*, const char*, va_list));
1609 static Void local bufferedPutchar Args((HugsStream*, Char));
1610 static String local bufferClear Args((HugsStream *stream));
1612 static Void local vBufferedPrintf(stream, fmt, ap)
1616 Int spaceLeft = BufferSize - stream->next;
1617 char* p = &stream->buffer[stream->next];
1618 Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
1619 if (0 <= charsAdded && charsAdded < spaceLeft)
1620 stream->next += charsAdded;
1621 #if 1 /* we can either buffer the first n chars or buffer the last n chars */
1627 static Void local bufferedPutchar(stream, c)
1630 if (BufferSize - stream->next >= 2) {
1631 stream->buffer[stream->next++] = c;
1632 stream->buffer[stream->next] = '\0';
1636 static String local bufferClear(stream)
1637 HugsStream *stream; {
1638 if (stream->next == 0) {
1642 return stream->buffer;
1646 /* ----------------------------------------------------------------------- */
1648 static HugsStream outputStream;
1650 * We rely on standard C semantics to initialise outputStream.next to 0.
1653 Void hugsEnableOutput(f)
1658 String hugsClearOutputBuffer() {
1659 return bufferClear(&outputStream);
1662 #ifdef HAVE_STDARG_H
1663 Void hugsPrintf(const char *fmt, ...) {
1664 va_list ap; /* pointer into argument list */
1665 va_start(ap, fmt); /* make ap point to first arg after fmt */
1666 if (!disableOutput) {
1669 vBufferedPrintf(&outputStream, fmt, ap);
1671 va_end(ap); /* clean up */
1674 Void hugsPrintf(fmt, va_alist)
1677 va_list ap; /* pointer into argument list */
1678 va_start(ap); /* make ap point to first arg after fmt */
1679 if (!disableOutput) {
1682 vBufferedPrintf(&outputStream, fmt, ap);
1684 va_end(ap); /* clean up */
1690 if (!disableOutput) {
1693 bufferedPutchar(&outputStream, c);
1697 Void hugsFlushStdout() {
1698 if (!disableOutput) {
1705 if (!disableOutput) {
1710 #ifdef HAVE_STDARG_H
1711 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
1714 if (!disableOutput) {
1715 vfprintf(fp, fmt, ap);
1717 vBufferedPrintf(&outputStream, fmt, ap);
1722 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
1728 if (!disableOutput) {
1729 vfprintf(fp, fmt, ap);
1731 vBufferedPrintf(&outputStream, fmt, ap);
1737 Void hugsPutc(c, fp)
1740 if (!disableOutput) {
1743 bufferedPutchar(&outputStream, c);
1747 #endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
1749 /* --------------------------------------------------------------------------
1750 * Hugs for Windows code (WinMain and related functions)
1751 * ------------------------------------------------------------------------*/
1753 #if HUGS_FOR_WINDOWS
1754 #include "winhugs.c"
1757 /*-------------------------------------------------------------------------*/