-/* 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
#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"
*/
-#if 0
+/* Boot closures. We only see these when compiling eval.scm, because once
+ eval.scm is in the house, closures are standard VM closures.
+ */
+
+static scm_t_bits scm_tc16_boot_closure;
+#define RETURN_BOOT_CLOSURE(code, env) SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, (code), (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_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);
+
+
#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)
{
- while (!scm_is_null (formals))
- {
- if (!scm_is_pair (formals))
- return 0;
- if (scm_is_null (args))
- return 1;
- formals = CDR (formals);
- args = CDR (args);
- }
- return !scm_is_null (args) ? 1 : 0;
+ scm_error_scm (scm_from_locale_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_from_locale_string ("Unrecognized keyword"), SCM_EOL,
+ SCM_BOOL_F);
}
-static SCM apply (SCM proc, SCM args);
/* the environment:
(VAL ... . MOD)
{
SCM mx;
SCM proc = SCM_UNDEFINED, args = SCM_EOL;
+ unsigned int argc;
loop:
SCM_TICK;
}
case SCM_M_LAMBDA:
- return scm_closure (mx, CAPTURE_ENV (env));
+ RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));
case SCM_M_QUOTE:
return mx;
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);
apply_proc:
/* Go here to tail-apply a procedure. PROC is the procedure and
* ARGS is the list of arguments. */
- if (SCM_CLOSUREP (proc))
+ if (BOOT_CLOSURE_P (proc))
{
- int nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
- SCM new_env = SCM_ENV (proc);
- if (SCM_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 = SCM_CLOSURE_BODY (proc);
- env = new_env;
+ prepare_boot_closure_env_for_apply (proc, args, &x, &env);
goto loop;
}
else
- return apply (proc, args);
+ return scm_vm_apply (scm_the_vm (), proc, args);
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
proc = eval (CAR (mx), env);
-
- mx = CDR (mx);
+ argc = SCM_I_INUM (CADR (mx));
+ mx = CDDR (mx);
- if (SCM_CLOSUREP (proc))
+ if (BOOT_CLOSURE_P (proc))
{
- int nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
- SCM new_env = SCM_ENV (proc);
- if (SCM_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 = SCM_CLOSURE_BODY (proc);
- env = new_env;
+ prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
goto loop;
}
else
{
- SCM rest = SCM_EOL;
- for (; scm_is_pair (mx); mx = CDR (mx))
- rest = scm_cons (eval (CAR (mx), env), rest);
- return apply (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:
{
producer = eval (CAR (mx), env);
proc = eval (CDR (mx), env); /* proc is the consumer. */
- v = apply (producer, SCM_EOL);
+ v = scm_vm_apply (scm_the_vm (), producer, SCM_EOL);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
else
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)));
}
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);
return SCM_UNSPECIFIED;
}
- default:
- abort ();
- }
-}
-
-static SCM
-apply (SCM proc, SCM args)
-{
- SCM arg1, arg2, arg3, rest;
- unsigned int nargs;
-
- SCM_ASRTGO (SCM_NIMP (proc), badproc);
-
- /* Args contains a list of all args. */
- {
- int ilen = scm_ilength (args);
- if (ilen < 0)
- scm_wrong_num_args (proc);
- nargs = ilen;
- }
+ case SCM_M_PROMPT:
+ {
+ SCM vm, prompt, handler, res;
- /* Parse args. */
- switch (nargs)
- {
- case 0:
- arg1 = SCM_UNDEFINED; arg2 = SCM_UNDEFINED;
- arg3 = SCM_UNDEFINED; rest = SCM_EOL;
- break;
- case 1:
- arg1 = CAR (args); arg2 = SCM_UNDEFINED;
- arg3 = SCM_UNDEFINED; rest = SCM_EOL;
- break;
- case 2:
- arg1 = CAR (args); arg2 = CADR (args);
- arg3 = SCM_UNDEFINED; rest = SCM_EOL;
- break;
- default:
- arg1 = CAR (args); arg2 = CADR (args);
- arg3 = CADDR (args); rest = CDDDR (args);
- break;
- }
+ 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 ()));
- tail:
- switch (SCM_TYP7 (proc))
- {
- case scm_tcs_closures:
- {
- int nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
- SCM env = SCM_ENV (proc);
- if (SCM_CLOSURE_HAS_REST_ARGS (proc))
+ if (SCM_PROMPT_SETJMP (prompt))
{
- if (SCM_UNLIKELY (scm_ilength (args) < nreq))
- scm_wrong_num_args (proc);
- for (; nreq; nreq--, args = CDR (args))
- env = scm_cons (CAR (args), env);
- env = scm_cons (args, env);
- }
- else
- {
- for (; scm_is_pair (args); args = CDR (args), nreq--)
- env = scm_cons (CAR (args), env);
- if (SCM_UNLIKELY (nreq != 0))
- scm_wrong_num_args (proc);
+ /* The prompt exited nonlocally. */
+ proc = handler;
+ args = scm_i_prompt_pop_abort_args_x (prompt);
+ goto apply_proc;
}
- return eval (SCM_CLOSURE_BODY (proc), env);
+
+ res = eval (CADR (mx), env);
+ scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
+ return res;
}
- case scm_tc7_subr_2o:
- if (nargs > 2 || nargs < 1) scm_wrong_num_args (proc);
- return SCM_SUBRF (proc) (arg1, arg2);
- case scm_tc7_subr_2:
- if (nargs != 2) scm_wrong_num_args (proc);
- return SCM_SUBRF (proc) (arg1, arg2);
- case scm_tc7_subr_0:
- if (nargs != 0) scm_wrong_num_args (proc);
- return SCM_SUBRF (proc) ();
- case scm_tc7_subr_1:
- if (nargs != 1) scm_wrong_num_args (proc);
- return SCM_SUBRF (proc) (arg1);
- case scm_tc7_subr_1o:
- if (nargs > 1) scm_wrong_num_args (proc);
- return SCM_SUBRF (proc) (arg1);
- case scm_tc7_dsubr:
- if (nargs != 1) scm_wrong_num_args (proc);
- if (SCM_I_INUMP (arg1))
- return scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)));
- else if (SCM_REALP (arg1))
- return scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)));
- else if (SCM_BIGP (arg1))
- return scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)));
- else if (SCM_FRACTIONP (arg1))
- return scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)));
- SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
- SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
- case scm_tc7_cxr:
- if (nargs != 1) scm_wrong_num_args (proc);
- return scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc));
- case scm_tc7_subr_3:
- if (nargs != 3) scm_wrong_num_args (proc);
- return SCM_SUBRF (proc) (arg1, arg2, arg3);
- case scm_tc7_lsubr:
- return SCM_SUBRF (proc) (args);
- case scm_tc7_lsubr_2:
- if (nargs < 2) scm_wrong_num_args (proc);
- return SCM_SUBRF (proc) (arg1, arg2, scm_cddr (args));
- case scm_tc7_asubr:
- if (nargs < 2)
- return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED);
- for (args = CDR (args); nargs > 1; args = CDR (args), nargs--)
- arg1 = SCM_SUBRF (proc) (arg1, CAR (args));
- return arg1;
- case scm_tc7_program:
- return scm_vm_apply (scm_the_vm (), proc, args);
- case scm_tc7_rpsubr:
- if (nargs == 0)
- return SCM_BOOL_T;
- for (args = CDR (args); nargs > 1;
- arg1 = CAR (args), args = CDR (args), nargs--)
- if (scm_is_false (SCM_SUBRF (proc) (arg1, CAR (args))))
- return SCM_BOOL_F;
- return SCM_BOOL_T;
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- goto badproc;
- switch (nargs)
- {
- case 0:
- return SCM_SMOB_APPLY_0 (proc);
- case 1:
- return SCM_SMOB_APPLY_1 (proc, arg1);
- case 2:
- return SCM_SMOB_APPLY_2 (proc, arg1, arg2);
- default:
- return SCM_SMOB_APPLY_3 (proc, arg1, arg2, scm_cddr (args));
- }
- case scm_tc7_gsubr:
- return scm_i_gsubr_apply_list (proc, args);
- case scm_tc7_pws:
- return apply (SCM_PROCEDURE (proc), args);
- case scm_tcs_struct:
- if (SCM_STRUCT_APPLICABLE_P (proc))
- {
- proc = SCM_STRUCT_PROCEDURE (proc);
- goto tail;
- }
- else
- goto badproc;
- default:
- badproc:
- scm_wrong_type_arg ("apply", SCM_ARG1, proc);
- }
-}
-SCM
-scm_closure_apply (SCM proc, SCM args)
-{
- unsigned int nargs;
- int nreq;
- SCM env;
-
- /* Args contains a list of all args. */
- {
- int ilen = scm_ilength (args);
- if (ilen < 0)
- scm_wrong_num_args (proc);
- nargs = ilen;
- }
-
- nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
- env = SCM_ENV (proc);
- if (SCM_CLOSURE_HAS_REST_ARGS (proc))
- {
- if (SCM_UNLIKELY (scm_ilength (args) < nreq))
- scm_wrong_num_args (proc);
- for (; nreq; nreq--, args = CDR (args))
- env = scm_cons (CAR (args), env);
- env = scm_cons (args, env);
- }
- else
- {
- for (; scm_is_pair (args); args = CDR (args), nreq--)
- env = scm_cons (CAR (args), env);
- if (SCM_UNLIKELY (nreq != 0))
- scm_wrong_num_args (proc);
+ default:
+ abort ();
}
- return eval (SCM_CLOSURE_BODY (proc), env);
}
-
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, "breakpoints", 0,
+ "*This option is now obsolete. Setting it has no effect." },
+ { SCM_OPTION_BOOLEAN, "trace", 0,
+ "*This option is now obsolete. Setting it has no effect." },
{ SCM_OPTION_BOOLEAN, "procnames", 1,
- "Record procedure names at definition." },
+ "*This option is now obsolete. Setting it has no effect." },
{ SCM_OPTION_BOOLEAN, "backwards", 0,
"Display backtrace in anti-chronological order." },
{ SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
SCM
scm_call_0 (SCM proc)
{
- if (SCM_PROGRAM_P (proc))
- return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
- else
- return scm_apply (proc, SCM_EOL, SCM_EOL);
+ return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
}
SCM
scm_call_1 (SCM proc, SCM arg1)
{
- if (SCM_PROGRAM_P (proc))
- return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
- else
- return scm_apply (proc, arg1, scm_listofnull);
+ return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
}
SCM
scm_call_2 (SCM proc, SCM arg1, SCM arg2)
{
- if (SCM_PROGRAM_P (proc))
- {
- SCM args[] = { arg1, arg2 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 2);
- }
- else
- return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
+ SCM args[] = { arg1, arg2 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 2);
}
SCM
scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
{
- if (SCM_PROGRAM_P (proc))
- {
- SCM args[] = { arg1, arg2, arg3 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 3);
- }
- else
- return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
+ SCM args[] = { arg1, arg2, arg3 };
+ return scm_c_vm_run (scm_the_vm (), proc, args, 3);
}
SCM
scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
{
- if (SCM_PROGRAM_P (proc))
- {
- SCM args[] = { arg1, arg2, arg3, arg4 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 4);
- }
- else
- return scm_apply (proc, arg1, scm_cons2 (arg2, arg3,
- scm_cons (arg4, scm_listofnull)));
+ SCM args[] = { arg1, arg2, arg3, 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
#undef FUNC_NAME
-SCM
-scm_closure (SCM code, SCM env)
+static SCM
+scm_c_primitive_eval (SCM exp)
{
- SCM z;
- SCM closcar = scm_cons (code, SCM_EOL);
- z = scm_immutable_cell (SCM_UNPACK (closcar) + scm_tc3_closure,
- (scm_t_bits) env);
- scm_remember_upto_here (closcar);
- return z;
+ if (!SCM_EXPANDED_P (exp))
+ exp = scm_call_1 (scm_current_module_transformer (), exp);
+ return eval (scm_memoize_expression (exp), SCM_EOL);
}
-
-SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
- (SCM exp),
- "Evaluate @var{exp} in the top-level environment specified by\n"
- "the current module.")
-#define FUNC_NAME s_scm_primitive_eval
+static SCM var_primitive_eval;
+SCM
+scm_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);
+ return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval),
+ &exp, 1);
}
-#undef FUNC_NAME
/* Eval does not take the second arg optionally. This is intentional
else
args = scm_cons_star (arg1, args);
- return apply (proc, args);
+ return scm_vm_apply (scm_the_vm (), proc, 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 (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 (proc);
+ for (; nreq; nreq--, args = CDR (args))
+ env = scm_cons (CAR (args), env);
+ env = scm_cons (args, env);
+ *out_body = BOOT_CLOSURE_BODY (proc);
+ *out_env = env;
+ }
+ else
+ {
+ 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 (eval (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 (eval (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, eval (CAR (inits), CDR (tail)));
+ }
+ }
+ }
+
+ *out_body = body;
+ *out_env = 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 (eval (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 (eval (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);
+ 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 (eval (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);
+ args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
+ scm_from_locale_symbol ("_"));
+ if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
+ args = scm_cons_star (scm_from_locale_symbol ("_"), args);
+ /* FIXME: optionals and rests */
+ scm_display (args, port);
+ scm_putc ('>', port);
+ return 1;
+}
void
scm_init_eval ()
{
+ SCM primitive_eval;
+
scm_init_opts (scm_evaluator_traps,
scm_evaluator_trap_table);
scm_init_opts (scm_eval_options_interface,
scm_eval_opts);
- scm_listofnull = scm_list_1 (SCM_EOL);
+ f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
+
+ scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0);
+ scm_set_smob_apply (scm_tc16_boot_closure, boot_closure_apply, 0, 0, 1);
+ scm_set_smob_print (scm_tc16_boot_closure, boot_closure_print);
- f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply);
- scm_permanent_object (f_apply);
+ primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
+ scm_c_primitive_eval);
+ var_primitive_eval = scm_define (SCM_SUBR_NAME (primitive_eval),
+ primitive_eval);
#include "libguile/eval.x"
}
HCoop / bpt / guile.git / blobdiff