PUBLIC INLINE void apply_closure(VMSTATE vms, OVECTOR closure, VECTOR argvec) {
if (closure == NULL || TAGGEDP(closure)) {
vm_raise(vms, (OBJ) newsym("invalid-callable"), (OBJ) closure);
} else if (closure->type == T_PRIM) {
int primargc;
prim_fn fnp = lookup_prim(NUM(AT(closure, PR_NUMBER)), &primargc);
if (fnp != NULL) {
if ((primargc >= 0 && argvec->_.length-1 != primargc) ||
(primargc < 0 && argvec->_.length-1 < -primargc))
vm_raise(vms, (OBJ) newsym("wrong-argc"), (OBJ) closure);
else
vms->r->vm_acc = fnp(vms, argvec);
} else
vm_raise(vms, (OBJ) newsym("invalid-primitive"), AT(closure, PR_NUMBER));
} else if (closure->type == T_CLOSURE) {
OVECTOR meth = (OVECTOR) AT(closure, CL_METHOD);
if (!MS_CAN_X(meth, vms->r->vm_effuid)) {
vm_raise(vms, (OBJ) newsym("no-permission"), AT(meth, ME_NAME));
return;
}
if (argvec->_.length-1 != NUM(AT(meth, ME_ARGC))) {
vm_raise(vms, (OBJ) newsym("wrong-argc"), (OBJ) meth);
return;
}
push_frame(vms);
vms->r->vm_env = argvec;
ATPUT(vms->r->vm_env, 0, AT(meth, ME_ENV));
vms->r->vm_lits = (VECTOR) AT(meth, ME_LITS);
vms->r->vm_code = (BVECTOR) AT(meth, ME_CODE);
vms->r->vm_self = (OBJECT) AT(closure, CL_SELF);
vms->c.vm_ip = 0;
vms->r->vm_method = meth;
if (NUM(AT(meth, ME_FLAGS)) & O_SETUID)
vms->r->vm_effuid = (OBJECT) AT(meth, ME_OWNER);
} else if (closure->type == T_CONTINUATION) {
int i;
VECTOR cstk = (VECTOR) AT(closure, CONT_STACK);
for (i = 0; i < cstk->_.length; i++)
ATPUT(vms->r->vm_stack, i, AT(cstk, i));
vms->c.vm_top = cstk->_.length;
restoreframe(vms, (OVECTOR) AT(closure, CONT_FRAME));
vms->r->vm_acc = AT(argvec, 1);
} else {
vm_raise(vms, (OBJ) newsym("invalid-callable"), (OBJ) closure);
}
}
PRIVATE void compile_main(FILE *conni, FILE *conno) {
REPL_DATA rd = allocmem(sizeof(repl_data));
VMstate vms;
rd->h1 = rd->h2 = NULL;
protect(&rd->h1);
protect(&rd->h2);
rd->vmregs = (VMREGS) newvector(NUM_VMREGS); /* dodgy casting :-) */
vms.r = rd->vmregs;
protect((OBJ *)(&rd->vmregs));
init_vm(&vms);
vms.c.vm_state = VM_STATE_NOQUOTA;
while (vms.c.vm_state != VM_STATE_DYING) {
ScanInst si;
char buf[16384];
rd->h1 = (OBJ) newbvector(0);
while (1) {
char *result;
result = fgets(buf, 256, conni);
if (result == NULL)
break;
while (1) {
int l = strlen(buf);
if (buf[l-1] == '\r' || buf[l-1] == '\n')
buf[l-1] = '\0';
else
break;
}
strcat(buf, "\n");
if (!strcmp(buf, ".\n"))
break;
rd->h2 = (OBJ) newstring(buf);
rd->h1 = (OBJ) bvector_concat((BVECTOR) rd->h1, (BVECTOR) rd->h2);
}
gc_reach_safepoint();
rd->h2 = (OBJ) newstringconn((BVECTOR) rd->h1);
fill_scaninst(&si, (OVECTOR) rd->h2);
while (!conn_closed((OVECTOR) rd->h2)) {
rd->h1 = (OBJ) parse(&vms, &si);
gc_reach_safepoint();
if (rd->h1 == NULL) {
sprintf(buf, "-->! the compiler returned NULL.\n");
} else {
vms.c.vm_state = VM_STATE_NOQUOTA;
ATPUT((OVECTOR) rd->h1, ME_OWNER, (OBJ) vms.r->vm_uid);
vms.r->vm_effuid = vms.r->vm_uid;
{
OVECTOR c = newovector_noinit(CL_MAXSLOTINDEX, T_CLOSURE);
ATPUT(c, CL_SELF, NULL);
ATPUT(c, CL_METHOD, rd->h1);
rd->h1 = (OBJ) c;
}
apply_closure(&vms, (OVECTOR) rd->h1, newvector_noinit(1));
while (!run_vm(&vms)) ;
rd->h1 = (OBJ) newvector(2);
ATPUT((VECTOR) rd->h1, 0, NULL);
ATPUT((VECTOR) rd->h1, 1, vms.r->vm_acc);
rd->h1 = lookup_prim(0x00001, NULL)(&vms, (VECTOR) rd->h1);
rd->h1 = (OBJ) bvector_concat((BVECTOR) rd->h1, newbvector(1));
/* terminates C-string */
gc_reach_safepoint();
sprintf(buf, "--> %s\n", ((BVECTOR) rd->h1)->vec);
}
fputs(buf, conno);
}
}
unprotect((OBJ *)(&rd->vmregs));
unprotect(&rd->h2);
unprotect(&rd->h1);
freemem(rd);
}
