PRIVATE int real_isa(OBJECT x, OBJECT y) {
while (1) {
if (x == NULL)
return 0;
if (x == y)
return 1;
if (x->parents == NULL)
return 0;
if (OBJECTP(x->parents)) {
x = (OBJECT) x->parents;
continue;
}
if (VECTORP(x->parents)) {
int i;
VECTOR vxp = (VECTOR) x->parents;
for (i = 0; i < vxp->_.length; i++)
if (real_isa((OBJECT) AT(vxp, i), y))
return 1;
return 0;
}
return 0;
}
}
at *with_object(at *p, at *f, at *q, int howfar)
{
assert(howfar>=0);
MM_ENTER;
at *ans = NIL;
if (OBJECTP(p)) {
object_t *obj = Mptr(p);
class_t *cl = Class(obj->backptr);
if (howfar > cl->num_slots)
howfar = cl->num_slots;
/* push object environment */
for (int i = 0; i<howfar; i++) {
Symbol(cl->slots[i]) = symbol_push(Symbol(cl->slots[i]), 0 , &(obj->slots[i]));
if (i < cl->num_cslots)
MARKVAR_SYMBOL(Symbol(cl->slots[i]));
}
SYMBOL_PUSH(at_this, p);
LOCK_SYMBOL(Symbol(at_this));
ans = apply(f, q);
/* pop object environment */
SYMBOL_POP(at_this);
for (int i = 0; i<howfar; i++)
SYMBOL_POP(cl->slots[i]);
} else {
if (p == NIL)
printf("*** Warning\007 (with-object () ...)\n");
SYMBOL_PUSH(at_this, p);
ans = apply(f, q);
SYMBOL_POP(at_this);
}
MM_RETURN(ans);
}
PRIVATE BVECTOR getPrintString_body(VMSTATE vms, OBJ x, int depth) {
char buf[80];
if (x == NULL)
return newstring("null");
if (NUMP(x)) {
sprintf(buf, "%ld", (long) NUM(x));
return newstring(buf);
}
if (SINGLETONP(x)) {
if (x == true) return newstring("true");
if (x == false) return newstring("false");
if (x == undefined) return newstring("undefined");
return newstring("#<unknown-singleton>");
}
if (OBJECTP(x))
return newstring("#<object>");
if (BVECTORP(x))
return (BVECTOR) x;
if (OVECTORP(x)) {
OVECTOR ov = (OVECTOR) x;
switch (ov->type) {
case T_HASHTABLE: return newstring("#<hashtable>");
case T_SLOT: return newstring("#<slot>");
case T_METHOD: return newstring("#<method>");
case T_CLOSURE: return newstring("#<closure>");
case T_SYMBOL: return (BVECTOR) AT(ov, SY_NAME);
case T_PRIM: return bvector_concat(newstring("#<prim "),
bvector_concat((BVECTOR) AT((OVECTOR) AT(ov, PR_NAME),
SY_NAME),
newstring(">")));
case T_FRAME: return newstring("#<frame>");
case T_VMREGS: return newstring("#<vmregs>");
case T_CONNECTION: return newstring("#<connection>");
case T_CONTINUATION: return newstring("#<continuation>");
case T_USERHASHLINK: return newstring("#<hashlink>");
default: return newstring("#<unknown-ovector-type>");
}
}
if (VECTORP(x)) {
if (depth < 5) {
VECTOR v = (VECTOR) x;
BVECTOR result = newstring("[");
int i;
for (i = 0; i < (int) x->length - 1; i++) {
result = bvector_concat(result, getPrintString_body(vms, AT(v, i), depth + 1));
result = bvector_concat(result, newstring(", "));
}
if (x->length > 0)
result = bvector_concat(result, getPrintString_body(vms, AT(v, x->length - 1), depth + 1));
return bvector_concat(result, newstring("]"));
} else
return newstring("[...]");
}
return newstring("unhandled-type-getPrintString");
}
PUBLIC int run_vm(VMSTATE vms) {
OBJ vm_hold; /* Holding register. NOT SEEN BY GC */
int ticks_left = VM_TIMESLICE_TICKS;
while (vms->c.vm_state != VM_STATE_DYING && ticks_left-- && vms->r->vm_acc != yield_thread) {
if (vms->c.vm_state > 0) {
vms->c.vm_state--;
if (vms->c.vm_state == 0) {
/* Quota expired. Warn. */
vms->c.vm_state = VM_DEFAULT_CPU_QUOTA;
vm_raise(vms, (OBJ) newsym("quota-expired"), NULL);
/* Make sure we don't recurse :-) */
vms->r->vm_trap_closure = NULL;
}
}
gc_reach_safepoint();
#ifdef DEBUG
debug_dump_instr( vms->r->vm_code->vec , vms->c.vm_ip );
#endif
switch (CODEAT(vms->c.vm_ip)) {
case OP_AT: {
int index = CODEAT(vms->c.vm_ip + 1);
if (index < 0 || index >= vms->r->vm_acc->length) {
vm_raise(vms, (OBJ) newsym("range-check-error"), vms->r->vm_acc);
break;
}
if (!VECTORP(vms->r->vm_acc)) {
vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc);
break;
}
vms->r->vm_acc = AT((VECTOR) vms->r->vm_acc, index);
vms->c.vm_ip += 2;
break;
}
case OP_ATPUT: {
int index = CODEAT(vms->c.vm_ip + 1);
vm_hold = PEEK();
if (index < 0 || index >= vm_hold->length) {
vm_raise(vms, (OBJ) newsym("range-check-error"), vm_hold);
break;
}
if (!VECTORP(vm_hold)) {
vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vm_hold);
break;
}
ATPUT((VECTOR) vm_hold, index, vms->r->vm_acc);
vms->c.vm_ip += 2;
break;
}
case OP_MOV_A_LOCL: {
int i = CODEAT(vms->c.vm_ip + 1);
vm_hold = (OBJ) vms->r->vm_env;
while (i-- > 0) vm_hold = AT((VECTOR) vm_hold, 0);
vms->r->vm_acc = AT((VECTOR) vm_hold, CODEAT(vms->c.vm_ip + 2) + 1);
vms->c.vm_ip += 3;
break;
}
case OP_MOV_A_GLOB:
vm_hold = AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1));
vms->r->vm_acc = AT((OVECTOR) vm_hold, SY_VALUE);
vms->c.vm_ip += 2;
break;
case OP_MOV_A_SLOT: {
OVECTOR slot, slotname;
if (!OBJECTP(vms->r->vm_acc)) {
vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc);
break;
}
slotname = (OVECTOR) AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1));
if (!O_CAN_X((OBJECT) vms->r->vm_acc, vms->r->vm_effuid)) {
NOPERMISSION((OBJ) slotname);
}
slot = findslot((OBJECT) vms->r->vm_acc, slotname, NULL);
if (slot == NULL) {
vm_raise(vms, (OBJ) newsym("slot-not-found"), (OBJ) slotname);
break;
}
if (!MS_CAN_R(slot, vms->r->vm_effuid)) {
NOPERMISSION((OBJ) slotname);
}
vms->r->vm_acc = AT(slot, SL_VALUE);
vms->c.vm_ip += 2;
break;
}
case OP_MOV_A_LITL:
vms->r->vm_acc = AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1));
vms->c.vm_ip += 2;
break;
case OP_MOV_A_SELF: vms->r->vm_acc = (OBJ) vms->r->vm_self; vms->c.vm_ip++; break;
case OP_MOV_A_FRAM: vms->r->vm_acc = (OBJ) vms->r->vm_frame; vms->c.vm_ip++; break;
case OP_MOV_LOCL_A: {
int i = CODEAT(vms->c.vm_ip + 1);
vm_hold = (OBJ) vms->r->vm_env;
while (i-- > 0) vm_hold = AT((VECTOR) vm_hold, 0);
ATPUT((VECTOR) vm_hold, CODEAT(vms->c.vm_ip + 2) + 1, vms->r->vm_acc);
vms->c.vm_ip += 3;
break;
}
case OP_MOV_GLOB_A:
if (!PRIVILEGEDP(vms->r->vm_effuid)) {
NOPERMISSION((OBJ) newsym("setting-global-value"));
}
vm_hold = AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1));
ATPUT((OVECTOR) vm_hold, SY_VALUE, vms->r->vm_acc);
vms->c.vm_ip += 2;
break;
case OP_MOV_SLOT_A: {
OVECTOR slot, slotname;
OBJECT target = (OBJECT) POP();
OBJECT foundin;
if (!OBJECTP(target)) {
vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), (OBJ) target);
break;
}
slotname = (OVECTOR) AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1));
if (!O_CAN_X(target, vms->r->vm_effuid)) {
NOPERMISSION((OBJ) slotname);
}
slot = findslot(target, slotname, &foundin);
if (slot == NULL) {
vm_raise(vms, (OBJ) newsym("slot-not-found"), (OBJ) slotname);
break;
}
if (!MS_CAN_W(slot, vms->r->vm_effuid)) {
NOPERMISSION((OBJ) slotname);
}
if (foundin == target) {
ATPUT(slot, SL_VALUE, vms->r->vm_acc);
} else {
OVECTOR newslot = addslot(target, slotname, (OBJECT) AT(slot, SL_OWNER));
ATPUT(newslot, SL_FLAGS, AT(slot, SL_FLAGS));
ATPUT(newslot, SL_VALUE, vms->r->vm_acc);
}
vms->c.vm_ip += 2;
break;
}
case OP_MOV_FRAM_A:
if (!PRIVILEGEDP(vms->r->vm_effuid)) {
NOPERMISSION((OBJ) newsym("restoring-vm-frame-pointer"));
}
if (!OVECTORP(vms->r->vm_acc) || ((OVECTOR) vms->r->vm_acc)->type != T_FRAME) {
vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc);
break;
}
vms->r->vm_frame = (OVECTOR) vms->r->vm_acc;
vms->c.vm_ip++;
break;
case OP_PUSH: PUSH(vms->r->vm_acc); vms->c.vm_ip++; break;
case OP_POP: vms->r->vm_acc = POP(); vms->c.vm_ip++; break;
case OP_SWAP:
vm_hold = POP();
PUSH(vms->r->vm_acc);
vms->r->vm_acc = vm_hold;
vms->c.vm_ip++;
break;
case OP_VECTOR:
vms->r->vm_acc = (OBJ) newvector(CODEAT(vms->c.vm_ip+1));
vms->c.vm_ip += 2;
break;
case OP_ENTER_SCOPE:
vm_hold = (OBJ) newvector(CODEAT(vms->c.vm_ip+1) + 1);
ATPUT((VECTOR) vm_hold, 0, (OBJ) vms->r->vm_env);
vms->r->vm_env = (VECTOR) vm_hold;
vms->c.vm_ip += 2;
break;
case OP_LEAVE_SCOPE:
vms->r->vm_env = (VECTOR) AT(vms->r->vm_env, 0);
vms->c.vm_ip++;
break;
case OP_MAKE_VECTOR: {
int i = 0;
int len = CODEAT(vms->c.vm_ip+1);
VECTOR vec = newvector_noinit(len);
for (i = len - 1; i >= 0; i--)
ATPUT(vec, i, POP());
vms->r->vm_acc = (OBJ) vec;
vms->c.vm_ip += 2;
break;
}
case OP_CLOSURE:
vms->r->vm_acc = make_closure_from((OVECTOR) vms->r->vm_acc,
vms->r->vm_self,
vms->r->vm_env,
vms->r->vm_effuid);
vms->c.vm_ip++;
break;
case OP_METHOD_CLOSURE: {
OVECTOR methname = (OVECTOR) AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1));
OVECTOR method;
if (!OBJECTP(vms->r->vm_acc)) {
vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc);
break;
}
method = findmethod((OBJECT) vms->r->vm_acc, methname);
if (method == NULL) {
vm_raise(vms, (OBJ) newsym("method-not-found"), (OBJ) methname);
break;
}
if (!MS_CAN_R(method, vms->r->vm_effuid)) {
NOPERMISSION((OBJ) methname);
}
vm_hold = (OBJ) newovector(CL_MAXSLOTINDEX, T_CLOSURE);
ATPUT((OVECTOR) vm_hold, CL_METHOD, (OBJ) method);
ATPUT((OVECTOR) vm_hold, CL_SELF, vms->r->vm_acc);
vms->r->vm_acc = vm_hold;
vms->c.vm_ip += 2;
break;
}
case OP_RET:
if (vms->r->vm_frame != NULL) {
restoreframe(vms, vms->r->vm_frame);
if (vms->r->vm_code != NULL)
break;
}
vms->c.vm_state = VM_STATE_DYING;
return 1; /* finished, nothing more to run! */
case OP_CALL: {
OVECTOR methname = (OVECTOR) AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1));
OVECTOR method;
if (vms->r->vm_acc == NULL || TAGGEDP(vms->r->vm_acc)) {
vm_raise(vms,
(OBJ) newsym("null-call-error"),
AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip+1)));
break;
}
if (!OBJECTP(vms->r->vm_acc)) {
vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc);
break;
}
method = findmethod((OBJECT) vms->r->vm_acc, methname);
if (method == NULL) {
vm_raise(vms, (OBJ) newsym("method-not-found"), (OBJ) methname);
break;
}
if (!MS_CAN_X(method, vms->r->vm_effuid)) {
NOPERMISSION((OBJ) methname);
}
vm_hold = POP();
if (vm_hold->length-1 != NUM(AT(method, ME_ARGC))) {
vm_raise(vms, (OBJ) newsym("wrong-argc"), (OBJ) methname);
break;
}
vms->c.vm_ip += 2;
push_frame(vms);
vms->r->vm_env = (VECTOR) vm_hold;
ATPUT(vms->r->vm_env, 0, AT(method, ME_ENV));
vms->r->vm_code = (BVECTOR) AT(method, ME_CODE);
vms->r->vm_lits = (VECTOR) AT(method, ME_LITS);
vms->r->vm_self = (OBJECT) vms->r->vm_acc;
if (NUM(AT(method, ME_FLAGS)) & O_SETUID)
vms->r->vm_effuid = (OBJECT) AT(method, ME_OWNER);
vms->r->vm_method = method;
vms->c.vm_ip = 0;
break;
}
case OP_CALL_AS: {
OVECTOR methname = (OVECTOR) AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip + 1));
OVECTOR method;
if (vms->r->vm_self == NULL ||
vms->r->vm_acc == NULL || TAGGEDP(vms->r->vm_acc)) {
vm_raise(vms,
(OBJ) newsym("null-call-error"),
AT(vms->r->vm_lits, CODEAT(vms->c.vm_ip+1)));
break;
}
if (!OBJECTP(vms->r->vm_acc)) {
vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc);
break;
}
method = findmethod((OBJECT) vms->r->vm_acc, methname);
if (method == NULL) {
vm_raise(vms, (OBJ) newsym("method-not-found"), (OBJ) methname);
break;
}
if (!MS_CAN_X(method, vms->r->vm_effuid)) {
NOPERMISSION((OBJ) methname);
}
vm_hold = POP();
if (vm_hold->length-1 != NUM(AT(method, ME_ARGC))) {
vm_raise(vms, (OBJ) newsym("wrong-argc"), (OBJ) methname);
break;
}
vms->c.vm_ip += 2;
push_frame(vms);
vms->r->vm_env = (VECTOR) vm_hold;
ATPUT(vms->r->vm_env, 0, AT(method, ME_ENV));
vms->r->vm_code = (BVECTOR) AT(method, ME_CODE);
vms->r->vm_lits = (VECTOR) AT(method, ME_LITS);
/* don't set vm_self, this is OP_CALL_AS. */
/* vms->r->vm_self = vms->r->vm_acc; */
if (NUM(AT(method, ME_FLAGS)) & O_SETUID)
vms->r->vm_effuid = (OBJECT) AT(method, ME_OWNER);
vms->r->vm_method = method;
vms->c.vm_ip = 0;
break;
}
case OP_APPLY:
vms->c.vm_ip++;
apply_closure(vms, (OVECTOR) vms->r->vm_acc, (VECTOR) POP());
break;
case OP_JUMP: vms->c.vm_ip += 3 + ((int16_t) CODE16AT(vms->c.vm_ip+1)); break;
case OP_JUMP_TRUE:
vms->c.vm_ip += (vms->r->vm_acc == false) ? 3 :
3 + ((int16_t) CODE16AT(vms->c.vm_ip+1));
break;
case OP_JUMP_FALSE:
vms->c.vm_ip += (vms->r->vm_acc != false) ? 3 :
3 + ((int16_t) CODE16AT(vms->c.vm_ip+1));
break;
case OP_NOT:
vms->r->vm_acc = (vms->r->vm_acc == false) ? true : false;
vms->c.vm_ip++;
break;
case OP_EQ:
vms->r->vm_acc = (vms->r->vm_acc == POP()) ? true : false;
vms->c.vm_ip++;
break;
case OP_NE:
vms->r->vm_acc = (vms->r->vm_acc != POP()) ? true : false;
vms->c.vm_ip++;
break;
NUMOP(OP_GT, vms->r->vm_acc = (NUM(vms->r->vm_acc) < NUM(POP())) ? true : false);
NUMOP(OP_LT, vms->r->vm_acc = (NUM(vms->r->vm_acc) > NUM(POP())) ? true : false);
NUMOP(OP_GE, vms->r->vm_acc = (NUM(vms->r->vm_acc) <= NUM(POP())) ? true : false);
NUMOP(OP_LE, vms->r->vm_acc = (NUM(vms->r->vm_acc) >= NUM(POP())) ? true : false);
NUMOP(OP_NEG, vms->r->vm_acc = MKNUM(-NUM(vms->r->vm_acc)));
NUMOP(OP_BNOT, vms->r->vm_acc = MKNUM(~NUM(vms->r->vm_acc)));
NUMOP(OP_BOR, vms->r->vm_acc = MKNUM(NUM(vms->r->vm_acc)|NUM(POP())));
NUMOP(OP_BAND, vms->r->vm_acc = MKNUM(NUM(vms->r->vm_acc)&NUM(POP())));
case OP_PLUS:
if (vms->r->vm_acc == NULL || PEEK() == NULL) {
vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc);
break;
}
if (NUMP(vms->r->vm_acc) && NUMP(PEEK()))
vms->r->vm_acc = MKNUM(NUM(vms->r->vm_acc)+NUM(POP()));
else if (TAGGEDP(vms->r->vm_acc) || TAGGEDP(PEEK())) {
vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc);
break;
} else if (BVECTORP(vms->r->vm_acc) && BVECTORP(PEEK()))
vms->r->vm_acc = (OBJ) bvector_concat((BVECTOR) POP(), (BVECTOR) vms->r->vm_acc);
else if (VECTORP(vms->r->vm_acc) && VECTORP(PEEK()))
vms->r->vm_acc = (OBJ) vector_concat((VECTOR) POP(), (VECTOR) vms->r->vm_acc);
else {
vm_raise(vms, (OBJ) newsym("vm-runtime-type-error"), vms->r->vm_acc);
break;
}
vms->c.vm_ip++;
break;
NUMOP(OP_MINUS, vms->r->vm_acc = MKNUM(NUM(POP())-NUM(vms->r->vm_acc)));
NUMOP(OP_STAR, vms->r->vm_acc = MKNUM(NUM(POP())*NUM(vms->r->vm_acc)));
NUMOP(OP_SLASH,
if (vms->r->vm_acc == MKNUM(0))
vm_raise(vms, (OBJ) newsym("divide-by-zero"), NULL);
else
vms->r->vm_acc = MKNUM(NUM(POP())/NUM(vms->r->vm_acc)));
NUMOP(OP_PERCENT,
if (vms->r->vm_acc == MKNUM(0))
vm_raise(vms, (OBJ) newsym("divide-by-zero"), NULL);
else
vms->r->vm_acc = MKNUM(NUM(POP())%NUM(vms->r->vm_acc)));
default:
fprintf(stderr, "Unknown bytecode reached (%d == 0x%x).\n",
CODEAT(vms->c.vm_ip),
CODEAT(vms->c.vm_ip));
exit(MOVE_EXIT_PROGRAMMER_FUCKUP);
}
}
return vms->c.vm_state == VM_STATE_DYING;
}