/*! \brief Add a directory to the Guile load path.
* \par Function Description
* Prepends \a s_path to the Guile system '%load-path', after
* expanding environment variables.
*
* \param [in] s_path Path to be added.
* \return SCM_BOOL_T.
*/
SCM g_rc_scheme_directory(SCM s_path)
{
char *temp;
gchar *expanded;
SCM s_load_path_var;
SCM s_load_path;
SCM_ASSERT (scm_is_string (s_path), s_path,
SCM_ARG1, "scheme-directory");
/* take care of any shell variables */
temp = scm_to_utf8_string (s_path);
expanded = s_expand_env_variables (temp);
s_path = scm_from_utf8_string (expanded);
free (temp);
g_free (expanded);
s_load_path_var = scm_c_lookup ("%load-path");
s_load_path = scm_variable_ref (s_load_path_var);
scm_variable_set_x (s_load_path_var, scm_cons (s_path, s_load_path));
scm_remember_upto_here_2 (s_load_path_var, s_load_path);
scm_remember_upto_here_1 (s_path);
return SCM_BOOL_T;
}
scm_t_bits
scm_dynstack_unwind_1 (scm_t_dynstack *dynstack)
{
scm_t_bits tag;
scm_t_bits *words;
scm_t_dynstack_item_type type;
tag = dynstack_pop (dynstack, &words);
type = SCM_DYNSTACK_TAG_TYPE (tag);
switch (type)
{
case SCM_DYNSTACK_TYPE_FRAME:
break;
case SCM_DYNSTACK_TYPE_UNWINDER:
WINDER_PROC (words) (WINDER_DATA (words));
clear_scm_t_bits (words, WINDER_WORDS);
break;
case SCM_DYNSTACK_TYPE_REWINDER:
clear_scm_t_bits (words, WINDER_WORDS);
break;
case SCM_DYNSTACK_TYPE_WITH_FLUID:
scm_swap_fluid (WITH_FLUID_FLUID (words),
WITH_FLUID_VALUE_BOX (words),
SCM_I_CURRENT_THREAD->dynamic_state);
clear_scm_t_bits (words, WITH_FLUID_WORDS);
break;
case SCM_DYNSTACK_TYPE_PROMPT:
/* we could invalidate the prompt */
clear_scm_t_bits (words, PROMPT_WORDS);
break;
case SCM_DYNSTACK_TYPE_DYNWIND:
{
SCM proc = DYNWIND_LEAVE (words);
clear_scm_t_bits (words, DYNWIND_WORDS);
scm_call_0 (proc);
}
break;
case SCM_DYNSTACK_TYPE_DYNAMIC_STATE:
scm_variable_set_x (DYNAMIC_STATE_STATE_BOX (words),
scm_set_current_dynamic_state
(scm_variable_ref (DYNAMIC_STATE_STATE_BOX (words))));
clear_scm_t_bits (words, DYNAMIC_STATE_WORDS);
break;
case SCM_DYNSTACK_TYPE_NONE:
default:
abort ();
}
return tag;
}
void
scm_dynstack_wind_1 (scm_t_dynstack *dynstack, scm_t_bits *item)
{
scm_t_bits tag = SCM_DYNSTACK_TAG (item);
scm_t_dynstack_item_type type = SCM_DYNSTACK_TAG_TYPE (tag);
scm_t_bits flags = SCM_DYNSTACK_TAG_FLAGS (tag);
size_t len = SCM_DYNSTACK_TAG_LEN (tag);
switch (type)
{
case SCM_DYNSTACK_TYPE_FRAME:
if (!(flags & SCM_F_DYNSTACK_FRAME_REWINDABLE))
scm_misc_error ("scm_dynstack_wind_1",
"cannot invoke continuation from this context",
SCM_EOL);
break;
case SCM_DYNSTACK_TYPE_UNWINDER:
break;
case SCM_DYNSTACK_TYPE_REWINDER:
WINDER_PROC (item) (WINDER_DATA (item));
break;
case SCM_DYNSTACK_TYPE_WITH_FLUID:
scm_swap_fluid (WITH_FLUID_FLUID (item),
WITH_FLUID_VALUE_BOX (item),
SCM_I_CURRENT_THREAD->dynamic_state);
break;
case SCM_DYNSTACK_TYPE_PROMPT:
/* see vm_reinstate_partial_continuation */
break;
case SCM_DYNSTACK_TYPE_DYNWIND:
scm_call_0 (DYNWIND_ENTER (item));
break;
case SCM_DYNSTACK_TYPE_DYNAMIC_STATE:
scm_variable_set_x (DYNAMIC_STATE_STATE_BOX (item),
scm_set_current_dynamic_state
(scm_variable_ref (DYNAMIC_STATE_STATE_BOX (item))));
break;
case SCM_DYNSTACK_TYPE_NONE:
default:
abort ();
}
{
scm_t_bits *words = push_dynstack_entry (dynstack, type, flags, len);
copy_scm_t_bits (words, item, len);
}
}
void
scm_dynstack_unwind_dynamic_state (scm_t_dynstack *dynstack,
scm_t_dynamic_state *dynamic_state)
{
scm_t_bits tag, *words;
size_t len;
tag = dynstack_pop (dynstack, &words);
len = SCM_DYNSTACK_TAG_LEN (tag);
assert (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_DYNAMIC_STATE);
assert (len == DYNAMIC_STATE_WORDS);
scm_variable_set_x (DYNAMIC_STATE_STATE_BOX (words),
scm_set_current_dynamic_state
(scm_variable_ref (DYNAMIC_STATE_STATE_BOX (words))));
clear_scm_t_bits (words, len);
}
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 ();
}
}
