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

Last change on this file since 4996 was 4996, checked in by piso, 18 years ago

SIMPLE-SEARCH

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