[Emacs-diffs] /srv/bzr/emacs/trunk r108692: * lisp/emacs-lisp/cl-macs.el (cl--make-usage-args): Handle improper lists.

[Stefan Monnier]

------------------------------------------------------------
revno: 108692
fixes bug: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=11719
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Sat 2012-06-23 00:24:06 -0400
message:
  * lisp/emacs-lisp/cl-macs.el (cl--make-usage-args): Handle improper lists.
modified:
  lisp/ChangeLog
  lisp/emacs-lisp/cl-loaddefs.el
  lisp/emacs-lisp/cl-macs.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2012-06-23 03:48:18 +0000
+++ b/lisp/ChangeLog    2012-06-23 04:24:06 +0000
@@ -1,5 +1,8 @@
 2012-06-23  Stefan Monnier  <address@hidden>
 
+       * 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).
 

=== modified file 'lisp/emacs-lisp/cl-loaddefs.el'
--- a/lisp/emacs-lisp/cl-loaddefs.el    2012-06-22 21:24:54 +0000
+++ b/lisp/emacs-lisp/cl-loaddefs.el    2012-06-23 04:24:06 +0000
@@ -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 @@
 ;;;;;;  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" "\

=== modified file 'lisp/emacs-lisp/cl-macs.el'
--- a/lisp/emacs-lisp/cl-macs.el        2012-06-22 21:24:54 +0000
+++ b/lisp/emacs-lisp/cl-macs.el        2012-06-23 04:24:06 +0000
@@ -350,28 +350,36 @@
    (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)