Commit 673e08bb authored by Stefan Monnier's avatar Stefan Monnier
Browse files

* lisp/emacs-lisp/cl-macs.el (cl--make-usage-var, cl--make-usage-args):

New functions.
(cl-transform-lambda): Use them.

Fixes: debbugs:9239
parent 412b6358
2011-08-05 Stefan Monnier <monnier@iro.umontreal.ca>
* 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 <rudalics@gmx.at>
* window.el (display-buffer-same-window)
......
......@@ -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" "\
......
......@@ -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)))))))
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment