summaryrefslogtreecommitdiff
path: root/libguile/eval.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/eval.c')
-rw-r--r--libguile/eval.c120
1 files changed, 84 insertions, 36 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index 48d1d74ef..f775d31b1 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -1,4 +1,4 @@
-/* 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
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -24,6 +24,7 @@
#endif
#include <alloca.h>
+#include <assert.h>
#include "libguile/__scm.h"
@@ -31,6 +32,7 @@
#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"
@@ -40,7 +42,6 @@
#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"
@@ -111,7 +112,6 @@ static scm_t_bits scm_tc16_boot_closure;
-#if 0
#define CAR(x) SCM_CAR(x)
#define CDR(x) SCM_CDR(x)
#define CAAR(x) SCM_CAAR(x)
@@ -120,16 +120,6 @@ static scm_t_bits scm_tc16_boot_closure;
#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");
@@ -172,6 +162,7 @@ eval (SCM x, SCM env)
{
SCM mx;
SCM proc = SCM_UNDEFINED, args = SCM_EOL;
+ unsigned int argc;
loop:
SCM_TICK;
@@ -215,6 +206,42 @@ eval (SCM x, SCM env)
scm_define (CAR (mx), eval (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);
+ 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] = eval (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);
+
+ 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);
@@ -253,7 +280,7 @@ eval (SCM x, SCM env)
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
proc = eval (CAR (mx), env);
- /* int nargs = CADR (mx); */
+ argc = SCM_I_INUM (CADR (mx));
mx = CDDR (mx);
if (BOOT_CLOSURE_P (proc))
@@ -262,7 +289,7 @@ eval (SCM x, SCM env)
SCM new_env = BOOT_CLOSURE_ENV (proc);
if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
{
- if (SCM_UNLIKELY (scm_ilength (mx) < nreq))
+ if (SCM_UNLIKELY (argc < nreq))
scm_wrong_num_args (proc);
for (; nreq; nreq--, mx = CDR (mx))
new_env = scm_cons (eval (CAR (mx), env), new_env);
@@ -287,27 +314,18 @@ eval (SCM x, SCM env)
}
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] = eval (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 (eval (mx, env));
case SCM_M_CALL_WITH_VALUES:
{
@@ -354,7 +372,7 @@ eval (SCM x, SCM env)
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)));
}
@@ -371,7 +389,7 @@ eval (SCM x, SCM env)
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);
@@ -400,6 +418,30 @@ eval (SCM x, SCM env)
return SCM_UNSPECIFIED;
}
+ case SCM_M_PROMPT:
+ {
+ SCM vm, prompt, handler, res;
+
+ vm = scm_the_vm ();
+ prompt = scm_c_make_prompt (eval (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);
+ 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);
+ goto apply_proc;
+ }
+
+ res = eval (CADR (mx), env);
+ scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
+ return res;
+ }
+
default:
abort ();
}
@@ -552,6 +594,12 @@ scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
return scm_c_vm_run (scm_the_vm (), proc, args, 4);
}
+SCM
+scm_call_n (SCM proc, SCM *argv, size_t nargs)
+{
+ return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
+}
+
/* Simple procedure applies
*/