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

Last change on this file since 11457 was 11391, checked in by vvoutilainen, 12 years ago

ABCL license is GPL + Classpath exception. This was intended
by Peter Graves, the original author. For reference, see
http://sourceforge.net/mailarchive/forum.php?thread_name=20040721115302.839%40prufrock&forum_name=armedbear-j-announce

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 8.7 KB
Line 
1;;; find.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: find.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $
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;;; From CMUCL.
35
36(defmacro vector-locater-macro (sequence body-form return-type)
37  `(let ((incrementer (if from-end -1 1))
38   (start (if from-end (1- (the fixnum end)) start))
39   (end (if from-end (1- (the fixnum start)) end)))
40     (declare (fixnum start end incrementer))
41     (do ((index start (+ index incrementer))
42    ,@(case return-type (:position nil) (:element '(current))))
43   ((= index end) ())
44       (declare (fixnum index))
45       ,@(case return-type
46     (:position nil)
47     (:element `((setf current (aref ,sequence index)))))
48       ,body-form)))
49
50(defmacro locater-test-not (item sequence seq-type return-type)
51  (let ((seq-ref (case return-type
52       (:position
53        (case seq-type
54          (:vector `(aref ,sequence index))
55          (:list `(pop ,sequence))))
56       (:element 'current)))
57  (return (case return-type
58      (:position 'index)
59      (:element 'current))))
60    `(if test-not
61   (if (not (funcall test-not ,item (sys::apply-key key ,seq-ref)))
62       (return ,return))
63   (if (funcall test ,item (sys::apply-key key ,seq-ref))
64       (return ,return)))))
65
66(defmacro vector-locater (item sequence return-type)
67  `(vector-locater-macro ,sequence
68       (locater-test-not ,item ,sequence :vector ,return-type)
69       ,return-type))
70
71(defmacro locater-if-test (test sequence seq-type return-type sense)
72  (let ((seq-ref (case return-type
73       (:position
74        (case seq-type
75          (:vector `(aref ,sequence index))
76          (:list `(pop ,sequence))))
77       (:element 'current)))
78  (return (case return-type
79      (:position 'index)
80      (:element 'current))))
81    (if sense
82  `(if (funcall ,test (sys::apply-key key ,seq-ref))
83       (return ,return))
84  `(if (not (funcall ,test (sys::apply-key key ,seq-ref)))
85       (return ,return)))))
86
87(defmacro vector-locater-if-macro (test sequence return-type sense)
88  `(vector-locater-macro ,sequence
89       (locater-if-test ,test ,sequence :vector ,return-type ,sense)
90       ,return-type))
91
92(defmacro vector-locater-if (test sequence return-type)
93  `(vector-locater-if-macro ,test ,sequence ,return-type t))
94
95(defmacro vector-locater-if-not (test sequence return-type)
96  `(vector-locater-if-macro ,test ,sequence ,return-type nil))
97
98(defmacro list-locater-macro (sequence body-form return-type)
99  `(if from-end
100       (do ((sequence (nthcdr (- (the fixnum (length sequence))
101         (the fixnum end))
102            (reverse (the list ,sequence))))
103      (index (1- (the fixnum end)) (1- index))
104      (terminus (1- (the fixnum start)))
105      ,@(case return-type (:position nil) (:element '(current))))
106     ((or (= index terminus) (null sequence)) ())
107   (declare (fixnum index terminus))
108   ,@(case return-type
109       (:position nil)
110       (:element `((setf current (pop ,sequence)))))
111   ,body-form)
112       (do ((sequence (nthcdr start ,sequence))
113      (index start (1+ index))
114      ,@(case return-type (:position nil) (:element '(current))))
115     ((or (= index (the fixnum end)) (null sequence)) ())
116   (declare (fixnum index))
117   ,@(case return-type
118       (:position nil)
119       (:element `((setf current (pop ,sequence)))))
120   ,body-form)))
121
122(defmacro list-locater (item sequence return-type)
123  `(list-locater-macro ,sequence
124           (locater-test-not ,item ,sequence :list ,return-type)
125           ,return-type))
126
127(defmacro list-locater-if-macro (test sequence return-type sense)
128  `(list-locater-macro ,sequence
129           (locater-if-test ,test ,sequence :list ,return-type ,sense)
130           ,return-type))
131
132(defmacro list-locater-if (test sequence return-type)
133  `(list-locater-if-macro ,test ,sequence ,return-type t))
134
135(defmacro list-locater-if-not (test sequence return-type)
136  `(list-locater-if-macro ,test ,sequence ,return-type nil))
137
138(defmacro vector-position (item sequence)
139  `(vector-locater ,item ,sequence :position))
140
141(defmacro list-position (item sequence)
142  `(list-locater ,item ,sequence :position))
143
144
145(defun position (item sequence &key from-end (test #'eql) test-not (start 0)
146                      end key)
147  (if (listp sequence)
148      (list-position* item sequence from-end test test-not start end key)
149      (vector-position* item sequence from-end test test-not start end key)))
150
151
152(defun list-position* (item sequence from-end test test-not start end key)
153  (declare (type fixnum start))
154  (let ((end (or end (length sequence))))
155    (declare (type fixnum end))
156    (list-position item sequence)))
157
158(defun vector-position* (item sequence from-end test test-not start end key)
159  (declare (type fixnum start))
160  (let ((end (or end (length sequence))))
161    (declare (type fixnum end))
162    (vector-position item sequence)))
163
164(defmacro vector-position-if (test sequence)
165  `(vector-locater-if ,test ,sequence :position))
166
167(defmacro list-position-if (test sequence)
168  `(list-locater-if ,test ,sequence :position))
169
170(defun position-if (test sequence &key from-end (start 0) key end)
171  (declare (type fixnum start))
172  (let ((end (or end (length sequence))))
173    (declare (type fixnum end))
174    (if (listp sequence)
175        (list-position-if test sequence)
176        (vector-position-if test sequence))))
177
178(defmacro vector-position-if-not (test sequence)
179  `(vector-locater-if-not ,test ,sequence :position))
180
181(defmacro list-position-if-not (test sequence)
182  `(list-locater-if-not ,test ,sequence :position))
183
184(defun position-if-not (test sequence &key from-end (start 0) key end)
185  (declare (type fixnum start))
186  (let ((end (or end (length sequence))))
187    (declare (type fixnum end))
188    (if (listp sequence)
189        (list-position-if-not test sequence)
190        (vector-position-if-not test sequence))))
191
192(defmacro vector-find (item sequence)
193  `(vector-locater ,item ,sequence :element))
194
195(defmacro list-find (item sequence)
196  `(list-locater ,item ,sequence :element))
197
198(defun list-find* (item sequence from-end test test-not start end key)
199  (declare (type fixnum start end))
200  (unless (or test test-not)
201    (setf test 'eql))
202  (list-find item sequence))
203
204(defun vector-find* (item sequence from-end test test-not start end key)
205  (declare (type fixnum start end))
206  (unless (or test test-not)
207    (setf test 'eql))
208  (vector-find item sequence))
209
210(defun find (item sequence &key from-end (test #'eql) test-not (start 0)
211                  end key)
212  (let ((end (check-sequence-bounds sequence start end)))
213    (if (listp sequence)
214        (list-find* item sequence from-end test test-not start end key)
215        (vector-find* item sequence from-end test test-not start end key))))
216
217(defmacro vector-find-if (test sequence)
218  `(vector-locater-if ,test ,sequence :element))
219
220(defmacro list-find-if (test sequence)
221  `(list-locater-if ,test ,sequence :element))
222
223(defun find-if (test sequence &key from-end (start 0) end key)
224  (let ((end (or end (length sequence))))
225    (declare (type fixnum end))
226    (if (listp sequence)
227        (list-find-if test sequence)
228        (vector-find-if test sequence))))
229
230(defmacro vector-find-if-not (test sequence)
231  `(vector-locater-if-not ,test ,sequence :element))
232
233(defmacro list-find-if-not (test sequence)
234  `(list-locater-if-not ,test ,sequence :element))
235
236(defun find-if-not (test sequence &key from-end (start 0) end key)
237  (let ((end (or end (length sequence))))
238    (declare (type fixnum end))
239    (if (listp sequence)
240        (list-find-if-not test sequence)
241        (vector-find-if-not test sequence))))
Note: See TracBrowser for help on using the repository browser.