[cl-utilities-cvs] CVS update: cl-utilities/extremum.lisp

[Peter Scott]

Update of /project/cl-utilities/cvsroot/cl-utilities
In directory common-lisp.net:/tmp/cvs-serv1422

Modified Files:
	extremum.lisp 
Log Message:
Added a couple of compiler macros which optimize the case where KEY is
#'identity.

Date: Fri May 13 21:45:10 2005
Author: pscott

Index: cl-utilities/extremum.lisp
diff -u cl-utilities/extremum.lisp:1.2 cl-utilities/extremum.lisp:1.3
--- cl-utilities/extremum.lisp:1.2	Thu May 12 23:17:23 2005
+++ cl-utilities/extremum.lisp	Fri May 13 21:45:09 2005
@@ -7,12 +7,21 @@
 
 (defun comparator (test &optional (key #'identity))
   "Comparison operator: auxilliary function used by EXTREMUM"
+  (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
   (lambda (a b) (if (funcall test
                              (funcall key a)
                              (funcall key b))
                     a
                     b)))
 
+;; This optimizes the case where KEY is #'identity
+(define-compiler-macro comparator (&whole whole test
+					  &optional (key #'identity))
+  (if (eql key #'identity)
+      `(lambda (a b)
+	(if (funcall ,test a b) a b))
+      whole))
+
 (defun zero-length-p (sequence)
   "Is the length of SEQUENCE equal to zero?"
   (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
@@ -39,6 +48,21 @@
 	  nil))
       (reduce (comparator predicate key) sequence
 	      :start start :end end)))
+
+;; This optimizes the case where KEY is #'identity
+(define-compiler-macro extremum (&whole whole sequence predicate
+					&key (key #'identity) (start 0) end)
+  (if (eql key #'identity)
+      (once-only (sequence predicate start end)
+	`(if (zero-length-p ,sequence)
+	  (restart-case (error 'no-extremum)
+	    (continue ()
+	      :report "Return NIL instead"
+	      nil))
+	  (locally (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+	    (reduce (comparator ,predicate) ,sequence
+		    :start ,start :end ,end))))
+      whole))
 
 ;; And, for backup, here's a strictly spec-compliant version.
 #+nil