Category : Miscellaneous Language Source Code
Archive   : XSCHME02.ZIP
Filename : XSCOM.C

/* xscom.c - a simple scheme bytecode compiler */
/* Copyright (c) 1988, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */

#include "xscheme.h"
#include "xsbcode.h"

/* size of code buffer */
#define CMAX 4000

/* continuation types */
#define C_RETURN -1
#define C_NEXT -2

/* macro to check for a lambda list keyword */
#define lambdakey(x) ((x) == lk_optional || (x) == lk_rest)

/* external variables */
extern LVAL lk_optional,lk_rest,true;

/* local variables */
static LVAL info; /* compiler info */

/* code buffer */
static unsigned char cbuff[CMAX]; /* base of code buffer */
static int cbase; /* base for current function */
static int cptr; /* code buffer pointer */

/* forward declarations */
int do_define(),do_set(),do_quote(),do_lambda(),do_delay();
int do_let(),do_letrec(),do_letstar(),do_cond(),do_and(),do_or();
int do_if(),do_begin(),do_while(),do_access();
LVAL make_code_object();

/* integrable function table */
typedef struct { char *nt_name; int nt_code,nt_args; } NTDEF;
static NTDEF *nptr,ntab[] = {
"ATOM", OP_ATOM, 1,
"EQ?", OP_EQ, 2,
"NULL?", OP_NULL, 1,
"NOT", OP_NULL, 1,
"CONS", OP_CONS, 2,
"CAR", OP_CAR, 1,
"CDR", OP_CDR, 1,
"SET-CAR!", OP_SETCAR, 2,
"SET-CDR!", OP_SETCDR, 2,
"+", OP_ADD, -2,
"-", OP_SUB, -2,
"*", OP_MUL, -2,
"QUOTIENT", OP_QUO, -2,
"<", OP_LSS, -2,
"=", OP_EQL, -2,
">", OP_GTR, -2,
0
};

/* special form table */
typedef struct { char *ft_name; int (*ft_fcn)(); } FTDEF;
static FTDEF ftab[] = {
"QUOTE", do_quote,
"LAMBDA", do_lambda,
"DELAY", do_delay,
"LET", do_let,
"LET*", do_letstar,
"LETREC", do_letrec,
"DEFINE", do_define,
"SET!", do_set,
"IF", do_if,
"COND", do_cond,
"BEGIN", do_begin,
"SEQUENCE", do_begin,
"AND", do_and,
"OR", do_or,
"WHILE", do_while,
"ACCESS", do_access,
0
};

/* xlcompile - compile an expression */
LVAL xlcompile(expr,ctenv)
LVAL expr,ctenv;
{
/* initialize the compile time environment */
info = cons(NIL,NIL); cpush(info);
rplaca(info,newframe(ctenv,1));
rplacd(info,cons(NIL,NIL));

/* setup the base of the code for this function */
cbase = cptr = 0;

/* setup the entry code */
putcbyte(OP_FRAME);
putcbyte(1);

/* compile the expression */
do_expr(expr,C_RETURN);

/* build the code object */
settop(make_code_object(NIL));
return (pop());
}

/* xlfunction - compile a function */
LVAL xlfunction(fun,fargs,body,ctenv)
LVAL fun,fargs,body,ctenv;
{
/* initialize the compile time environment */
info = cons(NIL,NIL); cpush(info);
rplaca(info,newframe(ctenv,1));
rplacd(info,cons(NIL,NIL));

/* setup the base of the code for this function */
cbase = cptr = 0;

/* compile the lambda list and the function body */
parse_lambda_list(fargs,body);
do_begin(body,C_RETURN);

/* build the code object */
settop(make_code_object(fun));
return (pop());
}

/* do_expr - compile an expression */
LOCAL do_expr(expr,cont)
LVAL expr; int cont;
{
LVAL fun;
if (consp(expr)) {
fun = car(expr);
if (!symbolp(fun) || (!in_ntab(expr,cont) && !in_ftab(expr,cont)))
do_call(expr,cont);
}
else if (symbolp(expr))
do_identifier(expr,cont);
else
do_literal(expr,cont);
}

/* in_ntab - check for a function in ntab */
LOCAL int in_ntab(expr,cont)
LVAL expr; int cont;
{
unsigned char *pname;
pname = getstring(getpname(car(expr)));
for (nptr = ntab; nptr->nt_name; ++nptr)
if (strcmp(pname,nptr->nt_name) == 0) {
do_nary(nptr->nt_code,nptr->nt_args,expr,cont);
return (TRUE);
}
return (FALSE);
}

