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

comparison lisp/cl-macs.el @ 4792:95b04754ea8c

Make #'equalp more compatible with CL; add a compiler macro, test & doc it. lisp/ChangeLog addition: 2009-11-08 Aidan Kehoe <kehoea@parhasard.net> * cl-extra.el (cl-string-vector-equalp) (cl-bit-vector-vector-equalp, cl-vector-array-equalp) (cl-hash-table-contents-equalp): New functions, to implement equalp treating arrays with identical contents as equivalent, as specified by Common Lisp. (equalp): Revise this function to implement array equivalence, and the hash-table equalp behaviour specified by CL. * cl-macs.el (equalp): Add a compiler macro for this function, used when one of the arguments is constant, and as such, its type is known at compile time. man/ChangeLog addition: 2009-11-08 Aidan Kehoe <kehoea@parhasard.net> * lispref/objects.texi (Equality Predicates): Document #'equalp here, as well as #'equal and #'eq. tests/ChangeLog addition: 2009-12-31 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el: Test much of the functionality of equalp; add a pointer to Paul Dietz' ANSI test suite for this function, converted to Emacs Lisp. Not including the tests themselves in XEmacs because who owns the copyright on the files is unclear and the GCL people didn't respond to my queries.

author	Aidan Kehoe <kehoea@parhasard.net>
date	Thu, 31 Dec 2009 15:09:41 +0000
parents	e29fcfd8df5f
children	8484c6c76837

comparison

equal deleted inserted replaced

-:ea07b60c097f
+:95b04754ea8c
 (define-compiler-macro regexp-quote (&whole form string)
 (if (stringp string)
 (regexp-quote string)
 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)))))
 (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

Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 4792:95b04754ea8c