1 new commit in XEmacs:
https://bitbucket.org/xemacs/xemacs/changeset/e63bb7b22c8f/
changeset: e63bb7b22c8f
user: kehoea
date: 2012-05-07 18:56:24
summary: Add compiler macros for #'equal, #'member, ... where #'eq,
#'memq appropriate.
lisp/ChangeLog addition:
2012-05-07 Aidan Kehoe <kehoea(a)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.
affected #: 2 files
diff -r 289cf21be887b161e4e22c42088a1184d81058c0 -r
e63bb7b22c8f6078e97bba15561799d127e75c77 lisp/ChangeLog
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -229,6 +229,31 @@
(since the compiler macro adds :test #'eq to the delete* call if
it's not clear that FOO is not a non-fixnum number).
+2012-05-07 Aidan Kehoe <kehoea(a)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.
+
2012-05-01 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-optimize-form-code-walker):
diff -r 289cf21be887b161e4e22c42088a1184d81058c0 -r
e63bb7b22c8f6078e97bba15561799d127e75c77 lisp/cl-macs.el
--- a/lisp/cl-macs.el
+++ b/lisp/cl-macs.el
@@ -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))
Repository URL:
https://bitbucket.org/xemacs/xemacs/
--
This is a commit notification from
bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches