diff lisp/cl-macs.el @ 5317:8aa511adfad6

#'delete-duplicates: don't attempt to compiler macroexpand with bad arguments 2010-12-29 Aidan Kehoe <kehoea@parhasard.net> * cl-macs.el (delete-duplicates): If the form has an incorrect number of arguments, don't attempt a compiler macroexpansion.
author Aidan Kehoe <kehoea@parhasard.net>
date Wed, 29 Dec 2010 23:56:57 +0000
parents 9ac28212c75a
children 60ba780f9078 6506fcb40fcf
line wrap: on
line diff
--- a/lisp/cl-macs.el	Wed Dec 29 23:53:48 2010 +0000
+++ b/lisp/cl-macs.el	Wed Dec 29 23:56:57 2010 +0000
@@ -3487,56 +3487,60 @@
 ;; XEmacs; inline delete-duplicates if it's called with one of the
 ;; common compile-time constant tests and an optional :from-end
 ;; argument, we want the speed in font-lock.el.
-(define-compiler-macro delete-duplicates (&whole form cl-seq &rest cl-keys)
-  (if (not (or (memq (car-safe cl-seq)
-		     ;; No need to check for a list at runtime with
-		     ;; these. We could expand the list, but these are all
-		     ;; the functions in the relevant context at the moment.
-		     '(nreverse append nconc mapcan mapcar string-to-list))
-	       (and (listp cl-seq) (equal (butlast cl-seq) '(the list)))))
-      form
-    (cond
-     ((or (plists-equal cl-keys '(:test 'eq) t)
-	  (plists-equal cl-keys '(:test #'eq) t))
-      `(let* ((begin ,cl-seq)
-	      cl-seq)
-	(while (memq (car begin) (cdr begin))
-	  (setq begin (cdr begin)))
-	(setq cl-seq begin)
-	(while (cddr cl-seq)
-	  (if (memq (cadr cl-seq) (cddr cl-seq))
-	      (setcdr (cdr cl-seq) (cddr cl-seq)))
-	  (setq cl-seq (cdr cl-seq)))
-	begin))
-     ((or (plists-equal cl-keys '(:test 'eq :from-end t) t)
-	  (plists-equal cl-keys '(:test #'eq :from-end t) t))
-      `(let* ((begin ,cl-seq)
-	      (cl-seq begin))
-	(while cl-seq
-	  (setq cl-seq (setcdr cl-seq
-			       (delq (car cl-seq) (cdr cl-seq)))))
-	begin))
-     ((or (plists-equal cl-keys '(:test 'equal) t)
-	  (plists-equal cl-keys '(:test #'equal) t))
-      `(let* ((begin ,cl-seq)
-	      cl-seq)
-	(while (member (car begin) (cdr begin))
-	  (setq begin (cdr begin)))
-	(setq cl-seq begin)
-	(while (cddr cl-seq)
-	  (if (member (cadr cl-seq) (cddr cl-seq))
-	      (setcdr (cdr cl-seq) (cddr cl-seq)))
-	  (setq cl-seq (cdr cl-seq)))
-	begin))
-     ((or (plists-equal cl-keys '(:test 'equal :from-end t) t)
-	  (plists-equal cl-keys '(:test #'equal :from-end t) t))
-      `(let* ((begin ,cl-seq)
-	      (cl-seq begin))
-	(while cl-seq
-	  (setq cl-seq (setcdr cl-seq (delete (car cl-seq)
-					      (cdr cl-seq)))))
-	begin))
-     (t form))))
+(define-compiler-macro delete-duplicates (&whole form &rest cl-keys)
+  (let ((cl-seq (if cl-keys (pop cl-keys))))
+    (if (or 
+	 (not (or (memq (car-safe cl-seq)
+			;; No need to check for a list at runtime with
+			;; these. We could expand the list, but these are all
+			;; the functions in the relevant context at the moment.
+			'(nreverse append nconc mapcan mapcar string-to-list))
+		 (and (listp cl-seq) (equal (butlast cl-seq) '(the list)))))
+	 ;; Wrong number of arguments.
+	 (not (cdr form)))
+	form
+      (cond
+       ((or (plists-equal cl-keys '(:test 'eq) t)
+	    (plists-equal cl-keys '(:test #'eq) t))
+	`(let* ((begin ,cl-seq)
+		cl-seq)
+	  (while (memq (car begin) (cdr begin))
+	    (setq begin (cdr begin)))
+	  (setq cl-seq begin)
+	  (while (cddr cl-seq)
+	    (if (memq (cadr cl-seq) (cddr cl-seq))
+		(setcdr (cdr cl-seq) (cddr cl-seq)))
+	    (setq cl-seq (cdr cl-seq)))
+	  begin))
+       ((or (plists-equal cl-keys '(:test 'eq :from-end t) t)
+	    (plists-equal cl-keys '(:test #'eq :from-end t) t))
+	`(let* ((begin ,cl-seq)
+		(cl-seq begin))
+	  (while cl-seq
+	    (setq cl-seq (setcdr cl-seq
+				 (delq (car cl-seq) (cdr cl-seq)))))
+	  begin))
+       ((or (plists-equal cl-keys '(:test 'equal) t)
+	    (plists-equal cl-keys '(:test #'equal) t))
+	`(let* ((begin ,cl-seq)
+		cl-seq)
+	  (while (member (car begin) (cdr begin))
+	    (setq begin (cdr begin)))
+	  (setq cl-seq begin)
+	  (while (cddr cl-seq)
+	    (if (member (cadr cl-seq) (cddr cl-seq))
+		(setcdr (cdr cl-seq) (cddr cl-seq)))
+	    (setq cl-seq (cdr cl-seq)))
+	  begin))
+       ((or (plists-equal cl-keys '(:test 'equal :from-end t) t)
+	    (plists-equal cl-keys '(:test #'equal :from-end t) t))
+	`(let* ((begin ,cl-seq)
+		(cl-seq begin))
+	  (while cl-seq
+	    (setq cl-seq (setcdr cl-seq (delete (car cl-seq)
+						(cdr cl-seq)))))
+	  begin))
+       (t form)))))
 
 ;; XEmacs; it's perfectly reasonable, and often much clearer to those
 ;; reading the code, to call regexp-quote on a constant string, which is