/* in_ftab - check for a function in ftab */
LOCAL int in_ftab(expr,cont)
LVAL expr; int cont;
{
unsigned char *pname;
FTDEF *fptr;
pname = getstring(getpname(car(expr)));
for (fptr = ftab; fptr->ft_name; ++fptr)
if (strcmp(pname,fptr->ft_name) == 0) {
(*fptr->ft_fcn)(cdr(expr),cont);
return (TRUE);
}
return (FALSE);
}

/* do_define - handle the (DEFINE ... ) expression */
LOCAL do_define(form,cont)
LVAL form; int cont;
{
if (atom(form))
xlerror("expecting symbol or function template",form);
define1(car(form),cdr(form),cont);
}

/* define1 - helper routine for do_define */
LOCAL define1(list,body,cont)
LVAL list,body; int cont;
{
LVAL fargs;
int off;

/* handle nested definitions */
if (consp(list)) {
cpush(cons(xlenter("LAMBDA"),NIL)); /* (LAMBDA) */
rplacd(top(),cons(cdr(list),NIL)); /* (LAMBDA args) */
rplacd(cdr(top()),body); /* (LAMBDA args body) */
settop(cons(top(),NIL)); /* ((LAMBDA args body)) */
define1(car(list),top(),cont);
drop(1);
}

/* compile procedure definitions */
else {

/* make sure it's a symbol */
if (!symbolp(list))
xlerror("expecting a symbol",list);

/* check for a procedure definition */
if (consp(body)
&& consp(car(body))
&& car(car(body)) == xlenter("LAMBDA")) {
fargs = car(cdr(car(body)));
body = cdr(cdr(car(body)));
cd_fundefinition(list,fargs,body);
}

/* compile the value expression or procedure body */
else
do_begin(body,C_NEXT);

/* define the variable value */
if (findcvariable(list,&off))
cd_evariable(OP_ESET,0,off);
else
cd_variable(OP_GSET,list);
do_literal(list,cont);
}
}

/* do_set - compile the (SET! ... ) expression */
LOCAL do_set(form,cont)
LVAL form; int cont;
{
if (atom(form))
xlerror("expecting symbol or ACCESS form",form);
else if (symbolp(car(form)))
do_setvar(form,cont);
else if (consp(car(form)))
do_setaccess(form,cont);
else
xlerror("expecting symbol or ACCESS form",form);
}

/* do_setvar - compile the (SET! var value) expression */
LOCAL do_setvar(form,cont)
LVAL form; int cont;
{
int lev,off;
LVAL sym;

/* get the variable name */
sym = car(form);

/* compile the value expression */
form = cdr(form);
if (atom(form))
xlerror("expecting value expression",form);
do_expr(car(form),C_NEXT);

/* set the variable value */
if (findvariable(sym,&lev,&off))
cd_evariable(OP_ESET,lev,off);
else
cd_variable(OP_GSET,sym);
do_continuation(cont);
}

/* do_quote - compile the (QUOTE ... ) expression */
LOCAL do_quote(form,cont)
LVAL form; int cont;
{
if (atom(form))
xlerror("expecting quoted expression",form);
do_literal(car(form),cont);
}

/* do_lambda - compile the (LAMBDA ... ) expression */
LOCAL do_lambda(form,cont)
LVAL form; int cont;
{
if (atom(form))
xlerror("expecting argument list",form);
cd_fundefinition(NIL,car(form),cdr(form));
do_continuation(cont);
}

/* cd_fundefinition - compile the function */
LOCAL cd_fundefinition(fun,fargs,body)
LVAL fun,fargs,body;
{
int oldcbase;

/* establish a new environment frame */
oldcbase = add_level();

/* compile the lambda list and the function body */
parse_lambda_list(fargs,body);
do_begin(body,C_RETURN);

/* build the code object */
cpush(make_code_object(fun));

/* restore the previous environment */
remove_level(oldcbase);

/* compile code to create a closure */
do_literal(pop(),C_NEXT);
putcbyte(OP_CLOSE);
}

