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

Last change on this file since 12516 was 12516, checked in by astalla, 11 years ago

Support for user-extensible sequences, adapted from SBCL.

  • 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 12516 2010-03-03 21:05:41Z astalla $
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;; From CMUCL.
37
38(eval-when (:compile-toplevel :execute)
39
40  (defmacro compare-elements (elt1 elt2)
41    `(if test-not
42         (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
43             (return nil)
44             t)
45         (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2)))
46             (return nil)
47             t)))
48
49
50  (defmacro search-compare-list-list (main sub)
51    `(do ((main ,main (cdr main))
52          (jndex start1 (1+ jndex))
53          (sub (nthcdr start1 ,sub) (cdr sub)))
54         ((or (null main) (null sub) (= end1 jndex))
55          t)
56       (compare-elements (car sub) (car main))))
57
58
59  (defmacro search-compare-list-vector (main sub)
60    `(do ((main ,main (cdr main))
61          (index start1 (1+ index)))
62         ((or (null main) (= index end1)) t)
63       (compare-elements (aref ,sub index) (car main))))
64
65
66  (defmacro search-compare-vector-list (main sub index)
67    `(do ((sub (nthcdr start1 ,sub) (cdr sub))
68          (jndex start1 (1+ jndex))
69          (index ,index (1+ index)))
70         ((or (= end1 jndex) (null sub)) t)
71       (compare-elements (car sub) (aref ,main index))))
72
73
74  (defmacro search-compare-vector-vector (main sub index)
75    `(do ((index ,index (1+ index))
76          (sub-index start1 (1+ sub-index)))
77         ((= sub-index end1) t)
78       (compare-elements (aref ,sub sub-index) (aref ,main index))))
79
80
81  (defmacro search-compare (main-type main sub index)
82    (if (eq main-type 'list)
83        `(if (listp ,sub)
84             (search-compare-list-list ,main ,sub)
85             (search-compare-list-vector ,main ,sub))
86        `(if (listp ,sub)
87             (search-compare-vector-list ,main ,sub ,index)
88             (search-compare-vector-vector ,main ,sub ,index))))
89
90
91  (defmacro list-search (main sub)
92    `(do ((main (nthcdr start2 ,main) (cdr main))
93          (index2 start2 (1+ index2))
94          (terminus (- end2 (- end1 start1)))
95          (last-match ()))
96         ((> index2 terminus) last-match)
97       (if (search-compare list main ,sub index2)
98           (if from-end
99               (setq last-match index2)
100               (return index2)))))
101
102
103  (defmacro vector-search (main sub)
104    `(do ((index2 start2 (1+ index2))
105          (terminus (- end2 (- end1 start1)))
106          (last-match ()))
107         ((> index2 terminus) last-match)
108       (if (search-compare vector ,main ,sub index2)
109           (if from-end
110               (setq last-match index2)
111               (return index2)))))
112
113  ) ; eval-when
114
115(defun search (sequence1 sequence2 &rest args &key from-end (test #'eql)
116         test-not (start1 0) end1 (start2 0) end2 key)
117  (let ((end1 (or end1 (length sequence1)))
118  (end2 (or end2 (length sequence2))))
119    (when key
120      (setq key (coerce-to-function key)))
121    (sequence::seq-dispatch sequence2
122      (list-search sequence2 sequence1)
123      (vector-search sequence2 sequence1)
124      (apply #'sequence:search sequence1 sequence2 args))))
125
126(defun simple-search (sequence1 sequence2)
127  (cond ((and (stringp sequence1) (stringp sequence2))
128         (simple-string-search sequence1 sequence2))
129        ((vectorp sequence2)
130         (simple-vector-search sequence1 sequence2))
131        (t
132         (search sequence1 sequence2 :from-end nil))))
Note: See TracBrowser for help on using the repository browser.