value_t read_sexpr(FILE *f)
{
value_t v;
switch (peek(f)) {
case TOK_CLOSE:
take();
lerror("read: error: unexpected ')'\n");
case TOK_DOT:
take();
lerror("read: error: unexpected '.'\n");
case TOK_SYM:
case TOK_NUM:
take();
return tokval;
case TOK_QUOTE:
take();
v = read_sexpr(f);
PUSH(v);
v = cons_("E, cons(&Stack[SP-1], &NIL));
POPN(2);
return v;
case TOK_OPEN:
take();
PUSH(NIL);
read_list(f, &Stack[SP-1]);
return POP();
}
return NIL;
}
OBJ
builtin_consP(int numArgs){
if(numArgs != 1){
POPN(numArgs);
js_error("(cons?): expects 1 argument", js_nil);
}
OBJ theArg = POP();
return( ISCONS(theArg) ? js_true : js_false);
}
OBJ
builtin_minus(int numArgs){
OBJ theArg;
switch (numArgs){
case 0:
js_error("(-): at least one arg expected", js_nil);
/* NOT REACHED */
case 1:
theArg = POP();
if( !ISINTEGER(theArg)){
js_error("(-): non-integer argument", theArg);
}
return newInteger( -INTVAL(theArg) );
default:
theArg = NTH_ARG(numArgs, 0);
if( !ISINTEGER(theArg)){
POPN(numArgs);
js_error("(-): non-integer argument", theArg);
}
jscheme_int64 *difference = NULL;
jscheme_int64 start = INTVAL(theArg);
difference = &start;
for(int i = 1; i < numArgs; i++){
OBJ nextArg = NTH_ARG(numArgs, i);
if( !ISINTEGER(nextArg)){
POPN(numArgs);
js_error("(-): non-integer argument", theArg);
}
if(__builtin_ssubl_overflow(*difference, INTVAL(nextArg), difference)){
// clean stack
POPN(numArgs);
js_error("(-): integer overflow", newInteger(*difference));
};
}
POPN(numArgs);
return newInteger(*difference);
}
/* NOT REACHED */
return js_nil;
}
static inline void
vm_method_missing_args(rb_thread_t *th, VALUE *argv,
int num, const rb_block_t *blockptr, int opt)
{
rb_control_frame_t * const reg_cfp = th->cfp;
MEMCPY(argv, STACK_ADDR_FROM_TOP(num + 1), VALUE, num + 1);
th->method_missing_reason = opt;
th->passed_block = blockptr;
POPN(num + 1);
}
OBJ
builtin_cons(int numArgs){
if(numArgs != 2){
POPN(numArgs);
js_error("(cons): expects 2 arguments", js_nil);
}
OBJ arg2 = POP();
OBJ arg1 = POP();
return newCons(arg1, arg2);
}
OBJ
builtin_times(int numArgs){
jscheme_int64 *product= NULL;
jscheme_int64 start = 1;
product = &start;
for(int i = 0; i < numArgs; i++){
OBJ theArg = POP();
if( !ISINTEGER(theArg)){
POPN((numArgs - 1) - i);
js_error("(*): non-integer argument", theArg);
}
if(__builtin_smull_overflow(*product,INTVAL(theArg),product)){
// clean stack
POPN((numArgs - 1) - i);
js_error("(*): integer overflow", newInteger(*product));
}
}
return newInteger(*product);
}
OBJ
builtin_cdr(int numArgs){
if(numArgs != 1){
POPN(numArgs);
js_error("(cdr): expects 1 argument", js_nil);
}
OBJ theArg = POP();
if(!ISCONS(theArg)){
js_error("(cdr): non-cons argument", theArg);
}
return CDR(theArg);
}
OBJ
builtin_set_cdr(int numArgs){
if(numArgs != 2){
POPN(numArgs);
js_error("(set-cdr!): expects 2 argument", js_nil);
}
OBJ newCdr = POP();
OBJ theCons = POP();
if(!ISCONS(theCons)){
js_error("(set-cdr!): non-cons argument", theCons);
}
SET_CDR(theCons, newCdr);
return js_void;
}
OBJ
builtin_plus(int numArgs){
jscheme_int64 start = 0;
jscheme_int64 *sum = NULL;
sum = &start;
int i;
for(i = 0; i < numArgs; i++){
OBJ theArg = POP();
if( !ISINTEGER(theArg)){
POPN((numArgs - 1) - i);
js_error("(+): non-integer argument", theArg);
}
if(__builtin_saddl_overflow( *sum, INTVAL(theArg), sum)){
// clean evalStack
POPN((numArgs - 1) - i);
js_error("(+): integer overflow", newInteger(*sum));
};
}
return newInteger(*sum);
}
static inline VALUE
vm_method_missing(rb_thread_t *th, ID id, VALUE recv,
int num, rb_block_t *blockptr, int opt)
{
VALUE val;
rb_control_frame_t * const reg_cfp = th->cfp;
VALUE *argv = ALLOCA_N(VALUE, num + 1);
MEMCPY(argv, STACK_ADDR_FROM_TOP(num + 1), VALUE, num + 1);
argv[0] = ID2SYM(id);
th->method_missing_reason = opt;
th->passed_block = blockptr;
POPN(num + 1);
val = rb_funcall2(recv, idMethodMissing, num + 1, argv);
return val;
}
static VALUE
vm_invoke_block(rb_thread_t *th, rb_control_frame_t *reg_cfp, rb_num_t num, rb_num_t flag)
{
const rb_block_t *block = GET_BLOCK_PTR();
rb_iseq_t *iseq;
int argc = (int)num;
VALUE type = GET_ISEQ()->local_iseq->type;
if ((type != ISEQ_TYPE_METHOD && type != ISEQ_TYPE_CLASS) || block == 0) {
rb_vm_localjump_error("no block given (yield)", Qnil, 0);
}
iseq = block->iseq;
argc = caller_setup_args(th, GET_CFP(), flag, argc, 0, 0);
if (BUILTIN_TYPE(iseq) != T_NODE) {
int opt_pc;
const int arg_size = iseq->arg_size;
VALUE * const rsp = GET_SP() - argc;
SET_SP(rsp);
CHECK_STACK_OVERFLOW(GET_CFP(), iseq->stack_max);
opt_pc = vm_yield_setup_args(th, iseq, argc, rsp, 0,
block_proc_is_lambda(block->proc));
vm_push_frame(th, iseq,
VM_FRAME_MAGIC_BLOCK, block->self, (VALUE) block->dfp,
iseq->iseq_encoded + opt_pc, rsp + arg_size, block->lfp,
iseq->local_size - arg_size);
return Qundef;
}
else {
VALUE val = vm_yield_with_cfunc(th, block, block->self, argc, STACK_ADDR_FROM_TOP(argc), 0);
POPN(argc); /* TODO: should put before C/yield? */
return val;
}
}
OBJ
builtin_eqP(int numArgs){
if(numArgs != 2){
POPN(numArgs);
js_error("(eq?): expects 2 arguments", js_nil);
}
OBJ arg2 = POP();
OBJ arg1 = POP();
// case 1: same jscheme OBJ
if( arg1 == arg2) return js_true;
// case 2: same INTEGER value
if(ISINTEGER(arg1)){
if(ISINTEGER(arg2)){
if( INTVAL(arg1) == INTVAL(arg2)){
return js_true;
}
}
}
// TO-DO: Strings, cons, ...
return js_false;
}
OBJ
builtin_eqStringP(int numArgs){
if(numArgs != 2){
POPN(numArgs);
js_error("(string=?): expects 2 arguments", js_nil);
}
OBJ arg2 = POP();
OBJ arg1 = POP();
// case 1: same jscheme OBJ
if( arg1 == arg2) return js_true;
// case 2: same INTEGER value
if(ISSTRING(arg1)){
if(ISSTRING(arg2)){
if( strcmp( STRINGVAL(arg1), STRINGVAL(arg2)) == 0) return js_true;
return js_false;
}
js_error("(string=?): non-string argument", arg2);
}
js_error("(string=?): non-string argument", arg1);
return js_false;
}
OBJ
builtin_gThanNrP(int numArgs){
if(numArgs != 2){
POPN(numArgs);
js_error("(>): expects 2 arguments", js_nil);
}
OBJ arg2 = POP();
OBJ arg1 = POP();
if(ISINTEGER(arg1)){
if(ISINTEGER(arg2)){
if( INTVAL(arg1) > INTVAL(arg2)) return js_true;
return js_false;
}else{
js_error("(>): non-integer argument", arg2);
}
}else{
js_error("(>): non-integer argument", arg1);
}
// NOT REACHED
return NULL;
}
pic_value
pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
{
struct pic_code *pc, c;
int ai = pic_gc_arena_preserve(pic);
jmp_buf jmp;
size_t argc, i;
struct pic_code boot[2];
#if PIC_DIRECT_THREADED_VM
static void *oplabels[] = {
&&L_OP_POP, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE, &&L_OP_PUSHFALSE, &&L_OP_PUSHFLOAT,
&&L_OP_PUSHINT, &&L_OP_PUSHCHAR, &&L_OP_PUSHCONST,
&&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET, &&L_OP_CREF, &&L_OP_CSET,
&&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_CALL, &&L_OP_TAILCALL, &&L_OP_RET, &&L_OP_LAMBDA,
&&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP,
&&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV,
&&L_OP_EQ, &&L_OP_LT, &&L_OP_LE, &&L_OP_STOP
};
#endif
if (setjmp(jmp) == 0) {
pic->jmp = &jmp;
}
else {
goto L_RAISE;
}
argc = pic_length(pic, argv) + 1;
#if VM_DEBUG
puts("== booting VM...");
printf(" proc = ");
pic_debug(pic, pic_obj_value(proc));
puts("");
printf(" argv = ");
pic_debug(pic, argv);
puts("");
printf(" irep = ");
print_irep(pic, proc->u.irep);
puts("\nLet's go!");
#endif
PUSH(pic_obj_value(proc));
for (i = 1; i < argc; ++i) {
PUSH(pic_car(pic, argv));
argv = pic_cdr(pic, argv);
}
/* boot! */
boot[0].insn = OP_CALL;
boot[0].u.i = argc;
boot[1].insn = OP_STOP;
pc = boot;
c = *pc;
goto L_CALL;
VM_LOOP {
CASE(OP_POP) {
POPN(1);
NEXT;
}
CASE(OP_PUSHNIL) {
PUSH(pic_nil_value());
NEXT;
}
CASE(OP_PUSHTRUE) {
PUSH(pic_true_value());
NEXT;
}
CASE(OP_PUSHFALSE) {
PUSH(pic_false_value());
NEXT;
}
CASE(OP_PUSHFLOAT) {
PUSH(pic_float_value(c.u.f));
NEXT;
}
CASE(OP_PUSHINT) {
PUSH(pic_int_value(c.u.i));
NEXT;
}
CASE(OP_PUSHCHAR) {
PUSH(pic_char_value(c.u.c));
NEXT;
}
CASE(OP_PUSHCONST) {
PUSH(pic->pool[c.u.i]);
NEXT;
}
CASE(OP_GREF) {
PUSH(pic->globals[c.u.i]);
NEXT;
}
CASE(OP_GSET) {
pic->globals[c.u.i] = POP();
NEXT;
}
CASE(OP_LREF) {
PUSH(pic->ci->fp[c.u.i]);
NEXT;
}
CASE(OP_LSET) {
pic->ci->fp[c.u.i] = POP();
NEXT;
}
CASE(OP_CREF) {
int depth = c.u.r.depth;
struct pic_env *env;
env = pic->ci->env;
while (depth--) {
env = env->up;
}
PUSH(env->values[c.u.r.idx]);
NEXT;
}
CASE(OP_CSET) {
int depth = c.u.r.depth;
struct pic_env *env;
env = pic->ci->env;
while (depth--) {
env = env->up;
}
env->values[c.u.r.idx] = POP();
NEXT;
}
CASE(OP_JMP) {
pc += c.u.i;
JUMP;
}
CASE(OP_JMPIF) {
pic_value v;
v = POP();
if (! pic_false_p(v)) {
pc += c.u.i;
JUMP;
}
NEXT;
}
CASE(OP_CALL) {
pic_value x, v;
pic_callinfo *ci;
struct pic_proc *proc;
L_CALL:
x = pic->sp[-c.u.i];
if (! pic_proc_p(x)) {
pic->errmsg = "invalid application";
goto L_RAISE;
}
proc = pic_proc_ptr(x);
ci = PUSHCI();
ci->argc = c.u.i;
ci->pc = pc;
ci->fp = pic->sp - c.u.i;
ci->env = NULL;
if (pic_proc_cfunc_p(x)) {
v = proc->u.cfunc(pic);
pic->sp = ci->fp;
POPCI();
PUSH(v);
pic_gc_arena_restore(pic, ai);
NEXT;
}
else {
int i;
pic_value rest;
if (ci->argc != proc->u.irep->argc) {
if (! (proc->u.irep->varg && ci->argc >= proc->u.irep->argc)) {
pic->errmsg = "wrong number of arguments";
goto L_RAISE;
}
}
/* prepare rest args */
if (proc->u.irep->varg) {
rest = pic_nil_value();
for (i = 0; i < ci->argc - proc->u.irep->argc; ++i) {
pic_gc_protect(pic, v = POP());
rest = pic_cons(pic, v, rest);
}
PUSH(rest);
}
/* prepare env */
if (proc->u.irep->cv_num == 0) {
ci->env = proc->env;
}
else {
ci->env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
ci->env->up = proc->env;
ci->env->valuec = proc->u.irep->cv_num;
ci->env->values = (pic_value *)pic_calloc(pic, ci->env->valuec, sizeof(pic_value));
for (i = 0; i < ci->env->valuec; ++i) {
ci->env->values[i] = ci->fp[proc->u.irep->cv_tbl[i]];
}
}
pc = proc->u.irep->code;
pic_gc_arena_restore(pic, ai);
JUMP;
}
}
CASE(OP_TAILCALL) {
int argc;
pic_value *argv;
argc = c.u.i;
argv = pic->sp - argc;
for (i = 0; i < argc; ++i) {
pic->ci->fp[i] = argv[i];
}
pic->sp = pic->ci->fp + argc;
pc = POPCI()->pc;
/* c is not changed */
goto L_CALL;
}
CASE(OP_RET) {
pic_value v;
pic_callinfo *ci;
if (pic->errmsg) {
L_RAISE:
goto L_STOP;
}
else {
v = POP();
ci = POPCI();
pc = ci->pc;
pic->sp = ci->fp;
PUSH(v);
}
NEXT;
}
CASE(OP_LAMBDA) {
struct pic_proc *proc;
proc = pic_proc_new(pic, pic->irep[c.u.i], pic->ci->env);
PUSH(pic_obj_value(proc));
pic_gc_arena_restore(pic, ai);
NEXT;
}
CASE(OP_CONS) {
pic_value a, b;
pic_gc_protect(pic, b = POP());
pic_gc_protect(pic, a = POP());
PUSH(pic_cons(pic, a, b));
pic_gc_arena_restore(pic, ai);
NEXT;
}
CASE(OP_CAR) {
pic_value p;
p = POP();
PUSH(pic_car(pic, p));
NEXT;
}
CASE(OP_CDR) {
pic_value p;
p = POP();
PUSH(pic_cdr(pic, p));
NEXT;
}
CASE(OP_NILP) {
pic_value p;
p = POP();
PUSH(pic_bool_value(pic_nil_p(p)));
NEXT;
}
#define DEFINE_ARITH_OP(opcode, op) \
CASE(opcode) { \
pic_value a, b; \
b = POP(); \
a = POP(); \
if (pic_int_p(a) && pic_int_p(b)) { \
double f = (double)pic_int(a) op (double)pic_int(b); \
if (INT_MIN <= f && f <= INT_MAX) { \
PUSH(pic_int_value((int)f)); \
} \
else { \
PUSH(pic_float_value(f)); \
} \
} \
else if (pic_float_p(a) && pic_float_p(b)) { \
PUSH(pic_float_value(pic_float(a) op pic_float(b))); \
} \
else if (pic_int_p(a) && pic_float_p(b)) { \
PUSH(pic_float_value(pic_int(a) op pic_float(b))); \
} \
else if (pic_float_p(a) && pic_int_p(b)) { \
PUSH(pic_float_value(pic_float(a) op pic_int(b))); \
} \
else { \
pic->errmsg = #op " got non-number operands"; \
goto L_RAISE; \
} \
NEXT; \
}
DEFINE_ARITH_OP(OP_ADD, +);
DEFINE_ARITH_OP(OP_SUB, -);
DEFINE_ARITH_OP(OP_MUL, *);
/* special care for (int / int) division */
CASE(OP_DIV) {
pic_value a, b;
b = POP();
a = POP();
if (pic_int_p(a) && pic_int_p(b)) {
PUSH(pic_float_value((double)pic_int(a) / pic_int(b)));
}
else if (pic_float_p(a) && pic_float_p(b)) {
PUSH(pic_float_value(pic_float(a) / pic_float(b)));
}
else if (pic_int_p(a) && pic_float_p(b)) {
PUSH(pic_float_value(pic_int(a) / pic_float(b)));
}
else if (pic_float_p(a) && pic_int_p(b)) {
PUSH(pic_float_value(pic_float(a) / pic_int(b)));
}
else {
pic->errmsg = "/ got non-number operands";
goto L_RAISE;
}
NEXT;
}
#define DEFINE_COMP_OP(opcode, op) \
CASE(opcode) { \
pic_value a, b; \
b = POP(); \
a = POP(); \
if (pic_int_p(a) && pic_int_p(b)) { \
PUSH(pic_bool_value(pic_int(a) op pic_int(b))); \
} \
else if (pic_float_p(a) && pic_float_p(b)) { \
PUSH(pic_bool_value(pic_float(a) op pic_float(b))); \
} \
else if (pic_int_p(a) && pic_int_p(b)) { \
PUSH(pic_bool_value(pic_int(a) op pic_float(b))); \
} \
else if (pic_float_p(a) && pic_int_p(b)) { \
PUSH(pic_bool_value(pic_float(a) op pic_int(b))); \
} \
else { \
pic->errmsg = #op " got non-number operands"; \
goto L_RAISE; \
} \
NEXT; \
}
DEFINE_COMP_OP(OP_EQ, ==);
DEFINE_COMP_OP(OP_LT, <);
DEFINE_COMP_OP(OP_LE, <=);
CASE(OP_STOP) {
pic_value val;
L_STOP:
val = POP();
pic->jmp = NULL;
if (pic->errmsg) {
return pic_undef_value();
}
#if VM_DEBUG
puts("**VM END STATE**");
printf("stbase\t= %p\nsp\t= %p\n", pic->stbase, pic->sp);
printf("cibase\t= %p\nci\t= %p\n", pic->cibase, pic->ci);
if (pic->stbase < pic->sp) {
pic_value *sp;
printf("* stack trace:");
for (sp = pic->stbase; pic->sp != sp; ++sp) {
pic_debug(pic, *sp);
puts("");
}
}
if (pic->stbase > pic->sp) {
puts("*** stack underflow!");
}
#endif
pic_gc_protect(pic, val);
return val;
}
} VM_LOOP_END;
}
OBJ
builtin_quotient(int numArgs){
#ifdef DEBUG
if( DETAILED_TYPES->state) printf(RED "WARNING:" RESET " division is implemented for integers only and will truncate fractions!\n");
#endif
OBJ theArg;
switch (numArgs){
case 0:
js_error("(/): at least one arg expected", js_nil);
/* NOT REACHED */
case 1:
theArg = POP();
if( !ISINTEGER(theArg)){
js_error("(/): non-integer argument", theArg);
/* NOT REACHED */
}
if( INTVAL(theArg) == 0){
js_error("(/): division by zero", theArg);
/* NOT REACHED */
}
return newInteger( 1 / INTVAL(theArg) );
default:
theArg = NTH_ARG(numArgs, 0);
if( !ISINTEGER(theArg)){
POPN(numArgs);
js_error("(/): non-integer argument", theArg);
/* NOT REACHED */
}
if( INTVAL(theArg) == 0){
for(int i = 1; i < numArgs; i++){
OBJ nextArg = NTH_ARG(numArgs, i);
if( !ISINTEGER(nextArg) ){
POPN(numArgs);
js_error("(/): non-integer argument", theArg);
/* NOT REACHED */
}
if( INTVAL(nextArg) == 0){
POPN(numArgs);
js_error("(/): division by zero", nextArg);
/* NOT REACHED */
}
}
POPN(numArgs);
return newInteger(0);
}
jscheme_int64 quotient = INTVAL(theArg);
for(int i = 1; i < numArgs; i++){
OBJ nextArg = NTH_ARG(numArgs, i);
if( !ISINTEGER(nextArg) ){
POPN(numArgs);
js_error("(/): non-integer argument", theArg);
/* NOT REACHED */
}
if( INTVAL(nextArg) == 0){
POPN(numArgs);
js_error("(/): division by zero", nextArg);
/* NOT REACHED */
}
quotient = quotient / INTVAL(nextArg);
}
POPN(numArgs);
return newInteger(quotient);
}
/* NOT REACHED */
return js_nil;
}
value_t eval_sexpr(value_t e, value_t *penv)
{
value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
value_t *rest;
cons_t *c;
symbol_t *sym;
u_int32_t saveSP;
int i, nargs, noeval=0;
number_t s, n;
eval_top:
if (issymbol(e)) {
sym = (symbol_t*)ptr(e);
if (sym->constant != UNBOUND) return sym->constant;
v = *penv;
while (iscons(v)) {
bind = car_(v);
if (iscons(bind) && car_(bind) == e)
return cdr_(bind);
v = cdr_(v);
}
if ((v = sym->binding) == UNBOUND)
lerror("eval: error: variable %s has no value\n", sym->name);
return v;
}
if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
lerror("eval: error: stack overflow\n");
saveSP = SP;
PUSH(e);
PUSH(*penv);
f = eval(car_(e), penv);
*penv = Stack[saveSP+1];
if (isbuiltin(f)) {
// handle builtin function
if (!isspecial(f)) {
// evaluate argument list, placing arguments on stack
v = Stack[saveSP] = cdr_(Stack[saveSP]);
while (iscons(v)) {
v = eval(car_(v), penv);
*penv = Stack[saveSP+1];
PUSH(v);
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
}
apply_builtin:
nargs = SP - saveSP - 2;
switch (intval(f)) {
// special forms
case F_QUOTE:
v = cdr_(Stack[saveSP]);
if (!iscons(v))
lerror("quote: error: expected argument\n");
v = car_(v);
break;
case F_MACRO:
case F_LAMBDA:
v = Stack[saveSP];
if (*penv != NIL) {
// build a closure (lambda args body . env)
v = cdr_(v);
PUSH(car(v));
argsyms = &Stack[SP-1];
PUSH(car(cdr_(v)));
body = &Stack[SP-1];
v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
cons(argsyms, cons(body, penv)));
}
break;
case F_LABEL:
v = Stack[saveSP];
if (*penv != NIL) {
v = cdr_(v);
PUSH(car(v)); // name
pv = &Stack[SP-1];
PUSH(car(cdr_(v))); // function
body = &Stack[SP-1];
*body = eval(*body, penv); // evaluate lambda
v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
}
break;
case F_IF:
v = car(cdr_(Stack[saveSP]));
if (eval(v, penv) != NIL)
v = car(cdr_(cdr_(Stack[saveSP])));
else
v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
tail_eval(v, Stack[saveSP+1]);
break;
case F_COND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = NIL;
while (iscons(*pv)) {
c = tocons(car_(*pv), "cond");
v = eval(c->car, penv);
*penv = Stack[saveSP+1];
if (v != NIL) {
*pv = cdr_(car_(*pv));
// evaluate body forms
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv), penv);
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
}
*pv = cdr_(*pv);
}
break;
case F_AND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = T;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv), penv)) == NIL) {
SP = saveSP;
return NIL;
}
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
case F_OR:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv), penv)) != NIL) {
SP = saveSP;
return v;
}
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
case F_WHILE:
PUSH(cdr(cdr_(Stack[saveSP])));
body = &Stack[SP-1];
PUSH(*body);
Stack[saveSP] = car_(cdr_(Stack[saveSP]));
value_t *cond = &Stack[saveSP];
PUSH(NIL);
pv = &Stack[SP-1];
while (eval(*cond, penv) != NIL) {
*penv = Stack[saveSP+1];
*body = Stack[SP-2];
while (iscons(*body)) {
*pv = eval(car_(*body), penv);
*penv = Stack[saveSP+1];
*body = cdr_(*body);
}
}
v = *pv;
break;
case F_PROGN:
// return last arg
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv), penv);
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
// ordinary functions
case F_SET:
argcount("set", nargs, 2);
e = Stack[SP-2];
v = *penv;
while (iscons(v)) {
bind = car_(v);
if (iscons(bind) && car_(bind) == e) {
cdr_(bind) = (v=Stack[SP-1]);
SP=saveSP;
return v;
}
v = cdr_(v);
}
tosymbol(e, "set")->binding = (v=Stack[SP-1]);
break;
case F_BOUNDP:
argcount("boundp", nargs, 1);
sym = tosymbol(Stack[SP-1], "boundp");
if (sym->binding == UNBOUND && sym->constant == UNBOUND)
v = NIL;
else
v = T;
break;
case F_EQ:
argcount("eq", nargs, 2);
v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
break;
case F_CONS:
argcount("cons", nargs, 2);
v = mk_cons();
car_(v) = Stack[SP-2];
cdr_(v) = Stack[SP-1];
break;
case F_CAR:
argcount("car", nargs, 1);
v = car(Stack[SP-1]);
break;
case F_CDR:
argcount("cdr", nargs, 1);
v = cdr(Stack[SP-1]);
break;
case F_RPLACA:
argcount("rplaca", nargs, 2);
car(v=Stack[SP-2]) = Stack[SP-1];
break;
case F_RPLACD:
argcount("rplacd", nargs, 2);
cdr(v=Stack[SP-2]) = Stack[SP-1];
break;
case F_ATOM:
argcount("atom", nargs, 1);
v = ((!iscons(Stack[SP-1])) ? T : NIL);
break;
case F_SYMBOLP:
argcount("symbolp", nargs, 1);
v = ((issymbol(Stack[SP-1])) ? T : NIL);
break;
case F_NUMBERP:
argcount("numberp", nargs, 1);
v = ((isnumber(Stack[SP-1])) ? T : NIL);
break;
case F_ADD:
s = 0;
for (i=saveSP+2; i < (int)SP; i++) {
n = tonumber(Stack[i], "+");
s += n;
}
v = number(s);
break;
case F_SUB:
if (nargs < 1)
lerror("-: error: too few arguments\n");
i = saveSP+2;
s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
for (; i < (int)SP; i++) {
n = tonumber(Stack[i], "-");
s -= n;
}
v = number(s);
break;
case F_MUL:
s = 1;
for (i=saveSP+2; i < (int)SP; i++) {
n = tonumber(Stack[i], "*");
s *= n;
}
v = number(s);
break;
case F_DIV:
if (nargs < 1)
lerror("/: error: too few arguments\n");
i = saveSP+2;
s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
for (; i < (int)SP; i++) {
n = tonumber(Stack[i], "/");
if (n == 0)
lerror("/: error: division by zero\n");
s /= n;
}
v = number(s);
break;
case F_LT:
argcount("<", nargs, 2);
if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
v = T;
else
v = NIL;
break;
case F_NOT:
argcount("not", nargs, 1);
v = ((Stack[SP-1] == NIL) ? T : NIL);
break;
case F_EVAL:
argcount("eval", nargs, 1);
v = Stack[SP-1];
tail_eval(v, NIL);
break;
case F_PRINT:
for (i=saveSP+2; i < (int)SP; i++)
print(stdout, v=Stack[i]);
break;
case F_READ:
argcount("read", nargs, 0);
v = read_sexpr(stdin);
break;
case F_LOAD:
argcount("load", nargs, 1);
v = load_file(tosymbol(Stack[SP-1], "load")->name);
break;
case F_PROG1:
// return first arg
if (nargs < 1)
lerror("prog1: error: too few arguments\n");
v = Stack[saveSP+2];
break;
case F_APPLY:
argcount("apply", nargs, 2);
v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
f = Stack[SP-2]; // first arg is new function
POPN(2); // pop apply's args
if (isbuiltin(f)) {
if (isspecial(f))
lerror("apply: error: cannot apply special operator "
"%s\n", builtin_names[intval(f)]);
// unpack arglist onto the stack
while (iscons(v)) {
PUSH(car_(v));
v = cdr_(v);
}
goto apply_builtin;
}
noeval = 1;
goto apply_lambda;
}
SP = saveSP;
return v;
}
else {
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
apply_lambda:
if (iscons(f)) {
headsym = car_(f);
if (headsym == LABEL) {
// (label name (lambda ...)) behaves the same as the lambda
// alone, except with name bound to the whole label expression
labl = f;
f = car(cdr(cdr_(labl)));
headsym = car(f);
}
// apply lambda or macro expression
PUSH(cdr(cdr(cdr_(f))));
lenv = &Stack[SP-1];
PUSH(car_(cdr_(f)));
argsyms = &Stack[SP-1];
PUSH(car_(cdr_(cdr_(f))));
body = &Stack[SP-1];
if (labl) {
// add label binding to environment
PUSH(labl);
PUSH(car_(cdr_(labl)));
*lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
POPN(3);
v = Stack[saveSP]; // refetch arglist
}
if (headsym == MACRO)
noeval = 1;
else if (headsym != LAMBDA)
lerror("apply: error: head must be lambda, macro, or label\n");
// build a calling environment for the lambda
// the environment is the argument binds on top of the captured
// environment
while (iscons(v)) {
// bind args
if (!iscons(*argsyms)) {
if (*argsyms == NIL)
lerror("apply: error: too many arguments\n");
break;
}
asym = car_(*argsyms);
if (!issymbol(asym))
lerror("apply: error: formal argument not a symbol\n");
v = car_(v);
if (!noeval) {
v = eval(v, penv);
*penv = Stack[saveSP+1];
}
PUSH(v);
*lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
POPN(2);
*argsyms = cdr_(*argsyms);
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
if (*argsyms != NIL) {
if (issymbol(*argsyms)) {
if (noeval) {
*lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
}
else {
PUSH(NIL);
PUSH(NIL);
rest = &Stack[SP-1];
// build list of rest arguments
// we have to build it forwards, which is tricky
while (iscons(v)) {
v = eval(car_(v), penv);
*penv = Stack[saveSP+1];
PUSH(v);
v = cons_(&Stack[SP-1], &NIL);
POP();
if (iscons(*rest))
cdr_(*rest) = v;
else
Stack[SP-2] = v;
*rest = v;
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
*lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
}
}
else if (iscons(*argsyms)) {
lerror("apply: error: too few arguments\n");
}
}
noeval = 0;
// macro: evaluate expansion in the calling environment
if (headsym == MACRO) {
SP = saveSP;
PUSH(*lenv);
lenv = &Stack[SP-1];
v = eval(*body, lenv);
tail_eval(v, *penv);
}
else {
tail_eval(*body, *lenv);
}
// not reached
}
type_error("apply", "function", f);
return NIL;
}
mos_METHOD(bcMethod,decompile)
{
static mos_value stk[_stk_SIZE];
static mos_value *sp = stk + (_stk_SIZE-1);
#define TOP *sp
#define PUSH(X) *(-- sp) = (X)
#define DUP() (sp[-1] = *sp, sp --)
#define POP() *(sp ++)
#define PUSHN(N) (sp -= (N))
#define POPN(N) (sp += (N))
#define ARG() (pc += 4, ((unsigned long) pc[-4] | ((unsigned long) pc[-3] << 8) | ((unsigned long) pc[-2] << 16) | ((unsigned long) pc[-1] << 24)))
const unsigned char *pc;
mos_value *fp;
mos_value meth = mos_RCVR;
mos_value bytecodes = mos_send(meth, mos_s(bytecodes));
/* Our constants vector */
mos_value *constants = mos_vector_V(mos_send(meth, mos_s(constants)));
/* Our arguments ident vector */
mos_value *args = mos_vector_V(mos_send(meth, mos_s(arguments)));
/* Out locals ident vector */
mos_value *locals = mos_vector_V(mos_send(meth, mos_s(locals)));
/* An array to hold the method body */
mos_value body = mos_vector_make(0, 0);
mos_value sel;
/* Save a frame pointer */
fp = sp;
// restart:
pc = (void*) mos_string_V(bytecodes);
again:
switch ( (mos_bc) *(pc ++) ) {
case mos_bc_nop:
goto again;
case mos_bc_restart:
PUSH(mos_exprSend(mos_undef, mos_s(_restart), 0));
goto again;
case mos_bc_object:
PUSH(mos_exprObject(mos_vector_make(0,0), mos_vector_make(0,0)));
goto again;
case mos_bc_block:
PUSH(mos_exprBlock(mos_vector_make(0,0), mos_vector_make(0,0), mos_vector_make(0,0)));
goto again;
case mos_bc_method:
PUSH(mos_exprMethod(mos_vector_make(0,0), mos_vector_make(0,0), mos_vector_make(0,0)));
goto again;
case mos_bc_dup:
DUP();
goto again;
case mos_bc_pop:
/* pop only occurs at the end of stmt */
mos_send(body, mos_s(append_), POP());
goto again;
case mos_bc_rtn:
case mos_bc_rtnBlk:
mos_send(body, mos_s(append_), mos_exprSend(mos_undef, mos_s(__RTN__), 1, POP()));
break;
case mos_bc_const:
PUSH(mos_exprSend(mos_undef, mos_s(_constants), 0));
goto again;
case mos_bc_lobby:
PUSH(mos_exprSend(mos_undef, mos_s(_), 0));
goto again;
case mos_bc_msg:
PUSH(mos_exprSend(mos_undef, mos_s(_msg), 0));
goto again;
case mos_bc_rcvr: /* msg | msg->rcvr */
(void) POP();
PUSH(mos_exprSend(mos_undef, mos_s(self), 0));
goto again;
case mos_bc_rcvrSet: /* msg value | value */
sel = POP();
TOP = mos_exprSend(mos_undef, mos_s(self_), 1, sel);
goto again;
case mos_bc_arg_: /* | args[I] */
sel = args[ARG()];
PUSH(mos_exprSend(mos_undef, sel, 0));
goto again;
case mos_bc_argSet_: /* x | rcvr */
sel = args[ARG()];
sel = mos_setter_selector(sel);
TOP = mos_exprSend(mos_undef, sel, 1, TOP);
goto again;
case mos_bc_locs_: /* | ... */
goto again;
case mos_bc_loc_: /* | local[I] */
sel = locals[ARG() - 1];
PUSH(mos_exprSend(mos_undef, sel, 0));
goto again;
case mos_bc_locSet_: /* locSet:<i> value | */
sel = locals[ARG() - 1];
sel = mos_setter_selector(sel);
TOP = mos_exprSend(mos_undef, sel, 1, TOP);
goto again;
case mos_bc_lit_: /* | constant[I] */
PUSH(mos_exprConstant(constants[ARG()]));
goto again;
case mos_bc_memo_:
case mos_bc_memoval_:
/* IMPLIMENT */
goto again;
case mos_bc_send_: /* sel rcvr args ... | result */
{
int nargs = ARG();
mos_value sel = POP();
mos_value rcvr = POP();
mos_value args = mos_vector_make(nargs, sp);
rcvr = mos_exprSendV(rcvr, sel, args);
POPN(nargs);
PUSH(rcvr);
}
goto again;
case mos_bc_sendDir_: /* sel cntx rcvr args ... | result */
{
int nargs = ARG();
mos_value sel = POP();
mos_value cntx = POP();
mos_value rcvr = POP();
mos_value args = mos_vector_make(nargs, sp);
rcvr = mos_exprSend_V(cntx, rcvr, sel, args);
POPN(nargs);
PUSH(rcvr);
}
goto again;
default:
fprintf(stderr, "\n:bcDecomp.c: unknown bytecode %d\n", pc[-1]);
break;
}
sp = fp;
/* Create a exprMethod object */
{
mos_value args = mos_send(meth, mos_s(arguments));
mos_value locals = mos_send(meth, mos_s(locals));
mos_return(mos_exprMethod(args, locals, body));
}
}