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