procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

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

Fixes: debbugs:9239
This commit is contained in:
Stefan Monnier 2011-08-05 12:31:21 -04:00
parent 412b635880
commit 673e08bbd4
4 changed files with 44 additions and 13 deletions
Download patch file Download diff file Expand all files Collapse all files

2
lisp/emacs-lisp/cl-loaddefs.el
View file

@ -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" "\

38
lisp/emacs-lisp/cl-macs.el
View file

@ -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)))))))