xemacs-beta: lisp/cl-macs.el comparison

comparison lisp/cl-macs.el @ 5420:b9167d522a9a

Rebase with 21.5 trunk.

author	Mats Lidell <matsl@xemacs.org>
date	Thu, 28 Oct 2010 23:53:24 +0200
parents	308d34e9f07d bbff29a01820
children	002cb5224e4f

comparison

equal deleted inserted replaced

-:eaf01113cd42
+:b9167d522a9a
 (defun cl-const-exprs-p (xs)
 (while (and xs (cl-const-expr-p (car xs)))
 (setq xs (cdr xs)))
 (not xs))
-(defun cl-const-expr-val (x)
+(defun cl-const-expr-val (x &optional cl-not-constant)
-(and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))
+(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
 (if (consp x)
 	(progn
 	(store-temp (gensym "--getf-store--")))
 (list (append (car method) (list tag-temp def-temp))
 	  (append (nth 1 method) (list tag def))
 	  (list store-temp)
 	  (list 'let (list (list (car (nth 2 method))
-				 (list 'cl-set-getf (nth 4 method)
+				 (list 'plist-put (nth 4 method)
 				       tag-temp store-temp)))
 		(nth 3 method) store-temp)
 	  (list 'getf (nth 4 method) tag-temp def-temp))))
 (define-setf-method substring (place from &optional to)
 		  (and tag-temp (list (list tag-temp tag))))
 	  (list 'if (list 'eq ttag (list 'car tval))
 		(list 'progn
 		      (cl-setf-do-store (nth 1 method) (list 'cddr tval))
 		      t)
-		(list 'cl-do-remf tval ttag)))))
+		(list 'plist-remprop tval ttag)))))
 ;;;###autoload
 (defmacro shiftf (place &rest args)
 "(shiftf PLACE PLACE... VAL): shift left among PLACEs.
 Example: (shiftf A B C) sets A to B, B to C, and returns the old A.
 ;;; Compile-time optimizations for some functions defined in this package.
 ;;; 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)
 	 (list 'if (list 'numberp a)
 	       (list 'equal a b)
 	 (list 'if (list 'numberp b)
 	       (list 'equal a b)
 	       (list 'eq a b)))
 	(t form)))
-(define-compiler-macro member* (&whole form a list &rest keys)
+(macrolet
-(let ((test (and (= (length keys) 2) (eq (car keys) :test)
+((define-star-compiler-macros (&rest macros)
-		   (cl-const-expr-val (nth 1 keys))))
+"For `member*', `assoc*' and `rassoc*' with constant ITEM or
-	a-val)
+:test arguments, use the versions with explicit tests if that makes sense."
-(cond ((eq test 'eq) (list 'memq a list))
+(list*
-	  ((eq test 'equal) (list 'member a list))
+	'progn
-	  ((or (null keys) (eq test 'eql))
+	(mapcar
-	   (if (eq (cl-const-expr-p a) t)
+	 (function*
-	       (list (if (and (numberp (setq a-val (cl-const-expr-val a)))
+	  (lambda ((star-function eq-function equal-function))
-			      (not (fixnump a-val)))
+	    `(define-compiler-macro ,star-function (&whole form item list
-			 'member
+						    &rest keys)
-		       'memq)
+	      (condition-case nil
-		     a list)
+		  (symbol-macrolet ((not-constant '#:not-constant))
-	     (if (eq (cl-const-expr-p list) t)
+		    (let* ((test-expr (plist-get keys :test ''eql))
-		 (let ((p (cl-const-expr-val list)) (mb nil) (mq nil))
+			   (test (cl-const-expr-val test-expr not-constant))
-		   (if (not (cdr p))
+			   (item-val (cl-const-expr-val item not-constant))
-		       (and p (list 'eql a (list 'quote (car p))))
+			   (list-val (cl-const-expr-val list not-constant)))
-		     (while p
+		      (if (and keys
-		       (if (and (numberp (car p)) (not (fixnump (car p))))
+			       (not (and (eq :test (car keys))
-			   (setq mb t)
+					 (eql 2 (length keys)))))
-			 (or (fixnump (car p)) (symbolp (car p)) (setq mq t)))
+			  form
-		       (setq p (cdr p)))
+			(cond ((eq test 'eq) `(,',eq-function ,item ,list))
-		     (if (not mb) (list 'memq a list)
+			      ((eq test 'equal)
-		       (if (not mq) (list 'member a list) form))))
+			       `(,',equal-function ,item ,list))
-	       form)))
+			      ((and (eq test 'eql)
-	  (t form))))
+				    (not (eq not-constant item-val)))
+			       (if (cl-non-fixnum-number-p item-val)
-(define-compiler-macro assoc* (&whole form a list &rest keys)
+				   `(,',equal-function ,item ,list)
-(let ((test (and (= (length keys) 2) (eq (car keys) :test)
+				 `(,',eq-function ,item ,list)))
-		   (cl-const-expr-val (nth 1 keys))))
+			      ((and (eq test 'eql) (not (eq not-constant
-	a-val)
+							    list-val)))
-(cond ((eq test 'eq) (list 'assq a list))
+			       (if (some 'cl-non-fixnum-number-p list-val)
-	  ((eq test 'equal) (list 'assoc a list))
+				   `(,',equal-function ,item ,list)
-	  ((and (eq (cl-const-expr-p a) t) (or (null keys) (eq test 'eql)))
+				 ;; This compiler macro used to limit calls
-	   (if (and (numberp (setq a-val (cl-const-expr-val a)))
+				 ;; to ,,eq-function to lists where all
-		    (not (fixnump a-val)))
+				 ;; elements were either fixnums or
-	       (list 'assoc a list) (list 'assq a list)))
+				 ;; symbols. There's no
-	  (t form))))
+				 ;; 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)
 	   (not (memq :key keys)))
 (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)))
 (while (setq args (cdr args))
 ;; 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)
-(let ((listp-check
+(if (not (or (memq (car-safe cl-seq)
-(cond
+		     ;; No need to check for a list at runtime with
-((memq (car-safe cl-seq)
+		     ;; these. We could expand the list, but these are all
-;; No need to check for a list at runtime with these. We
+		     ;; the functions in the relevant context at the moment.
-;; could expand the list, but these are all the functions
+		     '(nreverse append nconc mapcan mapcar string-to-list))
-;; in the relevant context at the moment.
+	       (and (listp cl-seq) (equal (butlast cl-seq) '(the list)))))
-'(nreverse append nconc mapcan mapcar string-to-list))
+form
-t)
+(cond
-((and (listp cl-seq) (eq (first cl-seq) 'the)
+((or (plists-equal cl-keys '(:test 'eq) t)
-(eq (second cl-seq) 'list))
+	  (plists-equal cl-keys '(:test #'eq) t))
-;; Allow users to force this, if they really want to.
+`(let* ((begin ,cl-seq)
-t)
+	      cl-seq)
-(t
+	(while (memq (car begin) (cdr begin))
-'(listp begin)))))
+	  (setq begin (cdr begin)))
-(cond ((loop
+	(setq cl-seq begin)
-	     for relevant-key-values
+	(while (cddr cl-seq)
-	     in '((:test 'eq)
+	  (if (memq (cadr cl-seq) (cddr cl-seq))
-		  (:test #'eq)
+	      (setcdr (cdr cl-seq) (cddr cl-seq)))
-		  (:test 'eq :from-end nil)
+	  (setq cl-seq (cdr cl-seq)))
-		  (:test #'eq :from-end nil))
+	begin))
-	     ;; One of the above corresponds exactly to CL-KEYS:
+((or (plists-equal cl-keys '(:test 'eq :from-end t) t)
-	     thereis (not (set-difference cl-keys relevant-key-values
+	  (plists-equal cl-keys '(:test #'eq :from-end t) t))
-					  :test #'equal)))
+`(let* ((begin ,cl-seq)
-`(let* ((begin ,cl-seq)
+	      (cl-seq begin))
-		   cl-seq)
+	(while cl-seq
-(if ,listp-check
+	  (setq cl-seq (setcdr cl-seq
-(progn
+			       (delq (car cl-seq) (cdr cl-seq)))))
-(while (memq (car begin) (cdr begin))
+	begin))
-(setq begin (cdr begin)))
+((or (plists-equal cl-keys '(:test 'equal) t)
-(setq cl-seq begin)
+	  (plists-equal cl-keys '(:test #'equal) t))
-(while (cddr cl-seq)
+`(let* ((begin ,cl-seq)
-(if (memq (cadr cl-seq) (cddr cl-seq))
+	      cl-seq)
-(setcdr (cdr cl-seq) (cddr cl-seq)))
+	(while (member (car begin) (cdr begin))
-(setq cl-seq (cdr cl-seq)))
+	  (setq begin (cdr begin)))
-begin)
+	(setq cl-seq begin)
-;; Call cl-delete-duplicates explicitly, to avoid the form
+	(while (cddr cl-seq)
-;; getting compiler-macroexpanded again:
+	  (if (member (cadr cl-seq) (cddr cl-seq))
-(cl-delete-duplicates begin ',cl-keys nil))))
+	      (setcdr (cdr cl-seq) (cddr cl-seq)))
-((loop
+	  (setq cl-seq (cdr cl-seq)))
-	     for relevant-key-values
+	begin))
-	     in '((:test 'eq :from-end t)
+((or (plists-equal cl-keys '(:test 'equal :from-end t) t)
-		  (:test #'eq :from-end t))
+	  (plists-equal cl-keys '(:test #'equal :from-end t) t))
-	     ;; One of the above corresponds exactly to CL-KEYS:
+`(let* ((begin ,cl-seq)
-	     thereis (not (set-difference cl-keys relevant-key-values
+	      (cl-seq begin))
-					  :test #'equal)))
+	(while cl-seq
-`(let* ((begin ,cl-seq)
+	  (setq cl-seq (setcdr cl-seq (delete (car cl-seq)
-		   (cl-seq begin))
+					      (cdr cl-seq)))))
-(if ,listp-check
+	begin))
-(progn
+(t form))))
-(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))))
 ;; XEmacs; it's perfectly reasonable, and often much clearer to those
 ;; reading the code, to call regexp-quote on a constant string, which is
 ;; something we can optimise here easily.
 (define-compiler-macro regexp-quote (&whole form string)
 	  ;; 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 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))))
 (define-compiler-macro notevery (&whole form &rest cl-rest)
 `(not (every ,@(cdr form))))
 (vector (cons 'vconcat (cddr form)))
 (bit-vector (cons 'bvconcat (cddr form)))
 (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
 ;; functions; if the form has more arguments and those arguments
 ;; have no side effects, transform to a series of two-argument
 			  (list 'list (list 'quote (caddr y)) 'x))
 		  (cons 'list (cdr y))))))
 '((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) (endp 'null x) (plusp '> x 0) (minusp '< x 0)
+(rest 'cdr x) (plusp '> x 0) (minusp '< x 0)
 (oddp  'eq (list 'logand x 1) 1)
 (evenp 'eq (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)

Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5420:b9167d522a9a