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