static SCM fetch_node(SCM smob, SCM args) {
MAKE_NODE * node;
SCM payload;
char *buf;
node = (MAKE_NODE *)SCM_SMOB_DATA(smob);
scm_lock_mutex(node->mutex);
if (!node->dirty) {
payload = node->payload;
scm_unlock_mutex(node->mutex);
return payload;
}
//log_msg("REGENERATE %08x\n", (unsigned long)smob);
node->dirty = 0;
switch (node->type) {
case TYPE_DATUM: break;
case TYPE_FILE:
buf = load_from_file(node->filepath);
if (buf != NULL)
node->payload = scm_take_locale_string(buf);
else node->payload = SCM_BOOL_F;
break;
case TYPE_CHAIN:
node->payload = scm_apply_0(node->callback, args);
break;
}
payload = node->payload;
scm_unlock_mutex(node->mutex);
scm_remember_upto_here_2(smob, args);
scm_remember_upto_here_1(payload);
return payload;
}
VISIBLE SCM
scm_raise_gsl_error (SCM arguments)
{
return
scm_apply_0 (scm_c_public_ref ("sortsmill math gsl", "raise-gsl-error"),
arguments);
}
SCM
scm_for_each (SCM proc, SCM arg1, SCM args)
{
static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
scm_i_pthread_once (&once, init_for_each_var);
return scm_apply_0 (scm_variable_ref (for_each_var),
scm_cons (proc, scm_cons (arg1, args)));
}
SCM
scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
{
return scm_apply_0 (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)));
}
SCM
scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
{
return scm_apply_0 (proc, scm_cons2 (arg1, arg2, args));
}
SCM
scm_apply_1 (SCM proc, SCM arg1, SCM args)
{
return scm_apply_0 (proc, scm_cons (arg1, args));
}
static SCM
eval (SCM x, SCM env)
{
SCM mx;
SCM proc = SCM_UNDEFINED, args = SCM_EOL;
unsigned int argc;
loop:
SCM_TICK;
mx = SCM_MEMOIZED_ARGS (x);
switch (SCM_I_INUM (SCM_CAR (x)))
{
case SCM_M_SEQ:
eval (CAR (mx), env);
x = CDR (mx);
goto loop;
case SCM_M_IF:
if (scm_is_true (EVAL1 (CAR (mx), env)))
x = CADR (mx);
else
x = CDDR (mx);
goto loop;
case SCM_M_LET:
{
SCM inits = CAR (mx);
SCM new_env;
int i;
new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED, env);
for (i = 0; i < VECTOR_LENGTH (inits); i++)
env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env));
env = new_env;
x = CDR (mx);
goto loop;
}
case SCM_M_LAMBDA:
RETURN_BOOT_CLOSURE (mx, env);
case SCM_M_CAPTURE_ENV:
{
SCM locs = CAR (mx);
SCM new_env;
int i;
new_env = make_env (VECTOR_LENGTH (locs), SCM_BOOL_F, env);
for (i = 0; i < VECTOR_LENGTH (locs); i++)
{
SCM loc = VECTOR_REF (locs, i);
int depth, width;
depth = SCM_I_INUM (CAR (loc));
width = SCM_I_INUM (CDR (loc));
env_set (new_env, 0, i, env_ref (env, depth, width));
}
env = new_env;
x = CDR (mx);
goto loop;
}
case SCM_M_QUOTE:
return mx;
case SCM_M_CAPTURE_MODULE:
return eval (mx, scm_current_module ());
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
/* Evaluate the argument holding the list of arguments */
args = EVAL1 (CADR (mx), env);
apply_proc:
/* Go here to tail-apply a procedure. PROC is the procedure and
* ARGS is the list of arguments. */
if (BOOT_CLOSURE_P (proc))
{
prepare_boot_closure_env_for_apply (proc, args, &x, &env);
goto loop;
}
else
return scm_apply_0 (proc, args);
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
argc = scm_ilength (CDR (mx));
mx = CDR (mx);
if (BOOT_CLOSURE_P (proc))
{
prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
goto loop;
}
else
{
SCM *argv;
unsigned int i;
argv = alloca (argc * sizeof (SCM));
for (i = 0; i < argc; i++, mx = CDR (mx))
argv[i] = EVAL1 (CAR (mx), env);
return scm_call_n (proc, argv, argc);
}
case SCM_M_CONT:
return scm_i_call_with_current_continuation (EVAL1 (mx, env));
case SCM_M_CALL_WITH_VALUES:
{
SCM producer;
SCM v;
producer = EVAL1 (CAR (mx), env);
/* `proc' is the consumer. */
proc = EVAL1 (CDR (mx), env);
v = scm_call_0 (producer);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
else
args = scm_list_1 (v);
goto apply_proc;
}
case SCM_M_LEXICAL_REF:
{
SCM pos;
int depth, width;
pos = mx;
depth = SCM_I_INUM (CAR (pos));
width = SCM_I_INUM (CDR (pos));
return env_ref (env, depth, width);
}
case SCM_M_LEXICAL_SET:
{
SCM pos;
int depth, width;
SCM val = EVAL1 (CDR (mx), env);
pos = CAR (mx);
depth = SCM_I_INUM (CAR (pos));
width = SCM_I_INUM (CDR (pos));
env_set (env, depth, width, val);
return SCM_UNSPECIFIED;
}
case SCM_M_BOX_REF:
{
SCM box = mx;
return scm_variable_ref (EVAL1 (box, env));
}
case SCM_M_BOX_SET:
{
SCM box = CAR (mx), val = CDR (mx);
return scm_variable_set_x (EVAL1 (box, env), EVAL1 (val, env));
}
case SCM_M_RESOLVE:
if (SCM_VARIABLEP (mx))
return mx;
else
{
SCM var;
var = scm_sys_resolve_variable (mx, env_tail (env));
scm_set_cdr_x (x, var);
return var;
}
case SCM_M_CALL_WITH_PROMPT:
{
struct scm_vm *vp;
SCM k, handler, res;
scm_i_jmp_buf registers;
scm_t_ptrdiff saved_stack_depth;
k = EVAL1 (CAR (mx), env);
handler = EVAL1 (CDDR (mx), env);
vp = scm_the_vm ();
saved_stack_depth = vp->stack_top - vp->sp;
/* Push the prompt onto the dynamic stack. */
scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
k,
vp->stack_top - vp->fp,
saved_stack_depth,
vp->ip,
®isters);
if (SCM_I_SETJMP (registers))
{
/* The prompt exited nonlocally. */
scm_gc_after_nonlocal_exit ();
proc = handler;
args = scm_i_prompt_pop_abort_args_x (vp, saved_stack_depth);
goto apply_proc;
}
res = scm_call_0 (eval (CADR (mx), env));
scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
return res;
}
default:
abort ();
}
}
/* This gets called from scm_internal_stack_catch when calling scm_apply. */
static SCM
gnm_guile_helper (void *data)
{
GnmGuileCallRec *ggcr = (GnmGuileCallRec *) data;
return scm_apply_0 (ggcr->function, ggcr->args);
}
