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

* lisp/emacs-lisp/cl-macs.el (cl--do-arglist): Understand _ on &key args.

Browse source 
(cl--make-usage-args): Strip _ from argument names.

Fixes: debbugs:12367
This commit is contained in:
Stefan Monnier 2012-09-06 11:35:08 -04:00
parent fcbfbdea93
commit d458ef98df
2 changed files with 21 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
lisp/ChangeLog
View file

@ -1,3 +1,9 @@
2012-09-06 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/cl-macs.el (cl--do-arglist): Understand _ on &key args
(bug#12367).
(cl--make-usage-args): Strip _ from argument names.
2012-09-06 Rüdiger Sonderfeld <ruediger@c-plusplus.de>
* progmodes/vhdl-mode.el (vhdl-speedbar-initialize): Don't use

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

@ -393,9 +393,14 @@ its argument list allows full Common Lisp conventions."
(mapcar (lambda (x)
(cond
((symbolp x)
(if (eq ?\& (aref (symbol-name x) 0))
(setq state x)
(make-symbol (upcase (symbol-name x)))))
(let ((first (aref (symbol-name x) 0)))
(if (eq ?\& first)
(setq state x)
;; Strip a leading underscore, since it only
;; means that this argument is unused.
(make-symbol (upcase (if (eq ?_ first)
(substring (symbol-name x) 1)
(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).
@ -479,7 +484,13 @@ its argument list allows full Common Lisp conventions."
(let ((arg (pop args)))
(or (consp arg) (setq arg (list arg)))
(let* ((karg (if (consp (car arg)) (caar arg)
(intern (format ":%s" (car arg)))))
(let ((name (symbol-name (car arg))))
;; Strip a leading underscore, since it only
;; means that this argument is unused, but
;; shouldn't affect the key's name (bug#12367).
(if (eq ?_ (aref name 0))
(setq name (substring name 1)))
(intern (format ":%s" name)))))
(varg (if (consp (car arg)) (cl-cadar arg) (car arg)))
(def (if (cdr arg) (cadr arg)
(or (car cl--bind-defs) (cadr (assq varg cl--bind-defs)))))