SCM random2scm(Random* rnd) { SCM_DEFER_INTS; SCM smob; SCM_NEWCELL (smob); SCM_SETCDR (smob, rnd); SCM_SETCAR (smob, random_tag_type); SCM_ALLOW_INTS; return smob; }
SCM gconf2scm (GConfEngine* conf) { SCM smob; gh_defer_ints(); SCM_NEWCELL (smob); SCM_SETCDR (smob, conf); SCM_SETCAR (smob, gconf_type_tag); gh_allow_ints(); return smob; }
inline void tmscm_set_car (tmscm a, tmscm b) { SCM_SETCAR(a,b); }
static SCM eval (SCM x, SCM env) { SCM mx; SCM proc = SCM_UNDEFINED, args = SCM_EOL; unsigned int argc; loop: SCM_TICK; if (!SCM_MEMOIZED_P (x)) abort (); mx = SCM_MEMOIZED_ARGS (x); switch (SCM_MEMOIZED_TAG (x)) { case SCM_M_SEQ: eval (CAR (mx), env); x = CDR (mx); goto loop; case SCM_M_IF: if (scm_is_true (EVAL1 (CAR (mx), env))) x = CADR (mx); else x = CDDR (mx); goto loop; case SCM_M_LET: { SCM inits = CAR (mx); SCM new_env = CAPTURE_ENV (env); for (; scm_is_pair (inits); inits = CDR (inits)) new_env = scm_cons (EVAL1 (CAR (inits), env), new_env); env = new_env; x = CDR (mx); goto loop; } case SCM_M_LAMBDA: RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env)); case SCM_M_QUOTE: return mx; case SCM_M_DEFINE: scm_define (CAR (mx), EVAL1 (CDR (mx), env)); return SCM_UNSPECIFIED; case SCM_M_DYNWIND: { SCM in, out, res; scm_i_thread *t = SCM_I_CURRENT_THREAD; in = EVAL1 (CAR (mx), env); out = EVAL1 (CDDR (mx), env); scm_call_0 (in); scm_dynstack_push_dynwind (&t->dynstack, in, out); res = eval (CADR (mx), env); scm_dynstack_pop (&t->dynstack); scm_call_0 (out); return res; } case SCM_M_WITH_FLUIDS: { long i, len; SCM *fluidv, *valuesv, walk, res; scm_i_thread *thread = SCM_I_CURRENT_THREAD; 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); scm_dynstack_push_fluids (&thread->dynstack, len, fluidv, valuesv, thread->dynamic_state); res = eval (CDDR (mx), env); scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state); return res; } case SCM_M_APPLY: /* Evaluate the procedure to be applied. */ proc = EVAL1 (CAR (mx), env); /* Evaluate the argument holding the list of arguments */ 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)) { prepare_boot_closure_env_for_apply (proc, args, &x, &env); goto loop; } else return scm_call_with_vm (scm_the_vm (), proc, args); case SCM_M_CALL: /* Evaluate the procedure to be applied. */ proc = EVAL1 (CAR (mx), env); argc = SCM_I_INUM (CADR (mx)); mx = CDDR (mx); if (BOOT_CLOSURE_P (proc)) { prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env); goto loop; } else { 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: return scm_i_call_with_current_continuation (EVAL1 (mx, env)); case SCM_M_CALL_WITH_VALUES: { SCM producer; SCM v; 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 args = scm_list_1 (v); goto apply_proc; } case SCM_M_LEXICAL_REF: { int n; SCM ret; for (n = SCM_I_INUM (mx); n; n--) env = CDR (env); ret = CAR (env); if (SCM_UNLIKELY (SCM_UNBNDP (ret))) /* we don't know what variable, though, because we don't have its name */ error_used_before_defined (); return ret; } case SCM_M_LEXICAL_SET: { int n; SCM val = EVAL1 (CDR (mx), env); for (n = SCM_I_INUM (CAR (mx)); n; n--) env = CDR (env); SCM_SETCAR (env, val); return SCM_UNSPECIFIED; } case SCM_M_TOPLEVEL_REF: if (SCM_VARIABLEP (mx)) return SCM_VARIABLE_REF (mx); else { while (scm_is_pair (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 = EVAL1 (CDR (mx), env); if (SCM_VARIABLEP (var)) { SCM_VARIABLE_SET (var, val); return SCM_UNSPECIFIED; } else { while (scm_is_pair (env)) env = CDR (env); SCM_VARIABLE_SET (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)), val); return SCM_UNSPECIFIED; } } case SCM_M_MODULE_REF: if (SCM_VARIABLEP (mx)) return SCM_VARIABLE_REF (mx); else return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x, SCM_BOOL_F)); case SCM_M_MODULE_SET: if (SCM_VARIABLEP (CDR (mx))) { 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), EVAL1 (CAR (mx), env)); return SCM_UNSPECIFIED; } case SCM_M_PROMPT: { SCM vm, k, res; scm_i_jmp_buf registers; /* We need the handler after nonlocal return to the setjmp, so make sure it is volatile. */ volatile SCM handler; k = EVAL1 (CAR (mx), env); handler = EVAL1 (CDDR (mx), env); vm = scm_the_vm (); /* Push the prompt onto the dynamic stack. */ scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack, SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY, k, SCM_VM_DATA (vm)->fp, SCM_VM_DATA (vm)->sp, SCM_VM_DATA (vm)->ip, ®isters); if (SCM_I_SETJMP (registers)) { /* 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_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack); return res; } default: abort (); } }
static SCM sort_applicable_methods (SCM method_list, long size, SCM const *targs) { long i, j, incr; SCM *v, vector = SCM_EOL; SCM buffer[BUFFSIZE]; SCM save = method_list; scm_t_array_handle handle; /* For reasonably sized method_lists we can try to avoid all the * consing and reorder the list in place... * This idea is due to David McClain <*****@*****.**> */ if (size <= BUFFSIZE) { for (i = 0; i < size; i++) { buffer[i] = SCM_CAR (method_list); method_list = SCM_CDR (method_list); } v = buffer; } else { /* Too many elements in method_list to keep everything locally */ vector = scm_i_vector2list (save, size); v = scm_vector_writable_elements (vector, &handle, NULL, NULL); } /* Use a simple shell sort since it is generally faster than qsort on * small vectors (which is probably mostly the case when we have to * sort a list of applicable methods). */ for (incr = size / 2; incr; incr /= 2) { for (i = incr; i < size; i++) { for (j = i - incr; j >= 0; j -= incr) { if (more_specificp (v[j], v[j+incr], targs)) break; else { SCM tmp = v[j + incr]; v[j + incr] = v[j]; v[j] = tmp; } } } } if (size <= BUFFSIZE) { /* We did it in locally, so restore the original list (reordered) in-place */ for (i = 0, method_list = save; i < size; i++, v++) { SCM_SETCAR (method_list, *v); method_list = SCM_CDR (method_list); } return save; } /* If we are here, that's that we did it the hard way... */ scm_array_handle_release (&handle); return scm_vector_to_list (vector); }
static SCM memoize (SCM exp, SCM env) { if (!SCM_EXPANDED_P (exp)) abort (); switch (SCM_EXPANDED_TYPE (exp)) { case SCM_EXPANDED_VOID: return MAKMEMO_QUOTE (SCM_UNSPECIFIED); case SCM_EXPANDED_CONST: return MAKMEMO_QUOTE (REF (exp, CONST, EXP)); case SCM_EXPANDED_PRIMITIVE_REF: if (scm_is_eq (scm_current_module (), scm_the_root_module ())) return maybe_makmemo_capture_module (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF, REF (exp, PRIMITIVE_REF, NAME))), env); else return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF, list_of_guile, REF (exp, PRIMITIVE_REF, NAME), SCM_BOOL_F)); case SCM_EXPANDED_LEXICAL_REF: return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env)); case SCM_EXPANDED_LEXICAL_SET: return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env), memoize (REF (exp, LEXICAL_SET, EXP), env)); case SCM_EXPANDED_MODULE_REF: return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF, REF (exp, MODULE_REF, MOD), REF (exp, MODULE_REF, NAME), REF (exp, MODULE_REF, PUBLIC))); case SCM_EXPANDED_MODULE_SET: return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_SET, REF (exp, MODULE_SET, MOD), REF (exp, MODULE_SET, NAME), REF (exp, MODULE_SET, PUBLIC)), memoize (REF (exp, MODULE_SET, EXP), env)); case SCM_EXPANDED_TOPLEVEL_REF: return maybe_makmemo_capture_module (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF, REF (exp, TOPLEVEL_REF, NAME))), env); case SCM_EXPANDED_TOPLEVEL_SET: return maybe_makmemo_capture_module (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_SET, REF (exp, TOPLEVEL_SET, NAME)), memoize (REF (exp, TOPLEVEL_SET, EXP), capture_env (env))), env); case SCM_EXPANDED_TOPLEVEL_DEFINE: return maybe_makmemo_capture_module (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_DEFINE, REF (exp, TOPLEVEL_DEFINE, NAME)), memoize (REF (exp, TOPLEVEL_DEFINE, EXP), capture_env (env))), env); case SCM_EXPANDED_CONDITIONAL: return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env), memoize (REF (exp, CONDITIONAL, CONSEQUENT), env), memoize (REF (exp, CONDITIONAL, ALTERNATE), env)); case SCM_EXPANDED_CALL: { SCM proc, args; proc = REF (exp, CALL, PROC); args = memoize_exps (REF (exp, CALL, ARGS), env); return MAKMEMO_CALL (memoize (proc, env), args); } case SCM_EXPANDED_PRIMCALL: { SCM name, args; int nargs; name = REF (exp, PRIMCALL, NAME); args = memoize_exps (REF (exp, PRIMCALL, ARGS), env); nargs = scm_ilength (args); if (nargs == 3 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt"))) return MAKMEMO_CALL_WITH_PROMPT (CAR (args), CADR (args), CADDR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("apply"))) return MAKMEMO_APPLY (CAR (args), CADR (args)); else if (nargs == 1 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-current-continuation"))) return MAKMEMO_CONT (CAR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-values"))) return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args)); else if (nargs == 1 && scm_is_eq (name, scm_from_latin1_symbol ("variable-ref"))) return MAKMEMO_BOX_REF (CAR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("variable-set!"))) return MAKMEMO_BOX_SET (CAR (args), CADR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("wind"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("unwind"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), SCM_EOL); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), SCM_EOL); else if (nargs == 1 && scm_is_eq (name, scm_from_latin1_symbol ("push-dynamic-state"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (push_dynamic_state), args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("pop-dynamic-state"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_dynamic_state), SCM_EOL); else if (scm_is_eq (scm_current_module (), scm_the_root_module ())) return MAKMEMO_CALL (maybe_makmemo_capture_module (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF, name)), env), args); else return MAKMEMO_CALL (MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF, list_of_guile, name, SCM_BOOL_F)), args); } case SCM_EXPANDED_SEQ: return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env), memoize (REF (exp, SEQ, TAIL), env)); case SCM_EXPANDED_LAMBDA: /* The body will be a lambda-case. */ { SCM meta, body, proc, new_env; meta = REF (exp, LAMBDA, META); body = REF (exp, LAMBDA, BODY); new_env = push_flat_link (capture_env (env)); proc = memoize (body, new_env); SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta); return maybe_makmemo_capture_module (capture_flat_env (proc, new_env), env); } case SCM_EXPANDED_LAMBDA_CASE: { SCM req, rest, opt, kw, inits, vars, body, alt; SCM unbound, arity, rib, new_env; int nreq, nopt, ninits; req = REF (exp, LAMBDA_CASE, REQ); rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST))); opt = REF (exp, LAMBDA_CASE, OPT); kw = REF (exp, LAMBDA_CASE, KW); inits = REF (exp, LAMBDA_CASE, INITS); vars = REF (exp, LAMBDA_CASE, GENSYMS); body = REF (exp, LAMBDA_CASE, BODY); alt = REF (exp, LAMBDA_CASE, ALTERNATE); nreq = scm_ilength (req); nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0; ninits = scm_ilength (inits); /* This relies on assignment conversion turning inits into a sequence of CONST expressions whose values are a unique "unbound" token. */ unbound = ninits ? REF (CAR (inits), CONST, EXP) : SCM_BOOL_F; rib = scm_vector (vars); new_env = push_nested_link (rib, env); if (scm_is_true (kw)) { /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */ SCM aok = CAR (kw), indices = SCM_EOL; for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw)) { SCM k; int idx; k = CAR (CAR (kw)); idx = lookup_rib (CADDR (CAR (kw)), rib); indices = scm_acons (k, SCM_I_MAKINUM (idx), indices); } kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED)); } if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt)) { if (scm_is_false (rest)) arity = FIXED_ARITY (nreq); else arity = REST_ARITY (nreq, SCM_BOOL_T); } else if (scm_is_true (alt)) arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound, SCM_MEMOIZED_ARGS (memoize (alt, env))); else arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound, SCM_BOOL_F); return MAKMEMO_LAMBDA (memoize (body, new_env), arity, SCM_EOL /* meta, filled in later */); } case SCM_EXPANDED_LET: { SCM vars, exps, body, varsv, inits, new_env; int i; vars = REF (exp, LET, GENSYMS); exps = REF (exp, LET, VALS); body = REF (exp, LET, BODY); varsv = scm_vector (vars); inits = scm_c_make_vector (VECTOR_LENGTH (varsv), SCM_BOOL_F); new_env = push_nested_link (varsv, capture_env (env)); for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++) VECTOR_SET (inits, i, memoize (CAR (exps), env)); return maybe_makmemo_capture_module (MAKMEMO_LET (inits, memoize (body, new_env)), env); } default: abort (); } }
static SCM memoize (SCM exp, SCM env) { if (!SCM_EXPANDED_P (exp)) abort (); switch (SCM_EXPANDED_TYPE (exp)) { case SCM_EXPANDED_VOID: return MAKMEMO_QUOTE (SCM_UNSPECIFIED); case SCM_EXPANDED_CONST: return MAKMEMO_QUOTE (REF (exp, CONST, EXP)); case SCM_EXPANDED_PRIMITIVE_REF: if (scm_is_eq (scm_current_module (), scm_the_root_module ())) return MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME)); else return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME), SCM_BOOL_F); case SCM_EXPANDED_LEXICAL_REF: return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env)); case SCM_EXPANDED_LEXICAL_SET: return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env), memoize (REF (exp, LEXICAL_SET, EXP), env)); case SCM_EXPANDED_MODULE_REF: return MAKMEMO_MOD_REF (REF (exp, MODULE_REF, MOD), REF (exp, MODULE_REF, NAME), REF (exp, MODULE_REF, PUBLIC)); case SCM_EXPANDED_MODULE_SET: return MAKMEMO_MOD_SET (memoize (REF (exp, MODULE_SET, EXP), env), REF (exp, MODULE_SET, MOD), REF (exp, MODULE_SET, NAME), REF (exp, MODULE_SET, PUBLIC)); case SCM_EXPANDED_TOPLEVEL_REF: return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME)); case SCM_EXPANDED_TOPLEVEL_SET: return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME), memoize (REF (exp, TOPLEVEL_SET, EXP), env)); case SCM_EXPANDED_TOPLEVEL_DEFINE: return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME), memoize (REF (exp, TOPLEVEL_DEFINE, EXP), env)); case SCM_EXPANDED_CONDITIONAL: return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env), memoize (REF (exp, CONDITIONAL, CONSEQUENT), env), memoize (REF (exp, CONDITIONAL, ALTERNATE), env)); case SCM_EXPANDED_CALL: { SCM proc, args; proc = REF (exp, CALL, PROC); args = memoize_exps (REF (exp, CALL, ARGS), env); return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args); } case SCM_EXPANDED_PRIMCALL: { SCM name, args; int nargs; name = REF (exp, PRIMCALL, NAME); args = memoize_exps (REF (exp, PRIMCALL, ARGS), env); nargs = scm_ilength (args); if (nargs == 3 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt"))) return MAKMEMO_CALL_WITH_PROMPT (CAR (args), CADR (args), CADDR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("apply"))) return MAKMEMO_APPLY (CAR (args), CADR (args)); else if (nargs == 1 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-current-continuation"))) return MAKMEMO_CONT (CAR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-values"))) return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("wind"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("unwind"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL); else if (scm_is_eq (scm_current_module (), scm_the_root_module ())) return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args); else return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name, SCM_BOOL_F), nargs, args); } case SCM_EXPANDED_SEQ: return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env), memoize (REF (exp, SEQ, TAIL), env)); case SCM_EXPANDED_LAMBDA: /* The body will be a lambda-case or #f. */ { SCM meta, docstring, body, proc; meta = REF (exp, LAMBDA, META); docstring = scm_assoc_ref (meta, scm_sym_documentation); body = REF (exp, LAMBDA, BODY); if (scm_is_false (body)) /* Give a body to case-lambda with no clauses. */ proc = MAKMEMO_LAMBDA (MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, scm_from_latin1_symbol ("throw"), SCM_BOOL_F), 5, scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key), MAKMEMO_QUOTE (SCM_BOOL_F), MAKMEMO_QUOTE (scm_from_latin1_string ("Wrong number of arguments")), MAKMEMO_QUOTE (SCM_EOL), MAKMEMO_QUOTE (SCM_BOOL_F))), FIXED_ARITY (0), SCM_BOOL_F /* docstring */); else proc = memoize (body, env); if (scm_is_string (docstring)) { SCM args = SCM_MEMOIZED_ARGS (proc); SCM_SETCAR (SCM_CDR (args), docstring); } return proc; } case SCM_EXPANDED_LAMBDA_CASE: { SCM req, rest, opt, kw, inits, vars, body, alt; SCM walk, minits, arity, new_env; int nreq, nopt, ntotal; req = REF (exp, LAMBDA_CASE, REQ); rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST))); opt = REF (exp, LAMBDA_CASE, OPT); kw = REF (exp, LAMBDA_CASE, KW); inits = REF (exp, LAMBDA_CASE, INITS); vars = REF (exp, LAMBDA_CASE, GENSYMS); body = REF (exp, LAMBDA_CASE, BODY); alt = REF (exp, LAMBDA_CASE, ALTERNATE); nreq = scm_ilength (req); nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0; ntotal = scm_ilength (vars); /* The vars are the gensyms, according to the divine plan. But we need to memoize the inits within their appropriate environment, complicating things. */ new_env = env; for (walk = req; scm_is_pair (walk); walk = CDR (walk), vars = CDR (vars)) new_env = scm_cons (CAR (vars), new_env); minits = SCM_EOL; for (walk = opt; scm_is_pair (walk); walk = CDR (walk), vars = CDR (vars), inits = CDR (inits)) { minits = scm_cons (memoize (CAR (inits), new_env), minits); new_env = scm_cons (CAR (vars), new_env); } if (scm_is_true (rest)) { new_env = scm_cons (CAR (vars), new_env); vars = CDR (vars); } for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits)) { minits = scm_cons (memoize (CAR (inits), new_env), minits); new_env = scm_cons (CAR (vars), new_env); } if (!scm_is_null (vars)) abort (); minits = scm_reverse_x (minits, SCM_UNDEFINED); if (scm_is_true (kw)) { /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */ SCM aok = CAR (kw), indices = SCM_EOL; for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw)) { SCM k; int idx; k = CAR (CAR (kw)); idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env); indices = scm_acons (k, SCM_I_MAKINUM (idx), indices); } kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED)); } if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt)) { if (scm_is_false (rest)) arity = FIXED_ARITY (nreq); else arity = REST_ARITY (nreq, SCM_BOOL_T); } else if (scm_is_true (alt)) arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_MEMOIZED_ARGS (memoize (alt, env))); else arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F); return MAKMEMO_LAMBDA (memoize (body, new_env), arity, SCM_BOOL_F /* docstring */); } case SCM_EXPANDED_LET: { SCM vars, exps, body, inits, new_env; vars = REF (exp, LET, GENSYMS); exps = REF (exp, LET, VALS); body = REF (exp, LET, BODY); inits = SCM_EOL; new_env = env; for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps)) { new_env = scm_cons (CAR (vars), new_env); inits = scm_cons (memoize (CAR (exps), env), inits); } return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED), memoize (body, new_env)); } case SCM_EXPANDED_LETREC: { SCM vars, exps, body, undefs, new_env; int i, nvars, in_order_p; vars = REF (exp, LETREC, GENSYMS); exps = REF (exp, LETREC, VALS); body = REF (exp, LETREC, BODY); in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P)); nvars = i = scm_ilength (vars); undefs = SCM_EOL; new_env = env; for (; scm_is_pair (vars); vars = CDR (vars)) { new_env = scm_cons (CAR (vars), new_env); undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs); } if (in_order_p) { SCM body_exps = SCM_EOL, seq; for (; scm_is_pair (exps); exps = CDR (exps), i--) body_exps = scm_cons (MAKMEMO_LEX_SET (i-1, memoize (CAR (exps), new_env)), body_exps); seq = memoize (body, new_env); for (; scm_is_pair (body_exps); body_exps = CDR (body_exps)) seq = MAKMEMO_SEQ (CAR (body_exps), seq); return MAKMEMO_LET (undefs, seq); } else { SCM sets = SCM_EOL, inits = SCM_EOL, set_seq; for (; scm_is_pair (exps); exps = CDR (exps), i--) { sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars, MAKMEMO_LEX_REF (i-1)), sets); inits = scm_cons (memoize (CAR (exps), new_env), inits); } inits = scm_reverse_x (inits, SCM_UNDEFINED); sets = scm_reverse_x (sets, SCM_UNDEFINED); if (scm_is_null (sets)) return memoize (body, env); for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets); sets = CDR (sets)) set_seq = MAKMEMO_SEQ (CAR (sets), set_seq); return MAKMEMO_LET (undefs, MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq), memoize (body, new_env))); } } default: abort (); } }