commit: Tweak a few compiler macros for functions in cl-seq.el.

changeset: 5329:7b391d07b334 tag: tip user: Aidan Kehoe <kehoea(a)parhasard.net&gt; date: Sun Jan 02 16:18:26 2011 +0000 files: lisp/ChangeLog lisp/cl-macs.el tests/ChangeLog tests/automated/lisp-tests.el description: Tweak a few compiler macros for functions in cl-seq.el. lisp/ChangeLog addition: 2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; * cl-macs.el (define-star-compiler-macros): Make sure the form has ITEM and LIST specified before attempting to change to calls with explicit tests; necessary for some tests in lisp-tests.el to compile correctly. (stable-union, stable-intersection): Add compiler macros for these functions, in the same way we do for most of the other functions in cl-seq.el. tests/ChangeLog addition: 2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; * automated/lisp-tests.el (test-fun): Test member*, assoc*, rassoc*, delete* here too. diff -r dae3d95cf319 -r 7b391d07b334 lisp/ChangeLog --- a/lisp/ChangeLog Sun Jan 02 02:32:59 2011 +0000 +++ b/lisp/ChangeLog Sun Jan 02 16:18:26 2011 +0000 ＠＠ -1,3 +1,13 ＠＠ +2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * cl-macs.el (define-star-compiler-macros): + Make sure the form has ITEM and LIST specified before attempting + to change to calls with explicit tests; necessary for some tests + in lisp-tests.el to compile correctly. + (stable-union, stable-intersection): Add compiler macros for these + functions, in the same way we do for most of the other functions + in cl-seq.el. + 2011-01-01 Aidan Kehoe <kehoea(a)parhasard.net&gt; * cl-macs.el (dolist, dotimes, do-symbols, macrolet) diff -r dae3d95cf319 -r 7b391d07b334 lisp/cl-macs.el --- a/lisp/cl-macs.el Sun Jan 02 02:32:59 2011 +0000 +++ b/lisp/cl-macs.el Sun Jan 02 16:18:26 2011 +0000 ＠＠ -3283,51 +3283,53 ＠＠ (mapcar (function* (lambda ((star-function eq-function equal-function)) - `(define-compiler-macro ,star-function (&whole form item list - &rest keys) - (condition-case nil - (symbol-macrolet ((not-constant '#:not-constant)) - (let* ((test-expr (plist-get keys :test ''eql)) - (test (cl-const-expr-val test-expr not-constant)) - (item-val (cl-const-expr-val item not-constant)) - (list-val (cl-const-expr-val list not-constant))) - (if (and keys - (not (and (eq :test (car keys)) - (eql 2 (length keys))))) - form - (cond ((eq test 'eq) `(,',eq-function ,item ,list)) - ((eq test 'equal) - `(,',equal-function ,item ,list)) - ((and (eq test 'eql) - (not (eq not-constant item-val))) - (if (cl-non-fixnum-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) - `(,',equal-function ,item ,list) - ;; This compiler macro used to limit calls - ;; to ,,eq-function to lists where all - ;; elements were either fixnums or - ;; symbols. There's no - ;; 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))))) + `(define-compiler-macro ,star-function (&whole form &rest keys) + (if (< (length form) 3) + form + (condition-case nil + (symbol-macrolet ((not-constant '#:not-constant)) + (let* ((item (pop keys)) + (list (pop keys)) + (test-expr (plist-get keys :test ''eql)) + (test (cl-const-expr-val test-expr not-constant)) + (item-val (cl-const-expr-val item not-constant)) + (list-val (cl-const-expr-val list not-constant))) + (if (and keys (not (and (eq :test (car keys)) + (eql 2 (length keys))))) + form + (cond ((eq test 'eq) `(,',eq-function ,item ,list)) + ((eq test 'equal) + `(,',equal-function ,item ,list)) + ((and (eq test 'eql) + (not (eq not-constant item-val))) + (if (cl-non-fixnum-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) + `(,',equal-function ,item ,list) + ;; This compiler macro used to limit + ;; calls to ,,eq-function to lists where + ;; all elements were either fixnums or + ;; symbols. There's no 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) ＠＠ -3736,6 +3738,16 ＠＠ (the string ,string) :test #'eq) form)) +(define-compiler-macro stable-union (&whole form &rest cl-keys) + (if (> (length form) 2) + (list* 'union (pop cl-keys) (pop cl-keys) :stable t cl-keys) + form)) + +(define-compiler-macro stable-intersection (&whole form &rest cl-keys) + (if (> (length form) 2) + (list* 'intersection (pop cl-keys) (pop cl-keys) :stable t cl-keys) + form)) + (map nil #'(lambda (function) ;; There are byte codes for the two-argument versions of these diff -r dae3d95cf319 -r 7b391d07b334 tests/ChangeLog --- a/tests/ChangeLog Sun Jan 02 02:32:59 2011 +0000 +++ b/tests/ChangeLog Sun Jan 02 16:18:26 2011 +0000 ＠＠ -1,3 +1,8 ＠＠ +2011-01-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * automated/lisp-tests.el (test-fun): Test member*, assoc*, + rassoc*, delete* here too. + 2010-12-30 Aidan Kehoe <kehoea(a)parhasard.net&gt; * automated/lisp-tests.el (wrong-type-argument): Add a missing diff -r dae3d95cf319 -r 7b391d07b334 tests/automated/lisp-tests.el --- a/tests/automated/lisp-tests.el Sun Jan 02 02:32:59 2011 +0000 +++ b/tests/automated/lisp-tests.el Sun Jan 02 16:18:26 2011 +0000 ＠＠ -798,12 +798,12 ＠＠ collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n)))))) (test-funs (&rest funs) `(progn ,＠(loop for fun in funs collect `(test-fun ,fun))))) - (test-funs member old-member + (test-funs member* member old-member memq old-memq - assoc old-assoc - rassoc old-rassoc + assoc* assoc old-assoc + rassoc* rassoc old-rassoc rassq old-rassq - delete old-delete + delete* delete old-delete delq old-delq remassoc remassq remrassoc remrassq)) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches