2 /* --------------------------------------------------------------------------
5 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
6 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
7 * Technology, 1994-1999, All rights reserved. It is distributed as
8 * free software under the license in the file "License", which is
9 * included in the distribution.
11 * $RCSfile: hugs.c,v $
13 * $Date: 2000/06/23 09:41:11 $
14 * ------------------------------------------------------------------------*/
20 #include "hugsbasictypes.h"
29 #include "Assembler.h" /* DEBUG_LoadSymbols */
30 #include "ForeignCall.h" /* createAdjThunk */
33 Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
34 Bool initDone = FALSE;
36 #if EXPLAIN_INSTANCE_RESOLUTION
37 Bool showInstRes = FALSE;
40 Bool multiInstRes = FALSE;
43 /* --------------------------------------------------------------------------
44 * Local function prototypes:
45 * ------------------------------------------------------------------------*/
47 static List local initialize ( Int,String [] );
48 static Void local promptForInput ( String );
49 static Void local interpreter ( Int,String [] );
50 static Void local menu ( Void );
51 static Void local guidance ( Void );
52 static Void local forHelp ( Void );
53 static Void local set ( Void );
54 static Void local changeDir ( Void );
55 static Void local load ( Void );
56 static Void local project ( Void );
57 static Void local editor ( Void );
58 static Void local find ( Void );
59 static Bool local startEdit ( Int,String );
60 static Void local runEditor ( Void );
61 static Void local setModule ( Void );
62 static Void local evaluator ( Void );
63 static Void local stopAnyPrinting ( Void );
64 static Void local showtype ( Void );
65 static String local objToStr ( Module, Cell );
66 static Void local info ( Void );
67 static Void local printSyntax ( Name );
68 static Void local showInst ( Inst );
69 static Void local describe ( Text );
70 static Void local listNames ( Void );
72 static Void local toggleSet ( Char,Bool );
73 static Void local togglesIn ( Bool );
74 static Void local optionInfo ( Void );
75 static Void local readOptions ( String );
76 static Bool local processOption ( String );
77 static Void local setHeapSize ( String );
78 static Int local argToInt ( String );
80 static Void local setLastEdit ( String,Int );
81 static Void local failed ( Void );
82 static String local strCopy ( String );
83 static Void local browseit ( Module,String,Bool );
84 static Void local browse ( Void );
85 static void local clearCurrentFile ( void );
87 static void loadActions ( List loadModules /* :: [CONID] */ );
88 static void addActions ( List extraModules /* :: [CONID] */ );
89 static Bool loadThePrelude ( void );
92 /* --------------------------------------------------------------------------
93 * Machine dependent code for Hugs interpreter:
94 * ------------------------------------------------------------------------*/
98 /* --------------------------------------------------------------------------
100 * ------------------------------------------------------------------------*/
102 static Bool printing = FALSE; /* TRUE => currently printing value*/
103 static Bool showStats = FALSE; /* TRUE => print stats after eval */
104 static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
105 static Bool addType = FALSE; /* TRUE => print type with value */
106 static Bool quiet = FALSE; /* TRUE => don't show progress */
107 static Bool lastWasObject = FALSE;
109 Bool flagAssert = FALSE; /* TRUE => assert False <e> causes
110 an assertion failure */
111 Bool preludeLoaded = FALSE;
112 Bool debugSC = FALSE;
113 Bool combined = FALSE;
115 Module moduleBeingParsed; /* so the parser (topModule) knows */
116 static char* currentFile; /* Name of current file, or NULL */
117 static char currentFileName[1000]; /* name is stored here if it exists*/
119 static Bool autoMain = FALSE;
120 static String lastEdit = 0; /* Name of script to edit (if any) */
121 static Int lastEdLine = 0; /* Editor line number (if possible)*/
122 static String prompt = 0; /* Prompt string */
123 static Int hpSize = DEFAULTHEAP; /* Desired heap size */
124 static Bool disableOutput = FALSE; /* TRUE => quiet */
125 String hugsEdit = 0; /* String for editor command */
126 String hugsPath = 0; /* String for file search path */
128 List ifaces_outstanding = NIL;
130 static ConId currentModule_failed = NIL; /* Remember failed module from :r */
134 /* --------------------------------------------------------------------------
136 * ------------------------------------------------------------------------*/
143 extern void setRtsFlags ( int );
145 static int diet_hep_initialised = 0;
146 static FILE* dh_logfile;
149 void printf_now ( void )
151 time_t now = time(NULL);
152 printf("\n=== DietHEP event at %s",ctime(&now));
156 void diet_hep_initialise ( void* cstackbase )
158 List modConIds; /* :: [CONID] */
161 String fakeargv[] = { "diet_hep", "+RTS",
162 "-D0", "-RTS", NULL };
165 if (diet_hep_initialised) return;
166 diet_hep_initialised = 1;
168 CStackBase = cstackbase;
170 dh_logfile = freopen("diet_hep_logfile.txt","a",stdout);
174 printf("===---===---=== DietHEP initialisation ===---===---===\n\n");
178 setInstallDir ( "diet_hep" );
180 /* The following copied from interpreter() */
181 setBreakAction ( HugsIgnoreBreak );
182 modConIds = initialize(sizeof(fakeargv)/sizeof(String)-1,fakeargv);
183 //setRtsFlags(4 | 128 | 32);
184 assert(isNull(modConIds));
185 setBreakAction ( HugsIgnoreBreak );
186 prelOK = loadThePrelude();
189 printf("diet_hep_initialise: fatal error: "
190 "can't load the Prelude.\n" );
196 if (combined) everybody(POSTPREL);
197 /* we now leave, and wait for requests */
202 DH_MODULE DH_LoadLibrary_wrk ( DH_LPCSTR modname )
206 t = findText(modname);
207 addActions ( singleton(mkCon(t)) );
209 if (isModule(m)) return m; else return 0;
213 void* DH_GetProcAddress_wrk ( DH_CALLCONV cconv,
215 DH_LPCSTR lpProcName )
220 StgStablePtr stableptr;
222 if (!isModule(hModule)) return NULL;
223 setCurrModule(hModule);
224 n = findName ( findText(lpProcName) );
225 if (!isName(n)) return NULL;
226 assert(isCPtr(name(n).closure));
228 /* n is the function which we want to f-x-d,
229 n :: prim_arg* -> IO prim_result.
230 Assume that name(n).closure is a cptr which points to n's BCO.
232 Make ns a stable pointer to n.
233 Manufacture a type descriptor string for n's type.
234 use createAdjThunk to build the adj thunk.
236 typedescr = makeTypeDescrText ( name(n).type );
237 if (!isText(typedescr)) return NULL;
238 if (cconv != dh_stdcall && cconv != dh_ccall) return NULL;
240 stableptr = getStablePtr( cptrOf(name(n).closure) );
241 adj_thunk = createAdjThunk ( stableptr,
242 textToStr(typedescr),
243 cconv==dh_stdcall ? 's' : 'c' );
247 /*----------- EXPORTS -------------*/
248 __attribute__((__stdcall__))
250 DH_LoadLibrary ( DH_LPCSTR modname )
254 diet_hep_initialise ( &xxx );
256 printf("=== DH_LoadLibrary: request to load `%s'\n\n", modname );
258 hdl = DH_LoadLibrary_wrk ( modname );
263 __attribute__((__stdcall__))
265 DH_GetProcAddress ( DH_CALLCONV cconv,
267 DH_LPCSTR lpProcName )
270 diet_hep_initialise ( &xxx );
272 printf("=== DH_GetProcAddress: request for `%s'\n\n", lpProcName );
274 return DH_GetProcAddress_wrk ( cconv, hModule, lpProcName );
281 HINSTANCE hInst /* Library instance handle. */ ,
282 DWORD reason /* Reason this function is being called. */ ,
283 LPVOID reserved /* Not used. */ )
288 case DLL_PROCESS_ATTACH:
291 case DLL_PROCESS_DETACH:
294 case DLL_THREAD_ATTACH:
297 case DLL_THREAD_DETACH:
304 //---------------------------------
307 int main ( int argc, char** argv )
311 hdl = DH_LoadLibrary("FooBar");
312 assert(isModule(hdl));
313 proc = DH_GetProcAddress ( dh_ccall, hdl, "wurble" );
314 fprintf ( stderr, "just before calling it\n");
315 ((void(*)(int)) proc) (33);
316 ((void(*)(int)) proc) (34);
317 ((void(*)(int)) proc) (35);
318 fprintf ( stderr, "exiting safely\n");
325 Main main ( Int, String [] ); /* now every func has a prototype */
330 CStackBase = &argc; /* Save stack base for use in gc */
334 checkBytecodeCount(); /* check for too many bytecodes */
338 /* If first arg is +Q or -Q, be entirely silent, and automatically run
339 main after loading scripts. Useful for running the nofib suite. */
340 if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
342 if (strcmp(argv[1],"-Q") == 0) {
347 Printf("__ __ __ __ ____ ___ _________________________________________\n");
348 Printf("|| || || || || || ||__ STGHugs: Based on the Haskell 98 standard\n");
349 Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-2000\n");
350 Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
351 Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
352 Printf("|| || Version: %s _________________________________________\n\n",HUGS_VERSION);
354 /* Get the absolute path to the directory containing the hugs
355 executable, so that we know where the Prelude and nHandle.so/.dll are.
356 We do this by reading env var STGHUGSDIR. This needs to succeed, so
357 setInstallDir won't return unless it succeeds.
359 setInstallDir ( argv[0] );
362 interpreter(argc,argv);
363 Printf("[Leaving Hugs]\n");
372 #endif /* DIET_HEP */
374 /* --------------------------------------------------------------------------
375 * Initialization, interpret command line args and read prelude:
376 * ------------------------------------------------------------------------*/
378 static List /*CONID*/ initialize ( Int argc, String argv[] )
383 setLastEdit((String)0,0);
390 hugsEdit = strCopy(fromEnv("EDITOR",NULL));
392 hugsPath = strCopy(HUGSPATH);
393 readOptions("-p\"%s> \" -r$$");
394 readOptions(fromEnv("STGHUGSFLAGS",""));
398 char exe_name[N_INSTALLDIR + 6];
399 strcpy(exe_name, installDir);
400 strcat(exe_name, "hugs");
401 DEBUG_LoadSymbols(exe_name);
405 /* startupHaskell extracts args between +RTS ... -RTS, and sets
406 prog_argc/prog_argv to the rest. We want to further process
407 the rest, so we then get hold of them again.
409 startupHaskell ( argc, argv, NULL );
410 getProgArgv ( &argc, &argv );
412 /* Find out early on if we're in combined mode or not.
413 everybody(PREPREL) needs to know this. Also, establish the
416 for (i = 1; i < argc; ++i) {
417 if (strcmp(argv[i], "--")==0) break;
418 if (strcmp(argv[i], "-c")==0) combined = FALSE;
419 if (strcmp(argv[i], "+c")==0) combined = TRUE;
421 if (strncmp(argv[i],"+h",2)==0 || strncmp(argv[i],"-h",2)==0)
422 setHeapSize(&(argv[i][2]));
426 initialModules = NIL;
428 for (i = 1; i < argc; ++i) { /* process command line arguments */
429 if (strcmp(argv[i], "--")==0)
430 { argv[i] = NULL; break; }
431 if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/) {
432 if (!processOption(argv[i]))
434 = cons ( mkCon(findText(argv[i])), initialModules );
440 Printf("Haskell 98 mode: Restart with command line option -98"
441 " to enable extensions\n");
443 Printf("Hugs mode: Restart with command line option +98 for"
444 " Haskell 98 mode\n");
448 Printf("Combined mode: Restart with command line -c for"
449 " standalone mode\n\n" );
451 Printf("Standalone mode: Restart with command line +c for"
452 " combined mode\n\n" );
455 /* slide args back over the deleted ones. */
457 for (i = 1; i < argc; i++)
463 setProgArgv ( argc, argv );
466 return initialModules;
469 /* --------------------------------------------------------------------------
470 * Command line options:
471 * ------------------------------------------------------------------------*/
473 struct options { /* command line option toggles */
474 char c; /* table defined in main app. */
479 extern struct options toggle[];
481 static Void local toggleSet(c,state) /* Set command line toggle */
485 for (i=0; toggle[i].c; ++i)
486 if (toggle[i].c == c) {
487 *toggle[i].flag = state;
491 ERRMSG(0) "Unknown toggle `%c'", c
495 static Void local togglesIn(state) /* Print current list of toggles in*/
496 Bool state; { /* given state */
499 for (i=0; toggle[i].c; ++i)
500 if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
502 Putchar((char)(state ? '+' : '-'));
503 Putchar(toggle[i].c);
510 static Void local optionInfo() { /* Print information about command */
511 static String fmts = "%-5s%s\n"; /* line settings */
512 static String fmtc = "%-5c%s\n";
515 Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
516 for (i=0; toggle[i].c; ++i) {
517 if (!haskell98 || toggle[i].h98) {
518 Printf(fmtc,toggle[i].c,toggle[i].description);
522 Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
523 Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
524 Printf(fmts,"pstr","Set prompt string to str");
525 Printf(fmts,"rstr","Set repeat last expression string to str");
526 Printf(fmts,"Pstr","Set search path for modules to str");
527 Printf(fmts,"Estr","Use editor setting given by str");
528 Printf(fmts,"cnum","Set constraint cutoff limit");
529 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
530 Printf(fmts,"Fstr","Set preprocessor filter to str");
533 Printf("\nCurrent settings: ");
536 Printf("-h%d",heapSize);
540 printString(repeatStr);
541 Printf(" -c%d",cutoff);
542 Printf("\nSearch path : -P");
543 printString(hugsPath);
546 if (projectPath!=NULL) {
547 Printf("\nProject Path : %s",projectPath);
550 Printf("\nEditor setting : -E");
551 printString(hugsEdit);
552 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
553 Printf("\nPreprocessor : -F");
554 printString(preprocessor);
556 Printf("\nCompatibility : %s", haskell98 ? "Haskell 98 (+98)"
557 : "Hugs Extensions (-98)");
566 static Void local readOptions(options) /* read options from string */
570 stringInput(options);
571 while ((s=readFilename())!=0) {
572 if (*s && !processOption(s)) {
573 ERRMSG(0) "Option string must begin with `+' or `-'"
580 static Bool local processOption(s) /* process string s for options, */
581 String s; { /* return FALSE if none found. */
593 case 'Q' : break; /* already handled */
595 case 'p' : if (s[1]) {
596 if (prompt) free(prompt);
597 prompt = strCopy(s+1);
601 case 'r' : if (s[1]) {
602 if (repeatStr) free(repeatStr);
603 repeatStr = strCopy(s+1);
608 String p = substPath(s+1,hugsPath ? hugsPath : "");
609 if (hugsPath) free(hugsPath);
614 case 'E' : if (hugsEdit) free(hugsEdit);
615 hugsEdit = strCopy(s+1);
618 #if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
619 case 'F' : if (preprocessor) free(preprocessor);
620 preprocessor = strCopy(s+1);
624 case 'h' : /* don't do anything, since pre-scan of args
625 will have got it already */
628 case 'c' : /* don't do anything, since pre-scan of args
629 will have got it already */
632 case 'D' : /* hack */
634 extern void setRtsFlags( int x );
635 setRtsFlags(argToInt(s+1));
639 default : if (strcmp("98",s)==0) {
640 if (initDone && ((state && !haskell98) ||
641 (!state && haskell98))) {
643 "Haskell 98 compatibility cannot be changed"
644 " while the interpreter is running\n");
657 static Void local setHeapSize(s)
660 hpSize = argToInt(s);
661 if (hpSize < MINIMUMHEAP)
662 hpSize = MINIMUMHEAP;
663 else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
664 hpSize = MAXIMUMHEAP;
665 if (initDone && hpSize != heapSize) {
666 /* ToDo: should this use a message box in winhugs? */
667 FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
674 static Int local argToInt(s) /* read integer from argument str */
679 if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
680 ERRMSG(0) "Missing integer in option setting \"%s\"", t
685 Int d = (*s++) - '0';
686 if (n > ((MAXPOSINT - d)/10)) {
687 ERRMSG(0) "Option setting \"%s\" is too large", t
691 } while (isascii((int)(*s)) && isdigit((int)(*s)));
693 if (*s=='K' || *s=='k') {
694 if (n > (MAXPOSINT/1000)) {
695 ERRMSG(0) "Option setting \"%s\" is too large", t
702 #if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
703 if (*s=='M' || *s=='m') {
704 if (n > (MAXPOSINT/1000000)) {
705 ERRMSG(0) "Option setting \"%s\" is too large", t
713 #if MAXPOSINT > 1000000000
714 if (*s=='G' || *s=='g') {
715 if (n > (MAXPOSINT/1000000000)) {
716 ERRMSG(0) "Option setting \"%s\" is too large", t
725 ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
732 /* --------------------------------------------------------------------------
733 * Print Menu of list of commands:
734 * ------------------------------------------------------------------------*/
736 static struct cmd cmds[] = {
737 {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
738 {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
739 {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
740 {":quit", QUIT}, {":set", SET}, {":find", FIND},
741 {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
743 {":module", SETMODULE},
745 #if EXPLAIN_INSTANCE_RESOLUTION
748 {":version", PNTVER},
753 static Void local menu() {
754 Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
755 Printf("c is the first character in the full name.\n\n");
756 Printf(":load <filenames> load modules from specified files\n");
757 Printf(":load clear all files except prelude\n");
758 Printf(":also <filenames> read additional modules\n");
759 Printf(":reload repeat last load command\n");
760 Printf(":project <filename> use project file\n");
761 Printf(":edit <filename> edit file\n");
762 Printf(":edit edit last module\n");
763 Printf(":module <module> set module for evaluating expressions\n");
764 Printf("<expr> evaluate expression\n");
765 Printf(":type <expr> print type of expression\n");
766 Printf(":? display this list of commands\n");
767 Printf(":set <options> set command line options\n");
768 Printf(":set help on command line options\n");
769 Printf(":names [pat] list names currently in scope\n");
770 Printf(":info <names> describe named objects\n");
771 Printf(":browse <modules> browse names defined in <modules>\n");
772 #if EXPLAIN_INSTANCE_RESOLUTION
773 Printf(":xplain <context> explain instance resolution for <context>\n");
775 Printf(":find <name> edit module containing definition of name\n");
776 Printf(":!command shell escape\n");
777 Printf(":cd dir change directory\n");
778 Printf(":gc force garbage collection\n");
779 Printf(":version print Hugs version\n");
780 Printf(":dump <name> print STG code for named fn\n");
781 Printf(":quit exit Hugs interpreter\n");
784 static Void local guidance() {
785 Printf("Command not recognised. ");
789 static Void local forHelp() {
790 Printf("Type :? for help\n");
793 /* --------------------------------------------------------------------------
794 * Setting of command line options:
795 * ------------------------------------------------------------------------*/
797 struct options toggle[] = { /* List of command line toggles */
798 {'s', 1, "Print no. reductions/cells after eval", &showStats},
799 {'t', 1, "Print type after evaluation", &addType},
800 {'g', 1, "Print no. cells recovered after gc", &gcMessages},
801 {'l', 1, "Literate modules as default", &literateScripts},
802 {'e', 1, "Warn about errors in literate modules", &literateErrors},
803 {'q', 1, "Print nothing to show progress", &quiet},
804 {'w', 1, "Always show which modules are loaded", &listScripts},
805 {'k', 1, "Show kind errors in full", &kindExpert},
806 {'o', 0, "Allow overlapping instances", &allowOverlap},
807 {'S', 1, "Debug: show generated SC code", &debugSC},
808 {'a', 1, "Raise exception on assert failure", &flagAssert},
809 #if EXPLAIN_INSTANCE_RESOLUTION
810 {'x', 1, "Explain instance resolution", &showInstRes},
813 {'m', 0, "Use multi instance resolution", &multiInstRes},
818 static Void local set() { /* change command line options from*/
819 String s; /* Hugs command line */
821 if ((s=readFilename())!=0) {
823 if (!processOption(s)) {
824 ERRMSG(0) "Option string must begin with `+' or `-'"
827 } while ((s=readFilename())!=0);
833 /* --------------------------------------------------------------------------
834 * Change directory command:
835 * ------------------------------------------------------------------------*/
837 static Void local changeDir() { /* change directory */
838 String s = readFilename();
840 ERRMSG(0) "Unable to change to directory \"%s\"", s
846 /* --------------------------------------------------------------------------
848 * ------------------------------------------------------------------------*/
850 static jmp_buf catch_error; /* jump buffer for error trapping */
852 HugsBreakAction currentBreakAction = HugsIgnoreBreak;
854 static void handler_IgnoreBreak ( int sig )
856 setHandler ( handler_IgnoreBreak );
859 static void handler_LongjmpOnBreak ( int sig )
861 setHandler ( handler_LongjmpOnBreak );
862 Printf("{Interrupted!}\n");
863 longjmp(catch_error,1);
866 static void handler_RtsInterrupt ( int sig )
868 setHandler ( handler_RtsInterrupt );
872 HugsBreakAction setBreakAction ( HugsBreakAction newAction )
874 HugsBreakAction tmp = currentBreakAction;
875 currentBreakAction = newAction;
877 case HugsIgnoreBreak:
878 setHandler ( handler_IgnoreBreak ); break;
879 case HugsLongjmpOnBreak:
880 setHandler ( handler_LongjmpOnBreak ); break;
881 case HugsRtsInterrupt:
882 setHandler ( handler_RtsInterrupt ); break;
884 internal("setBreakAction");
890 /* --------------------------------------------------------------------------
891 * The new module chaser, loader, etc
892 * ------------------------------------------------------------------------*/
894 List moduleGraph = NIL;
895 List prelModules = NIL;
896 List targetModules = NIL;
898 static String modeToString ( Cell mode )
901 case FM_SOURCE: return "source";
902 case FM_OBJECT: return "object";
903 case FM_EITHER: return "source or object";
904 default: internal("modeToString");
908 static Cell childMode ( Cell modeMeRequest, Cell modeMeActual )
910 assert(modeMeActual == FM_SOURCE ||
911 modeMeActual == FM_OBJECT);
912 assert(modeMeRequest == FM_SOURCE ||
913 modeMeRequest == FM_OBJECT ||
914 modeMeRequest == FM_EITHER);
915 if (modeMeRequest == FM_SOURCE) return modeMeRequest;
916 if (modeMeRequest == FM_OBJECT) return modeMeRequest;
917 if (modeMeActual == FM_OBJECT) return FM_OBJECT;
918 if (modeMeActual == FM_SOURCE) return FM_EITHER;
919 internal("childMode");
922 static Bool compatibleNewMode ( Cell modeNew, Cell modeExisting )
924 if (modeNew == FM_OBJECT && modeExisting == FM_OBJECT) return TRUE;
925 if (modeNew == FM_SOURCE && modeExisting == FM_SOURCE) return TRUE;
926 if (modeNew == FM_EITHER && modeExisting == FM_OBJECT) return TRUE;
927 if (modeNew == FM_EITHER && modeExisting == FM_SOURCE) return TRUE;
931 static void setCurrentFile ( Module mod )
933 assert(isModule(mod));
934 strncpy(currentFileName, textToStr(module(mod).text), 990);
935 strcat(currentFileName, textToStr(module(mod).srcExt));
936 currentFile = currentFileName;
937 moduleBeingParsed = mod;
940 static void clearCurrentFile ( void )
943 moduleBeingParsed = NIL;
946 static void ppMG ( void )
949 for (t = moduleGraph; nonNull(t); t=tl(t)) {
953 Printf ( " %s\n", textToStr(textOf(snd(u))));
957 for (v = snd(u); nonNull(v); v=tl(v))
958 Printf ( "%s ", textToStr(textOf(hd(v))) );
968 static Bool elemMG ( ConId mod )
971 for (gs = moduleGraph; nonNull(gs); gs=tl(gs))
972 switch (whatIs(hd(gs))) {
974 if (textOf(mod)==textOf(snd(hd(gs)))) return TRUE;
977 if (varIsMember(textOf(mod),snd(hd(gs)))) return TRUE;
986 static ConId selectArbitrarilyFromGroup ( Cell group )
988 switch (whatIs(group)) {
989 case GRP_NONREC: return snd(group);
990 case GRP_REC: return hd(snd(group));
991 default: internal("selectArbitrarilyFromGroup");
995 static ConId selectLatestMG ( void )
997 List gs = moduleGraph;
998 if (isNull(gs)) internal("selectLatestMG(1)");
999 while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs);
1000 return selectArbitrarilyFromGroup(hd(gs));
1004 static List /* of CONID */ listFromSpecifiedMG ( List mg )
1008 for (gs = mg; nonNull(gs); gs=tl(gs)) {
1009 switch (whatIs(hd(gs))) {
1010 case GRP_REC: cs = appendOnto(cs,snd(hd(gs))); break;
1011 case GRP_NONREC: cs = cons(snd(hd(gs)),cs); break;
1012 default: internal("listFromSpecifiedMG");
1018 static List /* of CONID */ listFromMG ( void )
1020 return listFromSpecifiedMG ( moduleGraph );
1024 /* Calculate the strongly connected components of modgList
1025 and assign them to moduleGraph. Uses the .uses field of
1026 each of the modules to build the graph structure.
1028 #define SCC modScc /* make scc algorithm for StgVars */
1029 #define LOWLINK modLowlink
1030 #define DEPENDS(t) snd(t)
1031 #define SETDEPENDS(c,v) snd(c)=v
1038 static void mgFromList ( List /* of CONID */ modgList )
1044 List adjList; /* :: [ (Text, [Text]) ] */
1050 for (t = modgList; nonNull(t); t=tl(t)) {
1052 mod = findModule(mT);
1053 assert(nonNull(mod));
1055 for (u = module(mod).uses; nonNull(u); u=tl(u))
1056 usesT = cons(textOf(hd(u)),usesT);
1058 /* artificially give all modules a dependency on Prelude */
1059 if (mT != textPrelude && mT != textPrelPrim)
1060 usesT = cons(textPrelude,usesT);
1061 adjList = cons(pair(mT,usesT),adjList);
1064 /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
1065 Modify this so that the adjacency list is a list of pointers
1066 back to bits of adjList -- that's what modScc needs.
1068 for (t = adjList; nonNull(t); t=tl(t)) {
1070 /* for each elem of the adjacency list ... */
1071 for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
1074 /* find the element of adjList whose fst is a */
1075 for (v = adjList; nonNull(v); v=tl(v)) {
1077 assert(isText(fst(hd(v))));
1078 if (fst(hd(v))==a) break;
1080 if (isNull(v)) internal("mgFromList");
1081 adj = cons(hd(v),adj);
1086 adjList = modScc ( adjList );
1087 /* adjList is now [ [(module-text, aux-info-field)] ] */
1091 for (t = adjList; nonNull(t); t=tl(t)) {
1094 /* scc :: [ (module-text, aux-info-field) ] */
1095 for (u = scc; nonNull(u); u=tl(u))
1096 hd(u) = mkCon(fst(hd(u)));
1098 /* scc :: [CONID] */
1099 if (length(scc) > 1) {
1102 /* singleton module in scc; does it import itself? */
1103 mod = findModule ( textOf(hd(scc)) );
1104 assert(nonNull(mod));
1106 for (u = module(mod).uses; nonNull(u); u=tl(u))
1107 if (textOf(hd(u))==textOf(hd(scc)))
1112 moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
1113 moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
1115 moduleGraph = reverse(moduleGraph);
1119 static List /* of CONID */ getModuleImports ( Cell tree )
1125 for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
1127 switch(whatIs(te)) {
1129 use = zfst(unap(M_IMPORT_Q,te));
1131 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
1134 use = zfst(unap(M_IMPORT_UNQ,te));
1136 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
1146 static void processModule ( Module m )
1162 unqualImports = NIL;
1163 foreignImports = NIL;
1164 foreignExports = NIL;
1171 tree = unap(M_MODULE,module(m).tree);
1172 modNm = zfst3(tree);
1174 if (textOf(modNm) != module(m).text) {
1175 ERRMSG(0) "Module name \"%s\" does not match file name \"%s%s\"",
1176 textToStr(textOf(modNm)),
1177 textToStr(module(m).text),
1178 textToStr(module(m).srcExt)
1182 setExportList(zsnd3(tree));
1183 topEnts = zthd3(tree);
1185 for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
1187 assert(isGenPair(te));
1189 switch(whatIs(te)) {
1191 addQualImport(zfst(te2),zsnd(te2));
1194 addUnqualImport(zfst(te2),zsnd(te2));
1197 tyconDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
1200 classDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
1203 instDefn(intOf(zfst3(te2)),zsnd3(te2),zthd3(te2));
1206 defaultDefn(intOf(zfst(te2)),zsnd(te2));
1209 foreignImport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
1210 zsel45(te2),zsel55(te2));
1213 foreignExport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
1214 zsel45(te2),zsel55(te2));
1216 valDefns = cons(te2,valDefns);
1219 internal("processModule");
1228 static Module parseModuleOrInterface ( ConId mc, Cell modeRequest )
1230 /* Allocate a module-table entry. */
1231 /* Parse the entity and fill in the .tree and .uses entries. */
1234 Bool sAvail; Time sTime; Long sSize;
1235 Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1240 Text mt = textOf(mc);
1241 Module mod = findModule ( mt );
1243 /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
1244 textToStr(mt),mod); */
1245 if (nonNull(mod) && !module(mod).fake)
1246 internal("parseModuleOrInterface");
1248 module(mod).fake = FALSE;
1251 mod = newModule(mt);
1253 /* This call malloc-ates path; we should deallocate it. */
1254 ok = findFilesForModule (
1255 textToStr(module(mod).text),
1258 &sAvail, &sTime, &sSize,
1259 &oiAvail, &oiTime, &oSize, &iSize
1262 if (!ok) goto cant_find;
1263 if (!sAvail && !oiAvail) goto cant_find;
1265 /* Find out whether to use source or object. */
1266 switch (modeRequest) {
1268 if (!sAvail) goto cant_find;
1272 if (!oiAvail) goto cant_find;
1276 if ( sAvail && !oiAvail) { useSource = TRUE; break; }
1277 if (!sAvail && oiAvail) { useSource = FALSE; break; }
1278 useSource = firstTimeIsLater ( sTime, oiTime ) ? TRUE : FALSE;
1281 internal("parseModuleOrInterface");
1284 /* Actually do the parsing. */
1286 module(mod).srcExt = findText(sExt);
1287 setCurrentFile(mod);
1289 strcat(name, textToStr(mt));
1291 module(mod).tree = parseModule(name,sSize);
1292 module(mod).uses = getModuleImports(module(mod).tree);
1293 module(mod).mode = FM_SOURCE;
1294 module(mod).lastStamp = sTime;
1296 module(mod).srcExt = findText(HI_ENDING);
1297 setCurrentFile(mod);
1299 strcat(name, textToStr(mt));
1300 strcat(name, DLL_ENDING);
1301 module(mod).objName = findText(name);
1302 module(mod).objSize = oSize;
1304 strcat(name, textToStr(mt));
1305 strcat(name, ".u_hi");
1306 module(mod).tree = parseInterface(name,iSize);
1307 module(mod).uses = getInterfaceImports(module(mod).tree);
1308 module(mod).mode = FM_OBJECT;
1309 module(mod).lastStamp = oiTime;
1312 if (path) free(path);
1316 if (path) free(path);
1319 "Can't find %s for module \"%s\"",
1320 modeToString(modeRequest), textToStr(mt)
1325 static void tryLoadGroup ( Cell grp )
1329 switch (whatIs(grp)) {
1331 m = findModule(textOf(snd(grp)));
1333 if (module(m).mode == FM_SOURCE) {
1334 processModule ( m );
1335 module(m).tree = NIL;
1337 processInterfaces ( singleton(snd(grp)) );
1338 m = findModule(textOf(snd(grp)));
1340 module(m).tree = NIL;
1344 for (t = snd(grp); nonNull(t); t=tl(t)) {
1345 m = findModule(textOf(hd(t)));
1347 if (module(m).mode == FM_SOURCE) {
1348 ERRMSG(0) "Source module \"%s\" imports itself recursively",
1349 textToStr(textOf(hd(t)))
1353 processInterfaces ( snd(grp) );
1354 for (t = snd(grp); nonNull(t); t=tl(t)) {
1355 m = findModule(textOf(hd(t)));
1357 module(m).tree = NIL;
1361 internal("tryLoadGroup");
1366 static void fallBackToPrelModules ( void )
1369 for (m = MODULE_BASE_ADDR;
1370 m < MODULE_BASE_ADDR+tabModuleSz; m++)
1372 && !varIsMember(module(m).text, prelModules))
1377 /* This function catches exceptions in most of the system.
1378 So it's only ok for procedures called from this one
1379 to do EENDs (ie, write error messages). Others should use
1382 static void achieveTargetModules ( Bool loadingThePrelude )
1385 volatile List modgList;
1387 volatile Module mod;
1392 Bool sAvail; Time sTime; Long sSize;
1393 Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1395 volatile Time oisTime;
1396 volatile Bool out_of_date;
1397 volatile List ood_new;
1399 volatile List modgList_new;
1400 volatile List parsedButNotLoaded;
1401 volatile List toChase;
1402 volatile List trans_cl;
1403 volatile List trans_cl_new;
1408 volatile List badMods;
1410 setBreakAction ( HugsIgnoreBreak );
1412 /* First, examine timestamps to find out which modules are
1413 out of date with respect to the source/interface/object files.
1416 modgList = listFromMG();
1418 for (t = modgList; nonNull(t); t=tl(t)) {
1420 if (varIsMember(textOf(hd(t)),prelModules))
1423 mod = findModule(textOf(hd(t)));
1424 if (isNull(mod)) internal("achieveTargetSet(1)");
1426 /* In standalone mode, only succeeds for source modules. */
1427 ok = findFilesForModule (
1428 textToStr(module(mod).text),
1431 &sAvail, &sTime, &sSize,
1432 &oiAvail, &oiTime, &oSize, &iSize
1435 if (!combined && !sAvail) ok = FALSE;
1437 fallBackToPrelModules();
1439 "Can't find source or object+interface for module \"%s\"",
1440 textToStr(module(mod).text)
1442 if (path) free(path);
1446 if (sAvail && oiAvail) {
1447 oisTime = whicheverIsLater(sTime,oiTime);
1449 else if (sAvail && !oiAvail) {
1452 else if (!sAvail && oiAvail) {
1456 internal("achieveTargetSet(2)");
1459 out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
1461 assert(!varIsMember(textOf(hd(t)),ood));
1462 ood = cons(hd(t),ood);
1465 if (path) { free(path); path = NULL; };
1468 /* Second, form a simplistic transitive closure of the out-of-date
1469 modules: a module is out of date if it imports an out-of-date
1474 for (t = modgList; nonNull(t); t=tl(t)) {
1475 mod = findModule(textOf(hd(t)));
1476 assert(nonNull(mod));
1477 for (us = module(mod).uses; nonNull(us); us=tl(us))
1478 if (varIsMember(textOf(hd(us)),ood))
1481 if (varIsMember(textOf(hd(t)),prelModules))
1482 Printf ( "warning: prelude module \"%s\" is out-of-date\n",
1483 textToStr(textOf(hd(t))) );
1485 if (!varIsMember(textOf(hd(t)),ood_new) &&
1486 !varIsMember(textOf(hd(t)),ood))
1487 ood_new = cons(hd(t),ood_new);
1490 if (isNull(ood_new)) break;
1491 ood = appendOnto(ood_new,ood);
1494 /* Now ood holds the entire set of modules which are out-of-date.
1495 Throw them out of the system, yielding a "reduced system",
1496 in which the remaining modules are in-date.
1498 for (t = ood; nonNull(t); t=tl(t)) {
1499 mod = findModule(textOf(hd(t)));
1500 assert(nonNull(mod));
1504 for (t = modgList; nonNull(t); t=tl(t))
1505 if (!varIsMember(textOf(hd(t)),ood))
1506 modgList_new = cons(hd(t),modgList_new);
1507 modgList = modgList_new;
1509 /* Update the module group list to reflect the reduced system.
1510 We do this so that if the following parsing phases fail, we can
1511 safely fall back to the reduced system.
1513 mgFromList ( modgList );
1515 /* Parse modules/interfaces, collecting parse trees and chasing
1516 imports, starting from the target set.
1518 toChase = dupList(targetModules);
1519 for (t = toChase; nonNull(t); t=tl(t)) {
1520 Cell mode = (!combined)
1522 : ( (loadingThePrelude && combined)
1525 hd(t) = zpair(hd(t), mode);
1528 /* toChase :: [ ((ConId, {FM_SOURCE|FM_OBJECT|FM_EITHER} )) ] */
1530 parsedButNotLoaded = NIL;
1533 while (nonNull(toChase)) {
1534 ConId mc = zfst(hd(toChase));
1535 Cell mode = zsnd(hd(toChase));
1536 toChase = tl(toChase);
1537 if (varIsMember(textOf(mc),modgList)
1538 || varIsMember(textOf(mc),parsedButNotLoaded)) {
1539 /* either exists fully, or is at least parsed */
1540 mod = findModule(textOf(mc));
1541 assert(nonNull(mod));
1542 if (!compatibleNewMode(mode,module(mod).mode)) {
1545 "module %s: %s required, but %s is more recent",
1546 textToStr(textOf(mc)), modeToString(mode),
1547 modeToString(module(mod).mode)
1549 goto parseException;
1553 setBreakAction ( HugsLongjmpOnBreak );
1554 if (setjmp(catch_error)==0) {
1555 /* try this; it may throw an exception */
1556 mod = parseModuleOrInterface ( mc, mode );
1558 /* here's the exception handler, if parsing fails */
1559 /* A parse error (or similar). Clean up and abort. */
1561 setBreakAction ( HugsIgnoreBreak );
1562 mod = findModule(textOf(mc));
1563 if (nonNull(mod)) nukeModule(mod);
1564 for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
1565 mod = findModule(textOf(hd(t)));
1566 assert(nonNull(mod));
1567 if (nonNull(mod)) nukeModule(mod);
1570 /* end of the exception handler */
1572 setBreakAction ( HugsIgnoreBreak );
1574 parsedButNotLoaded = cons(mc, parsedButNotLoaded);
1575 for (t = module(mod).uses; nonNull(t); t=tl(t))
1577 zpair( hd(t), childMode(mode,module(mod).mode) ),
1582 modgList = dupOnto(parsedButNotLoaded, modgList);
1584 /* We successfully parsed all modules reachable from the target
1585 set which were not part of the reduced system. However, there
1586 may be modules in the reduced system which are not reachable from
1587 the target set. We detect these now by building the transitive
1588 closure of the target set, and nuking modules in the reduced
1589 system which are not part of that closure.
1591 trans_cl = dupList(targetModules);
1594 for (t = trans_cl; nonNull(t); t=tl(t)) {
1595 mod = findModule(textOf(hd(t)));
1596 assert(nonNull(mod));
1597 for (u = module(mod).uses; nonNull(u); u=tl(u))
1598 if (!varIsMember(textOf(hd(u)),trans_cl)
1599 && !varIsMember(textOf(hd(u)),trans_cl_new)
1600 && !varIsMember(textOf(hd(u)),prelModules))
1601 trans_cl_new = cons(hd(u),trans_cl_new);
1603 if (isNull(trans_cl_new)) break;
1604 trans_cl = appendOnto(trans_cl_new,trans_cl);
1607 for (t = modgList; nonNull(t); t=tl(t)) {
1608 if (varIsMember(textOf(hd(t)),trans_cl)) {
1609 modgList_new = cons(hd(t),modgList_new);
1611 mod = findModule(textOf(hd(t)));
1612 assert(nonNull(mod));
1616 modgList = modgList_new;
1618 /* Now, the module symbol tables hold exactly the set of
1619 modules reachable from the target set, and modgList holds
1620 their names. Calculate the scc-ified module graph,
1621 since we need that to guide the next stage, that of
1622 Actually Loading the modules.
1624 If no errors occur, moduleGraph will reflect the final graph
1625 loaded. If an error occurs loading a group, we nuke
1626 that group, truncate the moduleGraph just prior to that
1627 group, and exit. That leaves the system having successfully
1628 loaded all groups prior to the one which failed.
1630 mgFromList ( modgList );
1632 for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
1635 if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
1636 parsedButNotLoaded)) continue;
1638 setBreakAction ( HugsLongjmpOnBreak );
1639 if (setjmp(catch_error)==0) {
1640 /* try this; it may throw an exception */
1643 /* here's the exception handler, if static/typecheck etc fails */
1644 /* nuke the entire rest (ie, the unloaded part)
1645 of the module graph */
1646 setBreakAction ( HugsIgnoreBreak );
1647 badMods = listFromSpecifiedMG ( mg );
1648 for (t = badMods; nonNull(t); t=tl(t)) {
1649 mod = findModule(textOf(hd(t)));
1650 if (nonNull(mod)) nukeModule(mod);
1652 /* truncate the module graph just prior to this group. */
1656 if (isNull(mg)) break;
1657 if (hd(mg) == grp) break;
1658 mg2 = cons ( hd(mg), mg2 );
1661 moduleGraph = reverse(mg2);
1663 /* end of the exception handler */
1665 setBreakAction ( HugsIgnoreBreak );
1668 /* Err .. I think that's it. If we get here, we've successfully
1669 achieved the target set. Phew!
1671 setBreakAction ( HugsIgnoreBreak );
1675 static Bool loadThePrelude ( void )
1680 moduleGraph = prelModules = NIL;
1683 conPrelude = mkCon(findText("Prelude"));
1684 conPrelHugs = mkCon(findText("PrelHugs"));
1685 targetModules = doubleton(conPrelude,conPrelHugs);
1686 achieveTargetModules(TRUE);
1687 ok = elemMG(conPrelude) && elemMG(conPrelHugs);
1689 conPrelude = mkCon(findText("Prelude"));
1690 targetModules = singleton(conPrelude);
1691 achieveTargetModules(TRUE);
1692 ok = elemMG(conPrelude);
1695 if (ok) prelModules = listFromMG();
1700 /* Refresh the current target modules, and attempt to set the
1701 current module to what it was before (ie currentModule):
1702 if currentModule_failed is different from currentModule,
1704 if nextCurrMod is non null, try to set it to that instead
1705 if the one we're after insn't available, select a target
1706 from the end of the module group list.
1708 static void refreshActions ( ConId nextCurrMod, Bool cleanAfter )
1713 /* Remember what the old current module was. */
1714 tryFor = mkCon(module(currentModule).text);
1716 /* Do the Real Work. */
1717 achieveTargetModules(FALSE);
1719 /* Remember if the current module was invalidated by this
1720 refresh, so later refreshes can attempt to reload it. */
1721 if (!elemMG(tryFor))
1722 currentModule_failed = tryFor;
1724 /* If a previous refresh failed to get an old current module,
1725 try for that instead. */
1726 if (nonNull(currentModule_failed)
1727 && textOf(currentModule_failed) != textOf(tryFor)
1728 && elemMG(currentModule_failed))
1729 tryFor = currentModule_failed;
1730 /* If our caller specified a new current module, that overrides
1731 all historical settings. */
1732 if (nonNull(nextCurrMod))
1733 tryFor = nextCurrMod;
1734 /* Finally, if we can't actually get hold of whatever it was we
1735 were after, select something which is possible. */
1736 if (!elemMG(tryFor))
1737 tryFor = selectLatestMG();
1739 /* combined mode kludge, to get Prelude rather than PrelHugs */
1740 if (combined && textOf(tryFor)==findText("PrelHugs"))
1741 tryFor = mkCon(findText("Prelude"));
1744 /* delete any targetModules which didn't actually get loaded */
1746 targetModules = NIL;
1747 for (; nonNull(t); t=tl(t))
1749 targetModules = cons(hd(t),targetModules);
1752 setCurrModule ( findModule(textOf(tryFor)) );
1753 Printf("Hugs session for:\n");
1758 static void addActions ( List extraModules /* :: [CONID] */ )
1761 for (t = extraModules; nonNull(t); t=tl(t)) {
1762 ConId extra = hd(t);
1763 if (!varIsMember(textOf(extra),targetModules))
1764 targetModules = cons(extra,targetModules);
1766 refreshActions ( isNull(extraModules)
1768 : hd(reverse(extraModules)),
1774 static void loadActions ( List loadModules /* :: [CONID] */ )
1777 targetModules = dupList ( prelModules );
1779 for (t = loadModules; nonNull(t); t=tl(t)) {
1781 if (!varIsMember(textOf(load),targetModules))
1782 targetModules = cons(load,targetModules);
1784 refreshActions ( isNull(loadModules)
1786 : hd(reverse(loadModules)),
1792 /* --------------------------------------------------------------------------
1793 * Access to external editor:
1794 * ------------------------------------------------------------------------*/
1796 /* ToDo: All this editor stuff needs fixing. */
1798 static Void local editor() { /* interpreter-editor interface */
1800 String newFile = readFilename();
1802 setLastEdit(newFile,0);
1803 if (readFilename()) {
1804 ERRMSG(0) "Multiple filenames not permitted"
1812 static Void local find() { /* edit file containing definition */
1815 String nm = readFilename(); /* of specified name */
1817 ERRMSG(0) "No name specified"
1820 else if (readFilename()) {
1821 ERRMSG(0) "Multiple names not permitted"
1827 setCurrModule(findEvalModule());
1829 if (nonNull(c=findTycon(t=findText(nm)))) {
1830 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1831 readScripts(N_PRELUDE_SCRIPTS);
1833 } else if (nonNull(c=findName(t))) {
1834 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1835 readScripts(N_PRELUDE_SCRIPTS);
1838 ERRMSG(0) "No current definition for name \"%s\"", nm
1845 static Void local runEditor() { /* run editor on script lastEdit */
1847 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1848 readScripts(N_PRELUDE_SCRIPTS);
1852 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1858 lastEdit = strCopy(fname);
1863 /* --------------------------------------------------------------------------
1864 * Read and evaluate an expression:
1865 * ------------------------------------------------------------------------*/
1867 static Void setModule ( void ) {
1868 /*set module in which to evaluate expressions*/
1871 String s = readFilename();
1873 mc = selectLatestMG();
1874 if (combined && textOf(mc)==findText("PrelHugs"))
1875 mc = mkCon(findText("Prelude"));
1876 m = findModule(textOf(mc));
1879 m = findModule(findText(s));
1881 ERRMSG(0) "Cannot find module \"%s\"", s
1889 static Module allocEvalModule ( void )
1891 Module evalMod = newModule( findText("_Eval_Module_") );
1892 module(evalMod).names = module(currentModule).names;
1893 module(evalMod).tycons = module(currentModule).tycons;
1894 module(evalMod).classes = module(currentModule).classes;
1895 module(evalMod).qualImports
1896 = singleton(pair(mkCon(textPrelude),modulePrelude));
1900 static Void local evaluator() { /* evaluate expr and print value */
1903 volatile Kinds ks = NIL;
1904 volatile Module evalMod = allocEvalModule();
1905 volatile Module currMod = currentModule;
1906 setCurrModule(evalMod);
1909 defaultDefns = combined ? stdDefaults : evalDefaults;
1911 setBreakAction ( HugsLongjmpOnBreak );
1912 if (setjmp(catch_error)==0) {
1916 type = typeCheckExp(TRUE);
1918 /* if an exception happens, we arrive here */
1919 setBreakAction ( HugsIgnoreBreak );
1920 goto cleanup_and_return;
1923 setBreakAction ( HugsIgnoreBreak );
1924 if (isPolyType(type)) {
1925 ks = polySigOf(type);
1926 bd = monotypeOf(type);
1931 if (whatIs(bd)==QUAL) {
1934 ERRMSG(0) "Unresolved overloading" ETHEN
1935 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1936 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1939 goto cleanup_and_return;
1945 if (isProgType(ks,bd)) {
1946 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1950 Cell d = provePred(ks,NIL,ap(classShow,bd));
1954 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1955 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1956 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1959 goto cleanup_and_return;
1961 inputExpr = ap2(nameShow, d,inputExpr);
1962 inputExpr = ap (namePutStr, inputExpr);
1963 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1965 evalExp(); printf("\n");
1968 printType(stdout,type);
1975 printf ( "result type is " );
1976 printType ( stdout, type );
1984 setBreakAction ( HugsIgnoreBreak );
1985 nukeModule(evalMod);
1986 setCurrModule(currMod);
1987 setCurrentFile(currMod);
1993 /* --------------------------------------------------------------------------
1994 * Print type of input expression:
1995 * ------------------------------------------------------------------------*/
1997 static Void showtype ( void ) { /* print type of expression (if any)*/
2000 volatile Module evalMod = allocEvalModule();
2001 volatile Module currMod = currentModule;
2002 setCurrModule(evalMod);
2004 if (setjmp(catch_error)==0) {
2008 defaultDefns = evalDefaults;
2009 type = typeCheckExp(FALSE);
2010 printExp(stdout,inputExpr);
2012 printType(stdout,type);
2015 /* if an exception happens, we arrive here */
2018 nukeModule(evalMod);
2019 setCurrModule(currMod);
2023 static Void local browseit(mod,t,all)
2030 Printf("module %s where\n",textToStr(module(mod).text));
2031 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
2033 /* only look at things defined in this module,
2034 unless `all' flag is set */
2035 if (all || name(nm).mod == mod) {
2036 /* unwanted artifacts, like lambda lifted values,
2037 are in the list of names, but have no types */
2038 if (nonNull(name(nm).type)) {
2039 printExp(stdout,nm);
2041 printType(stdout,name(nm).type);
2043 Printf(" -- data constructor");
2044 } else if (isMfun(nm)) {
2045 Printf(" -- class member");
2046 } else if (isSfun(nm)) {
2047 Printf(" -- selector function");
2055 Printf("Unknown module %s\n",t);
2060 static Void local browse() { /* browse modules */
2061 Int count = 0; /* or give menu of commands */
2065 for (; (s=readFilename())!=0; count++)
2066 if (strcmp(s,"all") == 0) {
2070 browseit(findModule(findText(s)),s,all);
2072 browseit(currentModule,NULL,all);
2076 #if EXPLAIN_INSTANCE_RESOLUTION
2077 static Void local xplain() { /* print type of expression (if any)*/
2079 Bool sir = showInstRes;
2081 setCurrModule(findEvalModule());
2082 startNewScript(0); /* Enables recovery of storage */
2083 /* allocated during evaluation */
2087 d = provePred(NIL,NIL,hd(inputContext));
2089 fprintf(stdout, "not Sat\n");
2091 fprintf(stdout, "Sat\n");
2097 /* --------------------------------------------------------------------------
2098 * Enhanced help system: print current list of scripts or give information
2100 * ------------------------------------------------------------------------*/
2102 static String local objToStr(m,c)
2105 #if 1 || DISPLAY_QUANTIFIERS
2106 static char newVar[60];
2107 switch (whatIs(c)) {
2108 case NAME : if (m == name(c).mod) {
2109 sprintf(newVar,"%s", textToStr(name(c).text));
2111 sprintf(newVar,"%s.%s",
2112 textToStr(module(name(c).mod).text),
2113 textToStr(name(c).text));
2117 case TYCON : if (m == tycon(c).mod) {
2118 sprintf(newVar,"%s", textToStr(tycon(c).text));
2120 sprintf(newVar,"%s.%s",
2121 textToStr(module(tycon(c).mod).text),
2122 textToStr(tycon(c).text));
2126 case CLASS : if (m == cclass(c).mod) {
2127 sprintf(newVar,"%s", textToStr(cclass(c).text));
2129 sprintf(newVar,"%s.%s",
2130 textToStr(module(cclass(c).mod).text),
2131 textToStr(cclass(c).text));
2135 default : internal("objToStr");
2139 static char newVar[33];
2140 switch (whatIs(c)) {
2141 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
2144 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
2147 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
2150 default : internal("objToStr");
2158 static Void dumpStg ( void )
2164 setCurrModule(findEvalModule());
2169 /* request to locate a symbol by name */
2170 if (s && (*s == '?')) {
2171 Text t = findText(s+1);
2172 locateSymbolByName(t);
2176 /* request to dump a bit of the heap */
2177 if (s && (*s == '-' || isdigit(*s))) {
2184 /* request to dump a symbol table entry */
2186 || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
2187 || !isdigit(s[1])) {
2188 fprintf(stderr, ":d -- bad request `%s'\n", s );
2193 case 't': dumpTycon(i); break;
2194 case 'n': dumpName(i); break;
2195 case 'c': dumpClass(i); break;
2196 case 'i': dumpInst(i); break;
2197 default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
2203 static Void local dumpStg( void ) { /* print STG stuff */
2208 Cell v; /* really StgVar */
2209 setCurrModule(findEvalModule());
2211 for (; (s=readFilename())!=0;) {
2214 /* find the name while ignoring module scopes */
2215 for (i=NAMEMIN; i<nameHw; i++)
2216 if (name(i).text == t) n = i;
2218 /* perhaps it's an "idNNNNNN" thing? */
2221 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2224 while (isdigit(s[i])) {
2225 v = v * 10 + (s[i]-'0');
2229 n = nameFromStgVar(v);
2232 if (isNull(n) && whatIs(v)==STGVAR) {
2233 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2234 printStg(stderr, v );
2237 Printf ( "Unknown reference `%s'\n", s );
2240 Printf ( "Not a Name: `%s'\n", s );
2242 if (isNull(name(n).stgVar)) {
2243 Printf ( "Doesn't have a STG tree: %s\n", s );
2245 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2246 printStg(stderr, name(n).stgVar);
2252 static Void local info() { /* describe objects */
2253 Int count = 0; /* or give menu of commands */
2256 for (; (s=readFilename())!=0; count++) {
2257 describe(findText(s));
2260 /* whatScripts(); */
2265 static Void local describe(t) /* describe an object */
2267 Tycon tc = findTycon(t);
2268 Class cl = findClass(t);
2269 Name nm = findName(t);
2271 if (nonNull(tc)) { /* as a type constructor */
2275 for (i=0; i<tycon(tc).arity; ++i) {
2276 t = ap(t,mkOffset(i));
2278 Printf("-- type constructor");
2280 Printf(" with kind ");
2281 printKind(stdout,tycon(tc).kind);
2284 switch (tycon(tc).what) {
2285 case SYNONYM : Printf("type ");
2286 printType(stdout,t);
2288 printType(stdout,tycon(tc).defn);
2292 case DATATYPE : { List cs = tycon(tc).defn;
2293 if (tycon(tc).what==DATATYPE) {
2298 printType(stdout,t);
2300 mapProc(printSyntax,cs);
2302 Printf("\n-- constructors:");
2304 for (; hasCfun(cs); cs=tl(cs)) {
2306 printExp(stdout,hd(cs));
2308 printType(stdout,name(hd(cs)).type);
2311 Printf("\n-- selectors:");
2313 for (; nonNull(cs); cs=tl(cs)) {
2315 printExp(stdout,hd(cs));
2317 printType(stdout,name(hd(cs)).type);
2322 case RESTRICTSYN : Printf("type ");
2323 printType(stdout,t);
2324 Printf(" = <restricted>");
2328 if (nonNull(in=findFirstInst(tc))) {
2329 Printf("\n-- instances:\n");
2332 in = findNextInst(tc,in);
2333 } while (nonNull(in));
2338 if (nonNull(cl)) { /* as a class */
2339 List ins = cclass(cl).instances;
2340 Kinds ks = cclass(cl).kinds;
2341 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2342 Printf("-- type class");
2344 Printf("-- constructor class");
2346 Printf(" with arity ");
2347 printKinds(stdout,ks);
2351 mapProc(printSyntax,cclass(cl).members);
2353 if (nonNull(cclass(cl).supers)) {
2354 printContext(stdout,cclass(cl).supers);
2357 printPred(stdout,cclass(cl).head);
2359 if (nonNull(cclass(cl).fds)) {
2360 List fds = cclass(cl).fds;
2362 for (; nonNull(fds); fds=tl(fds)) {
2364 printFD(stdout,hd(fds));
2369 if (nonNull(cclass(cl).members)) {
2370 List ms = cclass(cl).members;
2373 Type t = name(hd(ms)).type;
2374 if (isPolyType(t)) {
2378 printExp(stdout,hd(ms));
2380 if (isNull(tl(fst(snd(t))))) {
2383 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2385 printType(stdout,t);
2387 } while (nonNull(ms));
2391 Printf("\n-- instances:\n");
2395 } while (nonNull(ins));
2400 if (nonNull(nm)) { /* as a function/name */
2402 printExp(stdout,nm);
2404 if (nonNull(name(nm).type)) {
2405 printType(stdout,name(nm).type);
2407 Printf("<unknown type>");
2410 Printf(" -- data constructor");
2411 } else if (isMfun(nm)) {
2412 Printf(" -- class member");
2413 } else if (isSfun(nm)) {
2414 Printf(" -- selector function");
2420 if (isNull(tc) && isNull(cl) && isNull(nm)) {
2421 Printf("Unknown reference `%s'\n",textToStr(t));
2425 static Void local printSyntax(nm)
2427 Syntax sy = syntaxOf(nm);
2428 Text t = name(nm).text;
2429 String s = textToStr(t);
2430 if (sy != defaultSyntax(t)) {
2432 switch (assocOf(sy)) {
2433 case LEFT_ASS : Putchar('l'); break;
2434 case RIGHT_ASS : Putchar('r'); break;
2435 case NON_ASS : break;
2437 Printf(" %i ",precOf(sy));
2438 if (isascii((int)(*s)) && isalpha((int)(*s))) {
2447 static Void local showInst(in) /* Display instance decl header */
2449 Printf("instance ");
2450 if (nonNull(inst(in).specifics)) {
2451 printContext(stdout,inst(in).specifics);
2454 printPred(stdout,inst(in).head);
2458 /* --------------------------------------------------------------------------
2459 * List all names currently in scope:
2460 * ------------------------------------------------------------------------*/
2462 static Void local listNames() { /* list names matching optional pat*/
2463 String pat = readFilename();
2468 Module mod = currentModule;
2470 if (pat) { /* First gather names to list */
2472 names = addNamesMatching(pat,names);
2473 } while ((pat=readFilename())!=0);
2475 names = addNamesMatching((String)0,names);
2477 if (isNull(names)) { /* Then print them out */
2479 ERRMSG(0) "No names selected"
2483 for (termPos=0; nonNull(names); names=tl(names)) {
2484 String s = objToStr(mod,hd(names));
2486 if (termPos+1+l>width) {
2489 } else if (termPos>0) {
2497 Printf("\n(%d names listed)\n", count);
2500 /* --------------------------------------------------------------------------
2501 * print a prompt and read a line of input:
2502 * ------------------------------------------------------------------------*/
2504 static Void local promptForInput(moduleName)
2505 String moduleName; {
2506 char promptBuffer[1000];
2508 /* This is portable but could overflow buffer */
2509 sprintf(promptBuffer,prompt,moduleName);
2511 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2512 * promptBuffer instead.
2514 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2515 /* Reset prompt to a safe default to avoid an infinite loop */
2517 prompt = strCopy("? ");
2518 internal("Combined prompt and evaluation module name too long");
2522 stringInput("main\0"); else
2523 consoleInput(promptBuffer);
2526 /* --------------------------------------------------------------------------
2527 * main read-eval-print loop, with error trapping:
2528 * ------------------------------------------------------------------------*/
2530 static Void local interpreter(argc,argv)/* main interpreter loop */
2534 List modConIds; /* :: [CONID] */
2538 setBreakAction ( HugsIgnoreBreak );
2539 modConIds = initialize(argc,argv); /* the initial modules to load */
2540 setBreakAction ( HugsIgnoreBreak );
2541 prelOK = loadThePrelude();
2545 fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2547 fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2551 if (combined) everybody(POSTPREL);
2552 loadActions(modConIds);
2555 for (; nonNull(modConIds); modConIds=tl(modConIds))
2556 if (!elemMG(hd(modConIds))) {
2558 "hugs +Q: compilation failed -- can't run `main'\n" );
2565 /* initialize calls startupHaskell, which trashes our signal handlers */
2566 setBreakAction ( HugsIgnoreBreak );
2571 everybody(RESET); /* reset to sensible initial state */
2573 promptForInput(textToStr(module(currentModule).text));
2575 cmd = readCommand(cmds, (Char)':', (Char)'!');
2577 case EDIT : editor();
2581 case LOAD : modConIds = NIL;
2582 while ((s=readFilename())!=0) {
2583 modConIds = cons(mkCon(findText(s)),modConIds);
2586 loadActions(modConIds);
2589 case ALSO : modConIds = NIL;
2590 while ((s=readFilename())!=0)
2591 modConIds = cons(mkCon(findText(s)),modConIds);
2592 addActions(modConIds);
2595 case RELOAD : refreshActions(NIL,FALSE);
2600 case EVAL : evaluator();
2602 case TYPEOF : showtype();
2604 case BROWSE : browse();
2606 #if EXPLAIN_INSTANCE_RESOLUTION
2607 case XPLAIN : xplain();
2610 case NAMES : listNames();
2614 case BADCMD : guidance();
2618 case SYSTEM : if (shellEsc(readLine()))
2619 Printf("Warning: Shell escape terminated abnormally\n");
2621 case CHGDIR : changeDir();
2625 case PNTVER: Printf("-- Hugs Version %s\n",
2628 case DUMP : dumpStg();
2631 case COLLECT: consGC = FALSE;
2634 Printf("Garbage collection recovered %d cells\n",
2640 if (autoMain) break;
2644 /* --------------------------------------------------------------------------
2645 * Display progress towards goal:
2646 * ------------------------------------------------------------------------*/
2648 static Target currTarget;
2649 static Bool aiming = FALSE;
2652 static Int charCount;
2654 Void setGoal(what, t) /* Set goal for what to be t */
2659 #if EXPLAIN_INSTANCE_RESOLUTION
2663 currTarget = (t?t:1);
2665 for (charCount=0; *what; charCount++)
2670 Void soFar(t) /* Indicate progress towards goal */
2671 Target t; { /* has now reached t */
2674 #if EXPLAIN_INSTANCE_RESOLUTION
2680 Void done() { /* Goal has now been achieved */
2683 #if EXPLAIN_INSTANCE_RESOLUTION
2687 for (; charCount>0; charCount--) {
2696 static Void local failed() { /* Goal cannot be reached due to */
2697 if (aiming) { /* errors */
2704 /* --------------------------------------------------------------------------
2706 * ------------------------------------------------------------------------*/
2708 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
2709 if (printing) { /* after successful termination or */
2710 printing = FALSE; /* runtime error (e.g. interrupt) */
2713 #define plural(v) v, (v==1?"":"s")
2714 Printf("(%lu enter%s)\n",plural(numEnters));
2722 Cell errAssert(l) /* message to use when raising asserts, etc */
2726 str = mkStr(findText(currentFile));
2728 str = mkStr(findText(""));
2730 return (ap2(nameTangleMessage,str,mkInt(l)));
2733 Void errHead(l) /* print start of error message */
2735 failed(); /* failed to reach target ... */
2737 FPrintf(errorStream,"ERROR");
2740 FPrintf(errorStream," \"%s\"", currentFile);
2741 setLastEdit(currentFile,l);
2742 if (l) FPrintf(errorStream," (line %d)",l);
2745 FPrintf(errorStream,": ");
2746 FFlush(errorStream);
2749 Void errFail() { /* terminate error message and */
2750 Putc('\n',errorStream); /* produce exception to return to */
2751 FFlush(errorStream); /* main command loop */
2752 longjmp(catch_error,1);
2755 Void errFail_no_longjmp() { /* terminate error message but */
2756 Putc('\n',errorStream); /* don't produce an exception */
2757 FFlush(errorStream);
2760 Void errAbort() { /* altern. form of error handling */
2761 failed(); /* used when suitable error message*/
2762 stopAnyPrinting(); /* has already been printed */
2766 Void internal(msg) /* handle internal error */
2770 Printf("INTERNAL ERROR: %s\n",msg);
2773 longjmp(catch_error,1);
2776 Void fatal(msg) /* handle fatal error */
2779 Printf("\nFATAL ERROR: %s\n",msg);
2785 /* --------------------------------------------------------------------------
2786 * Read value from environment variable or registry:
2787 * ------------------------------------------------------------------------*/
2789 String fromEnv(var,def) /* return value of: */
2790 String var; /* environment variable named by var */
2791 String def; { /* or: default value given by def */
2792 String s = getenv(var);
2793 return (s ? s : def);
2796 /* --------------------------------------------------------------------------
2797 * String manipulation routines:
2798 * ------------------------------------------------------------------------*/
2800 static String local strCopy(s) /* make malloced copy of a string */
2804 if ((t=(char *)malloc(strlen(s)+1))==0) {
2805 ERRMSG(0) "String storage space exhausted"
2808 for (r=t; (*r++ = *s++)!=0; ) {
2816 /* --------------------------------------------------------------------------
2818 * We can redirect compiler output (prompts, error messages, etc) by
2819 * tweaking these functions.
2820 * ------------------------------------------------------------------------*/
2822 #ifdef HAVE_STDARG_H
2825 #include <varargs.h>
2828 Void hugsEnableOutput(f)
2833 #ifdef HAVE_STDARG_H
2834 Void hugsPrintf(const char *fmt, ...) {
2835 va_list ap; /* pointer into argument list */
2836 va_start(ap, fmt); /* make ap point to first arg after fmt */
2837 if (!disableOutput) {
2841 va_end(ap); /* clean up */
2844 Void hugsPrintf(fmt, va_alist)
2847 va_list ap; /* pointer into argument list */
2848 va_start(ap); /* make ap point to first arg after fmt */
2849 if (!disableOutput) {
2853 va_end(ap); /* clean up */
2859 if (!disableOutput) {
2865 Void hugsFlushStdout() {
2866 if (!disableOutput) {
2873 if (!disableOutput) {
2878 #ifdef HAVE_STDARG_H
2879 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2882 if (!disableOutput) {
2883 vfprintf(fp, fmt, ap);
2889 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2895 if (!disableOutput) {
2896 vfprintf(fp, fmt, ap);
2903 Void hugsPutc(c, fp)
2906 if (!disableOutput) {
2912 /* --------------------------------------------------------------------------
2913 * Send message to each component of system:
2914 * ------------------------------------------------------------------------*/
2916 Void everybody(what) /* send command `what' to each component of*/
2917 Int what; { /* system to respond as appropriate ... */
2919 fprintf ( stderr, "EVERYBODY %d\n", what );
2921 machdep(what); /* The order of calling each component is */
2922 storage(what); /* important for the PREPREL command */
2925 translateControl(what);
2927 staticAnalysis(what);
2928 deriveControl(what);
2937 mark(targetModules);
2939 mark(currentModule_failed);
2943 /*-------------------------------------------------------------------------*/