Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv16690/src/code
Modified Files:
list.lisp
Log Message:
1.0.7.25: better MEMBER transform
* Specialized versions for different keyword combinations: %MEMBER,
%MEMBER-TEST, %MEMBER-KEY-TEST, etc. These versions have positional
arguments, and the callable arguments are known to be functions.
* The transform open codes for all combinations of keywords if the
second argument is constant and (>= SPEED SPACE). Otherwise the
transform selects the appropriate specialized version and open
codes %COERCE-CALLABLE-TO-FUN around keyword arguments, allowing
type inference to optimize it away for arguments known to be
functions.
* Tests.
Index: list.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/list.lisp,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -d -r1.29 -r1.30
--- list.lisp 3 Jan 2007 20:49:54 -0000 1.29
+++ list.lisp 17 Jul 2007 13:18:06 -0000 1.30
@@ -734,8 +734,28 @@
(do ((list list (cdr list)))
((null list) nil)
(let ((car (car list)))
- (if (satisfies-the-test item car)
- (return list))))))
+ (when (satisfies-the-test item car)
+ (return list))))))
+
+(macrolet ((def (name funs form)
+ `(defun ,name (item list ,@funs)
+ ,@(when funs `((declare (function ,@funs))))
+ (do ((list list (cdr list)))
+ ((null list) nil)
+ (when ,form
+ (return list))))))
+ (def %member ()
+ (eql item (car list)))
+ (def %member-key (key)
+ (eql item (funcall key (car list))))
+ (def %member-key-test (key test)
+ (funcall test item (funcall key (car list))))
+ (def %member-key-test-not (key test-not)
+ (not (funcall test-not item (funcall key (car list)))))
+ (def %member-test (test)
+ (funcall test item (car list)))
+ (def %member-test-not (test-not)
+ (not (funcall test-not item (car list)))))
(defun member-if (test list &key key)
#!+sb-doc
|