[Emacs-diffs] /srv/bzr/emacs/trunk r105410: * lisp/emacs-lisp/cl-macs.el (cl--make-usage-var, cl--make-usage-args):

[Stefan Monnier]

------------------------------------------------------------
revno: 105410
fixes bug(s): http://debbugs.gnu.org/cgi/bugreport.cgi?bug=9239
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Fri 2011-08-05 12:31:21 -0400
message:
  * lisp/emacs-lisp/cl-macs.el (cl--make-usage-var, cl--make-usage-args):
  New functions.
  (cl-transform-lambda): Use them.
modified:
  lisp/ChangeLog
  lisp/emacs-lisp/cl-loaddefs.el
  lisp/emacs-lisp/cl-macs.el
  lisp/help-fns.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2011-08-05 06:23:23 +0000
+++ b/lisp/ChangeLog    2011-08-05 16:31:21 +0000
@@ -1,3 +1,9 @@
+2011-08-05  Stefan Monnier  <address@hidden>
+
+       * emacs-lisp/cl-macs.el (cl--make-usage-var, cl--make-usage-args):
+       New functions.
+       (cl-transform-lambda): Use them (bug#9239).
+
 2011-08-05  Martin Rudalics  <address@hidden>
 
        * window.el (display-buffer-same-window)

=== modified file 'lisp/emacs-lisp/cl-loaddefs.el'
--- a/lisp/emacs-lisp/cl-loaddefs.el    2011-08-03 10:20:59 +0000
+++ b/lisp/emacs-lisp/cl-loaddefs.el    2011-08-05 16:31:21 +0000
@@ -282,7 +282,7 @@
 ;;;;;;  flet progv psetq do-all-symbols do-symbols dotimes dolist
 ;;;;;;  do* do loop return-from return block etypecase typecase ecase
 ;;;;;;  case load-time-value eval-when destructuring-bind function*
-;;;;;;  defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" 
"21df83d6106cb0c3d037e75ad79359dc")
+;;;;;;  defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" 
"0907093f7720996444ededb4edfe8072")
 ;;; Generated autoloads from cl-macs.el
 
 (autoload 'gensym "cl-macs" "\

=== modified file 'lisp/emacs-lisp/cl-macs.el'
--- a/lisp/emacs-lisp/cl-macs.el        2011-08-02 18:49:12 +0000
+++ b/lisp/emacs-lisp/cl-macs.el        2011-08-05 16:31:21 +0000
@@ -238,6 +238,37 @@
 
 (declare-function help-add-fundoc-usage "help-fns" (docstring arglist))
 
+(defun cl--make-usage-var (x)
+  "X can be a var or a (destructuring) lambda-list."
+  (cond
+   ((symbolp x) (make-symbol (upcase (symbol-name x))))
+   ((consp x) (cl--make-usage-args x))
+   (t x)))
+
+(defun cl--make-usage-args (arglist)
+  ;; `orig-args' can contain &cl-defs (an internal
+  ;; CL thingy I don't understand), so remove it.
+  (let ((x (memq '&cl-defs arglist)))
+    (when x (setq arglist (delq (car x) (remq (cadr x) arglist)))))
+  (let ((state nil))
+    (mapcar (lambda (x)
+              (cond
+               ((symbolp x)
+                (if (eq ?\& (aref (symbol-name x) 0))
+                    (setq state x)
+                  (make-symbol (upcase (symbol-name x)))))
+               ((not (consp x)) x)
+               ((memq state '(nil &rest)) (cl--make-usage-args x))
+               (t        ;(VAR INITFORM SVAR) or ((KEYWORD VAR) INITFORM SVAR).
+                (list*
+                 (if (and (consp (car x)) (eq state '&key))
+                     (list (caar x) (cl--make-usage-var (nth 1 (car x))))
+                   (cl--make-usage-var (car x)))
+                 (nth 1 x)                          ;INITFORM.
+                 (cl--make-usage-args (nthcdr 2 x)) ;SVAR.
+                 ))))
+            arglist)))
+
 (defun cl-transform-lambda (form bind-block)
   (let* ((args (car form)) (body (cdr form)) (orig-args args)
         (bind-defs nil) (bind-enquote nil)
@@ -282,11 +313,8 @@
                         (require 'help-fns)
                         (cons (help-add-fundoc-usage
                                (if (stringp (car hdr)) (pop hdr))
-                               ;; orig-args can contain &cl-defs (an internal
-                               ;; CL thingy I don't understand), so remove it.
-                               (let ((x (memq '&cl-defs orig-args)))
-                                 (if (null x) orig-args
-                                   (delq (car x) (remq (cadr x) orig-args)))))
+                               (format "(fn %S)"
+                                       (cl--make-usage-args orig-args)))
                               hdr)))
                    (list (nconc (list 'let* bind-lets)
                                 (nreverse bind-forms) body)))))))

=== modified file 'lisp/help-fns.el'
--- a/lisp/help-fns.el  2011-06-27 21:39:03 +0000
+++ b/lisp/help-fns.el  2011-08-05 16:31:21 +0000
@@ -65,7 +65,9 @@
 
 (defun help-split-fundoc (docstring def)
   "Split a function DOCSTRING into the actual doc and the usage info.
-Return (USAGE . DOC) or nil if there's no usage info.
+Return (USAGE . DOC) or nil if there's no usage info, where USAGE info
+is a string describing the argument list of DEF, such as
+\"(apply FUNCTION &rest ARGUMENTS)\".
 DEF is the function whose usage we're looking for in DOCSTRING."
   ;; Functions can get the calling sequence at the end of the doc string.
   ;; In cases where `function' has been fset to a subr we can't search for
@@ -156,12 +158,7 @@
 (defun help-make-usage (function arglist)
   (cons (if (symbolp function) function 'anonymous)
        (mapcar (lambda (arg)
-                 (if (not (symbolp arg))
-                     (if (and (consp arg) (symbolp (car arg)))
-                         ;; CL style default values for optional args.
-                         (cons (intern (upcase (symbol-name (car arg))))
-                               (cdr arg))
-                       arg)
+                 (if (not (symbolp arg)) arg
                    (let ((name (symbol-name arg)))
                      (cond
                        ((string-match "\\`&" name) arg)