home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / drdobbs / 1991 / 08 / xscheme / xscom.c < prev    next >
Text File  |  1991-05-14  |  37KB  |  1,516 lines
  1. /* xscom.c - a simple scheme bytecode compiler */
  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. /* size of code buffer */
  10. #define CMAX    4000
  11.  
  12. /* continuation types */
  13. #define C_RETURN    -1
  14. #define C_NEXT        -2
  15.  
  16. /* macro to check for a lambda list keyword */
  17. #define lambdakey(x)    ((x) == lk_optional || (x) == lk_rest)
  18.  
  19. /* external variables */
  20. extern LVAL lk_optional,lk_rest,true;
  21.  
  22. /* local variables */
  23. static LVAL info;        /* compiler info */
  24.  
  25. /* code buffer */
  26. static unsigned char cbuff[CMAX];    /* base of code buffer */
  27. static int cbase;            /* base for current function */
  28. static int cptr;            /* code buffer pointer */
  29.  
  30. /* forward declarations */
  31. #ifdef __STDC__
  32. static void do_expr(LVAL expr,int cont);
  33. static int in_ntab(LVAL expr,int cont);
  34. static int in_ftab(LVAL expr,int cont);
  35. static void do_define(LVAL form,int cont);
  36. static void define1(LVAL list,LVAL body,int cont);
  37. static void do_set(LVAL form,int cont);
  38. static void do_setvar(LVAL form,int cont);
  39. static void do_quote(LVAL form,int cont);
  40. static void do_lambda(LVAL form,int cont);
  41. static void cd_fundefinition(LVAL fun,LVAL fargs,LVAL body);
  42. static void parse_lambda_list(LVAL fargs,LVAL body);
  43. static int find_internal_definitions(LVAL body,LVAL last);
  44. static void do_delay(LVAL form,int cont);
  45. static void do_let(LVAL form,int cont);
  46. static void do_named_let(LVAL form,int cont);
  47. static void cd_let(LVAL name,LVAL form,int cont);
  48. static void do_letrec(LVAL form,int cont);
  49. static void do_letstar(LVAL form,int cont);
  50. static void letstar1(LVAL blist,LVAL body);
  51. static int push_dummy_values(LVAL blist);
  52. static int push_init_expressions(LVAL blist);
  53. static void parse_let_variables(LVAL blist,LVAL body);
  54. static void set_bound_variables(LVAL blist);
  55. static LVAL make_code_object(LVAL fun);
  56. static void do_cond(LVAL form,int cont);
  57. static void do_and(LVAL form,int cont);
  58. static void do_or(LVAL form,int cont);
  59. static void do_if(LVAL form,int cont);
  60. static void do_begin(LVAL form,int cont);
  61. static void do_while(LVAL form,int cont);
  62. static void do_access(LVAL form,int cont);
  63. static void do_setaccess(LVAL form,int cont);
  64. static void do_call(LVAL form,int cont);
  65. static int push_args(LVAL form);
  66. static void do_nary(int op,int n,LVAL form,int cont);
  67. static int push_nargs(LVAL form,int n);
  68. static void do_literal(LVAL lit,int cont);
  69. static void do_identifier(LVAL sym,int cont);
  70. static void do_continuation(int cont);
  71. static int add_level(void);
  72. static void remove_level(int oldcbase);
  73. static int findvariable(LVAL sym,int *plev,int *poff);
  74. static int findcvariable(LVAL sym,int *poff);
  75. static int findliteral(LVAL lit);
  76. static void cd_variable(int op,LVAL sym);
  77. static void cd_evariable(int op,int lev,int off);
  78. static void cd_literal(LVAL lit);
  79. static int putcbyte(int b);
  80. static int putcword(int w);
  81. static void fixup(int chn);
  82. #else
  83. static void do_define(),do_set(),do_quote(),do_lambda(),do_delay();
  84. static void do_let(),do_letrec(),do_letstar(),do_cond(),do_and(),do_or();
  85. static void do_if(),do_begin(),do_while(),do_access();
  86. static LVAL make_code_object();
  87. #endif
  88.  
  89. /* integrable function table */
  90. typedef struct { char *nt_name; int nt_code,nt_args; } NTDEF;
  91. static NTDEF *nptr,ntab[] = {
  92.     "ATOM",            OP_ATOM,    1,
  93.     "EQ?",            OP_EQ,        2,
  94.     "NULL?",        OP_NULL,    1,
  95.     "NOT",            OP_NULL,    1,
  96.     "CONS",            OP_CONS,    2,
  97.     "CAR",            OP_CAR,        1,
  98.     "CDR",            OP_CDR,        1,
  99.     "SET-CAR!",        OP_SETCAR,    2,
  100.     "SET-CDR!",        OP_SETCDR,    2,
  101.     "+",            OP_ADD,        -2,
  102.     "-",            OP_SUB,        -2,
  103.     "*",            OP_MUL,        -2,
  104.     "QUOTIENT",        OP_QUO,        -2,
  105.     "<",            OP_LSS,        -2,
  106.     "=",            OP_EQL,        -2,
  107.     ">",            OP_GTR,        -2,
  108.     0
  109. };
  110.  
  111. /* special form table */
  112. typedef struct { char *ft_name; void (*ft_fcn)(); } FTDEF;
  113. static FTDEF ftab[] = {
  114.     "QUOTE",    do_quote,
  115.     "LAMBDA",    do_lambda,
  116.     "DELAY",    do_delay,
  117.     "LET",        do_let,
  118.     "LET*",        do_letstar,
  119.     "LETREC",    do_letrec,
  120.     "DEFINE",    do_define,
  121.     "SET!",        do_set,
  122.     "IF",        do_if,
  123.     "COND",        do_cond,
  124.     "BEGIN",    do_begin,
  125.     "SEQUENCE",    do_begin,
  126.     "AND",        do_and,
  127.     "OR",        do_or,
  128.     "WHILE",    do_while,
  129.     "ACCESS",    do_access,
  130.     0
  131. };
  132.  
  133. /* xlcompile - compile an expression */
  134. LVAL xlcompile(expr,ctenv)
  135.   LVAL expr,ctenv;
  136. {
  137.     /* initialize the compile time environment */
  138.     info = cons(NIL,NIL); cpush(info);
  139.     rplaca(info,newframe(ctenv,1));
  140.     rplacd(info,cons(NIL,NIL));
  141.  
  142.     /* setup the base of the code for this function */
  143.     cbase = cptr = 0;
  144.  
  145.     /* setup the entry code */
  146.     putcbyte(OP_FRAME);
  147.     putcbyte(1);
  148.  
  149.     /* compile the expression */
  150.     do_expr(expr,C_RETURN);
  151.  
  152.     /* build the code object */
  153.     settop(make_code_object(NIL));
  154.     return (pop());
  155. }
  156.  
  157. /* xlfunction - compile a function */
  158. LVAL xlfunction(fun,fargs,body,ctenv)
  159.   LVAL fun,fargs,body,ctenv;
  160. {
  161.     /* initialize the compile time environment */
  162.     info = cons(NIL,NIL); cpush(info);
  163.     rplaca(info,newframe(ctenv,1));
  164.     rplacd(info,cons(NIL,NIL));
  165.  
  166.     /* setup the base of the code for this function */
  167.     cbase = cptr = 0;
  168.  
  169.     /* compile the lambda list and the function body */
  170.     parse_lambda_list(fargs,body);
  171.     do_begin(body,C_RETURN);
  172.  
  173.     /* build the code object */
  174.     settop(make_code_object(fun));
  175.     return (pop());
  176. }
  177.  
  178. /* do_expr - compile an expression */
  179. static void do_expr(expr,cont)
  180.   LVAL expr; int cont;
  181. {
  182.     LVAL fun;
  183.     if (consp(expr)) {
  184.     fun = car(expr);
  185.      if (!symbolp(fun) || (!in_ntab(expr,cont) && !in_ftab(expr,cont)))
  186.         do_call(expr,cont);
  187.     }
  188.     else if (symbolp(expr))
  189.     do_identifier(expr,cont);
  190.     else
  191.     do_literal(expr,cont);
  192. }
  193.  
  194. /* in_ntab - check for a function in ntab */
  195. static int in_ntab(expr,cont)
  196.   LVAL expr; int cont;
  197. {
  198.     char *pname;
  199.     pname = getstring(getpname(car(expr)));
  200.     for (nptr = ntab; nptr->nt_name; ++nptr)
  201.     if (strcmp(pname,nptr->nt_name) == 0) {
  202.         do_nary(nptr->nt_code,nptr->nt_args,expr,cont);
  203.         return (TRUE);
  204.     }
  205.     return (FALSE);
  206. }
  207.  
  208. /* in_ftab - check for a function in ftab */
  209. static int in_ftab(expr,cont)
  210.   LVAL expr; int cont;
  211. {
  212.     char *pname;
  213.     FTDEF *fptr;
  214.     pname = getstring(getpname(car(expr)));
  215.     for (fptr = ftab; fptr->ft_name; ++fptr)
  216.     if (strcmp(pname,fptr->ft_name) == 0) {
  217.         (*fptr->ft_fcn)(cdr(expr),cont);
  218.         return (TRUE);
  219.     }
  220.     return (FALSE);
  221. }
  222.  
  223. /* do_define - handle the (DEFINE ... ) expression */
  224. static void do_define(form,cont)
  225.   LVAL form; int cont;
  226. {
  227.     if (atom(form))
  228.     xlerror("expecting symbol or function template",form);
  229.     define1(car(form),cdr(form),cont);
  230. }
  231.  
  232. /* define1 - helper routine for do_define */
  233. static void define1(list,body,cont)
  234.   LVAL list,body; int cont;
  235. {
  236.     LVAL fargs;
  237.     int off;
  238.  
  239.     /* handle nested definitions */
  240.     if (consp(list)) {
  241.     cpush(cons(xlenter("LAMBDA"),NIL));    /* (LAMBDA) */
  242.     rplacd(top(),cons(cdr(list),NIL));    /* (LAMBDA args) */
  243.     rplacd(cdr(top()),body);        /* (LAMBDA args body) */
  244.     settop(cons(top(),NIL));        /* ((LAMBDA args body)) */
  245.     define1(car(list),top(),cont);
  246.     drop(1);
  247.     }
  248.     
  249.     /* compile procedure definitions */
  250.     else {
  251.  
  252.     /* make sure it's a symbol */
  253.     if (!symbolp(list))
  254.         xlerror("expecting a symbol",list);
  255.  
  256.     /* check for a procedure definition */
  257.     if (consp(body)
  258.         &&  consp(car(body))
  259.         &&  car(car(body)) == xlenter("LAMBDA")) {
  260.         fargs = car(cdr(car(body)));
  261.         body = cdr(cdr(car(body)));
  262.         cd_fundefinition(list,fargs,body);
  263.     }
  264.  
  265.     /* compile the value expression or procedure body */
  266.     else
  267.         do_begin(body,C_NEXT);
  268.     
  269.     /* define the variable value */
  270.     if (findcvariable(list,&off))
  271.         cd_evariable(OP_ESET,0,off);
  272.     else
  273.         cd_variable(OP_GSET,list);
  274.     do_literal(list,cont);
  275.     }
  276. }
  277.  
  278. /* do_set - compile the (SET! ... ) expression */
  279. static void do_set(form,cont)
  280.   LVAL form; int cont;
  281. {
  282.     if (atom(form))
  283.     xlerror("expecting symbol or ACCESS form",form);
  284.     else if (symbolp(car(form)))
  285.     do_setvar(form,cont);
  286.     else if (consp(car(form)))
  287.     do_setaccess(form,cont);
  288.     else
  289.     xlerror("expecting symbol or ACCESS form",form);
  290. }
  291.  
  292. /* do_setvar - compile the (SET! var value) expression */
  293. static void do_setvar(form,cont)
  294.   LVAL form; int cont;
  295. {
  296.     int lev,off;
  297.     LVAL sym;
  298.  
  299.     /* get the variable name */
  300.     sym = car(form);
  301.  
  302.     /* compile the value expression */
  303.     form = cdr(form);
  304.     if (atom(form))
  305.     xlerror("expecting value expression",form);
  306.     do_expr(car(form),C_NEXT);
  307.  
  308.     /* set the variable value */
  309.     if (findvariable(sym,&lev,&off))
  310.     cd_evariable(OP_ESET,lev,off);
  311.     else
  312.     cd_variable(OP_GSET,sym);
  313.     do_continuation(cont);
  314. }
  315.  
  316. /* do_quote - compile the (QUOTE ... ) expression */
  317. static void do_quote(form,cont)
  318.   LVAL form; int cont;
  319. {
  320.     if (atom(form))
  321.     xlerror("expecting quoted expression",form);
  322.     do_literal(car(form),cont);
  323. }
  324.  
  325. /* do_lambda - compile the (LAMBDA ... ) expression */
  326. static void do_lambda(form,cont)
  327.   LVAL form; int cont;
  328. {
  329.     if (atom(form))
  330.     xlerror("expecting argument list",form);
  331.     cd_fundefinition(NIL,car(form),cdr(form));
  332.     do_continuation(cont);
  333. }
  334.  
  335. /* cd_fundefinition - compile the function */
  336. static void cd_fundefinition(fun,fargs,body)
  337.   LVAL fun,fargs,body;
  338. {
  339.     int oldcbase;
  340.  
  341.     /* establish a new environment frame */
  342.     oldcbase = add_level();
  343.  
  344.     /* compile the lambda list and the function body */
  345.     parse_lambda_list(fargs,body);
  346.     do_begin(body,C_RETURN);
  347.  
  348.     /* build the code object */
  349.     cpush(make_code_object(fun));
  350.     
  351.     /* restore the previous environment */
  352.     remove_level(oldcbase);
  353.  
  354.     /* compile code to create a closure */
  355.     do_literal(pop(),C_NEXT);
  356.     putcbyte(OP_CLOSE);
  357. }
  358.  
  359. /* parse_lambda_list - parse the formal argument list */
  360. static void parse_lambda_list(fargs,body)
  361.   LVAL fargs,body;
  362. {
  363.     LVAL arg,restarg,new,last;
  364.     int frame,slotn;
  365.     
  366.     /* setup the entry code */
  367.     putcbyte(OP_FRAME);
  368.     frame = putcbyte(0);
  369.  
  370.     /* initialize the argument name list and slot number */
  371.     restarg = last = NIL;
  372.     slotn = 1;
  373.     
  374.     /* handle each required argument */
  375.     while (consp(fargs)
  376.     &&     (arg = car(fargs)) != NIL
  377.     &&     !lambdakey(arg)) {
  378.  
  379.     /* make sure the argument is a symbol */
  380.     if (!symbolp(arg))
  381.         xlerror("variable must be a symbol",arg);
  382.  
  383.     /* add the argument name to the name list */
  384.     new = cons(arg,NIL);
  385.     if (last) rplacd(last,new);
  386.     else setelement(car(car(info)),0,new);
  387.     last = new;
  388.  
  389.     /* generate an instruction to move the argument into the frame */
  390.     putcbyte(OP_MVARG);
  391.     putcbyte(slotn++);
  392.     
  393.     /* move the formal argument list pointer ahead */
  394.     fargs = cdr(fargs);
  395.     }
  396.  
  397.     /* check for the '#!optional' argument */
  398.     if (consp(fargs)
  399.     &&  car(fargs) == lk_optional) {
  400.     fargs = cdr(fargs);
  401.  
  402.     /* handle each optional argument */
  403.     while (consp(fargs)
  404.     &&     (arg = car(fargs)) != NIL
  405.     &&     !lambdakey(arg)) {
  406.  
  407.         /* make sure the argument is a symbol */
  408.         if (!symbolp(arg))
  409.         xlerror("#!optional variable must be a symbol",arg);
  410.  
  411.         /* add the argument name to the name list */
  412.         new = cons(arg,NIL);
  413.         if (last) rplacd(last,new);
  414.         else setelement(car(car(info)),0,new);
  415.         last = new;
  416.  
  417.         /* move the argument into the frame */
  418.         putcbyte(OP_MVOARG);
  419.         putcbyte(slotn++);
  420.     
  421.         /* move the formal argument list pointer ahead */
  422.         fargs = cdr(fargs);
  423.     }
  424.     }
  425.  
  426.     /* check for the '#!rest' argument */
  427.     if (consp(fargs)
  428.     &&  car(fargs) == lk_rest) {
  429.     fargs = cdr(fargs);
  430.  
  431.     /* handle the rest argument */
  432.     if (consp(fargs)
  433.     &&  (restarg = car(fargs)) != NIL
  434.     &&  !lambdakey(restarg)) {
  435.  
  436.         /* make sure the argument is a symbol */
  437.         if (!symbolp(restarg))
  438.         xlerror("#!rest variable must be a symbol",restarg);
  439.  
  440.         /* add the argument name to the name list */
  441.         new = cons(restarg,NIL);
  442.         if (last) rplacd(last,new);
  443.         else setelement(car(car(info)),0,new);
  444.         last = new;
  445.  
  446.         /* make the #!rest argument list */
  447.         putcbyte(OP_MVRARG);
  448.         putcbyte(slotn++);
  449.  
  450.         /* move the formal argument list pointer ahead */
  451.         fargs = cdr(fargs);
  452.     }
  453.     else
  454.         xlerror("expecting the #!rest variable",fargs);
  455.     }
  456.  
  457.     /* check for the a dotted tail */
  458.     if (restarg == NIL && symbolp(fargs)) {
  459.     restarg = fargs;
  460.  
  461.     /* add the argument name to the name list */
  462.     new = cons(restarg,NIL);
  463.     if (last) rplacd(last,new);
  464.     else setelement(car(car(info)),0,new);
  465.     last = new;
  466.  
  467.     /* make the #!rest argument list */
  468.     putcbyte(OP_MVRARG);
  469.     putcbyte(slotn++);
  470.     fargs = NIL;
  471.     }
  472.  
  473.     /* check for the end of the argument list */
  474.     if (fargs != NIL)
  475.     xlerror("bad argument list tail",fargs);
  476.  
  477.     /* make sure the user didn't supply too many arguments */
  478.     if (restarg == NIL)
  479.     putcbyte(OP_ALAST);
  480.     
  481.     /* scan the body for internal definitions */
  482.     slotn += find_internal_definitions(body,last);
  483.     
  484.     /* fixup the frame instruction */
  485.     cbuff[cbase+frame] = slotn;
  486. }
  487.  
  488. /* find_internal_definitions - find internal definitions */
  489. static int find_internal_definitions(body,last)
  490.   LVAL body,last;
  491. {
  492.     LVAL define,sym,new;
  493.     int n=0;
  494.  
  495.     /* look for all (define...) forms */
  496.     for (define = xlenter("DEFINE"); consp(body); body = cdr(body))
  497.     if (consp(car(body)) && car(car(body)) == define) {
  498.         sym = cdr(car(body)); /* the rest of the (define...) form */
  499.         if (consp(sym)) {     /* make sure there is a second subform */
  500.         sym = car(sym);   /* get the second subform */
  501.         while (consp(sym))/* check for a procedure definition */
  502.             sym = car(sym);
  503.         if (symbolp(sym)) {
  504.             new = cons(sym,NIL);
  505.             if (last) rplacd(last,new);
  506.             else setelement(car(car(info)),0,new);
  507.             last = new;
  508.             ++n;
  509.         }
  510.         }
  511.     }
  512.     return (n);
  513. }
  514.  
  515. /* do_delay - compile the (DELAY ... ) expression */
  516. static void do_delay(form,cont)
  517.   LVAL form; int cont;
  518. {
  519.     int oldcbase;
  520.  
  521.     /* check argument list */
  522.     if (atom(form))
  523.     xlerror("expecting delay expression",form);
  524.  
  525.     /* establish a new environment frame */
  526.     oldcbase = add_level();
  527.  
  528.     /* setup the entry code */
  529.     putcbyte(OP_FRAME);
  530.     putcbyte(1);
  531.  
  532.     /* compile the expression */
  533.     do_expr(car(form),C_RETURN);
  534.  
  535.     /* build the code object */
  536.     cpush(make_code_object(NIL));
  537.     
  538.     /* restore the previous environment */
  539.     remove_level(oldcbase);
  540.  
  541.     /* compile code to create a closure */
  542.     do_literal(pop(),C_NEXT);
  543.     putcbyte(OP_DELAY);
  544.     do_continuation(cont);
  545. }
  546.  
  547. /* do_let - compile the (LET ... ) expression */
  548. static void do_let(form,cont)
  549.   LVAL form; int cont;
  550. {
  551.     /* handle named let */
  552.     if (consp(form) && symbolp(car(form)))
  553.     do_named_let(form,cont);
  554.     
  555.     /* handle unnamed let */
  556.     else
  557.         cd_let(NIL,form,cont);
  558. }
  559.  
  560. /* do_named_let - compile the (LET name ... ) expression */
  561. static void do_named_let(form,cont)
  562.   LVAL form; int cont;
  563. {
  564.     int oldcbase,nxt;
  565.  
  566.     /* save a continuation */
  567.     if (cont != C_RETURN) {
  568.     putcbyte(OP_SAVE);
  569.     nxt = putcword(0);
  570.     }
  571.     
  572.     /* establish a new environment frame */
  573.     oldcbase = add_level();
  574.     setelement(car(car(info)),0,cons(car(form),NIL));
  575.  
  576.     /* setup the entry code */
  577.     putcbyte(OP_FRAME);
  578.     putcbyte(2);
  579.     
  580.     /* compile the let expression */
  581.     cd_let(car(form),cdr(form),C_RETURN);
  582.  
  583.     /* build the code object */
  584.     cpush(make_code_object(NIL));
  585.     
  586.     /* restore the previous environment */
  587.     remove_level(oldcbase);
  588.  
  589.     /* compile code to create a closure */
  590.     do_literal(pop(),C_NEXT);
  591.     putcbyte(OP_CLOSE);
  592.  
  593.     /* apply the function */
  594.     putcbyte(OP_CALL);
  595.     putcbyte(1);
  596.  
  597.     /* target for the continuation */
  598.     if (cont != C_RETURN)
  599.     fixup(nxt);
  600. }
  601.  
  602. /* cd_let - code a let expression */
  603. static void cd_let(name,form,cont)
  604.   LVAL name,form; int cont;
  605. {
  606.     int oldcbase,nxt,lev,off,n;
  607.  
  608.     /* make sure there is a binding list */
  609.     if (atom(form) || !listp(car(form)))
  610.     xlerror("expecting binding list",form);
  611.  
  612.     /* save a continuation */
  613.     if (cont != C_RETURN) {
  614.     putcbyte(OP_SAVE);
  615.     nxt = putcword(0);
  616.     }
  617.     
  618.     /* push the initialization expressions */
  619.     n = push_init_expressions(car(form));
  620.  
  621.     /* establish a new environment frame */
  622.     oldcbase = add_level();
  623.  
  624.     /* compile the binding list */
  625.     parse_let_variables(car(form),cdr(form));
  626.  
  627.     /* compile the body of the let/letrec */
  628.     do_begin(cdr(form),C_RETURN);
  629.  
  630.     /* build the code object */
  631.     cpush(make_code_object(NIL));
  632.     
  633.     /* restore the previous environment */
  634.     remove_level(oldcbase);
  635.  
  636.     /* compile code to create a closure */
  637.     do_literal(pop(),C_NEXT);
  638.     putcbyte(OP_CLOSE);
  639.  
  640.     /* store the procedure */
  641.     if (name && findvariable(name,&lev,&off))
  642.     cd_evariable(OP_ESET,lev,off);
  643.  
  644.     /* apply the function */
  645.     putcbyte(OP_CALL);
  646.     putcbyte(n);
  647.  
  648.     /* target for the continuation */
  649.     if (cont != C_RETURN)
  650.     fixup(nxt);
  651. }
  652.  
  653. /* do_letrec - compile the (LETREC ... ) expression */
  654. static void do_letrec(form,cont)
  655.   LVAL form; int cont;
  656. {
  657.     int oldcbase,nxt,n;
  658.  
  659.     /* make sure there is a binding list */
  660.     if (atom(form) || !listp(car(form)))
  661.     xlerror("expecting binding list",form);
  662.  
  663.     /* save a continuation */
  664.     if (cont != C_RETURN) {
  665.     putcbyte(OP_SAVE);
  666.     nxt = putcword(0);
  667.     }
  668.     
  669.     /* push the initialization expressions */
  670.     n = push_dummy_values(car(form));
  671.  
  672.     /* establish a new environment frame */
  673.     oldcbase = add_level();
  674.  
  675.     /* compile the binding list */
  676.     parse_let_variables(car(form),cdr(form));
  677.  
  678.     /* compile instructions to set the bound variables */
  679.     set_bound_variables(car(form));
  680.     
  681.     /* compile the body of the let/letrec */
  682.     do_begin(cdr(form),C_RETURN);
  683.  
  684.     /* build the code object */
  685.     cpush(make_code_object(NIL));
  686.     
  687.     /* restore the previous environment */
  688.     remove_level(oldcbase);
  689.  
  690.     /* compile code to create a closure */
  691.     do_literal(pop(),C_NEXT);
  692.     putcbyte(OP_CLOSE);
  693.  
  694.     /* apply the function */
  695.     putcbyte(OP_CALL);
  696.     putcbyte(n);
  697.  
  698.     /* target for the continuation */
  699.     if (cont != C_RETURN)
  700.     fixup(nxt);
  701. }
  702.  
  703. /* do_letstar - compile the (LET* ... ) expression */
  704. static void do_letstar(form,cont)
  705.   LVAL form; int cont;
  706. {
  707.     int nxt;
  708.     
  709.     /* make sure there is a binding list */
  710.     if (atom(form) || !listp(car(form)))
  711.     xlerror("expecting binding list",form);
  712.  
  713.     /* handle the case where there are bindings */
  714.     if (consp(car(form))) {
  715.     
  716.     /* save a continuation */
  717.     if (cont != C_RETURN) {
  718.         putcbyte(OP_SAVE);
  719.         nxt = putcword(0);
  720.     }
  721.     
  722.     /* build the nested lambda expressions */
  723.     letstar1(car(form),cdr(form));
  724.     
  725.     /* target for the continuation */
  726.     if (cont != C_RETURN)
  727.         fixup(nxt);
  728.     }
  729.     
  730.     /* handle the case where there are no bindings */
  731.     else
  732.     do_begin(cdr(form),cont);
  733. }
  734.  
  735. /* letstar1 - helper routine for let* */
  736. static void letstar1(blist,body)
  737.   LVAL blist,body;
  738. {
  739.     int oldcbase,n;
  740.  
  741.     /* push the next initialization expressions */
  742.     cpush(cons(car(blist),NIL));
  743.     n = push_init_expressions(top());
  744.  
  745.     /* establish a new environment frame */
  746.     oldcbase = add_level();
  747.  
  748.     /* handle the case where there are more bindings */
  749.     if (consp(cdr(blist))) {
  750.     parse_let_variables(top(),NIL);
  751.     letstar1(cdr(blist),body);
  752.     }
  753.     
  754.     /* handle the last binding */
  755.     else {
  756.     parse_let_variables(top(),body);
  757.     do_begin(body,C_RETURN);
  758.     }
  759.     
  760.     /* build the code object */
  761.     settop(make_code_object(NIL));
  762.     
  763.     /* restore the previous environment */
  764.     remove_level(oldcbase);
  765.  
  766.     /* compile code to create a closure */
  767.     do_literal(pop(),C_NEXT);
  768.     putcbyte(OP_CLOSE);
  769.  
  770.     /* apply the function */
  771.     putcbyte(OP_CALL);
  772.     putcbyte(n);
  773. }
  774.  
  775. /* push_dummy_values - push dummy values for a 'letrec' expression */
  776. static int push_dummy_values(blist)
  777.   LVAL blist;
  778. {
  779.     int n=0;
  780.     if (consp(blist)) {
  781.     putcbyte(OP_NIL);
  782.     for (; consp(blist); blist = cdr(blist), ++n)
  783.         putcbyte(OP_PUSH);
  784.     }
  785.     return (n);
  786. }
  787.  
  788. /* push_init_expressions - push init expressions for a 'let' expression */
  789. static int push_init_expressions(blist)
  790.   LVAL blist;
  791. {
  792.     int n;
  793.     if (consp(blist)) {
  794.     n = push_init_expressions(cdr(blist));
  795.     if (consp(car(blist)) && consp(cdr(car(blist))))
  796.         do_expr(car(cdr(car(blist))),C_NEXT);
  797.     else
  798.         putcbyte(OP_NIL);
  799.     putcbyte(OP_PUSH);
  800.     return (n+1);
  801.     }
  802.     return (0);
  803. }
  804.  
  805. /* parse_let_variables - parse the binding list */
  806. static void parse_let_variables(blist,body)
  807.   LVAL blist,body;
  808. {
  809.     LVAL arg,new,last;
  810.     int frame,slotn;
  811.     
  812.     /* setup the entry code */
  813.     putcbyte(OP_FRAME);
  814.     frame = putcbyte(0);
  815.  
  816.     /* initialize the argument name list and slot number */
  817.     last = NIL;
  818.     slotn = 1;
  819.     
  820.     /* handle each required argument */
  821.     while (consp(blist) && (arg = car(blist)) != NIL) {
  822.  
  823.     /* make sure the argument is a symbol */
  824.     if (symbolp(arg))
  825.         new = cons(arg,NIL);
  826.     else if (consp(arg) && symbolp(car(arg)))
  827.         new = cons(car(arg),NIL);
  828.     else
  829.         xlerror("invalid binding",arg);
  830.  
  831.     /* add the argument name to the name list */
  832.     if (last) rplacd(last,new);
  833.     else setelement(car(car(info)),0,new);
  834.     last = new;
  835.  
  836.     /* generate an instruction to move the argument into the frame */
  837.     putcbyte(OP_MVARG);
  838.     putcbyte(slotn++);
  839.     
  840.     /* move the formal argument list pointer ahead */
  841.     blist = cdr(blist);
  842.     }
  843.     putcbyte(OP_ALAST);
  844.  
  845.     /* scan the body for internal definitions */
  846.     slotn += find_internal_definitions(body,last);
  847.     
  848.     /* fixup the frame instruction */
  849.     cbuff[cbase+frame] = slotn;
  850. }
  851.  
  852. /* set_bound_variables - set bound variables in a 'letrec' expression */
  853. static void set_bound_variables(blist)
  854.   LVAL blist;
  855. {
  856.     int lev,off;
  857.     for (; consp(blist); blist = cdr(blist)) {
  858.     if (consp(car(blist)) && consp(cdr(car(blist)))) {
  859.         do_expr(car(cdr(car(blist))),C_NEXT);
  860.         if (findvariable(car(car(blist)),&lev,&off))
  861.         cd_evariable(OP_ESET,lev,off);
  862.         else
  863.         xlerror("compiler error -- can't find",car(car(blist)));
  864.     }
  865.     }
  866. }
  867.  
  868. /* make_code_object - build a code object */
  869. static LVAL make_code_object(fun)
  870.   LVAL fun;
  871. {
  872.     unsigned char *cp;
  873.     LVAL code,p;
  874.     int i;
  875.  
  876.     /* create a code object */
  877.     code = newcode(FIRSTLIT + length(car(cdr(info)))); cpush(code);
  878.     setbcode(code,newstring(cptr - cbase));
  879.     setcname(code,fun);                        /* function name */
  880.     setvnames(code,getelement(car(car(info)),0));/* lambda list variables */
  881.  
  882.     /* copy the literals into the code object */
  883.     for (i = FIRSTLIT, p = car(cdr(info)); consp(p); p = cdr(p), ++i)
  884.     setelement(code,i,car(p));
  885.  
  886.     /* copy the byte codes */
  887.     for (i = cbase, cp = (unsigned char *)getstring(getbcode(code)); i < cptr; )
  888.     *cp++ = cbuff[i++];
  889.  
  890.     /* return the new code object */
  891.     return (pop());
  892. }
  893.  
  894. /* do_cond - compile the (COND ... ) expression */
  895. static void do_cond(form,cont)
  896.   LVAL form; int cont;
  897. {
  898.     int nxt,end;
  899.     if (consp(form)) {
  900.     for (end = 0; consp(form); form = cdr(form)) {
  901.         if (atom(car(form)))
  902.         xlerror("expecting a cond clause",form);
  903.         do_expr(car(car(form)),C_NEXT);
  904.         putcbyte(OP_BRF);
  905.         nxt = putcword(0);
  906.         if (cdr(car(form)))
  907.         do_begin(cdr(car(form)),cont);
  908.         else
  909.         do_continuation(cont);
  910.         if (cont == C_NEXT) {
  911.         putcbyte(OP_BR);
  912.         end = putcword(end);
  913.         }
  914.         fixup(nxt);
  915.     }
  916.     fixup(end);
  917.     }
  918.     else
  919.     putcbyte(OP_NIL);
  920.     do_continuation(cont);
  921. }
  922.  
  923. /* do_and - compile the (AND ... ) expression */
  924. static void do_and(form,cont)
  925.   LVAL form; int cont;
  926. {
  927.     int end;
  928.     if (consp(form)) {
  929.     for (end = 0; consp(form); form = cdr(form)) {
  930.         if (cdr(form)) {
  931.         do_expr(car(form),C_NEXT);
  932.         putcbyte(OP_BRF);
  933.         end = putcword(end);
  934.         }
  935.         else
  936.         do_expr(car(form),cont);
  937.     }
  938.     fixup(end);
  939.     }
  940.     else
  941.     putcbyte(OP_T);
  942.     do_continuation(cont);
  943. }
  944.  
  945. /* do_or - compile the (OR ... ) expression */
  946. static void do_or(form,cont)
  947.   LVAL form; int cont;
  948. {
  949.     int end;
  950.     if (consp(form)) {
  951.     for (end = 0; consp(form); form = cdr(form)) {
  952.         if (cdr(form)) {
  953.         do_expr(car(form),C_NEXT);
  954.         putcbyte(OP_BRT);
  955.         end = putcword(end);
  956.         }
  957.         else
  958.         do_expr(car(form),cont);
  959.     }
  960.     fixup(end);
  961.     }
  962.     else
  963.     putcbyte(OP_NIL);
  964.     do_continuation(cont);
  965. }
  966.  
  967. /* do_if - compile the (IF ... ) expression */
  968. static void do_if(form,cont)
  969.   LVAL form; int cont;
  970. {
  971.     int nxt,end;
  972.  
  973.     /* compile the test expression */
  974.     if (atom(form))
  975.     xlerror("expecting test expression",form);
  976.     do_expr(car(form),C_NEXT);
  977.  
  978.     /* skip around the 'then' clause if the expression is false */
  979.     putcbyte(OP_BRF);
  980.     nxt = putcword(0);
  981.  
  982.     /* skip to the 'then' clause */
  983.     form = cdr(form);
  984.     if (atom(form))
  985.     xlerror("expecting then clause",form);
  986.  
  987.     /* compile the 'then' and 'else' clauses */
  988.     if (consp(cdr(form))) {
  989.     if (cont == C_NEXT) {
  990.         do_expr(car(form),C_NEXT);
  991.         putcbyte(OP_BR);
  992.         end = putcword(0);
  993.     }
  994.     else {
  995.         do_expr(car(form),cont);
  996.         end = -1;
  997.     }
  998.     fixup(nxt);
  999.     do_expr(car(cdr(form)),cont);
  1000.     nxt = end;
  1001.     }
  1002.  
  1003.     /* compile just a 'then' clause */
  1004.     else
  1005.     do_expr(car(form),cont);
  1006.  
  1007.     /* handle the end of the statement */
  1008.     if (nxt >= 0) {
  1009.     fixup(nxt);
  1010.     do_continuation(cont);
  1011.     }
  1012. }
  1013.  
  1014. /* do_begin - compile the (BEGIN ... ) expression */
  1015. static void do_begin(form,cont)
  1016.   LVAL form; int cont;
  1017. {
  1018.     if (consp(form))
  1019.     for (; consp(form); form = cdr(form))
  1020.         if (consp(cdr(form)))
  1021.         do_expr(car(form),C_NEXT);
  1022.         else
  1023.         do_expr(car(form),cont);
  1024.     else {
  1025.     putcbyte(OP_NIL);
  1026.     do_continuation(cont);
  1027.     }
  1028. }
  1029.  
  1030. /* do_while - compile the (WHILE ... ) expression */
  1031. static void do_while(form,cont)
  1032.   LVAL form; int cont;
  1033. {
  1034.     int loop,nxt;
  1035.  
  1036.     /* make sure there is a test expression */
  1037.     if (atom(form))
  1038.     xlerror("expecting test expression",form);
  1039.  
  1040.     /* skip around the 'body' to the test expression */
  1041.     putcbyte(OP_BR);
  1042.     nxt = putcword(0);
  1043.  
  1044.     /* compile the loop body */
  1045.     loop = cptr - cbase;
  1046.     do_begin(cdr(form),C_NEXT);
  1047.  
  1048.     /* label for the first iteration */
  1049.     fixup(nxt);
  1050.  
  1051.     /* compile the test expression */
  1052.     nxt = cptr - cbase;
  1053.     do_expr(car(form),C_NEXT);
  1054.  
  1055.     /* skip around the 'body' if the expression is false */
  1056.     putcbyte(OP_BRT);
  1057.     putcword(loop);
  1058.  
  1059.     /* compile the continuation */
  1060.     do_continuation(cont);
  1061. }
  1062.  
  1063. /* do_access - compile the (ACCESS var env) expression */
  1064. static void do_access(form,cont)
  1065.   LVAL form; int cont;
  1066. {
  1067.     LVAL sym;
  1068.  
  1069.     /* get the variable name */
  1070.     if (atom(form) || !symbolp(car(form)))
  1071.     xlerror("expecting symbol",form);
  1072.     sym = car(form);
  1073.  
  1074.     /* compile the environment expression */
  1075.     form = cdr(form);
  1076.     if (atom(form))
  1077.     xlerror("expecting environment expression",form);
  1078.     do_expr(car(form),C_NEXT);
  1079.  
  1080.     /* get the variable value */
  1081.     cd_variable(OP_AREF,sym);
  1082.     do_continuation(cont);
  1083. }
  1084.  
  1085. /* do_setaccess - compile the (SET! (ACCESS var env) value) expression */
  1086. static void do_setaccess(form,cont)
  1087.   LVAL form; int cont;
  1088. {
  1089.     LVAL aform,sym;
  1090.  
  1091.     /* make sure this is an access form */
  1092.     aform = car(form);
  1093.     if (atom(aform) || car(aform) != xlenter("ACCESS"))
  1094.     xlerror("expecting an ACCESS form",aform);
  1095.  
  1096.     /* get the variable name */
  1097.     aform = cdr(aform);
  1098.     if (atom(aform) || !symbolp(car(aform)))
  1099.     xlerror("expecting symbol",aform);
  1100.     sym = car(aform);
  1101.  
  1102.     /* compile the environment expression */
  1103.     aform = cdr(aform);
  1104.     if (atom(aform))
  1105.     xlerror("expecting environment expression",aform);
  1106.     do_expr(car(aform),C_NEXT);
  1107.     putcbyte(OP_PUSH);
  1108.  
  1109.     /* compile the value expression */
  1110.     form = cdr(form);
  1111.     if (atom(form))
  1112.     xlerror("expecting value expression",form);
  1113.     do_expr(car(form),C_NEXT);
  1114.  
  1115.     /* set the variable value */
  1116.     cd_variable(OP_ASET,sym);
  1117.     do_continuation(cont);
  1118. }
  1119.  
  1120. /* do_call - compile a function call */
  1121. static void do_call(form,cont)
  1122.   LVAL form; int cont;
  1123. {
  1124.     int nxt,n;
  1125.     
  1126.     /* save a continuation */
  1127.     if (cont != C_RETURN) {
  1128.     putcbyte(OP_SAVE);
  1129.     nxt = putcword(0);
  1130.     }
  1131.     
  1132.     /* compile each argument expression */
  1133.     n = push_args(cdr(form));
  1134.  
  1135.     /* compile the function itself */
  1136.     do_expr(car(form),C_NEXT);
  1137.  
  1138.     /* apply the function */
  1139.     putcbyte(OP_CALL);
  1140.     putcbyte(n);
  1141.  
  1142.     /* target for the continuation */
  1143.     if (cont != C_RETURN)
  1144.     fixup(nxt);
  1145. }
  1146.  
  1147. /* push_args - compile the arguments for a function call */
  1148. static int push_args(form)
  1149.   LVAL form;
  1150. {
  1151.     int n;
  1152.     if (consp(form)) {
  1153.     n = push_args(cdr(form));
  1154.     do_expr(car(form),C_NEXT);
  1155.     putcbyte(OP_PUSH);
  1156.     return (n+1);
  1157.     }
  1158.     return (0);
  1159. }
  1160.  
  1161. /* do_nary - compile nary operator expressions */
  1162. static void do_nary(op,n,form,cont)
  1163.   int op,n; LVAL form; int cont;
  1164. {
  1165.     if (n < 0 && (n = (-n)) != length(cdr(form)))
  1166.     do_call(form,cont);
  1167.     else {
  1168.     push_nargs(cdr(form),n);
  1169.     putcbyte(op);
  1170.     do_continuation(cont);
  1171.     }
  1172. }
  1173.  
  1174. /* push_nargs - compile the arguments for an inline function call */
  1175. static int push_nargs(form,n)
  1176.   LVAL form; int n;
  1177. {
  1178.     if (consp(form)) {
  1179.     if (n == 0)
  1180.         xlerror("too many arguments",form);
  1181.     if (push_nargs(cdr(form),n-1))
  1182.         putcbyte(OP_PUSH);
  1183.     do_expr(car(form),C_NEXT);
  1184.     return (TRUE);
  1185.     }
  1186.     if (n)
  1187.     xlerror("too few arguments",form);
  1188.     return (FALSE);
  1189. }
  1190.  
  1191. /* do_literal - compile a literal */
  1192. static void do_literal(lit,cont)
  1193.   LVAL lit; int cont;
  1194. {
  1195.     cd_literal(lit);
  1196.     do_continuation(cont);
  1197. }
  1198.  
  1199. /* do_identifier - compile an identifier */
  1200. static void do_identifier(sym,cont)
  1201.   LVAL sym; int cont;
  1202. {
  1203.     int lev,off;
  1204.     if (sym == true)
  1205.     putcbyte(OP_T);
  1206.     else if (findvariable(sym,&lev,&off))
  1207.     cd_evariable(OP_EREF,lev,off);
  1208.     else
  1209.     cd_variable(OP_GREF,sym);
  1210.     do_continuation(cont);
  1211. }
  1212.  
  1213. /* do_continuation - compile a continuation */
  1214. static void do_continuation(cont)
  1215.   int cont;
  1216. {
  1217.     switch (cont) {
  1218.     case C_RETURN:
  1219.     putcbyte(OP_RETURN);
  1220.     break;
  1221.     case C_NEXT:
  1222.     break;
  1223.     }
  1224. }
  1225.  
  1226. /* add_level - add a nesting level */
  1227. static int add_level()
  1228. {
  1229.     int oldcbase;
  1230.     
  1231.     /* establish a new environment frame */
  1232.     rplaca(info,newframe(car(info),1));
  1233.     rplacd(info,cons(NIL,cdr(info)));
  1234.  
  1235.     /* setup the base of the code for this function */
  1236.     oldcbase = cbase;
  1237.     cbase = cptr;
  1238.  
  1239.     /* return the old code base */
  1240.     return (oldcbase);
  1241. }
  1242.  
  1243. /* remove_level - remove a nesting level */
  1244. static void remove_level(oldcbase)
  1245.   int oldcbase;
  1246. {
  1247.     /* restore the previous environment */
  1248.     rplaca(info,cdr(car(info)));
  1249.     rplacd(info,cdr(cdr(info)));
  1250.  
  1251.     /* restore the base and code pointer */
  1252.     cptr = cbase;
  1253.     cbase = oldcbase;
  1254. }
  1255.  
  1256. /* findvariable - find an environment variable */
  1257. static int findvariable(sym,plev,poff)
  1258.   LVAL sym; int *plev,*poff;
  1259. {
  1260.     int lev,off;
  1261.     LVAL e,a;
  1262.     for (e = car(info), lev = 0; envp(e); e = cdr(e), ++lev)
  1263.     for (a = getelement(car(e),0), off = 1; consp(a); a = cdr(a), ++off)
  1264.         if (sym == car(a)) {
  1265.         *plev = lev;
  1266.         *poff = off;
  1267.         return (TRUE);
  1268.         }
  1269.     return (FALSE);
  1270. }
  1271.  
  1272. /* findcvariable - find an environment variable in the current frame */
  1273. static int findcvariable(sym,poff)
  1274.   LVAL sym; int *poff;
  1275. {
  1276.     int off;
  1277.     LVAL a;
  1278.     a = getelement(car(car(info)),0);
  1279.     for (off = 1; consp(a); a = cdr(a), ++off)
  1280.     if (sym == car(a)) {
  1281.         *poff = off;
  1282.         return (TRUE);
  1283.     }
  1284.     return (FALSE);
  1285. }
  1286.  
  1287. /* findliteral - find a literal in the literal frame */
  1288. static int findliteral(lit)
  1289.   LVAL lit;
  1290. {
  1291.     int o = FIRSTLIT;
  1292.     LVAL t,p;
  1293.     if ((t = car(cdr(info))) != NIL) {
  1294.     for (p = NIL; consp(t); p = t, t = cdr(t), ++o)
  1295.         if (equal(lit,car(t)))
  1296.         return (o);
  1297.     rplacd(p,cons(lit,NIL));
  1298.     }
  1299.     else
  1300.     rplaca(cdr(info),cons(lit,NIL));
  1301.     return (o);
  1302. }
  1303.  
  1304. /* cd_variable - compile a variable reference */
  1305. static void cd_variable(op,sym)
  1306.   int op; LVAL sym;
  1307. {
  1308.     putcbyte(op);
  1309.     putcbyte(findliteral(sym));
  1310. }
  1311.  
  1312. /* cd_evariable - compile an environment variable reference */
  1313. static void cd_evariable(op,lev,off)
  1314.   int op,lev,off;      
  1315. {
  1316.     putcbyte(op);
  1317.     putcbyte(lev);
  1318.     putcbyte(off);
  1319. }
  1320.  
  1321. /* cd_literal - compile a literal reference */
  1322. static void cd_literal(lit)
  1323.   LVAL lit;
  1324. {
  1325.     if (lit == NIL)
  1326.     putcbyte(OP_NIL);
  1327.     else if (lit == true)
  1328.     putcbyte(OP_T);
  1329.     else {
  1330.     putcbyte(OP_LIT);
  1331.     putcbyte(findliteral(lit));
  1332.     }
  1333. }
  1334.  
  1335. /* putcbyte - put a code byte into data space */
  1336. static int putcbyte(b)
  1337.   int b;
  1338. {
  1339.     int adr;
  1340.     if (cptr >= CMAX)
  1341.     xlabort("insufficient code space");
  1342.     adr = (cptr - cbase);
  1343.     cbuff[cptr++] = b;
  1344.     return (adr);
  1345. }
  1346.  
  1347. /* putcword - put a code word into data space */
  1348. static int putcword(w)
  1349.   int w;
  1350. {
  1351.     int adr;
  1352.     adr = putcbyte(w >> 8);
  1353.     putcbyte(w);
  1354.     return (adr);
  1355. }
  1356.  
  1357. /* fixup - fixup a reference chain */
  1358. static void fixup(chn)
  1359.   int chn;
  1360. {
  1361.     int val,hval,nxt;
  1362.  
  1363.     /* store the value into each location in the chain */
  1364.     val = cptr - cbase; hval = val >> 8;
  1365.     while (chn) {
  1366.     nxt = (cbuff[cbase+chn] << 8) | (cbuff[cbase+chn+1]);
  1367.     cbuff[cbase+chn] = hval;
  1368.     cbuff[cbase+chn+1] = val;
  1369.     chn = nxt;
  1370.     }
  1371. }
  1372.  
  1373. /* length - find the length of a list */
  1374. int length(list)
  1375.   LVAL list;
  1376. {
  1377.     int len;
  1378.     for (len = 0; consp(list); list = cdr(list))
  1379.     ++len;
  1380.     return (len);
  1381. }
  1382.  
  1383. /* instruction output formats */
  1384. #define FMT_NONE    0
  1385. #define FMT_BYTE    1
  1386. #define FMT_LOFF    2
  1387. #define FMT_WORD    3
  1388. #define FMT_EOFF    4
  1389.  
  1390. typedef struct { int ot_code; char *ot_name; int ot_fmt; } OTDEF;
  1391. OTDEF otab[] = {
  1392. {    OP_BRT,        "BRT",        FMT_WORD    },
  1393. {    OP_BRF,        "BRF",        FMT_WORD    },
  1394. {    OP_BR,        "BR",        FMT_WORD    },
  1395. {    OP_LIT,        "LIT",        FMT_LOFF    },
  1396. {    OP_GREF,    "GREF",        FMT_LOFF    },
  1397. {    OP_GSET,    "GSET",        FMT_LOFF    },
  1398. {    OP_EREF,    "EREF",        FMT_EOFF    },
  1399. {    OP_ESET,    "ESET",        FMT_EOFF    },
  1400. {    OP_SAVE,    "SAVE",        FMT_WORD    },
  1401. {    OP_CALL,    "CALL",        FMT_BYTE    },
  1402. {    OP_RETURN,    "RETURN",    FMT_NONE    },
  1403. {    OP_T,        "T",        FMT_NONE    },
  1404. {    OP_NIL,        "NIL",        FMT_NONE    },
  1405. {    OP_PUSH,    "PUSH",        FMT_NONE    },
  1406. {    OP_CLOSE,    "CLOSE",    FMT_NONE    },
  1407. {    OP_DELAY,    "DELAY",    FMT_NONE    },
  1408.  
  1409. {    OP_FRAME,    "FRAME",    FMT_BYTE    },
  1410. {    OP_MVARG,    "MVARG",    FMT_BYTE    },
  1411. {    OP_MVOARG,    "MVOARG",    FMT_BYTE    },
  1412. {    OP_MVRARG,    "MVRARG",    FMT_BYTE    },
  1413. {    OP_ADROP,    "ADROP",    FMT_NONE    },
  1414. {    OP_ALAST,    "ALAST",    FMT_NONE    },
  1415.  
  1416. {    OP_AREF,    "AREF",        FMT_LOFF    },
  1417. {    OP_ASET,    "ASET",        FMT_LOFF    },
  1418.  
  1419. {0,0,0}
  1420. };
  1421.  
  1422. /* decode_procedure - decode the instructions in a code object */
  1423. void decode_procedure(fptr,fun)
  1424.   LVAL fptr,fun;
  1425. {
  1426.     int len,lc;
  1427.     LVAL code,env;
  1428.     code = getcode(fun);
  1429.     env = getenv(fun);
  1430.     len = getslength(getbcode(code));
  1431.     for (lc = 0; lc < len; )
  1432.     lc += decode_instruction(fptr,code,lc,env);
  1433. }
  1434.  
  1435. /* decode_instruction - decode a single bytecode instruction */
  1436. int decode_instruction(fptr,code,lc,env)
  1437.   LVAL fptr,code; int lc; LVAL env;
  1438. {
  1439.     unsigned char *cp;
  1440.     char buf[100];
  1441.     OTDEF *op;
  1442.     NTDEF *np;
  1443.     int i,n=1;
  1444.     LVAL tmp;
  1445.  
  1446.     /* get a pointer to the bytecodes for this instruction */
  1447.     cp = (unsigned char *)getstring(getbcode(code)) + lc;
  1448.  
  1449.     /* show the address and opcode */
  1450.     if ((tmp = getcname(code)) != NIL)
  1451.     sprintf(buf,"%s:%04x %02x ",getstring(getpname(tmp)),lc,*cp);
  1452.     else {
  1453.     sprintf(buf,AFMT,code); xlputstr(fptr,buf);
  1454.         sprintf(buf,":%04x %02x ",lc,*cp);
  1455.     }
  1456.     xlputstr(fptr,buf);
  1457.  
  1458.     /* display the operands */
  1459.     for (op = otab; op->ot_name; ++op)
  1460.     if (*cp == op->ot_code) {
  1461.         switch (op->ot_fmt) {
  1462.         case FMT_NONE:
  1463.         sprintf(buf,"      %s\n",op->ot_name);
  1464.         xlputstr(fptr,buf);
  1465.         break;
  1466.         case FMT_BYTE:
  1467.         sprintf(buf,"%02x    %s %02x\n",cp[1],op->ot_name,cp[1]);
  1468.         xlputstr(fptr,buf);
  1469.         n += 1;
  1470.         break;
  1471.         case FMT_LOFF:
  1472.         sprintf(buf,"%02x    %s %02x ; ",cp[1],op->ot_name,cp[1]);
  1473.         xlputstr(fptr,buf);
  1474.         xlprin1(getelement(code,cp[1]),fptr);
  1475.         xlterpri(fptr);
  1476.         n += 1;
  1477.         break;
  1478.         case FMT_WORD:
  1479.         sprintf(buf,"%02x %02x %s %02x%02x\n",cp[1],cp[2],
  1480.             op->ot_name,cp[1],cp[2]);
  1481.         xlputstr(fptr,buf);
  1482.         n += 2;
  1483.         break;
  1484.         case FMT_EOFF:
  1485.         if ((i = cp[1]) == 0)
  1486.             tmp = getvnames(code);
  1487.         else {
  1488.             for (tmp = env; i > 1; --i) tmp = cdr(tmp);
  1489.             tmp = getelement(car(tmp),0);
  1490.         }
  1491.         for (i = cp[2]; i > 1; --i) tmp = cdr(tmp);
  1492.         sprintf(buf,"%02x %02x %s %02x %02x ; ",cp[1],cp[2],
  1493.             op->ot_name,cp[1],cp[2]);
  1494.         xlputstr(fptr,buf);
  1495.         xlprin1(car(tmp),fptr);
  1496.         xlterpri(fptr);
  1497.         n += 2;
  1498.         break;
  1499.         }
  1500.         return (n);
  1501.     }
  1502.     
  1503.     /* check for an integrable function */
  1504.     for (np = ntab; np->nt_name; ++np)
  1505.     if (*cp == np->nt_code) {
  1506.         sprintf(buf,"      %s\n",np->nt_name);
  1507.         xlputstr(fptr,buf);
  1508.         return (n);
  1509.     }
  1510.  
  1511.     /* unknown opcode */
  1512.     sprintf(buf,"      <UNKNOWN>\n");
  1513.     xlputstr(fptr,buf);
  1514.     return (n);
  1515. }
  1516.