(setf (aref sequence index) new)
(setq count (1- count)))))
\f
-;;; locater macros used by FIND and POSITION
+
+;;; REMOVEME: old POSITION/FIND stuff
+
+#|
+
+;;;; locater macros used by FIND and POSITION
(eval-when (:compile-toplevel :execute)
(seq-dispatch sequence
(list-find-if-not test sequence)
(vector-find-if-not test sequence))))
+|#
+\f
+;;;; FIND, POSITION, and their -IF and -IF-NOT variants
+
+;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
+;;; POSITION-IF, etc.
+(declaim (inline effective-find-position-test effective-find-position-key))
+(defun effective-find-position-test (test test-not)
+ (cond ((and test test-not)
+ (error "can't specify both :TEST and :TEST-NOT"))
+ (test (%coerce-callable-to-function test))
+ (test-not
+ ;; (Without DYNAMIC-EXTENT, this is potentially horribly
+ ;; inefficient, but since the TEST-NOT option is deprecated
+ ;; anyway, we don't care.)
+ (complement (%coerce-callable-to-function test-not)))
+ (t #'eql)))
+(defun effective-find-position-key (key)
+ (if key
+ (%coerce-callable-to-function key)
+ #'identity))
+
+;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF
+(macrolet (;; shared logic for defining %FIND-POSITION and
+ ;; %FIND-POSITION-IF in terms of various inlineable cases
+ ;; of the expression defined in FROB and VECTOR*-FROB
+ (frobs ()
+ `(etypecase sequence-arg
+ (list (frob sequence-arg from-end))
+ (vector
+ (with-array-data ((sequence sequence-arg :offset-var offset)
+ (start start)
+ (end (or end (length sequence-arg))))
+ (multiple-value-bind (f p)
+ (macrolet ((frob2 () '(if from-end
+ (frob sequence t)
+ (frob sequence nil))))
+ (typecase sequence
+ (simple-vector (frob2))
+ (simple-string (frob2))
+ (t (vector*-frob sequence))))
+ (declare (type (or index null) p))
+ (values f (and p (the index (+ p offset))))))))))
+ (defun %find-position (item sequence-arg from-end start end key test)
+ (macrolet ((frob (sequence from-end)
+ `(%find-position item ,sequence
+ ,from-end start end key test))
+ (vector*-frob (sequence)
+ `(%find-position-vector-macro item ,sequence
+ from-end start end key test)))
+ (frobs)))
+ (defun %find-position-if (predicate sequence-arg from-end start end key)
+ (macrolet ((frob (sequence from-end)
+ `(%find-position-if predicate ,sequence
+ ,from-end start end key))
+ (vector*-frob (sequence)
+ `(%find-position-if-vector-macro predicate ,sequence
+ from-end start end key)))
+ (frobs))))
+
+;;; the user interface to FIND and POSITION: Get all our ducks in a row,
+;;; then call %FIND-POSITION
+(declaim (inline find position))
+(macrolet ((def-find-position (fun-name values-index)
+ `(defun ,fun-name (item
+ sequence
+ &key
+ from-end
+ (start 0)
+ end
+ key
+ test
+ test-not)
+ (nth-value
+ ,values-index
+ (%find-position item
+ sequence
+ from-end
+ start
+ end
+ (effective-find-position-key key)
+ (effective-find-position-test test
+ test-not))))))
+ (def-find-position find 0)
+ (def-find-position position 1))
+
+;;; the user interface to FIND-IF and POSITION-IF, entirely analogous
+;;; to the interface to FIND and POSITION
+(declaim (inline find-if position-if))
+(macrolet ((def-find-position-if (fun-name values-index)
+ `(defun ,fun-name (predicate sequence
+ &key from-end (start 0) end key)
+ (nth-value
+ ,values-index
+ (%find-position-if (%coerce-callable-to-function predicate)
+ sequence
+ from-end
+ start
+ end
+ (effective-find-position-key key))))))
+
+ (def-find-position-if find-if 0)
+ (def-find-position-if position-if 1))
+
+;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We don't
+;;; bother to worry about optimizing them.
+;;;
+;;; FIXME: Remove uses of these deprecated functions (and of :TEST-NOT
+;;; too) within the implementation of SBCL.
+(macrolet ((def-find-position-if-not (fun-name values-index)
+ `(defun ,fun-name (predicate sequence
+ &key from-end (start 0) end key)
+ (nth-value
+ ,values-index
+ (%find-position-if (complement (%coerce-callable-to-function
+ predicate))
+ sequence
+ from-end
+ start
+ end
+ (effective-find-position-key key))))))
+ (def-find-position-if-not find-if-not 0)
+ (def-find-position-if-not position-if-not 1))
\f
;;;; COUNT
projects / sbcl.git / blobdiff