/[cmucl]/src/hemlock/search2.lisp
ViewVC logotype

Contents of /src/hemlock/search2.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Tue Mar 13 15:49:59 2001 UTC (13 years, 1 month ago) by pw
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.3: +2 -2 lines
Change toplevel PROCLAIMs to DECLAIMs.
1 ;;; -*- Log: Hemlock.Log; Package: Hemlock-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/search2.lisp,v 1.4 2001/03/13 15:49:59 pw Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; More searching function for Hemlock. This file contains the stuff
13 ;;; to implement the various kinds of character searches.
14 ;;;
15 ;;; Written by Rob MacLachlan
16 ;;;
17
18 (in-package "HEMLOCK-INTERNALS")
19
20 ;;;; Character and Not-Character search kinds:
21
22 (eval-when (compile eval)
23 (defmacro forward-character-search-macro (string start length char test)
24 `(position ,char ,string :start ,start :end ,length :test ,test))
25
26 (defmacro backward-character-search-macro (string start char test)
27 `(position ,char ,string :end (1+ ,start) :test ,test :from-end t))
28
29 (defmacro define-character-search-method (name search macro test)
30 `(defun ,name (pattern line start)
31 (let ((char (search-pattern-pattern pattern)))
32 (when (,search line start ,macro char ,test)
33 (values line start 1)))))
34 ); eval-when (compile eval)
35
36 (define-character-search-method find-character-once-forward-method
37 search-once-forward-macro forward-character-search-macro #'char=)
38 (define-character-search-method find-not-character-once-forward-method
39 search-once-forward-macro forward-character-search-macro #'char/=)
40 (define-character-search-method find-character-once-backward-method
41 search-once-backward-macro backward-character-search-macro #'char=)
42 (define-character-search-method find-not-character-once-backward-method
43 search-once-backward-macro backward-character-search-macro #'char/=)
44
45 (define-search-kind :character (direction pattern old)
46 ":character - Pattern is a character to search for."
47 (unless old (setq old (internal-make-search-pattern)))
48 (setf (search-pattern-kind old) :character
49 (search-pattern-direction old) direction
50 (search-pattern-pattern old) pattern
51 (search-pattern-reclaim-function old) #'identity
52 (search-pattern-search-function old)
53 (if (eq direction :forward)
54 #'find-character-once-forward-method
55 #'find-character-once-backward-method))
56 old)
57
58 (define-search-kind :not-character (direction pattern old)
59 ":not-character - Find the first character which is not Char= to Pattern."
60 (unless old (setq old (internal-make-search-pattern)))
61 (setf (search-pattern-kind old) :not-character
62 (search-pattern-direction old) direction
63 (search-pattern-pattern old) pattern
64 (search-pattern-reclaim-function old) #'identity
65 (search-pattern-search-function old)
66 (if (eq direction :forward)
67 #'find-not-character-once-forward-method
68 #'find-not-character-once-backward-method))
69 old)
70
71 ;;;; Character set searching.
72 ;;;
73 ;;; These functions implement the :test, :test-not, :any and :not-any
74 ;;; search-kinds.
75
76 ;;; The Character-Set abstraction is used to hide somewhat the fact that
77 ;;; we are using %Sp-Find-Character-With-Attribute to implement the
78 ;;; character set searches.
79
80 (defvar *free-character-sets* ()
81 "A list of unused character-set objects for use by the Hemlock searching
82 primitives.")
83
84 ;;; Create-Character-Set -- Internal
85 ;;;
86 ;;; Create-Character-Set returns a character-set which will search
87 ;;; for no character.
88 ;;;
89 (defun create-character-set ()
90 (let ((set (or (pop *free-character-sets*)
91 (make-array 256 :element-type '(mod 256)))))
92 (declare (type (simple-array (mod 256)) set))
93 (dotimes (i search-char-code-limit)
94 (setf (aref set i) 0))
95 set))
96
97 ;;; Add-Character-To-Set -- Internal
98 ;;;
99 ;;; Modify the character-set Set to succeed for Character.
100 ;;;
101 (declaim (inline add-character-to-set))
102 (defun add-character-to-set (character set)
103 (setf (aref (the (simple-array (mod 256)) set)
104 (search-char-code character))
105 1))
106
107 ;;; Release-Character-Set -- Internal
108 ;;;
109 ;;; Release the storage for the character set Set.
110 ;;;
111 (defun release-character-set (set)
112 (push set *free-character-sets*))
113
114 (eval-when (compile eval)
115 ;;; Forward-Set-Search-Macro -- Internal
116 ;;;
117 ;;; Do a search for some character in Set in String starting at Start
118 ;;; and ending at End.
119 ;;;
120 (defmacro forward-set-search-macro (string start last set)
121 `(%sp-find-character-with-attribute ,string ,start ,last ,set 1))
122
123 ;;; Backward-Set-Search-Macro -- Internal
124 ;;;
125 ;;; Like forward-set-search-macro, only :from-end, and start is
126 ;;; implicitly 0.
127 ;;;
128 (defmacro backward-set-search-macro (string last set)
129 `(%sp-reverse-find-character-with-attribute ,string 0 (1+ ,last) ,set 1))
130 ); eval-when (compile eval)
131
132 (defstruct (set-search-pattern
133 (:include search-pattern)
134 (:print-function %print-search-pattern))
135 set)
136
137 (eval-when (compile eval)
138 (defmacro define-set-search-method (name search macro)
139 `(defun ,name (pattern line start)
140 (let ((set (set-search-pattern-set pattern)))
141 (when (,search line start ,macro set)
142 (values line start 1)))))
143 ); eval-when (compile eval)
144
145 (define-set-search-method find-set-once-forward-method
146 search-once-forward-macro forward-set-search-macro)
147
148 (define-set-search-method find-set-once-backward-method
149 search-once-backward-macro backward-set-search-macro)
150
151 (defun frob-character-set (pattern direction old kind)
152 (unless old (setq old (make-set-search-pattern)))
153 (setf (search-pattern-kind old) kind
154 (search-pattern-direction old) direction
155 (search-pattern-pattern old) pattern
156 (search-pattern-search-function old)
157 (if (eq direction :forward)
158 #'find-set-once-forward-method
159 #'find-set-once-backward-method)
160 (search-pattern-reclaim-function old)
161 #'(lambda (x) (release-character-set (set-search-pattern-set x))))
162 old)
163
164 (define-search-kind :test (direction pattern old)
165 ":test - Find the first character which satisfies the test function Pattern.
166 Pattern must be a function of its argument only."
167 (setq old (frob-character-set pattern direction old :test))
168 (let ((set (create-character-set)))
169 (dotimes (i search-char-code-limit)
170 (when (funcall pattern (code-char i))
171 (add-character-to-set (code-char i) set)))
172 (setf (set-search-pattern-set old) set))
173 old)
174
175 (define-search-kind :test-not (direction pattern old)
176 ":test-not - Find the first character which does not satisfy the
177 test function Pattern. Pattern must be a function of its argument only."
178 (setq old (frob-character-set pattern direction old :test-not))
179 (let ((set (create-character-set)))
180 (dotimes (i search-char-code-limit)
181 (unless (funcall pattern (code-char i))
182 (add-character-to-set (code-char i) set)))
183 (setf (set-search-pattern-set old) set))
184 old)
185
186 (define-search-kind :any (direction pattern old)
187 ":any - Find the first character which is the string Pattern."
188 (declare (string pattern))
189 (setq old (frob-character-set pattern direction old :any))
190 (let ((set (create-character-set)))
191 (dotimes (i (length pattern))
192 (add-character-to-set (char pattern i) set))
193 (setf (set-search-pattern-set old) set))
194 old)
195
196 (define-search-kind :not-any (direction pattern old)
197 ":not-any - Find the first character which is not in the string Pattern."
198 (declare (string pattern))
199 (setq old (frob-character-set pattern direction old :not-any))
200 (let ((set (create-character-set)))
201 (dotimes (i search-char-code-limit)
202 (unless (find (code-char i) pattern)
203 (add-character-to-set (code-char i) set)))
204 (setf (set-search-pattern-set old) set))
205 old)

  ViewVC Help
Powered by ViewVC 1.1.5