/**** use getlitfun where needed */
/**** allow literals to be NIL instead of zero-length vector */
/**** reduce stack checks */
/**** think through adding C continuations */
/**** avoid making closure in evform? */
/**** work through all opcodes provided and needed to get all special forms */
/**** separate out inline code */
/**** make more efficient function represaentation */
/**** move argument fixup, expansion, constant loading into code */
/**** build complete machine for unoptimized code */
/**** check that fast dispatch in non_bcode_call is OK */
/**** check MULVALS, protection of fun in non_bcode_call; check efficiency */
/**** play with efficiency of VM before adding lots of opcodes!!!*/
/**** check efficiency of number stuff */
/**** check on dynamic env and unwind-protect */
#include "xlisp.h"
#ifdef BYTECODE
#include "xlbcode.h"
#include "xlmodule.h"
/* forward declarations */
LOCAL LVAL copy_bcode P1H(LVAL);
LOCAL bytecode *non_bcode_call P4H(bytecode *, LVAL, int, int);
LOCAL bytecode *bccall_setup P5H(bytecode *, LVAL, LVAL, int, int);
LOCAL LVAL getf P3H(LVAL, LVAL, LVAL);
LOCAL int is_member P2H(LVAL, LVAL);
LOCAL int member_eql P2H(LVAL, LVAL);
LOCAL VOID bcloop P1H(int);
LOCAL int any_references_p P2H(LVAL, LVAL);
LOCAL VOID find_references P3H(LVAL, LVAL, LVAL *);
LOCAL LVAL cps_node_internals P1H(int);
LOCAL LVAL set_cps_node_internals P1H(int);
/*#define PROFILE*/
#ifdef PROFILE
LVAL s_profile_output;
#endif /* PROFILE */
/* external variables and functions */
extern LVAL xlenv, xlfenv, xldenv;
extern LVAL k_allow_other_keys, s_strict_keywords;
static LVAL s_leaf, s_call, s_not_supplied;
/* System Constants */ /**** move to xlisp.h */
#define CDEPTH 1000 /**** see if this is big enough */
/*****************************************************************************/
/*****************************************************************************/
/** **/
/** Byte Code Representation, Construction and Modification **/
/** **/
/*****************************************************************************/
/*****************************************************************************/
LVAL xlbcclose(V)
{
LVAL form = xlgabcode();
return(newbcclosure(s_lambda, form));
}
/****** maybe this should copy its closure? */
LVAL xlcoercemacro(V)
{
LVAL fun;
fun = xlgetarg();
xllastarg();
switch (ntype(fun)) {
case CLOSURE: settype(fun, s_macro); break;
case BCCLOSURE: setbcctype(fun, s_macro); break;
default: xlbadtype(fun);
}
return(fun);
}
#define bcode_codevec(fun) ((bytecode *) getstring(getbccode(getbcccode(fun))))
#define bcode_jumptable(fun) getbcjtab(getbcccode(fun))
/*****
#define bcode_literals(fun) getbclits(getbcccode(fun))
*/
#define bcode_index(fun) getfixnum(getbcidx(getbcccode(fun)))
#define bcode_environment(fun) getbcenv(getbcccode(fun))
#define set_bcode_index(fun,fi) setbcidx(getbcccode(fun),cvfixnum((FIXTYPE) fi))
#define set_bcode_environment(fun,env) setbcenv(getbcccode(fun),env)
LVAL xlmakebcode(V)
{
LVAL code, jtab, lits, idx, env, codestr, val, cl;
int i, n, c;
unsigned char *s;
code = xlgetarg();
jtab = (vectorp(code)) ? xlgavector() : xlgetarg();
lits = xlgavector();
idx = xlgafixnum();
env = xlgetarg();
xllastarg();
if (! (null(env) || vectorp(env))) xlbadtype(env);
xlsave1(codestr);
switch (ntype(code)) {
case VECTOR:
n = getsize(code);
codestr = newstring(n);
s = (unsigned char *) getstring(codestr);
for (i = 0; i < n; i++) {
cl = getelement(code,i);
if (! fixp(cl)) xlerror("not a fixnum", cl);
c = getfixnum(cl);
if (c < 0 || c >= 256) xlerror("out of character range", cl);
s[i] = c;
}
s[n] = 0;
break;
case FIXNUM:
/**** modify for handling dynamically loaded modules */
if (xlcurrentmodule < 0 || xlcurrentmodule >= xlnummodules)
xlfail("bad module index");
if (getfixnum(code) < 0
|| getfixnum(code) >= xlmodules[xlcurrentmodule].numfunctions)
xlfail("bad module function index");
codestr = cons(cvfixnum((FIXTYPE) xlcurrentmodule), code);
break;
default:
xlbadtype(code);
}
val = newbcode(codestr, jtab, lits, idx, env);
xlpop();
return(val);
}
LOCAL LVAL copy_bcode P1C(LVAL, fun)
{
LVAL body, old_body, closure;
xlsave1(body);
old_body = getbcccode(fun);
body = newbcode(getbccode(old_body),
getbcjtab(old_body),
getbclits(old_body),
getbcidx(old_body),
getbcenv(old_body));
closure = newbcclosure(s_lambda, body);
xlpop();
return(closure);
}
/*****************************************************************************/
/*****************************************************************************/
/** **/
/** Register, Literals and Value Accessors and Modifiers **/
/** **/
/*****************************************************************************/
/*****************************************************************************/
/**** should be (LVAL *) */
/****
#define getlitval(n) (getelement(literals,n))
*/
/**** put this in bcloop, do same for function passed in register */
/****
#define getlitfun(n, fun) { \
(fun) = getlitval(n); \
while (! fboundp(fun)) xlfunbound(fun); \
(fun) = getfunction(fun); \
}
*/
LVAL *vsbase = NULL;
#define vstop xlsp
/****
#define getregval(i) (vsbase[i])
#define setregval(i,v) (vsbase[i] = (v))
*/
#define set_result_or_regval(i,v) { \
if (i) setregval(i,v); \
else set_one_result(v); \
}
#define push_environment(e) { \
LVAL env = (e); \
if (env != NIL) { \
int n = getsize(env); \
if (xlsp + n > xlargstktop) xlargstkoverflow(); \
MEMCPY(xlsp, &(getelement(env, 0)), sizeof(LVAL) * n); \
xlsp += n; \
} \
}
/*****************************************************************************/
/*****************************************************************************/
/** **/
/** Continuation Stack **/
/** **/
/*****************************************************************************/
/*****************************************************************************/
/* The current byte code is stored in vsbase[-1]. This GC-protects the */
/* code. This should work fine, since the code only changes when vsbase */
/* does. */
#define current_function vsbase[-1]
CONTINUATIONP xlcontinuation_stack, xlcsend;
CONTINUATIONP xlcstop;
#define save_current_continuation(vr) { \
if (xlcstop >= xlcsend) xlabort("continuation stack overflow"); \
xlcstop->base = vsbase; \
xlcstop->top = vstop; \
xlcstop->pe.pc = current_pc; \
xlcstop->vreg = (vr); \
xlcstop++; \
}
#define check_catch_continuation() \
if (xlcstop >= xlcsend) xlabort("continuation stack overflow")
#define save_catch_continuation() xlcstop->pe.pc = current_pc
#define get_catch_continuation() xlcstop->pe.pc
#define set_saved_continuation_pc(npc) (xlcstop[-1].pe.pc = (npc))
/*****
#define DONE NIL
#define NO_VALUE -1
*/
#define restore_continuation(cont) { \
xlcstop = (cont); \
vsbase = xlcstop->base; \
vstop = xlcstop->top; \
current_pc = xlcstop->pe.pc; \
if (xlcstop->vreg != NO_VALUE) setregval(xlcstop->vreg,get_one_result()); \
}
#define do_return(c) { \
LVAL __c__ = (c); \
if (__c__ == DONE) goto done; \
xlcstop = xlcontinuation_stack + getfixnum(__c__); \
vsbase = xlcstop->base; \
vstop = xlcstop->top; \
if (xlcstop->vreg != NO_VALUE) setregval(xlcstop->vreg,get_one_result()); \
if (stringp(getbccode(getbcccode(current_function)))) { \
current_pc = xlcstop->pe.pc; \
} \
else { \
entry = xlcstop->pe.entry; \
goto compiled_continuation; \
} \
}
#define goto_target_pc(n) \
(bcode_codevec(current_function)\
+ getfixnum(getelement(bcode_jumptable(current_function),n)))
#define BCSAMPLE 10 * SAMPLE
static int BCsample = BCSAMPLE;
#define do_goto(n) { \
if (--BCsample < 0) { \
BCsample = BCSAMPLE; \
oscheck(); \
} \
current_pc = goto_target_pc(n); \
}
#define setup_call(fi) do_goto(fi)
#define test_do_goto(t,x,y) if (t) { do_goto(x); } else { do_goto(y); }
#define set_current_function() { \
if (stringp(getbccode(getbcccode(current_function)))) { \
setup_call(bcode_index(current_function)); \
} \
else { \
entry = bcode_index(current_function); \
goto compiled_continuation; \
} \
}
/*****************************************************************************/
/*****************************************************************************/
/** **/
/** PC Definitions and Mutators **/
/** **/
/*****************************************************************************/
/*****************************************************************************/
#define NULL_PC ((bytecode *) 0)
#define next_opcode() (*current_pc++)
#define bit(n) (1L<<(n))
/* adapted from CLISP */
#define get_operand(v) { \
v = next_opcode(); /* read first byte */ \
if (v & bit(7)) { /* bit 7 set? */ \
v &= ~bit(7); /* unset bit 7 */ \
v = v << 8; /* shift by 8 */ \
v |= next_opcode(); /* read next byte */ \
} \
}
/*****************************************************************************/
/*****************************************************************************/
/** **/
/** Available Opcodes **/
/** **/
/*****************************************************************************/
/*****************************************************************************/
enum OPCODES {
COPY,
GOTO,
ARITH2_OP,
ARITH_PRED2_OP,
SET_SVREF_OP,
SVREF_OP,
SET_AREF1,
AREF1,
SET_ELT,
ELT,
SET_ONE_VALUE_OP,
SET_ONE_VALUE_RETURN_OP,
SET_VALUES_OP,
SET_VALUES_RETURN_OP,
SET_VALUES_LIST_OP,
SET_VALUES_LIST_RETURN_OP,
CAR,
CDR,
RPLACA_OP,
RPLACD_OP,
CONS_OP,
TEST1_OP,
SAVE_MVCALL,
SAVE_CALL,
MVCALL,
CALL,
SAVE_MVLCALL,
SAVE_LCALL,
MVLCALL,
LCALL,
SAVE_MVVCALL,
SAVE_VCALL,
MVVCALL,
VCALL,
MAKE_CELL,
CELL_VALUE,
SET_CELL_VALUE,
TEST_ARITH2_OP,
SYMVAL,
SYMFUN,
EQ_OP,
EQL_OP,
EQUAL_OP,
CONSP_OP,
ENDP_OP,
SET_GET_OP,
GET_OP,
SET_NTH_OP,
NTH_OP,
SET_SYMVAL_OP,
TEST2_OP,
MAKE_CLOSURE_OP,
CATCH_BLOCK_OP,
THROW_RETURN_FROM_OP,
CATCH_TAGBODY_OP,
THROW_GO_OP,
UNWIND_PROTECT_OP,
RETURN_OP,
GET_ONE_VALUE_OP,
GET_VALUES_OP,
CASE_OP,
ARITH1_OP,
SLOT_VALUE_OP,
SET_SLOT_VALUE_OP,
SUPPLIED_P_OP,
CATCH_OP,
THROW_OP,
SET_AREF2_OP,
AREF2_OP,
DYNAMIC_BIND_OP,
DYNAMIC_UNBIND_OP,
CXR_OP,
ERRSET_OP,
NTH_VALUE_OP,
MAKE_Y_CLOSURES_OP,
PUSH_VALUES_OP,
POP_VALUES_OP,
INIT_OP,
SET_CAR_OP,
SET_CDR_OP,
INIT_0_OP,
STOP_OP,
SWAP_OP,
LDCONST_OP,
NCASE_OP,
MKCLOS_OP,
SETCLOSDATA_OP,
SETCLOSCODE_OP,
LDNOTSUPP_OP,
LDMVARGS_OP,
NOT_OP,
NEW_BLOCK_OP,
NEW_TAGBODY_OP,
NEW_GO_OP,
NEW_CATCH_OP,
NEW_ERRSET_OP,
NEW_UNWIND_PROTECT_OP,
GET_OPTARG_OP,
MAKE_KEYARGS_OP,
CHECK_LAST_KEYARG_OP,
GET_KEYARG_OP,
NEW_DYNAMIC_BIND_OP,
NEW_DYNAMIC_UNBIND_OP,
STRUCT_OP
};
/*****************************************************************************/
/*****************************************************************************/
/** **/
/** Opcode Support Functions **/
/** **/
/*****************************************************************************/
/*****************************************************************************/
LOCAL bytecode *non_bcode_call P4C(bytecode *, pc, LVAL, fun, int, vi, int, mvals)
{
bytecode *current_pc;
LVAL *newfp, val, *oldbase;
int argc, xi, i;
current_pc = pc;
if (mvals) argc = xlnumresults;
else get_operand(argc);
#ifdef PROFILE
if (subrp(fun)) {
LVAL s = getvalue(s_profile_output);
char *name = funtab[getoffset(fun)].fd_name;
if (s != s_unbound && name != NULL) {
xlputstr(s, name);
xlterpri(s);
}
}
#endif /* PROFILE */
/**** can't use fast subr dispatch with FASTMESS in objects.c */
/**** check MULVALS */
oldbase = vsbase;
if (subrp(fun)) {
LVAL *oldargv, *oldtop;
int oldargc;
oldargc = xlargc;
oldargv = xlargv;
oldtop = vstop;
xlargc = argc;
xlargv = vstop;
if (xlsp + argc > xlargstktop) xlargstkoverflow();
if (mvals)
for (i = 0; i < argc; i++)
*xlsp++ = xlresults[i];
else
for (i = 0; i < argc; i++) {
get_operand(xi);
*xlsp++ = getregval(xi);
}
val = (*getsubr(fun))();
if (! mulvalp(fun)) {
xlnumresults = 1;
xlresults[0] = val;
}
xlargc = oldargc;
xlargv = oldargv;
vstop = oldtop;
}
else {
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE) argc));
if (xlsp + argc > xlargstktop) xlargstkoverflow();
if (mvals)
for (i = 0; i < argc; i++)
*xlsp++ = xlresults[i];
else
for (i = 0; i < argc; i++) {
get_operand(xi);
*xlsp++ = getregval(xi);
}
xlfp = newfp;
/* call the function */
val = xlapply(argc);
}
vsbase = oldbase;
if (vi != NO_VALUE) setregval(vi, val);
return(current_pc);
}
LOCAL bytecode *bccall_setup P5C(bytecode *, pc, LVAL, fun, LVAL, cont, int, tailp, int, mvals)
{
bytecode *current_pc;
int argc, i, xi;
LVAL *base;
current_pc = pc;
if (mvals) argc = xlnumresults;
else get_operand(argc);
base = vsbase;
vsbase = vstop;
pusharg(cont);
if (!null(fun)) push_environment(bcode_environment(fun));
if (xlsp + argc > xlargstktop) xlargstkoverflow();
if (mvals)
for (i = 0; i < argc; i++)
*xlsp++ = xlresults[i];
else
for (i = 0; i < argc; i++) {
get_operand(xi);
*xlsp++ = base[xi];
}
if (tailp && xlcstop[-1].base != base) {
int n = vstop - vsbase;
MEMMOVE(base - 1, vsbase - 1, sizeof(LVAL) * (n + 1));
vstop = base + n;
vsbase = base;
}
return(current_pc);
}
#define case_match_p(x, y) (consp(y) ? member_eql(x, y) : eql(x, y))
/*****************************************************************************/
/*****************************************************************************/
/** **/
/** Local Utility Functions **/
/** **/
/*****************************************************************************/
/*****************************************************************************/
LOCAL LVAL getf P3C(LVAL, list, LVAL, sym, LVAL, dflt)
{
for (; consp(list) && consp(cdr(list)); list = cdr(cdr(list))) {
if (sym == car(list)) return(car(cdr(list)));
}
return(dflt);
}
/**** duplicated from common.c */
LOCAL int is_member P2C(LVAL, x, LVAL, list)
{
int result = FALSE;
for (; ! result && consp(list); list = cdr(list))
if (equal(x, car(list))) result = TRUE;
return(result);
}
/**** used in CASE_OP */
LOCAL int member_eql P2C(LVAL, x, LVAL, y)
{
for (; consp(y); y = cdr(y))
if (eql(x, car(y))) return(TRUE);
return(FALSE);
}
/*****************************************************************************/
/*****************************************************************************/
/** **/
/** The Virtual Machine **/
/** **/
/*****************************************************************************/
/*****************************************************************************/
/*
* The following functions have been moved out of bcloop in order to
* make bcloop easier to compile with optimization. The resulting code is
* maybe a couple of percent slower than it would be with these things
* inlined, but t should compile with a reasonable amount of optimization
* on most systems.
*/
LOCAL bytecode *do_ARITH2_OP P1H(bytecode *);
LOCAL bytecode *do_ARITH_PRED2_OP P1H(bytecode *);
LOCAL bytecode *do_SVREF_OP P2H(bytecode *, int);
LOCAL bytecode *do_AREF1_OP P2H(bytecode *, int);
LOCAL bytecode *do_ELT_OP P2H(bytecode *, int);
LOCAL bytecode *do_GET_OP P2H(bytecode *, int);
LOCAL bytecode *do_NTH_OP P2H(bytecode *, int);
LOCAL bytecode *do_MAKE_CLOSURE_OP P1H(bytecode *);
LOCAL bytecode *do_ARITH1_OP P1H(bytecode *);
LOCAL bytecode *do_AREF2_OP P2H(bytecode *, int);
LOCAL bytecode *do_CXR_OP P1H(bytecode *);
LOCAL bytecode *do_MAKE_Y_CLOSURES_OP P1H(bytecode *);
LOCAL bytecode *do_MKCLOS_OP P1H(bytecode *);
LOCAL bytecode *do_INIT_OP P1H(bytecode *);
LOCAL bytecode *do_ARITH2_OP P1C(bytecode *, current_pc)
{
int which, xi, yi, vi;
LVAL xl, yl, val;
which = next_opcode();
get_operand(xi);
get_operand(yi);
get_operand(vi);
xl = getregval(xi);
yl = getregval(yi);
switch (which) {
case '+': val = xladd2(xl, yl); break;
case '-': val = xlsub2(xl, yl); break;
case '*': val = xlmul2(xl, yl); break;
case '/': val = xldiv2(xl, yl); break;
case 'm': val = xlmin2(xl, yl); break;
case 'M': val = xlmax2(xl, yl); break;
default: val = NIL; /* to keep compiler happy */
}
set_result_or_regval(vi, val);
return(current_pc);
}
LOCAL bytecode *do_ARITH_PRED2_OP P1C(bytecode *, current_pc)
{
int which, xi, yi, vi;
LVAL xl, yl, val;
which = next_opcode();
get_operand(xi);
get_operand(yi);
get_operand(vi);
xl = getregval(xi);
yl = getregval(yi);
switch (which) {
case '<': val = xllss2(xl, yl); break;
case 'L': val = xlleq2(xl, yl); break;
case '=': val = xlequ2(xl, yl); break;
case '#': val = xlneq2(xl, yl); break;
case 'G': val = xlgeq2(xl, yl); break;
case '>': val = xlgtr2(xl, yl); break;
default: val = NIL; /* to keep compiler happy */
}
set_result_or_regval(vi, val);
return(current_pc);
}
LOCAL bytecode *do_SVREF_OP P2C(bytecode *, current_pc, int, set)
{
int ai, ii, vi, ri, i;
LVAL al, il, vl;
get_operand(ai);
al = getregval(ai);
get_operand(ii);
il = getregval(ii);
if (set) {
get_operand(vi);
vl = getregval(vi);
}
get_operand(ri);
if (! vectorp(al)) xlbadtype(al);
if (! fixp(il)) xlbadtype(il);
i = getfixnum(il);
if (i < 0 || i >= getsize(al))
xlerror("index out of range", il);
if (set) {
setelement(al, i, vl);
set_result_or_regval(ri, vl);
}
else
set_result_or_regval(ri, getelement(al, i));
return(current_pc);
}
LOCAL bytecode *do_AREF1_OP P2C(bytecode *, current_pc, int, set)
{
int ai, ii, vi, ri, i;
LVAL al, il, vl;
get_operand(ai);
al = getregval(ai);
get_operand(ii);
il = getregval(ii);
if (set) {
get_operand(vi);
vl = getregval(vi);
}
get_operand(ri);
if (darrayp(al)) al = getdarraydata(al);
switch (ntype(al)) {
case VECTOR:
case STRING:
case TVEC:
if (! fixp(il)) xlbadtype(il);
i = getfixnum(il);
if (i < 0 || i >= gettvecsize(al))
xlerror("index out of range", il);
if (set) {
settvecelement(al, i, vl);
set_result_or_regval(ri, vl);
}
else
set_result_or_regval(ri, gettvecelement(al, i));
break;
default:
xlbadtype(al);
}
return(current_pc);
}
LOCAL bytecode *do_ELT_OP P2C(bytecode *, current_pc, int, set)
{
int ai, ii, vi, ri, i;
LVAL al, il, vl;
get_operand(ai);
al = getregval(ai);
get_operand(ii);
il = getregval(ii);
if (set) {
get_operand(vi);
vl = getregval(vi);
}
get_operand(ri);
if (! fixp(il)) xlbadtype(il);
i = getfixnum(il);
switch (ntype(al)) {
case CONS:
{
for (; i > 0 && consp(al); --i)
al = cdr(al);
if((!consp(al)) || i < 0)
xlerror("index out of range", il);
if (set) {
rplaca(al,vl);
set_result_or_regval(ri, vl);
}
else
set_result_or_regval(ri, car(al));
}
break;
case VECTOR:
case STRING:
case TVEC:
if (i < 0 || i >= gettvecsize(al))
xlerror("index out of range", il);
if (set) {
settvecelement(al, i, vl);
set_result_or_regval(ri, vl);
}
else
set_result_or_regval(ri, gettvecelement(al, i));
break;
default:
xlbadtype(al);
}
return(current_pc);
}
LOCAL bytecode *do_GET_OP P2C(bytecode *, current_pc, int, set)
{
int xi, yi, vi, ri;
LVAL xl, yl, vl;
get_operand(xi);
xl = getregval(xi);
get_operand(yi);
yl = getregval(yi);
if (set) {
get_operand(vi);
vl = getregval(vi);
}
get_operand(ri);
if (! symbolp(xl)) xlbadtype(xl);
if (set) {
xlputprop(xl, vl, yl);
set_result_or_regval(ri, vl);
}
else
set_result_or_regval(ri, xlgetprop(xl, yl));
return(current_pc);
}
LOCAL bytecode *do_NTH_OP P2C(bytecode *, current_pc, int, set)
{
int ni, xi, vi, ri, i;
LVAL nl, xl, vl;
get_operand(ni);
nl = getregval(ni);
get_operand(xi);
xl = getregval(xi);
if (set) {
get_operand(vi);
vl = getregval(vi);
}
get_operand(ri);
if (! fixp(nl)) xlbadtype(nl);
for (i = (int) getfixnum(nl);
i > 0 && consp(xl);
i--, xl = cdr(xl));
if (set) {
if (consp(xl)) rplaca(xl, vl);
}
else
vl = (consp(xl)) ? car(xl) : NIL;
set_result_or_regval(ri, vl);
return(current_pc);
}
LOCAL bytecode *do_MAKE_CLOSURE_OP P1C(bytecode *, current_pc)
{
int fi, ri, n, xi, i;
LVAL env, closure;
xlstkcheck(2);
xlsave(env);
xlsave(closure);
get_operand(fi);
get_operand(ri);
get_operand(n);
env = newvector(n);
for (i = 0; i < n; i++) {
get_operand(xi);
setelement(env, i, getregval(xi));
}
closure = copy_bcode(current_function);
set_bcode_environment(closure, env);
set_bcode_index(closure, fi);
set_result_or_regval(ri, closure);
xlpopn(2);
return(current_pc);
}
LOCAL bytecode *do_ARITH1_OP P1C(bytecode *, current_pc)
{
int which, xi, ri;
LVAL xl, val;
which = next_opcode();
get_operand(xi);
get_operand(ri);
xl = getregval(xi);
switch(which) {
case 'p': val = xladd1(xl); break;
case 'm': val = xlsub1(xl); break;
case '-': val = xlsub2(cvfixnum((FIXTYPE) 0), xl); break;
case '/': val = xldiv2(cvfixnum((FIXTYPE) 1), xl); break;
default: val = NIL; /* to keep compiler happy */
}
set_result_or_regval(ri, val);
return(current_pc);
}
LOCAL bytecode *do_AREF2_OP P2C(bytecode *, current_pc, int, set)
{
int ai, ii, ji, vi, ri, i, j, k;
LVAL al, il, jl, vl, data, dims;
get_operand(ai);
al = getregval(ai);
get_operand(ii);
il = getregval(ii);
get_operand(ji);
jl = getregval(ji);
if (set) {
get_operand(vi);
vl = getregval(vi);
}
get_operand(ri);
if (! darrayp(al)) xlbadtype(al);
if (! fixp(il)) xlbadtype(il);
if (! fixp(jl)) xlbadtype(jl);
i = getfixnum(il);
j = getfixnum(jl);
data = getdarraydata(al);
dims = getdarraydim(al);
if (getsize(dims) != 2) xlbadtype(al);
k = (i * getfixnum(getelement(dims, 1))) + j;
if (k < 0 || k >= gettvecsize(data)) xlfail("index out of range");
if (set) {
settvecelement(data, k, vl);
set_result_or_regval(ri, vl);
}
else
set_result_or_regval(ri, gettvecelement(data, k));
return(current_pc);
}
LOCAL bytecode *do_CXR_OP P1C(bytecode *, current_pc)
{
int xi, vi;
int n, x;
LVAL a;
n = next_opcode();
x = next_opcode();
get_operand(xi);
get_operand(vi);
a = getregval(xi);
for (; n > 0; n--, x >>= 1) {
if (null(a)) break;
else if consp(a)
a = (x & 1) ? car(a) : cdr(a);
else xlbadtype(a);
}
set_result_or_regval(vi,a);
return(current_pc);
}
LOCAL bytecode *do_MAKE_Y_CLOSURES_OP P1C(bytecode *, current_pc)
{
int fi, ri, n, nv, xi, i;
LVAL env, closure;
xlstkcheck(2);
xlsave(env);
xlsave(closure);
get_operand(n);
get_operand(nv);
env = newvector(nv);
for (i = 0; i < n; i++) {
get_operand(fi);
get_operand(ri);
closure = copy_bcode(current_function);
set_bcode_environment(closure, env);
set_bcode_index(closure, fi);
setregval(ri, closure);
}
for (i = 0; i < nv; i++) {
get_operand(xi);
setelement(env, i, getregval(xi));
}
xlpopn(2);
return(current_pc);
}
LOCAL bytecode *do_MKCLOS_OP P1C(bytecode *, current_pc)
{
int ri, n, nv, i;
LVAL env, closure;
xlstkcheck(2);
xlsave(env);
xlsave(closure);
get_operand(nv);
get_operand(n);
env = newvector(nv);
for (i = 0; i < n; i++) {
get_operand(ri);
closure = copy_bcode(current_function);
set_bcode_environment(closure, env);
setregval(ri, closure);
}
xlpopn(2);
return(current_pc);
}
/**** see if this can be cleaned up */
LOCAL bytecode *do_INIT_OP P1C(bytecode *, current_pc)
{
int nc, nr, xi, argc;
LVAL literals = bcode_literals(current_function);
argc = vstop-vsbase;
switch (next_opcode()) {
case 0: /* This case should be handled handled separately by INIT_OP_0 */
{
int nreq;
get_operand(nreq);
if (nreq != argc) {
if (nreq > argc)
xltoofew();
else xltoomany();
}
}
break;
case 1:
{
int nreq, nopt, oi, i;
LVAL odef;
get_operand(nreq);
get_operand(nopt);
get_operand(oi);
odef = getlitval(oi);
if (argc < nreq) xltoofew();
if (nreq + nopt < argc) xltoomany();
for (i = argc - nreq; i < nopt; i++)
pusharg(getelement(odef,i));
}
break;
case 2:
{
int nreq, nopt, nro, oi, i;
LVAL odef, rest_arg, last;
get_operand(nreq);
get_operand(nopt);
nro = nreq + nopt;
if (argc < nreq) xltoofew();
if (nopt != 0) {
get_operand(oi);
odef = getlitval(oi);
for (i = argc - nreq; i < nopt; i++)
pusharg(getelement(odef,i));
}
if (argc > nro) {
xlsave1(rest_arg);
rest_arg = consa(vsbase[nro]);
for (i = nro + 1, last = rest_arg; i < argc; i++) {
rplacd(last, consa(vsbase[i]));
last = cdr(last);
}
xlpop();
}
else rest_arg = NIL;
vstop = vsbase + nro;
pusharg(rest_arg);
}
break;
default:
{
int nreq, nopt, nro, oi, rest, aok, ksi, kdi, i;
LVAL odef, kdef, ksym, rest_arg, last, ks, kd, args, key;
get_operand(nreq);
get_operand(nopt);
nro = nreq + nopt;
if (argc < nreq) xltoofew();
if (nopt != 0) {
get_operand(oi);
odef = getlitval(oi);
for (i = argc - nreq; i < nopt; i++)
pusharg(getelement(odef,i));
}
rest = next_opcode();
aok = next_opcode();
get_operand(ksi);
get_operand(kdi);
ksym = getlitval(ksi);
kdef = getlitval(kdi);
xlsave1(rest_arg);
if (argc > nro) {
rest_arg = consa(vsbase[nro]);
for (i = nro + 1, last = rest_arg; i < argc; i++) {
rplacd(last, consa(vsbase[i]));
last = cdr(last);
}
}
else rest_arg = NIL;
vstop = vsbase + nro;
if (rest) pusharg(rest_arg);
if (!null(getvalue(s_strict_keywords))
&& null(getf(rest_arg,
k_allow_other_keys,
(aok) ? s_true : NIL))) {
for (args = rest_arg; consp(args); args = cdr(cdr(args))) {
if (!consp(cdr(args)))
xlfail("keyword/value args must be even");
key = car(args);
if (! symbolp(key))
xlerror("not a valid keyword", key);
if (! is_member(key, ksym))
xlerror("keyword is not supported", key);
}
}
for (ks = ksym, kd = kdef; consp(ks) && consp(kd);
ks = cdr(ks), kd = cdr(kd))
pusharg(getf(rest_arg, car(ks), car(kd)));
xlpop();
}
break;
}
/* load any constanst used from the literals */
get_operand(nc);
while (nc-- > 0) {
get_operand(xi);
pusharg(getlitval(xi));
}
/* push additional space on top and initialize to nil */
get_operand(nr);
if (xlsp + nr > xlargstktop) xlargstkoverflow();
while (nr-- > 0) *xlsp++ = NIL;
return(current_pc);
}
static LVAL bc_get_keyarg P4C(LVAL, args, LVAL, key, LVAL, dflt, int *, pfound)
{
LVAL last = args;
for (args = cdr(args); consp(args); last = cdr(args), args = cdr(last)) {
if (! consp(cdr(args))) xlfail("keyword value missing");
if (car(args) == key) {
rplacd(last, cdr(cdr(args)));
if (pfound != NULL) *pfound = TRUE;
return car(cdr(args));
}
}
if (pfound != NULL) *pfound = FALSE;
return dflt;
}
/* bcloop - the interpreter main loop */
LOCAL VOID bcloop P1C(int, entry)
{
bytecode *current_pc;
LVAL fun;
int mvals;
#ifdef STSZ /* This function is a good candidate for stack ov */
stchck();
#endif
/**** this must only happen for byte code functions */
if (stringp(getbccode(getbcccode(current_function)))) {
do_goto(entry);
goto byte_code_continuation;
}
else goto compiled_continuation;
/* main loop */
byte_code_continuation:
while (TRUE) {
switch (next_opcode()) {
case COPY:
{
int xi, yi;
get_operand(xi);
get_operand(yi);
set_result_or_regval(yi, getregval(xi));
}
break;
case GOTO:
{
int n;
get_operand(n);
if (--xlsample <= 0) {
xlsample = SAMPLE;
oscheck();
}
do_goto(n);
}
break;
case ARITH2_OP:
current_pc = do_ARITH2_OP(current_pc);
break;
case ARITH_PRED2_OP:
current_pc = do_ARITH_PRED2_OP(current_pc);
break;
case SET_SVREF_OP:
current_pc = do_SVREF_OP(current_pc, TRUE);
break;
case SVREF_OP:
current_pc = do_SVREF_OP(current_pc, FALSE);
break;
case SET_AREF1:
current_pc = do_AREF1_OP(current_pc, TRUE);
break;
case AREF1:
current_pc = do_AREF1_OP(current_pc, FALSE);
break;
case SET_ELT:
current_pc = do_ELT_OP(current_pc, TRUE);
break;
case ELT:
current_pc = do_ELT_OP(current_pc, FALSE);
break;
case SET_ONE_VALUE_OP:
{
int vi;
get_operand(vi);
set_one_result(getregval(vi));
}
break;
case SET_ONE_VALUE_RETURN_OP:
{
int ci, vi;
get_operand(ci);
get_operand(vi);
set_one_result(getregval(vi));
do_return(getregval(ci));
}
break;
case SET_VALUES_OP:
{
int n, i, vi;
get_operand(n);
/***** check ought to be in code generation */
if (n > MULVALLIMIT) xlfail("too many results");
for (i = 0; i < n; i++) {
get_operand(vi);
xlresults[i] = getregval(vi);
}
xlnumresults = n;
}
break;
case SET_VALUES_RETURN_OP:
{
int ci, n, i, vi;
get_operand(ci);
get_operand(n);
/***** check ought to be in code generation */
if (n > MULVALLIMIT) xlfail("too many results");
for (i = 0; i < n; i++) {
get_operand(vi);
xlresults[i] = getregval(vi);
}
xlnumresults = n;
do_return(getregval(ci));
}
break;
case SET_VALUES_LIST_OP:
{
int vi, i;
LVAL v;
get_operand(vi);
for (i = 0, v = getregval(vi); consp(v); i++, v = cdr(v)) {
if (i >= MULVALLIMIT) xlfail("too many results");
xlresults[i] = car(v);
}
xlnumresults = i;
}
break;
case SET_VALUES_LIST_RETURN_OP:
{
int ci, vi, i;
LVAL v;
get_operand(ci);
get_operand(vi);
for (i = 0, v = getregval(vi); consp(v); i++, v = cdr(v)) {
if (i >= MULVALLIMIT) xlfail("too many results");
xlresults[i] = car(v);
}
xlnumresults = i;
do_return(getregval(ci));
}
break;
case CAR:
{
int xi, vi;
LVAL xl;
get_operand(xi);
get_operand(vi);
xl = getregval(xi);
if (! null(xl)) {
if (consp(xl)) xl = car(xl);
else xlbadtype(xl);
}
set_result_or_regval(vi, xl);
}
break;
case CDR:
{
int xi, vi;
LVAL xl;
get_operand(xi);
get_operand(vi);
xl = getregval(xi);
if (! null(xl)) {
if (consp(xl)) xl = cdr(xl);
else xlbadtype(xl);
}
set_result_or_regval(vi, xl);
}
break;
case RPLACA_OP:
{
int xi, vi, ri;
LVAL xl, vl;
get_operand(xi);
get_operand(vi);
get_operand(ri);
xl = getregval(xi);
vl = getregval(vi);
if (! null(xl)) {
if (consp(xl)) rplaca(xl, vl);
else xlbadtype(xl);
}
set_result_or_regval(ri, xl);
}
break;
case RPLACD_OP:
{
int xi, vi, ri;
LVAL xl, vl;
get_operand(xi);
get_operand(vi);
get_operand(ri);
xl = getregval(xi);
vl = getregval(vi);
if (! null(xl)) {
if (consp(xl)) rplacd(xl, vl);
else xlbadtype(xl);
}
set_result_or_regval(ri, xl);
}
break;
case CONS_OP:
{
int xi, yi, vi;
get_operand(xi);
get_operand(yi);
get_operand(vi);
set_result_or_regval(vi,cons(getregval(xi),getregval(yi)));
}
break;
case TEST1_OP:
{
int which, xi, yi, vi;
int tval = FALSE; /* initialized to keep compiler happy */
LVAL v;
which = next_opcode();
get_operand(xi);
get_operand(yi);
get_operand(vi);
v = getregval(vi);
switch (which) {
case 0: tval = (v != NIL) ? TRUE : FALSE; break;
case 1: tval = consp(v); break;
case 2: tval = (v != s_not_supplied) ? TRUE : FALSE; break;
case 3:
if (consp(v)) tval = FALSE;
else if (null(v)) tval = TRUE;
else xlbadtype(v);
break;
}
test_do_goto(tval, xi, yi);
}
break;
/*
* Function call opcodes use a fair number of goto's in order to
* maximize code reuse. It isn't pretty, but it keeps things small
* and prevents small variations from kreeping in.
*/
case SAVE_MVCALL:
mvals = TRUE;
goto save_call;
case SAVE_CALL:
mvals = FALSE;
save_call:
{
int fi;
LVAL literals = bcode_literals(current_function);
get_operand(fi);
fun = getlitval(fi);
if (symbolp(fun)) {
while (! fboundp(fun)) xlfunbound(fun);
fun = getfunction(fun);
}
}
save_call_body:
{
int vi;
LVAL cont;
get_operand(vi);
if (vi == 0) vi = NO_VALUE;
if (bcclosurep(fun)) {
cont = cvfixnum((FIXTYPE) (xlcstop - xlcontinuation_stack));
save_current_continuation(vi);
pusharg(fun);
current_pc = bccall_setup(current_pc, fun, cont, FALSE, mvals);
set_saved_continuation_pc(current_pc);
set_current_function();
}
else current_pc = non_bcode_call(current_pc, fun, vi, mvals);
}
break;
case MVCALL:
mvals = TRUE;
goto call;
case CALL:
mvals = FALSE;
call:
{
int fi;
LVAL literals = bcode_literals(current_function);
get_operand(fi);
fun = getlitval(fi);
if (symbolp(fun)) {
while (! fboundp(fun)) xlfunbound(fun);
fun = getfunction(fun);
}
}
call_body:
{
int ci;
LVAL cont;
get_operand(ci);
cont = getregval(ci);
if (bcclosurep(fun)) {
pusharg(fun);
current_pc = bccall_setup(current_pc, fun, cont, TRUE, mvals);
set_current_function();
}
else {
current_pc = non_bcode_call(current_pc, fun, NO_VALUE, mvals);
do_return(cont);
}
}
break;
case SAVE_MVLCALL:
mvals = TRUE;
goto save_lcall;
case SAVE_LCALL:
mvals = FALSE;
save_lcall:
{
int fi, vi;
LVAL cont;
get_operand(fi);
cont = cvfixnum((FIXTYPE) (xlcstop - xlcontinuation_stack));
get_operand(vi);
if (vi == 0) vi = NO_VALUE;
save_current_continuation(vi);
pusharg(current_function);
current_pc = bccall_setup(current_pc, NIL, cont, FALSE, mvals);
set_saved_continuation_pc(current_pc);
setup_call(fi);
}
break;
case MVLCALL:
mvals = TRUE;
goto lcall;
case LCALL:
mvals = FALSE;
lcall:
{
int fi, ci;
LVAL cont;
get_operand(fi);
get_operand(ci);
cont = getregval(ci);
pusharg(current_function);
current_pc = bccall_setup(current_pc, NIL, cont, TRUE, mvals);
setup_call(fi);
}
break;
case SAVE_MVVCALL:
mvals = TRUE;
goto save_vcall;
case SAVE_VCALL:
mvals = FALSE;
save_vcall:
{
int fi;
get_operand(fi);
fun = getregval(fi);
if (symbolp(fun)) {
while (! fboundp(fun)) xlfunbound(fun);
fun = getfunction(fun);
}
}
goto save_call_body;
case MVVCALL:
mvals = TRUE;
goto vcall;
case VCALL:
mvals = FALSE;
vcall:
{
int fi;
get_operand(fi);
fun = getregval(fi);
if (symbolp(fun)) {
while (! fboundp(fun)) xlfunbound(fun);
fun = getfunction(fun);
}
}
goto call_body;
case MAKE_CELL:
{
int vi, ci;
get_operand(vi);
get_operand(ci);
set_result_or_regval(ci, consa(getregval(vi)));
}
break;
case CELL_VALUE:
{
int ci, vi;
get_operand(ci);
get_operand(vi);
set_result_or_regval(vi, car(getregval(ci))); /**** NO error checking***/
}
break;
case SET_CELL_VALUE:
{
int ci, vi, ri;
LVAL cl, vl;
get_operand(ci);
get_operand(vi);
get_operand(ri);
cl = getregval(ci);
vl = getregval(vi);
rplaca(cl, vl); /**** NO error checking***/
set_result_or_regval(ri, vl);
}
break;
case TEST_ARITH2_OP:
{
int which, xi, yi, ui, vi;
LVAL ul, vl;
which = next_opcode();
get_operand(xi);
get_operand(yi);
get_operand(ui);
get_operand(vi);
ul = getregval(ui);
vl = getregval(vi);
test_do_goto(num_cmp2(which, ul, vl), xi, yi);
}
break;
case SYMVAL:
{
int si, vi;
LVAL sl;
LVAL literals = bcode_literals(current_function);
get_operand(si);
get_operand(vi);
sl = getlitval(si);
if (! symbolp(sl)) xlbadtype(sl);
#ifdef XLISP_STAT
if (! boundp(sl)) xlunbound(sl);
set_result_or_regval(vi, getvalue(sl));
#else
{
LVAL pair, val;
pair = getvalue(s_self);
if (! (consp(pair) &&
objectp(car(pair)) &&
xlobgetvalue(pair,sl,&val))) {
if (! boundp(sl)) xlunbound(sl);
val = getvalue(sl);
}
set_result_or_regval(vi, val);
}
#endif /* XLISP_STAT */
}
break;
case SYMFUN:
{
int si, vi;
LVAL sl;
LVAL literals = bcode_literals(current_function);
get_operand(si);
get_operand(vi);
sl = getlitval(si);
if (! symbolp(sl)) xlbadtype(sl);
while (! fboundp(sl)) xlfunbound(sl);
set_result_or_regval(vi, getfunction(sl));
}
break;
case EQ_OP:
{
int xi, yi, vi;
LVAL val;
get_operand(xi);
get_operand(yi);
get_operand(vi);
val = (getregval(xi) == getregval(yi)) ? s_true : NIL;
set_result_or_regval(vi, val);
}
break;
case EQL_OP:
{
int xi, yi, vi;
LVAL val;
get_operand(xi);
get_operand(yi);
get_operand(vi);
val = eql(getregval(xi), getregval(yi)) ? s_true : NIL;
set_result_or_regval(vi, val);
}
break;
case EQUAL_OP:
{
int xi, yi, vi;
LVAL val;
get_operand(xi);
get_operand(yi);
get_operand(vi);
val = equal(getregval(xi), getregval(yi)) ? s_true : NIL;
set_result_or_regval(vi, val);
}
break;
case CONSP_OP:
{
int xi, vi;
get_operand(xi);
get_operand(vi);
set_result_or_regval(vi, (consp(getregval(xi))) ? s_true : NIL);
}
break;
case ENDP_OP:
{
int xi, vi;
LVAL xl, val = NIL;
get_operand(xi);
get_operand(vi);
xl = getregval(xi);
if (null(xl)) val = s_true;
else if (! consp(xl)) xlbadtype(xl);
set_result_or_regval(vi, val);
}
break;
case SET_GET_OP:
current_pc = do_GET_OP(current_pc, TRUE);
break;
case GET_OP:
current_pc = do_GET_OP(current_pc, FALSE);
break;
case SET_NTH_OP:
current_pc = do_NTH_OP(current_pc, TRUE);
break;
case NTH_OP:
current_pc = do_NTH_OP(current_pc, FALSE);
break;
case SET_SYMVAL_OP:
{
int si, vi, ri;
LVAL sl, vl;
LVAL literals = bcode_literals(current_function);
get_operand(si);
get_operand(vi);
get_operand(ri);
sl = getlitval(si);
vl = getregval(vi);
if (! symbolp(sl)) xlbadtype(sl);
#ifdef XLISP_STAT
setvalue(sl, vl);
#else
{
LVAL pair;
pair = getvalue(s_self);
if (! (consp(pair) &&
objectp(car(pair)) &&
xlobsetvalue(pair,sl,vl)))
setvalue(sl, vl);
}
#endif /* XLISP_STAT */
set_result_or_regval(ri, vl);
}
break;
case TEST2_OP:
{
int which, xi, yi, ui, vi;
int tval = FALSE; /* initialized to keep compiler happy */
LVAL u, v;
which = next_opcode();
get_operand(xi);
get_operand(yi);
get_operand(ui);
get_operand(vi);
u = getregval(ui);
v = getregval(vi);
switch (which) {
case 0: tval = (u == v) ? TRUE : FALSE; break;
case 1: tval = eql(u, v); break;
case 2: tval = equal(u, v); break;
}
test_do_goto(tval, xi, yi);
}
break;
case MAKE_CLOSURE_OP:
current_pc = do_MAKE_CLOSURE_OP(current_pc);
break;
case CATCH_BLOCK_OP:
{
int ni, li, ci, ti, sts;
LVAL tag;
CONTEXT cntxt;
CONTINUATIONP old_cstop = xlcstop;
struct { int li; bytecode *cpc; } state;
get_operand(ni);
get_operand(li);
get_operand(ci);
get_operand(ti);
xlsave1(tag);
tag = consa(getregval(ni));
setregval(ci, DONE);
setregval(ti, tag);
save_current_continuation(NO_VALUE);
xlbegin(&cntxt, CF_THROW, tag);
state.li = li; state.cpc = current_pc;
sts = XL_SETJMP(cntxt.c_jmpbuf);
li = state.li; current_pc = state.cpc;
if (! sts)
bcloop(li);
restore_continuation(old_cstop);
xlend(&cntxt);
xlpop();
}
break;
case THROW_RETURN_FROM_OP:
{
int ri;
get_operand(ri);
xlthrow(getregval(ri), NIL);
}
break;
case CATCH_TAGBODY_OP:
{
int li, ci, ti, ri, sts;
LVAL tag;
CONTEXT cntxt;
CONTINUATIONP old_cstop = xlcstop;
struct { int li, ci, ti; bytecode *cpc; } state;
get_operand(li);
get_operand(ci);
get_operand(ti);
get_operand(ri);
xlsave1(tag);
tag = consa(NIL);
xlbegin(&cntxt, CF_THROW, tag);
/* check for a go */
state.li = li; state.ci = ci; state.ti = ti; state.cpc = current_pc;
sts = XL_SETJMP(cntxt.c_jmpbuf);
li = state.li; ci = state.ci; ti = state.ti; current_pc = state.cpc;
if (sts) {
restore_continuation(old_cstop);
if (fixp(xlvalue)) li = getfixnum(xlvalue);
else xlerror("bad go target", xlvalue);
}
setregval(ci, DONE);
setregval(ti, tag);
save_current_continuation(NO_VALUE);
bcloop(li);
restore_continuation(old_cstop);
xlend(&cntxt);
xlpop();
}
break;
case THROW_GO_OP:
{
int ri, li;
LVAL ll;
get_operand(ri);
get_operand(li);
ll = cvfixnum((FIXTYPE) li);
pusharg(ll); /* protect from GC */
xlthrow(getregval(ri), ll);
}
break;
case UNWIND_PROTECT_OP:
/***** ought to save values on stack, not cons them */
/**** state.val need to be protected? */
/**** is the value really needed? */
{
int l1i, l2i, pi, ui, sts;
CONTINUATIONP old_cstop = xlcstop;
CONTEXT cntxt;
struct {
CONTEXT *target;
int mask, l1i, l2i, ui;
LVAL val;
bytecode *cpc;
} state;
get_operand(l1i);
get_operand(l2i);
get_operand(pi);
get_operand(ui);
setregval(pi, DONE);
save_current_continuation(NO_VALUE);
xlbegin(&cntxt,CF_UNWIND,NIL);
state.l1i = l1i; state.l2i = l2i; state.ui = ui;
state.cpc = current_pc;
sts = XL_SETJMP(cntxt.c_jmpbuf);
l1i = state.l1i; l2i = state.l2i; ui = state.ui;
current_pc = state.cpc;
if (sts) {
state.target = xltarget;
state.mask = xlmask;
state.val = xlvalue;
}
else
bcloop(l1i);
xlend(&cntxt);
{
LVAL val;
int nvals, i;
restore_continuation(old_cstop);
setregval(ui, DONE);
save_current_continuation(NO_VALUE);
nvals = xlnumresults;
for (i = 0; i < nvals; i++) {
val = get_nth_result(i);
pusharg(val);
}
bcloop(l2i);
restore_continuation(old_cstop);
for (i = 0; i < nvals; i++)
set_nth_result(i, vstop[i]);
xlnumresults = nvals;
}
if (sts)
xljump(state.target,state.mask,state.val);
}
break;
case RETURN_OP:
{
int ci;
get_operand(ci);
do_return(getregval(ci));
}
break;
case GET_ONE_VALUE_OP:
{
int ri;
get_operand(ri);
setregval(ri, get_one_result());
}
break;
case GET_VALUES_OP:
{
int n, ri, i;
get_operand(n);
for (i = 0; i < n; i++) {
get_operand(ri);
setregval(ri, get_nth_result(i));
}
}
break;
case CASE_OP:
{
int ci, chi, li, i, n;
LVAL cl, chl, cs;
get_operand(ci);
get_operand(chi);
cl = getregval(ci);
chl = getregval(chi);
n = getsize(chl);
li = 0; /* to keep compiler happy */
for (i = 0; i < n; i++) {
get_operand(li);
cs = getelement(chl, i);
if (case_match_p(cl, cs)) break;
}
if (i == n) get_operand(li);
do_goto(li);
}
break;
case ARITH1_OP:
current_pc = do_ARITH1_OP(current_pc);
break;
case SLOT_VALUE_OP:
{
int xi, ri;
LVAL xl, self;
get_operand(xi);
get_operand(ri);
xl = getregval(xi);
self = getvalue(s_self);
set_result_or_regval(ri, slot_value(self, xl));
}
break;
case SET_SLOT_VALUE_OP:
{
int xi, vi, ri;
LVAL xl, vl, self;
get_operand(xi);
get_operand(vi);
get_operand(ri);
xl = getregval(xi);
vl = getregval(vi);
self = getvalue(s_self);
set_slot_value(self, xl, vl);
set_result_or_regval(ri, vl);
}
break;
case SUPPLIED_P_OP:
{
int xi, vi;
get_operand(xi);
get_operand(vi);
set_result_or_regval(vi, (getregval(xi) != s_not_supplied) ? s_true : NIL);
}
break;
case CATCH_OP:
{
int ti, li, ci, sts;
LVAL tag;
CONTEXT cntxt;
CONTINUATIONP old_cstop = xlcstop;
struct { int li; bytecode *cpc; } state;
get_operand(ti);
get_operand(li);
get_operand(ci);
tag = getregval(ti);
setregval(ci, DONE);
save_current_continuation(NO_VALUE);
xlbegin(&cntxt, CF_THROW, tag);
state.li = li; state.cpc = current_pc;
sts = XL_SETJMP(cntxt.c_jmpbuf);
li = state.li; current_pc = state.cpc;
if (! sts)
bcloop(li);
restore_continuation(old_cstop);
xlend(&cntxt);
}
break;
case THROW_OP:
{
int ti;
get_operand(ti);
xlthrow(getregval(ti), get_one_result());
}
break;
case SET_AREF2_OP:
current_pc = do_AREF2_OP(current_pc, TRUE);
break;
case AREF2_OP:
current_pc = do_AREF2_OP(current_pc, FALSE);
break;
case DYNAMIC_BIND_OP:
{
int si, vi;
LVAL nexts, nextv;
get_operand(si);
get_operand(vi);
pusharg(xldenv);
if (getregval(vi) == s_true) {
for (nexts = getregval(si); consp(nexts); nexts = cdr(nexts))
xldbind(car(nexts), getvalue(car(nexts)));
}
else {
for (nexts = getregval(si), nextv = getregval(vi);
consp(nexts) && consp(nextv);
nexts = cdr(nexts), nextv = cdr(nextv))
xldbind(car(nexts), car(nextv));
for (; consp(nexts); nexts = cdr(nexts))
xldbind(car(nexts), s_unbound);
}
}
break;
case DYNAMIC_UNBIND_OP:
{
LVAL olddenv = *--vstop;
xlunbind(olddenv);
}
break;
case CXR_OP:
current_pc = do_CXR_OP(current_pc);
break;
case ERRSET_OP:
{
int li, ci, fi, sts;
LVAL flag, val;
CONTEXT cntxt;
CONTINUATIONP old_cstop = xlcstop;
struct { int li; bytecode *cpc; } state;
get_operand(li);
get_operand(ci);
get_operand(fi);
flag = getregval(fi);
setregval(ci, DONE);
save_current_continuation(NO_VALUE);
xlbegin(&cntxt, CF_ERROR, flag);
state.li = li; state.cpc = current_pc;
sts = XL_SETJMP(cntxt.c_jmpbuf);
li = state.li; current_pc = state.cpc;
if (sts) {
set_one_result(NIL);
}
else {
bcloop(li);
val = get_one_result(); /* has to be done before set */
set_one_result(consa(val));
}
restore_continuation(old_cstop);
xlend(&cntxt);
}
break;
case NTH_VALUE_OP:
{
int ni, vi, n;
LVAL nl, vl;
get_operand(ni);
get_operand(vi);
nl = getregval(ni);
if (! fixp(nl)) xlbadtype(nl);
n = getfixnum(nl);
vl = (n < 0) ? NIL : get_nth_result(n);
set_result_or_regval(vi,vl);
}
break;
case MAKE_Y_CLOSURES_OP:
current_pc = do_MAKE_Y_CLOSURES_OP(current_pc);
break;
case PUSH_VALUES_OP:
{
int i, vr;
LVAL nl;
get_operand(vr);
nl = cvfixnum((FIXTYPE) xlnumresults);
setregval(vr, nl);
for (i = 0; i < xlnumresults; i++)
pusharg(xlresults[i]);
}
break;
case POP_VALUES_OP:
{
int i, ni, n;
LVAL nl;
get_operand(ni);
nl = getregval(ni);
n = getfixnum(nl);
vstop -= n;
for (i = 0; i < n; i++)
xlresults[i] = vstop[i];
xlnumresults = n;
}
break;
case INIT_OP:
current_pc = do_INIT_OP(current_pc);
break;
case SET_CAR_OP:
{
int xi, vi, ri;
LVAL xl, vl;
get_operand(xi);
get_operand(vi);
get_operand(ri);
xl = getregval(xi);
vl = getregval(vi);
if (! null(xl)) {
if (consp(xl)) rplaca(xl, vl);
else xlbadtype(xl);
}
set_result_or_regval(ri, vl);
}
break;
case SET_CDR_OP:
{
int xi, vi, ri;
LVAL xl, vl;
get_operand(xi);
get_operand(vi);
get_operand(ri);
xl = getregval(xi);
vl = getregval(vi);
if (! null(xl)) {
if (consp(xl)) rplacd(xl, vl);
else xlbadtype(xl);
}
set_result_or_regval(ri, vl);
}
break;
case INIT_0_OP:
{
int nc, nr, xi, argc, nreq;
LVAL literals = bcode_literals(current_function);
argc = vstop - vsbase;
get_operand(nreq);
if (nreq != argc) {
if (nreq > argc)
xltoofew();
else
xltoomany();
}
/* load any constanst used from the literals */
get_operand(nc);
while (nc-- > 0) {
get_operand(xi);
pusharg(getlitval(xi));
}
/* push additional space on top and initialize to nil */
get_operand(nr);
if (xlsp + nr > xlargstktop) xlargstkoverflow();
while (nr-- > 0) *xlsp++ = NIL;
}
break;
case STOP_OP:
goto done;
break;
case SWAP_OP:
{
int xi, yi;
LVAL tmp;
get_operand(xi);
get_operand(yi);
tmp = getregval(yi);
setregval(yi, getregval(xi));
setregval(xi, tmp);
}
break;
case LDCONST_OP:
{
int xi, yi;
LVAL literals = bcode_literals(current_function);
get_operand(xi);
get_operand(yi);
setregval(yi, getlitval(xi));
}
break;
case NCASE_OP:
{
int ci, chi, li, i, n;
LVAL cl, chl, cs;
LVAL literals = bcode_literals(current_function);
get_operand(ci);
get_operand(chi);
cl = getregval(ci);
chl = getlitval(chi);
n = getsize(chl);
li = 0; /* to keep compiler happy */
for (i = 0; i < n; i++) {
get_operand(li);
cs = getelement(chl, i);
if (case_match_p(cl, cs)) break;
}
if (i == n) get_operand(li);
do_goto(li);
}
break;
case MKCLOS_OP:
current_pc = do_MKCLOS_OP(current_pc);
break;
case SETCLOSDATA_OP:
{
int ci, nv, xi, i;
LVAL env;
get_operand(ci);
env = bcode_environment(getregval(ci));
get_operand(nv); /**** could check against size of env */
for (i = 0; i < nv; i++) {
get_operand(xi);
setelement(env, i, getregval(xi));
}
break;
}
case SETCLOSCODE_OP:
{
int ci, fi, li;
LVAL closure;
LVAL literals = bcode_literals(current_function);
get_operand(ci);
get_operand(fi);
get_operand(li);
closure = getregval(ci);
set_bcode_index(closure, fi);
setbcname(getbcccode(closure), getlitval(li));
break;
}
case LDNOTSUPP_OP:
{
int vi;
get_operand(vi);
setregval(vi, s_not_supplied);
break;
}
case LDMVARGS_OP:
{
int nreq, nopt, restp, fi, vi, nro, i;
/*LVAL literals = bcode_literals(current_function);*/
get_operand(nreq);
get_operand(nopt);
get_operand(restp);
get_operand(fi);/***** currently ignored -- use for error messages */
nro = nreq + nopt;
if (nreq > xlnumresults) xltoofew();
if (! restp && xlnumresults > nro) xltoomany();
for (i = 0; i < nro && i < xlnumresults; i++) {
get_operand(vi);
setregval(vi, xlresults[i]);
}
for (i = xlnumresults; i < nro; i++) {
get_operand(vi);
setregval(vi, s_not_supplied);
}
if (restp) {
get_operand(vi);
setregval(vi, NIL);
for (i = nro; i < xlnumresults; i++)
setregval(vi, cons(xlresults[i], getregval(vi)));
setregval(vi, xlnreverse(getregval(vi)));
}
break;
}
case NOT_OP:
{
int ai, vi;
get_operand(ai);
get_operand(vi);
setregval(vi, null(getregval(ai)) ? s_true: NIL);
break;
}
case NEW_BLOCK_OP:
{
volatile int ci;
LVAL * volatile oldbase = vsbase;
LVAL tag;
int bi;
CONTEXT cntxt;
get_operand(bi);
get_operand(ci);
xlsave1(tag);
tag = consa(NIL);
xlbegin(&cntxt, CF_THROW, tag);
if (! XL_SETJMP(cntxt.c_jmpbuf))
xlapp1(getregval(bi), tag); /**** inefficient but easy */
/* vsbase needs to be restored in jumps. xlcstop is handled in
the standard jump code, as is vstop = xlsp */
vsbase = oldbase;
do_goto(ci);
xlend(&cntxt);
xlpop();
break;
}
case NEW_TAGBODY_OP:
{
volatile int ci;
LVAL * volatile oldbase = vsbase;
LVAL tag;
int bi;
CONTEXT cntxt;
get_operand(bi);
get_operand(ci);
xlsave1(tag);
tag = consa(NIL);
xlbegin(&cntxt, CF_THROW, tag);
if (XL_SETJMP(cntxt.c_jmpbuf)) {
BC_evfun(xlvalue, 0, xlsp);
/* vsbase needs to be restored in jumps. xlcstop is handled in
the standard jump code, as is vstop = xlsp */
vsbase = oldbase;
}
else {
LVAL *oldsp = xlsp;
pusharg(tag);
BC_evfun(getregval(bi), 1, oldsp);
xlsp = oldsp;
}
do_goto(ci);
xlend(&cntxt);
xlpop();
break;
}
case NEW_GO_OP:
{
int ri, li;
get_operand(ri);
get_operand(li);
xlthrow(getregval(ri), getregval(li));
break; /* not reached */
}
case NEW_CATCH_OP:
{
volatile int ci;
LVAL * volatile oldbase = vsbase;
int ti, bi;
CONTEXT cntxt;
get_operand(ti);
get_operand(bi);
get_operand(ci);
xlbegin(&cntxt, CF_THROW, getregval(ti));
if (! XL_SETJMP(cntxt.c_jmpbuf))
BC_evfun(getregval(bi), 0, xlsp);
/* vsbase needs to be restored in jumps. xlcstop is handled in
the standard jump code, as is vstop = xlsp */
vsbase = oldbase;
do_goto(ci);
xlend(&cntxt);
break;
}
case NEW_ERRSET_OP:
{
volatile int ci;
LVAL * volatile oldbase = vsbase;
int bi, fi;
CONTEXT cntxt;
get_operand(bi);
get_operand(fi);
get_operand(ci);
xlbegin(&cntxt, CF_ERROR, getregval(fi));
if (XL_SETJMP(cntxt.c_jmpbuf)) {
set_one_result(NIL);
/* vsbase needs to be restored in jumps. xlcstop is handled in
the standard jump code, as is vstop = xlsp */
vsbase = oldbase;
}
else {
LVAL val;
BC_evfun(getregval(bi), 0, xlsp);
val = get_one_result(); /* has to be done before set */
set_one_result(consa(val));
}
do_goto(ci);
xlend(&cntxt);
break;
}
case NEW_UNWIND_PROTECT_OP:
{
volatile int ci, pi;
LVAL * volatile oldbase = vsbase;
int bi, sts = FALSE, nvals, i, mask;
CONTEXT cntxt, *target;
LVAL val;
get_operand(bi);
get_operand(pi);
get_operand(ci);
xlbegin(&cntxt,CF_UNWIND,NIL);
if (XL_SETJMP(cntxt.c_jmpbuf)) {
sts = TRUE;
target = xltarget;
mask = xlmask;
val = xlvalue;
/* vsbase needs to be restored in jumps. xlcstop is handled in
the standard jump code, as is vstop = xlsp */
vsbase = oldbase;
}
else {
BC_evfun(getregval(bi), 0, xlsp);
nvals = xlnumresults;
for (i = 0; i < nvals; i++) {
val = get_nth_result(i);
pusharg(val);
}
}
xlend(&cntxt);
BC_evfun(getregval(pi), 0, xlsp);
if (sts)
xljump(target, mask, val);
else {
vstop -= nvals;
for (i = 0; i < nvals; i++)
set_nth_result(i, vstop[i]);
xlnumresults = nvals;
do_goto(ci);
}
break;
}
case GET_OPTARG_OP:
{
int ai, di, vi, si;
LVAL val;
get_operand(ai);
get_operand(di);
get_operand(vi);
get_operand(si);
val = getregval(ai);
if (val == s_not_supplied) {
LVAL literals = bcode_literals(current_function);
setregval(vi, getlitval(di));
setregval(si, NIL);
}
else {
setregval(vi, val);
setregval(si, s_true);
}
break;
}
case MAKE_KEYARGS_OP:
{
int ai, vi;
get_operand(ai);
get_operand(vi);
setregval(vi, consd(copylist(getregval(ai))));
break;
}
case CHECK_LAST_KEYARG_OP:
{
int ai, others;
LVAL keys;
get_operand(ai);
get_operand(others);
keys = getregval(ai);
if (llength(cdr(keys)) % 2)
xlfail("missing keyword value");
if (! null(cdr(keys)) &&
! others &&
null(bc_get_keyarg(keys, k_allow_other_keys, NIL, NULL)) &&
! null(getvalue(s_strict_keywords)))
xlfail("too many keyword arguments");
break;
}
case GET_KEYARG_OP:
{
int ai, ki, di, vi, si, found;
LVAL literals = bcode_literals(current_function);
LVAL val;
get_operand(ai);
get_operand(ki);
get_operand(di);
get_operand(vi);
get_operand(si);
val = bc_get_keyarg(getregval(ai), getlitval(ki), getlitval(di),
&found);
setregval(vi, val);
setregval(si, found ? s_true : NIL);
break;
}
case NEW_DYNAMIC_BIND_OP:
{
int si, vi, ei;
LVAL nexts, nextv, olddenv = xldenv;
get_operand(si);
get_operand(vi);
get_operand(ei);
/**** For the moment, the old xldenv value is passed both in a
register and on the stack -- this is to help with
debugging. Eventually it will just be passed in a
register */
pusharg(xldenv);
if (getregval(vi) == s_true) {
for (nexts = getregval(si); consp(nexts); nexts = cdr(nexts))
xldbind(car(nexts), getvalue(car(nexts)));
}
else {
for (nexts = getregval(si), nextv = getregval(vi);
consp(nexts) && consp(nextv);
nexts = cdr(nexts), nextv = cdr(nextv))
xldbind(car(nexts), car(nextv));
for (; consp(nexts); nexts = cdr(nexts))
xldbind(car(nexts), s_unbound);
}
setregval(ei, olddenv);
break;
}
case NEW_DYNAMIC_UNBIND_OP:
{
/**** For the moment, the old xldenv value is passed both in a
register and on the stack -- this is to help with
debugging. Eventually it will just be passed on the
stack */
LVAL olddenv = *--vstop;
int ei;
get_operand(ei);
if (getregval(ei) != olddenv)
stdputstr("bad stack in unbind\n");
xlunbind(olddenv);
break;
}
case STRUCT_OP:
{
int si;
LVAL str;
get_operand(si);
str = getregval(si);
switch (next_opcode()) {
case 0:
{
int i, vi;
get_operand(i);
get_operand(vi);
if (! structp(str)) xlbadtype(str);
if (i >= getsize(str)) xlerror("bad structure reference",str);
setregval(vi, getelement(str,i));
break;
}
case 1:
{
int i, ni, vi;
LVAL val;
get_operand(i);
get_operand(ni);
get_operand(vi);
if (! structp(str)) xlbadtype(str);
if (i >= getsize(str)) xlerror("bad structure reference",str);
val = getregval(ni);
setelement(str, i, val);
setregval(vi, val);
break;
}
case 2:
{
int ti, vi, val = FALSE;
LVAL literals = bcode_literals(current_function);
LVAL type;
get_operand(ti);
get_operand(vi);
type = getlitval(ti);
if (structp(str)) {
for (str = getelement(str,0);
! null(str);
str = xlgetprop(str,s_strinclude))
if (str == type) {
val = TRUE;
break;
}
}
setregval(vi, val ? s_true : NIL);
break;
}
default: xlfail("unknown opcode");
}
break;
}
default: xlfail("unknown opcode");
}
}
compiled_continuation:
{
LVAL code = getbccode(getbcccode(current_function));
int i = (int) getfixnum(car(code));
int j = (int) getfixnum(cdr(code));
(*xlmodules[i].functions[j])(entry);
if (null(current_function)) goto done;
else if (stringp(getbccode(getbcccode(current_function)))) {
current_pc = xlcstop->pe.pc;
goto byte_code_continuation;
}
else {
entry = xlcstop->pe.entry;
goto compiled_continuation;
}
}
done:
return;
}
LVAL BC_evfun P3C(LVAL, fun, int, argc, LVAL *, argv)
{
CONTINUATIONP old_cstop = xlcstop;
LVAL *old_vsbase = vsbase, *old_vstop = vstop;
LVAL val;
bytecode *current_pc;
vsbase = argv; /**** for testing new frame handling */
current_pc = NULL_PC;
save_current_continuation(NO_VALUE); /***** replace */
pusharg(fun);
vsbase = vstop;
pusharg(DONE);
push_environment(bcode_environment(fun));
/* shift up the arguments */
if (xlsp + argc > xlargstktop) xlargstkoverflow();
MEMCPY(xlsp, argv, sizeof(LVAL) * argc);
xlsp += argc;
bcloop(bcode_index(fun));
val = get_one_result();
xlcstop = old_cstop;
vsbase = old_vsbase;
vstop = old_vstop;
return(val);
}
LVAL BC_evform P1C(LVAL, form)
{
LVAL fun, val, *argv;
int argc;
xlsave1(fun);
fun = newbcclosure(s_lambda, form);
argc = pushargs(fun,NIL);
argv = xlfp + 3;
val = BC_evfun(fun,argc,argv);
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
xlpop();
return(val);
}
VOID bcsymbols(V)
{
s_not_supplied = xlenter("%NOT-SUPPLIED");
s_leaf = xlenter("LEAF");
s_call = xlenter("CALL");
#ifdef PROFILE
s_profile_output = xlenter("*PROFILE-OUTPUT*");
#endif /* PROFILE */
}
VOID init_bytecode(V)
{
xlcontinuation_stack = (CONTINUATIONP) malloc(CDEPTH * sizeof(CONTINUATION));
if (xlcontinuation_stack == NULL)
xlfatal("insufficient memory");
xlcsend = xlcontinuation_stack + CDEPTH;
xlcstop = xlcontinuation_stack;
init_modules();
}
/*****************************************************************************/
/*****************************************************************************/
/** **/
/** Internal CPS Node Representation **/
/** **/
/*****************************************************************************/
/*****************************************************************************/
#define leaf_node_p(n) (cpsnodep(n) && (getcpstype(n) == s_leaf))
#define lambda_node_p(n) (cpsnodep(n) && (getcpstype(n) == s_lambda))
#define call_node_p(n) (cpsnodep(n) && (getcpstype(n) == s_call))
#define cps_node_internal(n, i) getelement(n, ((i) + 1))
#define set_cps_node_internal(n, i, v) setelement(n, ((i) + 1), (v))
#define node_children(n) cps_node_internal((n), 0)
#define node_parent(n) cps_node_internal((n), 1)
#define node_simplified(n) cps_node_internal((n), 2)
#define node_note(n) cps_node_internal((n), 3)
#define CPS_NODE_CHILDREN 0
#define CPS_NODE_PARENT 1
#define CPS_NODE_SIMPLIFIED 2
#define CPS_NODE_NOTE 3
#define CPS_LEAF_NODE_VALUE 4
#define CPS_LEAF_NODE_COUNT 5
#define CPS_LAMBDA_NODE_ARGLIST 4
#define CPS_LAMBDA_NODE_LAMBDA_LIST 5
#define CPS_LAMBDA_NODE_NAME 6
#define NUM_CPS_INTERNALS (CPSNODESIZE - 1)
LVAL xlmakecpsnode(V)
{
LVAL type;
type = xlgetarg();
xllastarg();
return(newcpsnode(type));
}
LVAL xlcpsinternal(V)
{
LVAL n, il;
int i;
n = xlgacpsnode();
il = xlgafixnum();
i = getfixnum(il);
if (i < 0 || i >= NUM_CPS_INTERNALS) xlerror("index out of range", il);
if (moreargs()) set_cps_node_internal(n, i, xlgetarg());
xllastarg();
return(cps_node_internal(n, i));
}
LVAL xlcpstransform(V)
{
LVAL a, b;
int i;
a = xlgacpsnode();
b = xlgacpsnode();
xllastarg();
setcpstype(a, getcpstype(b));
for (i = 0; i < NUM_CPS_INTERNALS; i++)
set_cps_node_internal(a, i, cps_node_internal(b, i));
return(a);
}
LVAL xlcpsleafnodep(V)
{
LVAL n;
n = xlgetarg();
xllastarg();
return((leaf_node_p(n)) ? s_true : NIL);
}
LVAL xlcpslambdanodep(V)
{
LVAL n;
n = xlgetarg();
xllastarg();
return((lambda_node_p(n)) ? s_true : NIL);
}
LVAL xlcpscallnodep(V)
{
LVAL n;
n = xlgetarg();
xllastarg();
return((call_node_p(n)) ? s_true : NIL);
}
LOCAL int any_references_p P2C(LVAL, v, LVAL, n)
{
LVAL ch;
if (! cpsnodep(n)) xlbadtype(n);
if (leaf_node_p(n)) {
return((v == n) ? TRUE : FALSE);
}
else {
for (ch = node_children(n); consp(ch); ch = cdr(ch)) {
if (any_references_p(v, car(ch))) return(TRUE);
}
return(FALSE);
}
}
LVAL xlcpsanyrefs(V)
{
LVAL v, n;
v = xlgacpsnode();
n = xlgacpsnode();
xllastarg();
return((any_references_p(v, n)) ? s_true : NIL);
}
LOCAL VOID find_references P3C(LVAL, v, LVAL, n, LVAL *, refs)
{
LVAL c, ch, tmp;
int i;
if (! cpsnodep(n)) xlbadtype(n);
if (! leaf_node_p(n)) {
for (ch = node_children(n), i = 0; consp(ch); ch = cdr(ch), i++) {
c = car(ch);
if (leaf_node_p(c)) {
if (v == c) {
xlsave1(tmp);
tmp = cons(n, cvfixnum((FIXTYPE) i));
*refs = cons(tmp, *refs);
xlpop();
}
}
else find_references(v, c, refs);
}
}
}
LVAL xlcpsfindrefs(V)
{
LVAL v, n, refs;
v = xlgacpsnode();
n = xlgacpsnode();
xllastarg();
xlsave1(refs);
refs = NIL;
find_references(v, n, &refs);
xlpop();
return(refs);
}
LOCAL LVAL cps_node_internals P1C(int, which)
{
LVAL n;
n = xlgacpsnode();
xllastarg();
return(cps_node_internal(n, which));
}
LVAL xlcpsnodechildren(V) { return(cps_node_internals(CPS_NODE_CHILDREN)); }
LVAL xlcpsnodeparent(V) { return(cps_node_internals(CPS_NODE_PARENT)); }
LVAL xlcpsnodesimplified(V) { return(cps_node_internals(CPS_NODE_SIMPLIFIED)); }
LVAL xlcpsnodenote(V) { return(cps_node_internals(CPS_NODE_NOTE)); }
LVAL xlcpsleafnodevalue(V) { return(cps_node_internals(CPS_LEAF_NODE_VALUE)); }
LVAL xlcpsleafnodecount() { return(cps_node_internals(CPS_LEAF_NODE_COUNT)); }
LVAL xlcpslambdanodearglist(V)
{
return(cps_node_internals(CPS_LAMBDA_NODE_ARGLIST));
}
LVAL xlcpslambdanodelambdalist(V)
{
return(cps_node_internals(CPS_LAMBDA_NODE_LAMBDA_LIST));
}
LVAL xlcpslambdanodename(V)
{
return(cps_node_internals(CPS_LAMBDA_NODE_NAME));
}
LOCAL LVAL set_cps_node_internals P1C(int, which)
{
LVAL n, v;
n = xlgacpsnode();
v = xlgetarg();
xllastarg();
set_cps_node_internal(n, which, v);
return(cps_node_internal(n, which));
}
LVAL xlcpssetnodechildren(V)
{
return(set_cps_node_internals(CPS_NODE_CHILDREN));
}
LVAL xlcpssetnodeparent(V) { return(set_cps_node_internals(CPS_NODE_PARENT)); }
LVAL xlcpssetnodesimplified(V)
{
return(set_cps_node_internals(CPS_NODE_SIMPLIFIED));
}
LVAL xlcpssetnodenote(V) { return(set_cps_node_internals(CPS_NODE_NOTE)); }
LVAL xlcpssetleafnodevalue(V)
{
return(set_cps_node_internals(CPS_LEAF_NODE_VALUE));
}
LVAL xlcpssetleafnodecount(V)
{
return(set_cps_node_internals(CPS_LEAF_NODE_COUNT));
}
LVAL xlcpssetlambdanodearglist(V)
{
return(set_cps_node_internals(CPS_LAMBDA_NODE_ARGLIST));
}
LVAL xlcpssetlambdanodelambdalist(V)
{
return(set_cps_node_internals(CPS_LAMBDA_NODE_LAMBDA_LIST));
}
LVAL xlcpssetlambdanodename(V)
{
return(set_cps_node_internals(CPS_LAMBDA_NODE_NAME));
}
LVAL xlcpslambdanodebody(V)
{
LVAL n, ch;
n = xlgacpsnode();
xllastarg();
ch = node_children(n);
return(consp(ch) ? car(ch) : NIL);
}
LVAL xlcpscallnodefunction(V)
{
LVAL n, ch;
n = xlgacpsnode();
xllastarg();
ch = node_children(n);
return(consp(ch) ? car(ch) : NIL);
}
LVAL xlcpscallnodeargs(V)
{
LVAL n, ch;
n = xlgacpsnode();
xllastarg();
ch = node_children(n);
return(consp(ch) ? cdr(ch) : NIL);
}
/*****************************************************************************/
/*****************************************************************************/
/** **/
/** Some Compiler Support Functions **/
/** **/
/*****************************************************************************/
/*****************************************************************************/
/**** what is wrong wih using symbol-value??? */
LVAL xldval(V)
{
LVAL s;
s = xlgasymbol();
xllastarg();
return(getvalue(s));
}
/**** is this needed? */
/* xlgetlambdaname - get the name associated with a closure */
LVAL xlgetlambdaname(V)
{
LVAL closure;
closure = xlgaclosure();
return(getname(closure));
}
/*****************************************************************************/
/*****************************************************************************/
/** **/
/** Some SETF Functions **/
/** **/
/*****************************************************************************/
/*****************************************************************************/
LVAL xsetget(V)
{
LVAL x, y, v;
x = xlgasymbol();
y = xlgetarg();
v = xlgetarg();
if (moreargs()) v = nextarg(); /* allows for extra argument */
xllastarg();
xlputprop(x, v, y);
return(v);
}
LVAL xsetsymval(V)
{
LVAL x, v;
x = xlgasymbol();
v = xlgetarg();
xllastarg();
setvalue(x, v);
return(v);
}
LVAL xsetsymfun(V)
{
LVAL x, v;
x = xlgasymbol();
v = xlgetarg();
xllastarg();
setfunction(x, v);
return(v);
}
LVAL xsetsymplist(V)
{
LVAL x, v;
x = xlgasymbol();
v = xlgetarg();
xllastarg();
setplist(x, v);
return(v);
}
LVAL xsetaref(V)
{
LVAL x, v;
int i;
x = xlgetarg();
i = rowmajorindex(x, NIL, TRUE); /* does error checking */
v = xlgetarg();
xllastarg();
settvecelement(darrayp(x) ? getdarraydata(x) : x, i, v);
return(v);
}
LVAL xsetgethash(V)
{
LVAL key, table, value;
key = xlgetarg();
table = xlgetarg();
value = xlgetarg();
xllastarg();
xlsetgethash(key, table, value);
return(value);
}
LVAL xsetcar(V)
{
LVAL x, v;
x = xlgacons();
v = xlgetarg();
xllastarg();
rplaca(x, v);
return v;
}
LVAL xsetcdr(V)
{
LVAL x, v;
x = xlgacons();
v = xlgetarg();
xllastarg();
rplacd(x, v);
return v;
}
LVAL xsetnth(V)
{
LVAL nl, xl, vl;
int i;
nl = xlgafixnum();
xl = xlgalist();
vl = xlgetarg();
xllastarg();
for (i = (int) getfixnum(nl); i > 0 && consp(xl); i--, xl = cdr(xl));
if (consp(xl)) rplaca(xl, vl);
return vl;
}
LVAL xsetelt(V)
{
LVAL al, il, vl;
int i;
al = xlgetarg();
il = xlgafixnum();
vl = xlgetarg();
xllastarg();
i = getfixnum(il);
switch (ntype(al)) {
case CONS:
for (; i > 0 && consp(al); --i)
al = cdr(al);
if((!consp(al)) || i < 0)
xlerror("index out of range", il);
rplaca(al,vl);
break;
case VECTOR:
case STRING:
case TVEC:
if (i < 0 || i >= gettvecsize(al))
xlerror("index out of range", il);
settvecelement(al, i, vl);
break;
default:
xlbadtype(al);
}
return vl;
}
LVAL xsetsvref(V)
{
LVAL al, il, vl;
int i;
al = xlgavector();
il = xlgafixnum();
vl = xlgetarg();
xllastarg();
i = getfixnum(il);
if (i < 0 || i >= getsize(al))
xlerror("index out of range", il);
setelement(al, i, vl);
return vl;
}
/*****************************************************************************/
/*****************************************************************************/
/** **/
/** Some experimental code for C compiled code **/
/** **/
/*****************************************************************************/
/*****************************************************************************/
/****
#define RETURN(c) { \
LVAL __c__ = (getregval(c)); \
if (__c__ == DONE) { vsbase[-1] = NIL; return; } \
xlcstop = xlcontinuation_stack + getfixnum(__c__); \
vsbase = xlcstop->base; \
vstop = xlcstop->top; \
if (xlcstop->vreg != NO_VALUE) setregval(xlcstop->vreg,get_one_result()); \
if (xlcstop < FVcont) return; \
else { entry = xlcstop->pe.entry; goto entry; } \
}
#define cmp_check_required_only_argcount(n) { \
int argc = vstop - vsbase; \
if (argc != (n)) { \
if (argc < (n)) xltoofew(); \
else xltoomany(); \
} \
}
#define cmp_push_space(n) { \
int __n__ = (n); \
if (xlsp + __n__ > xlargstktop) xlargstkoverflow(); \
while (__n__ -- > 0) *xlsp++ = NIL; \
}
*/
LVAL cmpAREF1 P2C(LVAL, xl, LVAL, il)
{
int i;
if (darrayp(xl)) xl = getdarraydata(xl);
if (! fixp(il)) xlbadtype(il);
i = getfixnum(il);
if (i < 0 || i >= gettvecsize(xl)) /* does error check */
xlerror("index out of range", il);
xl = gettvecelement(xl, i);
return(xl);
}
/****
#define cmpCAR(x) \
(tmp = (x), (null(tmp)) ? NIL : (consp(tmp)) ? car(tmp) : xlbadtype(tmp))
#define cmpCDR(x) \
(tmp = (x), (null(tmp)) ? NIL : (consp(tmp)) ? cdr(tmp) : xlbadtype(tmp))
#define cmp_save_current_continuation(Entry, vr) { \
if (xlcstop >= xlcsend) xlabort("continuation stack overflow"); \
xlcstop->base = vsbase; \
xlcstop->top = vstop; \
xlcstop->pe.entry = (Entry); \
xlcstop->vreg = (vr); \
xlcstop++; \
}
*/
VOID cmp_call_setup P6C(LVAL, fun, int, vi, int, entry, int, argc, LVAL, cont, int, tailp)
{
if (bcclosurep(fun)) {
if (!tailp) {
cont = cvfixnum((FIXTYPE) (xlcstop - xlcontinuation_stack));
cmp_save_current_continuation(entry, vi);
}
pusharg(fun);
vsbase = vstop;
pusharg(cont);
push_environment(bcode_environment(fun));
if (xlsp + argc > xlargstktop) xlargstkoverflow();
if (xlcstop >= xlcsend) xlabort("continuation stack overflow");
if (stringp(getbccode(getbcccode(fun)))) {
xlcstop->pe.pc =
bcode_codevec(fun)
+ getfixnum(getelement(bcode_jumptable(fun),bcode_index(fun)));
}
else xlcstop->pe.entry = bcode_index(fun);
}
else {
LVAL *newfp;
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE) argc));
if (xlsp + argc > xlargstktop) xlargstkoverflow();
xlfp = newfp;
}
}
/*
VOID cmp_shift_tail_frame(base)
LVAL *base;
int argc;
{
if (xlcstop[-1].base != base) {
n = vstop - vsbase;
MEMMOVE(base - 1, vsbase - 1, sizeof(LVAL) * (n + 1));
vstop = base + n;
vsbase = base;
}
}
*/
/****
#define cmp_shift_tail_frame(base) { \
if (xlcstop[-1].base != base) { \
int n = vstop - vsbase; \
MEMMOVE(base - 1, vsbase - 1, sizeof(LVAL) * (n + 1)); \
vstop = base + n; \
vsbase = base; \
} \
}
#define cmp_do_call(fun, argc) { \
if (bcclosurep(fun)) return; \
else xlapply(argc); \
}
#define cmp_do_call_set(fun, argc, vreg) { \
if (bcclosurep(fun)) return; \
else setregval(vreg, xlapply(argc)); \
}
#define cmp_do_tail_call(fun,base,argc,creg) { \
if (bcclosurep(fun)) { \
cmp_shift_tail_frame(base); \
return; \
} \
else { \
xlapply(argc); \
RETURN(creg); \
} \
}
#define cmp_do_lcall(f) goto f;
#define cmp_do_tail_lcall(f,base) {\
cmp_shift_tail_frame(base); \
goto f; \
}
#define cmp_tail_lcall_setup(argc, cont) { \
LVAL Cont = (cont); \
pusharg(vsbase[-1]); \
vsbase = vstop; \
pusharg(Cont); \
if (xlsp + argc > xlargstktop) xlargstkoverflow(); \
}
*/
/*
VOID cmp_tail_lcall_setup(argc, cont)
int argc;
LVAL cont;
{
pusharg(vsbase[-1]);
vsbase = vstop;
pusharg(cont);
if (xlsp + argc > xlargstktop) xlargstkoverflow();
}
*/
/****
#define cmp_lcall_setup(vi, entry, argc) { \
LVAL Cont; \
Cont = cvfixnum((FIXTYPE) (xlcstop - xlcontinuation_stack)); \
cmp_save_current_continuation(entry, vi); \
pusharg(vsbase[-1]); \
vsbase = vstop; \
pusharg(Cont); \
if (xlsp + argc > xlargstktop) xlargstkoverflow(); \
}
*/
/*
VOID cmp_lcall_setup(vi, entry, argc)
int vi, entry, argc;
{
LVAL cont;
cont = cvfixnum((FIXTYPE) (xlcstop - xlcontinuation_stack));
cmp_save_current_continuation(entry, vi);
pusharg(vsbase[-1]);
vsbase = vstop;
pusharg(cont);
if (xlsp + argc > xlargstktop) xlargstkoverflow();
}
*/
#endif /* BYTECODE */
syntax highlighted by Code2HTML, v. 0.9.1