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