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/28 10:42:17 $
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 # if defined(mingw32_TARGET_OS)
878 /* Be wierd. You can't longjmp in a signal handler,
879 and posix signals are not supported.
881 if (newAction == HugsRtsInterrupt) {
882 setHandler ( handler_RtsInterrupt );
884 signal(SIGINT,SIG_IGN);
889 case HugsIgnoreBreak:
890 setHandler ( handler_IgnoreBreak ); break;
891 case HugsLongjmpOnBreak:
892 setHandler ( handler_LongjmpOnBreak ); break;
893 case HugsRtsInterrupt:
894 setHandler ( handler_RtsInterrupt ); break;
896 internal("setBreakAction");
904 /* --------------------------------------------------------------------------
905 * The new module chaser, loader, etc
906 * ------------------------------------------------------------------------*/
908 List moduleGraph = NIL;
909 List prelModules = NIL;
910 List targetModules = NIL;
912 static String modeToString ( Cell mode )
915 case FM_SOURCE: return "source";
916 case FM_OBJECT: return "object";
917 case FM_EITHER: return "source or object";
918 default: internal("modeToString");
922 static Cell childMode ( Cell modeMeRequest, Cell modeMeActual )
924 assert(modeMeActual == FM_SOURCE ||
925 modeMeActual == FM_OBJECT);
926 assert(modeMeRequest == FM_SOURCE ||
927 modeMeRequest == FM_OBJECT ||
928 modeMeRequest == FM_EITHER);
929 if (modeMeRequest == FM_SOURCE) return modeMeRequest;
930 if (modeMeRequest == FM_OBJECT) return modeMeRequest;
931 if (modeMeActual == FM_OBJECT) return FM_OBJECT;
932 if (modeMeActual == FM_SOURCE) return FM_EITHER;
933 internal("childMode");
936 static Bool compatibleNewMode ( Cell modeNew, Cell modeExisting )
938 if (modeNew == FM_OBJECT && modeExisting == FM_OBJECT) return TRUE;
939 if (modeNew == FM_SOURCE && modeExisting == FM_SOURCE) return TRUE;
940 if (modeNew == FM_EITHER && modeExisting == FM_OBJECT) return TRUE;
941 if (modeNew == FM_EITHER && modeExisting == FM_SOURCE) return TRUE;
945 static void setCurrentFile ( Module mod )
947 assert(isModule(mod));
948 strncpy(currentFileName, textToStr(module(mod).text), 990);
949 strcat(currentFileName, textToStr(module(mod).srcExt));
950 currentFile = currentFileName;
951 moduleBeingParsed = mod;
954 static void clearCurrentFile ( void )
957 moduleBeingParsed = NIL;
960 static void ppMG ( void )
963 for (t = moduleGraph; nonNull(t); t=tl(t)) {
967 Printf ( " %s\n", textToStr(textOf(snd(u))));
971 for (v = snd(u); nonNull(v); v=tl(v))
972 Printf ( "%s ", textToStr(textOf(hd(v))) );
982 static Bool elemMG ( ConId mod )
985 for (gs = moduleGraph; nonNull(gs); gs=tl(gs))
986 switch (whatIs(hd(gs))) {
988 if (textOf(mod)==textOf(snd(hd(gs)))) return TRUE;
991 if (varIsMember(textOf(mod),snd(hd(gs)))) return TRUE;
1000 static ConId selectArbitrarilyFromGroup ( Cell group )
1002 switch (whatIs(group)) {
1003 case GRP_NONREC: return snd(group);
1004 case GRP_REC: return hd(snd(group));
1005 default: internal("selectArbitrarilyFromGroup");
1009 static ConId selectLatestMG ( void )
1011 List gs = moduleGraph;
1012 if (isNull(gs)) internal("selectLatestMG(1)");
1013 while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs);
1014 return selectArbitrarilyFromGroup(hd(gs));
1018 static List /* of CONID */ listFromSpecifiedMG ( List mg )
1022 for (gs = mg; nonNull(gs); gs=tl(gs)) {
1023 switch (whatIs(hd(gs))) {
1024 case GRP_REC: cs = appendOnto(cs,snd(hd(gs))); break;
1025 case GRP_NONREC: cs = cons(snd(hd(gs)),cs); break;
1026 default: internal("listFromSpecifiedMG");
1032 static List /* of CONID */ listFromMG ( void )
1034 return listFromSpecifiedMG ( moduleGraph );
1038 /* Calculate the strongly connected components of modgList
1039 and assign them to moduleGraph. Uses the .uses field of
1040 each of the modules to build the graph structure.
1042 #define SCC modScc /* make scc algorithm for StgVars */
1043 #define LOWLINK modLowlink
1044 #define DEPENDS(t) snd(t)
1045 #define SETDEPENDS(c,v) snd(c)=v
1052 static void mgFromList ( List /* of CONID */ modgList )
1058 List adjList; /* :: [ (Text, [Text]) ] */
1064 for (t = modgList; nonNull(t); t=tl(t)) {
1066 mod = findModule(mT);
1067 assert(nonNull(mod));
1069 for (u = module(mod).uses; nonNull(u); u=tl(u))
1070 usesT = cons(textOf(hd(u)),usesT);
1072 /* artificially give all modules a dependency on Prelude */
1073 if (mT != textPrelude && mT != textPrelPrim)
1074 usesT = cons(textPrelude,usesT);
1075 adjList = cons(pair(mT,usesT),adjList);
1078 /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
1079 Modify this so that the adjacency list is a list of pointers
1080 back to bits of adjList -- that's what modScc needs.
1082 for (t = adjList; nonNull(t); t=tl(t)) {
1084 /* for each elem of the adjacency list ... */
1085 for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
1088 /* find the element of adjList whose fst is a */
1089 for (v = adjList; nonNull(v); v=tl(v)) {
1091 assert(isText(fst(hd(v))));
1092 if (fst(hd(v))==a) break;
1094 if (isNull(v)) internal("mgFromList");
1095 adj = cons(hd(v),adj);
1100 adjList = modScc ( adjList );
1101 /* adjList is now [ [(module-text, aux-info-field)] ] */
1105 for (t = adjList; nonNull(t); t=tl(t)) {
1108 /* scc :: [ (module-text, aux-info-field) ] */
1109 for (u = scc; nonNull(u); u=tl(u))
1110 hd(u) = mkCon(fst(hd(u)));
1112 /* scc :: [CONID] */
1113 if (length(scc) > 1) {
1116 /* singleton module in scc; does it import itself? */
1117 mod = findModule ( textOf(hd(scc)) );
1118 assert(nonNull(mod));
1120 for (u = module(mod).uses; nonNull(u); u=tl(u))
1121 if (textOf(hd(u))==textOf(hd(scc)))
1126 moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
1127 moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
1129 moduleGraph = reverse(moduleGraph);
1133 static List /* of CONID */ getModuleImports ( Cell tree )
1139 for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
1141 switch(whatIs(te)) {
1143 use = zfst(unap(M_IMPORT_Q,te));
1145 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
1148 use = zfst(unap(M_IMPORT_UNQ,te));
1150 if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
1160 static void processModule ( Module m )
1176 unqualImports = NIL;
1177 foreignImports = NIL;
1178 foreignExports = NIL;
1185 tree = unap(M_MODULE,module(m).tree);
1186 modNm = zfst3(tree);
1188 if (textOf(modNm) != module(m).text) {
1189 ERRMSG(0) "Module name \"%s\" does not match file name \"%s%s\"",
1190 textToStr(textOf(modNm)),
1191 textToStr(module(m).text),
1192 textToStr(module(m).srcExt)
1196 setExportList(zsnd3(tree));
1197 topEnts = zthd3(tree);
1199 for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
1201 assert(isGenPair(te));
1203 switch(whatIs(te)) {
1205 addQualImport(zfst(te2),zsnd(te2));
1208 addUnqualImport(zfst(te2),zsnd(te2));
1211 tyconDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
1214 classDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
1217 instDefn(intOf(zfst3(te2)),zsnd3(te2),zthd3(te2));
1220 defaultDefn(intOf(zfst(te2)),zsnd(te2));
1223 foreignImport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
1224 zsel45(te2),zsel55(te2));
1227 foreignExport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
1228 zsel45(te2),zsel55(te2));
1230 valDefns = cons(te2,valDefns);
1233 internal("processModule");
1242 static Module parseModuleOrInterface ( ConId mc, Cell modeRequest )
1244 /* Allocate a module-table entry. */
1245 /* Parse the entity and fill in the .tree and .uses entries. */
1248 Bool sAvail; Time sTime; Long sSize;
1249 Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1254 Text mt = textOf(mc);
1255 Module mod = findModule ( mt );
1257 /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
1258 textToStr(mt),mod); */
1259 if (nonNull(mod) && !module(mod).fake)
1260 internal("parseModuleOrInterface");
1262 module(mod).fake = FALSE;
1265 mod = newModule(mt);
1267 /* This call malloc-ates path; we should deallocate it. */
1268 ok = findFilesForModule (
1269 textToStr(module(mod).text),
1272 &sAvail, &sTime, &sSize,
1273 &oiAvail, &oiTime, &oSize, &iSize
1276 if (!ok) goto cant_find;
1277 if (!sAvail && !oiAvail) goto cant_find;
1279 /* Find out whether to use source or object. */
1280 switch (modeRequest) {
1282 if (!sAvail) goto cant_find;
1286 if (!oiAvail) goto cant_find;
1290 if ( sAvail && !oiAvail) { useSource = TRUE; break; }
1291 if (!sAvail && oiAvail) { useSource = FALSE; break; }
1292 useSource = firstTimeIsLater ( sTime, oiTime ) ? TRUE : FALSE;
1295 internal("parseModuleOrInterface");
1298 /* Actually do the parsing. */
1300 module(mod).srcExt = findText(sExt);
1301 setCurrentFile(mod);
1303 strcat(name, textToStr(mt));
1305 module(mod).tree = parseModule(name,sSize);
1306 module(mod).uses = getModuleImports(module(mod).tree);
1307 module(mod).mode = FM_SOURCE;
1308 module(mod).lastStamp = sTime;
1310 module(mod).srcExt = findText(HI_ENDING);
1311 setCurrentFile(mod);
1313 strcat(name, textToStr(mt));
1314 strcat(name, DLL_ENDING);
1315 module(mod).objName = findText(name);
1316 module(mod).objSize = oSize;
1318 strcat(name, textToStr(mt));
1319 strcat(name, ".u_hi");
1320 module(mod).tree = parseInterface(name,iSize);
1321 module(mod).uses = getInterfaceImports(module(mod).tree);
1322 module(mod).mode = FM_OBJECT;
1323 module(mod).lastStamp = oiTime;
1326 if (path) free(path);
1330 if (path) free(path);
1333 "Can't find %s for module \"%s\"",
1334 modeToString(modeRequest), textToStr(mt)
1339 static void tryLoadGroup ( Cell grp )
1343 switch (whatIs(grp)) {
1345 m = findModule(textOf(snd(grp)));
1347 if (module(m).mode == FM_SOURCE) {
1348 processModule ( m );
1349 module(m).tree = NIL;
1351 processInterfaces ( singleton(snd(grp)) );
1352 m = findModule(textOf(snd(grp)));
1354 module(m).tree = NIL;
1358 for (t = snd(grp); nonNull(t); t=tl(t)) {
1359 m = findModule(textOf(hd(t)));
1361 if (module(m).mode == FM_SOURCE) {
1362 ERRMSG(0) "Source module \"%s\" imports itself recursively",
1363 textToStr(textOf(hd(t)))
1367 processInterfaces ( snd(grp) );
1368 for (t = snd(grp); nonNull(t); t=tl(t)) {
1369 m = findModule(textOf(hd(t)));
1371 module(m).tree = NIL;
1375 internal("tryLoadGroup");
1380 static void fallBackToPrelModules ( void )
1383 for (m = MODULE_BASE_ADDR;
1384 m < MODULE_BASE_ADDR+tabModuleSz; m++)
1386 && !varIsMember(module(m).text, prelModules))
1391 /* This function catches exceptions in most of the system.
1392 So it's only ok for procedures called from this one
1393 to do EENDs (ie, write error messages). Others should use
1396 static void achieveTargetModules ( Bool loadingThePrelude )
1399 volatile List modgList;
1401 volatile Module mod;
1406 Bool sAvail; Time sTime; Long sSize;
1407 Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1409 volatile Time oisTime;
1410 volatile Bool out_of_date;
1411 volatile List ood_new;
1413 volatile List modgList_new;
1414 volatile List parsedButNotLoaded;
1415 volatile List toChase;
1416 volatile List trans_cl;
1417 volatile List trans_cl_new;
1422 volatile List badMods;
1424 setBreakAction ( HugsIgnoreBreak );
1426 /* First, examine timestamps to find out which modules are
1427 out of date with respect to the source/interface/object files.
1430 modgList = listFromMG();
1432 for (t = modgList; nonNull(t); t=tl(t)) {
1434 if (varIsMember(textOf(hd(t)),prelModules))
1437 mod = findModule(textOf(hd(t)));
1438 if (isNull(mod)) internal("achieveTargetSet(1)");
1440 /* In standalone mode, only succeeds for source modules. */
1441 ok = findFilesForModule (
1442 textToStr(module(mod).text),
1445 &sAvail, &sTime, &sSize,
1446 &oiAvail, &oiTime, &oSize, &iSize
1449 if (!combined && !sAvail) ok = FALSE;
1451 fallBackToPrelModules();
1453 "Can't find source or object+interface for module \"%s\"",
1454 textToStr(module(mod).text)
1456 if (path) free(path);
1460 if (sAvail && oiAvail) {
1461 oisTime = whicheverIsLater(sTime,oiTime);
1463 else if (sAvail && !oiAvail) {
1466 else if (!sAvail && oiAvail) {
1470 internal("achieveTargetSet(2)");
1473 out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
1475 assert(!varIsMember(textOf(hd(t)),ood));
1476 ood = cons(hd(t),ood);
1479 if (path) { free(path); path = NULL; };
1482 /* Second, form a simplistic transitive closure of the out-of-date
1483 modules: a module is out of date if it imports an out-of-date
1488 for (t = modgList; nonNull(t); t=tl(t)) {
1489 mod = findModule(textOf(hd(t)));
1490 assert(nonNull(mod));
1491 for (us = module(mod).uses; nonNull(us); us=tl(us))
1492 if (varIsMember(textOf(hd(us)),ood))
1495 if (varIsMember(textOf(hd(t)),prelModules))
1496 Printf ( "warning: prelude module \"%s\" is out-of-date\n",
1497 textToStr(textOf(hd(t))) );
1499 if (!varIsMember(textOf(hd(t)),ood_new) &&
1500 !varIsMember(textOf(hd(t)),ood))
1501 ood_new = cons(hd(t),ood_new);
1504 if (isNull(ood_new)) break;
1505 ood = appendOnto(ood_new,ood);
1508 /* Now ood holds the entire set of modules which are out-of-date.
1509 Throw them out of the system, yielding a "reduced system",
1510 in which the remaining modules are in-date.
1512 for (t = ood; nonNull(t); t=tl(t)) {
1513 mod = findModule(textOf(hd(t)));
1514 assert(nonNull(mod));
1518 for (t = modgList; nonNull(t); t=tl(t))
1519 if (!varIsMember(textOf(hd(t)),ood))
1520 modgList_new = cons(hd(t),modgList_new);
1521 modgList = modgList_new;
1523 /* Update the module group list to reflect the reduced system.
1524 We do this so that if the following parsing phases fail, we can
1525 safely fall back to the reduced system.
1527 mgFromList ( modgList );
1529 /* Parse modules/interfaces, collecting parse trees and chasing
1530 imports, starting from the target set.
1532 toChase = dupList(targetModules);
1533 for (t = toChase; nonNull(t); t=tl(t)) {
1534 Cell mode = (!combined)
1536 : ( (loadingThePrelude && combined)
1539 hd(t) = zpair(hd(t), mode);
1542 /* toChase :: [ ((ConId, {FM_SOURCE|FM_OBJECT|FM_EITHER} )) ] */
1544 parsedButNotLoaded = NIL;
1547 while (nonNull(toChase)) {
1548 ConId mc = zfst(hd(toChase));
1549 Cell mode = zsnd(hd(toChase));
1550 toChase = tl(toChase);
1551 if (varIsMember(textOf(mc),modgList)
1552 || varIsMember(textOf(mc),parsedButNotLoaded)) {
1553 /* either exists fully, or is at least parsed */
1554 mod = findModule(textOf(mc));
1555 assert(nonNull(mod));
1556 if (!compatibleNewMode(mode,module(mod).mode)) {
1559 "module %s: %s required, but %s is more recent",
1560 textToStr(textOf(mc)), modeToString(mode),
1561 modeToString(module(mod).mode)
1563 goto parseException;
1567 setBreakAction ( HugsLongjmpOnBreak );
1568 if (setjmp(catch_error)==0) {
1569 /* try this; it may throw an exception */
1570 mod = parseModuleOrInterface ( mc, mode );
1572 /* here's the exception handler, if parsing fails */
1573 /* A parse error (or similar). Clean up and abort. */
1575 setBreakAction ( HugsIgnoreBreak );
1576 mod = findModule(textOf(mc));
1577 if (nonNull(mod)) nukeModule(mod);
1578 for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
1579 mod = findModule(textOf(hd(t)));
1580 assert(nonNull(mod));
1581 if (nonNull(mod)) nukeModule(mod);
1584 /* end of the exception handler */
1586 setBreakAction ( HugsIgnoreBreak );
1588 parsedButNotLoaded = cons(mc, parsedButNotLoaded);
1589 for (t = module(mod).uses; nonNull(t); t=tl(t))
1591 zpair( hd(t), childMode(mode,module(mod).mode) ),
1596 modgList = dupOnto(parsedButNotLoaded, modgList);
1598 /* We successfully parsed all modules reachable from the target
1599 set which were not part of the reduced system. However, there
1600 may be modules in the reduced system which are not reachable from
1601 the target set. We detect these now by building the transitive
1602 closure of the target set, and nuking modules in the reduced
1603 system which are not part of that closure.
1605 trans_cl = dupList(targetModules);
1608 for (t = trans_cl; nonNull(t); t=tl(t)) {
1609 mod = findModule(textOf(hd(t)));
1610 assert(nonNull(mod));
1611 for (u = module(mod).uses; nonNull(u); u=tl(u))
1612 if (!varIsMember(textOf(hd(u)),trans_cl)
1613 && !varIsMember(textOf(hd(u)),trans_cl_new)
1614 && !varIsMember(textOf(hd(u)),prelModules))
1615 trans_cl_new = cons(hd(u),trans_cl_new);
1617 if (isNull(trans_cl_new)) break;
1618 trans_cl = appendOnto(trans_cl_new,trans_cl);
1621 for (t = modgList; nonNull(t); t=tl(t)) {
1622 if (varIsMember(textOf(hd(t)),trans_cl)) {
1623 modgList_new = cons(hd(t),modgList_new);
1625 mod = findModule(textOf(hd(t)));
1626 assert(nonNull(mod));
1630 modgList = modgList_new;
1632 /* Now, the module symbol tables hold exactly the set of
1633 modules reachable from the target set, and modgList holds
1634 their names. Calculate the scc-ified module graph,
1635 since we need that to guide the next stage, that of
1636 Actually Loading the modules.
1638 If no errors occur, moduleGraph will reflect the final graph
1639 loaded. If an error occurs loading a group, we nuke
1640 that group, truncate the moduleGraph just prior to that
1641 group, and exit. That leaves the system having successfully
1642 loaded all groups prior to the one which failed.
1644 mgFromList ( modgList );
1646 for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
1649 if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
1650 parsedButNotLoaded)) continue;
1652 setBreakAction ( HugsLongjmpOnBreak );
1653 if (setjmp(catch_error)==0) {
1654 /* try this; it may throw an exception */
1657 /* here's the exception handler, if static/typecheck etc fails */
1658 /* nuke the entire rest (ie, the unloaded part)
1659 of the module graph */
1660 setBreakAction ( HugsIgnoreBreak );
1661 badMods = listFromSpecifiedMG ( mg );
1662 for (t = badMods; nonNull(t); t=tl(t)) {
1663 mod = findModule(textOf(hd(t)));
1664 if (nonNull(mod)) nukeModule(mod);
1666 /* truncate the module graph just prior to this group. */
1670 if (isNull(mg)) break;
1671 if (hd(mg) == grp) break;
1672 mg2 = cons ( hd(mg), mg2 );
1675 moduleGraph = reverse(mg2);
1677 /* end of the exception handler */
1679 setBreakAction ( HugsIgnoreBreak );
1682 /* Err .. I think that's it. If we get here, we've successfully
1683 achieved the target set. Phew!
1685 setBreakAction ( HugsIgnoreBreak );
1689 static Bool loadThePrelude ( void )
1694 moduleGraph = prelModules = NIL;
1697 conPrelude = mkCon(findText("Prelude"));
1698 conPrelHugs = mkCon(findText("PrelHugs"));
1699 targetModules = doubleton(conPrelude,conPrelHugs);
1700 achieveTargetModules(TRUE);
1701 ok = elemMG(conPrelude) && elemMG(conPrelHugs);
1703 conPrelude = mkCon(findText("Prelude"));
1704 targetModules = singleton(conPrelude);
1705 achieveTargetModules(TRUE);
1706 ok = elemMG(conPrelude);
1709 if (ok) prelModules = listFromMG();
1714 /* Refresh the current target modules, and attempt to set the
1715 current module to what it was before (ie currentModule):
1716 if currentModule_failed is different from currentModule,
1718 if nextCurrMod is non null, try to set it to that instead
1719 if the one we're after insn't available, select a target
1720 from the end of the module group list.
1722 static void refreshActions ( ConId nextCurrMod, Bool cleanAfter )
1727 /* Remember what the old current module was. */
1728 tryFor = mkCon(module(currentModule).text);
1730 /* Do the Real Work. */
1731 achieveTargetModules(FALSE);
1733 /* Remember if the current module was invalidated by this
1734 refresh, so later refreshes can attempt to reload it. */
1735 if (!elemMG(tryFor))
1736 currentModule_failed = tryFor;
1738 /* If a previous refresh failed to get an old current module,
1739 try for that instead. */
1740 if (nonNull(currentModule_failed)
1741 && textOf(currentModule_failed) != textOf(tryFor)
1742 && elemMG(currentModule_failed))
1743 tryFor = currentModule_failed;
1744 /* If our caller specified a new current module, that overrides
1745 all historical settings. */
1746 if (nonNull(nextCurrMod))
1747 tryFor = nextCurrMod;
1748 /* Finally, if we can't actually get hold of whatever it was we
1749 were after, select something which is possible. */
1750 if (!elemMG(tryFor))
1751 tryFor = selectLatestMG();
1753 /* combined mode kludge, to get Prelude rather than PrelHugs */
1754 if (combined && textOf(tryFor)==findText("PrelHugs"))
1755 tryFor = mkCon(findText("Prelude"));
1758 /* delete any targetModules which didn't actually get loaded */
1760 targetModules = NIL;
1761 for (; nonNull(t); t=tl(t))
1763 targetModules = cons(hd(t),targetModules);
1766 setCurrModule ( findModule(textOf(tryFor)) );
1767 Printf("Hugs session for:\n");
1772 static void addActions ( List extraModules /* :: [CONID] */ )
1775 for (t = extraModules; nonNull(t); t=tl(t)) {
1776 ConId extra = hd(t);
1777 if (!varIsMember(textOf(extra),targetModules))
1778 targetModules = cons(extra,targetModules);
1780 refreshActions ( isNull(extraModules)
1782 : hd(reverse(extraModules)),
1788 static void loadActions ( List loadModules /* :: [CONID] */ )
1791 targetModules = dupList ( prelModules );
1793 for (t = loadModules; nonNull(t); t=tl(t)) {
1795 if (!varIsMember(textOf(load),targetModules))
1796 targetModules = cons(load,targetModules);
1798 refreshActions ( isNull(loadModules)
1800 : hd(reverse(loadModules)),
1806 /* --------------------------------------------------------------------------
1807 * Access to external editor:
1808 * ------------------------------------------------------------------------*/
1810 /* ToDo: All this editor stuff needs fixing. */
1812 static Void local editor() { /* interpreter-editor interface */
1814 String newFile = readFilename();
1816 setLastEdit(newFile,0);
1817 if (readFilename()) {
1818 ERRMSG(0) "Multiple filenames not permitted"
1826 static Void local find() { /* edit file containing definition */
1829 String nm = readFilename(); /* of specified name */
1831 ERRMSG(0) "No name specified"
1834 else if (readFilename()) {
1835 ERRMSG(0) "Multiple names not permitted"
1841 setCurrModule(findEvalModule());
1843 if (nonNull(c=findTycon(t=findText(nm)))) {
1844 if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1845 readScripts(N_PRELUDE_SCRIPTS);
1847 } else if (nonNull(c=findName(t))) {
1848 if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1849 readScripts(N_PRELUDE_SCRIPTS);
1852 ERRMSG(0) "No current definition for name \"%s\"", nm
1859 static Void local runEditor() { /* run editor on script lastEdit */
1861 if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
1862 readScripts(N_PRELUDE_SCRIPTS);
1866 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1872 lastEdit = strCopy(fname);
1877 /* --------------------------------------------------------------------------
1878 * Read and evaluate an expression:
1879 * ------------------------------------------------------------------------*/
1881 static Void setModule ( void ) {
1882 /*set module in which to evaluate expressions*/
1885 String s = readFilename();
1887 mc = selectLatestMG();
1888 if (combined && textOf(mc)==findText("PrelHugs"))
1889 mc = mkCon(findText("Prelude"));
1890 m = findModule(textOf(mc));
1893 m = findModule(findText(s));
1895 ERRMSG(0) "Cannot find module \"%s\"", s
1903 static Module allocEvalModule ( void )
1905 Module evalMod = newModule( findText("_Eval_Module_") );
1906 module(evalMod).names = module(currentModule).names;
1907 module(evalMod).tycons = module(currentModule).tycons;
1908 module(evalMod).classes = module(currentModule).classes;
1909 module(evalMod).qualImports
1910 = singleton(pair(mkCon(textPrelude),modulePrelude));
1914 static Void local evaluator() { /* evaluate expr and print value */
1917 volatile Kinds ks = NIL;
1918 volatile Module evalMod = allocEvalModule();
1919 volatile Module currMod = currentModule;
1920 setCurrModule(evalMod);
1923 defaultDefns = combined ? stdDefaults : evalDefaults;
1925 setBreakAction ( HugsLongjmpOnBreak );
1926 if (setjmp(catch_error)==0) {
1930 type = typeCheckExp(TRUE);
1932 /* if an exception happens, we arrive here */
1933 setBreakAction ( HugsIgnoreBreak );
1934 goto cleanup_and_return;
1937 setBreakAction ( HugsIgnoreBreak );
1938 if (isPolyType(type)) {
1939 ks = polySigOf(type);
1940 bd = monotypeOf(type);
1945 if (whatIs(bd)==QUAL) {
1948 ERRMSG(0) "Unresolved overloading" ETHEN
1949 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
1950 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
1953 goto cleanup_and_return;
1959 if (isProgType(ks,bd)) {
1960 inputExpr = ap(nameRunIO_toplevel,inputExpr);
1964 Cell d = provePred(ks,NIL,ap(classShow,bd));
1968 ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1969 ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
1970 ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
1973 goto cleanup_and_return;
1975 inputExpr = ap2(nameShow, d,inputExpr);
1976 inputExpr = ap (namePutStr, inputExpr);
1977 inputExpr = ap (nameRunIO_toplevel, inputExpr);
1979 evalExp(); printf("\n");
1982 printType(stdout,type);
1989 printf ( "result type is " );
1990 printType ( stdout, type );
1998 setBreakAction ( HugsIgnoreBreak );
1999 nukeModule(evalMod);
2000 setCurrModule(currMod);
2001 setCurrentFile(currMod);
2007 /* --------------------------------------------------------------------------
2008 * Print type of input expression:
2009 * ------------------------------------------------------------------------*/
2011 static Void showtype ( void ) { /* print type of expression (if any)*/
2014 volatile Module evalMod = allocEvalModule();
2015 volatile Module currMod = currentModule;
2016 setCurrModule(evalMod);
2018 if (setjmp(catch_error)==0) {
2022 defaultDefns = evalDefaults;
2023 type = typeCheckExp(FALSE);
2024 printExp(stdout,inputExpr);
2026 printType(stdout,type);
2029 /* if an exception happens, we arrive here */
2032 nukeModule(evalMod);
2033 setCurrModule(currMod);
2037 static Void local browseit(mod,t,all)
2044 Printf("module %s where\n",textToStr(module(mod).text));
2045 for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
2047 /* only look at things defined in this module,
2048 unless `all' flag is set */
2049 if (all || name(nm).mod == mod) {
2050 /* unwanted artifacts, like lambda lifted values,
2051 are in the list of names, but have no types */
2052 if (nonNull(name(nm).type)) {
2053 printExp(stdout,nm);
2055 printType(stdout,name(nm).type);
2057 Printf(" -- data constructor");
2058 } else if (isMfun(nm)) {
2059 Printf(" -- class member");
2060 } else if (isSfun(nm)) {
2061 Printf(" -- selector function");
2069 Printf("Unknown module %s\n",t);
2074 static Void local browse() { /* browse modules */
2075 Int count = 0; /* or give menu of commands */
2079 for (; (s=readFilename())!=0; count++)
2080 if (strcmp(s,"all") == 0) {
2084 browseit(findModule(findText(s)),s,all);
2086 browseit(currentModule,NULL,all);
2090 #if EXPLAIN_INSTANCE_RESOLUTION
2091 static Void local xplain() { /* print type of expression (if any)*/
2093 Bool sir = showInstRes;
2095 setCurrModule(findEvalModule());
2096 startNewScript(0); /* Enables recovery of storage */
2097 /* allocated during evaluation */
2101 d = provePred(NIL,NIL,hd(inputContext));
2103 fprintf(stdout, "not Sat\n");
2105 fprintf(stdout, "Sat\n");
2111 /* --------------------------------------------------------------------------
2112 * Enhanced help system: print current list of scripts or give information
2114 * ------------------------------------------------------------------------*/
2116 static String local objToStr(m,c)
2119 #if 1 || DISPLAY_QUANTIFIERS
2120 static char newVar[60];
2121 switch (whatIs(c)) {
2122 case NAME : if (m == name(c).mod) {
2123 sprintf(newVar,"%s", textToStr(name(c).text));
2125 sprintf(newVar,"%s.%s",
2126 textToStr(module(name(c).mod).text),
2127 textToStr(name(c).text));
2131 case TYCON : if (m == tycon(c).mod) {
2132 sprintf(newVar,"%s", textToStr(tycon(c).text));
2134 sprintf(newVar,"%s.%s",
2135 textToStr(module(tycon(c).mod).text),
2136 textToStr(tycon(c).text));
2140 case CLASS : if (m == cclass(c).mod) {
2141 sprintf(newVar,"%s", textToStr(cclass(c).text));
2143 sprintf(newVar,"%s.%s",
2144 textToStr(module(cclass(c).mod).text),
2145 textToStr(cclass(c).text));
2149 default : internal("objToStr");
2153 static char newVar[33];
2154 switch (whatIs(c)) {
2155 case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
2158 case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
2161 case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
2164 default : internal("objToStr");
2172 static Void dumpStg ( void )
2178 setCurrModule(findEvalModule());
2183 /* request to locate a symbol by name */
2184 if (s && (*s == '?')) {
2185 Text t = findText(s+1);
2186 locateSymbolByName(t);
2190 /* request to dump a bit of the heap */
2191 if (s && (*s == '-' || isdigit(*s))) {
2198 /* request to dump a symbol table entry */
2200 || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
2201 || !isdigit(s[1])) {
2202 fprintf(stderr, ":d -- bad request `%s'\n", s );
2207 case 't': dumpTycon(i); break;
2208 case 'n': dumpName(i); break;
2209 case 'c': dumpClass(i); break;
2210 case 'i': dumpInst(i); break;
2211 default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
2217 static Void local dumpStg( void ) { /* print STG stuff */
2222 Cell v; /* really StgVar */
2223 setCurrModule(findEvalModule());
2225 for (; (s=readFilename())!=0;) {
2228 /* find the name while ignoring module scopes */
2229 for (i=NAMEMIN; i<nameHw; i++)
2230 if (name(i).text == t) n = i;
2232 /* perhaps it's an "idNNNNNN" thing? */
2235 s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2238 while (isdigit(s[i])) {
2239 v = v * 10 + (s[i]-'0');
2243 n = nameFromStgVar(v);
2246 if (isNull(n) && whatIs(v)==STGVAR) {
2247 Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2248 printStg(stderr, v );
2251 Printf ( "Unknown reference `%s'\n", s );
2254 Printf ( "Not a Name: `%s'\n", s );
2256 if (isNull(name(n).stgVar)) {
2257 Printf ( "Doesn't have a STG tree: %s\n", s );
2259 Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2260 printStg(stderr, name(n).stgVar);
2266 static Void local info() { /* describe objects */
2267 Int count = 0; /* or give menu of commands */
2270 for (; (s=readFilename())!=0; count++) {
2271 describe(findText(s));
2274 /* whatScripts(); */
2279 static Void local describe(t) /* describe an object */
2281 Tycon tc = findTycon(t);
2282 Class cl = findClass(t);
2283 Name nm = findName(t);
2285 if (nonNull(tc)) { /* as a type constructor */
2289 for (i=0; i<tycon(tc).arity; ++i) {
2290 t = ap(t,mkOffset(i));
2292 Printf("-- type constructor");
2294 Printf(" with kind ");
2295 printKind(stdout,tycon(tc).kind);
2298 switch (tycon(tc).what) {
2299 case SYNONYM : Printf("type ");
2300 printType(stdout,t);
2302 printType(stdout,tycon(tc).defn);
2306 case DATATYPE : { List cs = tycon(tc).defn;
2307 if (tycon(tc).what==DATATYPE) {
2312 printType(stdout,t);
2314 mapProc(printSyntax,cs);
2316 Printf("\n-- constructors:");
2318 for (; hasCfun(cs); cs=tl(cs)) {
2320 printExp(stdout,hd(cs));
2322 printType(stdout,name(hd(cs)).type);
2325 Printf("\n-- selectors:");
2327 for (; nonNull(cs); cs=tl(cs)) {
2329 printExp(stdout,hd(cs));
2331 printType(stdout,name(hd(cs)).type);
2336 case RESTRICTSYN : Printf("type ");
2337 printType(stdout,t);
2338 Printf(" = <restricted>");
2342 if (nonNull(in=findFirstInst(tc))) {
2343 Printf("\n-- instances:\n");
2346 in = findNextInst(tc,in);
2347 } while (nonNull(in));
2352 if (nonNull(cl)) { /* as a class */
2353 List ins = cclass(cl).instances;
2354 Kinds ks = cclass(cl).kinds;
2355 if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2356 Printf("-- type class");
2358 Printf("-- constructor class");
2360 Printf(" with arity ");
2361 printKinds(stdout,ks);
2365 mapProc(printSyntax,cclass(cl).members);
2367 if (nonNull(cclass(cl).supers)) {
2368 printContext(stdout,cclass(cl).supers);
2371 printPred(stdout,cclass(cl).head);
2373 if (nonNull(cclass(cl).fds)) {
2374 List fds = cclass(cl).fds;
2376 for (; nonNull(fds); fds=tl(fds)) {
2378 printFD(stdout,hd(fds));
2383 if (nonNull(cclass(cl).members)) {
2384 List ms = cclass(cl).members;
2387 Type t = name(hd(ms)).type;
2388 if (isPolyType(t)) {
2392 printExp(stdout,hd(ms));
2394 if (isNull(tl(fst(snd(t))))) {
2397 t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2399 printType(stdout,t);
2401 } while (nonNull(ms));
2405 Printf("\n-- instances:\n");
2409 } while (nonNull(ins));
2414 if (nonNull(nm)) { /* as a function/name */
2416 printExp(stdout,nm);
2418 if (nonNull(name(nm).type)) {
2419 printType(stdout,name(nm).type);
2421 Printf("<unknown type>");
2424 Printf(" -- data constructor");
2425 } else if (isMfun(nm)) {
2426 Printf(" -- class member");
2427 } else if (isSfun(nm)) {
2428 Printf(" -- selector function");
2434 if (isNull(tc) && isNull(cl) && isNull(nm)) {
2435 Printf("Unknown reference `%s'\n",textToStr(t));
2439 static Void local printSyntax(nm)
2441 Syntax sy = syntaxOf(nm);
2442 Text t = name(nm).text;
2443 String s = textToStr(t);
2444 if (sy != defaultSyntax(t)) {
2446 switch (assocOf(sy)) {
2447 case LEFT_ASS : Putchar('l'); break;
2448 case RIGHT_ASS : Putchar('r'); break;
2449 case NON_ASS : break;
2451 Printf(" %i ",precOf(sy));
2452 if (isascii((int)(*s)) && isalpha((int)(*s))) {
2461 static Void local showInst(in) /* Display instance decl header */
2463 Printf("instance ");
2464 if (nonNull(inst(in).specifics)) {
2465 printContext(stdout,inst(in).specifics);
2468 printPred(stdout,inst(in).head);
2472 /* --------------------------------------------------------------------------
2473 * List all names currently in scope:
2474 * ------------------------------------------------------------------------*/
2476 static Void local listNames() { /* list names matching optional pat*/
2477 String pat = readFilename();
2482 Module mod = currentModule;
2484 if (pat) { /* First gather names to list */
2486 names = addNamesMatching(pat,names);
2487 } while ((pat=readFilename())!=0);
2489 names = addNamesMatching((String)0,names);
2491 if (isNull(names)) { /* Then print them out */
2493 ERRMSG(0) "No names selected"
2497 for (termPos=0; nonNull(names); names=tl(names)) {
2498 String s = objToStr(mod,hd(names));
2500 if (termPos+1+l>width) {
2503 } else if (termPos>0) {
2511 Printf("\n(%d names listed)\n", count);
2514 /* --------------------------------------------------------------------------
2515 * print a prompt and read a line of input:
2516 * ------------------------------------------------------------------------*/
2518 static Void local promptForInput(moduleName)
2519 String moduleName; {
2520 char promptBuffer[1000];
2522 /* This is portable but could overflow buffer */
2523 sprintf(promptBuffer,prompt,moduleName);
2525 /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2526 * promptBuffer instead.
2528 if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2529 /* Reset prompt to a safe default to avoid an infinite loop */
2531 prompt = strCopy("? ");
2532 internal("Combined prompt and evaluation module name too long");
2536 stringInput("main\0"); else
2537 consoleInput(promptBuffer);
2540 /* --------------------------------------------------------------------------
2541 * main read-eval-print loop, with error trapping:
2542 * ------------------------------------------------------------------------*/
2544 static Void local interpreter(argc,argv)/* main interpreter loop */
2548 List modConIds; /* :: [CONID] */
2552 setBreakAction ( HugsIgnoreBreak );
2553 modConIds = initialize(argc,argv); /* the initial modules to load */
2554 setBreakAction ( HugsIgnoreBreak );
2555 prelOK = loadThePrelude();
2559 fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2561 fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2565 if (combined) everybody(POSTPREL);
2566 loadActions(modConIds);
2569 for (; nonNull(modConIds); modConIds=tl(modConIds))
2570 if (!elemMG(hd(modConIds))) {
2572 "hugs +Q: compilation failed -- can't run `main'\n" );
2579 /* initialize calls startupHaskell, which trashes our signal handlers */
2580 setBreakAction ( HugsIgnoreBreak );
2585 everybody(RESET); /* reset to sensible initial state */
2587 promptForInput(textToStr(module(currentModule).text));
2589 cmd = readCommand(cmds, (Char)':', (Char)'!');
2591 case EDIT : editor();
2595 case LOAD : modConIds = NIL;
2596 while ((s=readFilename())!=0) {
2597 modConIds = cons(mkCon(findText(s)),modConIds);
2600 loadActions(modConIds);
2603 case ALSO : modConIds = NIL;
2604 while ((s=readFilename())!=0)
2605 modConIds = cons(mkCon(findText(s)),modConIds);
2606 addActions(modConIds);
2609 case RELOAD : refreshActions(NIL,FALSE);
2614 case EVAL : evaluator();
2616 case TYPEOF : showtype();
2618 case BROWSE : browse();
2620 #if EXPLAIN_INSTANCE_RESOLUTION
2621 case XPLAIN : xplain();
2624 case NAMES : listNames();
2628 case BADCMD : guidance();
2632 case SYSTEM : if (shellEsc(readLine()))
2633 Printf("Warning: Shell escape terminated abnormally\n");
2635 case CHGDIR : changeDir();
2639 case PNTVER: Printf("-- Hugs Version %s\n",
2642 case DUMP : dumpStg();
2645 case COLLECT: consGC = FALSE;
2648 Printf("Garbage collection recovered %d cells\n",
2654 if (autoMain) break;
2658 /* --------------------------------------------------------------------------
2659 * Display progress towards goal:
2660 * ------------------------------------------------------------------------*/
2662 static Target currTarget;
2663 static Bool aiming = FALSE;
2666 static Int charCount;
2668 Void setGoal(what, t) /* Set goal for what to be t */
2673 #if EXPLAIN_INSTANCE_RESOLUTION
2677 currTarget = (t?t:1);
2679 for (charCount=0; *what; charCount++)
2684 Void soFar(t) /* Indicate progress towards goal */
2685 Target t; { /* has now reached t */
2688 #if EXPLAIN_INSTANCE_RESOLUTION
2694 Void done() { /* Goal has now been achieved */
2697 #if EXPLAIN_INSTANCE_RESOLUTION
2701 for (; charCount>0; charCount--) {
2710 static Void local failed() { /* Goal cannot be reached due to */
2711 if (aiming) { /* errors */
2718 /* --------------------------------------------------------------------------
2720 * ------------------------------------------------------------------------*/
2722 static Void local stopAnyPrinting() { /* terminate printing of expression,*/
2723 if (printing) { /* after successful termination or */
2724 printing = FALSE; /* runtime error (e.g. interrupt) */
2727 #define plural(v) v, (v==1?"":"s")
2728 Printf("(%lu enter%s)\n",plural(numEnters));
2736 Cell errAssert(l) /* message to use when raising asserts, etc */
2740 str = mkStr(findText(currentFile));
2742 str = mkStr(findText(""));
2744 return (ap2(nameTangleMessage,str,mkInt(l)));
2747 Void errHead(l) /* print start of error message */
2749 failed(); /* failed to reach target ... */
2751 FPrintf(errorStream,"ERROR");
2754 FPrintf(errorStream," \"%s\"", currentFile);
2755 setLastEdit(currentFile,l);
2756 if (l) FPrintf(errorStream," (line %d)",l);
2759 FPrintf(errorStream,": ");
2760 FFlush(errorStream);
2763 Void errFail() { /* terminate error message and */
2764 Putc('\n',errorStream); /* produce exception to return to */
2765 FFlush(errorStream); /* main command loop */
2766 longjmp(catch_error,1);
2769 Void errFail_no_longjmp() { /* terminate error message but */
2770 Putc('\n',errorStream); /* don't produce an exception */
2771 FFlush(errorStream);
2774 Void errAbort() { /* altern. form of error handling */
2775 failed(); /* used when suitable error message*/
2776 stopAnyPrinting(); /* has already been printed */
2780 Void internal(msg) /* handle internal error */
2784 Printf("INTERNAL ERROR: %s\n",msg);
2787 longjmp(catch_error,1);
2790 Void fatal(msg) /* handle fatal error */
2793 Printf("\nFATAL ERROR: %s\n",msg);
2799 /* --------------------------------------------------------------------------
2800 * Read value from environment variable or registry:
2801 * ------------------------------------------------------------------------*/
2803 String fromEnv(var,def) /* return value of: */
2804 String var; /* environment variable named by var */
2805 String def; { /* or: default value given by def */
2806 String s = getenv(var);
2807 return (s ? s : def);
2810 /* --------------------------------------------------------------------------
2811 * String manipulation routines:
2812 * ------------------------------------------------------------------------*/
2814 static String local strCopy(s) /* make malloced copy of a string */
2818 if ((t=(char *)malloc(strlen(s)+1))==0) {
2819 ERRMSG(0) "String storage space exhausted"
2822 for (r=t; (*r++ = *s++)!=0; ) {
2830 /* --------------------------------------------------------------------------
2832 * We can redirect compiler output (prompts, error messages, etc) by
2833 * tweaking these functions.
2834 * ------------------------------------------------------------------------*/
2836 #ifdef HAVE_STDARG_H
2839 #include <varargs.h>
2842 Void hugsEnableOutput(f)
2847 #ifdef HAVE_STDARG_H
2848 Void hugsPrintf(const char *fmt, ...) {
2849 va_list ap; /* pointer into argument list */
2850 va_start(ap, fmt); /* make ap point to first arg after fmt */
2851 if (!disableOutput) {
2855 va_end(ap); /* clean up */
2858 Void hugsPrintf(fmt, va_alist)
2861 va_list ap; /* pointer into argument list */
2862 va_start(ap); /* make ap point to first arg after fmt */
2863 if (!disableOutput) {
2867 va_end(ap); /* clean up */
2873 if (!disableOutput) {
2879 Void hugsFlushStdout() {
2880 if (!disableOutput) {
2887 if (!disableOutput) {
2892 #ifdef HAVE_STDARG_H
2893 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2896 if (!disableOutput) {
2897 vfprintf(fp, fmt, ap);
2903 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2909 if (!disableOutput) {
2910 vfprintf(fp, fmt, ap);
2917 Void hugsPutc(c, fp)
2920 if (!disableOutput) {
2926 /* --------------------------------------------------------------------------
2927 * Send message to each component of system:
2928 * ------------------------------------------------------------------------*/
2930 Void everybody(what) /* send command `what' to each component of*/
2931 Int what; { /* system to respond as appropriate ... */
2933 fprintf ( stderr, "EVERYBODY %d\n", what );
2935 machdep(what); /* The order of calling each component is */
2936 storage(what); /* important for the PREPREL command */
2939 translateControl(what);
2941 staticAnalysis(what);
2942 deriveControl(what);
2951 mark(targetModules);
2953 mark(currentModule_failed);
2957 /*-------------------------------------------------------------------------*/