summaryrefslogtreecommitdiff
path: root/libguile/memoize.c
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2012-11-28 16:42:49 +0100
committerLudovic Courtès <ludo@gnu.org>2012-11-28 16:43:59 +0100
commitc438cd7175540536c3965b4ffea28ae6df7e59e0 (patch)
treed605cd827451938f46218bb8692d44438cb0ecce /libguile/memoize.c
parentfc32c44995dacb2c3f2fb9d1eafec59c44787c32 (diff)
downloadguile-c438cd7175540536c3965b4ffea28ae6df7e59e0.tar.gz
eval: Store docstrings for lambdas.
Fixes <http://bugs.gnu.org/12173>. Reported by Ian Price <ianprice90@googlemail.com>. * libguile/memoize.c (MAKMEMO_LAMBDA): New `docstring' parameter. Add it as the second argument of `SCM_M_LAMBDA'. Update caller. (memoize)[SCM_M_LAMBDA]: Extract docstring from EXP; when `memoize' returns, add the docstring to the lambda's arguments. (unmemoize)[SCM_M_LAMBDA]: Adjust to new argument layout of `SCM_M_LAMBDA'. * libguile/eval.c (BOOT_CLOSURE_NUM_REQUIRED_ARGS, BOOT_CLOSURE_HAS_REST_ARGS, BOOT_CLOSURE_IS_REST, BOOT_CLOSURE_PARSE_FULL): Adjust to new argument layout of `SCM_M_LAMBDA'. * module/ice-9/eval.scm (primitive-eval)[make-general-closure]: Likewise. [eval]: When EXP is a lambda, match its docstring; when the docstring is not #f, add it to the closures procedure properties. * test-suite/tests/eval.test ("docstrings"): New test prefix. * libguile/procs.c (sym_documentation): Rename to... (scm_sym_documentation): ... this. Make it global. * libguile/procs.h (scm_sym_documentation): New declaration.
Diffstat (limited to 'libguile/memoize.c')
-rw-r--r--libguile/memoize.c101
1 files changed, 61 insertions, 40 deletions
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 911d97294..0f4837a92 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -1,6 +1,7 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
- * Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
+ * 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
@@ -78,8 +79,9 @@ scm_t_bits scm_tc16_memoized;
#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) \
@@ -268,7 +270,21 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_LAMBDA:
/* The body will be a lambda-case. */
- return memoize (REF (exp, LAMBDA, BODY), env);
+ {
+ SCM meta, docstring, proc;
+
+ meta = REF (exp, LAMBDA, META);
+ docstring = scm_assoc_ref (meta, scm_sym_documentation);
+
+ proc = memoize (REF (exp, LAMBDA, 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:
{
@@ -350,7 +366,8 @@ memoize (SCM exp, SCM env)
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:
@@ -640,39 +657,43 @@ unmemoize (const SCM expr)
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)),