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