--- a/lisp/cl-macs.el	Sun Dec 26 01:48:40 2010 +0100
+++ b/lisp/cl-macs.el	Fri Dec 31 00:27:29 2010 +0100
@@ -109,7 +109,8 @@
 
 ;;; Check if no side effects.
 (defun cl-safe-expr-p (x)
-  (or (not (and (consp x) (not (memq (car x) '(quote function function*)))))
+  (or (not (and (consp x) (not (memq (car x)
+                                     '(quote function function* lambda)))))
       (and (symbolp (car x))
 	   (or (memq (car x) cl-simple-funcs)
 	       (memq (car x) cl-safe-funcs)
@@ -3484,56 +3485,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
@@ -3750,7 +3755,7 @@
          (put function 'cl-compiler-macro
               #'(lambda (form &rest arguments)
                   (if (or (null (nthcdr 3 form))
-                          (notevery #'cl-safe-expr-p (cdr form)))
+                          (notevery #'cl-safe-expr-p (butlast (cdr arguments))))
                       form
                     (cons 'and (mapcon
                                 #'(lambda (rest)
@@ -3760,22 +3765,28 @@
                                 (cdr form)))))))
      '(= < > <= >=))
 
-(mapc
- #'(lambda (y)
-     (put (car y) 'side-effect-free t)
-     (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro)
-     (put (car y) 'cl-compiler-macro
-	  (list 'lambda '(w x)
-		(if (symbolp (cadr y))
-		    (list 'list (list 'quote (cadr y))
-			  (list 'list (list 'quote (caddr y)) 'x))
-		  (cons 'list (cdr y))))))
- '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x)
+;; XEmacs; unroll this loop at macro-expansion time, so the compiler macros
+;; are byte-compiled.
+(macrolet
+    ((inline-side-effect-free-compiler-macros (&rest details)
+       (cons
+        'progn
+        (loop
+          for (function . details) in details
+          nconc `((put ',function 'side-effect-free t)
+                  (define-compiler-macro ,function (&whole form x)
+                    ,(if (symbolp (car details))
+                         (reduce #'(lambda (object1 object2)
+                                     `(list ',object1 ,object2))
+                                 details :from-end t :initial-value 'x)
+                       (cons 'list details))))))))
+  (inline-side-effect-free-compiler-macros
+   (first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x)
    (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)
    (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)
    (rest 'cdr x) (plusp '> x 0) (minusp '< x 0)
-   (oddp  'eq (list 'logand x 1) 1)
-   (evenp 'eq (list 'logand x 1) 0)
+   (oddp  'eql (list 'logand x 1) 1)
+   (evenp 'eql (list 'logand x 1) 0)
    (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr)
    (caaar car caar) (caadr car cadr) (cadar car cdar)
    (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr)