From: Nikodemus Siivola Date: Thu, 31 Jul 2008 13:32:10 +0000 (+0000) Subject: additional list seeking transformations X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=1db4f16ef02f5b4d699d78541edb19ad8f3defc8;p=sbcl.git additional list seeking transformations * Implement TRANSFORM-LIST-PRED-SEEK, very much akin to TRANSFORM-LIST-ITEM-SEEK, and use it to optimize MEMBER-IF[-NOT], ASSOC-IF[-NOT], and RASSOC-IF[-NOT]. * Implement full versions of list seeking functions in terms of the specialized versions: in some cases this is a win, in some cases a loss -- but the number of places where functionality is duplicated is reduced, which should be easier on the maintenance and less bug-prone. * Add a TRANSFORM-LIST-ITEM-SEEK transform for RASSOC. * LVAR-FOR-NAMED-FUNCTION was a restricted form of LVAR-FUN-IS. Do away with the former, and move the latter to ir1util.lisp. --- diff --git a/NEWS b/NEWS index 63f1842..b95aa43 100644 --- a/NEWS +++ b/NEWS @@ -4,6 +4,9 @@ changes in sbcl-1.0.20 relative to 1.0.19: SB-C::STACK-ALLOCATE-DYNAMIC-EXTENT, SB-C::STACK-ALLOCATE-VECTOR, and SB-C::STACK-ALLOCATE-VALUE-CELLS no longer exist. See documentation and SB-EXT:*STACK-ALLOCATE-DYNAMIC-EXTENT* for details. + * optimization: ASSOC-IF, ASSOC-IF-NOT, MEMBER-IF, MEMBER-IF-NOT, + RASSOC, RASSOC-IF, and RASSOC-IF-NOT are now equally efficient + as ASSOC and MEMEBER. * optimization: runtime lookup of function definitions can be elided in more cases, eg: (let ((x 'foo)) (funcall foo)). * bug fix: fixed #427: unused local aliens no longer cause compiler diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 0a3357c..d612db1 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1185,6 +1185,10 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK" "%ASSOC" "%ASSOC-EQ" + "%ASSOC-IF" + "%ASSOC-IF-KEY" + "%ASSOC-IF-NOT" + "%ASSOC-IF-NOT-KEY" "%ASSOC-KEY" "%ASSOC-KEY-EQ" "%ASSOC-KEY-TEST" @@ -1230,6 +1234,10 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%MASK-FIELD" "%MEMBER" "%MEMBER-EQ" + "%MEMBER-IF" + "%MEMBER-IF-KEY" + "%MEMBER-IF-NOT" + "%MEMBER-IF-NOT-KEY" "%MEMBER-KEY" "%MEMBER-KEY-EQ" "%MEMBER-KEY-TEST" @@ -1237,6 +1245,18 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%MEMBER-TEST" "%MEMBER-TEST-NOT" "%NEGATE" "%POW" "%PUTHASH" + "%RASSOC" + "%RASSOC-EQ" + "%RASSOC-IF" + "%RASSOC-IF-KEY" + "%RASSOC-IF-NOT" + "%RASSOC-IF-NOT-KEY" + "%RASSOC-KEY" + "%RASSOC-KEY-EQ" + "%RASSOC-KEY-TEST" + "%RASSOC-KEY-TEST-NOT" + "%RASSOC-TEST" + "%RASSOC-TEST-NOT" "%RAW-BITS" "%RAW-BITS-WITH-OFFSET" "%VECTOR-RAW-BITS" "%RAW-REF-COMPLEX-DOUBLE" "%RAW-REF-COMPLEX-LONG" "%RAW-REF-COMPLEX-SINGLE" "%RAW-REF-DOUBLE" diff --git a/src/code/list.lisp b/src/code/list.lisp index 46cbb32..39af79e 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -19,10 +19,10 @@ (declaim (maybe-inline tree-equal nth %setnth nthcdr make-list - member-if member-if-not tailp union + tailp union nunion intersection nintersection set-difference nset-difference set-exclusive-or nset-exclusive-or subsetp acons - assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if + subst subst-if subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis)) ;;; These functions perform basic list operations. @@ -801,41 +801,45 @@ ;;;; functions for using lists as sets -(defun member (item list &key key (test #'eql testp) (test-not #'eql notp)) +(defun member (item list &key key (test nil testp) (test-not nil notp)) #!+sb-doc "Return the tail of LIST beginning with first element satisfying EQLity, :TEST, or :TEST-NOT with the given ITEM." (when (and testp notp) (error ":TEST and :TEST-NOT were both supplied.")) (let ((key (and key (%coerce-callable-to-fun key))) - (test (if testp (%coerce-callable-to-fun test) test)) - (test-not (if notp (%coerce-callable-to-fun test-not) test-not))) - (declare (type function test test-not)) - (do ((list list (cdr list))) - ((null list) nil) - (let ((car (car list))) - (when (satisfies-the-test item car) - (return list)))))) + (test (and testp (%coerce-callable-to-fun test))) + (test-not (and notp (%coerce-callable-to-fun test-not)))) + (cond (test + (if key + (%member-key-test item list key test) + (%member-test item list test))) + (test-not + (if key + (%member-key-test-not item list key test-not) + (%member-test-not item list test-not))) + (t + (if key + (%member-key item list key) + (%member item list)))))) (defun member-if (test list &key key) #!+sb-doc "Return tail of LIST beginning with first element satisfying TEST." (let ((test (%coerce-callable-to-fun test)) (key (and key (%coerce-callable-to-fun key)))) - (do ((list list (cdr list))) - ((endp list) nil) - (if (funcall test (apply-key key (car list))) - (return list))))) + (if key + (%member-if-key test list key) + (%member-if test list)))) (defun member-if-not (test list &key key) #!+sb-doc "Return tail of LIST beginning with first element not satisfying TEST." (let ((test (%coerce-callable-to-fun test)) (key (and key (%coerce-callable-to-fun key)))) - (do ((list list (cdr list))) - ((endp list) ()) - (if (not (funcall test (apply-key key (car list)))) - (return list))))) + (if key + (%member-if-not-key test list key) + (%member-if-not test list)))) (defun tailp (object list) #!+sb-doc @@ -851,13 +855,21 @@ "Add ITEM to LIST unless it is already a member" (when (and testp notp) (error ":TEST and :TEST-NOT were both supplied.")) - (let ((key (and key (%coerce-callable-to-fun key)))) - (if (let ((key-val (apply-key key item))) - (if notp - (member key-val list :test-not test-not :key key) - (member key-val list :test test :key key))) - list - (cons item list)))) + (let ((key (and key (%coerce-callable-to-fun key))) + (test (and testp (%coerce-callable-to-fun test))) + (test-not (and notp (%coerce-callable-to-fun test-not)))) + (cond (test + (if key + (%adjoin-key-test item list key test) + (%adjoin-test item list test))) + (test-not + (if key + (%adjoin-key-test-not item list key test-not) + (%adjoin-test-not item list test-not))) + (t + (if key + (%adjoin-key item list key) + (%adjoin item list)))))) (defconstant +list-based-union-limit+ 80) @@ -1132,15 +1144,6 @@ (error "The lists of keys and data are of unequal length.")) (setq alist (acons (car x) (car y) alist)))) -;;; This is defined in the run-time environment, not just the compile-time -;;; environment (i.e. not wrapped in EVAL-WHEN (COMPILE EVAL)) because it -;;; can appear in inline expansions. -(defmacro assoc-guts (test-expr) - `(do ((alist alist (cdr alist))) - ((endp alist)) - (when (and (car alist) ,test-expr) - (return (car alist))))) - (defun assoc (item alist &key key (test nil testp) (test-not nil notp)) #!+sb-doc "Return the cons in ALIST whose car is equal (by a given test or EQL) to @@ -1152,17 +1155,16 @@ (test-not (and notp (%coerce-callable-to-fun test-not)))) (cond (test (if key - (assoc-guts (funcall test item (funcall key (caar alist)))) - (assoc-guts (funcall test item (caar alist))))) + (%assoc-key-test item alist key test) + (%assoc-test item alist test))) (test-not (if key - (assoc-guts (not (funcall test-not item - (funcall key (caar alist))))) - (assoc-guts (not (funcall test-not item (caar alist)))))) + (%assoc-key-test-not item alist key test-not) + (%assoc-test-not item alist test-not))) (t (if key - (assoc-guts (eql item (funcall key (caar alist)))) - (assoc-guts (eql item (caar alist)))))))) + (%assoc-key item alist key) + (%assoc item alist)))))) (defun assoc-if (predicate alist &key key) #!+sb-doc @@ -1171,8 +1173,8 @@ (let ((predicate (%coerce-callable-to-fun predicate)) (key (and key (%coerce-callable-to-fun key)))) (if key - (assoc-guts (funcall predicate (funcall key (caar alist)))) - (assoc-guts (funcall predicate (caar alist)))))) + (%assoc-if-key predicate alist key) + (%assoc-if predicate alist)))) (defun assoc-if-not (predicate alist &key key) #!+sb-doc @@ -1181,8 +1183,8 @@ (let ((predicate (%coerce-callable-to-fun predicate)) (key (and key (%coerce-callable-to-fun key)))) (if key - (assoc-guts (not (funcall predicate (funcall key (caar alist))))) - (assoc-guts (not (funcall predicate (caar alist))))))) + (%assoc-if-not-key predicate alist key) + (%assoc-if-not predicate alist)))) (defun rassoc (item alist &key key (test nil testp) (test-not nil notp)) (declare (list alist)) @@ -1196,17 +1198,16 @@ (test-not (and notp (%coerce-callable-to-fun test-not)))) (cond (test (if key - (assoc-guts (funcall test item (funcall key (cdar alist)))) - (assoc-guts (funcall test item (cdar alist))))) + (%rassoc-key-test item alist key test) + (%rassoc-test item alist test))) (test-not (if key - (assoc-guts (not (funcall test-not item - (funcall key (cdar alist))))) - (assoc-guts (not (funcall test-not item (cdar alist)))))) + (%rassoc-key-test-not item alist key test-not) + (%rassoc-test-not item alist test-not))) (t (if key - (assoc-guts (eql item (funcall key (cdar alist)))) - (assoc-guts (eql item (cdar alist)))))))) + (%rassoc-key item alist key) + (%rassoc item alist)))))) (defun rassoc-if (predicate alist &key key) #!+sb-doc @@ -1215,8 +1216,8 @@ (let ((predicate (%coerce-callable-to-fun predicate)) (key (and key (%coerce-callable-to-fun key)))) (if key - (assoc-guts (funcall predicate (funcall key (cdar alist)))) - (assoc-guts (funcall predicate (cdar alist)))))) + (%rassoc-if-key predicate alist key) + (%rassoc-if predicate alist)))) (defun rassoc-if-not (predicate alist &key key) #!+sb-doc @@ -1225,8 +1226,8 @@ (let ((predicate (%coerce-callable-to-fun predicate)) (key (and key (%coerce-callable-to-fun key)))) (if key - (assoc-guts (not (funcall predicate (funcall key (cdar alist))))) - (assoc-guts (not (funcall predicate (cdar alist))))))) + (%rassoc-if-not-key predicate alist key) + (%rassoc-if-not predicate alist)))) ;;;; mapping functions @@ -1292,73 +1293,96 @@ ;;;; Specialized versions -;;; %ADJOIN-*, %ASSOC-*, and %MEMBER-* functions. Deftransforms -;;; delegate to TRANSFORM-LIST-ITEM-SEEK which picks the appropriate -;;; version. These win because they have only positional arguments, -;;; the TEST, TEST-NOT & KEY functions are known to exist (or not), -;;; and are known to be functions instead of function designators. We -;;; are also able to transform many common cases to -EQ versions, -;;; which are substantially faster then EQL using ones. +;;; %ADJOIN-*, %ASSOC-*, %MEMBER-*, and %RASSOC-* functions. Deftransforms +;;; delegate to TRANSFORM-LIST-PRED-SEEK and TRANSFORM-LIST-ITEM-SEEK which +;;; pick the appropriate versions. These win because they have only positional +;;; arguments, the TEST, TEST-NOT & KEY functions are known to exist (or not), +;;; and are known to be functions instead of function designators. We are also +;;; able to transform many common cases to -EQ versions, which are +;;; substantially faster then EQL using ones. (macrolet ((def (funs form &optional variant) - (flet ((%def (name) + (flet ((%def (name &optional conditional) (let* ((body-loop `(do ((list list (cdr list))) ((null list) nil) (declare (list list)) (let ((this (car list))) - ,(ecase name - (assoc - (if funs - `(when this - (let ((target (car this))) - (when ,form - (return this)))) - ;; If there is no TEST/TEST-NOT or - ;; KEY, do the EQ/EQL test first, - ;; before checking for NIL. - `(let ((target (car this))) - (when (and ,form this) - (return this))))) - (member - `(let ((target this)) - (when ,form - (return list)))) - (adjoin - `(let ((target this)) - (when ,form - (return t)))))))) + ,(let ((cxx (if (char= #\A (char (string name) 0)) + 'car ; assoc, assoc-if, assoc-if-not + 'cdr))) ; rassoc, rassoc-if, rassoc-if-not + (ecase name + ((assoc rassoc) + (if funs + `(when this + (let ((target (,cxx this))) + (when ,form + (return this)))) + ;; If there is no TEST/TEST-NOT or + ;; KEY, do the EQ/EQL test first, + ;; before checking for NIL. + `(let ((target (,cxx this))) + (when (and ,form this) + (return this))))) + ((assoc-if assoc-if-not rassoc-if rassoc-if-not) + (aver (equal '(eql x) (subseq form 0 2))) + `(when this + (let ((target (,cxx this))) + (,conditional (funcall ,@(cdr form)) + (return this))))) + (member + `(let ((target this)) + (when ,form + (return list)))) + ((member-if member-if-not) + (aver (equal '(eql x) (subseq form 0 2))) + `(let ((target this)) + (,conditional (funcall ,@(cdr form)) + (return list)))) + (adjoin + `(let ((target this)) + (when ,form + (return t))))))))) (body (if (eq 'adjoin name) `(if (let ,(when (member 'key funs) - `((item (funcall key item)))) + `((x (funcall key x)))) ,body-loop) list - (cons item list)) + (cons x list)) body-loop))) `(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant)) - (item list ,@funs) + (x list ,@funs) (declare (optimize speed (sb!c::verify-arg-count 0))) ,@(when funs `((declare (function ,@funs)))) + ,@(unless (member name '(member assoc adjoin rassoc)) `((declare (function x)))) ,body)))) `(progn ,(%def 'adjoin) ,(%def 'assoc) - ,(%def 'member))))) + ,(%def 'member) + ,(%def 'rassoc) + ,@(when (and (not variant) (member funs '(() (key)) :test #'equal)) + (list (%def 'member-if 'when) + (%def 'member-if-not 'unless) + (%def 'assoc-if 'when) + (%def 'assoc-if-not 'unless) + (%def 'rassoc-if 'when) + (%def 'rassoc-if-not 'unless))))))) (def () - (eql item target)) + (eql x target)) (def () - (eq item target) + (eq x target) eq) (def (key) - (eql item (funcall key target))) + (eql x (funcall key target))) (def (key) - (eq item (funcall key target)) + (eq x (funcall key target)) eq) (def (key test) - (funcall test item (funcall key target))) + (funcall test x (funcall key target))) (def (key test-not) - (not (funcall test-not item (funcall key target)))) + (not (funcall test-not x (funcall key target)))) (def (test) - (funcall test item target)) + (funcall test x target)) (def (test-not) - (not (funcall test-not item target)))) + (not (funcall test-not x target)))) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 2beb884..99e2ef8 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1926,14 +1926,14 @@ (setf (block-reoptimize (node-block node)) t) (reoptimize-component (node-component node) :maybe))))))) -;;; True if LVAR is for 'NAME, or #'NAME (global, not local) -(defun lvar-for-named-function (lvar name) - (if (constant-lvar-p lvar) - (eq name (lvar-value lvar)) - (let ((use (lvar-uses lvar))) - (and (not (listp use)) - (ref-p use) - (let ((leaf (ref-leaf use))) - (and (global-var-p leaf) - (eq :global-function (global-var-kind leaf)) - (eq name (leaf-source-name leaf)))))))) +;;; Return true if LVAR's only use is a non-NOTINLINE reference to a +;;; global function with one of the specified NAMES. +(defun lvar-fun-is (lvar names) + (declare (type lvar lvar) (list names)) + (let ((use (lvar-uses lvar))) + (and (ref-p use) + (let ((leaf (ref-leaf use))) + (and (global-var-p leaf) + (eq (global-var-kind leaf) :global-function) + (not (null (member (leaf-source-name leaf) names + :test #'equal)))))))) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 3277b04..eaf85fd 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -291,7 +291,7 @@ (or end length) (sequence-bounding-indices-bad-error vector start end))))) -(defun specialized-list-seek-function-name (function-name key-functions variant) +(defun specialized-list-seek-function-name (function-name key-functions &optional variant) (or (find-symbol (with-output-to-string (s) ;; Write "%NAME-FUN1-FUN2-FUN3", etc. Not only is ;; this ever so slightly faster then FORMAT, this @@ -311,10 +311,10 @@ (defun transform-list-item-seek (name item list key test test-not node) ;; If TEST is EQL, drop it. - (when (and test (lvar-for-named-function test 'eql)) + (when (and test (lvar-fun-is test '(eql))) (setf test nil)) ;; Ditto for KEY IDENTITY. - (when (and key (lvar-for-named-function key 'identity)) + (when (and key (lvar-fun-is key '(identity))) (setf key nil)) ;; Key can legally be NIL, but if it's NIL for sure we pretend it's ;; not there at all. If it might be NIL, make up a form to that @@ -331,7 +331,7 @@ #'identity))) (t (values key '(%coerce-callable-to-fun key)))))) - (let* ((c-test (cond ((and test (lvar-for-named-function test 'eq)) + (let* ((c-test (cond ((and test (lvar-fun-is test '(eq))) (setf test nil) 'eq) ((and (not test) (not test-not)) @@ -348,14 +348,15 @@ (when tail `(if (let ((this ',(car tail))) ,(ecase name - (assoc - `(and this (let ((target (car this))) - ,test-expr))) + ((assoc rassoc) + (let ((cxx (if (eq name 'assoc) 'car 'cdr))) + `(and this (let ((target (,cxx this))) + ,test-expr)))) (member `(let ((target this)) ,test-expr)))) ',(ecase name - (assoc (car tail)) + ((assoc rassoc) (car tail)) (member tail)) ,(open-code (cdr tail))))) (ensure-fun (fun) @@ -364,7 +365,7 @@ `(%coerce-callable-to-fun ,fun)))) (let* ((cp (constant-lvar-p list)) (c-list (when cp (lvar-value list)))) - (cond ((and cp c-list (member name '(assoc member)) + (cond ((and cp c-list (member name '(assoc rassoc member)) (policy node (>= speed space))) `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs) ,(open-code c-list))) @@ -378,14 +379,77 @@ `(,(specialized-list-seek-function-name name funs c-test) item list ,@(mapcar #'ensure-fun funs))))))))) -(deftransform member ((item list &key key test test-not) * * :node node) - (transform-list-item-seek 'member item list key test test-not node)) - -(deftransform assoc ((item list &key key test test-not) * * :node node) - (transform-list-item-seek 'assoc item list key test test-not node)) +(defun transform-list-pred-seek (name pred list key node) + ;; If KEY is IDENTITY, drop it. + (when (and key (lvar-fun-is key '(identity))) + (setf key nil)) + ;; Key can legally be NIL, but if it's NIL for sure we pretend it's + ;; not there at all. If it might be NIL, make up a form to that + ;; ensures it is a function. + (multiple-value-bind (key key-form) + (when key + (let ((key-type (lvar-type key)) + (null-type (specifier-type 'null))) + (cond ((csubtypep key-type null-type) + (values nil nil)) + ((csubtypep null-type key-type) + (values key '(if key + (%coerce-callable-to-fun key) + #'identity))) + (t + (values key '(%coerce-callable-to-fun key)))))) + (let ((test-expr `(%funcall pred ,(if key '(%funcall key target) 'target))) + (pred-expr (if (csubtypep (lvar-type pred) (specifier-type 'function)) + 'pred + '(%coerce-callable-to-fun pred)))) + (when (member name '(member-if-not assoc-if-not rassoc-if-not)) + (setf test-expr `(not ,test-expr))) + (labels ((open-code (tail) + (when tail + `(if (let ((this ',(car tail))) + ,(ecase name + ((assoc-if assoc-if-not rassoc-if rassoc-if-not) + (let ((cxx (if (member name '(assoc-if assoc-if-not)) 'car 'cdr))) + `(and this (let ((target (,cxx this))) + ,test-expr)))) + ((member-if member-if-not) + `(let ((target this)) + ,test-expr)))) + ',(ecase name + ((assoc-if assoc-if-not rassoc-if rassoc-if-not) + (car tail)) + ((member-if member-if-not) + tail)) + ,(open-code (cdr tail)))))) + (let* ((cp (constant-lvar-p list)) + (c-list (when cp (lvar-value list)))) + (cond ((and cp c-list (policy node (>= speed space))) + `(let ((pred ,pred-expr) + ,@(when key `((key ,key-form)))) + ,(open-code c-list))) + ((and cp (not c-list)) + ;; constant nil list -- nothing to find! + nil) + (t + ;; specialized out-of-line version + `(,(specialized-list-seek-function-name name (when key '(key))) + ,pred-expr list ,@(when key (list key-form)))))))))) -(deftransform adjoin ((item list &key key test test-not) * * :node node) - (transform-list-item-seek 'adjoin item list key test test-not node)) +(macrolet ((def (name &optional if/if-not) + `(progn + (deftransform ,name ((item list &key key test test-not) * * :node node) + (transform-list-item-seek ',name item list key test test-not node)) + ,@(when if/if-not + (let ((if-name (symbolicate name "-IF")) + (if-not-name (symbolicate name "-IF-NOT"))) + `((deftransform ,if-name ((pred list &key key) * * :node node) + (transform-list-pred-seek ',if-name pred list key node)) + (deftransform ,if-not-name ((pred list &key key) * * :node node) + (transform-list-pred-seek ',if-not-name pred list key node)))))))) + (def adjoin) + (def assoc t) + (def member t) + (def rassoc t)) (deftransform memq ((item list) (t (constant-arg list))) (labels ((rec (tail) @@ -471,18 +535,6 @@ ;;;; utilities -;;; Return true if LVAR's only use is a non-NOTINLINE reference to a -;;; global function with one of the specified NAMES. -(defun lvar-fun-is (lvar names) - (declare (type lvar lvar) (list names)) - (let ((use (lvar-uses lvar))) - (and (ref-p use) - (let ((leaf (ref-leaf use))) - (and (global-var-p leaf) - (eq (global-var-kind leaf) :global-function) - (not (null (member (leaf-source-name leaf) names - :test #'equal)))))))) - ;;; If LVAR is a constant lvar, the return the constant value. If it ;;; is null, then return default, otherwise quietly give up the IR1 ;;; transform. diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp index d42a879..d9b06b2 100644 --- a/tests/list.pure.lisp +++ b/tests/list.pure.lisp @@ -183,7 +183,6 @@ (test nil (member -1.0 numbers :key #'- :test 'eql)))) ;;; assoc - (macrolet ((test (expected form) (let ((numbers '((1 a) (2 b))) (tricky '(nil (a . b) nil (nil . c) (c . d)))) @@ -229,6 +228,96 @@ ;; alist (test (nil . c) (assoc nil tricky :test #'eq)))) +;;; rassoc +(macrolet ((test (expected form) + (let ((numbers '((a . 1) (b . 2))) + (tricky '(nil (b . a) nil (c . nil) (d . c)))) + `(progn + (assert (equal ',expected (let ((numbers ',numbers) + (tricky ',tricky)) + (funcall fun ,@(cdr form))))) + (assert (equal ',expected (funcall (lambda () + (declare (optimize speed)) + (let ((numbers ',numbers) + (tricky ',tricky)) + ,form))))) + (assert (equal ',expected (funcall (lambda () + (declare (optimize space)) + (let ((numbers ',numbers) + (tricky ',tricky)) + ,form))))))))) + (let ((fun (car (list 'rassoc)))) + (test (a . 1) (rassoc 1 numbers)) + (test (b . 2) (rassoc 2 numbers)) + (test (a . 1) (rassoc 1 numbers :key 'identity)) + (test (b . 2) (rassoc 2 numbers :key #'identity)) + (test nil (rassoc 1.0 numbers)) + + (test (a . 1) (rassoc 1.0 numbers :test #'=)) + (test (a . 1) (rassoc 1.0 numbers :test #'= :key nil)) + (test (b . 2) (rassoc 2.0 numbers :test '=)) + (test nil (rassoc 0 numbers :test '=)) + + (test (a . 1) (rassoc 0 numbers :test-not #'>)) + (test (b . 2) (rassoc 1 numbers :test-not 'eql)) + (test nil (rassoc 0 numbers :test-not '<)) + + (test (a . 1) (rassoc -1 numbers :key #'-)) + (test (b . 2) (rassoc -2 numbers :key '-)) + (test nil (rassoc -1.0 numbers :key #'-)) + + (test (a . 1) (rassoc -1.0 numbers :key #'- :test '=)) + (test (b . 2) (rassoc -2.0 numbers :key #'- :test '=)) + (test nil (rassoc -1.0 numbers :key #'- :test 'eql)) + + (test (c . nil) (rassoc nil tricky :test #'eq)))) + +;;;; member-if & assoc-if & rassoc-if +(macrolet ((test (value form) + `(let ((* ,value)) + (assert (eval ,form)) + (assert (funcall (compile nil (lambda () ,form))))))) + (test 'evenp + (equal '(2 3 4) (member-if * (list 1 2 3 4)))) + (test 'evenp + (equal '(2 3 4) (locally (declare (optimize speed)) + (member-if * '(1 2 3 4))))) + (test 'evenp + (equal '(3 4) (member-if * (list 1 2 3 4) :key (lambda (x) (if (= 3 x) 2 1))))) + (test 'evenp + (equal '(2 :two) (assoc-if * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four))))) + (test 'evenp + (equal '(3 :three) (assoc-if * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four)) + :key (lambda (x) (if (= 3 x) 2 1))))) + (test 'evenp + (equal '(:two . 2) (rassoc-if * (list '(:one . 1) '(:three . 3) '(:two . 2) '(:four . 4))))) + (test (list 1 2 3 4) + (equal '(2 3 4) (member-if 'evenp *))) + (test (list (cons 1 'a) (cons 2 'b) (cons 3 'c)) + (equal (cons 2 'b) (assoc-if 'evenp *)))) + +;;;; member-if-not & assoc-if-not +(macrolet ((test (value form) + `(let ((* ,value)) + (assert (eval ,form)) + (assert (funcall (compile nil (lambda () ,form))))))) + (test 'oddp + (equal '(2 3 4) (member-if-not * (list 1 2 3 4)))) + (test 'oddp + (equal '(2 3 4) (locally (declare (optimize speed)) + (member-if-not * '(1 2 3 4))))) + (test 'oddp + (equal '(3 4) (member-if-not * (list 1 2 3 4) :key (lambda (x) (if (= 3 x) 2 1))))) + (test 'oddp + (equal '(2 :two) (assoc-if-not * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four))))) + (test 'oddp + (equal '(3 :three) (assoc-if-not * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four)) + :key (lambda (x) (if (= 3 x) 2 1))))) + (test (list 1 2 3 4) + (equal '(2 3 4) (member-if-not 'oddp *))) + (test (list (cons 1 'a) (cons 2 'b) (cons 3 'c)) + (equal (cons 2 'b) (assoc-if-not 'oddp *)))) + ;;; bug reported by Dan Corkill: *PRINT-CASE* affected the compiler transforms ;;; for ASSOC & MEMBER (let ((*print-case* :downcase)) diff --git a/version.lisp-expr b/version.lisp-expr index be72424..c6e291d 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.19.9" +"1.0.19.10"