removed elist-like descriptions for definitions
[k8-xscheme:k8-xscheme.git] / src / core / xsvm.c
1 /* xscheme bytecode interpreter */
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 #include "xscheme.h"
8 #include "xsbcode.h"
9
10
11 /* declarations from xsfunc.c */
12 extern XSVal xsfadd (void);
13 extern XSVal xsfsub (void);
14 extern XSVal xsfmul (void);
15 extern XSVal xsflss (void);
16 extern XSVal xsfgtr (void);
17 extern XSVal xsfeql (void);
18 extern XSVal xsfleq (void);
19 extern XSVal xsfgeq (void);
20 extern XSVal xsfneql (void);
21
22
23 /* macros to get the address of the code string for a code object */
24 #define getcodestr(x)  ((unsigned char *)(xsGetBCode(x))->vect.bdata)
25
26 /* globals */
27 int xsTraceF = XS_FALSE; /* 'trace enable' flag */
28 int xsSigBreakF = 0; /* set to non-zero to interrupt interpreter */
29 int xsArgC; /* argument count */
30 jmp_buf xsBCDispatchJP; /* bytecode dispatcher */
31
32 /* local variables */
33 unsigned char *xsCodeBase, *xsPC;
34
35
36 /* bad function error */
37 static void badfuntype (XSVal arg) {
38   xsError("bad function type", arg);
39 }
40
41
42 /* bad argument type error */
43 static void badargtype (XSVal arg) {
44   xsBadType(arg);
45 }
46
47
48 /* find a variable in an environment */
49 static XSVal findvar (XSVal env, XSVal var, int *poff) {
50   XSVal names;
51   int off;
52   for (; env != XS_NIL; env = xsCDR(env)) {
53     names = xsGetElement(xsCAR(env), 0);
54     for (off = 1; names != XS_NIL; off++, names = xsCDR(names)) {
55       if (var == xsCAR(names)) {
56         *poff = off;
57         return env;
58       }
59     }
60   }
61   return XS_NIL;
62 }
63
64
65 /* make a continuation */
66 XSVal xsMakeContinuation (void) {
67   XSVal cont, *src, *dst;
68   int size;
69   /* save a continuation on the stack */
70   xsCheck(3);
71   xsPush(xsSmFixNum((XS_FIXTYPE)(xsPC-xsCodeBase)));
72   xsPush(xsRFun);
73   xsPush(xsREnv);
74   /* create and initialize a continuation object */
75   size = (int)(xsStackTop-xsSP);
76   cont = xsAllocContinuation(size);
77   for (src = xsSP, dst = &cont->vect.data[0]; --size >= 0; ) *dst++ = *src++;
78   /* return the continuation */
79   return cont;
80 }
81
82
83 /* restore a continuation to the stack */
84 /* The continuation should be in xsRVal */
85 static void restoreContinuation (void) {
86   XSVal *src;
87   int size = xsGetSize(xsRVal);
88   for (src = &xsRVal->vect.data[size], xsSP = xsStackTop; --size >= 0; ) *--xsSP = *--src;
89 }
90
91
92 /* find keyword in an assoc list */
93 static int xsFindKeywordArg (XSVal alist, int eno) {
94   while (alist != XS_NIL) {
95     if (xsGetFixNum(xsCDR(xsCAR(alist))) == eno) {
96       /* keyword found; search it in args */
97       XSVal kwsym = xsCAR(xsCAR(alist));
98       int f;
99       for (f = xsArgC-2; f >= 0; f -= 2) {
100         if (kwsym == xsSP[f]) return f;
101         if (!xsSymbolP(xsSP[f])) return -1;
102       }
103       return -1;
104     }
105     alist = xsCDR(alist);
106   }
107   /* the thing that should not be! */
108   return -1;
109 }
110
111
112 /* check for signal interruption */
113 #ifdef XS_ALLOW_SIGBREAK
114 # define CHECK_SIGBREAK_MACRO \
115     if (xsSigBreakF) { \
116       int sig = xsSigBreakF; \
117       xsSigBreakF = 0; \
118       xsUserSigHandler(sig); \
119     }
120 #else
121 # define CHECK_SIGBREAK_MACRO
122 #endif
123
124 #ifdef XS_SIGBREAKS_ON_EVERY_OPCODE
125 # define CHECK_SIGBREAK_EVERY  CHECK_SIGBREAK_MACRO
126 # define CHECK_SIGBREAK
127 #else
128 # define CHECK_SIGBREAK_EVERY
129 # define CHECK_SIGBREAK        CHECK_SIGBREAK_MACRO
130 #endif
131
132 /* execute byte codes */
133 void xsExecute (XSVal fun, int argNo) {
134   XSVal tmp;
135   unsigned int i, avn, opc;
136   int k, f, t;
137   XS_FIXTYPE fixtmp, fixtmp1;
138   int off = -1, cxlen;
139   unsigned char cxmask;
140   /* initialize the registers */
141   if (!xsClosureP(fun)) xsError("invalid function", fun);
142   xsRFun = xsGetCode(fun);
143   xsREnv = xsGetEnv(fun);
144   xsRVal = xsRTmp = XS_NIL;
145   /* initialize the argument count */
146   xsArgC = argNo; /*0;*/
147   /* set the initial xsPC */
148   xsCodeBase = xsPC = getcodestr(xsRFun);
149   /* setup a target for the error handler */
150   setjmp(xsBCDispatchJP);
151   /* execute the code */
152   for (;;) {
153     CHECK_SIGBREAK_EVERY
154 #ifdef XS_OPT_VM_TRACE
155     /* print the trace information */
156     if (xsTraceF) {
157       xsDisasmInstr(xsCurEPort(), xsRFun, (int)(xsPC-xsCodeBase), xsREnv);
158       xsTerPri(xsCurEPort());
159     }
160 #endif
161     /* execute the next bytecode instruction */
162     switch (*xsPC++) {
163       case XS_OP_BRT:
164         i = *xsPC++ << 8; i |= *xsPC++;
165         if (xsRVal) xsPC = xsCodeBase+i;
166         break;
167       case XS_OP_BRF:
168         i = *xsPC++ << 8; i |= *xsPC++;
169         if (!xsRVal) xsPC = xsCodeBase+i;
170         break;
171       case XS_OP_BR:
172         i = *xsPC++ << 8; i |= *xsPC++;
173         xsPC = xsCodeBase+i;
174         break;
175       case XS_OP_BRSIGCK: /* same as BR, but checks for sigbreak */
176         i = *xsPC++ << 8; i |= *xsPC++;
177         xsPC = xsCodeBase+i;
178         CHECK_SIGBREAK /* due to WHILE/UNTIL */
179         break;
180       case XS_OP_LIT:
181         xsRVal = xsGetElement(xsRFun, *xsPC++);
182         break;
183       case XS_OP_GREF:
184         tmp = xsGetElement(xsRFun, *xsPC++);
185         if ((xsRVal = xsGetValue(tmp)) == xsUnboundSym) {
186           xsRVal = xsGetValue(xsEnter("*UNBOUND-HANDLER*"));
187           if (xsRVal != XS_NIL) {
188             xsPC -= 2; /* backup the xsPC */
189             tmp = xsMakeContinuation();
190             xsCheck(2);
191             xsPush(tmp);
192             xsPush(xsGetElement(xsRFun, xsPC[1]));
193             xsArgC = 2;
194             xsApply();
195           } else xsError("unbound variable", tmp);
196         }
197         break;
198       case XS_OP_GSET:
199         tmp = xsGetElement(xsRFun, *xsPC++);
200         if (xsGetValue(tmp) == xsUnboundSym) xsError("assigning to undefined variable", tmp);
201         xsSetValue(tmp, xsRVal);
202         break;
203       case XS_OP_GSETDEF:
204         xsSetValue(xsGetElement(xsRFun, *xsPC++), xsRVal);
205         break;
206       case XS_OP_EREF:
207         k = *xsPC++;
208         tmp = xsREnv;
209         while (--k >= 0) tmp = xsCDR(tmp);
210         xsRVal = xsGetElement(xsCAR(tmp), *xsPC++);
211         break;
212       case XS_OP_ESET:
213         k = *xsPC++;
214         tmp = xsREnv;
215         while (--k >= 0) tmp = xsCDR(tmp);
216         xsSetElement(xsCAR(tmp), *xsPC++, xsRVal);
217         break;
218       case XS_OP_EREF0: /* EREF 0 ... */
219         xsRVal = xsGetElement(xsCAR(xsREnv), *xsPC++);
220         break;
221       case XS_OP_ESET0: /* ESET 0 ... */
222         xsSetElement(xsCAR(xsREnv), *xsPC++, xsRVal);
223         break;
224       case XS_OP_AREF:
225         i = *xsPC++;
226         tmp = xsRVal;
227         if (!xsEnvP(tmp)) badargtype(tmp);
228         if ((tmp = findvar(tmp, xsGetElement(xsRFun, i), &off)) != XS_NIL) xsRVal = xsGetElement(xsCAR(tmp), off);
229         else xsRVal = xsUnassignedSym;
230         break;
231       case XS_OP_ASET:
232         i = *xsPC++;
233         tmp = xsPop();
234         if (!xsEnvP(tmp)) badargtype(tmp);
235         if ((tmp = findvar(tmp, xsGetElement(xsRFun, i), &off)) == XS_NIL) xsError("no binding for variable", xsGetElement(xsRFun, i));
236         xsSetElement(xsCAR(tmp), off, xsRVal);
237         break;
238       case XS_OP_SAVE: /* save a continuation */
239         i = *xsPC++ << 8; i |= *xsPC++;
240         xsCheck(3);
241         xsPush(xsSmFixNum((XS_FIXTYPE)i));
242         xsPush(xsRFun);
243         xsPush(xsREnv);
244         break;
245       case XS_OP_CALL: /* call a function (or built-in) */
246         xsArgC = *xsPC++; /* get argument count */
247         xsApply(); /* apply the function */
248 #ifdef XS_ALLOW_SIGBREAK
249 # ifdef XS_SIGBREAKS_ON_CALL
250         /* check for signal interruption */
251         if (xsSigBreakF) {
252           int sig = xsSigBreakF;
253           xsSigBreakF = 0;
254           xsUserSigHandler(sig);
255         }
256 # endif
257 #endif
258         CHECK_SIGBREAK
259         break;
260       case XS_OP_RETURN: /* return to the continuation on the stack */
261         /* out of stack? get out of evaluator */
262         /*
263         if (xsSP == xsStackTop) {
264           fprintf(stderr, "!!!!!!\n");
265           return;
266         }
267         */
268         xsReturn();
269         break;
270       case XS_OP_FRAME: /* create an environment frame */
271         i = *xsPC++; /* get the frame size */
272         xsREnv = xsNewFrame(xsREnv, i);
273         xsSetElement(xsCAR(xsREnv), 0, xsGetVNames(xsRFun));
274         break;
275       case XS_OP_MVARG:  /* move required argument to frame slot */
276         i = *xsPC++; /* get the slot number */
277         if (--xsArgC < 0) xsError("too few arguments", xsRFun); /* was xsFail */
278         xsSetElement(xsCAR(xsREnv), i, xsPop());
279         break;
280       case XS_OP_MVOARG: /* move optional argument to frame slot */
281         i = *xsPC++; /* get the slot number */
282         if (xsArgC > 0) {
283           xsSetElement(xsCAR(xsREnv), i, xsPop());
284           xsArgC--;
285         } else xsSetElement(xsCAR(xsREnv), i, xsObjDefault);
286         break;
287       case XS_OP_MVRARG: /* build rest argument and move to frame slot */
288         i = *xsPC++; /* get the slot number */
289         for (xsRVal = XS_NIL, k = xsArgC; --k >= 0; ) xsRVal = xsNewPair(xsSP[k], xsRVal);
290         xsSetElement(xsCAR(xsREnv), i, xsRVal);
291         xsDrop(xsArgC);
292         break;
293       case XS_OP_ALAST:  /* make sure there are no more arguments */
294         if (xsArgC > 0) xsError("too many arguments", xsRFun); /* was xsFail */
295         break;
296       case XS_OP_TRUE:
297         xsRVal = xsTrue;
298         break;
299       case XS_OP_NIL:
300         xsRVal = XS_NIL;
301         break;
302       case XS_OP_PUSH:
303         xsCPush(xsRVal);
304         break;
305       case XS_OP_CLOSE:
306         if (!xsCodeP(xsRVal)) badargtype(xsRVal);
307         xsRVal = xsNewClosure(xsRVal, xsREnv);
308         break;
309       case XS_OP_DELAY:
310         if (!xsCodeP(xsRVal)) badargtype(xsRVal);
311         xsRVal = xsNewPromise(xsRVal, xsREnv);
312         break;
313       case XS_OP_ATOMP:
314         xsRVal = xsIsAtom(xsRVal) ? xsTrue : XS_NIL;
315         break;
316       case XS_OP_EQP:
317         xsRVal = (xsRVal == xsPop() ? xsTrue : XS_NIL);
318         break;
319       case XS_OP_NULLP:
320         xsRVal = (xsRVal ? XS_NIL : xsTrue);
321         break;
322       case XS_OP_CONS:
323         xsRVal = xsNewPair(xsRVal, xsPop());
324         break;
325       case XS_OP_CAR:
326         if (!xsIsList(xsRVal)) badargtype(xsRVal);
327         xsRVal = xsRVal ? xsCAR(xsRVal) : XS_NIL;
328         break;
329       case XS_OP_CDR:
330         if (!xsIsList(xsRVal)) badargtype(xsRVal);
331         xsRVal = (xsRVal ? xsCDR(xsRVal) : XS_NIL);
332         break;
333       case XS_OP_SETCAR:
334         if (!xsPairP(xsRVal)) badargtype(xsRVal);
335         xsRPLACA(xsRVal, xsPop());
336         break;
337       case XS_OP_SETCDR:
338         if (!xsPairP(xsRVal)) badargtype(xsRVal);
339         xsRPLACD(xsRVal, xsPop());
340         break;
341       case XS_OP_MVXARG: /* move oarg to frame slot and jump or go on */
342         i = *xsPC++; /* get the slot number */
343         if (xsArgC > 0) {
344           /* argument is here */
345           xsSetElement(xsCAR(xsREnv), i, xsPop());
346           xsArgC--;
347           /* jump over the initializer */
348           i = *xsPC++ << 8; i |= *xsPC++;
349           xsPC = xsCodeBase+i;
350         } else {
351           /* skip jump addr */
352           xsPC += 2;
353         }
354         break;
355       case XS_OP_MVYARG: /* move oarg to frame slot and jump or go on; fix slot+1 */
356         i = *xsPC++; /* get the slot number */
357         if (xsArgC > 0) {
358           /* argument is here */
359           xsSetElement(xsCAR(xsREnv), i, xsPop());
360           xsArgC--;
361           /* fix svar */
362           xsSetElement(xsCAR(xsREnv), i+1, xsTrue);
363           /* jump over the initializer */
364           i = *xsPC++ << 8; i |= *xsPC++;
365           xsPC = xsCodeBase+i;
366         } else {
367           /* fix svar */
368           xsSetElement(xsCAR(xsREnv), i+1, XS_NIL);
369           /* skip jump addr */
370           xsPC += 2;
371         }
372         break;
373       case XS_OP_KWXARG: /* keyword arg */
374       case XS_OP_KWYARG: /* keyword arg, fix slot+1 */
375       case XS_OP_KWZARG: /* keyword arg, set to default */
376         opc = xsPC[-1];
377         i = *xsPC++; /* get the var slot number */
378         avn = *xsPC++; /* get the kwalist slot number */
379         if (xsArgC > 1) {
380           /* find stack position for this keyword argument */
381           if ((f = xsFindKeywordArg(xsGetElement(xsRFun, avn), i)) >= 0) {
382             /* found */
383             xsSetElement(xsCAR(xsREnv), i, xsSP[f+1]);
384             /* remove this arg */
385             for (t = f+1, f--; f >= 0; t--, f--) xsSP[t] = xsSP[f];
386             xsDrop(2);
387             xsArgC -= 2;
388             switch (opc) {
389               case XS_OP_KWYARG:
390                 /* fix svar */
391                 xsSetElement(xsCAR(xsREnv), i+1, xsTrue);
392                 /* fallthru */
393               case XS_OP_KWXARG:
394                 /* jump over the initializer */
395                 i = *xsPC++ << 8; i |= *xsPC++;
396                 xsPC = xsCodeBase+i;
397                 break;
398             }
399             break;
400           }
401         }
402         /* set to 'default value' or NIL */
403         switch (opc) {
404           case XS_OP_KWYARG:
405             /* fix svar */
406             xsSetElement(xsCAR(xsREnv), i+1, XS_NIL);
407             /* falltru */
408           case XS_OP_KWXARG:
409             /* skip jump addr */
410             xsPC += 2;
411             break;
412           case XS_OP_KWZARG:
413             /* fix var */
414             xsSetElement(xsCAR(xsREnv), i, xsObjDefault);
415             break;
416         }
417         break;
418       case XS_OP_ADD:
419         tmp = xsPop();
420         if (xsFixNumP(xsRVal) && xsFixNumP(tmp)) xsRVal = xsNewFixNum(xsGetFixNum(xsRVal)+xsGetFixNum(tmp));
421         else {
422           xsPush(tmp); xsPush(xsRVal); xsArgC = 2;
423           xsRVal = xsfadd();
424         }
425         break;
426       case XS_OP_SUB:
427         tmp = xsPop();
428         if (xsFixNumP(xsRVal) && xsFixNumP(tmp)) xsRVal = xsNewFixNum(xsGetFixNum(xsRVal)-xsGetFixNum(tmp));
429         else {
430           xsPush(tmp); xsPush(xsRVal); xsArgC = 2;
431           xsRVal = xsfsub();
432         }
433         break;
434       case XS_OP_MUL:
435         tmp = xsPop();
436         if (xsFixNumP(xsRVal) && xsFixNumP(tmp)) xsRVal = xsNewFixNum(xsGetFixNum(xsRVal)*xsGetFixNum(tmp));
437         else {
438           xsPush(tmp); xsPush(xsRVal); xsArgC = 2;
439           xsRVal = xsfmul();
440         }
441         break;
442       case XS_OP_DIV:
443         tmp = xsPop();
444         if (xsFixNumP(xsRVal) && xsFixNumP(tmp)) {
445           if ((fixtmp = xsGetFixNum(tmp)) == (XS_FIXTYPE)0) xsError("division by zero", xsRFun); /* was xsFail */
446           xsRVal = xsNewFixNum(xsGetFixNum(xsRVal)/fixtmp);
447         } else if (xsFixNumP(xsRVal)) badargtype(tmp);
448         else badargtype(xsRVal);
449         break;
450       case XS_OP_REM:
451         tmp = xsPop();
452         if (xsFixNumP(xsRVal) && xsFixNumP(tmp)) {
453           if ((fixtmp = xsGetFixNum(tmp)) == (XS_FIXTYPE)0) xsError("division by zero", xsRFun); /* was xsFail */
454           xsRVal = xsNewFixNum(xsGetFixNum(xsRVal)%fixtmp);
455         } else if (xsFixNumP(xsRVal)) badargtype(tmp);
456         else badargtype(xsRVal);
457         break;
458       case XS_OP_MOD:
459         tmp = xsPop();
460         if (xsFixNumP(xsRVal) && xsFixNumP(tmp)) {
461           if ((fixtmp = xsGetFixNum(tmp)) == (XS_FIXTYPE)0) xsError("division by zero", xsRFun); /* was xsFail */
462           fixtmp1 = xsGetFixNum(xsRVal) % fixtmp;
463           if ((fixtmp1 < 0 && fixtmp > 0) ||
464               (fixtmp1 > 0 && fixtmp < 0)) fixtmp1 += fixtmp;
465           xsRVal = xsNewFixNum(fixtmp1);
466         } else if (xsFixNumP(xsRVal)) badargtype(tmp);
467         else badargtype(xsRVal);
468         break;
469       case XS_OP_LESS:
470         tmp = xsPop();
471         if (xsFixNumP(xsRVal) && xsFixNumP(tmp)) xsRVal = xsGetFixNum(xsRVal)<xsGetFixNum(tmp) ? xsTrue : XS_NIL;
472         else {
473           xsPush(tmp); xsPush(xsRVal); xsArgC = 2;
474           xsRVal = xsflss();
475         }
476         break;
477       case XS_OP_EQUAL:
478         tmp = xsPop();
479         if (xsFixNumP(xsRVal) && xsFixNumP(tmp)) xsRVal = xsGetFixNum(xsRVal)==xsGetFixNum(tmp) ? xsTrue : XS_NIL;
480         else {
481           xsPush(tmp); xsPush(xsRVal); xsArgC = 2;
482           xsRVal = xsfeql();
483         }
484         break;
485       case XS_OP_GREAT:
486         tmp = xsPop();
487         if (xsFixNumP(xsRVal) && xsFixNumP(tmp)) xsRVal = xsGetFixNum(xsRVal)>xsGetFixNum(tmp) ? xsTrue : XS_NIL;
488         else {
489           xsPush(tmp); xsPush(xsRVal); xsArgC = 2;
490           xsRVal = xsfgtr();
491         }
492         break;
493       case XS_OP_NEQUAL:
494         tmp = xsPop();
495         if (xsFixNumP(xsRVal) && xsFixNumP(tmp)) xsRVal = xsGetFixNum(xsRVal)!=xsGetFixNum(tmp) ? xsTrue : XS_NIL;
496         else {
497           xsPush(tmp); xsPush(xsRVal); xsArgC = 2;
498           xsRVal = xsfneql();
499         }
500         break;
501       case XS_OP_LESSEQ:
502         tmp = xsPop();
503         if (xsFixNumP(xsRVal) && xsFixNumP(tmp)) xsRVal = xsGetFixNum(xsRVal)<=xsGetFixNum(tmp) ? xsTrue : XS_NIL;
504         else {
505           xsPush(tmp); xsPush(xsRVal); xsArgC = 2;
506           xsRVal = xsfleq();
507         }
508         break;
509       case XS_OP_GREATEQ:
510         tmp = xsPop();
511         if (xsFixNumP(xsRVal) && xsFixNumP(tmp)) xsRVal = xsGetFixNum(xsRVal)>=xsGetFixNum(tmp) ? xsTrue : XS_NIL;
512         else {
513           xsPush(tmp); xsPush(xsRVal); xsArgC = 2;
514           xsRVal = xsfgeq();
515         }
516         break;
517       case XS_OP_ZEROP:
518         if (xsFixNumP(xsRVal)) xsRVal = xsGetFixNum(xsRVal) ? XS_NIL : xsTrue;
519         else if (xsFloNumP(xsRVal)) xsRVal = xsGetFloNum(xsRVal)==0.0 ? xsTrue : XS_NIL;
520         else badargtype(xsRVal);
521         break;
522       case XS_OP_NEGP:
523         if (xsFixNumP(xsRVal)) xsRVal = xsGetFixNum(xsRVal)<0 ? xsTrue : XS_NIL;
524         else if (xsFloNumP(xsRVal)) xsRVal = xsGetFloNum(xsRVal)<0.0 ? xsTrue : XS_NIL;
525         else badargtype(xsRVal);
526         break;
527       case XS_OP_POSP:
528         if (xsFixNumP(xsRVal)) xsRVal = xsGetFixNum(xsRVal)>0 ? xsTrue : XS_NIL;
529         else if (xsFloNumP(xsRVal)) xsRVal = xsGetFloNum(xsRVal)>0.0 ? xsTrue : XS_NIL;
530         else badargtype(xsRVal);
531         break;
532       case XS_OP_ONEP:
533         if (xsFixNumP(xsRVal)) xsRVal = xsGetFixNum(xsRVal)==1 ? xsTrue : XS_NIL;
534         else if (xsFloNumP(xsRVal)) xsRVal = xsGetFloNum(xsRVal)==1.0 ? xsTrue : XS_NIL;
535         else badargtype(xsRVal);
536         break;
537       case XS_OP_INC1:
538         if (xsFixNumP(xsRVal)) xsRVal = xsNewFixNum(xsGetFixNum(xsRVal)+1);
539         else if (xsFloNumP(xsRVal)) xsRVal = xsNewFloNum(xsGetFixNum(xsRVal)+1.0);
540         else badargtype(xsRVal);
541         break;
542       case XS_OP_DEC1:
543         if (xsFixNumP(xsRVal)) xsRVal = xsNewFixNum(xsGetFixNum(xsRVal)-1);
544         else if (xsFloNumP(xsRVal)) xsRVal = xsNewFloNum(xsGetFixNum(xsRVal)-1.0);
545         else badargtype(xsRVal);
546         break;
547       case XS_OP_INC2:
548         if (xsFixNumP(xsRVal)) xsRVal = xsNewFixNum(xsGetFixNum(xsRVal)+2);
549         else if (xsFloNumP(xsRVal)) xsRVal = xsNewFloNum(xsGetFixNum(xsRVal)+2.0);
550         else badargtype(xsRVal);
551         break;
552       case XS_OP_DEC2:
553         if (xsFixNumP(xsRVal)) xsRVal = xsNewFixNum(xsGetFixNum(xsRVal)-2);
554         else if (xsFloNumP(xsRVal)) xsRVal = xsNewFloNum(xsGetFixNum(xsRVal)-2.0);
555         else badargtype(xsRVal);
556         break;
557       case XS_OP_INC4:
558         if (xsFixNumP(xsRVal)) xsRVal = xsNewFixNum(xsGetFixNum(xsRVal)+4);
559         else if (xsFloNumP(xsRVal)) xsRVal = xsNewFloNum(xsGetFixNum(xsRVal)+4.0);
560         else badargtype(xsRVal);
561         break;
562       case XS_OP_DEC4:
563         if (xsFixNumP(xsRVal)) xsRVal = xsNewFixNum(xsGetFixNum(xsRVal)-4);
564         else if (xsFloNumP(xsRVal)) xsRVal = xsNewFloNum(xsGetFixNum(xsRVal)-4.0);
565         else badargtype(xsRVal);
566         break;
567       case XS_OP_CXR_1: cxlen = 1; goto docXr;
568       case XS_OP_CXR_2: cxlen = 2; goto docXr;
569       case XS_OP_CXR_3: cxlen = 3; goto docXr;
570       case XS_OP_CXR_4: cxlen = 4; goto docXr;
571       case XS_OP_CXR_5: cxlen = 5; goto docXr;
572       case XS_OP_CXR_6: cxlen = 6; goto docXr;
573       case XS_OP_CXR_7: cxlen = 7; goto docXr;
574       case XS_OP_CXR_8: cxlen = 8;
575 docXr:
576         cxmask = *xsPC++;
577         while (cxlen-- > 0) {
578           if (!xsPairP(xsRVal)) xsBadType(xsRVal);
579           xsRVal = cxmask&01?xsCDR(xsRVal):xsCAR(xsRVal);
580           cxmask >>= 1;
581         }
582         break;
583       default:
584         /*fprintf(stderr, "opc=%02X\n", xsPC[-1]);*/
585         xsError("bad opcode", xsSmFixNum((XS_FIXTYPE)(*--xsPC)));
586         break;
587     }
588   }
589 }
590
591
592 static jmp_buf *xsEvalStringJP;
593
594 static void xsEvalStringCont (void) {
595   longjmp(*xsEvalStringJP, 1);
596 }
597
598
599 XSVal xsEvalString (const char *str) {
600   XSVal evs;
601   jmp_buf esJP;
602   jmp_buf *oesJP = xsEvalStringJP;
603   xsEvalStringJP = &esJP;
604   /*printf("EVAL-STRING: [%s]\n", str);*/
605   /*xsSP = xsStackTop;*/
606   /* save a continuation */
607   xsCheck(2);
608   xsPush(xsNewCCSubr(xsEvalStringCont, NULL));
609   xsPush(xsREnv);
610   /* setup the argument list */
611   xsPush(xsNewString(str));
612   /* run */
613   evs = xsEnter("%EVAL-WHOLE-STRING");
614   evs = (xsIsBound(evs) ? xsGetValue(evs) : XS_NIL);
615   xsRFun = xsREnv = xsRVal = XS_NIL;
616   if (evs == XS_NIL) {
617     xsDrop(3); /* drop args and continuation */
618     return XS_NIL;
619   }
620   if (setjmp(*xsEvalStringJP)) return xsRVal;
621   xsExecute(evs, 1);
622   xsEvalStringJP = oesJP;
623   return xsRVal;
624 }
625
626
627 /* apply a function to arguments */
628 /* The function should be in xsRVal and the arguments should
629  * be on the stack. The number of arguments should be in xsArgC.
630  */
631 void xsApply (void) {
632   XSVal tmp;
633   /* check for null function */
634   if (xsIsNil(xsRVal)) badfuntype(xsRVal);
635   /* dispatch on function type */
636   switch (xsCTypeNG(xsRVal)) {
637     case XS_CSUBR:
638       xsRVal = (*xsGetSubr(xsRVal))();
639       xsReturn();
640       break;
641     case XS_CXSUBR:
642       (*xsGetSubr(xsRVal))();
643       break;
644     case XS_CCLOSURE:
645       xsRFun = xsGetCode(xsRVal);
646       xsREnv = xsGetEnv(xsRVal);
647       xsCodeBase = xsPC = getcodestr(xsRFun);
648       break;
649     case XS_COBJECT:
650       xsSendMsg(xsRVal, xsGASymbol());
651       break;
652     case XS_CMETHOD:
653       xsRFun = xsGetCode(xsRVal);
654       xsREnv = xsNewPair(xsTop(), xsGetEnv(xsRVal));
655       xsCodeBase = xsPC = getcodestr(xsRFun);
656       break;
657     case XS_CCONTINUATION:
658       tmp = xsGetArg();
659       xsLastArg();
660       restoreContinuation();
661       xsRVal = tmp;
662       xsReturn();
663       break;
664     case XS_CUSER:
665       if (xsRVal->user.udef->exec) {
666         xsRVal = (xsRVal->user.udef->exec)(xsRVal);
667         xsReturn();
668         break;
669       }
670     default:
671       badfuntype(xsRVal);
672   }
673 }
674
675
676 /* return to a continuation on the stack */
677 void xsReturn (void) {
678   XSVal tmp;
679   /* restore the enviroment and the continuation function */
680   xsREnv = xsPop();
681   tmp = xsPop();
682   /* dispatch on the function type */
683   switch (xsCType(tmp)) {
684     case XS_CCODE:
685       xsRFun = tmp;
686       tmp = xsPop();
687       xsCodeBase = getcodestr(xsRFun);
688       xsPC = xsCodeBase+(int)xsGetSMFixNum(tmp);
689       break;
690     case XS_CCSUBR:
691       (*xsGetSubr(tmp))();
692       break;
693     default:
694       xsError("bad continuation", tmp);
695   }
696 }
697
698
699 /* protect the state of the interpreter from the collector */
700 void xsGCProtect (XSProtectedFn protectedF) {
701   int pcoff = xsPC-xsCodeBase;
702   protectedF();
703   if (xsRFun) {
704     xsCodeBase = getcodestr(xsRFun);
705     xsPC = xsCodeBase+pcoff;
706   }
707 }
708
709
710 /* value stack overflow */
711 void xsStackOverflow (void) {
712   xsAbort("value stack overflow");
713 }
714
715
716 static void xsPExecuteCont (void) {
717   longjmp(*xsTopLevelJP, XS_EXEC_EX_OK);
718 }
719
720
721 int xsPExecute (XSVal fun, int argNo) {
722   int res = XS_TRUE;
723   jmp_buf pexecBufJP;
724   jmp_buf *oldTLJP = xsTopLevelJP;
725   if (!xsClosureP(fun)) {
726     xsDrop(argNo);
727     return XS_FALSE;
728   }
729   xsTopLevelJP = &pexecBufJP;
730   switch (setjmp(pexecBufJP)) {
731     case 0:
732       xsRVal = fun;
733       /* push continuation */
734       xsCheck(2);
735       if (argNo == 0) {
736         xsPush(xsNewCCSubr(xsPExecuteCont, NULL));
737         xsPush(xsREnv);
738       } else {
739         int f;
740         /* make room for continuation */
741         xsPush(XS_NIL);
742         xsPush(XS_NIL);
743         /* move args */
744         for (f = 0; f < argNo; f++) xsSP[f] = xsSP[f+2];
745         xsSP[argNo+1] = xsNewCCSubr(xsPExecuteCont, NULL);
746         xsSP[argNo+0] = xsREnv;
747       }
748       xsExecute(fun, argNo);
749       break;
750     case XS_EXEC_EX_OK:
751       break;
752     default:
753       res = XS_FALSE;
754   }
755   xsTopLevelJP = oldTLJP;
756   return res;
757 }
758
759
760 static void xsfExecIntrCC (void) {
761   /* restore everything; env and self already poped */
762   XSVal tmp;
763   int pcOfs;
764   tmp = xsPop();
765   xsArgC = xsGetFixNum(tmp);
766   tmp = xsPop();
767   pcOfs = xsGetFixNum(tmp);
768   xsRFun = xsPop();
769   xsRVal = xsPop();
770   xsCodeBase = xsGetBCode(xsRFun)->vect.bdata;
771   xsPC = xsCodeBase+pcOfs;
772 }
773
774
775 void xsExecuteInterruptor (XSVal fun, int argNo) {
776   int f;
777   if (!xsClosureP(fun)) {
778     /* not a closure, just do nothing */
779     xsDrop(argNo);
780     return;
781   }
782   /* save various data */
783   xsCheck(6); /* ensure that we have a room for 6 items at the stack */
784   /* push 6 empty args */
785   xsPush(XS_NIL); xsPush(XS_NIL); xsPush(XS_NIL);
786   xsPush(XS_NIL); xsPush(XS_NIL); xsPush(XS_NIL);
787   /* move args */
788   for (f = 0; f < argNo; f++) xsSP[f] = xsSP[f+6];
789   /* */
790   xsSP[argNo+5] = xsRVal;
791   xsSP[argNo+4] = xsRFun;
792   xsRVal = fun; /* for apply, and protect from GC */
793   xsSP[argNo+3] = xsNewFixNum((XS_FIXTYPE)(xsPC-xsCodeBase)); /* save pc */
794   xsSP[argNo+2] = xsNewFixNum((XS_FIXTYPE)xsArgC); /* save current argument number; we really need it */
795   /* push continuation */
796   xsSP[argNo+1] = xsNewCCSubr(xsfExecIntrCC, NULL);
797   xsSP[argNo+0] = xsREnv;
798   /* apply function */
799   xsArgC = argNo;
800   xsApply();
801 }