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.

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_NUM_REQUIRED_ARGS(x) (SCM_I_INUM (CADDR (BOOT_CLOSURE_CODE (x))))
-#define BOOT_CLOSURE_IS_FIXED(x) scm_is_null (CDDR (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_HAS_REST_ARGS(x) scm_is_true (CADDR (SCM_CDR (BOOT_CLOSURE_CODE (x))))
-#define BOOT_CLOSURE_IS_REST(x) scm_is_null (CDDDR (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;                                            \

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
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * Free Software Foundation, Inc.
+ *   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) \
+#define MAKMEMO_LAMBDA(body, arity, docstring)			\
-  MAKMEMO (SCM_M_LAMBDA, (scm_cons (body, arity)))
+  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 body = CAR (args), spec = CDDR (args);
-                           scm_make_list (CADR (args), sym_placeholder),
+
-                           unmemoize (CAR (args)));
+	if (scm_is_null (CDR (spec)))
-      else if (scm_is_null (CDDDR (args)))
+	  return scm_list_3 (scm_sym_lambda,
-        {
+			     scm_make_list (CAR (spec), sym_placeholder),
-          SCM formals = scm_make_list (CADR (args), sym_placeholder);
+			     unmemoize (CAR (args)));
-          return scm_list_3 (scm_sym_lambda,
+	else if (scm_is_null (SCM_CDDR (spec)))
-                             scm_is_true (CADDR (args))
+	  {
-                             ? scm_cons_star (sym_placeholder, formals)
+	    SCM formals = scm_make_list (CAR (spec), sym_placeholder);
-                             : formals,
+	    return scm_list_3 (scm_sym_lambda,
-                             unmemoize (CAR (args)));
+			       scm_is_true (CADR (spec))
-        }
+			       ? scm_cons_star (sym_placeholder, formals)
-      else
+			       : formals,
-        {
+			       unmemoize (CAR (args)));
-          SCM body = CAR (args), spec = CDR (args), alt, tail;
+	  }
-          
+	else
-          alt = CADDR (CDDDR (spec));
+	  {
-          if (scm_is_true (alt))
+	    SCM alt, tail;
-            tail = CDR (unmemoize (alt));
+
-          else
+	    alt = CADDR (CDDDR (spec));
-            tail = SCM_EOL;
+	    if (scm_is_true (alt))
-          
+	      tail = CDR (unmemoize (alt));
-          return scm_cons
+	    else
-            (sym_case_lambda_star,
+	      tail = SCM_EOL;
-             scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
+
-                                               CADR (spec),
+	    return scm_cons
-                                               CADDR (spec),
+	      (sym_case_lambda_star,
-                                               CADDDR (spec),
+	       scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
-                                               unmemoize_exprs (CADR (CDDDR (spec)))),
+						 CADR (spec),
-                                   unmemoize (body)),
+						 CADDR (spec),
-                       tail));
+						 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)),

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
 

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 */
 
 /*

module/ice-9/eval.scm

@@ -1,7 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 
-;;;; Copyright (C) 2009, 2010
+;;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc.
-;;;; 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))
+                    (spec (cddr alt))
-                    (rest (if (null? (cddr alt)) #f (caddr alt)))
+                    (nreq (car spec))
-                    (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt)))
+                    (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))
+              (let* ((spec (cddr alt))
-                     (rest?* (if (null? (cddr alt)) #f (caddr alt)))
+                     (nreq* (car spec))
-                     (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt)))
+                     (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))
+        (('lambda (body docstring nreq . tail))
-         (if (null? tail)
+         (let ((proc
-             (make-fixed-closure eval nreq body (capture-env env))
+                (if (null? tail)
-             (if (null? (cdr tail))
+                    (make-fixed-closure eval nreq body (capture-env env))
-                 (make-general-closure (capture-env env) body nreq (car tail)
+                    (if (null? (cdr tail))
-                                       0 #f '() #f)
+                        (make-general-closure (capture-env env) body
-                 (apply make-general-closure (capture-env env) body nreq tail))))
+                                              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))

test-suite/tests/eval.test

@@ -427,6 +427,36 @@
           (thunk (let loop () (cons 's (loop)))))
       (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
 ;;;