added "autorequire"; preparing libraries for autorequire
[k8-xscheme:k8-xscheme.git] / src / xscheme.c
1 /* xscheme main driver */
2 /* Copyright (c) 1988, David Michael Betz
3  * Copyright (c) 2010, Ketmar // Vampire Avalon
4  * All rights reserved.
5  * see LICENSE for terms of using.
6  */
7 #ifndef _WIN32
8 # ifndef _GNU_SOURCE
9 #  define _GNU_SOURCE
10 # endif
11 #endif
12
13 #include <stdio.h>
14 #include <stdlib.h>
15 #include <string.h>
16 #include <unistd.h>
17
18 #include "xscheme.h"
19 #include "xsdlib.h"
20
21 #include "xsdl.h"
22 #include "xsosprim.h"
23 #include "xstre.h"
24
25
26 /* the program banner */
27 #define BANNER  "XScheme - Version 0.28.1"
28
29
30 static jmp_buf xmainTopLevelJP;
31 int xsTIOInRawMode = 0;
32
33
34 #ifndef _WIN32
35 #include "linenoise.h"
36 static int sigintCnt = 0;
37
38 static char *rdLine = NULL, *rdLinePos = NULL;
39 static int stdinDone = 0;
40
41 static int rdlineGetC (void) {
42   if (!isatty(fileno(stdin)) || xsTIOInRawMode) {
43     unsigned char c;
44     int res = read(STDIN_FILENO, &c, 1);
45     if (res <= 0) return EOF;
46     return c;
47   }
48   while (!rdLinePos) {
49     if (stdinDone) return EOF;
50     /* get new line */
51     fflush(stdout); fflush(stderr);
52     rdLine = rdLinePos = linenoise("> ");
53     if (!rdLine) stdinDone = 1;
54     else if (rdLine[0]) linenoiseHistoryAdd(rdLine);
55     sigintCnt = 0;
56   }
57   if (!rdLinePos[0]) { rdLinePos = NULL; return '\n'; }
58   return *rdLinePos++;
59 }
60 #endif
61
62
63 static char myPath[8192];
64
65
66 xsSIGCBackFn xsSIGALRMCBack = NULL;
67 xsSIGCBackFn xsSIGVTALRMCBack = NULL;
68 #ifndef _WIN32
69 #include <signal.h>
70 #include <sys/time.h>
71
72 static void sigHandler (int sig) {
73   switch (sig) {
74     case SIGALRM:
75 #ifdef XS_ALLOW_SIGBREAK
76       if (xsSIGALRMCBack) xsSIGALRMCBack(sig);
77 #endif
78       break;
79     case SIGVTALRM:
80       if (xsSIGVTALRMCBack) xsSIGVTALRMCBack(sig);
81       break;
82     case SIGINT:
83       fprintf(stderr, "\nSIGINT\n");
84 #ifdef XS_ALLOW_SIGBREAK
85       xsSigBreakF = -1;
86 #endif
87       if (++sigintCnt > 2) {
88         fprintf(stderr, "***FORCED SHUTDOWN***\n");
89         xsShutdown();
90       }
91       break;
92   }
93 }
94 #endif
95
96
97 static void xsOSError (const char *msg) {
98   xsErrPutStr("error: ");
99   xsErrPutStr(msg);
100   xsErrPutStr("\n");
101 }
102
103
104 static XSVal xsoShowBackTrace = XS_NIL;
105
106
107 static void xsDumpEnv (XSVal env) {
108   int f, c;
109   XSVal vec, vlst;
110   char buf[128];
111   xsErrPutStr("env: ");
112   xsErrPrint(env);
113   for (f = 0; env != XS_NIL; f++, env = xsCDR(env)) {
114     sprintf(buf, "frame #%d:\n", f);
115     xsErrPutStr(buf);
116     vec = xsCAR(env);
117     vlst = xsGetElement(vec, 0);
118     for (c = 1; c < xsGetSize(vec); c++) {
119       xsErrPutStr(" ");
120       if (vlst != XS_NIL) {
121         xsPrin1(xsCAR(vlst), xsGetValue(xsStdErrSym));
122         vlst = xsCDR(vlst);
123       } else xsErrPutStr("<unknown>");
124       xsErrPutStr(": ");
125       xsErrPrint(xsGetElement(vec, c));
126     }
127     for (; vlst != XS_NIL; vlst = xsCDR(vlst)) {
128       xsErrPutStr(" ");
129       xsErrPrint(xsCAR(vlst));
130       xsErrPutStr(": <nothing>\n");
131       vlst = xsCDR(vlst);
132     }
133   }
134   xsErrPutStr("------\n");
135 }
136
137
138 void xsBackTrace (void) {
139   XSVal *sp;
140   if (xsGetValue(xsoShowBackTrace) == XS_NIL) return;
141   xsErrPutStr("Backtrace:\n");
142   for (sp = xsSP; sp < xsStackTop; sp++) {
143     /*fprintf(stderr, "sp:%08x; top:%08x; base:%08x\n", (unsigned int)sp, (unsigned int)xsStackTop, (unsigned int)xsStackBase);*/
144     XSVal cur = *sp;
145     xsErrPutStr(" ");
146     if (cur == XS_NIL) {
147       xsErrPutStr("#nil\n");
148       continue;
149     }
150     xsErrPrint(cur);
151     switch (xsCType(cur)) {
152       case XS_CENV:
153         xsDumpEnv(cur);
154         break;
155       default: ;
156     }
157   }
158 }
159
160
161 static void xsShowFPos (XSVal fun, unsigned int pc) {
162   XSVal dinf;
163   char buf[256];
164   int line = 0, lpos = 0;
165   if (fun == XS_NIL) return;
166   dinf = xsGetDbgInf(fun);
167   if (dinf == XS_NIL) return;
168   for (dinf = xsCDR(dinf); dinf != XS_NIL; dinf = xsCDR(dinf)) {
169     XSVal i = xsCAR(dinf);
170     XS_FIXTYPE dpc = xsGetFixNum(xsCAR(i));
171     if (dpc > pc) break;
172     line = xsGetFixNum(xsCAR(xsCDR(i)));
173     lpos = xsGetFixNum(xsCDR(xsCDR(i)));
174   }
175   if (line < 1) return;
176   sprintf(buf, "  error at line %d, pos %d\n", line, lpos);
177   xsErrPutStr(buf);
178 }
179
180
181 static void xsShowErrInfoEpi (void) {
182   char buf[256];
183   sprintf(buf, "  pc: 0x%04X\n", (unsigned int)(xsPC-xsCodeBase));
184   xsErrPutStr(buf);
185   xsShowFPos(xsRFun, (unsigned int)(xsPC-xsCodeBase));
186   xsBackTrace();
187 }
188
189
190 /* display the error message */
191 void xsError (const char *msg, XSVal arg) {
192   if (!xsInDynamicUnwinder) {
193     xsCPush(arg!=xsUnboundSym?arg:XS_NIL);
194     xsCPush(xsNewString(msg?msg:""));
195     xsDynamicUnwind();
196     xsArgC = 2;
197     xsUserErrorHandler();
198   } else {
199     longjmp(*xsTopLevelJP, XS_USER_ERROR_CODE);
200   }
201 }
202
203
204 void xsUserErrorHandler (void) {
205   XSVal msg;
206   xsDynamicUnwind();
207   xsRVal = xsGetValue(xsEnter("*ERROR-HANDLER*"));
208   if (xsClosureP(xsRVal)) {
209     xsInvokeErrorHandler();
210   }
211   /* no scheme error handler */
212   if (xsArgC > 0) {
213     msg = xsGAString();
214     /* display the error message */
215     xsErrPutStr("error: ");
216     xsErrPutStr(xsGetString(msg));
217     xsErrPutStr("\n");
218     /* print each of the remaining arguments on separate lines */
219     while (xsMoreArgs()) {
220       xsErrPutStr("  ");
221       xsErrPrint(xsGetArg());
222     }
223   }
224   /* print the function where the error occurred */
225   xsErrPutStr("happened in: ");
226   xsErrPrint(xsRFun);
227   xsShowErrInfoEpi();
228   longjmp(*xsTopLevelJP, XS_USER_ERROR_CODE);
229 }
230
231
232 void xsAbort (const char *msg) {
233   xsErrPutStr("Abort: ");
234   xsErrPutStr(msg);
235   xsErrPutStr("\n");
236   xsErrPutStr("happened in: ");
237   xsErrPrint(xsRFun);
238   xsShowErrInfoEpi();
239   xsDynamicUnwind();
240   longjmp(*xsTopLevelJP, 1);
241 }
242
243
244 void xsFatal (const char *msg) {
245   xsOSError(msg);
246   exit(1);
247 }
248
249
250 void xsShutdown (void) {
251   longjmp(xmainTopLevelJP, 2);
252   exit(0);
253 }
254
255
256 static XSUserSignalCBFn csigList[4096];
257 const int csigSize = 4096;
258 static int csigUsed = 1;
259
260
261 int xsRegisterSigHandler (XSUserSignalCBFn cb) {
262   int f;
263   if (!cb) return 0;
264   for (f = 1; f <= csigUsed; f++) if (!csigList[f]) break;
265   if (csigUsed > csigSize) return 0; else f = csigUsed++;
266   csigList[f] = cb;
267   return f;
268 }
269
270
271 int xsUnregisterSigHandler (int sig, XSUserSignalCBFn cb) {
272   if (sig > 0 && sig <= csigSize && csigList[sig] == cb) {
273     csigList[sig] = NULL;
274     return XS_TRUE;
275   }
276   return XS_FALSE;
277 }
278
279
280 void xsUserSigHandler (int sig) {
281   if (sig < 0) {
282     /* ^C */
283     /* the user interrupt handler must
284      * set 'xsSigBreakF' to -1 to tell xsExecute() that is should
285      * call this function */
286     xsErrPutStr("\nUser abort\nhappened in: ");
287     xsErrPrint(xsRFun);
288     xsShowErrInfoEpi();
289     xsDynamicUnwind();
290     longjmp(*xsTopLevelJP, 1);
291   }
292   if (sig > 0 && sig < csigUsed && csigList[sig]) {
293     csigList[sig](sig);
294   }
295   /* we can just return to continue, or do `longjmp(xsBCDispatchJP, 0);` instead */
296 }
297
298
299 static void usage (void) {
300 #ifndef XS_OPT_NOTRACE
301   printf("usage: xscheme [-t] [-H] [-v] [-T] [file args...]\n");
302 #else
303   printf("usage: xscheme [-H] [-v] [-T] [file args...]\n");
304 #endif
305   exit(1);
306 }
307
308
309 static XSVal xsfVersionStr (void) {
310   xsLastArg();
311   return xsNewString(BANNER);
312 }
313
314
315 static XSVal xsfOSStr (void) {
316   xsLastArg();
317   return xsNewString(
318 #ifdef _WIN32
319     "windoze"
320 #else
321     "GNU/Linux"
322 #endif
323   );
324 }
325
326 static XSVal xsfWindozeP (void) {
327   xsLastArg();
328 #ifdef _WIN32
329   return xsTrue;
330 #else
331   return XS_NIL;
332 #endif
333 }
334
335 static XSVal xsfLinuxP (void) {
336   xsLastArg();
337 #ifdef _WIN32
338   return XS_NIL;
339 #else
340   return xsTrue;
341 #endif
342 }
343
344
345 static void xsInitUserSyms (void) {
346   xsLockGC();
347   xsSetValue(xsEnter("*MY-PATH*"), xsNewString(myPath));
348   xsSubr("VERSION-STR", xsfVersionStr);
349   xsSubr("OS-STR", xsfOSStr);
350   xsSubr("WINDOZE?", xsfWindozeP);
351   xsSubr("LINUX?", xsfLinuxP);
352   xsoShowBackTrace = xsEnter("*SHOW-BACKTRACE?*");
353   xsSetValue(xsoShowBackTrace, xsTrue);
354   xsUnlockGC();
355 }
356
357
358 int main (int argc, char *argv[]) {
359   int src, dst;
360   XSVal code;
361   char *p, *fname = NULL;
362   int xsCLIArgC; /* command line argument count */
363   int noHelp = 0;
364   int optLoadVerbose = 0;
365   int optLoadDiskScm = 0;
366   char oldPath[8192];
367
368   strcpy(myPath, argv[0]);
369 #ifdef _WIN32
370   p = strrchr(myPath, '\\');
371   if (!p || p == myPath) strcpy(myPath, "."); else *p = '\0';
372 #else
373   p = strrchr(myPath, '/');
374   if (!p || p == myPath) strcpy(myPath, "."); else *p = '\0';
375 #endif
376   getcwd(oldPath, sizeof(oldPath)-1);
377   chdir(myPath);
378   getcwd(myPath, sizeof(myPath)-1);
379   chdir(oldPath);
380 #ifdef _WIN32
381   if (myPath[strlen(myPath)-1] != '\\') strcat(myPath, "\\");
382   for (p = myPath; *p; p++) if (*p == '\\') *p = '/';
383 #else
384   if (myPath[strlen(myPath)-1] != '/') strcat(myPath, "/");
385 #endif
386
387   /* process the arguments */
388   for (src = dst = 1, xsCLIArgC = 1; src < argc; src++) {
389     /* handle options */
390     if (argv[src][0] == '-') {
391       for (p = &argv[src][1]; *p != '\0'; )
392         switch (*p++) {
393 #ifndef XS_OPT_NOTRACE
394           case 'T':
395             xsTraceF = XS_TRUE;
396             break;
397 #endif
398           case 'H':
399             noHelp = 1;
400             break;
401           case 'v':
402             optLoadVerbose = 1;
403             break;
404           case 't':
405             xsIgnoreEOFSym = 1;
406             break;
407           case 'Z':
408             optLoadDiskScm = 1;
409             break;
410           default:
411             usage();
412         }
413     } else {
414       /* handle a filename */
415       if (!fname) {
416         fname = argv[src];
417         argv[0] = argv[src];
418       } else {
419         argv[dst++] = argv[src];
420         xsCLIArgC++;
421       }
422     }
423   }
424
425   /* setup an initialization error handler */
426
427 #ifndef _WIN32
428   /* hook input */
429   xsStdInGetCHook = rdlineGetC;
430 #endif
431
432   /* initialize */
433   /* create the default workspace */
434   if (!xsScmInit(XS_DEFAULT_STACK_SIZE)) {
435     fprintf(stderr, "ERROR: can't initialize XScheme!\n");
436     return 1;
437   }
438   xsDLSymInit(myPath);
439   xsOSSymInit();
440   xsTRESymInit();
441   xsInitUserSyms();
442
443   /* build argument vector */
444   {
445     int f;
446     xsCPush(xsAllocVector(xsCLIArgC)); /* save and protect from GC */
447     for (f = 0; f < xsCLIArgC; f++) xsSetElement(xsTop(), f, xsNewString(argv[f]));
448     xsSetValue(xsEnter("*ARGV*"), xsPop());
449   }
450
451   /* load initialization file */
452   if (optLoadDiskScm) {
453     int wasError = 0;
454     getcwd(oldPath, sizeof(oldPath)-1);
455     chdir(myPath);
456     xsPEvalString("(load \"sysinit/xscheme.scm\")", &wasError);
457     if (wasError) {
458       chdir(oldPath);
459       fprintf(stderr, "ERROR: something went wrong in init!\n");
460       return 1;
461     }
462     xsPEvalString("(load \"sysinit/libinfo.scm\")", &wasError);
463     chdir(oldPath);
464     if (wasError) {
465       fprintf(stderr, "ERROR: something went wrong in init!\n");
466       return 1;
467     }
468   } else {
469     if (!xsRunPreInitializer()) {
470       fprintf(stderr, "ERROR: something went wrong in init!\n");
471       return 1;
472     }
473     if (!xsLoadDefaultLibInfo()) {
474       fprintf(stderr, "ERROR: something went wrong in init!\n");
475       return 1;
476     }
477   }
478
479   if (!noHelp) xsPEvalString("(require help)", NULL);
480
481 #ifndef _WIN32
482   signal(SIGALRM, sigHandler);
483   signal(SIGVTALRM, sigHandler);
484   signal(SIGINT, sigHandler);
485 #endif
486
487   xsCompSaveLineInfo = 1;
488   if (fname) {
489     if (setjmp(xmainTopLevelJP)) goto quit;
490     if (!xsLoadScmFile(fname, optLoadVerbose)) {
491       xsErrPutStr("ERROR: can't load file: ");
492       xsErrPutStr(fname);
493       xsErrPutStr("\n");
494     }
495     goto quit;
496   }
497
498   /* trap errors */
499   switch (setjmp(xmainTopLevelJP)) {
500     case 2:
501       goto quit;
502     case 0:
503     default:
504       xsDynamicUnwind();
505       code = xsEnter("*TOPLEVEL*");
506       code = (xsIsBound(code) ? xsGetValue(code) : XS_NIL);
507       xsRFun = xsREnv = xsRVal = XS_NIL;
508       xsResetStack();
509       break;
510   }
511   xsTopLevelJP = &xmainTopLevelJP;
512   /* execute the main loop */
513   if (code != XS_NIL) xsExecute(code, 0);
514 quit:
515   xsDynamicUnwind();
516   xsMemDeinit();
517   xsDLDeinit();
518   return 0;
519 }