--- a/lisp/ChangeLog	Mon Oct 18 23:43:03 2010 +0900
+++ b/lisp/ChangeLog	Mon Oct 25 13:04:04 2010 +0100
@@ -1,3 +1,41 @@
+2010-10-25  Aidan Kehoe  <kehoea@parhasard.net>
+
+	Add compiler macros and compilation sanity-checking for various
+	functions that take keywords.
+
+	* byte-optimize.el (side-effect-free-fns): #'symbol-value is
+	side-effect free and not error free.
+	* bytecomp.el (byte-compile-normal-call): Check keyword argument
+	lists for sanity; store information about the positions where
+	keyword arguments start using the new byte-compile-keyword-start
+	property.
+	* cl-macs.el (cl-const-expr-val): Take a new optional argument,
+	cl-not-constant, defaulting to nil, in this function; return it if
+	the expression is not constant.
+	(cl-non-fixnum-number-p): Make this into a separate function, we
+	want to pass it to #'every.
+	(eql): Use it.
+	(define-star-compiler-macros): Use the same code to generate the
+	member*, assoc* and rassoc* compiler macros; special-case some
+	code in #'add-to-list in subr.el.
+	(remove, remq): Add compiler macros for these two functions, in
+	preparation for #'remove being in C.
+	(define-foo-if-compiler-macros): Transform (remove-if-not ...) calls to
+	(remove ... :if-not) at compile time, which will be a real win
+	once the latter is in C.
+	(define-substitute-if-compiler-macros)
+	(define-subst-if-compiler-macros): Similarly for these functions.
+	(delete-duplicates): Change this compiler macro to use
+	#'plists-equal; if we don't have information about the type of
+	SEQUENCE at compile time, don't bother attempting to inline the
+	call, the function will be in C soon enough.
+	(equalp): Remove an old commented-out compiler macro for this, if
+	we want to see it it's in version control.
+	(subst-char-in-string): Transform this to a call to nsubstitute or
+	nsubstitute, if that is appropriate.
+	* cl.el (ldiff): Don't call setf here, this makes for a load-time
+	dependency problem in cl-macs.el
+
 2010-06-14  Stephen J. Turnbull  <stephen@xemacs.org>
 
 	* term/vt100.el:

--- a/lisp/byte-optimize.el	Mon Oct 18 23:43:03 2010 +0900
+++ b/lisp/byte-optimize.el	Mon Oct 25 13:04:04 2010 +0100
@@ -1247,7 +1247,8 @@
 	 parse-colon-path plist-get previous-window
 	 radians-to-degrees rassq regexp-quote reverse round
 	 sin sqrt string< string= string-equal string-lessp string-to-char
-	 string-to-int string-to-number substring symbol-plist
+	 string-to-int string-to-number substring symbol-plist symbol-value
+	 symbol-name symbol-function symbol
 	 tan upcase user-variable-p vconcat
 	 ;; XEmacs change: window-edges -> window-pixel-edges
 	 window-buffer window-dedicated-p window-pixel-edges window-height

--- a/lisp/bytecomp.el	Mon Oct 18 23:43:03 2010 +0900
+++ b/lisp/bytecomp.el	Mon Oct 25 13:04:04 2010 +0100
@@ -2838,7 +2838,83 @@
   (when for-effect
     (byte-compile-discard)))
 
