From 673e08bbd4209cc234c76c4430cc62924ba3ba49 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 5 Aug 2011 12:31:21 -0400 Subject: [PATCH] * lisp/emacs-lisp/cl-macs.el (cl--make-usage-var, cl--make-usage-args): New functions. (cl-transform-lambda): Use them. Fixes: debbugs:9239 --- lisp/ChangeLog | 6 ++++++ lisp/emacs-lisp/cl-loaddefs.el | 2 +- lisp/emacs-lisp/cl-macs.el | 38 +++++++++++++++++++++++++++++++++----- lisp/help-fns.el | 11 ++++------- 4 files changed, 44 insertions(+), 13 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 2e8240b41bb..16ba0d34f02 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2011-08-05 Stefan Monnier + + * 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 * window.el (display-buffer-same-window) diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 4b9985380c3..7beb4d4b4cc 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -282,7 +282,7 @@ Not documented ;;;;;; 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" "\ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 6d242eda3ab..fb19115287c 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -238,6 +238,37 @@ It is a list of elements of the form either: (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 @@ It is a list of elements of the form either: (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))))))) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index b13e6a77d5d..5e034b14fde 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -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 @@ the same names as used in the original source code, when possible." (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) -- 2.11.4.GIT