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