Mercurial > hg > xemacs-beta

diff lisp/cl-macs.el @ 5659:e63bb7b22c8f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add compiler macros for #'equal, #'member, ... where #'eq, #'memq appropriate. lisp/ChangeLog addition: 2012-05-07 Aidan Kehoe <kehoea@parhasard.net> * cl-macs.el: * cl-macs.el (cl-non-fixnum-number-p): Rename, to cl-non-immediate-number-p. This is a little more informative as a name, though still not ideal, in that it will give t for some immediate fixnums on 64-bit builds. * cl-macs.el (eql): * cl-macs.el (define-star-compiler-macros): * cl-macs.el (delq): * cl-macs.el (remq): Use the new name. * cl-macs.el (cl-equal-equivalent-to-eq-p): New. * cl-macs.el (cl-car-or-pi): New. * cl-macs.el (cl-cdr-or-pi): New. * cl-macs.el (equal): New compiler macro. * cl-macs.el (member): New compiler macro. * cl-macs.el (assoc): New compiler macro. * cl-macs.el (rassoc): New compiler macro. If any of #'equal, #'member, #'assoc or #'rassoc has a constant argument such that #'eq, #'memq, #'assq or #'rassq, respectively, are equivalent, make the substitution. Relevant in files like ispell.el, there's a reasonable amount of code out there that doesn't quite get the distinction.
author Aidan Kehoe <kehoea@parhasard.net>
date Mon, 07 May 2012 17:56:24 +0100
parents 289cf21be887
children 796f2a8fdced
line wrap: on
line diff
--- a/lisp/cl-macs.el	Sun May 06 15:29:59 2012 +0100
+++ b/lisp/cl-macs.el	Mon May 07 17:56:24 2012 +0100
@@ -3203,7 +3203,7 @@
     ((most-positive-fixnum-on-32-bit-machines () (1- (lsh 1 30)))
      (most-negative-fixnum-on-32-bit-machines ()
        (lognot (most-positive-fixnum-on-32-bit-machines))))
-  (defun cl-non-fixnum-number-p (object)
+  (defun cl-non-immediate-number-p (object)
     "Return t if OBJECT is a number not guaranteed to be immediate."
     (and (numberp object)
 	 (or (not (fixnump object))
@@ -3218,16 +3218,55 @@
 (define-compiler-macro eql (&whole form a b)
   (cond ((eq (cl-const-expr-p a) t)
 	 (let ((val (cl-const-expr-val a)))
-	   (if (cl-non-fixnum-number-p val)
+	   (if (cl-non-immediate-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 (cl-non-fixnum-number-p val)
+	   (if (cl-non-immediate-number-p val)
 	       (list 'equal a b)
 	     (list 'eq a b))))
 	(t form)))
 
+(defun cl-equal-equivalent-to-eq-p (object)
+  (or (symbolp object) (characterp object)
+      (and (fixnump object) (not (cl-non-immediate-number-p object)))))
+
+(defun cl-car-or-pi (object)
+  (if (consp object) (car object) pi))
+
+(defun cl-cdr-or-pi (object)
+  (if (consp object) (cdr object) pi))
+
+(define-compiler-macro equal (&whole form a b)
+  (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val a pi))
+          (cl-equal-equivalent-to-eq-p (cl-const-expr-val b pi)))
+      (cons 'eq (cdr form))
+    form))
+
+(define-compiler-macro member (&whole form elt list)
+  (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val elt pi))
+          (every #'cl-equal-equivalent-to-eq-p
+                 (cl-const-expr-val list '(1.0))))
+      (cons 'memq (cdr form))
+    form))
+
+(define-compiler-macro assoc (&whole form elt list)
+  (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val elt pi))
+          (not (find-if-not #'cl-equal-equivalent-to-eq-p
+                            (cl-const-expr-val list '((1.0 . nil)))
+                            :key #'cl-car-or-pi)))
+      (cons 'assq (cdr form))
+    form))
+
+(define-compiler-macro rassoc (&whole form elt list)
+  (if (or (cl-equal-equivalent-to-eq-p (cl-const-expr-val elt pi))
+          (not (find-if-not #'cl-equal-equivalent-to-eq-p
+                            (cl-const-expr-val list '((nil . 1.0)))
+                            :key #'cl-cdr-or-pi)))
+      (cons 'rassq (cdr form))
+    form)))
+
 (macrolet
     ((define-star-compiler-macros (&rest macros)
        "For `member*', `assoc*' and `rassoc*' with constant ITEM or
@@ -3256,12 +3295,12 @@
                                  `(,',equal-function ,item ,list))
                                 ((and (eq test 'eql)
                                       (not (eq not-constant item-val)))
-                                 (if (cl-non-fixnum-number-p item-val)
+                                 (if (cl-non-immediate-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)
+                                 (if (some 'cl-non-immediate-number-p list-val)
                                      `(,',equal-function ,item ,list)
                                    ;; This compiler macro used to limit
                                    ;; calls to ,,eq-function to lists where
@@ -3313,7 +3352,7 @@
           ((not-constant '#:not-constant))
         (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
           (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
-                   (not (cl-non-fixnum-number-p cl-const-expr-val)))
+                   (not (cl-non-immediate-number-p cl-const-expr-val)))
               (cons 'delete* (cdr form))
             `(delete* ,@(cdr form) :test #'eq))))
     form))
@@ -3336,7 +3375,7 @@
           ((not-constant '#:not-constant))
         (let ((cl-const-expr-val (cl-const-expr-val (nth 1 form) not-constant)))
           (if (and (cdr form) (not (eq not-constant cl-const-expr-val))
-                   (not (cl-non-fixnum-number-p cl-const-expr-val)))
+                   (not (cl-non-immediate-number-p cl-const-expr-val)))
               (cons 'remove* (cdr form))
             `(remove* ,@(cdr form) :test #'eq))))
     form))