/* parse_lambda_list - parse the formal argument list */
LOCAL parse_lambda_list(fargs,body)
LVAL fargs,body;
{
LVAL arg,restarg,new,last;
int frame,slotn;

/* setup the entry code */
putcbyte(OP_FRAME);
frame = putcbyte(0);

/* initialize the argument name list and slot number */
restarg = last = NIL;
slotn = 1;

/* handle each required argument */
while (consp(fargs) && (arg = car(fargs)) && !lambdakey(arg)) {

/* make sure the argument is a symbol */
if (!symbolp(arg))
xlerror("variable must be a symbol",arg);

/* add the argument name to the name list */
new = cons(arg,NIL);
if (last) rplacd(last,new);
else setelement(car(car(info)),0,new);
last = new;

/* generate an instruction to move the argument into the frame */
putcbyte(OP_MVARG);
putcbyte(slotn++);

/* move the formal argument list pointer ahead */
fargs = cdr(fargs);
}

/* check for the '#!optional' argument */
if (consp(fargs) && car(fargs) == lk_optional) {
fargs = cdr(fargs);

/* handle each optional argument */
while (consp(fargs) && (arg = car(fargs)) && !lambdakey(arg)) {

/* make sure the argument is a symbol */
if (!symbolp(arg))
xlerror("#!optional variable must be a symbol",arg);

/* add the argument name to the name list */
new = cons(arg,NIL);
if (last) rplacd(last,new);
else setelement(car(car(info)),0,new);
last = new;

/* move the argument into the frame */
putcbyte(OP_MVOARG);
putcbyte(slotn++);

/* move the formal argument list pointer ahead */
fargs = cdr(fargs);
}
}

/* check for the '#!rest' argument */
if (consp(fargs) && car(fargs) == lk_rest) {
fargs = cdr(fargs);

/* handle the rest argument */
if (consp(fargs) && (restarg = car(fargs)) && !lambdakey(restarg)) {

/* make sure the argument is a symbol */
if (!symbolp(restarg))
xlerror("#!rest variable must be a symbol",restarg);

/* add the argument name to the name list */
new = cons(restarg,NIL);
if (last) rplacd(last,new);
else setelement(car(car(info)),0,new);
last = new;

/* make the #!rest argument list */
putcbyte(OP_MVRARG);
putcbyte(slotn++);

/* move the formal argument list pointer ahead */
fargs = cdr(fargs);
}
else
xlerror("expecting the #!rest variable");
}

/* check for the a dotted tail */
if (restarg == NIL && symbolp(fargs)) {
restarg = fargs;

/* add the argument name to the name list */
new = cons(restarg,NIL);
if (last) rplacd(last,new);
else setelement(car(car(info)),0,new);
last = new;

/* make the #!rest argument list */
putcbyte(OP_MVRARG);
putcbyte(slotn++);
fargs = NIL;
}

/* check for the end of the argument list */
if (fargs != NIL)
xlerror("bad argument list tail",fargs);

/* make sure the user didn't supply too many arguments */
if (restarg == NIL)
putcbyte(OP_ALAST);

/* scan the body for internal definitions */
slotn += find_internal_definitions(body,last);

/* fixup the frame instruction */
cbuff[cbase+frame] = slotn;
}

/* find_internal_definitions - find internal definitions */
LOCAL int find_internal_definitions(body,last)
LVAL body,last;
{
LVAL define,sym,new;
int n=0;

/* look for all (define...) forms */
for (define = xlenter("DEFINE"); consp(body); body = cdr(body))
if (consp(car(body)) && car(car(body)) == define) {
sym = cdr(car(body)); /* the rest of the (define...) form */
if (consp(sym)) { /* make sure there is a second subform */
sym = car(sym); /* get the second subform */
while (consp(sym))/* check for a procedure definition */
sym = car(sym);
if (symbolp(sym)) {
new = cons(sym,NIL);
if (last) rplacd(last,new);
else setelement(car(car(info)),0,new);
last = new;
++n;
}
}
}
return (n);
}

/* do_delay - compile the (DELAY ... ) expression */
LOCAL do_delay(form,cont)
LVAL form; int cont;
{
int oldcbase;

/* check argument list */
if (atom(form))
xlerror("expecting delay expression",form);

/* establish a new environment frame */
oldcbase = add_level();

/* setup the entry code */
putcbyte(OP_FRAME);
putcbyte(1);

/* compile the expression */
do_expr(car(form),C_RETURN);

/* build the code object */
cpush(make_code_object(NIL));

/* restore the previous environment */
remove_level(oldcbase);

/* compile code to create a closure */
do_literal(pop(),C_NEXT);
putcbyte(OP_DELAY);
do_continuation(cont);
}

/* do_let - compile the (LET ... ) expression */
LOCAL do_let(form,cont)
LVAL form; int cont;
{
/* handle named let */
if (consp(form) && symbolp(car(form)))
do_named_let(form,cont);

/* handle unnamed let */
else
cd_let(NIL,form,cont);
}

/* do_named_let - compile the (LET name ... ) expression */
LOCAL do_named_let(form,cont)
LVAL form; int cont;
{
int oldcbase,nxt;

/* save a continuation */
if (cont != C_RETURN) {
putcbyte(OP_SAVE);
nxt = putcword(0);
}

/* establish a new environment frame */
oldcbase = add_level();
setelement(car(car(info)),0,cons(car(form),NIL));

/* setup the entry code */
putcbyte(OP_FRAME);
putcbyte(2);

/* compile the let expression */
cd_let(car(form),cdr(form),C_RETURN);

/* build the code object */
cpush(make_code_object(NIL));

/* restore the previous environment */
remove_level(oldcbase);

/* compile code to create a closure */
do_literal(pop(),C_NEXT);
putcbyte(OP_CLOSE);

/* apply the function */
putcbyte(OP_CALL);
putcbyte(1);

/* target for the continuation */
if (cont != C_RETURN)
fixup(nxt);
}

