home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / drdobbs / 1991 / 08 / xscheme / xsint.c < prev    next >
Text File  |  1991-06-04  |  11KB  |  480 lines
  1. /* xsint.c - xscheme bytecode interpreter */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7. #include "xsbcode.h"
  8.  
  9. /* sample rate (instructions per sample) */
  10. #define SRATE    1000
  11.  
  12. /* macros to get the address of the code string for a code object */
  13. #define getcodestr(x) ((unsigned char *)getstring(getbcode(x)))
  14.  
  15. /* globals */
  16. int trace=FALSE;    /* trace enable */
  17. int xlargc;        /* argument count */
  18. jmp_buf bc_dispatch;    /* bytecode dispatcher */
  19.  
  20. /* external variables */
  21. extern LVAL xlfun,xlenv,xlval;
  22. extern LVAL s_stdin,s_stdout,s_unbound;
  23. extern LVAL s_unassigned,default_object,true;
  24.  
  25. /* external routines */
  26. extern LVAL xadd(),xsub(),xmul(),xdiv(),xlss(),xeql(),xgtr();
  27.  
  28. /* local variables */
  29. static unsigned char *base,*pc;
  30. static int sample=SRATE;
  31.  
  32. #ifdef __STDC__
  33. static LVAL findvar(LVAL env,LVAL var,int *poff);
  34. static LVAL make_continuation(void);
  35. static void restore_continuation(void);
  36. static void badfuntype(LVAL arg);
  37. static void badargtype(LVAL arg);
  38. #else
  39. static LVAL findvar();
  40. static LVAL make_continuation();
  41. #endif
  42.  
  43. /* xtraceon - built-in function 'trace-on' */
  44. LVAL xtraceon()
  45. {
  46.     xllastarg()
  47.     trace = TRUE;
  48.     return (NIL);
  49. }
  50.  
  51. /* xtraceoff - built-in function 'trace-off' */
  52. LVAL xtraceoff()
  53. {
  54.     xllastarg()
  55.     trace = FALSE;
  56.     return (NIL);
  57. }
  58.  
  59. /* xlexecute - execute byte codes */
  60. void xlexecute(fun)
  61.   LVAL fun;
  62. {
  63.     register LVAL tmp;
  64.     register unsigned int i;
  65.     register int k;
  66.     FIXTYPE fixtmp;
  67.     int off;
  68.  
  69.     /* initialize the registers */
  70.     xlfun = getcode(fun);
  71.     xlenv = getenv(fun);
  72.     xlval = NIL;
  73.  
  74.     /* initialize the argument count */
  75.     xlargc = 0;
  76.  
  77.     /* set the initial pc */
  78.     base = pc = getcodestr(xlfun);
  79.  
  80.     /* setup a target for the error handler */
  81.     setjmp(bc_dispatch);
  82.     
  83.     /* execute the code */
  84.     for (;;) {
  85.  
  86.     /* check for control codes */
  87.     if (--sample <= 0) {
  88.         sample = SRATE;
  89.         oscheck();
  90.     }
  91.  
  92.     /* print the trace information */
  93.     if (trace)
  94.         decode_instruction(curoutput(),xlfun,(int)(pc-base),xlenv);
  95.  
  96.     /* execute the next bytecode instruction */
  97.     switch (*pc++) {
  98.     case OP_BRT:
  99.         i = *pc++ << 8; i |= *pc++;
  100.         if (xlval) pc = base + i;
  101.         break;
  102.     case OP_BRF:
  103.         i = *pc++ << 8; i |= *pc++;
  104.         if (!xlval) pc = base + i;
  105.         break;
  106.     case OP_BR:
  107.         i = *pc++ << 8; i |= *pc++;
  108.         pc = base + i;
  109.         break;
  110.     case OP_LIT:
  111.         xlval = getelement(xlfun,*pc++);
  112.         break;
  113.     case OP_GREF:
  114.         tmp = getelement(xlfun,*pc++);
  115.         if ((xlval = getvalue(tmp)) == s_unbound) {
  116.             xlval = getvalue(xlenter("*UNBOUND-HANDLER*"));
  117.             if (xlval != NIL) {
  118.             oscheck();
  119.             pc -= 2; /* backup the pc */
  120.             tmp = make_continuation();
  121.             check(2);
  122.             push(tmp);
  123.             push(getelement(xlfun,pc[1]));
  124.             xlargc = 2;
  125.             xlapply();
  126.             }
  127.             else
  128.             xlerror("unbound variable",tmp);
  129.         }
  130.         break;
  131.     case OP_GSET:
  132.         setvalue(getelement(xlfun,*pc++),xlval);
  133.         break;
  134.     case OP_EREF:
  135.         k = *pc++;
  136.         tmp = xlenv;
  137.         while (--k >= 0) tmp = cdr(tmp);
  138.         xlval = getelement(car(tmp),*pc++);
  139.         break;
  140.     case OP_ESET:
  141.         k = *pc++;
  142.         tmp = xlenv;
  143.         while (--k >= 0) tmp = cdr(tmp);
  144.         setelement(car(tmp),*pc++,xlval);
  145.         break;
  146.     case OP_AREF:
  147.         i = *pc++;
  148.         tmp = xlval;
  149.         if (!envp(tmp)) badargtype(tmp);
  150.         if ((tmp = findvar(tmp,getelement(xlfun,i),&off)) != NIL)
  151.             xlval = getelement(car(tmp),off);
  152.         else
  153.             xlval = s_unassigned;
  154.         break;
  155.     case OP_ASET:
  156.         i = *pc++;
  157.         tmp = pop();
  158.         if (!envp(tmp)) badargtype(tmp);
  159.         if ((tmp = findvar(tmp,getelement(xlfun,i),&off)) == NIL)
  160.             xlerror("no binding for variable",getelement(xlfun,i));
  161.         setelement(car(tmp),off,xlval);
  162.         break;
  163.     case OP_SAVE:    /* save a continuation */
  164.         i = *pc++ << 8; i |= *pc++;
  165.         check(3);
  166.         push(cvsfixnum((FIXTYPE)i));
  167.         push(xlfun);
  168.         push(xlenv);
  169.         break;
  170.     case OP_CALL:    /* call a function (or built-in) */
  171.         xlargc = *pc++;    /* get argument count */
  172.         xlapply();    /* apply the function */
  173.         break;
  174.     case OP_RETURN:    /* return to the continuation on the stack */
  175.         xlreturn();
  176.         break;
  177.     case OP_FRAME:    /* create an environment frame */
  178.         i = *pc++;    /* get the frame size */
  179.         xlenv = newframe(xlenv,i);
  180.         setelement(car(xlenv),0,getvnames(xlfun));
  181.         break;
  182.     case OP_MVARG:    /* move required argument to frame slot */
  183.         i = *pc++;    /* get the slot number */
  184.         if (--xlargc < 0)
  185.             xlfail("too few arguments");
  186.         setelement(car(xlenv),i,pop());
  187.         break;
  188.     case OP_MVOARG:    /* move optional argument to frame slot */
  189.         i = *pc++;    /* get the slot number */
  190.         if (xlargc > 0) {
  191.             setelement(car(xlenv),i,pop());
  192.             --xlargc;
  193.         }
  194.         else
  195.             setelement(car(xlenv),i,default_object);
  196.         break;
  197.     case OP_MVRARG:    /* build rest argument and move to frame slot */
  198.         i = *pc++;    /* get the slot number */
  199.         for (xlval = NIL, k = xlargc; --k >= 0; )
  200.             xlval = cons(xlsp[k],xlval);
  201.         setelement(car(xlenv),i,xlval);
  202.         drop(xlargc);
  203.         break;
  204.     case OP_ALAST:    /* make sure there are no more arguments */
  205.         if (xlargc > 0)
  206.             xlfail("too many arguments");
  207.         break;
  208.     case OP_T:
  209.         xlval = true;
  210.         break;
  211.     case OP_NIL:
  212.         xlval = NIL;
  213.         break;
  214.     case OP_PUSH:
  215.         cpush(xlval);
  216.         break;
  217.     case OP_CLOSE:
  218.         if (!codep(xlval)) badargtype(xlval);
  219.         xlval = cvclosure(xlval,xlenv);
  220.         break;
  221.     case OP_DELAY:
  222.         if (!codep(xlval)) badargtype(xlval);
  223.         xlval = cvpromise(xlval,xlenv);
  224.         break;
  225.     case OP_ATOM:
  226.         xlval = (atom(xlval) ? true : NIL);
  227.         break;
  228.     case OP_EQ:
  229.         xlval = (xlval == pop() ? true : NIL);
  230.         break;
  231.     case OP_NULL:
  232.         xlval = (xlval ? NIL : true);
  233.         break;
  234.     case OP_CONS:
  235.         xlval = cons(xlval,pop());
  236.         break;
  237.     case OP_CAR:
  238.         if (!listp(xlval)) badargtype(xlval);
  239.         xlval = (xlval ? car(xlval) : NIL);
  240.         break;
  241.     case OP_CDR:
  242.         if (!listp(xlval)) badargtype(xlval);
  243.         xlval = (xlval ? cdr(xlval) : NIL);
  244.         break;
  245.     case OP_SETCAR:
  246.         if (!consp(xlval)) badargtype(xlval);
  247.         rplaca(xlval,pop());
  248.         break;
  249.     case OP_SETCDR:
  250.         if (!consp(xlval)) badargtype(xlval);
  251.         rplacd(xlval,pop());
  252.         break;
  253.     case OP_ADD:
  254.         tmp = pop();
  255.         if (fixp(xlval) && fixp(tmp))
  256.             xlval = cvfixnum(getfixnum(xlval) + getfixnum(tmp));
  257.         else {
  258.             push(tmp); push(xlval); xlargc = 2;
  259.             xlval = xadd();
  260.         }
  261.         break;
  262.     case OP_SUB:
  263.         tmp = pop();
  264.         if (fixp(xlval) && fixp(tmp))
  265.             xlval = cvfixnum(getfixnum(xlval) - getfixnum(tmp));
  266.         else {
  267.             push(tmp); push(xlval); xlargc = 2;
  268.             xlval = xsub();
  269.         }
  270.         break;
  271.     case OP_MUL:
  272.         tmp = pop();
  273.         if (fixp(xlval) && fixp(tmp))
  274.             xlval = cvfixnum(getfixnum(xlval) * getfixnum(tmp));
  275.         else {
  276.             push(tmp); push(xlval); xlargc = 2;
  277.             xlval = xmul();
  278.         }
  279.         break;
  280.     case OP_QUO:
  281.         tmp = pop();
  282.         if (fixp(xlval) && fixp(tmp)) {
  283.             if ((fixtmp = getfixnum(tmp)) == (FIXTYPE)0)
  284.             xlfail("division by zero");
  285.             xlval = cvfixnum(getfixnum(xlval) / fixtmp);
  286.         }
  287.         else if (fixp(xlval))
  288.             badargtype(tmp);
  289.         else
  290.             badargtype(xlval);
  291.         break;
  292.     case OP_LSS:
  293.         tmp = pop();
  294.         if (fixp(xlval) && fixp(tmp))
  295.             xlval = (getfixnum(xlval) < getfixnum(tmp) ? true : NIL);
  296.         else {
  297.             push(tmp); push(xlval); xlargc = 2;
  298.             xlval = xlss();
  299.         }
  300.         break;
  301.     case OP_EQL:
  302.         tmp = pop();
  303.         if (fixp(xlval) && fixp(tmp))
  304.             xlval = (getfixnum(xlval) == getfixnum(tmp) ? true : NIL);
  305.         else {
  306.             push(tmp); push(xlval); xlargc = 2;
  307.             xlval = xeql();
  308.         }
  309.         break;
  310.     case OP_GTR:
  311.         tmp = pop();
  312.         if (fixp(xlval) && fixp(tmp))
  313.             xlval = (getfixnum(xlval) > getfixnum(tmp) ? true : NIL);
  314.         else {
  315.             push(tmp); push(xlval); xlargc = 2;
  316.             xlval = xgtr();
  317.         }
  318.         break;
  319.     default:
  320.         xlerror("bad opcode",cvsfixnum((FIXTYPE)*--pc));
  321.         break;
  322.     }
  323.     }
  324. }
  325.  
  326. /* findvar - find a variable in an environment */
  327. static LVAL findvar(env,var,poff)
  328.   LVAL env,var; int *poff;
  329. {
  330.     LVAL names;
  331.     int off;
  332.     for (; env != NIL; env = cdr(env)) {
  333.     names = getelement(car(env),0);
  334.     for (off = 1; names != NIL; ++off, names = cdr(names))
  335.         if (var == car(names)) {
  336.         *poff = off;
  337.         return (env);
  338.         }
  339.     }
  340.     return (NIL);
  341. }
  342.  
  343. /* xlapply - apply a function to arguments */
  344. /*    The function should be in xlval and the arguments should
  345.     be on the stack.  The number of arguments should be in xlargc.
  346. */
  347. void xlapply()
  348. {
  349.     LVAL tmp;
  350.  
  351.     /* check for null function */
  352.     if (null(xlval))
  353.     badfuntype(xlval);
  354.  
  355.     /* dispatch on function type */
  356.     switch (ntype(xlval)) {
  357.     case SUBR:
  358.     xlval = (*getsubr(xlval))();
  359.     xlreturn();
  360.     break;
  361.     case XSUBR:
  362.     (*getsubr(xlval))();
  363.     break;
  364.     case CLOSURE:
  365.     xlfun = getcode(xlval);
  366.     xlenv = getenv(xlval);
  367.     base = pc = getcodestr(xlfun);
  368.     break;
  369.     case OBJECT:
  370.     xlsend(xlval,xlgasymbol());
  371.     break;
  372.     case METHOD:
  373.     xlfun = getcode(xlval);
  374.     xlenv = cons(top(),getenv(xlval));
  375.     base = pc = getcodestr(xlfun);
  376.     break;
  377.     case CONTINUATION:
  378.     tmp = xlgetarg();
  379.     xllastarg();
  380.     restore_continuation();
  381.     xlval = tmp;
  382.     xlreturn();
  383.     break;
  384.     default:
  385.     badfuntype(xlval);
  386.     }
  387. }
  388.  
  389. /* xlreturn - return to a continuation on the stack */
  390. void xlreturn()
  391. {
  392.     LVAL tmp;
  393.     
  394.     /* restore the enviroment and the continuation function */
  395.     xlenv = pop();
  396.     tmp = pop();
  397.     
  398.     /* dispatch on the function type */
  399.     switch (ntype(tmp)) {
  400.     case CODE:
  401.         xlfun = tmp;
  402.         tmp = pop();
  403.     base = getcodestr(xlfun);
  404.     pc = base + (int)getsfixnum(tmp);
  405.     break;
  406.     case CSUBR:
  407.     (*getsubr(tmp))();
  408.     break;
  409.     default:
  410.     xlerror("bad continuation",tmp);
  411.     }
  412. }
  413.  
  414. /* make_continuation - make a continuation */
  415. static LVAL make_continuation()
  416. {
  417.     LVAL cont,*src,*dst;
  418.     int size;
  419.  
  420.     /* save a continuation on the stack */
  421.     check(3);
  422.     push(cvsfixnum((FIXTYPE)(pc - base)));
  423.     push(xlfun);
  424.     push(xlenv);
  425.  
  426.     /* create and initialize a continuation object */
  427.     size = (int)(xlstktop - xlsp);
  428.     cont = newcontinuation(size);
  429.     for (src = xlsp, dst = &cont->n_vdata[0]; --size >= 0; )
  430.     *dst++ = *src++;
  431.     
  432.     /* return the continuation */
  433.     return (cont);
  434. }
  435.  
  436. /* restore_continuation - restore a continuation to the stack */
  437. /*    The continuation should be in xlval.
  438. */
  439. static void restore_continuation()
  440. {
  441.     LVAL *src;
  442.     int size;
  443.     size = getsize(xlval);
  444.     for (src = &xlval->n_vdata[size], xlsp = xlstktop; --size >= 0; )
  445.     *--xlsp = *--src;
  446. }
  447.  
  448. /* gc_protect - protect the state of the interpreter from the collector */
  449. void gc_protect(protected_fcn)
  450.   void (*protected_fcn)();
  451. {
  452.     int pcoff;
  453.     pcoff = pc - base;
  454.     (*protected_fcn)();
  455.     if (xlfun) {
  456.     base = getcodestr(xlfun);
  457.     pc = base + pcoff;
  458.     }
  459. }
  460.  
  461. /* badfuntype - bad function error */
  462. static void badfuntype(arg)
  463.   LVAL arg;
  464. {
  465.     xlerror("bad function type",arg);
  466. }
  467.  
  468. /* badargtype - bad argument type error */
  469. static void badargtype(arg)
  470.   LVAL arg;
  471. {
  472.     xlbadtype(arg);
  473. }
  474.  
  475. /* xlstkover - value stack overflow */
  476. void xlstkover()
  477. {
  478.     xlabort("value stack overflow");
  479. }
  480.