[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-109-gc438c
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-109-gc438cd7 |
|
Date: |
Wed, 28 Nov 2012 15:45:36 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=c438cd7175540536c3965b4ffea28ae6df7e59e0
The branch, stable-2.0 has been updated
via c438cd7175540536c3965b4ffea28ae6df7e59e0 (commit)
from fc32c44995dacb2c3f2fb9d1eafec59c44787c32 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit c438cd7175540536c3965b4ffea28ae6df7e59e0
Author: Ludovic Courtès <address@hidden>
Date: Wed Nov 28 16:42:49 2012 +0100
eval: Store docstrings for lambdas.
Fixes <http://bugs.gnu.org/12173>.
Reported by Ian Price <address@hidden>.
* 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.
-----------------------------------------------------------------------
Summary of changes:
libguile/eval.c | 10 ++--
libguile/memoize.c | 101 ++++++++++++++++++++++++++-----------------
libguile/procs.c | 9 ++--
libguile/procs.h | 5 ++-
module/ice-9/eval.scm | 43 +++++++++++--------
test-suite/tests/eval.test | 30 +++++++++++++
6 files changed, 130 insertions(+), 68 deletions(-)
diff --git a/libguile/eval.c b/libguile/eval.c
index e52fa48..c5b4580 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -109,16 +109,16 @@ static scm_t_bits scm_tc16_boot_closure;
#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)))
+#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) (SCM_I_INUM (CADDR
(BOOT_CLOSURE_CODE (x))))
+#define BOOT_CLOSURE_IS_FIXED(x) (scm_is_null (CDDDR (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)))
+#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (SCM_CDR
(BOOT_CLOSURE_CODE (x))))
+#define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (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); \
+ body = CAR (fu); fu = CDDR (fu); \
\
rest = kw = alt = SCM_BOOL_F; \
inits = SCM_EOL; \
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 911d972..0f4837a 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)),
diff --git a/libguile/procs.c b/libguile/procs.c
index a096591..59caed1 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2006, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2006, 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
@@ -75,7 +76,7 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_SYMBOL (sym_documentation, "documentation");
+SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
(SCM proc),
@@ -86,7 +87,7 @@ SCM_DEFINE (scm_procedure_documentation,
"procedure-documentation", 1, 0, 0,
#define FUNC_NAME s_scm_procedure_documentation
{
SCM_VALIDATE_PROC (SCM_ARG1, proc);
- return scm_procedure_property (proc, sym_documentation);
+ return scm_procedure_property (proc, scm_sym_documentation);
}
#undef FUNC_NAME
diff --git a/libguile/procs.h b/libguile/procs.h
index a4dfaff..a35872e 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -3,7 +3,8 @@
#ifndef SCM_PROCS_H
#define SCM_PROCS_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2006, 2008, 2009,
+ * 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
@@ -36,6 +37,8 @@ SCM_API SCM scm_procedure (SCM proc);
SCM_API SCM scm_setter (SCM proc);
SCM_INTERNAL void scm_init_procs (void);
+SCM_INTERNAL SCM scm_sym_documentation;
+
#endif /* SCM_PROCS_H */
/*
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 81b9538..4054bd8 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -1,7 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 2009, 2010
-;;;; Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 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
@@ -65,7 +64,7 @@
(define (make-formals n)
(map (lambda (i)
(datum->syntax
- x
+ x
(string->symbol
(string (integer->char (+ (char->integer #\a) i))))))
(iota n)))
@@ -225,11 +224,12 @@
;; multiple arities, as with case-lambda.
(define (make-general-closure env body nreq rest? nopt kw inits alt)
(define alt-proc
- (and alt
+ (and alt ; (body docstring nreq ...)
(let* ((body (car alt))
- (nreq (cadr alt))
- (rest (if (null? (cddr alt)) #f (caddr alt)))
- (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr
alt)))
+ (spec (cddr alt))
+ (nreq (car spec))
+ (rest (if (null? (cdr spec)) #f (cadr spec)))
+ (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr
spec)))
(nopt (if tail (car tail) 0))
(kw (and tail (cadr tail)))
(inits (if tail (caddr tail) '()))
@@ -246,9 +246,10 @@
(and kw (car kw))
(and rest? '_)))
(set-procedure-minimum-arity! proc nreq nopt rest?))
- (let* ((nreq* (cadr alt))
- (rest?* (if (null? (cddr alt)) #f (caddr alt)))
- (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr
alt)))
+ (let* ((spec (cddr alt))
+ (nreq* (car spec))
+ (rest?* (if (null? (cdr spec)) #f (cadr spec)))
+ (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr
spec)))
(nopt* (if tail (car tail) 0))
(alt* (and tail (cadddr tail))))
(if (or (< nreq* nreq)
@@ -397,14 +398,20 @@
(eval body new-env)
(lp (cdr inits)
(cons (eval (car inits) env) new-env)))))
-
- (('lambda (body nreq . tail))
- (if (null? tail)
- (make-fixed-closure eval nreq body (capture-env env))
- (if (null? (cdr tail))
- (make-general-closure (capture-env env) body nreq (car tail)
- 0 #f '() #f)
- (apply make-general-closure (capture-env env) body nreq
tail))))
+
+ (('lambda (body docstring nreq . tail))
+ (let ((proc
+ (if (null? tail)
+ (make-fixed-closure eval nreq body (capture-env env))
+ (if (null? (cdr tail))
+ (make-general-closure (capture-env env) body
+ nreq (car tail)
+ 0 #f '() #f)
+ (apply make-general-closure (capture-env env)
+ body nreq tail)))))
+ (when docstring
+ (set-procedure-property! proc 'documentation docstring))
+ proc))
(('begin (first . rest))
(let lp ((first first) (rest rest))
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index a5fbfec..6ab3b8a 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -428,6 +428,36 @@
(call-with-vm vm thunk))))
;;;
+;;; docstrings
+;;;
+
+(with-test-prefix "docstrings"
+
+ (pass-if-equal "fixed closure"
+ '("hello" "world")
+ (map procedure-documentation
+ (list (eval '(lambda (a b) "hello" (+ a b))
+ (current-module))
+ (eval '(lambda (a b) "world" (- a b))
+ (current-module)))))
+
+ (pass-if-equal "fixed closure with many args"
+ "So many args."
+ (procedure-documentation
+ (eval '(lambda (a b c d e f g h i j k)
+ "So many args."
+ (+ a b))
+ (current-module))))
+
+ (pass-if-equal "general closure"
+ "How general."
+ (procedure-documentation
+ (eval '(lambda* (a b #:key k #:rest r)
+ "How general."
+ (+ a b))
+ (current-module)))))
+
+;;;
;;; local-eval
;;;
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-109-gc438cd7,
Ludovic Courtès <=