/* cd_let - code a let expression */
LOCAL cd_let(name,form,cont)
LVAL name,form; int cont;
{
int oldcbase,nxt,lev,off,n;

/* make sure there is a binding list */
if (atom(form) || !listp(car(form)))
xlerror("expecting binding list",form);

/* save a continuation */
if (cont != C_RETURN) {
putcbyte(OP_SAVE);
nxt = putcword(0);
}

/* push the initialization expressions */
n = push_init_expressions(car(form));

/* establish a new environment frame */
oldcbase = add_level();

/* compile the binding list */
parse_let_variables(car(form),cdr(form));

/* compile the body of the let/letrec */
do_begin(cdr(form),C_RETURN);

/* build the code object */
cpush(make_code_object(NIL));

/* restore the previous environment */
remove_level(oldcbase);

/* compile code to create a closure */
do_literal(pop(),C_NEXT);
putcbyte(OP_CLOSE);

/* store the procedure */
if (name && findvariable(name,&lev,&off))
cd_evariable(OP_ESET,lev,off);

/* apply the function */
putcbyte(OP_CALL);
putcbyte(n);

/* target for the continuation */
if (cont != C_RETURN)
fixup(nxt);
}

/* do_letrec - compile the (LETREC ... ) expression */
LOCAL do_letrec(form,cont)
LVAL form; int cont;
{
int oldcbase,nxt,n;

/* make sure there is a binding list */
if (atom(form) || !listp(car(form)))
xlerror("expecting binding list",form);

/* save a continuation */
if (cont != C_RETURN) {
putcbyte(OP_SAVE);
nxt = putcword(0);
}

/* push the initialization expressions */
n = push_dummy_values(car(form));

/* establish a new environment frame */
oldcbase = add_level();

/* compile the binding list */
parse_let_variables(car(form),cdr(form));

/* compile instructions to set the bound variables */
set_bound_variables(car(form));

/* compile the body of the let/letrec */
do_begin(cdr(form),C_RETURN);

/* build the code object */
cpush(make_code_object(NIL));

/* restore the previous environment */
remove_level(oldcbase);

/* compile code to create a closure */
do_literal(pop(),C_NEXT);
putcbyte(OP_CLOSE);

/* apply the function */
putcbyte(OP_CALL);
putcbyte(n);

/* target for the continuation */
if (cont != C_RETURN)
fixup(nxt);
}

/* do_letstar - compile the (LET* ... ) expression */
LOCAL do_letstar(form,cont)
LVAL form; int cont;
{
int nxt;

/* make sure there is a binding list */
if (atom(form) || !listp(car(form)))
xlerror("expecting binding list",form);

/* handle the case where there are bindings */
if (consp(car(form))) {

/* save a continuation */
if (cont != C_RETURN) {
putcbyte(OP_SAVE);
nxt = putcword(0);
}

/* build the nested lambda expressions */
letstar1(car(form),cdr(form));

/* target for the continuation */
if (cont != C_RETURN)
fixup(nxt);
}

/* handle the case where there are no bindings */
else
do_begin(cdr(form),cont);
}

/* letstar1 - helper routine for let* */
LOCAL letstar1(blist,body)
LVAL blist,body;
{
int oldcbase,n;

/* push the next initialization expressions */
cpush(cons(car(blist),NIL));
n = push_init_expressions(top());

/* establish a new environment frame */
oldcbase = add_level();

/* handle the case where there are more bindings */
if (consp(cdr(blist))) {
parse_let_variables(top(),NIL);
letstar1(cdr(blist),body);
}

/* handle the last binding */
else {
parse_let_variables(top(),body);
do_begin(body,C_RETURN);

}

/* build the code object */
settop(make_code_object(NIL));

/* restore the previous environment */
remove_level(oldcbase);

/* compile code to create a closure */
do_literal(pop(),C_NEXT);
putcbyte(OP_CLOSE);

/* apply the function */
putcbyte(OP_CALL);
putcbyte(n);
}

/* push_dummy_values - push dummy values for a 'letrec' expression */
LOCAL int push_dummy_values(blist)
LVAL blist;
{
int n=0;
if (consp(blist)) {
putcbyte(OP_NIL);
for (; consp(blist); blist = cdr(blist), ++n)
putcbyte(OP_PUSH);
}
return (n);
}

