X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/23f276dea70668b7291589de1c7d7ea7ebd9026f..a1652dec108b7b500146a57a99cd8aeb90e98ea9:/libguile/eval.c diff --git a/libguile/eval.c b/libguile/eval.c index 664d66217..8d11570fc 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 @@ -27,21 +27,21 @@ #include "libguile/__scm.h" -#include #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" @@ -97,7 +97,51 @@ */ -#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) @@ -106,16 +150,6 @@ #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"); @@ -126,22 +160,20 @@ static void error_used_before_defined (void) "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) @@ -160,6 +192,7 @@ eval (SCM x, SCM env) { SCM mx; SCM proc = SCM_UNDEFINED, args = SCM_EOL; + unsigned int argc; loop: SCM_TICK; @@ -194,7 +227,7 @@ eval (SCM x, SCM env) } case SCM_M_LAMBDA: - return scm_closure (mx, CAPTURE_ENV (env)); + RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env)); case SCM_M_QUOTE: return mx; @@ -203,6 +236,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); @@ -212,89 +281,39 @@ eval (SCM x, SCM 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: { @@ -303,7 +322,7 @@ eval (SCM x, SCM env) 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 @@ -341,7 +360,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))); } @@ -358,7 +377,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); @@ -387,194 +406,35 @@ eval (SCM x, SCM env) 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 } @@ -583,10 +443,12 @@ scm_t_option scm_eval_opts[] = { 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." }, @@ -692,56 +554,40 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, 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 @@ -985,31 +831,21 @@ scm_for_each (SCM proc, SCM arg1, SCM args) #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 @@ -1070,22 +906,252 @@ scm_apply (SCM proc, SCM arg1, SCM args) 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 ("#', 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" }