• Home
• org.armedbear.lisp
• abcl
• 0.27.0
• source code
• find.lisp

×

Project download

Many resources are needed to download a project. Please understand that we have to compensate our server costs. Thank you in advance.
Project price only 1 $

You can buy this project and download/modify it how often you want.

org.armedbear.lisp.find.lisp Maven / Gradle / Ivy

;;; find.lisp
;;;
;;; Copyright (C) 2003-2005 Peter Graves
;;; $Id: find.lisp 12516 2010-03-03 21:05:41Z astalla $
;;;
;;; 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))))