+;; Generate the list of functions with keyword arguments like so:
+;; 
+;; (delete-duplicates
+;;  (sort*
+;;   (loop
+;;     for symbol being each symbol in obarray
+;;     with arglist = nil
+;;     if (and (fboundp symbol)
+;; 	    (ignore-errors (setq symbol (indirect-function symbol)))
+;; 	    (cond
+;; 	     ((and (subrp symbol) (setq symbol (intern (subr-name symbol)))))
+;; 	     ((and (compiled-function-p symbol)
+;; 		   (setq symbol (compiled-function-annotation symbol)))))
+;; 	    (setq arglist (function-arglist symbol))
+;; 	    (setq arglist (ignore-errors (read-from-string arglist)))
+;; 	    (setq arglist (car arglist))
+;; 	    (setq arglist (position '&key arglist)))
+;;     collect (cons symbol arglist))
+;;   #'string-lessp
+;;   :key #'car) :test #'eq :key #'car)
+;;
+;; That won't include those that take advantage of cl-seq.el's
+;; cl-parsing-keywords macro, but the below list does.
+
+(map nil
+     (function*
+      (lambda ((function . nargs))
+	;; Document that the car of OBJECT, a symbol, describes a function
+	;; taking keyword arguments from the argument index described by
+	;; the cdr of OBJECT.
+	(put function 'byte-compile-keyword-start nargs)))
+     '((adjoin . 3) (assoc* . 3) (assoc-if . 3) (assoc-if-not . 3)
+       (count . 3) (count-if . 3) (count-if-not . 3) (define-behavior . 3)
+       (define-behavior-group . 2) (delete* . 3) (delete-duplicates . 2)
+       (delete-if . 3) (delete-if-not . 3) (fill . 3) (find . 3) (find-if . 3)
+       (find-if-not . 3) (internal-make-translation-table . 1)
+       (make-Print-context . 1) (make-hash-table . 1) (make-saved-window . 1)
+       (make-window-configuration . 1) (member* . 3)
+       (member-if . 3) (member-if-not . 3) (merge . 5) (nsublis . 3)
+       (nsubst . 4) (nsubst-if . 4) (nsubst-if-not . 4) (nsubstitute . 4)
+       (nsubstitute-if . 4) (nsubstitute-if-not . 4) (override-behavior . 2)
+       (position . 3) (position-if . 3) (position-if-not . 3) (rassoc* . 3)
+       (rassoc-if . 3) (rassoc-if-not . 3) (reduce . 3) (remove* . 3)
+       (remove-duplicates . 2) (remove-if . 3) (remove-if-not . 3)
+       (replace . 3) (sort* . 3) (stable-sort . 3) (sublis . 3)
+       (subsetp . 3) (subst . 4) (subst-if . 4) (subst-if-not . 4)
+       (substitute . 4) (substitute-if . 4) (substitute-if-not . 4)
+       (tree-equal . 3)))
+
 (defun byte-compile-normal-call (form)
+  (and (get (car form) 'byte-compile-keyword-start)
+       (let ((plist (nthcdr (get (car form) 'byte-compile-keyword-start)
+			    form)))
+	 (symbol-macrolet
+	     ((not-present '#:not-present))
+	   (if (not (valid-plist-p plist))
+	       (byte-compile-warn
+		"#'%s: ill-formed keyword argument list: %S" (car form) plist)
+	     (and
+	      (memq 'callargs byte-compile-warnings)
+	      (map nil
+		   (function*
+		    (lambda ((function . nargs))
+		      (and (setq function (plist-get plist function
+						     not-present))
+			   (not (eq function not-present))
+			   (byte-compile-constp function)
+			   (byte-compile-callargs-warn
+			    (cons (eval function)
+				  (member*
+				   nargs
+				   ;; Dummy arguments. There's no need for
+				   ;; it to be longer than even 2, now, but
+				   ;; very little harm in it.
+				   '(9 8 7 6 5 4 3 2 1)))))))
+		   '((:key . 1) (:test . 2) (:test-not . 2)
+		     (:if . 1) (:if-not . 1))))))))
   (if byte-compile-generate-call-tree
       (byte-compile-annotate-call-tree form))
   (byte-compile-push-constant (car form))

--- a/lisp/cl-macs.el	Mon Oct 18 23:43:03 2010 +0900
+++ b/lisp/cl-macs.el	Mon Oct 25 13:04:04 2010 +0100
@@ -135,8 +135,11 @@
     (setq xs (cdr xs)))
   (not xs))
 
-(defun cl-const-expr-val (x)
-  (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))
+(defun cl-const-expr-val (x &optional cl-not-constant)
+  (let ((cl-const-expr-p (cl-const-expr-p x)))
+    (cond ((eq cl-const-expr-p t) (if (consp x) (nth 1 x) x))
+	  ((eq cl-const-expr-p 'func) (nth 1 x))
+	  (cl-not-constant))))
 
 (defun cl-expr-access-order (x v)
   (if (cl-const-expr-p x) v
@@ -3264,16 +3267,19 @@
 ;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time,
 ;;; mainly to make sure these macros will be present.
 
+(defun cl-non-fixnum-number-p (object)
+  (and (numberp object) (not (fixnump object))))
+
 (put 'eql 'byte-compile nil)
 (define-compiler-macro eql (&whole form a b)
   (cond ((eq (cl-const-expr-p a) t)
 	 (let ((val (cl-const-expr-val a)))
-	   (if (and (numberp val) (not (fixnump val)))
+	   (if (cl-non-fixnum-number-p val)
 	       (list 'equal a b)
 	     (list 'eq a b))))
 	((eq (cl-const-expr-p b) t)
 	 (let ((val (cl-const-expr-val b)))
-	   (if (and (numberp val) (not (fixnump val)))
+	   (if (cl-non-fixnum-number-p val)
 	       (list 'equal a b)
 	     (list 'eq a b))))
 	((cl-simple-expr-p a 5)
@@ -3287,44 +3293,65 @@
 	       (list 'eq a b)))
 	(t form)))
 
-(define-compiler-macro member* (&whole form a list &rest keys)
-  (let ((test (and (= (length keys) 2) (eq (car keys) :test)
-		   (cl-const-expr-val (nth 1 keys))))
-	a-val)
-    (cond ((eq test 'eq) (list 'memq a list))
-	  ((eq test 'equal) (list 'member a list))
-	  ((or (null keys) (eq test 'eql))
-	   (if (eq (cl-const-expr-p a) t)
-	       (list (if (and (numberp (setq a-val (cl-const-expr-val a)))
-			      (not (fixnump a-val)))
-			 'member
-		       'memq)
-		     a list)
-	     (if (eq (cl-const-expr-p list) t)
-		 (let ((p (cl-const-expr-val list)) (mb nil) (mq nil))
-		   (if (not (cdr p))
-		       (and p (list 'eql a (list 'quote (car p))))
-		     (while p
-		       (if (and (numberp (car p)) (not (fixnump (car p))))
-			   (setq mb t)
-			 (or (fixnump (car p)) (symbolp (car p)) (setq mq t)))
-		       (setq p (cdr p)))
-		     (if (not mb) (list 'memq a list)
-		       (if (not mq) (list 'member a list) form))))
-	       form)))
-	  (t form))))
-
-(define-compiler-macro assoc* (&whole form a list &rest keys)
-  (let ((test (and (= (length keys) 2) (eq (car keys) :test)
-		   (cl-const-expr-val (nth 1 keys))))
-	a-val)
-    (cond ((eq test 'eq) (list 'assq a list))
-	  ((eq test 'equal) (list 'assoc a list))
-	  ((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql)))
-	   (if (and (numberp (setq a-val (cl-const-expr-val a)))
-		    (not (fixnump a-val)))
-	       (list 'assoc a list) (list 'assq a list)))
-	  (t form))))
+(macrolet
+    ((define-star-compiler-macros (&rest macros)
+       "For `member*', `assoc*' and `rassoc*' with constant ITEM or
+:test arguments, use the versions with explicit tests if that makes sense."
+       (list*
+	'progn
+	(mapcar
+	 (function*
+	  (lambda ((star-function eq-function equal-function))
+	    `(define-compiler-macro ,star-function (&whole form item list
+						    &rest keys)
+	      (condition-case nil
+		  (symbol-macrolet ((not-constant '#:not-constant))
+		    (let* ((test-expr (plist-get keys :test ''eql))
+			   (test (cl-const-expr-val test-expr not-constant))
+			   (item-val (cl-const-expr-val item not-constant))
+			   (list-val (cl-const-expr-val list not-constant)))
+		      (if (and keys
+			       (not (and (eq :test (car keys))
+					 (eql 2 (length keys)))))
+			  form
+			(cond ((eq test 'eq) `(,',eq-function ,item ,list))
+			      ((eq test 'equal)
+			       `(,',equal-function ,item ,list))
+			      ((and (eq test 'eql)
+				    (not (eq not-constant item-val)))
+			       (if (cl-non-fixnum-number-p item-val)
+				   `(,',equal-function ,item ,list)
+				 `(,',eq-function ,item ,list)))
+			      ((and (eq test 'eql) (not (eq not-constant
+							    list-val)))
+			       (if (some 'cl-non-fixnum-number-p list-val)
+				   `(,',equal-function ,item ,list)
+				 ;; This compiler macro used to limit calls
+				 ;; to ,,eq-function to lists where all
+				 ;; elements were either fixnums or
+				 ;; symbols. There's no
+				 ;; reason to do this.
+				 `(,',eq-function ,item ,list)))
+			      ;; This is a hilariously specific case; see
+			      ;; add-to-list in subr.el.
+			      ((and (eq test not-constant)
+				    (eq 'or (car-safe test-expr))
+				    (eql 3 (length test-expr))
+				    (every #'cl-safe-expr-p (cdr form))
+				    `(if ,(second test-expr)
+					 (,',star-function ,item ,list :test
+							   ,(second test-expr))
+				      (,',star-function
+				       ,item ,list :test ,(third test-expr)))))
+			      (t form)))))
+		;; No need to warn about a malformed property list,
+		;; #'byte-compile-normal-call will do that for us.
+		(malformed-property-list form)))))
+	 macros))))
+  (define-star-compiler-macros
+    (member* memq member)
+    (assoc* assq assoc)
+    (rassoc* rassq rassoc)))
 
 (define-compiler-macro adjoin (&whole form a list &rest keys)
   (if (and (cl-simple-expr-p a) (cl-simple-expr-p list)
@@ -3332,6 +3359,112 @@
       (list 'if (list* 'member* a list keys) list (list 'cons a list))
     form))
 
+(define-compiler-macro remove (item sequence)
+  `(remove* ,item ,sequence :test #'equal))
+
+(define-compiler-macro remq (item sequence)
+  `(remove* ,item ,sequence :test #'eq))
+
+(macrolet
+    ((define-foo-if-compiler-macros (&rest alist)
+       "Avoid the funcall, variable binding and keyword parsing overhead
+for the FOO-IF and FOO-IF-NOT functions, transforming to forms using the
+non-standard :if and :if-not keywords at compile time."
+       (cons
+	'progn
+	(mapcar
+	 (function*
+	  (lambda ((function-if . function))
+	    (let ((keyword (if (equal (substring (symbol-name function-if) -3)
+				      "not")
+			       :if-not
+			     :if)))
+	      `(define-compiler-macro ,function-if (&whole form &rest args)
+		 (if (and (nthcdr 2 form)
+			  (or (consp (cl-const-expr-val (second form)))
+			      (cl-safe-expr-p (second form))))
+		     ;; It doesn't matter what the second argument is, it's
+		     ;; ignored by FUNCTION.  We know that the symbol
+		     ;; FUNCTION is in the constants vector, so use it.
+		     `(,',function ',',function ,(third form) ,,keyword
+		       ,(second form) ,@(nthcdr 3 form))
+		   form)))))
+	 alist))))
+  (define-foo-if-compiler-macros
+    (remove-if . remove*)
+    (remove-if-not . remove*)
+    (delete-if . delete*)
+    (delete-if-not . delete*)
+    (find-if . find)
+    (find-if-not . find)
+    (position-if . position)
+    (position-if-not . position)
+    (count-if . count)
+    (count-if-not . count)
+    (member-if . member*)
+    (member-if-not . member*)
+    (assoc-if . assoc*)
+    (assoc-if-not . assoc*)
+    (rassoc-if . rassoc*)
+    (rassoc-if-not . rassoc*)))
+
+(macrolet
+    ((define-substitute-if-compiler-macros (&rest alist)
+       "Like the above, but for `substitute-if' and friends."
+       (cons
+	'progn
+	(mapcar
+	 (function*
+	  (lambda ((function-if . function))
+	    (let ((keyword (if (equal (substring (symbol-name function-if) -3)
+				      "not")
+			       :if-not
+			     :if)))
+	      `(define-compiler-macro ,function-if (&whole form &rest args)
+		 (if (and (nthcdr 3 form)
+			  (or (consp (cl-const-expr-val (third form)))
+			      (cl-safe-expr-p (third form))))
+		     `(,',function ,(second form) ',',function ,(fourth form)
+		       ,,keyword ,(third form) ,@(nthcdr 4 form))
+		   form)))))
+	 alist))))
+  (define-substitute-if-compiler-macros
+    (substitute-if . substitute)
+    (substitute-if-not . substitute)
+    (nsubstitute-if . nsubstitute)
+    (nsubstitute-if-not . nsubstitute)))
+
+(macrolet
+    ((define-subst-if-compiler-macros (&rest alist)
+       "Like the above, but for `subst-if' and friends."
+       (cons
+	'progn
+	(mapcar
+	 (function*
+	  (lambda ((function-if . function))
+	    (let ((keyword (if (equal (substring (symbol-name function-if) -3)
+				      "not")
+			       :if-not
+			     :if)))
+	      `(define-compiler-macro ,function-if (&whole form &rest args)
+		(if (and (nthcdr 3 form)
+			 (or (consp (cl-const-expr-val (third form)))
+			     (cl-safe-expr-p (third form))))
+		    `(,',function ,(if (cl-const-expr-p (second form))
+				       `'((nil . ,(cl-const-expr-val
+						   (second form))))
+				     `(list (cons ',',function
+						  ,(second form))))
+		      ,(fourth form) ,,keyword ,(third form)
+		      ,@(nthcdr 4 form))
+		   form)))))
+	 alist))))
+  (define-subst-if-compiler-macros
+    (subst-if . sublis)
+    (subst-if-not . sublis)
+    (nsubst-if . nsublis)
+    (nsubst-if-not . nsublis)))
+
 (define-compiler-macro list* (arg &rest others)
   (let* ((args (reverse (cons arg others)))
 	 (form (car args)))
@@ -3362,106 +3495,55 @@
 ;; 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)
-  (let ((listp-check 
-         (cond
-          ((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))
-             t)
-          ((and (listp cl-seq) (eq (first cl-seq) 'the)
-                (eq (second cl-seq) 'list))
-           ;; Allow users to force this, if they really want to.
-           t)
-          (t
-           '(listp begin)))))
-    (cond ((loop
-	     for relevant-key-values
-	     in '((:test 'eq)
-		  (:test #'eq)
-		  (:test 'eq :from-end nil)
-		  (:test #'eq :from-end nil))
-	     ;; One of the above corresponds exactly to CL-KEYS:
-	     thereis (not (set-difference cl-keys relevant-key-values
-					  :test #'equal)))
-           `(let* ((begin ,cl-seq)
-		   cl-seq)
-             (if ,listp-check
-                 (progn
-                   (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)
-               ;; Call cl-delete-duplicates explicitly, to avoid the form
-               ;; getting compiler-macroexpanded again:
-               (cl-delete-duplicates begin ',cl-keys nil))))
-          ((loop
-	     for relevant-key-values
-	     in '((:test 'eq :from-end t)
-		  (:test #'eq :from-end t))
-	     ;; One of the above corresponds exactly to CL-KEYS:
-	     thereis (not (set-difference cl-keys relevant-key-values
-					  :test #'equal)))
-           `(let* ((begin ,cl-seq)
-		   (cl-seq begin))
-             (if ,listp-check
-                 (progn
-                   (while cl-seq
-                     (setq cl-seq (setcdr cl-seq
-                                          (delq (car cl-seq) (cdr cl-seq)))))
-                   begin)
-               ;; Call cl-delete-duplicates explicitly, to avoid the form
-               ;; getting compiler-macroexpanded again:
-               (cl-delete-duplicates begin ',cl-keys nil))))
-
-          ((loop
-	     for relevant-key-values
-	     in '((:test 'equal)
-		  (:test #'equal)
-		  (:test 'equal :from-end nil)
-		  (:test #'equal :from-end nil))
-	     ;; One of the above corresponds exactly to CL-KEYS:
-	     thereis (not (set-difference cl-keys relevant-key-values
-					  :test #'equal)))
-           `(let* ((begin ,cl-seq)
-		   cl-seq)
-             (if ,listp-check
-                 (progn
-		   (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)
-               ;; Call cl-delete-duplicates explicitly, to avoid the form
-               ;; getting compiler-macroexpanded again:
-               (cl-delete-duplicates begin ',cl-keys nil))))
-          ((loop
-	     for relevant-key-values
-	     in '((:test 'equal :from-end t)
-		  (:test #'equal :from-end t))
-	     ;; One of the above corresponds exactly to CL-KEYS:
-	     thereis (not (set-difference cl-keys relevant-key-values
-					  :test #'equal)))
-           `(let* ((begin ,cl-seq)
-                   (cl-seq begin))
-             (if ,listp-check
-                 (progn
-                   (while cl-seq
-                     (setq cl-seq
-			   (setcdr cl-seq (delete (car cl-seq) (cdr cl-seq)))))
-		   begin)
-               ;; Call cl-delete-duplicates explicitly, to avoid the form
-               ;; getting compiler-macroexpanded again:
-               (cl-delete-duplicates begin ',cl-keys nil))))
-          (t form))))
+  (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))))
 
 ;; XEmacs; it's perfectly reasonable, and often much clearer to those
 ;; reading the code, to call regexp-quote on a constant string, which is
@@ -3560,117 +3642,6 @@
 	  ;; byte-optimize.el).
 	  (t form)))))
 
-;;(define-compiler-macro equalp (&whole form x y) 
-;;  "Expand calls to `equalp' where X or Y is a constant expression.
-;;
-;;Much of the processing that `equalp' does is dependent on the types of both
-;;of its arguments, and with type information for one of them, we can
-;;eliminate much of the body of the function at compile time.
-;;
-;;Where both X and Y are constant expressions, `equalp' is evaluated at
-;;compile time by byte-optimize.el--this compiler macro passes FORM through to
-;;the byte optimizer in those cases."
-;;  ;; Cases where both arguments are constant are handled in
-;;  ;; byte-optimize.el, we only need to handle those cases where one is
-;;  ;; constant here.
-;;  (let* ((equalp-sym (eval-when-compile (gensym)))
-;;	(let-form '(progn))
-;;	(check-bit-vector t)
-;;	(check-string t)
-;;	(original-y y)
-;;	equalp-temp checked)
-;;  (macrolet
-;;      ((unordered-check (check)
-;;	 `(prog1
-;;	     (setq checked
-;;		   (or ,check
-;;		       (prog1 ,(sublis '((x . y) (y . x)) check :test #'eq)
-;;			 (setq equalp-temp x x y y equalp-temp))))
-;;	   (when checked
-;;	     (unless (symbolp y)
-;;	       (setq let-form `(let ((,equalp-sym ,y))) y equalp-sym))))))
-;;    ;; In the bodies of the below clauses, x is always a constant expression
-;;    ;; of the type we're interested in, and y is always a symbol that refers
-;;    ;; to the result non-constant side of the comparison. 
-;;    (cond ((unordered-check (and (arrayp x) (not (cl-const-expr-p y))))
-;;	   ;; Strings and other arrays. A vector containing the same
-;;	   ;; character elements as a given string is equalp to that string;
-;;	   ;; a bit-vector can only be equalp to a string if both are
-;;	   ;; zero-length.
-;;	   (cond
-;;	    ((member x '("" #* []))
-;;	     ;; No need to protect against multiple evaluation here:
-;;	     `(and (member ,original-y '("" #* [])) t))
-;;	    ((stringp x)
-;;	     `(,@let-form
-;;	       (if (stringp ,y)
-;;		   (eq t (compare-strings ,x nil nil
-;;					  ,y nil nil t))
-;;		 (if (vectorp ,y) 
-;;		     (cl-string-vector-equalp ,x ,y)))))
-;;	    ((bit-vector-p x)
-;;	     `(,@let-form
-;;	       (if (bit-vector-p ,y)
-;;		   ;; No need to call equalp on each element here:
-;;		   (equal ,x ,y)
-;;		 (if (vectorp ,y) 
-;;		     (cl-bit-vector-vector-equalp ,x ,y)))))
-;;	    (t
-;;	     (loop
-;;	       for elt across x
-;;	       ;; We may not need to check the other argument if it's a
-;;	       ;; string or bit vector, depending on the contents of x:
-;;	       always (progn
-;;			(unless (characterp elt) (setq check-string nil))
-;;			(unless (and (numberp elt) (or (= elt 0) (= elt 1)))
-;;			  (setq check-bit-vector nil))
-;;			(or check-string check-bit-vector)))
-;;	     `(,@let-form
-;;	       (cond
-;;		,@(if check-string
-;;		      `(((stringp ,y) 
-;;			 (cl-string-vector-equalp ,y ,x))))
-;;		,@(if check-bit-vector 
-;;		      `(((bit-vector-p ,y)
-;;			 (cl-bit-vector-vector-equalp ,y ,x))))
-;;		((vectorp ,y)
-;;		 (cl-vector-array-equalp ,x ,y)))))))
-;;	  ((unordered-check (and (characterp x) (not (cl-const-expr-p y))))
-;;	   `(,@let-form
-;;	     (or (eq ,x ,y)
-;;		  ;; eq has a bytecode, char-equal doesn't.
-;;		 (and (characterp ,y)
-;;		      (eq (downcase ,x) (downcase ,y))))))
-;;	  ((unordered-check (and (numberp x) (not (cl-const-expr-p y))))
-;;	   `(,@let-form
-;;	     (and (numberp ,y)
-;;		  (= ,x ,y))))
-;;	  ((unordered-check (and (hash-table-p x) (not (cl-const-expr-p y))))
-;;	   ;; Hash tables; follow the CL spec.
-;;	   `(,@let-form
-;;	     (and (hash-table-p ,y)
-;;		  (eq ',(hash-table-test x) (hash-table-test ,y))
-;;		  (= ,(hash-table-count x) (hash-table-count ,y))
-;;		  (cl-hash-table-contents-equalp ,x ,y))))
-;;	  ((unordered-check
-;;	    ;; Symbols; eq. 
-;;	    (and (not (cl-const-expr-p y))
-;;		 (or (memq x '(nil t))
-;;		     (and (eq (car-safe x) 'quote) (symbolp (second x))))))
-;;	   (cons 'eq (cdr form)))
-;;	  ((unordered-check
-;;	    ;; Compare conses at runtime, there's no real upside to
-;;	    ;; unrolling the function -> they fall through to the next
-;;	    ;; clause in this function.
-;;	    (and (cl-const-expr-p x) (not (consp x))
-;;		 (not (cl-const-expr-p y))))
-;;	   ;; All other types; use equal.
-;;	   (cons 'equal (cdr form)))
-;;	  ;; Neither side is a constant expression, do all our evaluation at
-;;	  ;; runtime (or both are, and equalp will be called from
-;;	  ;; byte-optimize.el).
-;;	  (t form)))))
-
 (define-compiler-macro notany (&whole form &rest cl-rest)
   `(not (some ,@(cdr form))))
 
@@ -3773,6 +3744,13 @@
         (string (cons 'concat (cddr form))))
     form))
 
+(define-compiler-macro subst-char-in-string (&whole form fromchar tochar
+					     string &optional inplace)
+  (if (every #'cl-safe-expr-p (cdr form))
+      `(funcall (if ,inplace #'nsubstitute #'substitute) ,tochar ,fromchar
+	(the string ,string) :test #'eq)
+    form))
+
 (map nil
      #'(lambda (function)
          ;; There are byte codes for the two-argument versions of these

--- a/lisp/cl.el	Mon Oct 18 23:43:03 2010 +0900
+++ b/lisp/cl.el	Mon Oct 25 13:04:04 2010 +0100
@@ -542,8 +542,8 @@
 	 (prog1
 	     (setq result (list (car list)))
 	   (while (and (setq list (cdr-safe list)) (not (eql list sublist)))
-	     (setf (cdr result) (if (consp list) (list (car list)) list)
-		   result (cdr result)
+	     (setcdr result (if (consp list) (list (car list)) list))
+	     (setq result (cdr result)
 		   evenp (not evenp))
 	     (if evenp (setq before (cdr before)))
 	     (if (eq before list) (error 'circular-list list)))))))