-;;; locater macros used by FIND and POSITION
-
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-locater-macro (sequence body-form return-type)
- `(let ((incrementer (if from-end -1 1))
- (start (if from-end (1- (the fixnum end)) start))
- (end (if from-end (1- (the fixnum start)) end)))
- (declare (fixnum start end incrementer))
- (do ((index start (+ index incrementer))
- ,@(case return-type (:position nil) (:element '(current))))
- ((= index end) ())
- (declare (fixnum index))
- ,@(case return-type
- (:position nil)
- (:element `((setf current (aref ,sequence index)))))
- ,body-form)))
-
-(sb!xc:defmacro locater-test-not (item sequence seq-type return-type)
- (let ((seq-ref (case return-type
- (:position
- (case seq-type
- (:vector `(aref ,sequence index))
- (:list `(pop ,sequence))))
- (:element 'current)))
- (return (case return-type
- (:position 'index)
- (:element 'current))))
- `(if test-not
- (if (not (funcall test-not ,item (apply-key key ,seq-ref)))
- (return ,return))
- (if (funcall test ,item (apply-key key ,seq-ref))
- (return ,return)))))
-
-(sb!xc:defmacro vector-locater (item sequence return-type)
- `(vector-locater-macro ,sequence
- (locater-test-not ,item ,sequence :vector ,return-type)
- ,return-type))
-
-(sb!xc:defmacro locater-if-test (test sequence seq-type return-type sense)
- (let ((seq-ref (case return-type
- (:position
- (case seq-type
- (:vector `(aref ,sequence index))
- (:list `(pop ,sequence))))
- (:element 'current)))
- (return (case return-type
- (:position 'index)
- (:element 'current))))
- (if sense
- `(if (funcall ,test (apply-key key ,seq-ref))
- (return ,return))
- `(if (not (funcall ,test (apply-key key ,seq-ref)))
- (return ,return)))))
-
-(sb!xc:defmacro vector-locater-if-macro (test sequence return-type sense)
- `(vector-locater-macro ,sequence
- (locater-if-test ,test ,sequence :vector ,return-type ,sense)
- ,return-type))
-
-(sb!xc:defmacro vector-locater-if (test sequence return-type)
- `(vector-locater-if-macro ,test ,sequence ,return-type t))
-
-(sb!xc:defmacro vector-locater-if-not (test sequence return-type)
- `(vector-locater-if-macro ,test ,sequence ,return-type nil))
-
-(sb!xc:defmacro list-locater-macro (sequence body-form return-type)
- `(if from-end
- (do ((sequence (nthcdr (- (the fixnum (length sequence))
- (the fixnum end))
- (reverse (the list ,sequence))))
- (index (1- (the fixnum end)) (1- index))
- (terminus (1- (the fixnum start)))
- ,@(case return-type (:position nil) (:element '(current))))
- ((or (= index terminus) (null sequence)) ())
- (declare (fixnum index terminus))
- ,@(case return-type
- (:position nil)
- (:element `((setf current (pop ,sequence)))))
- ,body-form)
- (do ((sequence (nthcdr start ,sequence))
- (index start (1+ index))
- ,@(case return-type (:position nil) (:element '(current))))
- ((or (= index (the fixnum end)) (null sequence)) ())
- (declare (fixnum index))
- ,@(case return-type
- (:position nil)
- (:element `((setf current (pop ,sequence)))))
- ,body-form)))
-
-(sb!xc:defmacro list-locater (item sequence return-type)
- `(list-locater-macro ,sequence
- (locater-test-not ,item ,sequence :list ,return-type)
- ,return-type))
-
-(sb!xc:defmacro list-locater-if-macro (test sequence return-type sense)
- `(list-locater-macro ,sequence
- (locater-if-test ,test ,sequence :list ,return-type ,sense)
- ,return-type))
-
-(sb!xc:defmacro list-locater-if (test sequence return-type)
- `(list-locater-if-macro ,test ,sequence ,return-type t))
-
-(sb!xc:defmacro list-locater-if-not (test sequence return-type)
- `(list-locater-if-macro ,test ,sequence ,return-type nil))
-
-) ; EVAL-WHEN
-\f
-;;;; POSITION
-
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-position (item sequence)
- `(vector-locater ,item ,sequence :position))
-
-(sb!xc:defmacro list-position (item sequence)
- `(list-locater ,item ,sequence :position))
-
-) ; EVAL-WHEN
-
-;;; POSITION cannot default end to the length of sequence since it is not
-;;; an error to supply nil for its value. We must test for END being NIL
-;;; in the body of the function, and this is actually done in the support
-;;; routines for other reasons (see below).
-(defun position (item sequence &key from-end (test #'eql) test-not (start 0)
- end key)
- #!+sb-doc
- "Returns the zero-origin index of the first element in SEQUENCE
- satisfying the test (default is EQL) with the given ITEM"
- (seq-dispatch sequence
- (list-position* item sequence from-end test test-not start end key)
- (vector-position* item sequence from-end test test-not start end key)))
-
-;;; The support routines for SUBSEQ are used by compiler transforms, so we
-;;; worry about dealing with END being supplied or defaulting to NIL
-;;; at this level.
-
-(defun list-position* (item sequence from-end test test-not start end key)
- (declare (fixnum start))
- (when (null end) (setf end (length sequence)))
- (list-position item sequence))
-
-(defun vector-position* (item sequence from-end test test-not start end key)
- (declare (fixnum start))
- (when (null end) (setf end (length sequence)))
- (vector-position item sequence))
+;;;; FIND, POSITION, and their -IF and -IF-NOT variants
+
+(defun effective-find-position-test (test test-not)
+ (effective-find-position-test test test-not))
+(defun effective-find-position-key (key)
+ (effective-find-position-key key))
+
+;;; 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 (%check-vector-sequence-bounds
+ sequence-arg start end)))
+ (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)))
+ (defun %find-position-if-not (predicate sequence-arg from-end start end key)
+ (macrolet ((frob (sequence from-end)
+ `(%find-position-if-not predicate ,sequence
+ ,from-end start end key))
+ (vector*-frob (sequence)
+ `(%find-position-if-not-vector-macro predicate ,sequence
+ from-end start end key)))
+ (frobs))))
+
+;;; the user interface to FIND and POSITION: just interpreter stubs,
+;;; nowadays.
+(defun find (item sequence &key from-end (start 0) end key test test-not)
+ ;; FIXME: this can't be the way to go, surely?
+ (find item sequence :from-end from-end :start start :end end :key key
+ :test test :test-not test-not))
+(defun position (item sequence &key from-end (start 0) end key test test-not)
+ (position item sequence :from-end from-end :start start :end end :key key
+ :test test :test-not test-not))
+
+;;; the user interface to FIND-IF and POSITION-IF, entirely analogous
+;;; to the interface to FIND and POSITION
+(defun find-if (predicate sequence &key from-end (start 0) end key)
+ (find-if predicate sequence :from-end from-end :start start
+ :end end :key key))
+(defun position-if (predicate sequence &key from-end (start 0) end key)
+ (position-if predicate sequence :from-end from-end :start start
+ :end end :key key))
+
+(defun find-if-not (predicate sequence &key from-end (start 0) end key)
+ (find-if-not predicate sequence :from-end from-end :start start
+ :end end :key key))
+(defun position-if-not (predicate sequence &key from-end (start 0) end key)
+ (position-if-not predicate sequence :from-end from-end :start start
+ :end end :key key))