/* push_init_expressions - push init expressions for a 'let' expression */
LOCAL int push_init_expressions(blist)
LVAL blist;
{
int n;
if (consp(blist)) {
n = push_init_expressions(cdr(blist));
if (consp(car(blist)) && consp(cdr(car(blist))))
do_expr(car(cdr(car(blist))),C_NEXT);
else
putcbyte(OP_NIL);
putcbyte(OP_PUSH);
return (n+1);
}
return (0);

}

/* parse_let_variables - parse the binding list */
LOCAL parse_let_variables(blist,body)
LVAL blist,body;
{
LVAL arg,new,last;
int frame,slotn;

/* setup the entry code */
putcbyte(OP_FRAME);
frame = putcbyte(0);

/* initialize the argument name list and slot number */
last = NIL;
slotn = 1;

/* handle each required argument */
while (consp(blist) && (arg = car(blist))) {

/* make sure the argument is a symbol */
if (symbolp(arg))
new = cons(arg,NIL);
else if (consp(arg) && symbolp(car(arg)))
new = cons(car(arg),NIL);
else
xlerror("invalid binding",arg);

/* add the argument name to the name list */
if (last) rplacd(last,new);
else setelement(car(car(info)),0,new);
last = new;

/* generate an instruction to move the argument into the frame */
putcbyte(OP_MVARG);
putcbyte(slotn++);

/* move the formal argument list pointer ahead */
blist = cdr(blist);
}
putcbyte(OP_ALAST);

/* scan the body for internal definitions */
slotn += find_internal_definitions(body,last);

/* fixup the frame instruction */
cbuff[cbase+frame] = slotn;
}

/* set_bound_variables - set bound variables in a 'letrec' expression */
LOCAL set_bound_variables(blist)
LVAL blist;
{
int lev,off;
for (; consp(blist); blist = cdr(blist)) {
if (consp(car(blist)) && consp(cdr(car(blist)))) {
do_expr(car(cdr(car(blist))),C_NEXT);
if (findvariable(car(car(blist)),&lev,&off))
cd_evariable(OP_ESET,lev,off);
else
xlerror("compiler error -- can't find",car(car(blist)));
}
}
}

/* make_code_object - build a code object */
LOCAL LVAL make_code_object(fun)
LVAL fun;
{
unsigned char *cp;
LVAL code,p;
int i;

/* create a code object */
code = newcode(FIRSTLIT + length(car(cdr(info)))); cpush(code);
setbcode(code,newstring(cptr - cbase));
setcname(code,fun); /* function name */
setvnames(code,getelement(car(car(info)),0));/* lambda list variables */

/* copy the literals into the code object */
for (i = FIRSTLIT, p = car(cdr(info)); consp(p); p = cdr(p), ++i)
setelement(code,i,car(p));

/* copy the byte codes */
for (i = cbase, cp = getstring(getbcode(code)); i < cptr; )
*cp++ = cbuff[i++];

/* return the new code object */
return (pop());
}

/* do_cond - compile the (COND ... ) expression */
LOCAL do_cond(form,cont)
LVAL form; int cont;
{
int nxt,end;
if (consp(form)) {
for (end = 0; consp(form); form = cdr(form)) {
if (atom(car(form)))
xlerror("expecting a cond clause",form);
do_expr(car(car(form)),C_NEXT);
putcbyte(OP_BRF);
nxt = putcword(0);
if (cdr(car(form)))
do_begin(cdr(car(form)),cont);
else
do_continuation(cont);
if (cont == C_NEXT) {
putcbyte(OP_BR);
end = putcword(end);
}
fixup(nxt);
}
fixup(end);
}
else
putcbyte(OP_NIL);
do_continuation(cont);
}

/* do_and - compile the (AND ... ) expression */
LOCAL do_and(form,cont)
LVAL form; int cont;
{
int end;
if (consp(form)) {
for (end = 0; consp(form); form = cdr(form)) {
if (cdr(form)) {
do_expr(car(form),C_NEXT);
putcbyte(OP_BRF);
end = putcword(end);
}
else
do_expr(car(form),cont);
}
fixup(end);
}
else
putcbyte(OP_T);
do_continuation(cont);
}

/* do_or - compile the (OR ... ) expression */
LOCAL do_or(form,cont)
LVAL form; int cont;
{
int end;
if (consp(form)) {
for (end = 0; consp(form); form = cdr(form)) {
if (cdr(form)) {
do_expr(car(form),C_NEXT);
putcbyte(OP_BRT);
end = putcword(end);
}
else
do_expr(car(form),cont);
}
fixup(end);
}
else
putcbyte(OP_NIL);
do_continuation(cont);
}

