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
"%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"
"%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"
"%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"
(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.
\f
;;;; 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
"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)
(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
(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
(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
(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))
(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
(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
(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))))
\f
;;;; mapping functions
;;;; 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))))
(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))))))))
(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
(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
#'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))
(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)
`(%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)))
`(,(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)
\f
;;;; 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.
(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))))
;; 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))
;;; 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"
projects / sbcl.git / commitdiff