source: trunk/abcl/src/org/armedbear/lisp/find.lisp

;;; find.lisp
;;;
;;; Copyright (C) 2003-2005 Peter Graves
;;; $Id: find.lisp 15569 2022-03-19 12:50:18Z mevenson $
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module.  An independent module is a module which is not derived from
;;; or based on this library.  If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so.  If you do not wish to do so, delete this
;;; exception statement from your version.

(in-package #:system)

(require "EXTENSIBLE-SEQUENCES-BASE")

;;; From CMUCL.

(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)))

(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 (sys::apply-key key ,seq-ref)))
             (return ,return))
         (if (funcall test ,item (sys::apply-key key ,seq-ref))
             (return ,return)))))

(defmacro vector-locater (item sequence return-type)
  `(vector-locater-macro ,sequence
                         (locater-test-not ,item ,sequence :vector ,return-type)
                         ,return-type))

(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 (sys::apply-key key ,seq-ref))
             (return ,return))
        `(if (not (funcall ,test (sys::apply-key key ,seq-ref)))
             (return ,return)))))

(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))

(defmacro vector-locater-if (test sequence return-type)
  `(vector-locater-if-macro ,test ,sequence ,return-type t))

(defmacro vector-locater-if-not (test sequence return-type)
  `(vector-locater-if-macro ,test ,sequence ,return-type nil))

(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)))

(defmacro list-locater (item sequence return-type)
  `(list-locater-macro ,sequence
                       (locater-test-not ,item ,sequence :list ,return-type)
                       ,return-type))

(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))

(defmacro list-locater-if (test sequence return-type)
  `(list-locater-if-macro ,test ,sequence ,return-type t))

(defmacro list-locater-if-not (test sequence return-type)
  `(list-locater-if-macro ,test ,sequence ,return-type nil))

(defmacro vector-position (item sequence)
  `(vector-locater ,item ,sequence :position))

(defmacro list-position (item sequence)
  `(list-locater ,item ,sequence :position))


(defun position (item sequence &rest args &key from-end (test #'eql) test-not
                 (start 0) end key)
  (sequence::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)
    (apply #'sequence:position item sequence args)))

(defun list-position* (item sequence from-end test test-not start end key)
  (declare (type fixnum start))
  (let ((end (or end (length sequence))))
    (declare (type fixnum end))
    (list-position item sequence)))

(defun vector-position* (item sequence from-end test test-not start end key)
  (declare (type fixnum start))
  (let ((end (or end (length sequence))))
    (declare (type fixnum end))
    (vector-position item sequence)))

(defmacro vector-position-if (test sequence)
  `(vector-locater-if ,test ,sequence :position))

(defmacro list-position-if (test sequence)
  `(list-locater-if ,test ,sequence :position))

(defun position-if (test sequence &rest args &key from-end (start 0) key end)
  (declare (type fixnum start))
  (let ((end (or end (length sequence))))
    (declare (type fixnum end))
    (sequence::seq-dispatch sequence
      (list-position-if test sequence)
      (vector-position-if test sequence)
      (apply #'sequence:position-if test sequence args))))

(defmacro vector-position-if-not (test sequence)
  `(vector-locater-if-not ,test ,sequence :position))

(defmacro list-position-if-not (test sequence)
  `(list-locater-if-not ,test ,sequence :position))

(defun position-if-not (test sequence &rest args &key from-end (start 0) key end)
  (declare (type fixnum start))
  (let ((end (or end (length sequence))))
    (declare (type fixnum end))
    (sequence::seq-dispatch sequence
      (list-position-if-not test sequence)
      (vector-position-if-not test sequence)
      (apply #'sequence:position-if-not test sequence args))))

(defmacro vector-find (item sequence)
  `(vector-locater ,item ,sequence :element))

(defmacro list-find (item sequence)
  `(list-locater ,item ,sequence :element))

(defun list-find* (item sequence from-end test test-not start end key)
  (declare (type fixnum start end))
  (unless (or test test-not)
    (setf test 'eql))
  (list-find item sequence))

(defun vector-find* (item sequence from-end test test-not start end key)
  (declare (type fixnum start end))
  (unless (or test test-not)
    (setf test 'eql))
  (vector-find item sequence))

(defun find (item sequence &rest args &key from-end (test #'eql) test-not
             (start 0) end key)
  (let ((end (check-sequence-bounds sequence start end)))
    (sequence::seq-dispatch sequence
      (list-find* item sequence from-end test test-not start end key)
      (vector-find* item sequence from-end test test-not start end key)
      (apply #'sequence:find item sequence args))))

(defmacro vector-find-if (test sequence)
  `(vector-locater-if ,test ,sequence :element))

(defmacro list-find-if (test sequence)
  `(list-locater-if ,test ,sequence :element))

(defun find-if (test sequence &rest args &key from-end (start 0) end key)
  (let ((end (or end (length sequence))))
    (declare (type fixnum end))
    (sequence::seq-dispatch sequence
      (list-find-if test sequence)
      (vector-find-if test sequence)
      (apply #'sequence:find-if test sequence args))))

(defmacro vector-find-if-not (test sequence)
  `(vector-locater-if-not ,test ,sequence :element))

(defmacro list-find-if-not (test sequence)
  `(list-locater-if-not ,test ,sequence :element))

(defun find-if-not (test sequence &rest args &key from-end (start 0) end key)
  (let ((end (or end (length sequence))))
    (declare (type fixnum end))
    (sequence::seq-dispatch sequence
      (list-find-if-not test sequence)
      (vector-find-if-not test sequence)
      (apply #'sequence:find-if-not test sequence args))))