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

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

EVAL-WHEN

File size: 4.0 KB
Line 
1;;; search.lisp
2;;;
3;;; Copyright (C) 2003-2004 Peter Graves
4;;; $Id: search.lisp,v 1.22 2004-03-28 17:45:14 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(eval-when (:compile-toplevel :execute)
25
26  (defmacro compare-elements (elt1 elt2)
27    `(if test-not
28         (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
29             (return nil)
30             t)
31         (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2)))
32             (return nil)
33             t)))
34
35
36  (defmacro search-compare-list-list (main sub)
37    `(do ((main ,main (cdr main))
38          (jndex start1 (1+ jndex))
39          (sub (nthcdr start1 ,sub) (cdr sub)))
40         ((or (null main) (null sub) (= end1 jndex))
41          t)
42       (compare-elements (car sub) (car main))))
43
44
45  (defmacro search-compare-list-vector (main sub)
46    `(do ((main ,main (cdr main))
47          (index start1 (1+ index)))
48         ((or (null main) (= index end1)) t)
49       (compare-elements (aref ,sub index) (car main))))
50
51
52  (defmacro search-compare-vector-list (main sub index)
53    `(do ((sub (nthcdr start1 ,sub) (cdr sub))
54          (jndex start1 (1+ jndex))
55          (index ,index (1+ index)))
56         ((or (= end1 jndex) (null sub)) t)
57       (compare-elements (car sub) (aref ,main index))))
58
59
60  (defmacro search-compare-vector-vector (main sub index)
61    `(do ((index ,index (1+ index))
62          (sub-index start1 (1+ sub-index)))
63         ((= sub-index end1) t)
64       (compare-elements (aref ,sub sub-index) (aref ,main index))))
65
66
67  (defmacro search-compare (main-type main sub index)
68    (if (eq main-type 'list)
69        `(if (listp ,sub)
70             (search-compare-list-list ,main ,sub)
71             (search-compare-list-vector ,main ,sub))
72        `(if (listp ,sub)
73             (search-compare-vector-list ,main ,sub ,index)
74             (search-compare-vector-vector ,main ,sub ,index))))
75
76
77  (defmacro list-search (main sub)
78    `(do ((main (nthcdr start2 ,main) (cdr main))
79          (index2 start2 (1+ index2))
80          (terminus (- end2 (- end1 start1)))
81          (last-match ()))
82         ((> index2 terminus) last-match)
83       (if (search-compare list main ,sub index2)
84           (if from-end
85               (setq last-match index2)
86               (return index2)))))
87
88
89  (defmacro vector-search (main sub)
90    `(do ((index2 start2 (1+ index2))
91          (terminus (- end2 (- end1 start1)))
92          (last-match ()))
93         ((> index2 terminus) last-match)
94       (if (search-compare vector ,main ,sub index2)
95           (if from-end
96               (setq last-match index2)
97               (return index2)))))
98
99  ) ; eval-when
100
101(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not
102                         (start1 0) end1 (start2 0) end2 key)
103  (let ((end1 (or end1 (length sequence1)))
104  (end2 (or end2 (length sequence2))))
105    (when key
106      (setq key (coerce-to-function key)))
107    (if (listp sequence2)
108        (list-search sequence2 sequence1)
109        (vector-search sequence2 sequence1))))
110
111(defun simple-search (sequence1 sequence2)
112  (cond ((and (stringp sequence1) (stringp sequence2))
113         (simple-string-search sequence1 sequence2))
114        ((vectorp sequence2)
115         (simple-vector-search sequence1 sequence2))
116        (t
117         (search sequence1 sequence2 :from-end nil))))
Note: See TracBrowser for help on using the repository browser.