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

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

EVAL-WHEN

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