-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
#endif
#include <alloca.h>
+#include <stdarg.h>
#include "libguile/__scm.h"
*/
static scm_t_bits scm_tc16_boot_closure;
-#define RETURN_BOOT_CLOSURE(code, env) SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, (code), (env))
+#define RETURN_BOOT_CLOSURE(code, env) \
+ SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, SCM_UNPACK (code), SCM_UNPACK (env))
#define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
#define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
#define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
static void error_invalid_keyword (SCM proc)
{
- scm_error_scm (scm_from_locale_symbol ("keyword-argument-error"), proc,
+ scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
scm_from_locale_string ("Invalid keyword"), SCM_EOL,
SCM_BOOL_F);
}
static void error_unrecognized_keyword (SCM proc)
{
- scm_error_scm (scm_from_locale_symbol ("keyword-argument-error"), proc,
+ scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
scm_from_locale_string ("Unrecognized keyword"), SCM_EOL,
SCM_BOOL_F);
}
+/* Multiple values truncation. */
+static SCM
+truncate_values (SCM x)
+{
+ if (SCM_LIKELY (!SCM_VALUESP (x)))
+ return x;
+ else
+ {
+ SCM l = scm_struct_ref (x, SCM_INUM0);
+ if (SCM_LIKELY (scm_is_pair (l)))
+ return scm_car (l);
+ else
+ {
+ scm_ithrow (scm_from_latin1_symbol ("vm-run"),
+ scm_list_3 (scm_from_latin1_symbol ("vm-run"),
+ scm_from_locale_string
+ ("Too few values returned to continuation"),
+ SCM_EOL),
+ 1);
+ /* Not reached. */
+ return SCM_BOOL_F;
+ }
+ }
+}
+#define EVAL1(x, env) (truncate_values (eval ((x), (env))))
+
/* the environment:
(VAL ... . MOD)
If MOD is #f, it means the environment was captured before modules were
case, because further lexical contours should capture the current module.
*/
#define CAPTURE_ENV(env) \
- ((env == SCM_EOL) ? scm_current_module () : \
- ((env == SCM_BOOL_F) ? scm_the_root_module () : env))
+ (scm_is_null (env) ? scm_current_module () : \
+ (scm_is_false (env) ? scm_the_root_module () : env))
static SCM
eval (SCM x, SCM env)
mx = SCM_MEMOIZED_ARGS (x);
switch (SCM_MEMOIZED_TAG (x))
{
- case SCM_M_BEGIN:
- for (; !scm_is_null (CDR (mx)); mx = CDR (mx))
- eval (CAR (mx), env);
- x = CAR (mx);
+ case SCM_M_SEQ:
+ eval (CAR (mx), env);
+ x = CDR (mx);
goto loop;
case SCM_M_IF:
- if (scm_is_true (eval (CAR (mx), env)))
+ if (scm_is_true (EVAL1 (CAR (mx), env)))
x = CADR (mx);
else
x = CDDR (mx);
SCM inits = CAR (mx);
SCM new_env = CAPTURE_ENV (env);
for (; scm_is_pair (inits); inits = CDR (inits))
- new_env = scm_cons (eval (CAR (inits), env), new_env);
+ new_env = scm_cons (EVAL1 (CAR (inits), env),
+ new_env);
env = new_env;
x = CDR (mx);
goto loop;
return mx;
case SCM_M_DEFINE:
- scm_define (CAR (mx), eval (CDR (mx), env));
+ scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
case SCM_M_DYNWIND:
{
SCM in, out, res, old_winds;
- in = eval (CAR (mx), env);
- out = eval (CDDR (mx), env);
+ in = EVAL1 (CAR (mx), env);
+ out = EVAL1 (CDDR (mx), env);
scm_call_0 (in);
old_winds = scm_i_dynwinds ();
scm_i_set_dynwinds (scm_acons (in, out, old_winds));
len = scm_ilength (CAR (mx));
fluidv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
- fluidv[i] = eval (CAR (walk), env);
+ fluidv[i] = EVAL1 (CAR (walk), env);
valuesv = alloca (sizeof (SCM)*len);
for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
- valuesv[i] = eval (CAR (walk), env);
+ valuesv[i] = EVAL1 (CAR (walk), env);
wf = scm_i_make_with_fluids (len, fluidv, valuesv);
scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
- proc = eval (CAR (mx), env);
+ proc = EVAL1 (CAR (mx), env);
/* Evaluate the argument holding the list of arguments */
- args = eval (CADR (mx), env);
+ args = EVAL1 (CADR (mx), env);
apply_proc:
/* Go here to tail-apply a procedure. PROC is the procedure and
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
- proc = eval (CAR (mx), env);
+ proc = EVAL1 (CAR (mx), env);
argc = SCM_I_INUM (CADR (mx));
mx = CDDR (mx);
argv = alloca (argc * sizeof (SCM));
for (i = 0; i < argc; i++, mx = CDR (mx))
- argv[i] = eval (CAR (mx), env);
+ argv[i] = EVAL1 (CAR (mx), env);
return scm_c_vm_run (scm_the_vm (), proc, argv, argc);
}
case SCM_M_CONT:
- return scm_i_call_with_current_continuation (eval (mx, env));
+ return scm_i_call_with_current_continuation (EVAL1 (mx, env));
case SCM_M_CALL_WITH_VALUES:
{
SCM producer;
SCM v;
- producer = eval (CAR (mx), env);
- proc = eval (CDR (mx), env); /* proc is the consumer. */
+ 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);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
case SCM_M_LEXICAL_SET:
{
int n;
- SCM val = eval (CDR (mx), env);
+ SCM val = EVAL1 (CDR (mx), env);
for (n = SCM_I_INUM (CAR (mx)); n; n--)
env = CDR (env);
SCM_SETCAR (env, val);
case SCM_M_TOPLEVEL_SET:
{
SCM var = CAR (mx);
- SCM val = eval (CDR (mx), env);
+ SCM val = EVAL1 (CDR (mx), env);
if (SCM_VARIABLEP (var))
{
SCM_VARIABLE_SET (var, val);
case SCM_M_MODULE_SET:
if (SCM_VARIABLEP (CDR (mx)))
{
- SCM_VARIABLE_SET (CDR (mx), eval (CAR (mx), env));
+ SCM_VARIABLE_SET (CDR (mx), EVAL1 (CAR (mx), env));
return SCM_UNSPECIFIED;
}
else
{
SCM_VARIABLE_SET
(scm_memoize_variable_access_x (x, SCM_BOOL_F),
- eval (CAR (mx), env));
+ EVAL1 (CAR (mx), env));
return SCM_UNSPECIFIED;
}
case SCM_M_PROMPT:
{
- SCM vm, prompt, handler, res;
+ SCM vm, res;
+ /* We need the prompt and handler values after a longjmp case,
+ so make sure they are volatile. */
+ volatile SCM handler, prompt;
vm = scm_the_vm ();
- prompt = scm_c_make_prompt (eval (CAR (mx), env), SCM_VM_DATA (vm)->fp,
+ prompt = scm_c_make_prompt (EVAL1 (CAR (mx), env),
+ SCM_VM_DATA (vm)->fp,
SCM_VM_DATA (vm)->sp, SCM_VM_DATA (vm)->ip,
0, -1, scm_i_dynwinds ());
- handler = eval (CDDR (mx), env);
+ handler = EVAL1 (CDDR (mx), env);
scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
if (SCM_PROMPT_SETJMP (prompt))
{
/* The prompt exited nonlocally. */
proc = handler;
- args = scm_i_prompt_pop_abort_args_x (prompt);
+ args = scm_i_prompt_pop_abort_args_x (scm_the_vm ());
goto apply_proc;
}
return scm_c_vm_run (scm_the_vm (), 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);
+}
+
+SCM
+scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
+ SCM arg6)
+{
+ SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 6);
+}
+
+SCM
+scm_call_7 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
+ SCM arg6, SCM arg7)
+{
+ SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 7);
+}
+
+SCM
+scm_call_8 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
+ 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);
+}
+
+SCM
+scm_call_9 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
+ 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);
+}
+
SCM
scm_call_n (SCM proc, SCM *argv, size_t nargs)
{
return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
}
+SCM
+scm_call (SCM proc, ...)
+{
+ va_list argp;
+ SCM *argv = NULL;
+ size_t i, nargs = 0;
+
+ va_start (argp, proc);
+ while (!SCM_UNBNDP (va_arg (argp, SCM)))
+ nargs++;
+ va_end (argp);
+
+ argv = alloca (nargs * sizeof (SCM));
+ va_start (argp, proc);
+ for (i = 0; i < nargs; i++)
+ argv[i] = va_arg (argp, SCM);
+ va_end (argp);
+
+ return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
+}
+
/* Simple procedure applies
*/
SCM *lloc;
SCM_VALIDATE_NONEMPTYLIST (1, lst);
lloc = &lst;
- while (!scm_is_null (SCM_CDR (*lloc))) /* Perhaps should be
- SCM_NULL_OR_NIL_P, but not
- needed in 99.99% of cases,
- and it could seriously hurt
- performance. - Neil */
+ while (!scm_is_null (SCM_CDR (*lloc)))
lloc = SCM_CDRLOC (*lloc);
SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
*lloc = SCM_CAR (*lloc);
#undef FUNC_NAME
-
-/* Typechecking for multi-argument MAP and FOR-EACH.
-
- Verify that each element of the vector ARGV, except for the first,
- is a proper list whose length is LEN. Attribute errors to WHO,
- and claim that the i'th element of ARGV is WHO's i+2'th argument. */
-static inline void
-check_map_args (SCM argv,
- long len,
- SCM gf,
- SCM proc,
- SCM args,
- const char *who)
-{
- long i;
-
- for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (argv, i);
- long elt_len = scm_ilength (elt);
-
- if (elt_len < 0)
- {
- if (gf)
- scm_apply_generic (gf, scm_cons (proc, args));
- else
- scm_wrong_type_arg (who, i + 2, elt);
- }
-
- if (elt_len != len)
- scm_out_of_range_pos (who, elt, scm_from_long (i + 2));
- }
-}
-
-
-SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map);
-
-/* Note: Currently, scm_map applies PROC to the argument list(s)
- sequentially, starting with the first element(s). This is used in
- evalext.c where the Scheme procedure `map-in-order', which guarantees
- sequential behaviour, is implemented using scm_map. If the
- behaviour changes, we need to update `map-in-order'.
-*/
-
SCM
scm_map (SCM proc, SCM arg1, SCM args)
-#define FUNC_NAME s_map
{
- long i, len;
- SCM res = SCM_EOL;
- SCM *pres = &res;
-
- len = scm_ilength (arg1);
- SCM_GASSERTn (len >= 0,
- g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map);
- SCM_VALIDATE_REST_ARGUMENT (args);
- if (scm_is_null (args))
- {
- SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_map, proc, arg1, SCM_ARG1, s_map);
- while (SCM_NIMP (arg1))
- {
- *pres = scm_list_1 (scm_call_1 (proc, SCM_CAR (arg1)));
- pres = SCM_CDRLOC (*pres);
- arg1 = SCM_CDR (arg1);
- }
- return res;
- }
- if (scm_is_null (SCM_CDR (args)))
- {
- SCM arg2 = SCM_CAR (args);
- int len2 = scm_ilength (arg2);
- SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_map,
- scm_cons2 (proc, arg1, args), SCM_ARG1, s_map);
- SCM_GASSERTn (len2 >= 0,
- g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map);
- if (len2 != len)
- SCM_OUT_OF_RANGE (3, arg2);
- while (SCM_NIMP (arg1))
- {
- *pres = scm_list_1 (scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
- pres = SCM_CDRLOC (*pres);
- arg1 = SCM_CDR (arg1);
- arg2 = SCM_CDR (arg2);
- }
- return res;
- }
- arg1 = scm_cons (arg1, args);
- args = scm_vector (arg1);
- check_map_args (args, len, g_map, proc, arg1, s_map);
- while (1)
- {
- arg1 = SCM_EOL;
- for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
- if (SCM_IMP (elt))
- return res;
- arg1 = scm_cons (SCM_CAR (elt), arg1);
- SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
- }
- *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
- pres = SCM_CDRLOC (*pres);
- }
-}
-#undef FUNC_NAME
+ static SCM var = SCM_BOOL_F;
+ if (scm_is_false (var))
+ var = scm_private_variable (scm_the_root_module (),
+ scm_from_latin1_symbol ("map"));
-SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each);
+ return scm_apply (scm_variable_ref (var),
+ scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
+}
SCM
scm_for_each (SCM proc, SCM arg1, SCM args)
-#define FUNC_NAME s_for_each
{
- long i, len;
- len = scm_ilength (arg1);
- SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
- SCM_ARG2, s_for_each);
- SCM_VALIDATE_REST_ARGUMENT (args);
- if (scm_is_null (args))
- {
- SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_for_each,
- proc, arg1, SCM_ARG1, s_for_each);
- while (SCM_NIMP (arg1))
- {
- scm_call_1 (proc, SCM_CAR (arg1));
- arg1 = SCM_CDR (arg1);
- }
- return SCM_UNSPECIFIED;
- }
- if (scm_is_null (SCM_CDR (args)))
- {
- SCM arg2 = SCM_CAR (args);
- int len2 = scm_ilength (arg2);
- SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_for_each,
- scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each);
- SCM_GASSERTn (len2 >= 0, g_for_each,
- scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each);
- if (len2 != len)
- SCM_OUT_OF_RANGE (3, arg2);
- while (SCM_NIMP (arg1))
- {
- scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2));
- arg1 = SCM_CDR (arg1);
- arg2 = SCM_CDR (arg2);
- }
- return SCM_UNSPECIFIED;
- }
- arg1 = scm_cons (arg1, args);
- args = scm_vector (arg1);
- check_map_args (args, len, g_for_each, proc, arg1, s_for_each);
- while (1)
- {
- arg1 = SCM_EOL;
- for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
- if (SCM_IMP (elt))
- return SCM_UNSPECIFIED;
- arg1 = scm_cons (SCM_CAR (elt), arg1);
- SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
- }
- scm_apply (proc, arg1, SCM_EOL);
- }
+ 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"));
+
+ return scm_apply (scm_variable_ref (var),
+ scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
}
-#undef FUNC_NAME
static SCM
}
for (; i < nreq + nopt; i++, inits = CDR (inits))
- env = scm_cons (eval (CAR (inits), env), env);
+ env = scm_cons (EVAL1 (CAR (inits), env), env);
if (scm_is_true (rest))
env = scm_cons (args, env);
env = scm_cons (CAR (args), env);
for (; i < nreq + nopt; i++, inits = CDR (inits))
- env = scm_cons (eval (CAR (inits), env), env);
+ env = scm_cons (EVAL1 (CAR (inits), env), env);
if (scm_is_true (rest))
{
{
SCM tail = scm_list_tail (env, SCM_I_MAKINUM (i));
if (SCM_UNBNDP (CAR (tail)))
- SCM_SETCAR (tail, eval (CAR (inits), CDR (tail)));
+ SCM_SETCAR (tail, EVAL1 (CAR (inits), CDR (tail)));
}
}
}
&& !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
{
for (; scm_is_pair (exps); exps = CDR (exps), nreq--)
- new_env = scm_cons (eval (CAR (exps), *inout_env), new_env);
+ new_env = scm_cons (EVAL1 (CAR (exps), *inout_env),
+ new_env);
if (SCM_UNLIKELY (nreq != 0))
scm_wrong_num_args (proc);
*out_body = BOOT_CLOSURE_BODY (proc);
if (SCM_UNLIKELY (argc < nreq))
scm_wrong_num_args (proc);
for (; nreq; nreq--, exps = CDR (exps))
- new_env = scm_cons (eval (CAR (exps), *inout_env), new_env);
+ new_env = scm_cons (EVAL1 (CAR (exps), *inout_env),
+ new_env);
{
SCM rest = SCM_EOL;
for (; scm_is_pair (exps); exps = CDR (exps))
- rest = scm_cons (eval (CAR (exps), *inout_env), rest);
+ rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest);
new_env = scm_cons (scm_reverse (rest),
new_env);
}
{
SCM args = SCM_EOL;
for (; scm_is_pair (exps); exps = CDR (exps))
- args = scm_cons (eval (CAR (exps), *inout_env), args);
+ args = scm_cons (EVAL1 (CAR (exps), *inout_env), args);
args = scm_reverse_x (args, SCM_UNDEFINED);
prepare_boot_closure_env_for_apply (proc, args, out_body, inout_env);
}
boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
{
SCM args;
- scm_puts ("#<boot-closure ", port);
- scm_uintprint ((scm_t_bits)SCM2PTR (closure), 16, port);
- scm_putc (' ', port);
+ scm_puts_unlocked ("#<boot-closure ", port);
+ scm_uintprint (SCM_UNPACK (closure), 16, port);
+ scm_putc_unlocked (' ', port);
args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
- scm_from_locale_symbol ("_"));
+ scm_from_latin1_symbol ("_"));
if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
- args = scm_cons_star (scm_from_locale_symbol ("_"), args);
+ args = scm_cons_star (scm_from_latin1_symbol ("_"), args);
/* FIXME: optionals and rests */
scm_display (args, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
HCoop / bpt / guile.git / blobdiff