/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,
- * 2005,2006,2007,2008,2009,2010,2011,2012,2013
+ * 2005,2006,2007,2008,2009,2010,2011,2012,2013,2014
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
#define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE (x))))
/* NB: One may only call the following accessors if the closure is not REST. */
#define BOOT_CLOSURE_IS_FULL(x) (1)
-#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt) \
+#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,ninits,unbound,alt) \
do { SCM fu = fu_; \
body = CAR (fu); fu = CDDR (fu); \
\
rest = kw = alt = SCM_BOOL_F; \
- inits = SCM_EOL; \
- nopt = 0; \
+ unbound = SCM_BOOL_F; \
+ nopt = ninits = 0; \
\
nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
if (scm_is_pair (fu)) \
{ \
nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
kw = CAR (fu); fu = CDR (fu); \
- inits = CAR (fu); fu = CDR (fu); \
+ ninits = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
+ unbound = CAR (fu); fu = CDR (fu); \
alt = CAR (fu); \
} \
} \
}
-SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
-
-static void error_used_before_defined (void)
-{
- scm_error (scm_unbound_variable_key, NULL,
- "Variable used before given a value", SCM_EOL, SCM_BOOL_F);
-}
-
static void error_invalid_keyword (SCM proc, SCM obj)
{
scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
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_DEFINE:
- scm_define (CAR (mx), EVAL1 (CDR (mx), env));
- return SCM_UNSPECIFIED;
-
case SCM_M_CAPTURE_MODULE:
return eval (mx, scm_current_module ());
goto loop;
}
else
- return scm_call_with_vm (scm_the_vm (), proc, args);
+ return scm_apply_0 (proc, args);
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
for (i = 0; i < argc; i++, mx = CDR (mx))
argv[i] = EVAL1 (CAR (mx), env);
- return scm_c_vm_run (scm_the_vm (), proc, argv, argc);
+ return scm_call_n (proc, argv, argc);
}
case SCM_M_CONT:
producer = EVAL1 (CAR (mx), env);
/* `proc' is the consumer. */
proc = EVAL1 (CDR (mx), env);
- v = scm_call_with_vm (scm_the_vm (), producer, SCM_EOL);
+ v = scm_call_0 (producer);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
else
case SCM_M_LEXICAL_REF:
{
- SCM pos, ret;
+ SCM pos;
int depth, width;
pos = mx;
depth = SCM_I_INUM (CAR (pos));
width = SCM_I_INUM (CDR (pos));
- ret = env_ref (env, depth, width);
-
- if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
- /* we don't know what variable, though, because we don't have its
- name */
- error_used_before_defined ();
- return ret;
+ return env_ref (env, depth, width);
}
case SCM_M_LEXICAL_SET:
return SCM_UNSPECIFIED;
}
- case SCM_M_TOPLEVEL_REF:
- if (SCM_VARIABLEP (mx))
- return SCM_VARIABLE_REF (mx);
- else
- {
- env = env_tail (env);
- return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x, env));
- }
+ case SCM_M_BOX_REF:
+ {
+ SCM box = mx;
- case SCM_M_TOPLEVEL_SET:
+ return scm_variable_ref (EVAL1 (box, env));
+ }
+
+ case SCM_M_BOX_SET:
{
- SCM var = CAR (mx);
- SCM val = EVAL1 (CDR (mx), env);
- if (SCM_VARIABLEP (var))
- {
- SCM_VARIABLE_SET (var, val);
- return SCM_UNSPECIFIED;
- }
- else
- {
- env = env_tail (env);
- SCM_VARIABLE_SET (scm_memoize_variable_access_x (x, env), val);
- return SCM_UNSPECIFIED;
- }
+ SCM box = CAR (mx), val = CDR (mx);
+
+ return scm_variable_set_x (EVAL1 (box, env), EVAL1 (val, env));
}
- case SCM_M_MODULE_REF:
+ case SCM_M_RESOLVE:
if (SCM_VARIABLEP (mx))
- return SCM_VARIABLE_REF (mx);
- else
- return SCM_VARIABLE_REF
- (scm_memoize_variable_access_x (x, SCM_BOOL_F));
-
- case SCM_M_MODULE_SET:
- if (SCM_VARIABLEP (CDR (mx)))
- {
- SCM_VARIABLE_SET (CDR (mx), EVAL1 (CAR (mx), env));
- return SCM_UNSPECIFIED;
- }
+ return mx;
else
{
- SCM_VARIABLE_SET
- (scm_memoize_variable_access_x (x, SCM_BOOL_F),
- EVAL1 (CAR (mx), env));
- return SCM_UNSPECIFIED;
+ 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:
{
- SCM vm, k, res;
+ struct scm_vm *vp;
+ SCM k, res;
scm_i_jmp_buf registers;
/* We need the handler after nonlocal return to the setjmp, so
make sure it is volatile. */
k = EVAL1 (CAR (mx), env);
handler = EVAL1 (CDDR (mx), env);
- vm = scm_the_vm ();
+ vp = scm_the_vm ();
/* Push the prompt onto the dynamic stack. */
scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
| SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
k,
- SCM_VM_DATA (vm)->fp,
- SCM_VM_DATA (vm)->sp,
- SCM_VM_DATA (vm)->ip,
+ vp->fp - vp->stack_base,
+ vp->sp - vp->stack_base,
+ 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 (scm_the_vm ());
+ vp = scm_the_vm ();
+ args = scm_i_prompt_pop_abort_args_x (vp);
goto apply_proc;
}
SCM
scm_call_0 (SCM proc)
{
- return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
+ return scm_call_n (proc, NULL, 0);
}
SCM
scm_call_1 (SCM proc, SCM arg1)
{
- return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
+ return scm_call_n (proc, &arg1, 1);
}
SCM
scm_call_2 (SCM proc, SCM arg1, SCM arg2)
{
SCM args[] = { arg1, arg2 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 2);
+ return scm_call_n (proc, args, 2);
}
SCM
scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
{
SCM args[] = { arg1, arg2, arg3 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 3);
+ return scm_call_n (proc, args, 3);
}
SCM
scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
{
SCM args[] = { arg1, arg2, arg3, arg4 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 4);
+ return scm_call_n (proc, args, 4);
}
SCM
scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 5);
+ return scm_call_n (proc, args, 5);
}
SCM
SCM arg6)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 6);
+ return scm_call_n (proc, args, 6);
}
SCM
SCM arg6, SCM arg7)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 7);
+ return scm_call_n (proc, args, 7);
}
SCM
SCM arg6, SCM arg7, SCM arg8)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 8);
+ return scm_call_n (proc, args, 8);
}
SCM
SCM arg6, SCM arg7, SCM arg8, SCM arg9)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 9);
+ return scm_call_n (proc, args, 9);
}
-SCM
-scm_call_n (SCM proc, SCM *argv, size_t nargs)
-{
- return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
-}
+/* scm_call_n defined in vm.c */
SCM
scm_call (SCM proc, ...)
argv[i] = va_arg (argp, SCM);
va_end (argp);
- return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
+ return scm_call_n (proc, argv, nargs);
}
/* Simple procedure applies
SCM
scm_apply_0 (SCM proc, SCM args)
{
- return scm_apply (proc, args, SCM_EOL);
+ SCM *argv;
+ int i, nargs;
+
+ nargs = scm_ilength (args);
+ if (SCM_UNLIKELY (nargs < 0))
+ scm_wrong_type_arg_msg ("apply", 2, args, "list");
+
+ /* FIXME: Use vm_builtin_apply instead of alloca. */
+ argv = alloca (nargs * sizeof(SCM));
+ for (i = 0; i < nargs; i++)
+ {
+ argv[i] = SCM_CAR (args);
+ args = SCM_CDR (args);
+ }
+
+ return scm_call_n (proc, argv, nargs);
}
SCM
scm_apply_1 (SCM proc, SCM arg1, SCM args)
{
- return scm_apply (proc, scm_cons (arg1, args), SCM_EOL);
+ return scm_apply_0 (proc, scm_cons (arg1, args));
}
SCM
scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
{
- return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL);
+ return scm_apply_0 (proc, scm_cons2 (arg1, arg2, args));
}
SCM
scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
{
- return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)),
- SCM_EOL);
+ return scm_apply_0 (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)));
}
+static SCM map_var, for_each_var;
+
+static void init_map_var (void)
+{
+ map_var = scm_private_variable (scm_the_root_module (),
+ scm_from_latin1_symbol ("map"));
+}
+
+static void init_for_each_var (void)
+{
+ for_each_var = scm_private_variable (scm_the_root_module (),
+ scm_from_latin1_symbol ("for-each"));
+}
SCM
scm_map (SCM proc, SCM arg1, SCM args)
{
- static SCM var = SCM_BOOL_F;
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_map_var);
- if (scm_is_false (var))
- var = scm_private_variable (scm_the_root_module (),
- scm_from_latin1_symbol ("map"));
-
- return scm_apply (scm_variable_ref (var),
- scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
+ return scm_apply_0 (scm_variable_ref (map_var),
+ scm_cons (proc, scm_cons (arg1, args)));
}
SCM
scm_for_each (SCM proc, SCM arg1, SCM args)
{
- static SCM var = SCM_BOOL_F;
-
- if (scm_is_false (var))
- var = scm_private_variable (scm_the_root_module (),
- scm_from_latin1_symbol ("for-each"));
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_for_each_var);
- return scm_apply (scm_variable_ref (var),
- scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
+ return scm_apply_0 (scm_variable_ref (for_each_var),
+ scm_cons (proc, scm_cons (arg1, args)));
}
SCM
scm_primitive_eval (SCM exp)
{
- return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval),
- &exp, 1);
+ return scm_call_n (scm_variable_ref (var_primitive_eval),
+ &exp, 1);
}
/* Apply a function to a list of arguments.
- This function is exported to the Scheme level as taking two
- required arguments and a tail argument, as if it were:
+ This function's interface is a bit wonly. It takes two required
+ arguments and a tail argument, as if it were:
+
(lambda (proc arg1 . args) ...)
- Thus, if you just have a list of arguments to pass to a procedure,
- pass the list as ARG1, and '() for ARGS. If you have some fixed
- args, pass the first as ARG1, then cons any remaining fixed args
- onto the front of your argument list, and pass that as ARGS. */
+
+ Usually you want to use scm_apply_0 or one of its cousins. */
SCM
scm_apply (SCM proc, SCM arg1, SCM args)
{
- /* Fix things up so that args contains all args. */
- if (scm_is_null (args))
- args = arg1;
- else
- args = scm_cons_star (arg1, args);
-
- return scm_call_with_vm (scm_the_vm (), proc, args);
+ return scm_apply_0 (proc,
+ scm_is_null (args) ? arg1 : scm_cons_star (arg1, args));
}
static void
}
else
{
- int i, argc, nreq, nopt, nenv;
- SCM body, rest, kw, inits, alt;
+ int i, argc, nreq, nopt, ninits, nenv;
+ SCM body, rest, kw, unbound, alt;
SCM mx = BOOT_CLOSURE_CODE (proc);
loop:
- BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw, inits, alt);
+ BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw,
+ ninits, unbound, alt);
argc = scm_ilength (args);
if (argc < nreq)
}
/* At this point we are committed to the chosen clause. */
- nenv = nreq + (scm_is_true (rest) ? 1 : 0) + scm_ilength (inits);
- env = make_env (nenv, SCM_UNDEFINED, env);
+ nenv = nreq + (scm_is_true (rest) ? 1 : 0) + ninits;
+ env = make_env (nenv, unbound, env);
for (i = 0; i < nreq; i++, args = CDR (args))
env_set (env, 0, i, CAR (args));
if (scm_is_false (kw))
{
/* Optional args (possibly), but no keyword args. */
- for (; i < argc && i < nreq + nopt;
- i++, args = CDR (args), inits = CDR (inits))
+ for (; i < argc && i < nreq + nopt; i++, args = CDR (args))
env_set (env, 0, i, CAR (args));
-
- for (; i < nreq + nopt; i++, inits = CDR (inits))
- env_set (env, 0, i, EVAL1 (CAR (inits), env));
-
if (scm_is_true (rest))
- env_set (env, 0, i++, args);
+ env_set (env, 0, nreq + nopt, args);
}
else
{
/* Optional args. As before, but stop at the first keyword. */
for (; i < argc && i < nreq + nopt && !scm_is_keyword (CAR (args));
- i++, args = CDR (args), inits = CDR (inits))
+ i++, args = CDR (args))
env_set (env, 0, i, CAR (args));
-
- for (; i < nreq + nopt; i++, inits = CDR (inits))
- env_set (env, 0, i, EVAL1 (CAR (inits), env));
-
if (scm_is_true (rest))
- env_set (env, 0, i++, args);
+ env_set (env, 0, nreq + nopt, args);
/* Parse keyword args. */
{
- int kw_start_idx = i;
SCM walk;
if (scm_is_pair (args) && scm_is_pair (CDR (args)))
}
if (scm_is_pair (args) && scm_is_false (rest))
error_invalid_keyword (proc, CAR (args));
-
- /* Now fill in unbound values, evaluating init expressions in their
- appropriate environment. */
- for (i = kw_start_idx; scm_is_pair (inits); i++, inits = CDR (inits))
- if (SCM_UNBNDP (env_ref (env, 0, i)))
- env_set (env, 0, i, EVAL1 (CAR (inits), env));
}
}
- if (!scm_is_null (inits))
- abort ();
- if (i != nenv)
- abort ();
-
*out_body = body;
*out_env = env;
}
HCoop / bpt / guile.git / blobdiff