scm_closure_t
VM::lookup_system_closure(const char* name)
{
scm_obj_t proc = m_heap->lookup_system_environment(make_symbol(m_heap, name));
if (CLOSUREP(proc)) return (scm_closure_t)proc;
fatal("fatal: #<closure %s> not available in system environment", name);
}
static void fast_read_macro(lref_t reader, lref_t * retval)
{
lref_t macro_transformer;
fast_read(reader, ¯o_transformer, false);
if (!CLOSUREP(macro_transformer))
vmerror_fast_read("malformed macro, bad transformer", macro_transformer, false);
*retval = macrocons(macro_transformer);
}
// spawn
scm_obj_t
subr_spawn(VM* vm, int argc, scm_obj_t argv[])
{
#if USE_PARALLEL_VM
if (argc >= 1) {
if (CLOSUREP(argv[0])) {
vm->m_interp->update(vm, VM_STATE_BLOCK);
int n = vm->m_interp->spawn(vm, (scm_closure_t)argv[0], argc - 1, argv + 1);
vm->m_interp->update(vm, VM_STATE_ACTIVE);
if (n < 0) return scm_timeout;
return MAKEFIXNUM(n);
}
wrong_type_argument_violation(vm, "spawn", 0, "closure", argv[0], argc, argv);
return scm_undef;
}
wrong_number_of_arguments_violation(vm, "spawn", 1, -1, argc, argv);
return scm_undef;
#else
fatal("%s:%u spawn not supported on this build", __FILE__, __LINE__);
#endif
}
EVAL_INLINE lref_t apply(lref_t function, size_t argc, lref_t argv[], lref_t *env, lref_t *retval)
{
lref_t args[3];
if (SUBRP(function)) {
return subr_apply(function, argc, argv, env, retval);
} else if (CLOSUREP(function)) {
lref_t c_code = CLOSURE_CODE(function);
*env = extend_env(arg_list_from_buffer(argc, argv),
CAR(c_code),
CLOSURE_ENV(function));
return CDR(c_code); /* tail call */
} else if (argc > 0) {
if (HASHP(function) || STRUCTUREP(function)) {
args[0] = function;
args[1] = argv[0];
args[2] = (argc > 1) ? argv[1] : NIL;
*retval = lslot_ref(MAX2(argc + 1, 2), args);
return NIL;
} else if (SYMBOLP(function)) {
if (HASHP(argv[0]) || STRUCTUREP(argv[0])) {
args[0] = argv[0];
args[1] = function;
args[2] = (argc > 1) ? argv[1] : NIL;
*retval = lslot_ref(MAX2(argc + 1, 2), args);
return NIL;
}
}
}
vmerror_wrong_type(function);
return NIL;
}
static void fast_read_loader_application(lref_t reader, enum fasl_opcode_t opcode)
{
assert(FASL_READER_P(reader));
size_t argc = 0;
lref_t argv[FAST_LOAD_STACK_DEPTH];
fast_read(reader, &argv[0], false);
if (!(SUBRP(argv[0]) || CLOSUREP(argv[0])))
vmerror_fast_read(_T("Invalid function to apply"), reader, NIL);
if (opcode == FASL_OP_LOADER_APPLYN)
{
lref_t ac;
fast_read(reader, &ac, false);
if (!FIXNUMP(ac))
vmerror_fast_read("Expected fixnum for loader application argc", reader, ac);
argc = (size_t)FIXNM(ac);
if (argc > FAST_LOAD_STACK_DEPTH) /* Assuming FAST_LOAD_STACK_DEPTH <= ARG_BUF_LEN - 2 */
vmerror_fast_read("Loader application, argc < FAST_LOAD_STACK_DEPTH", reader, ac);
for(size_t ii = 0; ii < argc; ii++)
argv[ii + 1] = fast_loader_stack_pop(reader);
/* Fake a final NIL argument so that we can pass in the argv arguments
* as scalars rather than as a list. */
argc++;
argv[argc] = NIL;
}
else if (opcode != FASL_OP_LOADER_APPLY0)
panic("invalid opcode in fast_read_loader_application");
dscwritef(DF_SHOW_FAST_LOAD_FORMS, (_T("; DEBUG: FASL applying ~s (argc=~cd)\n"), argv[0], argc));
FASL_READER_STREAM(reader)->accum = lapply(argc + 1, argv);
}
EVAL_INLINE lref_t apply(lref_t function,
size_t argc, lref_t argv[],
lref_t * env, lref_t * retval)
{
if (SUBRP(function))
return subr_apply(function, argc, argv, env, retval);
if (CLOSUREP(function))
{
lref_t c_code = CLOSURE_CODE(function);
*env = extend_env(arg_list_from_buffer(argc, argv),
CAR(c_code),
CLOSURE_ENV(function));
return CDR(c_code); /* tail call */
}
vmerror_wrong_type(function);
return NIL;
}
