source: trunk/j/src/org/armedbear/lisp/find.lisp @ 8509

Last change on this file since 8509 was 8509, checked in by piso, 17 years ago

Added some TYPE FIXNUM declarations.

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