/* do_if - compile the (IF ... ) expression */
LOCAL do_if(form,cont)
LVAL form; int cont;
{
int nxt,end;

/* compile the test expression */
if (atom(form))
xlerror("expecting test expression",form);
do_expr(car(form),C_NEXT);

/* skip around the 'then' clause if the expression is false */
putcbyte(OP_BRF);
nxt = putcword(0);

/* skip to the 'then' clause */
form = cdr(form);
if (atom(form))
xlerror("expecting then clause",form);

/* compile the 'then' and 'else' clauses */
if (consp(cdr(form))) {
if (cont == C_NEXT) {
do_expr(car(form),C_NEXT);
putcbyte(OP_BR);
end = putcword(0);
}
else {
do_expr(car(form),cont);
end = -1;
}
fixup(nxt);
do_expr(car(cdr(form)),cont);
nxt = end;
}

/* compile just a 'then' clause */
else
do_expr(car(form),cont);

/* handle the end of the statement */
if (nxt >= 0) {
fixup(nxt);
do_continuation(cont);
}
}

/* do_begin - compile the (BEGIN ... ) expression */
LOCAL do_begin(form,cont)
LVAL form; int cont;
{
if (consp(form))
for (; consp(form); form = cdr(form))
if (consp(cdr(form)))
do_expr(car(form),C_NEXT);
else
do_expr(car(form),cont);
else {
putcbyte(OP_NIL);
do_continuation(cont);
}
}

/* do_while - compile the (WHILE ... ) expression */
LOCAL do_while(form,cont)
LVAL form; int cont;
{
int loop,nxt;

/* make sure there is a test expression */
if (atom(form))
xlerror("expecting test expression",form);

/* skip around the 'body' to the test expression */
putcbyte(OP_BR);
nxt = putcword(0);

/* compile the loop body */
loop = cptr - cbase;
do_begin(cdr(form),C_NEXT);

/* label for the first iteration */
fixup(nxt);

/* compile the test expression */
nxt = cptr - cbase;
do_expr(car(form),C_NEXT);

/* skip around the 'body' if the expression is false */
putcbyte(OP_BRT);
putcword(loop);

/* compile the continuation */
do_continuation(cont);
}

/* do_access - compile the (ACCESS var env) expression */
LOCAL do_access(form,cont)
LVAL form; int cont;
{
LVAL sym;

/* get the variable name */
if (atom(form) || !symbolp(car(form)))
xlerror("expecting symbol",form);
sym = car(form);

/* compile the environment expression */
form = cdr(form);
if (atom(form))
xlerror("expecting environment expression",form);
do_expr(car(form),C_NEXT);

/* get the variable value */
cd_variable(OP_AREF,sym);
do_continuation(cont);
}

/* do_setaccess - compile the (SET! (ACCESS var env) value) expression */
LOCAL do_setaccess(form,cont)
LVAL form; int cont;
{
LVAL aform,sym;

/* make sure this is an access form */
aform = car(form);
if (atom(aform) || car(aform) != xlenter("ACCESS"))
xlerror("expecting an ACCESS form",aform);

/* get the variable name */
aform = cdr(aform);
if (atom(aform) || !symbolp(car(aform)))
xlerror("expecting symbol",aform);
sym = car(aform);

/* compile the environment expression */
aform = cdr(aform);
if (atom(aform))
xlerror("expecting environment expression",aform);
do_expr(car(aform),C_NEXT);
putcbyte(OP_PUSH);

/* compile the value expression */
form = cdr(form);
if (atom(form))
xlerror("expecting value expression",form);
do_expr(car(form),C_NEXT);

/* set the variable value */
cd_variable(OP_ASET,sym);
do_continuation(cont);
}

/* do_call - compile a function call */
LOCAL do_call(form,cont)
LVAL form; int cont;
{
int nxt,n;

/* save a continuation */
if (cont != C_RETURN) {
putcbyte(OP_SAVE);
nxt = putcword(0);
}

/* compile each argument expression */
n = push_args(cdr(form));

/* compile the function itself */
do_expr(car(form),C_NEXT);

/* apply the function */
putcbyte(OP_CALL);
putcbyte(n);

/* target for the continuation */
if (cont != C_RETURN)
fixup(nxt);
}

/* push_args - compile the arguments for a function call */
LOCAL int push_args(form)
LVAL form;
{
int n;
if (consp(form)) {
n = push_args(cdr(form));
do_expr(car(form),C_NEXT);
putcbyte(OP_PUSH);
return (n+1);
}
return (0);
}

/* do_nary - compile nary operator expressions */
LOCAL do_nary(op,n,form,cont)
int op,n; LVAL form; int cont;
{
if (n < 0 && (n = (-n)) != length(cdr(form)))
do_call(form,cont);
else {
push_nargs(cdr(form),n);
putcbyte(op);
do_continuation(cont);
}
}

