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

Last change on this file since 12516 was 12516, checked in by astalla, 11 years ago

Support for user-extensible sequences, adapted from SBCL.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 9.1 KB
Line 
1;;; find.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: find.lisp 12516 2010-03-03 21:05:41Z astalla $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package #:system)
33
34(require "EXTENSIBLE-SEQUENCES-BASE")
35
36;;; From CMUCL.
37
38(defmacro vector-locater-macro (sequence body-form return-type)
39  `(let ((incrementer (if from-end -1 1))
40   (start (if from-end (1- (the fixnum end)) start))
41   (end (if from-end (1- (the fixnum start)) end)))
42     (declare (fixnum start end incrementer))
43     (do ((index start (+ index incrementer))
44    ,@(case return-type (:position nil) (:element '(current))))
45   ((= index end) ())
46       (declare (fixnum index))
47       ,@(case return-type
48     (:position nil)
49     (:element `((setf current (aref ,sequence index)))))
50       ,body-form)))
51
52(defmacro locater-test-not (item sequence seq-type return-type)
53  (let ((seq-ref (case return-type
54       (:position
55        (case seq-type
56          (:vector `(aref ,sequence index))
57          (:list `(pop ,sequence))))
58       (:element 'current)))
59  (return (case return-type
60      (:position 'index)
61      (:element 'current))))
62    `(if test-not
63   (if (not (funcall test-not ,item (sys::apply-key key ,seq-ref)))
64       (return ,return))
65   (if (funcall test ,item (sys::apply-key key ,seq-ref))
66       (return ,return)))))
67
68(defmacro vector-locater (item sequence return-type)
69  `(vector-locater-macro ,sequence
70       (locater-test-not ,item ,sequence :vector ,return-type)
71       ,return-type))
72
73(defmacro locater-if-test (test sequence seq-type return-type sense)
74  (let ((seq-ref (case return-type
75       (:position
76        (case seq-type
77          (:vector `(aref ,sequence index))
78          (:list `(pop ,sequence))))
79       (:element 'current)))
80  (return (case return-type
81      (:position 'index)
82      (:element 'current))))
83    (if sense
84  `(if (funcall ,test (sys::apply-key key ,seq-ref))
85       (return ,return))
86  `(if (not (funcall ,test (sys::apply-key key ,seq-ref)))
87       (return ,return)))))
88
89(defmacro vector-locater-if-macro (test sequence return-type sense)
90  `(vector-locater-macro ,sequence
91       (locater-if-test ,test ,sequence :vector ,return-type ,sense)
92       ,return-type))
93
94(defmacro vector-locater-if (test sequence return-type)
95  `(vector-locater-if-macro ,test ,sequence ,return-type t))
96
97(defmacro vector-locater-if-not (test sequence return-type)
98  `(vector-locater-if-macro ,test ,sequence ,return-type nil))
99
100(defmacro list-locater-macro (sequence body-form return-type)
101  `(if from-end
102       (do ((sequence (nthcdr (- (the fixnum (length sequence))
103         (the fixnum end))
104            (reverse (the list ,sequence))))
105      (index (1- (the fixnum end)) (1- index))
106      (terminus (1- (the fixnum start)))
107      ,@(case return-type (:position nil) (:element '(current))))
108     ((or (= index terminus) (null sequence)) ())
109   (declare (fixnum index terminus))
110   ,@(case return-type
111       (:position nil)
112       (:element `((setf current (pop ,sequence)))))
113   ,body-form)
114       (do ((sequence (nthcdr start ,sequence))
115      (index start (1+ index))
116      ,@(case return-type (:position nil) (:element '(current))))
117     ((or (= index (the fixnum end)) (null sequence)) ())
118   (declare (fixnum index))
119   ,@(case return-type
120       (:position nil)
121       (:element `((setf current (pop ,sequence)))))
122   ,body-form)))
123
124(defmacro list-locater (item sequence return-type)
125  `(list-locater-macro ,sequence
126           (locater-test-not ,item ,sequence :list ,return-type)
127           ,return-type))
128
129(defmacro list-locater-if-macro (test sequence return-type sense)
130  `(list-locater-macro ,sequence
131           (locater-if-test ,test ,sequence :list ,return-type ,sense)
132           ,return-type))
133
134(defmacro list-locater-if (test sequence return-type)
135  `(list-locater-if-macro ,test ,sequence ,return-type t))
136
137(defmacro list-locater-if-not (test sequence return-type)
138  `(list-locater-if-macro ,test ,sequence ,return-type nil))
139
140(defmacro vector-position (item sequence)
141  `(vector-locater ,item ,sequence :position))
142
143(defmacro list-position (item sequence)
144  `(list-locater ,item ,sequence :position))
145
146
147(defun position (item sequence &rest args &key from-end (test #'eql) test-not
148     (start 0) end key)
149  (sequence::seq-dispatch sequence
150    (list-position* item sequence from-end test test-not start end key)
151    (vector-position* item sequence from-end test test-not start end key)
152    (apply #'sequence:position item sequence args)))
153
154(defun list-position* (item sequence from-end test test-not start end key)
155  (declare (type fixnum start))
156  (let ((end (or end (length sequence))))
157    (declare (type fixnum end))
158    (list-position item sequence)))
159
160(defun vector-position* (item sequence from-end test test-not start end key)
161  (declare (type fixnum start))
162  (let ((end (or end (length sequence))))
163    (declare (type fixnum end))
164    (vector-position item sequence)))
165
166(defmacro vector-position-if (test sequence)
167  `(vector-locater-if ,test ,sequence :position))
168
169(defmacro list-position-if (test sequence)
170  `(list-locater-if ,test ,sequence :position))
171
172(defun position-if (test sequence &rest args &key from-end (start 0) key end)
173  (declare (type fixnum start))
174  (let ((end (or end (length sequence))))
175    (declare (type fixnum end))
176    (sequence::seq-dispatch sequence
177      (list-position-if test sequence)
178      (vector-position-if test sequence)
179      (apply #'sequence:position-if test sequence args))))
180
181(defmacro vector-position-if-not (test sequence)
182  `(vector-locater-if-not ,test ,sequence :position))
183
184(defmacro list-position-if-not (test sequence)
185  `(list-locater-if-not ,test ,sequence :position))
186
187(defun position-if-not (test sequence &rest args &key from-end (start 0) key end)
188  (declare (type fixnum start))
189  (let ((end (or end (length sequence))))
190    (declare (type fixnum end))
191    (sequence::seq-dispatch sequence
192      (list-position-if-not test sequence)
193      (vector-position-if-not test sequence)
194      (apply #'sequence:position-if-not test sequence args))))
195
196(defmacro vector-find (item sequence)
197  `(vector-locater ,item ,sequence :element))
198
199(defmacro list-find (item sequence)
200  `(list-locater ,item ,sequence :element))
201
202(defun list-find* (item sequence from-end test test-not start end key)
203  (declare (type fixnum start end))
204  (unless (or test test-not)
205    (setf test 'eql))
206  (list-find item sequence))
207
208(defun vector-find* (item sequence from-end test test-not start end key)
209  (declare (type fixnum start end))
210  (unless (or test test-not)
211    (setf test 'eql))
212  (vector-find item sequence))
213
214(defun find (item sequence &rest args &key from-end (test #'eql) test-not
215       (start 0) end key)
216  (let ((end (check-sequence-bounds sequence start end)))
217    (sequence::seq-dispatch sequence
218      (list-find* item sequence from-end test test-not start end key)
219      (vector-find* item sequence from-end test test-not start end key)
220      (apply #'sequence:find item sequence args))))
221
222(defmacro vector-find-if (test sequence)
223  `(vector-locater-if ,test ,sequence :element))
224
225(defmacro list-find-if (test sequence)
226  `(list-locater-if ,test ,sequence :element))
227
228(defun find-if (test sequence &rest args &key from-end (start 0) end key)
229  (let ((end (or end (length sequence))))
230    (declare (type fixnum end))
231    (sequence::seq-dispatch sequence
232      (list-find-if test sequence)
233      (vector-find-if test sequence)
234      (apply #'sequence:find-if test sequence args))))
235
236(defmacro vector-find-if-not (test sequence)
237  `(vector-locater-if-not ,test ,sequence :element))
238
239(defmacro list-find-if-not (test sequence)
240  `(list-locater-if-not ,test ,sequence :element))
241
242(defun find-if-not (test sequence &rest args &key from-end (start 0) end key)
243  (let ((end (or end (length sequence))))
244    (declare (type fixnum end))
245    (sequence::seq-dispatch sequence
246      (list-find-if-not test sequence)
247      (vector-find-if-not test sequence)
248      (apply #'sequence:find-if-not test sequence args))))
Note: See TracBrowser for help on using the repository browser.