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: 1999/10/15 21:40:49 $
14 * ------------------------------------------------------------------------*/
34 Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
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 Bool local startEdit Args((Int,String));
55 static Void local runEditor Args((Void));
56 static Void local setModule Args((Void));
57 static Module local findEvalModule Args((Void));
58 static Void local evaluator Args((Void));
59 static Void local stopAnyPrinting Args((Void));
60 static Void local showtype Args((Void));
61 static String local objToStr Args((Module, Cell));
62 static Void local info Args((Void));
63 static Void local printSyntax Args((Name));
64 static Void local showInst Args((Inst));
65 static Void local describe Args((Text));
66 static Void local listNames Args((Void));
68 static Void local toggleSet Args((Char,Bool));
69 static Void local togglesIn Args((Bool));
70 static Void local optionInfo Args((Void));
71 #if USE_REGISTRY || HUGS_FOR_WINDOWS
72 static String local optionsToStr Args((Void));
74 static Void local readOptions Args((String));
75 static Bool local processOption Args((String));
76 static Void local setHeapSize Args((String));
77 static Int local argToInt Args((String));
79 static Void local loadProject Args((String));
80 static Void local clearProject Args((Void));
81 static Bool local addScript Args((Int));
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));
88 /* --------------------------------------------------------------------------
89 * Machine dependent code for Hugs interpreter:
90 * ------------------------------------------------------------------------*/
97 /* --------------------------------------------------------------------------
99 * ------------------------------------------------------------------------*/
101 static Bool printing = FALSE; /* TRUE => currently printing value*/
102 static Bool showStats = FALSE; /* TRUE => print stats after eval */
103 static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
104 static Bool addType = FALSE; /* TRUE => print type with value */
105 static Bool useDots = RISCOS; /* TRUE => use dots in progress */
106 static Bool quiet = FALSE; /* TRUE => don't show progress */
107 static Bool lastWasObject = FALSE;
108 Bool preludeLoaded = FALSE;
109 Bool optimise = FALSE;
113 String modName; /* Module name */
114 Bool details; /* FALSE => remaining fields are invalid */
115 String path; /* Path to module */
116 String srcExt; /* ".hs" or ".lhs" if fromSource */
117 Time lastChange; /* Time of last change to script */
118 Bool fromSource; /* FALSE => load object code */
119 Bool postponed; /* Indicates postponed load */
126 static Void local makeStackEntry Args((ScriptInfo*,String));
127 static Void local addStackEntry Args((String));
129 static ScriptInfo scriptInfo[NUM_SCRIPTS];
131 static Int numScripts; /* Number of scripts loaded */
132 static Int nextNumScripts;
133 static Int namesUpto; /* Number of script names set */
134 static Bool needsImports; /* set to TRUE if imports required */
135 String scriptFile; /* Name of current script (if any) */
139 static Text evalModule = 0; /* Name of module we eval exprs in */
140 static String currProject = 0; /* Name of current project file */
141 static Bool projectLoaded = FALSE; /* TRUE => project file loaded */
143 static Bool autoMain = FALSE;
144 static String lastEdit = 0; /* Name of script to edit (if any) */
145 static Int lastEdLine = 0; /* Editor line number (if possible)*/
146 static String prompt = 0; /* Prompt string */
147 static Int hpSize = DEFAULTHEAP; /* Desired heap size */
148 String hugsEdit = 0; /* String for editor command */
149 String hugsPath = 0; /* String for file search path */
152 static Bool disableOutput = FALSE; /* redirect output to buffer? */
155 String bool2str ( Bool b )
157 if (b) return "Yes"; else return "No ";
160 void ppSmStack ( String who )
164 fflush(stdout);fflush(stderr);
166 printf ( "ppSmStack %s: numScripts = %d namesUpto = %d needsImports = %s\n",
167 who, numScripts, namesUpto, bool2str(needsImports) );
168 assert (namesUpto >= numScripts);
169 printf ( " Det FrS Pst ObL Module Ext Size ModTime Path\n" );
170 for (i = namesUpto-1; i >= 0; i--) {
171 printf ( "%c%2d: %3s %3s %3s %3s %16s %-4s %5ld %8lx %s\n",
172 (i==numScripts ? '*' : ' '),
173 i, bool2str(scriptInfo[i].details),
174 bool2str(scriptInfo[i].fromSource),
175 bool2str(scriptInfo[i].postponed),
176 bool2str(scriptInfo[i].objLoaded),
177 scriptInfo[i].modName,
178 scriptInfo[i].fromSource ? scriptInfo[i].srcExt : "",
180 scriptInfo[i].lastChange,
185 fflush(stdout);fflush(stderr);
191 /* --------------------------------------------------------------------------
193 * ------------------------------------------------------------------------*/
195 #ifndef NO_MAIN /* we omit main when building the "Hugs server" */
197 Main main Args((Int, String [])); /* now every func has a prototype */
202 #ifdef HAVE_CONSOLE_H /* Macintosh port */
204 _fcreator = 'R*ch'; /* // 'KAHL'; //'*TEX'; //'ttxt'; */
206 console_options.top = 50;
207 console_options.left = 20;
209 console_options.nrows = 32;
210 console_options.ncols = 80;
212 console_options.pause_atexit = 1;
213 console_options.title = "\pHugs";
215 console_options.procID = 5;
216 argc = ccommand(&argv);
219 CStackBase = &argc; /* Save stack base for use in gc */
221 /* Try and figure out an absolute path to the executable, so
222 we can make a reasonable guess about where the default
223 libraries (Prelude etc) are.
225 setDefaultLibDir ( argv[0] );
227 /* If first arg is +Q or -Q, be entirely silent, and automatically run
228 main after loading scripts. Useful for running the nofib suite. */
229 if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
234 Printf("__ __ __ __ ____ ___ _______________________________________________\n");
235 Printf("|| || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system\n");
236 Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999\n");
237 Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
238 Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
239 Printf("|| || Version: %s _______________________________________________\n\n",HUGS_VERSION);
242 Printf(" Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
245 interpreter(argc,argv);
246 Printf("[Leaving Hugs]\n");
257 /* --------------------------------------------------------------------------
258 * Initialization, interpret command line args and read prelude:
259 * ------------------------------------------------------------------------*/
261 static Void local initialize(argc,argv)/* Interpreter initialization */
266 char argv_0_orig[1000];
268 setLastEdit((String)0,0);
275 hugsEdit = strCopy(fromEnv("EDITOR","c:\\windows\notepad.exe"));
279 hugsEdit = strCopy(fromEnv("EDITOR",NULL));
281 hugsPath = strCopy(HUGSPATH); readOptions("-p\"%s> \" -r$$");
283 projectPath = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
284 "HUGSPATH", PATHSEP, ""));
285 readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
286 readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
287 #endif /* USE_REGISTRY */
288 readOptions(fromEnv("STGHUGSFLAGS",""));
290 strncpy(argv_0_orig,argv[0],1000); /* startupHaskell mangles argv[0] */
291 startupHaskell (argc,argv);
292 argc = prog_argc; argv = prog_argv;
294 namesUpto = numScripts = 0;
295 addStackEntry("Prelude");
297 for (i=1; i<argc; ++i) { /* process command line arguments */
298 if (strcmp(argv[i], "--")==0) break;
299 if (strcmp(argv[i],"+")==0 && i+1<argc) {
301 ERRMSG(0) "Multiple project filenames on command line"
306 } else if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
307 && !processOption(argv[i])) {
308 addStackEntry(argv[i]);
313 DEBUG_LoadSymbols(argv_0_orig);
319 if (!scriptName[0]) {
320 Printf("Prelude not found on current path: \"%s\"\n",
321 hugsPath ? hugsPath : "");
322 fatal("Unable to load prelude");
327 Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n\n");
329 Printf("Hugs mode: Restart with command line option +98 for Haskell 98 mode\n\n");
333 evalModule = findText(""); /* evaluate wrt last module by default */
337 "\nUsing project file, ignoring additional filenames\n");
339 loadProject(strCopy(proj));
344 /* --------------------------------------------------------------------------
345 * Command line options:
346 * ------------------------------------------------------------------------*/
348 struct options { /* command line option toggles */
349 char c; /* table defined in main app. */
353 extern struct options toggle[];
355 static Void local toggleSet(c,state) /* Set command line toggle */
359 for (i=0; toggle[i].c; ++i)
360 if (toggle[i].c == c) {
361 *toggle[i].flag = state;
364 ERRMSG(0) "Unknown toggle `%c'", c
368 static Void local togglesIn(state) /* Print current list of toggles in*/
369 Bool state; { /* given state */
372 for (i=0; toggle[i].c; ++i)
373 if (*toggle[i].flag == state) {
375 Putchar((char)(state ? '+' : '-'));
376 Putchar(toggle[i].c);
383 static Void local optionInfo() { /* Print information about command */
384 static String fmts = "%-5s%s\n"; /* line settings */
385 static String fmtc = "%-5c%s\n";
388 Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
389 for (i=0; toggle[i].c; ++i)
390 Printf(fmtc,toggle[i].c,toggle[i].description);
392 Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
393 Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
394 Printf(fmts,"pstr","Set prompt string to str");
395 Printf(fmts,"rstr","Set repeat last expression string to str");
396 Printf(fmts,"Pstr","Set search path for modules to str");
397 Printf(fmts,"Estr","Use editor setting given by str");
398 Printf(fmts,"cnum","Set constraint cutoff limit");
399 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
400 Printf(fmts,"Fstr","Set preprocessor filter to str");
403 Printf("\nCurrent settings: ");
406 Printf("-h%d",heapSize);
410 printString(repeatStr);
411 Printf(" -c%d",cutoff);
412 Printf("\nSearch path : -P");
413 printString(hugsPath);
416 if (projectPath!=NULL) {
417 Printf("\nProject Path : %s",projectPath);
420 Printf("\nEditor setting : -E");
421 printString(hugsEdit);
422 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
423 Printf("\nPreprocessor : -F");
424 printString(preprocessor);
426 Printf("\nCompatibility : %s", haskell98 ? "Haskell 98"
427 : "Hugs Extensions");
431 #if USE_REGISTRY || HUGS_FOR_WINDOWS
439 #define PUTInt(optc,i) \
440 sprintf(next,"-%c%d",optc,i); \
443 #define PUTStr(c,s) \
444 next=PUTStr_aux(next,c,s)
446 static String local PUTStr_aux Args((String,Char, String));
448 static String local PUTStr_aux(next,c,s)
454 sprintf(next,"-%c\"",c);
457 PUTS(unlexChar(*t,'"'));
465 static String local optionsToStr() { /* convert options to string */
466 static char buffer[2000];
467 String next = buffer;
470 for (i=0; toggle[i].c; ++i) {
471 PUTC(*toggle[i].flag ? '+' : '-');
475 PUTInt('h',hpSize); PUTC(' ');
477 PUTStr('r',repeatStr);
478 PUTStr('P',hugsPath);
479 PUTStr('E',hugsEdit);
480 PUTInt('c',cutoff); PUTC(' ');
481 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
482 PUTStr('F',preprocessor);
487 #endif /* USE_REGISTRY */
494 static Void local readOptions(options) /* read options from string */
498 stringInput(options);
499 while ((s=readFilename())!=0) {
500 if (*s && !processOption(s)) {
501 ERRMSG(0) "Option string must begin with `+' or `-'"
508 static Bool local processOption(s) /* process string s for options, */
509 String s; { /* return FALSE if none found. */
521 case 'Q' : break; /* already handled */
523 case 'p' : if (s[1]) {
524 if (prompt) free(prompt);
525 prompt = strCopy(s+1);
529 case 'r' : if (s[1]) {
530 if (repeatStr) free(repeatStr);
531 repeatStr = strCopy(s+1);
536 String p = substPath(s+1,hugsPath ? hugsPath : "");
537 if (hugsPath) free(hugsPath);
542 case 'E' : if (hugsEdit) free(hugsEdit);
543 hugsEdit = strCopy(s+1);
546 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
547 case 'F' : if (preprocessor) free(preprocessor);
548 preprocessor = strCopy(s+1);
552 case 'h' : setHeapSize(s+1);
555 case 'D' : /* hack */
557 extern void setRtsFlags( int x );
558 setRtsFlags(argToInt(s+1));
562 default : if (strcmp("98",s)==0) {
563 if (heapBuilt() && ((state && !haskell98) ||
564 (!state && haskell98))) {
565 FPrintf(stderr,"Haskell 98 compatibility cannot be changed while the interpreter is running\n");
578 static Void local setHeapSize(s)
581 hpSize = argToInt(s);
582 if (hpSize < MINIMUMHEAP)
583 hpSize = MINIMUMHEAP;
584 else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
585 hpSize = MAXIMUMHEAP;
586 if (heapBuilt() && hpSize != heapSize) {
587 /* ToDo: should this use a message box in winhugs? */
589 FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
591 FPrintf(stderr,"Cannot change heap size\n");
599 static Int local argToInt(s) /* read integer from argument str */
604 if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
605 ERRMSG(0) "Missing integer in option setting \"%s\"", t
610 Int d = (*s++) - '0';
611 if (n > ((MAXPOSINT - d)/10)) {
612 ERRMSG(0) "Option setting \"%s\" is too large", t
616 } while (isascii((int)(*s)) && isdigit((int)(*s)));
618 if (*s=='K' || *s=='k') {
619 if (n > (MAXPOSINT/1000)) {
620 ERRMSG(0) "Option setting \"%s\" is too large", t
627 #if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
628 if (*s=='M' || *s=='m') {
629 if (n > (MAXPOSINT/1000000)) {
630 ERRMSG(0) "Option setting \"%s\" is too large", t
638 #if MAXPOSINT > 1000000000
639 if (*s=='G' || *s=='g') {
640 if (n > (MAXPOSINT/1000000000)) {
641 ERRMSG(0) "Option setting \"%s\" is too large", t
650 ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
657 /* --------------------------------------------------------------------------
658 * Print Menu of list of commands:
659 * ------------------------------------------------------------------------*/
661 static struct cmd cmds[] = {
662 {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
663 {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
664 {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
665 {":quit", QUIT}, {":set", SET}, {":find", FIND},
666 {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
667 {":dump", DUMP}, {":ztats", STATS},
668 {":module",SETMODULE},
673 static Void local menu() {
674 Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
675 Printf("c is the first character in the full name.\n\n");
676 Printf(":load <filenames> load modules from specified files\n");
677 Printf(":load clear all files except prelude\n");
678 Printf(":also <filenames> read additional modules\n");
679 Printf(":reload repeat last load command\n");
680 Printf(":project <filename> use project file\n");
681 Printf(":edit <filename> edit file\n");
682 Printf(":edit edit last module\n");
683 Printf(":module <module> set module for evaluating expressions\n");
684 Printf("<expr> evaluate expression\n");
685 Printf(":type <expr> print type of expression\n");
686 Printf(":? display this list of commands\n");
687 Printf(":set <options> set command line options\n");
688 Printf(":set help on command line options\n");
689 Printf(":names [pat] list names currently in scope\n");
690 Printf(":info <names> describe named objects\n");
691 Printf(":find <name> edit module containing definition of name\n");
692 Printf(":!command shell escape\n");
693 Printf(":cd dir change directory\n");
694 Printf(":gc force garbage collection\n");
695 Printf(":dump <name> print STG code for named fn\n");
696 #ifdef CRUDE_PROFILING
697 Printf(":ztats <name> print reduction stats\n");
699 Printf(":quit exit Hugs interpreter\n");
702 static Void local guidance() {
703 Printf("Command not recognised. ");
707 static Void local forHelp() {
708 Printf("Type :? for help\n");
711 /* --------------------------------------------------------------------------
712 * Setting of command line options:
713 * ------------------------------------------------------------------------*/
715 struct options toggle[] = { /* List of command line toggles */
716 {'s', "Print no. reductions/cells after eval", &showStats},
717 {'t', "Print type after evaluation", &addType},
718 /*ToDo?? {'f', "Terminate evaluation on first error", &failOnError},*/
719 {'g', "Print no. cells recovered after gc", &gcMessages},
720 {'l', "Literate modules as default", &literateScripts},
721 {'e', "Warn about errors in literate modules", &literateErrors},
722 {'.', "Print dots to show progress", &useDots},
723 {'q', "Print nothing to show progress", &quiet},
724 {'w', "Always show which modules are loaded", &listScripts},
725 {'k', "Show kind errors in full", &kindExpert},
726 {'o', "Allow overlapping instances", &allowOverlap},
727 {'O', "Optimise (improve?) generated code", &optimise},
729 {'D', "Debug: show generated code", &debugCode},
734 static Void local set() { /* change command line options from*/
735 String s; /* Hugs command line */
737 if ((s=readFilename())!=0) {
739 if (!processOption(s)) {
740 ERRMSG(0) "Option string must begin with `+' or `-'"
743 } while ((s=readFilename())!=0);
745 writeRegString("Options", optionsToStr());
752 /* --------------------------------------------------------------------------
753 * Change directory command:
754 * ------------------------------------------------------------------------*/
756 static Void local changeDir() { /* change directory */
757 String s = readFilename();
759 ERRMSG(0) "Unable to change to directory \"%s\"", s
764 /* --------------------------------------------------------------------------
765 * Loading project and script files:
766 * ------------------------------------------------------------------------*/
768 static Void local loadProject(s) /* Load project file */
772 projInput(currProject);
773 scriptFile = currProject;
774 forgetScriptsFrom(1);
775 while ((s=readFilename())!=0)
778 ERRMSG(0) "Empty project file"
782 projectLoaded = TRUE;
785 static Void local clearProject() { /* clear name for current project */
789 projectLoaded = FALSE;
791 setLastEdit((String)0,0);
797 static Void local makeStackEntry ( ScriptInfo* ent, String iname )
800 Bool sAvail, iAvail, oAvail;
801 Time sTime, iTime, oTime;
802 Long sSize, iSize, oSize;
805 ok = findFilesForModule (
809 &sAvail, &sTime, &sSize,
810 &iAvail, &iTime, &iSize,
811 &oAvail, &oTime, &oSize
815 /* "Can't file source or object+interface for module \"%s\"", */
816 "Can't file source for module \"%s\"",
820 /* findFilesForModule should enforce this */
821 if (!(sAvail || (oAvail && iAvail)))
823 /* Load objects in preference to sources if both are available */
824 /* 11 Oct 99: disable object loading in the interim.
825 Will probably only reinstate when HEP becomes available.
827 ? (oAvail && iAvail && timeEarlier(sTime,oTime))
832 /* ToDo: namesUpto overflow */
833 ent->modName = strCopy(iname);
836 ent->fromSource = !fromObj;
838 ent->postponed = FALSE;
839 ent->lastChange = sTime; /* ToDo: is this right? */
840 ent->size = fromObj ? iSize : sSize;
841 ent->oSize = fromObj ? oSize : 0;
842 ent->objLoaded = FALSE;
847 static Void nukeEnding( String s )
850 if (l > 2 && strncmp(s+l-2,".o" ,3)==0) s[l-2] = 0; else
851 if (l > 3 && strncmp(s+l-3,".hi" ,3)==0) s[l-3] = 0; else
852 if (l > 3 && strncmp(s+l-3,".hs" ,3)==0) s[l-3] = 0; else
853 if (l > 4 && strncmp(s+l-4,".lhs",4)==0) s[l-4] = 0; else
854 if (l > 4 && strncmp(s+l-4,".dll",4)==0) s[l-4] = 0; else
855 if (l > 4 && strncmp(s+l-4,".DLL",4)==0) s[l-4] = 0;
858 static Void local addStackEntry(s) /* Add script to list of scripts */
859 String s; { /* to be read in ... */
864 if (namesUpto>=NUM_SCRIPTS) {
865 ERRMSG(0) "Too many module files (maximum of %d allowed)",
872 for (s2 = s; *s2; s2++)
873 if (*s2 == SLASH && *(s2+1)) s = s2+1;
876 for (i = 0; i < namesUpto; i++)
877 if (strcmp(scriptInfo[i].modName,s)==0)
881 makeStackEntry ( &scriptInfo[namesUpto], strCopy(s) );
887 /* Return TRUE if no imports were needed; FALSE otherwise. */
888 static Bool local addScript(stacknum) /* read single file */
890 static char name[FILENAME_MAX+1];
891 Int len = scriptInfo[stacknum].size;
893 #if HUGS_FOR_WINDOWS /* Set clock cursor while loading */
895 SetCursor(LoadCursor(NULL, IDC_WAIT));
898 // setLastEdit(name,0);
901 strcpy(name, scriptInfo[stacknum].path);
902 strcat(name, scriptInfo[stacknum].modName);
903 if (scriptInfo[stacknum].fromSource)
904 strcat(name, scriptInfo[stacknum].srcExt); else
909 if (scriptInfo[stacknum].fromSource) {
910 if (lastWasObject) finishInterfaces();
911 lastWasObject = FALSE;
912 Printf("Reading script \"%s\":\n",name);
913 needsImports = FALSE;
914 parseScript(name,len);
915 if (needsImports) return FALSE;
920 Printf("Reading iface \"%s\":\n", name);
922 needsImports = FALSE;
924 // set nameObj for the benefit of openGHCIface
925 strcpy(nameObj, scriptInfo[stacknum].path);
926 strcat(nameObj, scriptInfo[stacknum].modName);
927 strcat(nameObj, DLL_ENDING);
928 sizeObj = scriptInfo[stacknum].oSize;
930 loadInterface(name,len);
932 lastWasObject = TRUE;
933 if (needsImports) return FALSE;
937 preludeLoaded = TRUE;
942 Bool chase(imps) /* Process list of import requests */
946 Int origPos = numScripts; /* keep track of original position */
947 String origName = scriptInfo[origPos].modName;
948 for (; nonNull(imps); imps=tl(imps)) {
949 String iname = textToStr(textOf(hd(imps)));
951 for (; i<namesUpto; i++)
952 if (strcmp(scriptInfo[i].modName,iname)==0)
954 //fprintf(stderr, "import name = %s num = %d\n", iname, i );
957 /* We should have filled in the details of each module
958 the first time we hear about it.
960 assert(scriptInfo[i].details);
963 if (i>=origPos) { /* Neither loaded or queued */
970 if (scriptInfo[origPos].fromSource)
971 scriptInfo[origPos].postponed = TRUE;
973 if (i==namesUpto) { /* Name not found (i==namesUpto) */
974 /* Find out where it lives, whether source or object, etc */
975 makeStackEntry ( &scriptInfo[i], iname );
979 if (scriptInfo[i].postponed && scriptInfo[i].fromSource) {
980 /* Check for recursive dependency */
982 "Recursive import dependency between \"%s\" and \"%s\"",
983 scriptInfo[origPos].modName, iname
986 /* Move stack entry i to somewhere below origPos. If i denotes
987 * an object, destination is immediately below origPos.
988 * Otherwise, it's underneath the queue of objects below origPos.
991 if (scriptInfo[i].fromSource)
992 while (!scriptInfo[dstPosn].fromSource && dstPosn > 0)
997 for (; i > dstPosn; i--) scriptInfo[i] = scriptInfo[i-1];
998 scriptInfo[dstPosn] = tmp;
999 if (dstPosn < nextNumScripts) nextNumScripts = dstPosn;
1003 return needsImports;
1006 static Void local forgetScriptsFrom(scno)/* remove scripts from system */
1010 for (i=scno; i<namesUpto; ++i)
1012 free(scriptName[i]);
1014 dropScriptsFrom(scno-1);
1016 if (numScripts>namesUpto)
1020 /* --------------------------------------------------------------------------
1021 * Commands for loading and removing script files:
1022 * ------------------------------------------------------------------------*/
1024 static Void local load() { /* read filenames from command line */
1025 String s; /* and add to list of scripts waiting */
1027 while ((s=readFilename())!=0)
1032 static Void local project() { /* read list of script names from */
1033 String s; /* project file */
1035 if ((s=readFilename()) || currProject) {
1037 s = strCopy(currProject);
1038 else if (readFilename()) {
1039 ERRMSG(0) "Too many project files"
1046 ERRMSG(0) "No project filename specified"
1053 static Void local readScripts(n) /* Reread current list of scripts, */
1054 Int n; { /* loading everything after and */
1055 Time timeStamp; /* including the first script which*/
1056 Long fileSize; /* has been either changed or added*/
1057 static char name[FILENAME_MAX+1];
1059 lastWasObject = FALSE;
1060 ppSmStack("readscripts-begin");
1061 #if HUGS_FOR_WINDOWS
1062 SetCursor(LoadCursor(NULL, IDC_WAIT));
1066 for (; n<numScripts; n++) { /* Scan previously loaded scripts */
1067 ppSmStack("readscripts-loop1");
1068 getFileInfo(scriptName[n], &timeStamp, &fileSize);
1069 if (timeChanged(timeStamp,lastChange[n])) {
1070 dropScriptsFrom(n-1);
1075 for (; n<NUM_SCRIPTS; n++) /* No scripts have been postponed */
1076 postponed[n] = FALSE; /* at this stage */
1079 while (numScripts<namesUpto) { /* Process any remaining scripts */
1080 ppSmStack("readscripts-loop2");
1081 getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
1082 timeSet(lastChange[numScripts],timeStamp);
1083 if (numScripts>0) /* no new script for prelude */
1084 startNewScript(scriptName[numScripts]);
1085 if (addScript(scriptName[numScripts],fileSize))
1088 dropScriptsFrom(numScripts-1);
1094 for (; n<numScripts; n++) {
1095 ppSmStack("readscripts-loop2");
1096 strcpy(name, scriptInfo[n].path);
1097 strcat(name, scriptInfo[n].modName);
1098 if (scriptInfo[n].fromSource)
1099 strcat(name, scriptInfo[n].srcExt); else
1100 strcat(name, ".hi"); //ToDo: should be .o
1101 getFileInfo(name,&timeStamp, &fileSize);
1102 if (timeChanged(timeStamp,scriptInfo[n].lastChange)) {
1103 dropScriptsFrom(n-1);
1108 for (; n<NUM_SCRIPTS; n++)
1109 scriptInfo[n].postponed = FALSE;
1113 while (numScripts < namesUpto) {
1114 ppSmStack ( "readscripts-loop2" );
1116 if (scriptInfo[numScripts].fromSource) {
1119 startNewScript(scriptInfo[numScripts].modName);
1120 nextNumScripts = NUM_SCRIPTS; //bogus initialisation
1121 if (addScript(numScripts)) {
1123 assert(nextNumScripts==NUM_SCRIPTS);
1126 dropScriptsFrom(numScripts-1);
1130 if (scriptInfo[numScripts].objLoaded) {
1133 scriptInfo[numScripts].objLoaded = TRUE;
1136 startNewScript(scriptInfo[numScripts].modName);
1138 nextNumScripts = NUM_SCRIPTS;
1139 if (addScript(numScripts)) {
1141 assert(nextNumScripts==NUM_SCRIPTS);
1143 //while (!scriptInfo[numScripts].fromSource && numScripts > 0)
1145 //if (scriptInfo[numScripts].fromSource)
1147 numScripts = nextNumScripts;
1148 assert(nextNumScripts<NUM_SCRIPTS);
1152 if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
1157 { Int m = namesUpto-1;
1158 Text mtext = findText(scriptInfo[m].modName);
1159 setCurrModule(mtext);
1168 setLastEdit((String)0, 0);
1169 ppSmStack("readscripts-end ");
1172 static Void local whatScripts() { /* list scripts in current session */
1174 Printf("\nHugs session for:");
1176 Printf(" (project: %s)",currProject);
1177 for (i=0; i<numScripts; ++i)
1178 Printf("\n%s%s",scriptInfo[i].path, scriptInfo[i].modName);
1182 /* --------------------------------------------------------------------------
1183 * Access to external editor:
1184 * ------------------------------------------------------------------------*/
1186 static Void local editor() { /* interpreter-editor interface */
1187 String newFile = readFilename();
1189 setLastEdit(newFile,0);
1190 if (readFilename()) {
1191 ERRMSG(0) "Multiple filenames not permitted"
1198 static Void local find() { /* edit file containing definition */
1200 This just plain wont work no more.
1202 String nm = readFilename(); /* of specified name */
1204 ERRMSG(0) "No name specified"
1207 else if (readFilename()) {
1208 ERRMSG(0) "Multiple names not permitted"
1214 setCurrModule(findEvalModule());
1216 if (nonNull(c=findTycon(t=findText(nm)))) {
1217 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1220 } else if (nonNull(c=findName(t))) {
1221 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1225 ERRMSG(0) "No current definition for name \"%s\"", nm
1232 static Void local runEditor() { /* run editor on script lastEdit */
1233 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1237 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1242 lastEdit = strCopy(fname);
1244 #if HUGS_FOR_WINDOWS
1245 DrawStatusLine(hWndMain); /* Redo status line */
1249 /* --------------------------------------------------------------------------
1250 * Read and evaluate an expression:
1251 * ------------------------------------------------------------------------*/
1253 static Void local setModule(){/*set module in which to evaluate expressions*/
1254 String s = readFilename();
1255 if (!s) s = ""; /* :m clears the current module selection */
1256 evalModule = findText(s);
1257 setLastEdit(fileOfModule(findEvalModule()),0);
1260 static Module local findEvalModule() { /*Module in which to eval expressions*/
1261 Module m = findModule(evalModule);
1267 static Void local evaluator() { /* evaluate expr and print value */
1271 setCurrModule(findEvalModule());
1273 startNewScript(0); /* Enables recovery of storage */
1274 /* allocated during evaluation */
1277 defaultDefns = evalDefaults;
1278 type = typeCheckExp(TRUE);
1279 if (isPolyType(type)) {
1280 ks = polySigOf(type);
1281 bd = monotypeOf(type);
1286 if (whatIs(bd)==QUAL) {
1287 ERRMSG(0) "Unresolved overloading" ETHEN
1288 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1289 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1299 if (typeMatches(type,ap(typeIO,typeUnit))) {
1300 inputExpr = ap(nameRunIO,inputExpr);
1304 Cell d = provePred(ks,NIL,ap(classShow,bd));
1306 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1307 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1308 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1312 inputExpr = ap2(findName(findText("show")),d,inputExpr);
1313 inputExpr = ap(findName(findText("putStr")), inputExpr);
1314 inputExpr = ap(nameRunIO, inputExpr);
1316 evalExp(); printf("\n");
1319 printType(stdout,type);
1326 printf ( "result type is " );
1327 printType ( stdout, type );
1336 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
1337 if (printing) { /* after successful termination or */
1338 printing = FALSE; /* runtime error (e.g. interrupt) */
1341 #define plural(v) v, (v==1?"":"s")
1342 Printf("%lu cell%s",plural(numCells));
1344 Printf(", %u garbage collection%s",plural(numGcs));
1353 /* --------------------------------------------------------------------------
1354 * Print type of input expression:
1355 * ------------------------------------------------------------------------*/
1357 static Void local showtype() { /* print type of expression (if any)*/
1360 setCurrModule(findEvalModule());
1361 startNewScript(0); /* Enables recovery of storage */
1362 /* allocated during evaluation */
1365 defaultDefns = evalDefaults;
1366 type = typeCheckExp(FALSE);
1367 printExp(stdout,inputExpr);
1369 printType(stdout,type);
1373 /* --------------------------------------------------------------------------
1374 * Enhanced help system: print current list of scripts or give information
1376 * ------------------------------------------------------------------------*/
1378 static String local objToStr(m,c)
1381 #if 1 || DISPLAY_QUANTIFIERS
1382 static char newVar[60];
1383 switch (whatIs(c)) {
1384 case NAME : if (m == name(c).mod) {
1385 sprintf(newVar,"%s", textToStr(name(c).text));
1387 sprintf(newVar,"%s.%s",
1388 textToStr(module(name(c).mod).text),
1389 textToStr(name(c).text));
1393 case TYCON : if (m == tycon(c).mod) {
1394 sprintf(newVar,"%s", textToStr(tycon(c).text));
1396 sprintf(newVar,"%s.%s",
1397 textToStr(module(tycon(c).mod).text),
1398 textToStr(tycon(c).text));
1402 case CLASS : if (m == cclass(c).mod) {
1403 sprintf(newVar,"%s", textToStr(cclass(c).text));
1405 sprintf(newVar,"%s.%s",
1406 textToStr(module(cclass(c).mod).text),
1407 textToStr(cclass(c).text));
1411 default : internal("objToStr");
1415 static char newVar[33];
1416 switch (whatIs(c)) {
1417 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
1420 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1423 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1426 default : internal("objToStr");
1434 static Void local dumpStg( void ) { /* print STG stuff */
1439 Cell v; /* really StgVar */
1440 setCurrModule(findEvalModule());
1442 for (; (s=readFilename())!=0;) {
1445 /* find the name while ignoring module scopes */
1446 for (i=NAMEMIN; i<nameHw; i++)
1447 if (name(i).text == t) n = i;
1449 /* perhaps it's an "idNNNNNN" thing? */
1452 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
1455 while (isdigit(s[i])) {
1456 v = v * 10 + (s[i]-'0');
1460 n = nameFromStgVar(v);
1463 if (isNull(n) && whatIs(v)==STGVAR) {
1464 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
1465 Printf ( "{- stgSize of body is %d -}\n\n", stgSize(stgVarBody(v)));
1466 printStg(stderr, v );
1469 Printf ( "Unknown reference `%s'\n", s );
1472 Printf ( "Not a Name: `%s'\n", s );
1474 if (isNull(name(n).stgVar)) {
1475 Printf ( "Doesn't have a STG tree: %s\n", s );
1477 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
1478 Printf ( "{- stgSize of body is %d -}\n\n",
1479 stgSize(stgVarBody(name(n).stgVar)));
1480 printStg(stderr, name(n).stgVar);
1485 static Void local info() { /* describe objects */
1486 Int count = 0; /* or give menu of commands */
1489 setCurrModule(findEvalModule());
1490 startNewScript(0); /* for recovery of storage */
1491 for (; (s=readFilename())!=0; count++) {
1492 describe(findText(s));
1500 static Void local describe(t) /* describe an object */
1502 Tycon tc = findTycon(t);
1503 Class cl = findClass(t);
1504 Name nm = findName(t);
1505 Module mod = findModule(t);
1507 if (nonNull(tc)) { /* as a type constructor */
1511 for (i=0; i<tycon(tc).arity; ++i) {
1512 t = ap(t,mkOffset(i));
1514 Printf("-- type constructor");
1516 Printf(" with kind ");
1517 printKind(stdout,tycon(tc).kind);
1520 switch (tycon(tc).what) {
1521 case SYNONYM : Printf("type ");
1522 printType(stdout,t);
1524 printType(stdout,tycon(tc).defn);
1528 case DATATYPE : { List cs = tycon(tc).defn;
1529 if (tycon(tc).what==DATATYPE) {
1534 printType(stdout,t);
1536 mapProc(printSyntax,cs);
1538 Printf("\n-- constructors:");
1540 for (; hasCfun(cs); cs=tl(cs)) {
1542 printExp(stdout,hd(cs));
1544 printType(stdout,name(hd(cs)).type);
1547 Printf("\n-- selectors:");
1549 for (; nonNull(cs); cs=tl(cs)) {
1551 printExp(stdout,hd(cs));
1553 printType(stdout,name(hd(cs)).type);
1558 case RESTRICTSYN : Printf("type ");
1559 printType(stdout,t);
1560 Printf(" = <restricted>");
1564 if (nonNull(in=findFirstInst(tc))) {
1565 Printf("\n-- instances:\n");
1568 in = findNextInst(tc,in);
1569 } while (nonNull(in));
1574 if (nonNull(cl)) { /* as a class */
1575 List ins = cclass(cl).instances;
1576 Kinds ks = cclass(cl).kinds;
1577 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
1578 Printf("-- type class");
1580 Printf("-- constructor class");
1582 Printf(" with arity ");
1583 printKinds(stdout,ks);
1587 mapProc(printSyntax,cclass(cl).members);
1589 if (nonNull(cclass(cl).supers)) {
1590 printContext(stdout,cclass(cl).supers);
1593 printPred(stdout,cclass(cl).head);
1594 if (nonNull(cclass(cl).members)) {
1595 List ms = cclass(cl).members;
1598 Type t = monotypeOf(name(hd(ms)).type);
1600 printExp(stdout,hd(ms));
1602 if (isNull(tl(fst(snd(t))))) {
1605 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
1607 printType(stdout,t);
1609 } while (nonNull(ms));
1613 Printf("\n-- instances:\n");
1617 } while (nonNull(ins));
1622 if (nonNull(nm)) { /* as a function/name */
1624 printExp(stdout,nm);
1626 if (nonNull(name(nm).type)) {
1627 printType(stdout,name(nm).type);
1629 Printf("<unknown type>");
1633 Printf(" -- data constructor");
1634 } else if (isMfun(nm)) {
1635 Printf(" -- class member");
1636 } else if (isSfun(nm)) {
1637 Printf(" -- selector function");
1642 if (nonNull(mod)) { /* as a module */
1644 Printf("-- module\n");
1646 Printf("\n-- values\n");
1647 for (t=module(mod).names; nonNull(t); t=tl(t)) {
1649 Printf ( "%s ", textToStr(name(nm).text));
1652 Printf("\n\n-- type constructors\n");
1653 for (t=module(mod).tycons; nonNull(t); t=tl(t)) {
1655 Printf ( "%s ", textToStr(tycon(tc).text));
1658 Printf("\n\n-- classes\n");
1659 for (t=module(mod).classes; nonNull(t); t=tl(t)) {
1661 Printf ( "%s ", textToStr(cclass(cl).text));
1667 if (isNull(tc) && isNull(cl) && isNull(nm) && isNull(mod)) {
1668 Printf("Unknown reference `%s'\n",textToStr(t));
1672 static Void local printSyntax(nm)
1674 Syntax sy = syntaxOf(nm);
1675 Text t = name(nm).text;
1676 String s = textToStr(t);
1677 if (sy != defaultSyntax(t)) {
1679 switch (assocOf(sy)) {
1680 case LEFT_ASS : Putchar('l'); break;
1681 case RIGHT_ASS : Putchar('r'); break;
1682 case NON_ASS : break;
1684 Printf(" %i ",precOf(sy));
1685 if (isascii((int)(*s)) && isalpha((int)(*s))) {
1694 static Void local showInst(in) /* Display instance decl header */
1696 Printf("instance ");
1697 if (nonNull(inst(in).specifics)) {
1698 printContext(stdout,inst(in).specifics);
1701 printPred(stdout,inst(in).head);
1705 /* --------------------------------------------------------------------------
1706 * List all names currently in scope:
1707 * ------------------------------------------------------------------------*/
1709 static Void local listNames() { /* list names matching optional pat*/
1710 String pat = readFilename();
1712 Int width = getTerminalWidth() - 1;
1715 Module mod = findEvalModule();
1717 if (pat) { /* First gather names to list */
1719 names = addNamesMatching(pat,names);
1720 } while ((pat=readFilename())!=0);
1722 names = addNamesMatching((String)0,names);
1724 if (isNull(names)) { /* Then print them out */
1725 ERRMSG(0) "No names selected"
1728 for (termPos=0; nonNull(names); names=tl(names)) {
1729 String s = objToStr(mod,hd(names));
1731 if (termPos+1+l>width) {
1734 } else if (termPos>0) {
1742 Printf("\n(%d names listed)\n", count);
1745 /* --------------------------------------------------------------------------
1746 * print a prompt and read a line of input:
1747 * ------------------------------------------------------------------------*/
1749 static Void local promptForInput(moduleName)
1750 String moduleName; {
1751 char promptBuffer[1000];
1753 /* This is portable but could overflow buffer */
1754 sprintf(promptBuffer,prompt,moduleName);
1756 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
1757 * promptBuffer instead.
1759 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
1760 /* Reset prompt to a safe default to avoid an infinite loop */
1762 prompt = strCopy("? ");
1763 internal("Combined prompt and evaluation module name too long");
1767 stringInput("main\0"); else
1768 consoleInput(promptBuffer);
1771 /* --------------------------------------------------------------------------
1772 * main read-eval-print loop, with error trapping:
1773 * ------------------------------------------------------------------------*/
1775 static jmp_buf catch_error; /* jump buffer for error trapping */
1777 static Void local interpreter(argc,argv)/* main interpreter loop */
1780 Int errorNumber = setjmp(catch_error);
1782 if (errorNumber && autoMain) {
1783 fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" );
1787 breakOn(TRUE); /* enable break trapping */
1788 if (numScripts==0) { /* only succeeds on first time, */
1789 if (errorNumber) /* before prelude has been loaded */
1790 fatal("Unable to load prelude");
1791 initialize(argc,argv);
1797 everybody(RESET); /* reset to sensible initial state */
1798 dropScriptsFrom(numScripts-1); /* remove partially loaded scripts */
1799 /* not counting prelude as a script*/
1801 promptForInput(textToStr(module(findEvalModule()).text));
1803 cmd = readCommand(cmds, (Char)':', (Char)'!');
1808 case EDIT : editor();
1812 case LOAD : clearProject();
1813 forgetScriptsFrom(1);
1816 case ALSO : clearProject();
1817 forgetScriptsFrom(numScripts);
1820 case RELOAD : readScripts(1);
1822 case PROJECT: project();
1827 case EVAL : evaluator();
1829 case TYPEOF : showtype();
1831 case NAMES : listNames();
1835 case BADCMD : guidance();
1840 #ifdef CRUDE_PROFILING
1844 case SYSTEM : if (shellEsc(readLine()))
1845 Printf("Warning: Shell escape terminated abnormally\n");
1847 case CHGDIR : changeDir();
1851 case DUMP : dumpStg();
1854 case COLLECT: consGC = FALSE;
1857 Printf("Garbage collection recovered %d cells\n",
1864 Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
1865 millisecs(userElapsed), millisecs(systElapsed));
1867 if (autoMain) break;
1872 /* --------------------------------------------------------------------------
1873 * Display progress towards goal:
1874 * ------------------------------------------------------------------------*/
1876 static Target currTarget;
1877 static Bool aiming = FALSE;
1880 static Int charCount;
1882 Void setGoal(what, t) /* Set goal for what to be t */
1886 currTarget = (t?t:1);
1889 currPos = strlen(what);
1890 maxPos = getTerminalWidth() - 1;
1894 for (charCount=0; *what; charCount++)
1899 Void soFar(t) /* Indicate progress towards goal */
1900 Target t; { /* has now reached t */
1903 Int newPos = (Int)((maxPos * ((long)t))/currTarget);
1908 if (newPos>currPos) {
1911 while (newPos>++currPos);
1918 Void done() { /* Goal has now been achieved */
1921 while (maxPos>currPos++)
1926 for (; charCount>0; charCount--) {
1935 static Void local failed() { /* Goal cannot be reached due to */
1936 if (aiming) { /* errors */
1943 /* --------------------------------------------------------------------------
1945 * ------------------------------------------------------------------------*/
1947 Void errHead(l) /* print start of error message */
1949 failed(); /* failed to reach target ... */
1951 FPrintf(errorStream,"ERROR");
1954 FPrintf(errorStream," \"%s\"", scriptFile);
1955 setLastEdit(scriptFile,l);
1956 if (l) FPrintf(errorStream," (line %d)",l);
1959 FPrintf(errorStream,": ");
1960 FFlush(errorStream);
1963 Void errFail() { /* terminate error message and */
1964 Putc('\n',errorStream); /* produce exception to return to */
1965 FFlush(errorStream); /* main command loop */
1966 longjmp(catch_error,1);
1969 Void errAbort() { /* altern. form of error handling */
1970 failed(); /* used when suitable error message*/
1971 stopAnyPrinting(); /* has already been printed */
1975 Void internal(msg) /* handle internal error */
1977 #if HUGS_FOR_WINDOWS
1979 wsprintf(buf,"INTERNAL ERROR: %s",msg);
1980 MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
1984 Printf("INTERNAL ERROR: %s\n",msg);
1986 longjmp(catch_error,1);
1989 Void fatal(msg) /* handle fatal error */
1991 #if HUGS_FOR_WINDOWS
1993 wsprintf(buf,"FATAL ERROR: %s",msg);
1994 MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
1997 Printf("\nFATAL ERROR: %s\n",msg);
2002 sigHandler(breakHandler) { /* respond to break interrupt */
2003 #if HUGS_FOR_WINDOWS
2004 MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
2007 Printf("{Interrupted!}\n");
2009 breakOn(TRUE); /* reinstall signal handler - redundant on BSD systems */
2010 /* but essential on POSIX (and other?) systems */
2016 longjmp(catch_error,1);
2017 sigResume;/*NOTREACHED*/
2020 /* --------------------------------------------------------------------------
2021 * Read value from environment variable or registry:
2022 * ------------------------------------------------------------------------*/
2024 String fromEnv(var,def) /* return value of: */
2025 String var; /* environment variable named by var */
2026 String def; { /* or: default value given by def */
2027 String s = getenv(var);
2028 return (s ? s : def);
2031 /* --------------------------------------------------------------------------
2032 * String manipulation routines:
2033 * ------------------------------------------------------------------------*/
2035 static String local strCopy(s) /* make malloced copy of a string */
2039 if ((t=(char *)malloc(strlen(s)+1))==0) {
2040 ERRMSG(0) "String storage space exhausted"
2043 for (r=t; (*r++ = *s++)!=0; ) {
2050 /* --------------------------------------------------------------------------
2052 * We can redirect compiler output (prompts, error messages, etc) by
2053 * tweaking these functions.
2054 * ------------------------------------------------------------------------*/
2056 #if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
2058 #ifdef HAVE_STDARG_H
2061 #include <varargs.h>
2064 /* ----------------------------------------------------------------------- */
2066 #define BufferSize 5000 /* size of redirected output buffer */
2068 typedef struct _HugsStream {
2069 char buffer[BufferSize]; /* buffer for redirected output */
2070 Int next; /* next space in buffer */
2073 static Void local vBufferedPrintf Args((HugsStream*, const char*, va_list));
2074 static Void local bufferedPutchar Args((HugsStream*, Char));
2075 static String local bufferClear Args((HugsStream *stream));
2077 static Void local vBufferedPrintf(stream, fmt, ap)
2081 Int spaceLeft = BufferSize - stream->next;
2082 char* p = &stream->buffer[stream->next];
2083 Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
2084 if (0 <= charsAdded && charsAdded < spaceLeft)
2085 stream->next += charsAdded;
2086 #if 1 /* we can either buffer the first n chars or buffer the last n chars */
2092 static Void local bufferedPutchar(stream, c)
2095 if (BufferSize - stream->next >= 2) {
2096 stream->buffer[stream->next++] = c;
2097 stream->buffer[stream->next] = '\0';
2101 static String local bufferClear(stream)
2102 HugsStream *stream; {
2103 if (stream->next == 0) {
2107 return stream->buffer;
2111 /* ----------------------------------------------------------------------- */
2113 static HugsStream outputStreamH;
2115 * We rely on standard C semantics to initialise outputStreamH.next to 0.
2118 Void hugsEnableOutput(f)
2123 String hugsClearOutputBuffer() {
2124 return bufferClear(&outputStreamH);
2127 #ifdef HAVE_STDARG_H
2128 Void hugsPrintf(const char *fmt, ...) {
2129 va_list ap; /* pointer into argument list */
2130 va_start(ap, fmt); /* make ap point to first arg after fmt */
2131 if (!disableOutput) {
2134 vBufferedPrintf(&outputStreamH, fmt, ap);
2136 va_end(ap); /* clean up */
2139 Void hugsPrintf(fmt, va_alist)
2142 va_list ap; /* pointer into argument list */
2143 va_start(ap); /* make ap point to first arg after fmt */
2144 if (!disableOutput) {
2147 vBufferedPrintf(&outputStreamH, fmt, ap);
2149 va_end(ap); /* clean up */
2155 if (!disableOutput) {
2158 bufferedPutchar(&outputStreamH, c);
2162 Void hugsFlushStdout() {
2163 if (!disableOutput) {
2170 if (!disableOutput) {
2175 #ifdef HAVE_STDARG_H
2176 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2179 if (!disableOutput) {
2180 vfprintf(fp, fmt, ap);
2182 vBufferedPrintf(&outputStreamH, fmt, ap);
2187 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2193 if (!disableOutput) {
2194 vfprintf(fp, fmt, ap);
2196 vBufferedPrintf(&outputStreamH, fmt, ap);
2202 Void hugsPutc(c, fp)
2205 if (!disableOutput) {
2208 bufferedPutchar(&outputStreamH, c);
2212 #endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
2213 /* --------------------------------------------------------------------------
2214 * Send message to each component of system:
2215 * ------------------------------------------------------------------------*/
2217 Void everybody(what) /* send command `what' to each component of*/
2218 Int what; { /* system to respond as appropriate ... */
2219 machdep(what); /* The order of calling each component is */
2220 storage(what); /* important for the INSTALL command */
2223 translateControl(what);
2225 staticAnalysis(what);
2226 deriveControl(what);
2233 /* --------------------------------------------------------------------------
2234 * Hugs for Windows code (WinMain and related functions)
2235 * ------------------------------------------------------------------------*/
2237 #if HUGS_FOR_WINDOWS
2238 #include "winhugs.c"