commit/XEmacs: kehoea: Add compiler macros for #'equal, #'member, ... where #'eq, #'memq appropriate.

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&gt; * 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&gt; + + * 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&gt; * 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