-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
+/* 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"
-#include <assert.h>
#include "libguile/_scm.h"
#include "libguile/alist.h"
#include "libguile/async.h"
#include "libguile/continuations.h"
+#include "libguile/control.h"
#include "libguile/debug.h"
#include "libguile/deprecation.h"
#include "libguile/dynwind.h"
#include "libguile/eq.h"
+#include "libguile/expand.h"
#include "libguile/feature.h"
#include "libguile/fluids.h"
#include "libguile/goops.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
-#include "libguile/lang.h"
#include "libguile/list.h"
#include "libguile/macros.h"
#include "libguile/memoize.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)
-#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CAR (BOOT_CLOSURE_CODE (x)))
-#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADR (BOOT_CLOSURE_CODE (x)))
-#define BOOT_CLOSURE_BODY(x) CDDR (BOOT_CLOSURE_CODE (x))
+#define BOOT_CLOSURE_BODY(x) CAR (BOOT_CLOSURE_CODE (x))
+#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CADR (BOOT_CLOSURE_CODE (x)))
+#define BOOT_CLOSURE_IS_FIXED(x) scm_is_null (CDDR (BOOT_CLOSURE_CODE (x)))
+/* NB: One may only call the following accessors if the closure is not FIXED. */
+#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (BOOT_CLOSURE_CODE (x)))
+#define BOOT_CLOSURE_IS_REST(x) scm_is_null (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) \
+ do { SCM fu = fu_; \
+ body = CAR (fu); fu = CDR (fu); \
+ \
+ rest = kw = alt = SCM_BOOL_F; \
+ inits = SCM_EOL; \
+ nopt = 0; \
+ \
+ nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
+ if (scm_is_pair (fu)) \
+ { \
+ rest = 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); \
+ alt = CAR (fu); \
+ } \
+ } \
+ } while (0)
+static void prepare_boot_closure_env_for_apply (SCM proc, SCM args,
+ SCM *out_body, SCM *out_env);
+static void prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
+ SCM exps, SCM *out_body,
+ SCM *inout_env);
-
-#if 0
#define CAR(x) SCM_CAR(x)
#define CDR(x) SCM_CDR(x)
#define CAAR(x) SCM_CAAR(x)
#define CDDR(x) SCM_CDDR(x)
#define CADDR(x) SCM_CADDR(x)
#define CDDDR(x) SCM_CDDDR(x)
-#else
-#define CAR(x) scm_car(x)
-#define CDR(x) scm_cdr(x)
-#define CAAR(x) scm_caar(x)
-#define CADR(x) scm_cadr(x)
-#define CDAR(x) scm_cdar(x)
-#define CDDR(x) scm_cddr(x)
-#define CADDR(x) scm_caddr(x)
-#define CDDDR(x) scm_cdddr(x)
-#endif
SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
"Variable used before given a value", SCM_EOL, SCM_BOOL_F);
}
-int
-scm_badargsp (SCM formals, SCM args)
+static void error_invalid_keyword (SCM 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_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)
{
- while (!scm_is_null (formals))
+ if (SCM_LIKELY (!SCM_VALUESP (x)))
+ return x;
+ else
{
- if (!scm_is_pair (formals))
- return 0;
- if (scm_is_null (args))
- return 1;
- formals = CDR (formals);
- args = CDR (args);
+ 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;
+ }
}
- return !scm_is_null (args) ? 1 : 0;
}
+#define EVAL1(x, env) (truncate_values (eval ((x), (env))))
/* the environment:
(VAL ... . MOD)
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)
{
SCM mx;
SCM proc = SCM_UNDEFINED, args = SCM_EOL;
+ unsigned int argc;
loop:
SCM_TICK;
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 = 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));
+ res = eval (CADR (mx), env);
+ scm_i_set_dynwinds (old_winds);
+ scm_call_0 (out);
+ return res;
+ }
+
+ case SCM_M_WITH_FLUIDS:
+ {
+ long i, len;
+ SCM *fluidv, *valuesv, walk, wf, res;
+ len = scm_ilength (CAR (mx));
+ fluidv = alloca (sizeof (SCM)*len);
+ for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
+ 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] = 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);
+ scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
+ res = eval (CDDR (mx), env);
+ scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
+ scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
+
+ return res;
+ }
+
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
* ARGS is the list of arguments. */
if (BOOT_CLOSURE_P (proc))
{
- int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
- SCM new_env = BOOT_CLOSURE_ENV (proc);
- if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
- {
- if (SCM_UNLIKELY (scm_ilength (args) < nreq))
- scm_wrong_num_args (proc);
- for (; nreq; nreq--, args = CDR (args))
- new_env = scm_cons (CAR (args), new_env);
- new_env = scm_cons (args, new_env);
- }
- else
- {
- if (SCM_UNLIKELY (scm_ilength (args) != nreq))
- scm_wrong_num_args (proc);
- for (; scm_is_pair (args); args = CDR (args))
- new_env = scm_cons (CAR (args), new_env);
- }
- x = BOOT_CLOSURE_BODY (proc);
- env = new_env;
+ prepare_boot_closure_env_for_apply (proc, args, &x, &env);
goto loop;
}
else
- return scm_vm_apply (scm_the_vm (), proc, args);
+ return scm_call_with_vm (scm_the_vm (), proc, args);
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
- proc = eval (CAR (mx), env);
- /* int nargs = CADR (mx); */
+ proc = EVAL1 (CAR (mx), env);
+ argc = SCM_I_INUM (CADR (mx));
mx = CDDR (mx);
if (BOOT_CLOSURE_P (proc))
{
- int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
- SCM new_env = BOOT_CLOSURE_ENV (proc);
- if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
- {
- if (SCM_UNLIKELY (scm_ilength (mx) < nreq))
- scm_wrong_num_args (proc);
- for (; nreq; nreq--, mx = CDR (mx))
- new_env = scm_cons (eval (CAR (mx), env), new_env);
- {
- SCM rest = SCM_EOL;
- for (; scm_is_pair (mx); mx = CDR (mx))
- rest = scm_cons (eval (CAR (mx), env), rest);
- new_env = scm_cons (scm_reverse (rest),
- new_env);
- }
- }
- else
- {
- for (; scm_is_pair (mx); mx = CDR (mx), nreq--)
- new_env = scm_cons (eval (CAR (mx), env), new_env);
- if (SCM_UNLIKELY (nreq != 0))
- scm_wrong_num_args (proc);
- }
- x = BOOT_CLOSURE_BODY (proc);
- env = new_env;
+ prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
goto loop;
}
else
{
- SCM rest = SCM_EOL;
- /* FIXME: use alloca */
- for (; scm_is_pair (mx); mx = CDR (mx))
- rest = scm_cons (eval (CAR (mx), env), rest);
- return scm_vm_apply (scm_the_vm (), proc, scm_reverse (rest));
+ 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_c_vm_run (scm_the_vm (), proc, argv, argc);
}
-
- case SCM_M_CONT:
- {
- int first;
- SCM val = scm_make_continuation (&first);
- if (!first)
- return val;
- else
- {
- proc = eval (mx, env);
- args = scm_list_1 (val);
- goto apply_proc;
- }
- }
+ 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 = eval (CAR (mx), env);
- proc = eval (CDR (mx), env); /* proc is the consumer. */
- v = scm_vm_apply (scm_the_vm (), producer, SCM_EOL);
+ 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);
else
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);
else
{
while (scm_is_pair (env))
- env = scm_cdr (env);
+ env = CDR (env);
return SCM_VARIABLE_REF
(scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
}
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);
else
{
while (scm_is_pair (env))
- env = scm_cdr (env);
+ env = CDR (env);
SCM_VARIABLE_SET
(scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
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, 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 (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 = 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 (scm_the_vm ());
+ goto apply_proc;
+ }
+
+ res = eval (CADR (mx), env);
+ scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
+ return res;
+ }
+
default:
abort ();
}
}
-scm_t_option scm_eval_opts[] = {
- { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." },
- { 0 }
-};
-
-scm_t_option scm_debug_opts[] = {
- { SCM_OPTION_BOOLEAN, "cheap", 1,
- "*This option is now obsolete. Setting it has no effect." },
- { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
- { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." },
- { SCM_OPTION_BOOLEAN, "procnames", 1,
- "Record procedure names at definition." },
- { SCM_OPTION_BOOLEAN, "backwards", 0,
- "Display backtrace in anti-chronological order." },
- { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
- { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
- { SCM_OPTION_INTEGER, "frames", 3,
- "Maximum number of tail-recursive frames in backtrace." },
- { SCM_OPTION_INTEGER, "maxdepth", 1000,
- "Maximal number of stored backtrace frames." },
- { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
- { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
- { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
- /* This default stack limit will be overridden by debug.c:init_stack_limit(),
- if we have getrlimit() and the stack limit is not INFINITY. But it is still
- important, as some systems have both the soft and the hard limits set to
- INFINITY; in that case we fall back to this value.
-
- The situation is aggravated by certain compilers, which can consume
- "beaucoup de stack", as they say in France.
-
- See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
- more discussion. This setting is 640 KB on 32-bit arches (should be enough
- for anyone!) or a whoppin' 1280 KB on 64-bit arches.
- */
- { SCM_OPTION_INTEGER, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
- { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T,
- "Show file names and line numbers "
- "in backtraces when not `#f'. A value of `base' "
- "displays only base names, while `#t' displays full names."},
- { SCM_OPTION_BOOLEAN, "warn-deprecated", 0,
- "Warn when deprecated features are used." },
- { 0 },
-};
-
-
-/*
- * this ordering is awkward and illogical, but we maintain it for
- * compatibility. --hwn
- */
-scm_t_option scm_evaluator_trap_table[] = {
- { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
- { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
- { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
- { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." },
- { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." },
- { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." },
- { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." },
- { SCM_OPTION_BOOLEAN, "memoize-symbol", 0, "Trap when memoizing a symbol." },
- { SCM_OPTION_SCM, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F, "The handler for memoization." },
- { 0 }
-};
-
-
-SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
- (SCM setting),
- "Option interface for the evaluation options. Instead of using\n"
- "this procedure directly, use the procedures @code{eval-enable},\n"
- "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
-#define FUNC_NAME s_scm_eval_options_interface
-{
- SCM ans;
-
- scm_dynwind_begin (0);
- scm_dynwind_critical_section (SCM_BOOL_F);
- ans = scm_options (setting,
- scm_eval_opts,
- FUNC_NAME);
- scm_dynwind_end ();
-
- return ans;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
- (SCM setting),
- "Option interface for the evaluator trap options.")
-#define FUNC_NAME s_scm_evaluator_traps
-{
- SCM ans;
-
-
- scm_options_try (setting,
- scm_evaluator_trap_table,
- FUNC_NAME, 1);
- SCM_CRITICAL_SECTION_START;
- ans = scm_options (setting,
- scm_evaluator_trap_table,
- FUNC_NAME);
-
- /* njrev: same again. */
- SCM_CRITICAL_SECTION_END;
- return ans;
-}
-#undef FUNC_NAME
-
-
-
\f
/* Simple procedure calls
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
scm_c_primitive_eval (SCM exp)
{
- SCM transformer = scm_current_module_transformer ();
- if (scm_is_true (transformer))
- exp = scm_call_1 (transformer, exp);
- exp = scm_memoize_expression (exp);
- return eval (exp, SCM_EOL);
+ if (!SCM_EXPANDED_P (exp))
+ exp = scm_call_1 (scm_current_module_transformer (), exp);
+ return eval (scm_memoize_expression (exp), SCM_EOL);
}
static SCM var_primitive_eval;
else
args = scm_cons_star (arg1, args);
- return scm_vm_apply (scm_the_vm (), proc, args);
+ return scm_call_with_vm (scm_the_vm (), proc, args);
}
-
-static SCM
-boot_closure_apply (SCM closure, SCM args)
+static void
+prepare_boot_closure_env_for_apply (SCM proc, SCM args,
+ SCM *out_body, SCM *out_env)
{
- int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure);
- SCM new_env = BOOT_CLOSURE_ENV (closure);
- if (BOOT_CLOSURE_HAS_REST_ARGS (closure))
+ int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
+ SCM env = BOOT_CLOSURE_ENV (proc);
+
+ if (BOOT_CLOSURE_IS_FIXED (proc)
+ || (BOOT_CLOSURE_IS_REST (proc)
+ && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
+ {
+ if (SCM_UNLIKELY (scm_ilength (args) != nreq))
+ scm_wrong_num_args (proc);
+ for (; scm_is_pair (args); args = CDR (args))
+ env = scm_cons (CAR (args), env);
+ *out_body = BOOT_CLOSURE_BODY (proc);
+ *out_env = env;
+ }
+ else if (BOOT_CLOSURE_IS_REST (proc))
{
if (SCM_UNLIKELY (scm_ilength (args) < nreq))
- scm_wrong_num_args (closure);
+ scm_wrong_num_args (proc);
for (; nreq; nreq--, args = CDR (args))
- new_env = scm_cons (CAR (args), new_env);
- new_env = scm_cons (args, new_env);
+ env = scm_cons (CAR (args), env);
+ env = scm_cons (args, env);
+ *out_body = BOOT_CLOSURE_BODY (proc);
+ *out_env = env;
}
else
{
- if (SCM_UNLIKELY (scm_ilength (args) != nreq))
- scm_wrong_num_args (closure);
- for (; scm_is_pair (args); args = CDR (args))
- new_env = scm_cons (CAR (args), new_env);
+ int i, argc, nreq, nopt;
+ SCM body, rest, kw, inits, alt;
+ SCM mx = BOOT_CLOSURE_CODE (proc);
+
+ loop:
+ BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw, inits, alt);
+
+ argc = scm_ilength (args);
+ if (argc < nreq)
+ {
+ if (scm_is_true (alt))
+ {
+ mx = alt;
+ goto loop;
+ }
+ else
+ scm_wrong_num_args (proc);
+ }
+ if (scm_is_false (kw) && argc > nreq + nopt && scm_is_false (rest))
+ {
+ if (scm_is_true (alt))
+ {
+ mx = alt;
+ goto loop;
+ }
+ else
+ scm_wrong_num_args (proc);
+ }
+
+ for (i = 0; i < nreq; i++, args = CDR (args))
+ env = scm_cons (CAR (args), env);
+
+ if (scm_is_false (kw))
+ {
+ /* Optional args (possibly), but no keyword args. */
+ for (; i < argc && i < nreq + nopt;
+ i++, args = CDR (args))
+ {
+ env = scm_cons (CAR (args), env);
+ inits = CDR (inits);
+ }
+
+ for (; i < nreq + nopt; i++, inits = CDR (inits))
+ env = scm_cons (EVAL1 (CAR (inits), env), env);
+
+ if (scm_is_true (rest))
+ env = scm_cons (args, env);
+ }
+ else
+ {
+ SCM aok;
+
+ aok = CAR (kw);
+ kw = CDR (kw);
+
+ /* Keyword 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))
+ env = scm_cons (CAR (args), env);
+
+ for (; i < nreq + nopt; i++, inits = CDR (inits))
+ env = scm_cons (EVAL1 (CAR (inits), env), env);
+
+ if (scm_is_true (rest))
+ {
+ env = scm_cons (args, env);
+ i++;
+ }
+
+ /* Now fill in env with unbound values, limn the rest of the args for
+ keywords, and fill in unbound values with their inits. */
+ {
+ int imax = i - 1;
+ int kw_start_idx = i;
+ SCM walk, k, v;
+ for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
+ if (SCM_I_INUM (CDAR (walk)) > imax)
+ imax = SCM_I_INUM (CDAR (walk));
+ for (; i <= imax; i++)
+ env = scm_cons (SCM_UNDEFINED, env);
+
+ if (scm_is_pair (args) && scm_is_pair (CDR (args)))
+ for (; scm_is_pair (args) && scm_is_pair (CDR (args));
+ args = CDR (args))
+ {
+ k = CAR (args); v = CADR (args);
+ if (!scm_is_keyword (k))
+ {
+ if (scm_is_true (rest))
+ continue;
+ else
+ break;
+ }
+ for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
+ if (scm_is_eq (k, CAAR (walk)))
+ {
+ /* Well... ok, list-set! isn't the nicest interface, but
+ hey. */
+ int iset = imax - SCM_I_INUM (CDAR (walk));
+ scm_list_set_x (env, SCM_I_MAKINUM (iset), v);
+ args = CDR (args);
+ break;
+ }
+ if (scm_is_null (walk) && scm_is_false (aok))
+ error_unrecognized_keyword (proc);
+ }
+ if (scm_is_pair (args) && scm_is_false (rest))
+ error_invalid_keyword (proc);
+
+ /* Now fill in unbound values, evaluating init expressions in their
+ appropriate environment. */
+ for (i = imax - kw_start_idx; scm_is_pair (inits); i--, inits = CDR (inits))
+ {
+ SCM tail = scm_list_tail (env, SCM_I_MAKINUM (i));
+ if (SCM_UNBNDP (CAR (tail)))
+ SCM_SETCAR (tail, EVAL1 (CAR (inits), CDR (tail)));
+ }
+ }
+ }
+
+ *out_body = body;
+ *out_env = env;
}
- return eval (BOOT_CLOSURE_BODY (closure), new_env);
+}
+
+static void
+prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
+ SCM exps, SCM *out_body, SCM *inout_env)
+{
+ int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
+ SCM new_env = BOOT_CLOSURE_ENV (proc);
+ if (BOOT_CLOSURE_IS_FIXED (proc)
+ || (BOOT_CLOSURE_IS_REST (proc)
+ && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
+ {
+ for (; scm_is_pair (exps); exps = CDR (exps), nreq--)
+ 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);
+ *inout_env = new_env;
+ }
+ else if (BOOT_CLOSURE_IS_REST (proc))
+ {
+ if (SCM_UNLIKELY (argc < nreq))
+ scm_wrong_num_args (proc);
+ for (; nreq; nreq--, exps = CDR (exps))
+ 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 (EVAL1 (CAR (exps), *inout_env), rest);
+ new_env = scm_cons (scm_reverse (rest),
+ new_env);
+ }
+ *out_body = BOOT_CLOSURE_BODY (proc);
+ *inout_env = new_env;
+ }
+ else
+ {
+ SCM args = SCM_EOL;
+ for (; scm_is_pair (exps); exps = CDR (exps))
+ 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);
+ }
+}
+
+static SCM
+boot_closure_apply (SCM closure, SCM args)
+{
+ SCM body, env;
+ prepare_boot_closure_env_for_apply (closure, args, &body, &env);
+ return eval (body, env);
}
static int
boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
{
SCM args;
- scm_puts ("#<boot-closure ", port);
- scm_uintprint ((unsigned long)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 ("_"));
- if (BOOT_CLOSURE_HAS_REST_ARGS (closure))
- args = scm_cons_star (scm_from_locale_symbol ("_"), args);
+ scm_from_latin1_symbol ("_"));
+ if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
+ 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;
}
{
SCM primitive_eval;
- scm_init_opts (scm_evaluator_traps,
- scm_evaluator_trap_table);
- scm_init_opts (scm_eval_options_interface,
- scm_eval_opts);
-
f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0);
HCoop / bpt / guile.git / blobdiff