mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-03 11:33:37 +00:00
Code Issues Releases Activity

* lisp/emacs-lisp/cl-macs.el (cl--make-usage-args): Handle improper lists.

Browse Source 
Fixes: debbugs:11719
This commit is contained in:
Stefan Monnier 2012-06-23 00:24:06 -04:00
parent e33c6771f6
commit b68581e26c
3 changed files with 35 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
lisp/ChangeLog
View File

@ -1,5 +1,8 @@
2012-06-23 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/cl-macs.el (cl--make-usage-args): Handle improper lists
(bug#11719).
* minibuffer.el (completion--twq-try): Try to fail more gracefully when
the requote function doesn't work properly (bug#11714).

4
lisp/emacs-lisp/cl-loaddefs.el
View File

@ -11,7 +11,7 @@
;;;;;; cl--set-frame-visible-p cl--map-overlays cl--map-intervals
;;;;;; cl--map-keymap-recursively cl-notevery cl-notany cl-every
;;;;;; cl-some cl-mapcon cl-mapcan cl-mapl cl-maplist cl-map cl--mapcar-many
;;;;;; cl-equalp cl-coerce) "cl-extra" "cl-extra.el" "25963dec757a527e3be3ba7f7abc49ee")
;;;;;; cl-equalp cl-coerce) "cl-extra" "cl-extra.el" "3656b89f2196d70e50ba9d7bb9519416")
;;; Generated autoloads from cl-extra.el
(autoload 'cl-coerce "cl-extra" "\
@ -265,7 +265,7 @@ Remove from SYMBOL's plist the property PROPNAME and its value.
;;;;;; cl-return cl-block cl-etypecase cl-typecase cl-ecase cl-case
;;;;;; cl-load-time-value cl-eval-when cl-destructuring-bind cl-function
;;;;;; cl-defmacro cl-defun cl-gentemp cl-gensym) "cl-macs" "cl-macs.el"
;;;;;; "66d8d151a97f91a79ebe3d1a9d699483")
;;;;;; "41a15289eda7e6ae03ac9edd86bbb1a6")
;;; Generated autoloads from cl-macs.el
(autoload 'cl-gensym "cl-macs" "\

52
lisp/emacs-lisp/cl-macs.el
View File

@ -350,28 +350,36 @@ its argument list allows full Common Lisp conventions."
(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).
(cl-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)))
(if (cdr-safe (last arglist)) ;Not a proper list.
(let* ((last (last arglist))
(tail (cdr last)))
(unwind-protect
(progn
(setcdr last nil)
(nconc (cl--make-usage-args arglist) (cl--make-usage-var tail)))
(setcdr last tail)))
;; `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).
(cl-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--do-arglist (args expr &optional num) ; uses bind-*
(if (nlistp args)