/* push_nargs - compile the arguments for an inline function call */
LOCAL int push_nargs(form,n)
LVAL form; int n;
{
if (consp(form)) {
if (n == 0)
xlerror("too many arguments",form);
if (push_nargs(cdr(form),n-1))
putcbyte(OP_PUSH);
do_expr(car(form),C_NEXT);
return (TRUE);
}
if (n)
xlerror("too few arguments",form);
return (FALSE);
}

/* do_literal - compile a literal */
LOCAL do_literal(lit,cont)
LVAL lit; int cont;
{
cd_literal(lit);
do_continuation(cont);
}

/* do_identifier - compile an identifier */
LOCAL do_identifier(sym,cont)
LVAL sym; int cont;
{
int lev,off;
if (sym == true)
putcbyte(OP_T);
else if (findvariable(sym,&lev,&off))
cd_evariable(OP_EREF,lev,off);
else
cd_variable(OP_GREF,sym);
do_continuation(cont);
}

/* do_continuation - compile a continuation */
LOCAL do_continuation(cont)
int cont;
{
switch (cont) {
case C_RETURN:
putcbyte(OP_RETURN);
break;
case C_NEXT:
break;
}
}

/* add_level - add a nesting level */
LOCAL int add_level()
{
int oldcbase;

/* establish a new environment frame */
rplaca(info,newframe(car(info),1));
rplacd(info,cons(NIL,cdr(info)));

/* setup the base of the code for this function */
oldcbase = cbase;
cbase = cptr;

/* return the old code base */
return (oldcbase);
}

/* remove_level - remove a nesting level */
LOCAL remove_level(oldcbase)
int oldcbase;
{
/* restore the previous environment */
rplaca(info,cdr(car(info)));
rplacd(info,cdr(cdr(info)));

/* restore the base and code pointer */
cptr = cbase;
cbase = oldcbase;
}

/* findvariable - find an environment variable */
LOCAL int findvariable(sym,plev,poff)
LVAL sym; int *plev,*poff;
{
int lev,off;
LVAL e,a;
for (e = car(info), lev = 0; envp(e); e = cdr(e), ++lev)
for (a = getelement(car(e),0), off = 1; consp(a); a = cdr(a), ++off)
if (sym == car(a)) {
*plev = lev;
*poff = off;
return (TRUE);
}
return (FALSE);
}

/* findcvariable - find an environment variable in the current frame */
LOCAL int findcvariable(sym,poff)
LVAL sym; int *poff;
{
int off;
LVAL a;
a = getelement(car(car(info)),0);
for (off = 1; consp(a); a = cdr(a), ++off)
if (sym == car(a)) {
*poff = off;
return (TRUE);
}
return (FALSE);
}

/* findliteral - find a literal in the literal frame */
LOCAL int findliteral(lit)
LVAL lit;
{
int o = FIRSTLIT;
LVAL t,p;
if (t = car(cdr(info))) {

for (p = NIL; consp(t); p = t, t = cdr(t), ++o)
if (equal(lit,car(t)))
return (o);
rplacd(p,cons(lit,NIL));
}
else
rplaca(cdr(info),cons(lit,NIL));
return (o);
}

/* cd_variable - compile a variable reference */
LOCAL cd_variable(op,sym)
int op; LVAL sym;
{
putcbyte(op);
putcbyte(findliteral(sym));
}

/* cd_evariable - compile an environment variable reference */
LOCAL cd_evariable(op,lev,off)
int op,lev,off;
{
putcbyte(op);
putcbyte(lev);
putcbyte(off);
}

/* cd_literal - compile a literal reference */
LOCAL cd_literal(lit)
LVAL lit;
{
if (lit == NIL)
putcbyte(OP_NIL);
else if (lit == true)
putcbyte(OP_T);
else {
putcbyte(OP_LIT);
putcbyte(findliteral(lit));
}
}

/* putcbyte - put a code byte into data space */
LOCAL int putcbyte(b)
int b;
{
int adr;
if (cptr >= CMAX)
xlabort("insufficient code space");
adr = (cptr - cbase);
cbuff[cptr++] = b;
return (adr);
}


/* putcword - put a code word into data space */
LOCAL int putcword(w)
int w;
{
int adr;
adr = putcbyte(w >> 8);
putcbyte(w);
return (adr);
}

/* fixup - fixup a reference chain */
LOCAL fixup(chn)
int chn;
{
int val,hval,nxt;

/* store the value into each location in the chain */
val = cptr - cbase; hval = val >> 8;
for (; chn; chn = nxt) {
nxt = (cbuff[cbase+chn] << 8) | (cbuff[cbase+chn+1]);
cbuff[cbase+chn] = hval;
cbuff[cbase+chn+1] = val;
}
}

/* length - find the length of a list */
int length(list)
LVAL list;
{
int len;
for (len = 0; consp(list); list = cdr(list))
++len;
return (len);
}

