source: trunk/abcl/src/org/armedbear/lisp/search.lisp @ 14207

Last change on this file since 14207 was 14121, checked in by ehuelsmann, 9 years ago

Move exports from autoloads.lisp to the respective defining files.
Also, delete JVM-COMPILE-PACKAGE, which hasn't been used in our
sources for ages and doesn't seem to serve an external purpose.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 4.8 KB
Line 
1;;; search.lisp
2;;;
3;;; Copyright (C) 2003-2004 Peter Graves
4;;; $Id: search.lisp 14121 2012-08-18 11:37:34Z ehuelsmann $
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;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "SYSTEM")
33
34(require "EXTENSIBLE-SEQUENCES-BASE")
35
36(export '(simple-search))
37
38
39;; From CMUCL.
40
41(eval-when (:compile-toplevel :execute)
42
43  (defmacro compare-elements (elt1 elt2)
44    `(if test-not
45         (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
46             (return nil)
47             t)
48         (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2)))
49             (return nil)
50             t)))
51
52
53  (defmacro search-compare-list-list (main sub)
54    `(do ((main ,main (cdr main))
55          (jndex start1 (1+ jndex))
56          (sub (nthcdr start1 ,sub) (cdr sub)))
57         ((or (null main) (null sub) (= end1 jndex))
58          t)
59       (compare-elements (car sub) (car main))))
60
61
62  (defmacro search-compare-list-vector (main sub)
63    `(do ((main ,main (cdr main))
64          (index start1 (1+ index)))
65         ((or (null main) (= index end1)) t)
66       (compare-elements (aref ,sub index) (car main))))
67
68
69  (defmacro search-compare-vector-list (main sub index)
70    `(do ((sub (nthcdr start1 ,sub) (cdr sub))
71          (jndex start1 (1+ jndex))
72          (index ,index (1+ index)))
73         ((or (= end1 jndex) (null sub)) t)
74       (compare-elements (car sub) (aref ,main index))))
75
76
77  (defmacro search-compare-vector-vector (main sub index)
78    `(do ((index ,index (1+ index))
79          (sub-index start1 (1+ sub-index)))
80         ((= sub-index end1) t)
81       (compare-elements (aref ,sub sub-index) (aref ,main index))))
82
83
84  (defmacro search-compare (main-type main sub index)
85    (if (eq main-type 'list)
86        `(if (listp ,sub)
87             (search-compare-list-list ,main ,sub)
88             (search-compare-list-vector ,main ,sub))
89        `(if (listp ,sub)
90             (search-compare-vector-list ,main ,sub ,index)
91             (search-compare-vector-vector ,main ,sub ,index))))
92
93
94  (defmacro list-search (main sub)
95    `(do ((main (nthcdr start2 ,main) (cdr main))
96          (index2 start2 (1+ index2))
97          (terminus (- end2 (- end1 start1)))
98          (last-match ()))
99         ((> index2 terminus) last-match)
100       (if (search-compare list main ,sub index2)
101           (if from-end
102               (setq last-match index2)
103               (return index2)))))
104
105
106  (defmacro vector-search (main sub)
107    `(do ((index2 start2 (1+ index2))
108          (terminus (- end2 (- end1 start1)))
109          (last-match ()))
110         ((> index2 terminus) last-match)
111       (if (search-compare vector ,main ,sub index2)
112           (if from-end
113               (setq last-match index2)
114               (return index2)))))
115
116  ) ; eval-when
117
118(defun search (sequence1 sequence2 &rest args &key from-end (test #'eql)
119         test-not (start1 0) end1 (start2 0) end2 key)
120  (let ((end1 (or end1 (length sequence1)))
121  (end2 (or end2 (length sequence2))))
122    (when key
123      (setq key (coerce-to-function key)))
124    (sequence::seq-dispatch sequence2
125      (list-search sequence2 sequence1)
126      (vector-search sequence2 sequence1)
127      (apply #'sequence:search sequence1 sequence2 args))))
128
129(defun simple-search (sequence1 sequence2)
130  (cond ((and (stringp sequence1) (stringp sequence2))
131         (simple-string-search sequence1 sequence2))
132        ((vectorp sequence2)
133         (simple-vector-search sequence1 sequence2))
134        (t
135         (search sequence1 sequence2 :from-end nil))))
Note: See TracBrowser for help on using the repository browser.