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

Last change on this file since 9266 was 8517, checked in by piso, 16 years ago

Work in progress.

File size: 7.8 KB
Line 
1;;; find.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: find.lisp,v 1.10 2005-02-10 01:49: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 (the fixnum (+ 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  (declare (type fixnum start))
139  (let ((end (or end (length sequence))))
140    (declare (type fixnum end))
141    (list-position item sequence)))
142
143(defun vector-position* (item sequence from-end test test-not start end key)
144  (declare (type fixnum start))
145  (let ((end (or end (length sequence))))
146    (declare (type fixnum end))
147    (vector-position item sequence)))
148
149(defmacro vector-position-if (test sequence)
150  `(vector-locater-if ,test ,sequence :position))
151
152(defmacro list-position-if (test sequence)
153  `(list-locater-if ,test ,sequence :position))
154
155(defun position-if (test sequence &key from-end (start 0) key end)
156  (declare (type fixnum start))
157  (let ((end (or end (length sequence))))
158    (declare (type fixnum end))
159    (if (listp sequence)
160        (list-position-if test sequence)
161        (vector-position-if test sequence))))
162
163(defmacro vector-position-if-not (test sequence)
164  `(vector-locater-if-not ,test ,sequence :position))
165
166(defmacro list-position-if-not (test sequence)
167  `(list-locater-if-not ,test ,sequence :position))
168
169(defun position-if-not (test sequence &key from-end (start 0) key end)
170  (declare (type fixnum start))
171  (let ((end (or end (length sequence))))
172    (declare (type fixnum end))
173    (if (listp sequence)
174        (list-position-if-not test sequence)
175        (vector-position-if-not test sequence))))
176
177(defmacro vector-find (item sequence)
178  `(vector-locater ,item ,sequence :element))
179
180(defmacro list-find (item sequence)
181  `(list-locater ,item ,sequence :element))
182
183(defun find (item sequence &key from-end (test #'eql) test-not (start 0)
184                  end key)
185  (if (listp sequence)
186      (list-find* item sequence from-end test test-not start end key)
187      (vector-find* item sequence from-end test test-not start end key)))
188
189(defun list-find* (item sequence from-end test test-not start end key)
190  (let ((end (or end (length sequence))))
191    (declare (type fixnum end))
192    (list-find item sequence)))
193
194(defun vector-find* (item sequence from-end test test-not start end key)
195  (let ((end (or end (length sequence))))
196    (declare (type fixnum end))
197    (vector-find item sequence)))
198
199(defmacro vector-find-if (test sequence)
200  `(vector-locater-if ,test ,sequence :element))
201
202(defmacro list-find-if (test sequence)
203  `(list-locater-if ,test ,sequence :element))
204
205(defun find-if (test sequence &key from-end (start 0) end key)
206  (let ((end (or end (length sequence))))
207    (declare (type fixnum end))
208    (if (listp sequence)
209        (list-find-if test sequence)
210        (vector-find-if test sequence))))
211
212(defmacro vector-find-if-not (test sequence)
213  `(vector-locater-if-not ,test ,sequence :element))
214
215(defmacro list-find-if-not (test sequence)
216  `(list-locater-if-not ,test ,sequence :element))
217
218(defun find-if-not (test sequence &key from-end (start 0) end key)
219  (let ((end (or end (length sequence))))
220    (declare (type fixnum end))
221    (if (listp sequence)
222        (list-find-if-not test sequence)
223        (vector-find-if-not test sequence))))
Note: See TracBrowser for help on using the repository browser.