-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
- * Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
+ * Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
scm_t_bits scm_tc16_memoized;
-#define MAKMEMO(n, args) (scm_cell (scm_tc16_memoized | ((n) << 16), (scm_t_bits)(args)))
+#define MAKMEMO(n, args) \
+ (scm_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (args)))
#define MAKMEMO_BEGIN(exps) \
MAKMEMO (SCM_M_BEGIN, exps)
#define FULL_ARITY(nreq, rest, nopt, kw, inits, alt) \
scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, inits, \
alt, SCM_UNDEFINED)
-#define MAKMEMO_LAMBDA(body, arity) \
- MAKMEMO (SCM_M_LAMBDA, (scm_cons (body, arity)))
+#define MAKMEMO_LAMBDA(body, arity, docstring) \
+ MAKMEMO (SCM_M_LAMBDA, \
+ scm_cons (body, scm_cons (docstring, arity)))
#define MAKMEMO_LET(inits, body) \
MAKMEMO (SCM_M_LET, scm_cons (inits, body))
#define MAKMEMO_QUOTE(exp) \
return MAKMEMO_BEGIN (memoize_exps (REF (exp, SEQUENCE, EXPS), env));
case SCM_EXPANDED_LAMBDA:
- /* The body will be a lambda-case. */
- return memoize (REF (exp, LAMBDA, BODY), env);
+ /* 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;
+ int nreq, nopt, ntotal;
req = REF (exp, LAMBDA_CASE, REQ);
- rest = REF (exp, LAMBDA_CASE, REST);
+ 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);
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,
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))
else
arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
- return MAKMEMO_LAMBDA (memoize (body, new_env), arity);
+ return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
+ SCM_BOOL_F /* docstring */);
}
case SCM_EXPANDED_LET:
case SCM_EXPANDED_LETREC:
{
- SCM vars, exps, body, undefs, inits, sets, new_env;
- int i, nvars;
+ SCM vars, exps, body, undefs, new_env;
+ int i, nvars, in_order_p;
- vars = REF (exp, LET, GENSYMS);
- exps = REF (exp, LET, VALS);
- body = REF (exp, LET, BODY);
+ 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);
- inits = undefs = sets = SCM_EOL;
+ undefs = SCM_EOL;
new_env = env;
- for (; scm_is_pair (vars); vars = CDR (vars), i--)
+ for (; scm_is_pair (vars); vars = CDR (vars))
{
new_env = scm_cons (CAR (vars), new_env);
undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
- sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
- MAKMEMO_LEX_REF (i-1)),
- sets);
}
- for (; scm_is_pair (exps); exps = CDR (exps))
- inits = scm_cons (memoize (CAR (exps), new_env), inits);
- inits = scm_reverse_x (inits, SCM_UNDEFINED);
-
- return MAKMEMO_LET
- (undefs,
- MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (inits, MAKMEMO_BEGIN (sets)),
- memoize (body, new_env))));
+ if (in_order_p)
+ {
+ SCM body_exps = SCM_EOL;
+ 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);
+ body_exps = scm_cons (memoize (body, new_env), body_exps);
+ body_exps = scm_reverse_x (body_exps, SCM_UNDEFINED);
+ return MAKMEMO_LET (undefs, MAKMEMO_BEGIN (body_exps));
+ }
+ else
+ {
+ SCM sets = SCM_EOL, inits = SCM_EOL;
+ 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);
+ return MAKMEMO_LET
+ (undefs,
+ MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (inits, MAKMEMO_BEGIN (sets)),
+ memoize (body, new_env))));
+ }
}
case SCM_EXPANDED_DYNLET:
#define SCM_MAKE_MEMOIZER(STR, MEMOIZER, N) \
(scm_cell (scm_tc16_memoizer, \
- (scm_t_bits)(scm_c_make_gsubr (STR, N, 0, 0, MEMOIZER))))
+ SCM_UNPACK (scm_c_make_gsubr (STR, N, 0, 0, MEMOIZER))))
#define SCM_DEFINE_MEMOIZER(STR, MEMOIZER, N) \
SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_MEMOIZER (STR, MEMOIZER, N)))
-static SCM m_apply (SCM proc, SCM args);
+#define SCM_MAKE_REST_MEMOIZER(STR, MEMOIZER, N) \
+ (scm_cell (scm_tc16_memoizer, \
+ SCM_UNPACK ((scm_c_make_gsubr (STR, N, 0, 1, MEMOIZER)))))
+#define SCM_DEFINE_REST_MEMOIZER(STR, MEMOIZER, N) \
+SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_REST_MEMOIZER (STR, MEMOIZER, N)))
+
+static SCM m_apply (SCM proc, SCM arg, SCM rest);
static SCM m_call_cc (SCM proc);
static SCM m_call_values (SCM prod, SCM cons);
static SCM m_dynamic_wind (SCM pre, SCM exp, SCM post);
static SCM m_prompt (SCM tag, SCM exp, SCM handler);
-SCM_DEFINE_MEMOIZER ("@apply", m_apply, 2);
+SCM_DEFINE_REST_MEMOIZER ("@apply", m_apply, 2);
SCM_DEFINE_MEMOIZER ("@call-with-current-continuation", m_call_cc, 1);
SCM_DEFINE_MEMOIZER ("@call-with-values", m_call_values, 2);
SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind, 3);
\f
-static SCM m_apply (SCM proc, SCM args)
+static SCM m_apply (SCM proc, SCM arg, SCM rest)
#define FUNC_NAME "@apply"
{
+ long len;
+
SCM_VALIDATE_MEMOIZED (1, proc);
- SCM_VALIDATE_MEMOIZED (2, args);
- return MAKMEMO_APPLY (proc, args);
+ SCM_VALIDATE_MEMOIZED (2, arg);
+ len = scm_ilength (rest);
+ if (len < 0)
+ abort ();
+ else if (len == 0)
+ return MAKMEMO_APPLY (proc, arg);
+ else
+ {
+ SCM tail;
+
+ rest = scm_reverse (rest);
+ tail = scm_car (rest);
+ rest = scm_cdr (rest);
+ len--;
+
+ while (scm_is_pair (rest))
+ {
+ tail = MAKMEMO_CALL (MAKMEMO_MOD_REF (scm_list_1 (scm_from_latin1_symbol ("guile")),
+ scm_from_latin1_symbol ("cons"),
+ SCM_BOOL_F),
+ 2,
+ scm_list_2 (scm_car (rest), tail));
+ rest = scm_cdr (rest);
+ }
+ return MAKMEMO_APPLY (proc, tail);
+ }
}
#undef FUNC_NAME
return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
case SCM_M_LAMBDA:
- if (scm_is_null (CDDR (args)))
- return scm_list_3 (scm_sym_lambda,
- scm_make_list (CADR (args), sym_placeholder),
- unmemoize (CAR (args)));
- else if (scm_is_null (CDDDR (args)))
- {
- SCM formals = scm_make_list (CADR (args), sym_placeholder);
- return scm_list_3 (scm_sym_lambda,
- scm_is_true (CADDR (args))
- ? scm_cons_star (sym_placeholder, formals)
- : formals,
- unmemoize (CAR (args)));
- }
- else
- {
- SCM body = CAR (args), spec = CDR (args), alt, tail;
-
- alt = CADDR (CDDDR (spec));
- if (scm_is_true (alt))
- tail = CDR (unmemoize (alt));
- else
- tail = SCM_EOL;
-
- return scm_cons
- (sym_case_lambda_star,
- scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
- CADR (spec),
- CADDR (spec),
- CADDDR (spec),
- unmemoize_exprs (CADR (CDDDR (spec)))),
- unmemoize (body)),
- tail));
- }
+ {
+ SCM body = CAR (args), spec = CDDR (args);
+
+ if (scm_is_null (CDR (spec)))
+ return scm_list_3 (scm_sym_lambda,
+ scm_make_list (CAR (spec), sym_placeholder),
+ unmemoize (CAR (args)));
+ else if (scm_is_null (SCM_CDDR (spec)))
+ {
+ SCM formals = scm_make_list (CAR (spec), sym_placeholder);
+ return scm_list_3 (scm_sym_lambda,
+ scm_is_true (CADR (spec))
+ ? scm_cons_star (sym_placeholder, formals)
+ : formals,
+ unmemoize (CAR (args)));
+ }
+ else
+ {
+ SCM alt, tail;
+
+ alt = CADDR (CDDDR (spec));
+ if (scm_is_true (alt))
+ tail = CDR (unmemoize (alt));
+ else
+ tail = SCM_EOL;
+
+ return scm_cons
+ (sym_case_lambda_star,
+ scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
+ CADR (spec),
+ CADDR (spec),
+ CADDDR (spec),
+ unmemoize_exprs (CADR (CDDDR (spec)))),
+ unmemoize (body)),
+ tail));
+ }
+ }
case SCM_M_LET:
return scm_list_3 (scm_sym_let,
unmemoize_bindings (CAR (args)),
scm_init_memoize ()
{
scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
- scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);
scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
scm_tc16_memoizer = scm_make_smob_type ("memoizer", 0);
#include "libguile/memoize.x"
- list_of_guile = scm_list_1 (scm_from_locale_symbol ("guile"));
+ list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
}
/*
HCoop / bpt / guile.git / blobdiff