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

comparison lisp/cl-macs.el @ 5294:bbff29a01820

Add compiler macros and compilation sanity-checks for functions with keywords. 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

author	Aidan Kehoe <kehoea@parhasard.net>
date	Mon, 25 Oct 2010 13:04:04 +0100
parents	99de5fd48e87
children	ec05a30f7148 b9167d522a9a

comparison

equal deleted inserted replaced

-:63f247c5da0a
+:bbff29a01820
 (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
 ;;; 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

Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 5294:bbff29a01820