Amiga-Request@cs.odu.edu (Amiga Sources/Binaries Moderator) (04/15/90)
Submitted-by: rusty@fe2o3.UUCP (Rusty Haddock)
Posting-number: Volume 90, Issue 143
Archive-name: applications/xscheme-0.20/part05
#!/bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 5 (of 7)."
# Contents: Src/xscom.c
# Wrapped by tadguy@xanth on Sat Apr 14 17:07:28 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'Src/xscom.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xscom.c'\"
else
echo shar: Extracting \"'Src/xscom.c'\" \(33402 characters\)
sed "s/^X//" >'Src/xscom.c' <<'END_OF_FILE'
X/* xscom.c - a simple scheme bytecode compiler */
X/* Copyright (c) 1988, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xscheme.h"
X#include "xsbcode.h"
X
X/* size of code buffer */
X#define CMAX 4000
X
X/* continuation types */
X#define C_RETURN -1
X#define C_NEXT -2
X
X/* macro to check for a lambda list keyword */
X#define lambdakey(x) ((x) == lk_optional || (x) == lk_rest)
X
X/* external variables */
Xextern LVAL lk_optional,lk_rest,true;
X
X/* local variables */
Xstatic LVAL info; /* compiler info */
X
X/* code buffer */
Xstatic unsigned char cbuff[CMAX]; /* base of code buffer */
Xstatic int cbase; /* base for current function */
Xstatic int cptr; /* code buffer pointer */
X
X/* forward declarations */
Xint do_define(),do_set(),do_quote(),do_lambda(),do_delay();
Xint do_let(),do_letrec(),do_letstar(),do_cond(),do_and(),do_or();
Xint do_if(),do_begin(),do_while(),do_access();
XLVAL make_code_object();
X
X/* integrable function table */
Xtypedef struct { char *nt_name; int nt_code,nt_args; } NTDEF;
Xstatic NTDEF *nptr,ntab[] = {
X "ATOM", OP_ATOM, 1,
X "EQ?", OP_EQ, 2,
X "NULL?", OP_NULL, 1,
X "NOT", OP_NULL, 1,
X "CONS", OP_CONS, 2,
X "CAR", OP_CAR, 1,
X "CDR", OP_CDR, 1,
X "SET-CAR!", OP_SETCAR, 2,
X "SET-CDR!", OP_SETCDR, 2,
X "+", OP_ADD, -2,
X "-", OP_SUB, -2,
X "*", OP_MUL, -2,
X "QUOTIENT", OP_QUO, -2,
X "<", OP_LSS, -2,
X "=", OP_EQL, -2,
X ">", OP_GTR, -2,
X 0
X};
X
X/* special form table */
Xtypedef struct { char *ft_name; int (*ft_fcn)(); } FTDEF;
Xstatic FTDEF ftab[] = {
X "QUOTE", do_quote,
X "LAMBDA", do_lambda,
X "DELAY", do_delay,
X "LET", do_let,
X "LET*", do_letstar,
X "LETREC", do_letrec,
X "DEFINE", do_define,
X "SET!", do_set,
X "IF", do_if,
X "COND", do_cond,
X "BEGIN", do_begin,
X "SEQUENCE", do_begin,
X "AND", do_and,
X "OR", do_or,
X "WHILE", do_while,
X "ACCESS", do_access,
X 0
X};
X
X/* xlcompile - compile an expression */
XLVAL xlcompile(expr,ctenv)
X LVAL expr,ctenv;
X{
X /* initialize the compile time environment */
X info = cons(NIL,NIL); cpush(info);
X rplaca(info,newframe(ctenv,1));
X rplacd(info,cons(NIL,NIL));
X
X /* setup the base of the code for this function */
X cbase = cptr = 0;
X
X /* setup the entry code */
X putcbyte(OP_FRAME);
X putcbyte(1);
X
X /* compile the expression */
X do_expr(expr,C_RETURN);
X
X /* build the code object */
X settop(make_code_object(NIL));
X return (pop());
X}
X
X/* xlfunction - compile a function */
XLVAL xlfunction(fun,fargs,body,ctenv)
X LVAL fun,fargs,body,ctenv;
X{
X /* initialize the compile time environment */
X info = cons(NIL,NIL); cpush(info);
X rplaca(info,newframe(ctenv,1));
X rplacd(info,cons(NIL,NIL));
X
X /* setup the base of the code for this function */
X cbase = cptr = 0;
X
X /* compile the lambda list and the function body */
X parse_lambda_list(fargs,body);
X do_begin(body,C_RETURN);
X
X /* build the code object */
X settop(make_code_object(fun));
X return (pop());
X}
X
X/* do_expr - compile an expression */
XLOCAL do_expr(expr,cont)
X LVAL expr; int cont;
X{
X LVAL fun;
X if (consp(expr)) {
X fun = car(expr);
X if (!symbolp(fun) || (!in_ntab(expr,cont) && !in_ftab(expr,cont)))
X do_call(expr,cont);
X }
X else if (symbolp(expr))
X do_identifier(expr,cont);
X else
X do_literal(expr,cont);
X}
X
X/* in_ntab - check for a function in ntab */
XLOCAL int in_ntab(expr,cont)
X LVAL expr; int cont;
X{
X unsigned char *pname;
X pname = getstring(getpname(car(expr)));
X for (nptr = ntab; nptr->nt_name; ++nptr)
X if (strcmp(pname,nptr->nt_name) == 0) {
X do_nary(nptr->nt_code,nptr->nt_args,expr,cont);
X return (TRUE);
X }
X return (FALSE);
X}
X
X/* in_ftab - check for a function in ftab */
XLOCAL int in_ftab(expr,cont)
X LVAL expr; int cont;
X{
X unsigned char *pname;
X FTDEF *fptr;
X pname = getstring(getpname(car(expr)));
X for (fptr = ftab; fptr->ft_name; ++fptr)
X if (strcmp(pname,fptr->ft_name) == 0) {
X (*fptr->ft_fcn)(cdr(expr),cont);
X return (TRUE);
X }
X return (FALSE);
X}
X
X/* do_define - handle the (DEFINE ... ) expression */
XLOCAL do_define(form,cont)
X LVAL form; int cont;
X{
X if (atom(form))
X xlerror("expecting symbol or function template",form);
X define1(car(form),cdr(form),cont);
X}
X
X/* define1 - helper routine for do_define */
XLOCAL define1(list,body,cont)
X LVAL list,body; int cont;
X{
X LVAL fargs;
X int off;
X
X /* handle nested definitions */
X if (consp(list)) {
X cpush(cons(xlenter("LAMBDA"),NIL)); /* (LAMBDA) */
X rplacd(top(),cons(cdr(list),NIL)); /* (LAMBDA args) */
X rplacd(cdr(top()),body); /* (LAMBDA args body) */
X settop(cons(top(),NIL)); /* ((LAMBDA args body)) */
X define1(car(list),top(),cont);
X drop(1);
X }
X
X /* compile procedure definitions */
X else {
X
X /* make sure it's a symbol */
X if (!symbolp(list))
X xlerror("expecting a symbol",list);
X
X /* check for a procedure definition */
X if (consp(body)
X && consp(car(body))
X && car(car(body)) == xlenter("LAMBDA")) {
X fargs = car(cdr(car(body)));
X body = cdr(cdr(car(body)));
X cd_fundefinition(list,fargs,body);
X }
X
X /* compile the value expression or procedure body */
X else
X do_begin(body,C_NEXT);
X
X /* define the variable value */
X if (findcvariable(list,&off))
X cd_evariable(OP_ESET,0,off);
X else
X cd_variable(OP_GSET,list);
X do_literal(list,cont);
X }
X}
X
X/* do_set - compile the (SET! ... ) expression */
XLOCAL do_set(form,cont)
X LVAL form; int cont;
X{
X if (atom(form))
X xlerror("expecting symbol or ACCESS form",form);
X else if (symbolp(car(form)))
X do_setvar(form,cont);
X else if (consp(car(form)))
X do_setaccess(form,cont);
X else
X xlerror("expecting symbol or ACCESS form",form);
X}
X
X/* do_setvar - compile the (SET! var value) expression */
XLOCAL do_setvar(form,cont)
X LVAL form; int cont;
X{
X int lev,off;
X LVAL sym;
X
X /* get the variable name */
X sym = car(form);
X
X /* compile the value expression */
X form = cdr(form);
X if (atom(form))
X xlerror("expecting value expression",form);
X do_expr(car(form),C_NEXT);
X
X /* set the variable value */
X if (findvariable(sym,&lev,&off))
X cd_evariable(OP_ESET,lev,off);
X else
X cd_variable(OP_GSET,sym);
X do_continuation(cont);
X}
X
X/* do_quote - compile the (QUOTE ... ) expression */
XLOCAL do_quote(form,cont)
X LVAL form; int cont;
X{
X if (atom(form))
X xlerror("expecting quoted expression",form);
X do_literal(car(form),cont);
X}
X
X/* do_lambda - compile the (LAMBDA ... ) expression */
XLOCAL do_lambda(form,cont)
X LVAL form; int cont;
X{
X if (atom(form))
X xlerror("expecting argument list",form);
X cd_fundefinition(NIL,car(form),cdr(form));
X do_continuation(cont);
X}
X
X/* cd_fundefinition - compile the function */
XLOCAL cd_fundefinition(fun,fargs,body)
X LVAL fun,fargs,body;
X{
X int oldcbase;
X
X /* establish a new environment frame */
X oldcbase = add_level();
X
X /* compile the lambda list and the function body */
X parse_lambda_list(fargs,body);
X do_begin(body,C_RETURN);
X
X /* build the code object */
X cpush(make_code_object(fun));
X
X /* restore the previous environment */
X remove_level(oldcbase);
X
X /* compile code to create a closure */
X do_literal(pop(),C_NEXT);
X putcbyte(OP_CLOSE);
X}
X
X/* parse_lambda_list - parse the formal argument list */
XLOCAL parse_lambda_list(fargs,body)
X LVAL fargs,body;
X{
X LVAL arg,restarg,new,last;
X int frame,slotn;
X
X /* setup the entry code */
X putcbyte(OP_FRAME);
X frame = putcbyte(0);
X
X /* initialize the argument name list and slot number */
X restarg = last = NIL;
X slotn = 1;
X
X /* handle each required argument */
X while (consp(fargs) && (arg = car(fargs)) && !lambdakey(arg)) {
X
X /* make sure the argument is a symbol */
X if (!symbolp(arg))
X xlerror("variable must be a symbol",arg);
X
X /* add the argument name to the name list */
X new = cons(arg,NIL);
X if (last) rplacd(last,new);
X else setelement(car(car(info)),0,new);
X last = new;
X
X /* generate an instruction to move the argument into the frame */
X putcbyte(OP_MVARG);
X putcbyte(slotn++);
X
X /* move the formal argument list pointer ahead */
X fargs = cdr(fargs);
X }
X
X /* check for the '#!optional' argument */
X if (consp(fargs) && car(fargs) == lk_optional) {
X fargs = cdr(fargs);
X
X /* handle each optional argument */
X while (consp(fargs) && (arg = car(fargs)) && !lambdakey(arg)) {
X
X /* make sure the argument is a symbol */
X if (!symbolp(arg))
X xlerror("#!optional variable must be a symbol",arg);
X
X /* add the argument name to the name list */
X new = cons(arg,NIL);
X if (last) rplacd(last,new);
X else setelement(car(car(info)),0,new);
X last = new;
X
X /* move the argument into the frame */
X putcbyte(OP_MVOARG);
X putcbyte(slotn++);
X
X /* move the formal argument list pointer ahead */
X fargs = cdr(fargs);
X }
X }
X
X /* check for the '#!rest' argument */
X if (consp(fargs) && car(fargs) == lk_rest) {
X fargs = cdr(fargs);
X
X /* handle the rest argument */
X if (consp(fargs) && (restarg = car(fargs)) && !lambdakey(restarg)) {
X
X /* make sure the argument is a symbol */
X if (!symbolp(restarg))
X xlerror("#!rest variable must be a symbol",restarg);
X
X /* add the argument name to the name list */
X new = cons(restarg,NIL);
X if (last) rplacd(last,new);
X else setelement(car(car(info)),0,new);
X last = new;
X
X /* make the #!rest argument list */
X putcbyte(OP_MVRARG);
X putcbyte(slotn++);
X
X /* move the formal argument list pointer ahead */
X fargs = cdr(fargs);
X }
X else
X xlerror("expecting the #!rest variable");
X }
X
X /* check for the a dotted tail */
X if (restarg == NIL && symbolp(fargs)) {
X restarg = fargs;
X
X /* add the argument name to the name list */
X new = cons(restarg,NIL);
X if (last) rplacd(last,new);
X else setelement(car(car(info)),0,new);
X last = new;
X
X /* make the #!rest argument list */
X putcbyte(OP_MVRARG);
X putcbyte(slotn++);
X fargs = NIL;
X }
X
X /* check for the end of the argument list */
X if (fargs != NIL)
X xlerror("bad argument list tail",fargs);
X
X /* make sure the user didn't supply too many arguments */
X if (restarg == NIL)
X putcbyte(OP_ALAST);
X
X /* scan the body for internal definitions */
X slotn += find_internal_definitions(body,last);
X
X /* fixup the frame instruction */
X cbuff[cbase+frame] = slotn;
X}
X
X/* find_internal_definitions - find internal definitions */
XLOCAL int find_internal_definitions(body,last)
X LVAL body,last;
X{
X LVAL define,sym,new;
X int n=0;
X
X /* look for all (define...) forms */
X for (define = xlenter("DEFINE"); consp(body); body = cdr(body))
X if (consp(car(body)) && car(car(body)) == define) {
X sym = cdr(car(body)); /* the rest of the (define...) form */
X if (consp(sym)) { /* make sure there is a second subform */
X sym = car(sym); /* get the second subform */
X while (consp(sym))/* check for a procedure definition */
X sym = car(sym);
X if (symbolp(sym)) {
X new = cons(sym,NIL);
X if (last) rplacd(last,new);
X else setelement(car(car(info)),0,new);
X last = new;
X ++n;
X }
X }
X }
X return (n);
X}
X
X/* do_delay - compile the (DELAY ... ) expression */
XLOCAL do_delay(form,cont)
X LVAL form; int cont;
X{
X int oldcbase;
X
X /* check argument list */
X if (atom(form))
X xlerror("expecting delay expression",form);
X
X /* establish a new environment frame */
X oldcbase = add_level();
X
X /* setup the entry code */
X putcbyte(OP_FRAME);
X putcbyte(1);
X
X /* compile the expression */
X do_expr(car(form),C_RETURN);
X
X /* build the code object */
X cpush(make_code_object(NIL));
X
X /* restore the previous environment */
X remove_level(oldcbase);
X
X /* compile code to create a closure */
X do_literal(pop(),C_NEXT);
X putcbyte(OP_DELAY);
X do_continuation(cont);
X}
X
X/* do_let - compile the (LET ... ) expression */
XLOCAL do_let(form,cont)
X LVAL form; int cont;
X{
X /* handle named let */
X if (consp(form) && symbolp(car(form)))
X do_named_let(form,cont);
X
X /* handle unnamed let */
X else
X cd_let(NIL,form,cont);
X}
X
X/* do_named_let - compile the (LET name ... ) expression */
XLOCAL do_named_let(form,cont)
X LVAL form; int cont;
X{
X int oldcbase,nxt;
X
X /* save a continuation */
X if (cont != C_RETURN) {
X putcbyte(OP_SAVE);
X nxt = putcword(0);
X }
X
X /* establish a new environment frame */
X oldcbase = add_level();
X setelement(car(car(info)),0,cons(car(form),NIL));
X
X /* setup the entry code */
X putcbyte(OP_FRAME);
X putcbyte(2);
X
X /* compile the let expression */
X cd_let(car(form),cdr(form),C_RETURN);
X
X /* build the code object */
X cpush(make_code_object(NIL));
X
X /* restore the previous environment */
X remove_level(oldcbase);
X
X /* compile code to create a closure */
X do_literal(pop(),C_NEXT);
X putcbyte(OP_CLOSE);
X
X /* apply the function */
X putcbyte(OP_CALL);
X putcbyte(1);
X
X /* target for the continuation */
X if (cont != C_RETURN)
X fixup(nxt);
X}
X
X/* cd_let - code a let expression */
XLOCAL cd_let(name,form,cont)
X LVAL name,form; int cont;
X{
X int oldcbase,nxt,lev,off,n;
X
X /* make sure there is a binding list */
X if (atom(form) || !listp(car(form)))
X xlerror("expecting binding list",form);
X
X /* save a continuation */
X if (cont != C_RETURN) {
X putcbyte(OP_SAVE);
X nxt = putcword(0);
X }
X
X /* push the initialization expressions */
X n = push_init_expressions(car(form));
X
X /* establish a new environment frame */
X oldcbase = add_level();
X
X /* compile the binding list */
X parse_let_variables(car(form),cdr(form));
X
X /* compile the body of the let/letrec */
X do_begin(cdr(form),C_RETURN);
X
X /* build the code object */
X cpush(make_code_object(NIL));
X
X /* restore the previous environment */
X remove_level(oldcbase);
X
X /* compile code to create a closure */
X do_literal(pop(),C_NEXT);
X putcbyte(OP_CLOSE);
X
X /* store the procedure */
X if (name && findvariable(name,&lev,&off))
X cd_evariable(OP_ESET,lev,off);
X
X /* apply the function */
X putcbyte(OP_CALL);
X putcbyte(n);
X
X /* target for the continuation */
X if (cont != C_RETURN)
X fixup(nxt);
X}
X
X/* do_letrec - compile the (LETREC ... ) expression */
XLOCAL do_letrec(form,cont)
X LVAL form; int cont;
X{
X int oldcbase,nxt,n;
X
X /* make sure there is a binding list */
X if (atom(form) || !listp(car(form)))
X xlerror("expecting binding list",form);
X
X /* save a continuation */
X if (cont != C_RETURN) {
X putcbyte(OP_SAVE);
X nxt = putcword(0);
X }
X
X /* push the initialization expressions */
X n = push_dummy_values(car(form));
X
X /* establish a new environment frame */
X oldcbase = add_level();
X
X /* compile the binding list */
X parse_let_variables(car(form),cdr(form));
X
X /* compile instructions to set the bound variables */
X set_bound_variables(car(form));
X
X /* compile the body of the let/letrec */
X do_begin(cdr(form),C_RETURN);
X
X /* build the code object */
X cpush(make_code_object(NIL));
X
X /* restore the previous environment */
X remove_level(oldcbase);
X
X /* compile code to create a closure */
X do_literal(pop(),C_NEXT);
X putcbyte(OP_CLOSE);
X
X /* apply the function */
X putcbyte(OP_CALL);
X putcbyte(n);
X
X /* target for the continuation */
X if (cont != C_RETURN)
X fixup(nxt);
X}
X
X/* do_letstar - compile the (LET* ... ) expression */
XLOCAL do_letstar(form,cont)
X LVAL form; int cont;
X{
X int nxt;
X
X /* make sure there is a binding list */
X if (atom(form) || !listp(car(form)))
X xlerror("expecting binding list",form);
X
X /* handle the case where there are bindings */
X if (consp(car(form))) {
X
X /* save a continuation */
X if (cont != C_RETURN) {
X putcbyte(OP_SAVE);
X nxt = putcword(0);
X }
X
X /* build the nested lambda expressions */
X letstar1(car(form),cdr(form));
X
X /* target for the continuation */
X if (cont != C_RETURN)
X fixup(nxt);
X }
X
X /* handle the case where there are no bindings */
X else
X do_begin(cdr(form),cont);
X}
X
X/* letstar1 - helper routine for let* */
XLOCAL letstar1(blist,body)
X LVAL blist,body;
X{
X int oldcbase,n;
X
X /* push the next initialization expressions */
X cpush(cons(car(blist),NIL));
X n = push_init_expressions(top());
X
X /* establish a new environment frame */
X oldcbase = add_level();
X
X /* handle the case where there are more bindings */
X if (consp(cdr(blist))) {
X parse_let_variables(top(),NIL);
X letstar1(cdr(blist),body);
X }
X
X /* handle the last binding */
X else {
X parse_let_variables(top(),body);
X do_begin(body,C_RETURN);
X }
X
X /* build the code object */
X settop(make_code_object(NIL));
X
X /* restore the previous environment */
X remove_level(oldcbase);
X
X /* compile code to create a closure */
X do_literal(pop(),C_NEXT);
X putcbyte(OP_CLOSE);
X
X /* apply the function */
X putcbyte(OP_CALL);
X putcbyte(n);
X}
X
X/* push_dummy_values - push dummy values for a 'letrec' expression */
XLOCAL int push_dummy_values(blist)
X LVAL blist;
X{
X int n=0;
X if (consp(blist)) {
X putcbyte(OP_NIL);
X for (; consp(blist); blist = cdr(blist), ++n)
X putcbyte(OP_PUSH);
X }
X return (n);
X}
X
X/* push_init_expressions - push init expressions for a 'let' expression */
XLOCAL int push_init_expressions(blist)
X LVAL blist;
X{
X int n;
X if (consp(blist)) {
X n = push_init_expressions(cdr(blist));
X if (consp(car(blist)) && consp(cdr(car(blist))))
X do_expr(car(cdr(car(blist))),C_NEXT);
X else
X putcbyte(OP_NIL);
X putcbyte(OP_PUSH);
X return (n+1);
X }
X return (0);
X}
X
X/* parse_let_variables - parse the binding list */
XLOCAL parse_let_variables(blist,body)
X LVAL blist,body;
X{
X LVAL arg,new,last;
X int frame,slotn;
X
X /* setup the entry code */
X putcbyte(OP_FRAME);
X frame = putcbyte(0);
X
X /* initialize the argument name list and slot number */
X last = NIL;
X slotn = 1;
X
X /* handle each required argument */
X while (consp(blist) && (arg = car(blist))) {
X
X /* make sure the argument is a symbol */
X if (symbolp(arg))
X new = cons(arg,NIL);
X else if (consp(arg) && symbolp(car(arg)))
X new = cons(car(arg),NIL);
X else
X xlerror("invalid binding",arg);
X
X /* add the argument name to the name list */
X if (last) rplacd(last,new);
X else setelement(car(car(info)),0,new);
X last = new;
X
X /* generate an instruction to move the argument into the frame */
X putcbyte(OP_MVARG);
X putcbyte(slotn++);
X
X /* move the formal argument list pointer ahead */
X blist = cdr(blist);
X }
X putcbyte(OP_ALAST);
X
X /* scan the body for internal definitions */
X slotn += find_internal_definitions(body,last);
X
X /* fixup the frame instruction */
X cbuff[cbase+frame] = slotn;
X}
X
X/* set_bound_variables - set bound variables in a 'letrec' expression */
XLOCAL set_bound_variables(blist)
X LVAL blist;
X{
X int lev,off;
X for (; consp(blist); blist = cdr(blist)) {
X if (consp(car(blist)) && consp(cdr(car(blist)))) {
X do_expr(car(cdr(car(blist))),C_NEXT);
X if (findvariable(car(car(blist)),&lev,&off))
X cd_evariable(OP_ESET,lev,off);
X else
X xlerror("compiler error -- can't find",car(car(blist)));
X }
X }
X}
X
X/* make_code_object - build a code object */
XLOCAL LVAL make_code_object(fun)
X LVAL fun;
X{
X unsigned char *cp;
X LVAL code,p;
X int i;
X
X /* create a code object */
X code = newcode(FIRSTLIT + length(car(cdr(info)))); cpush(code);
X setbcode(code,newstring(cptr - cbase));
X setcname(code,fun); /* function name */
X setvnames(code,getelement(car(car(info)),0));/* lambda list variables */
X
X /* copy the literals into the code object */
X for (i = FIRSTLIT, p = car(cdr(info)); consp(p); p = cdr(p), ++i)
X setelement(code,i,car(p));
X
X /* copy the byte codes */
X for (i = cbase, cp = getstring(getbcode(code)); i < cptr; )
X *cp++ = cbuff[i++];
X
X /* return the new code object */
X return (pop());
X}
X
X/* do_cond - compile the (COND ... ) expression */
XLOCAL do_cond(form,cont)
X LVAL form; int cont;
X{
X int nxt,end;
X if (consp(form)) {
X for (end = 0; consp(form); form = cdr(form)) {
X if (atom(car(form)))
X xlerror("expecting a cond clause",form);
X do_expr(car(car(form)),C_NEXT);
X putcbyte(OP_BRF);
X nxt = putcword(0);
X if (cdr(car(form)))
X do_begin(cdr(car(form)),cont);
X else
X do_continuation(cont);
X if (cont == C_NEXT) {
X putcbyte(OP_BR);
X end = putcword(end);
X }
X fixup(nxt);
X }
X fixup(end);
X }
X else
X putcbyte(OP_NIL);
X do_continuation(cont);
X}
X
X/* do_and - compile the (AND ... ) expression */
XLOCAL do_and(form,cont)
X LVAL form; int cont;
X{
X int end;
X if (consp(form)) {
X for (end = 0; consp(form); form = cdr(form)) {
X if (cdr(form)) {
X do_expr(car(form),C_NEXT);
X putcbyte(OP_BRF);
X end = putcword(end);
X }
X else
X do_expr(car(form),cont);
X }
X fixup(end);
X }
X else
X putcbyte(OP_T);
X do_continuation(cont);
X}
X
X/* do_or - compile the (OR ... ) expression */
XLOCAL do_or(form,cont)
X LVAL form; int cont;
X{
X int end;
X if (consp(form)) {
X for (end = 0; consp(form); form = cdr(form)) {
X if (cdr(form)) {
X do_expr(car(form),C_NEXT);
X putcbyte(OP_BRT);
X end = putcword(end);
X }
X else
X do_expr(car(form),cont);
X }
X fixup(end);
X }
X else
X putcbyte(OP_NIL);
X do_continuation(cont);
X}
X
X/* do_if - compile the (IF ... ) expression */
XLOCAL do_if(form,cont)
X LVAL form; int cont;
X{
X int nxt,end;
X
X /* compile the test expression */
X if (atom(form))
X xlerror("expecting test expression",form);
X do_expr(car(form),C_NEXT);
X
X /* skip around the 'then' clause if the expression is false */
X putcbyte(OP_BRF);
X nxt = putcword(0);
X
X /* skip to the 'then' clause */
X form = cdr(form);
X if (atom(form))
X xlerror("expecting then clause",form);
X
X /* compile the 'then' and 'else' clauses */
X if (consp(cdr(form))) {
X if (cont == C_NEXT) {
X do_expr(car(form),C_NEXT);
X putcbyte(OP_BR);
X end = putcword(0);
X }
X else {
X do_expr(car(form),cont);
X end = -1;
X }
X fixup(nxt);
X do_expr(car(cdr(form)),cont);
X nxt = end;
X }
X
X /* compile just a 'then' clause */
X else
X do_expr(car(form),cont);
X
X /* handle the end of the statement */
X if (nxt >= 0) {
X fixup(nxt);
X do_continuation(cont);
X }
X}
X
X/* do_begin - compile the (BEGIN ... ) expression */
XLOCAL do_begin(form,cont)
X LVAL form; int cont;
X{
X if (consp(form))
X for (; consp(form); form = cdr(form))
X if (consp(cdr(form)))
X do_expr(car(form),C_NEXT);
X else
X do_expr(car(form),cont);
X else {
X putcbyte(OP_NIL);
X do_continuation(cont);
X }
X}
X
X/* do_while - compile the (WHILE ... ) expression */
XLOCAL do_while(form,cont)
X LVAL form; int cont;
X{
X int loop,nxt;
X
X /* make sure there is a test expression */
X if (atom(form))
X xlerror("expecting test expression",form);
X
X /* skip around the 'body' to the test expression */
X putcbyte(OP_BR);
X nxt = putcword(0);
X
X /* compile the loop body */
X loop = cptr - cbase;
X do_begin(cdr(form),C_NEXT);
X
X /* label for the first iteration */
X fixup(nxt);
X
X /* compile the test expression */
X nxt = cptr - cbase;
X do_expr(car(form),C_NEXT);
X
X /* skip around the 'body' if the expression is false */
X putcbyte(OP_BRT);
X putcword(loop);
X
X /* compile the continuation */
X do_continuation(cont);
X}
X
X/* do_access - compile the (ACCESS var env) expression */
XLOCAL do_access(form,cont)
X LVAL form; int cont;
X{
X LVAL sym;
X
X /* get the variable name */
X if (atom(form) || !symbolp(car(form)))
X xlerror("expecting symbol",form);
X sym = car(form);
X
X /* compile the environment expression */
X form = cdr(form);
X if (atom(form))
X xlerror("expecting environment expression",form);
X do_expr(car(form),C_NEXT);
X
X /* get the variable value */
X cd_variable(OP_AREF,sym);
X do_continuation(cont);
X}
X
X/* do_setaccess - compile the (SET! (ACCESS var env) value) expression */
XLOCAL do_setaccess(form,cont)
X LVAL form; int cont;
X{
X LVAL aform,sym;
X
X /* make sure this is an access form */
X aform = car(form);
X if (atom(aform) || car(aform) != xlenter("ACCESS"))
X xlerror("expecting an ACCESS form",aform);
X
X /* get the variable name */
X aform = cdr(aform);
X if (atom(aform) || !symbolp(car(aform)))
X xlerror("expecting symbol",aform);
X sym = car(aform);
X
X /* compile the environment expression */
X aform = cdr(aform);
X if (atom(aform))
X xlerror("expecting environment expression",aform);
X do_expr(car(aform),C_NEXT);
X putcbyte(OP_PUSH);
X
X /* compile the value expression */
X form = cdr(form);
X if (atom(form))
X xlerror("expecting value expression",form);
X do_expr(car(form),C_NEXT);
X
X /* set the variable value */
X cd_variable(OP_ASET,sym);
X do_continuation(cont);
X}
X
X/* do_call - compile a function call */
XLOCAL do_call(form,cont)
X LVAL form; int cont;
X{
X int nxt,n;
X
X /* save a continuation */
X if (cont != C_RETURN) {
X putcbyte(OP_SAVE);
X nxt = putcword(0);
X }
X
X /* compile each argument expression */
X n = push_args(cdr(form));
X
X /* compile the function itself */
X do_expr(car(form),C_NEXT);
X
X /* apply the function */
X putcbyte(OP_CALL);
X putcbyte(n);
X
X /* target for the continuation */
X if (cont != C_RETURN)
X fixup(nxt);
X}
X
X/* push_args - compile the arguments for a function call */
XLOCAL int push_args(form)
X LVAL form;
X{
X int n;
X if (consp(form)) {
X n = push_args(cdr(form));
X do_expr(car(form),C_NEXT);
X putcbyte(OP_PUSH);
X return (n+1);
X }
X return (0);
X}
X
X/* do_nary - compile nary operator expressions */
XLOCAL do_nary(op,n,form,cont)
X int op,n; LVAL form; int cont;
X{
X if (n < 0 && (n = (-n)) != length(cdr(form)))
X do_call(form,cont);
X else {
X push_nargs(cdr(form),n);
X putcbyte(op);
X do_continuation(cont);
X }
X}
X
X/* push_nargs - compile the arguments for an inline function call */
XLOCAL int push_nargs(form,n)
X LVAL form; int n;
X{
X if (consp(form)) {
X if (n == 0)
X xlerror("too many arguments",form);
X if (push_nargs(cdr(form),n-1))
X putcbyte(OP_PUSH);
X do_expr(car(form),C_NEXT);
X return (TRUE);
X }
X if (n)
X xlerror("too few arguments",form);
X return (FALSE);
X}
X
X/* do_literal - compile a literal */
XLOCAL do_literal(lit,cont)
X LVAL lit; int cont;
X{
X cd_literal(lit);
X do_continuation(cont);
X}
X
X/* do_identifier - compile an identifier */
XLOCAL do_identifier(sym,cont)
X LVAL sym; int cont;
X{
X int lev,off;
X if (sym == true)
X putcbyte(OP_T);
X else if (findvariable(sym,&lev,&off))
X cd_evariable(OP_EREF,lev,off);
X else
X cd_variable(OP_GREF,sym);
X do_continuation(cont);
X}
X
X/* do_continuation - compile a continuation */
XLOCAL do_continuation(cont)
X int cont;
X{
X switch (cont) {
X case C_RETURN:
X putcbyte(OP_RETURN);
X break;
X case C_NEXT:
X break;
X }
X}
X
X/* add_level - add a nesting level */
XLOCAL int add_level()
X{
X int oldcbase;
X
X /* establish a new environment frame */
X rplaca(info,newframe(car(info),1));
X rplacd(info,cons(NIL,cdr(info)));
X
X /* setup the base of the code for this function */
X oldcbase = cbase;
X cbase = cptr;
X
X /* return the old code base */
X return (oldcbase);
X}
X
X/* remove_level - remove a nesting level */
XLOCAL remove_level(oldcbase)
X int oldcbase;
X{
X /* restore the previous environment */
X rplaca(info,cdr(car(info)));
X rplacd(info,cdr(cdr(info)));
X
X /* restore the base and code pointer */
X cptr = cbase;
X cbase = oldcbase;
X}
X
X/* findvariable - find an environment variable */
XLOCAL int findvariable(sym,plev,poff)
X LVAL sym; int *plev,*poff;
X{
X int lev,off;
X LVAL e,a;
X for (e = car(info), lev = 0; envp(e); e = cdr(e), ++lev)
X for (a = getelement(car(e),0), off = 1; consp(a); a = cdr(a), ++off)
X if (sym == car(a)) {
X *plev = lev;
X *poff = off;
X return (TRUE);
X }
X return (FALSE);
X}
X
X/* findcvariable - find an environment variable in the current frame */
XLOCAL int findcvariable(sym,poff)
X LVAL sym; int *poff;
X{
X int off;
X LVAL a;
X a = getelement(car(car(info)),0);
X for (off = 1; consp(a); a = cdr(a), ++off)
X if (sym == car(a)) {
X *poff = off;
X return (TRUE);
X }
X return (FALSE);
X}
X
X/* findliteral - find a literal in the literal frame */
XLOCAL int findliteral(lit)
X LVAL lit;
X{
X int o = FIRSTLIT;
X LVAL t,p;
X if (t = car(cdr(info))) {
X for (p = NIL; consp(t); p = t, t = cdr(t), ++o)
X if (equal(lit,car(t)))
X return (o);
X rplacd(p,cons(lit,NIL));
X }
X else
X rplaca(cdr(info),cons(lit,NIL));
X return (o);
X}
X
X/* cd_variable - compile a variable reference */
XLOCAL cd_variable(op,sym)
X int op; LVAL sym;
X{
X putcbyte(op);
X putcbyte(findliteral(sym));
X}
X
X/* cd_evariable - compile an environment variable reference */
XLOCAL cd_evariable(op,lev,off)
X int op,lev,off;
X{
X putcbyte(op);
X putcbyte(lev);
X putcbyte(off);
X}
X
X/* cd_literal - compile a literal reference */
XLOCAL cd_literal(lit)
X LVAL lit;
X{
X if (lit == NIL)
X putcbyte(OP_NIL);
X else if (lit == true)
X putcbyte(OP_T);
X else {
X putcbyte(OP_LIT);
X putcbyte(findliteral(lit));
X }
X}
X
X/* putcbyte - put a code byte into data space */
XLOCAL int putcbyte(b)
X int b;
X{
X int adr;
X if (cptr >= CMAX)
X xlabort("insufficient code space");
X adr = (cptr - cbase);
X cbuff[cptr++] = b;
X return (adr);
X}
X
X/* putcword - put a code word into data space */
XLOCAL int putcword(w)
X int w;
X{
X int adr;
X adr = putcbyte(w >> 8);
X putcbyte(w);
X return (adr);
X}
X
X/* fixup - fixup a reference chain */
XLOCAL fixup(chn)
X int chn;
X{
X int val,hval,nxt;
X
X /* store the value into each location in the chain */
X val = cptr - cbase; hval = val >> 8;
X for (; chn; chn = nxt) {
X nxt = (cbuff[cbase+chn] << 8) | (cbuff[cbase+chn+1]);
X cbuff[cbase+chn] = hval;
X cbuff[cbase+chn+1] = val;
X }
X}
X
X/* length - find the length of a list */
Xint length(list)
X LVAL list;
X{
X int len;
X for (len = 0; consp(list); list = cdr(list))
X ++len;
X return (len);
X}
X
X/* instruction output formats */
X#define FMT_NONE 0
X#define FMT_BYTE 1
X#define FMT_LOFF 2
X#define FMT_WORD 3
X#define FMT_EOFF 4
X
Xtypedef struct { int ot_code; char *ot_name; int ot_fmt; } OTDEF;
XOTDEF otab[] = {
X{ OP_BRT, "BRT", FMT_WORD },
X{ OP_BRF, "BRF", FMT_WORD },
X{ OP_BR, "BR", FMT_WORD },
X{ OP_LIT, "LIT", FMT_LOFF },
X{ OP_GREF, "GREF", FMT_LOFF },
X{ OP_GSET, "GSET", FMT_LOFF },
X{ OP_EREF, "EREF", FMT_EOFF },
X{ OP_ESET, "ESET", FMT_EOFF },
X{ OP_SAVE, "SAVE", FMT_WORD },
X{ OP_CALL, "CALL", FMT_BYTE },
X{ OP_RETURN, "RETURN", FMT_NONE },
X{ OP_T, "T", FMT_NONE },
X{ OP_NIL, "NIL", FMT_NONE },
X{ OP_PUSH, "PUSH", FMT_NONE },
X{ OP_CLOSE, "CLOSE", FMT_NONE },
X{ OP_DELAY, "DELAY", FMT_NONE },
X
X{ OP_FRAME, "FRAME", FMT_BYTE },
X{ OP_MVARG, "MVARG", FMT_BYTE },
X{ OP_MVOARG, "MVOARG", FMT_BYTE },
X{ OP_MVRARG, "MVRARG", FMT_BYTE },
X{ OP_ADROP, "ADROP", FMT_NONE },
X{ OP_ALAST, "ALAST", FMT_NONE },
X
X{ OP_AREF, "AREF", FMT_LOFF },
X{ OP_ASET, "ASET", FMT_LOFF },
X
X{0,0,0}
X};
X
X/* decode_procedure - decode the instructions in a code object */
Xdecode_procedure(fptr,fun)
X LVAL fptr,fun;
X{
X int len,lc,n;
X LVAL code,env;
X code = getcode(fun);
X env = getenv(fun);
X len = getslength(getbcode(code));
X for (lc = 0; lc < len; lc += n)
X n = decode_instruction(fptr,code,lc,env);
X}
X
X/* decode_instruction - decode a single bytecode instruction */
Xint decode_instruction(fptr,code,lc,env)
X LVAL fptr,code; int lc; LVAL env;
X{
X unsigned char *cp;
X char buf[100];
X OTDEF *op;
X NTDEF *np;
X int i,n=1;
X LVAL tmp;
X
X /* get a pointer to the bytecodes for this instruction */
X cp = getstring(getbcode(code)) + lc;
X
X /* show the address and opcode */
X if (tmp = getcname(code))
X sprintf(buf,"%s:%04x %02x ",getstring(getpname(tmp)),lc,*cp);
X else {
X sprintf(buf,AFMT,code); xlputstr(fptr,buf);
X sprintf(buf,":%04x %02x ",lc,*cp);
X }
X xlputstr(fptr,buf);
X
X /* display the operands */
X for (op = otab; op->ot_name; ++op)
X if (*cp == op->ot_code) {
X switch (op->ot_fmt) {
X case FMT_NONE:
X sprintf(buf," %s\n",op->ot_name);
X xlputstr(fptr,buf);
X break;
X case FMT_BYTE:
X sprintf(buf,"%02x %s %02x\n",cp[1],op->ot_name,cp[1]);
X xlputstr(fptr,buf);
X n += 1;
X break;
X case FMT_LOFF:
X sprintf(buf,"%02x %s %02x ; ",cp[1],op->ot_name,cp[1]);
X xlputstr(fptr,buf);
X xlprin1(getelement(code,cp[1]),fptr);
X xlterpri(fptr);
X n += 1;
X break;
X case FMT_WORD:
X sprintf(buf,"%02x %02x %s %02x%02x\n",cp[1],cp[2],
X op->ot_name,cp[1],cp[2]);
X xlputstr(fptr,buf);
X n += 2;
X break;
X case FMT_EOFF:
X if ((i = cp[1]) == 0)
X tmp = getvnames(code);
X else {
X for (tmp = env; i > 1; --i) tmp = cdr(tmp);
X tmp = getelement(car(tmp),0);
X }
X for (i = cp[2]; i > 1; --i) tmp = cdr(tmp);
X sprintf(buf,"%02x %02x %s %02x %02x ; ",cp[1],cp[2],
X op->ot_name,cp[1],cp[2]);
X xlputstr(fptr,buf);
X xlprin1(car(tmp),fptr);
X xlterpri(fptr);
X n += 2;
X break;
X }
X return (n);
X }
X
X /* check for an integrable function */
X for (np = ntab; np->nt_name; ++np)
X if (*cp == np->nt_code) {
X sprintf(buf," %s\n",np->nt_name);
X xlputstr(fptr,buf);
X return (n);
X }
X
X /* unknown opcode */
X sprintf(buf," <UNKNOWN>\n");
X xlputstr(fptr,buf);
X return (n);
X}
END_OF_FILE
if test 33402 -ne `wc -c <'Src/xscom.c'`; then
echo shar: \"'Src/xscom.c'\" unpacked with wrong size!
fi
# end of 'Src/xscom.c'
fi
echo shar: End of archive 5 \(of 7\).
cp /dev/null ark5isdone
MISSING=""
for I in 1 2 3 4 5 6 7 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 7 archives.
rm -f ark[1-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
Mail submissions (sources or binaries) to <amiga@cs.odu.edu>.
Mail comments to the moderator at <amiga-request@cs.odu.edu>.
Post requests for sources, and general discussion to comp.sys.amiga.