/* instruction output formats */
#define FMT_NONE 0
#define FMT_BYTE 1
#define FMT_LOFF 2
#define FMT_WORD 3
#define FMT_EOFF 4

typedef struct { int ot_code; char *ot_name; int ot_fmt; } OTDEF;
OTDEF otab[] = {
{ OP_BRT, "BRT", FMT_WORD },
{ OP_BRF, "BRF", FMT_WORD },
{ OP_BR, "BR", FMT_WORD },
{ OP_LIT, "LIT", FMT_LOFF },
{ OP_GREF, "GREF", FMT_LOFF },
{ OP_GSET, "GSET", FMT_LOFF },
{ OP_EREF, "EREF", FMT_EOFF },
{ OP_ESET, "ESET", FMT_EOFF },
{ OP_SAVE, "SAVE", FMT_WORD },
{ OP_CALL, "CALL", FMT_BYTE },
{ OP_RETURN, "RETURN", FMT_NONE },
{ OP_T, "T", FMT_NONE },
{ OP_NIL, "NIL", FMT_NONE },
{ OP_PUSH, "PUSH", FMT_NONE },
{ OP_CLOSE, "CLOSE", FMT_NONE },
{ OP_DELAY, "DELAY", FMT_NONE },

{ OP_FRAME, "FRAME", FMT_BYTE },
{ OP_MVARG, "MVARG", FMT_BYTE },
{ OP_MVOARG, "MVOARG", FMT_BYTE },
{ OP_MVRARG, "MVRARG", FMT_BYTE },
{ OP_ADROP, "ADROP", FMT_NONE },
{ OP_ALAST, "ALAST", FMT_NONE },

{ OP_AREF, "AREF", FMT_LOFF },
{ OP_ASET, "ASET", FMT_LOFF },

{0,0,0}
};

/* decode_procedure - decode the instructions in a code object */
decode_procedure(fptr,fun)
LVAL fptr,fun;
{
int len,lc,n;
LVAL code,env;
code = getcode(fun);
env = getenv(fun);
len = getslength(getbcode(code));
for (lc = 0; lc < len; lc += n)
n = decode_instruction(fptr,code,lc,env);
}

/* decode_instruction - decode a single bytecode instruction */
int decode_instruction(fptr,code,lc,env)
LVAL fptr,code; int lc; LVAL env;
{
unsigned char *cp;
char buf[100];
OTDEF *op;
NTDEF *np;
int i,n=1;
LVAL tmp;

/* get a pointer to the bytecodes for this instruction */
cp = getstring(getbcode(code)) + lc;

/* show the address and opcode */
if (tmp = getcname(code))
sprintf(buf,"%s:%04x %02x ",getstring(getpname(tmp)),lc,*cp);
else {
sprintf(buf,AFMT,code); xlputstr(fptr,buf);
sprintf(buf,":%04x %02x ",lc,*cp);
}
xlputstr(fptr,buf);

/* display the operands */
for (op = otab; op->ot_name; ++op)
if (*cp == op->ot_code) {
switch (op->ot_fmt) {
case FMT_NONE:
sprintf(buf," %s\n",op->ot_name);
xlputstr(fptr,buf);
break;
case FMT_BYTE:
sprintf(buf,"%02x %s %02x\n",cp[1],op->ot_name,cp[1]);
xlputstr(fptr,buf);
n += 1;
break;
case FMT_LOFF:
sprintf(buf,"%02x %s %02x ; ",cp[1],op->ot_name,cp[1]);
xlputstr(fptr,buf);
xlprin1(getelement(code,cp[1]),fptr);
xlterpri(fptr);
n += 1;
break;
case FMT_WORD:
sprintf(buf,"%02x %02x %s %02x%02x\n",cp[1],cp[2],
op->ot_name,cp[1],cp[2]);
xlputstr(fptr,buf);
n += 2;
break;
case FMT_EOFF:
if ((i = cp[1]) == 0)
tmp = getvnames(code);
else {
for (tmp = env; i > 1; --i) tmp = cdr(tmp);
tmp = getelement(car(tmp),0);
}
for (i = cp[2]; i > 1; --i) tmp = cdr(tmp);
sprintf(buf,"%02x %02x %s %02x %02x ; ",cp[1],cp[2],
op->ot_name,cp[1],cp[2]);
xlputstr(fptr,buf);
xlprin1(car(tmp),fptr);
xlterpri(fptr);
n += 2;
break;
}
return (n);
}

/* check for an integrable function */
for (np = ntab; np->nt_name; ++np)
if (*cp == np->nt_code) {
sprintf(buf," %s\n",np->nt_name);
xlputstr(fptr,buf);
return (n);
}

/* unknown opcode */
sprintf(buf," \n");
xlputstr(fptr,buf);
return (n);
}