/[cl-ppcre]/cl-ppcre/closures.lisp
ViewVC logotype

Contents of /cl-ppcre/closures.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Thu Apr 22 18:53:13 2004 UTC (9 years, 11 months ago) by eweitz
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +2 -2 lines
pre-0.7.7, including hyperdoc support
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
2 ;;; $Header: /tiger/var/lib/cvsroots/cl-ppcre/cl-ppcre/closures.lisp,v 1.2 2004/04/22 18:53:13 eweitz Exp $
3
4 ;;; Here we create the closures which together build the final
5 ;;; scanner.
6
7 ;;; Copyright (c) 2002-2004, Dr. Edmund Weitz. All rights reserved.
8
9 ;;; Redistribution and use in source and binary forms, with or without
10 ;;; modification, are permitted provided that the following conditions
11 ;;; are met:
12
13 ;;; * Redistributions of source code must retain the above copyright
14 ;;; notice, this list of conditions and the following disclaimer.
15
16 ;;; * Redistributions in binary form must reproduce the above
17 ;;; copyright notice, this list of conditions and the following
18 ;;; disclaimer in the documentation and/or other materials
19 ;;; provided with the distribution.
20
21 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
22 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
23 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
24 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
25 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
26 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
27 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
28 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
29 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33 (in-package #:cl-ppcre)
34
35 (declaim (inline *string*= *string*-equal))
36
37 (defun *string*= (string2 start1 end1 start2 end2)
38 "Like STRING=, i.e. compares the special string *STRING* from START1
39 to END1 with STRING2 from START2 to END2. Note that there's no
40 boundary check - this has to be implemented by the caller."
41 (declare (optimize speed
42 (safety 0)
43 (space 0)
44 (debug 0)
45 (compilation-speed 0)
46 #+:lispworks (hcl:fixnum-safety 0)))
47 (declare (type fixnum start1 end1 start2 end2))
48 (loop for string1-idx of-type fixnum from start1 below end1
49 for string2-idx of-type fixnum from start2 below end2
50 always (char= (schar *string* string1-idx)
51 (schar string2 string2-idx))))
52
53 (defun *string*-equal (string2 start1 end1 start2 end2)
54 "Like STRING-EQUAL, i.e. compares the special string *STRING* from
55 START1 to END1 with STRING2 from START2 to END2. Note that there's no
56 boundary check - this has to be implemented by the caller."
57 (declare (optimize speed
58 (safety 0)
59 (space 0)
60 (debug 0)
61 (compilation-speed 0)
62 #+:lispworks (hcl:fixnum-safety 0)))
63 (declare (type fixnum start1 end1 start2 end2))
64 (loop for string1-idx of-type fixnum from start1 below end1
65 for string2-idx of-type fixnum from start2 below end2
66 always (char-equal (schar *string* string1-idx)
67 (schar string2 string2-idx))))
68
69 (defgeneric create-matcher-aux (regex next-fn)
70 (declare (optimize speed
71 (safety 0)
72 (space 0)
73 (debug 0)
74 (compilation-speed 0)
75 #+:lispworks (hcl:fixnum-safety 0)))
76 (:documentation "Creates a closure which takes one parameter,
77 START-POS, and tests whether REGEX can match *STRING* at START-POS
78 such that the call to NEXT-FN after the match would succeed."))
79
80 (defmethod create-matcher-aux ((seq seq) next-fn)
81 ;; the closure for a SEQ is a chain of closures for the elements of
82 ;; this sequence which call each other in turn; the last closure
83 ;; calls NEXT-FN
84 (loop for element in (reverse (elements seq))
85 for curr-matcher = next-fn then next-matcher
86 for next-matcher = (create-matcher-aux element curr-matcher)
87 finally (return next-matcher)))
88
89 (defmethod create-matcher-aux ((alternation alternation) next-fn)
90 ;; first create closures for all alternations of ALTERNATION
91 (let ((all-matchers (mapcar #'(lambda (choice)
92 (create-matcher-aux choice next-fn))
93 (choices alternation))))
94 ;; now create a closure which checks if one of the closures
95 ;; created above can succeed
96 (lambda (start-pos)
97 (declare (type fixnum start-pos))
98 (loop for matcher in all-matchers
99 thereis (funcall (the function matcher) start-pos)))))
100
101 (defmethod create-matcher-aux ((register register) next-fn)
102 ;; the position of this REGISTER within the whole regex; we start to
103 ;; count at 0
104 (let ((num (num register)))
105 (declare (type fixnum num))
106 ;; STORE-END-OF-REG is a thin wrapper around NEXT-FN which will
107 ;; update the corresponding values of *REGS-START* and *REGS-END*
108 ;; after the inner matcher has succeeded
109 (flet ((store-end-of-reg (start-pos)
110 (declare (type fixnum start-pos)
111 (type function next-fn))
112 (setf (svref *reg-starts* num) (svref *regs-maybe-start* num)
113 (svref *reg-ends* num) start-pos)
114 (funcall next-fn start-pos)))
115 ;; the inner matcher is a closure corresponding to the regex
116 ;; wrapped by this REGISTER
117 (let ((inner-matcher (create-matcher-aux (regex register)
118 #'store-end-of-reg)))
119 (declare (type function inner-matcher))
120 ;; here comes the actual closure for REGISTER
121 (lambda (start-pos)
122 (declare (type fixnum start-pos))
123 ;; remember the old values of *REGS-START* and friends in
124 ;; case we cannot match
125 (let ((old-*reg-starts* (svref *reg-starts* num))
126 (old-*regs-maybe-start* (svref *regs-maybe-start* num))
127 (old-*reg-ends* (svref *reg-ends* num)))
128 ;; we cannot use *REGS-START* here because Perl allows
129 ;; regular expressions like /(a|\1x)*/
130 (setf (svref *regs-maybe-start* num) start-pos)
131 (let ((next-pos (funcall inner-matcher start-pos)))
132 (unless next-pos
133 ;; restore old values on failure
134 (setf (svref *reg-starts* num) old-*reg-starts*
135 (svref *regs-maybe-start* num) old-*regs-maybe-start*
136 (svref *reg-ends* num) old-*reg-ends*))
137 next-pos)))))))
138
139 (defmethod create-matcher-aux ((lookahead lookahead) next-fn)
140 ;; create a closure which just checks for the inner regex and
141 ;; doesn't care about NEXT-FN
142 (let ((test-matcher (create-matcher-aux (regex lookahead) #'identity)))
143 (declare (type function next-fn test-matcher))
144 (if (positivep lookahead)
145 ;; positive look-ahead: check success of inner regex, then call
146 ;; NEXT-FN
147 (lambda (start-pos)
148 (and (funcall test-matcher start-pos)
149 (funcall next-fn start-pos)))
150 ;; negative look-ahead: check failure of inner regex, then call
151 ;; NEXT-FN
152 (lambda (start-pos)
153 (and (not (funcall test-matcher start-pos))
154 (funcall next-fn start-pos))))))
155
156 (defmethod create-matcher-aux ((lookbehind lookbehind) next-fn)
157 (let ((len (len lookbehind))
158 ;; create a closure which just checks for the inner regex and
159 ;; doesn't care about NEXT-FN
160 (test-matcher (create-matcher-aux (regex lookbehind) #'identity)))
161 (declare (type function next-fn test-matcher)
162 (type fixnum len))
163 (if (positivep lookbehind)
164 ;; positive look-behind: check success of inner regex (if we're
165 ;; far enough from the start of *STRING*), then call NEXT-FN
166 (lambda (start-pos)
167 (declare (type fixnum start-pos))
168 (and (>= (- start-pos *start-pos*) len)
169 (funcall test-matcher (- start-pos len))
170 (funcall next-fn start-pos)))
171 ;; negative look-behind: check failure of inner regex (if we're
172 ;; far enough from the start of *STRING*), then call NEXT-FN
173 (lambda (start-pos)
174 (declare (type fixnum start-pos))
175 (and (or (< start-pos len)
176 (not (funcall test-matcher (- start-pos len))))
177 (funcall next-fn start-pos))))))
178
179 (defmacro insert-char-class-tester ((char-class chr-expr) &body body)
180 "Utility macro to replace each occurence of '(CHAR-CLASS-TEST)
181 within BODY with the correct test (corresponding to CHAR-CLASS)
182 against CHR-EXPR."
183 (with-unique-names (%char-class)
184 ;; the actual substitution is done here: replace
185 ;; '(CHAR-CLASS-TEST) with NEW
186 (flet ((substitute-char-class-tester (new)
187 (subst new '(char-class-test) body
188 :test #'equalp)))
189 `(let* ((,%char-class ,char-class)
190 (hash (hash ,%char-class))
191 (count (if hash
192 (hash-table-count hash)
193 most-positive-fixnum))
194 ;; collect a list of "all" characters in the hash if
195 ;; there aren't more than two
196 (key-list (if (<= count 2)
197 (loop for chr being the hash-keys of hash
198 collect chr)
199 nil))
200 downcasedp)
201 (declare (type fixnum count))
202 ;; check if we can partition the hash into three ranges (or
203 ;; less)
204 (multiple-value-bind (min1 max1 min2 max2 min3 max3)
205 (create-ranges-from-hash hash)
206 ;; if that didn't work and CHAR-CLASS is case-insensitive we
207 ;; try it again with every character downcased
208 (when (and (not min1)
209 (case-insensitive-p ,%char-class))
210 (multiple-value-setq (min1 max1 min2 max2 min3 max3)
211 (create-ranges-from-hash hash :downcasep t))
212 (setq downcasedp t))
213 (cond ((= count 1)
214 ;; hash contains exactly one character so we just
215 ;; check for this single character; (note that this
216 ;; actually can't happen because this case is
217 ;; optimized away in CONVERT already...)
218 (let ((chr1 (first key-list)))
219 ,@(substitute-char-class-tester
220 `(char= ,chr-expr chr1))))
221 ((= count 2)
222 ;; hash contains exactly two characters
223 (let ((chr1 (first key-list))
224 (chr2 (second key-list)))
225 ,@(substitute-char-class-tester
226 `(let ((chr ,chr-expr))
227 (or (char= chr chr1)
228 (char= chr chr2))))))
229 ((word-char-class-p ,%char-class)
230 ;; special-case: hash is \w, \W, [\w], [\W] or
231 ;; something equivalent
232 ,@(substitute-char-class-tester
233 `(word-char-p ,chr-expr)))
234 ((= count *regex-char-code-limit*)
235 ;; according to the ANSI standard we might have all
236 ;; possible characters in the hash even if it
237 ;; doesn't contain CHAR-CODE-LIMIT characters but
238 ;; this doesn't seem to be the case for current
239 ;; implementations (also note that this optimization
240 ;; implies that you must not have characters with
241 ;; character codes beyond *REGEX-CHAR-CODE-LIMIT* in
242 ;; your regexes if you've changed this limit); we
243 ;; expect the compiler to optimize this T "test"
244 ;; away
245 ,@(substitute-char-class-tester t))
246 ((and downcasedp min1 min2 min3)
247 ;; three different ranges, downcased
248 ,@(substitute-char-class-tester
249 `(let ((chr ,chr-expr))
250 (or (char-not-greaterp min1 chr max1)
251 (char-not-greaterp min2 chr max2)
252 (char-not-greaterp min3 chr max3)))))
253 ((and downcasedp min1 min2)
254 ;; two ranges, downcased
255 ,@(substitute-char-class-tester
256 `(let ((chr ,chr-expr))
257 (or (char-not-greaterp min1 chr max1)
258 (char-not-greaterp min2 chr max2)))))
259 ((and downcasedp min1)
260 ;; one downcased range
261 ,@(substitute-char-class-tester
262 `(char-not-greaterp min1 ,chr-expr max1)))
263 ((and min1 min2 min3)
264 ;; three ranges
265 ,@(substitute-char-class-tester
266 `(let ((chr ,chr-expr))
267 (or (char<= min1 chr max1)
268 (char<= min2 chr max2)
269 (char<= min3 chr max3)))))
270 ((and min1 min2)
271 ;; two ranges
272 ,@(substitute-char-class-tester
273 `(let ((chr ,chr-expr))
274 (or (char<= min1 chr max1)
275 (char<= min2 chr max2)))))
276 (min1
277 ;; one range
278 ,@(substitute-char-class-tester
279 `(char<= min1 ,chr-expr max1)))
280 (t
281 ;; the general case; note that most of the above
282 ;; "optimizations" are based on experiences and
283 ;; benchmarks with CMUCL - if you're really
284 ;; concerned with speed you might find out that the
285 ;; general case is almost always the best one for
286 ;; other implementations (because the speed of their
287 ;; hash-table access in relation to other operations
288 ;; might be better than in CMUCL)
289 ,@(substitute-char-class-tester
290 `(gethash ,chr-expr hash)))))))))
291
292 (defmethod create-matcher-aux ((char-class char-class) next-fn)
293 (declare (type function next-fn))
294 ;; insert a test against the current character within *STRING*
295 (insert-char-class-tester (char-class (schar *string* start-pos))
296 (if (invertedp char-class)
297 (lambda (start-pos)
298 (declare (type fixnum start-pos))
299 (and (< start-pos *end-pos*)
300 (not (char-class-test))
301 (funcall next-fn (1+ start-pos))))
302 (lambda (start-pos)
303 (declare (type fixnum start-pos))
304 (and (< start-pos *end-pos*)
305 (char-class-test)
306 (funcall next-fn (1+ start-pos)))))))
307
308 (defmethod create-matcher-aux ((str str) next-fn)
309 (declare (type fixnum *end-string-pos*)
310 (type function next-fn)
311 ;; this special value is set by CREATE-SCANNER when the
312 ;; closures are built
313 (special end-string))
314 (let* ((len (len str))
315 (case-insensitive-p (case-insensitive-p str))
316 (start-of-end-string-p (start-of-end-string-p str))
317 (skip (skip str))
318 (str (str str))
319 (chr (schar str 0))
320 (end-string (and end-string (str end-string)))
321 (end-string-len (if end-string
322 (length end-string)
323 nil)))
324 (declare (type fixnum len))
325 (cond ((and start-of-end-string-p case-insensitive-p)
326 ;; closure for the first STR which belongs to the constant
327 ;; string at the end of the regular expression;
328 ;; case-insensitive version
329 (lambda (start-pos)
330 (declare (type fixnum start-pos end-string-len))
331 (let ((test-end-pos (+ start-pos end-string-len)))
332 (declare (type fixnum test-end-pos))
333 ;; either we're at *END-STRING-POS* (which means that
334 ;; it has already been confirmed that end-string
335 ;; starts here) or we really have to test
336 (and (or (= start-pos *end-string-pos*)
337 (and (<= test-end-pos *end-pos*)
338 (*string*-equal end-string start-pos test-end-pos
339 0 end-string-len)))
340 (funcall next-fn (+ start-pos len))))))
341 (start-of-end-string-p
342 ;; closure for the first STR which belongs to the constant
343 ;; string at the end of the regular expression;
344 ;; case-sensitive version
345 (lambda (start-pos)
346 (declare (type fixnum start-pos end-string-len))
347 (let ((test-end-pos (+ start-pos end-string-len)))
348 (declare (type fixnum test-end-pos))
349 ;; either we're at *END-STRING-POS* (which means that
350 ;; it has already been confirmed that end-string
351 ;; starts here) or we really have to test
352 (and (or (= start-pos *end-string-pos*)
353 (and (<= test-end-pos *end-pos*)
354 (*string*= end-string start-pos test-end-pos
355 0 end-string-len)))
356 (funcall next-fn (+ start-pos len))))))
357 (skip
358 ;; a STR which can be skipped because some other function
359 ;; has already confirmed that it matches
360 (lambda (start-pos)
361 (declare (type fixnum start-pos))
362 (funcall next-fn (+ start-pos len))))
363 ((and (= len 1) case-insensitive-p)
364 ;; STR represent exactly one character; case-insensitive
365 ;; version
366 (lambda (start-pos)
367 (declare (type fixnum start-pos))
368 (and (< start-pos *end-pos*)
369 (char-equal (schar *string* start-pos) chr)
370 (funcall next-fn (1+ start-pos)))))
371 ((= len 1)
372 ;; STR represent exactly one character; case-sensitive
373 ;; version
374 (lambda (start-pos)
375 (declare (type fixnum start-pos))
376 (and (< start-pos *end-pos*)
377 (char= (schar *string* start-pos) chr)
378 (funcall next-fn (1+ start-pos)))))
379 (case-insensitive-p
380 ;; general case, case-insensitive version
381 (lambda (start-pos)
382 (declare (type fixnum start-pos))
383 (let ((next-pos (+ start-pos len)))
384 (declare (type fixnum next-pos))
385 (and (<= next-pos *end-pos*)
386 (*string*-equal str start-pos next-pos 0 len)
387 (funcall next-fn next-pos)))))
388 (t
389 ;; general case, case-sensitive version
390 (lambda (start-pos)
391 (declare (type fixnum start-pos))
392 (let ((next-pos (+ start-pos len)))
393 (declare (type fixnum next-pos))
394 (and (<= next-pos *end-pos*)
395 (*string*= str start-pos next-pos 0 len)
396 (funcall next-fn next-pos))))))))
397
398 (declaim (inline word-boundary-p))
399
400 (defun word-boundary-p (start-pos)
401 "Check whether START-POS is a word-boundary within *STRING*."
402 (declare (optimize speed
403 (safety 0)
404 (space 0)
405 (debug 0)
406 (compilation-speed 0)
407 #+:lispworks (hcl:fixnum-safety 0)))
408 (declare (type fixnum start-pos))
409 (let ((1-start-pos (1- start-pos)))
410 ;; either the character before START-POS is a word-constituent and
411 ;; the character at START-POS isn't...
412 (or (and (or (= start-pos *end-pos*)
413 (and (< start-pos *end-pos*)
414 (not (word-char-p (schar *string* start-pos)))))
415 (and (< 1-start-pos *end-pos*)
416 (<= *start-pos* 1-start-pos)
417 (word-char-p (schar *string* 1-start-pos))))
418 ;; ...or vice versa
419 (and (or (= start-pos *start-pos*)
420 (and (< 1-start-pos *end-pos*)
421 (<= *start-pos* 1-start-pos)
422 (not (word-char-p (schar *string* 1-start-pos)))))
423 (and (< start-pos *end-pos*)
424 (word-char-p (schar *string* start-pos)))))))
425
426 (defmethod create-matcher-aux ((word-boundary word-boundary) next-fn)
427 (declare (type function next-fn))
428 (if (negatedp word-boundary)
429 (lambda (start-pos)
430 (and (not (word-boundary-p start-pos))
431 (funcall next-fn start-pos)))
432 (lambda (start-pos)
433 (and (word-boundary-p start-pos)
434 (funcall next-fn start-pos)))))
435
436 (defmethod create-matcher-aux ((everything everything) next-fn)
437 (declare (type function next-fn))
438 (if (single-line-p everything)
439 ;; closure for single-line-mode: we really match everything, so we
440 ;; just advance the index into *STRING* by one and carry on
441 (lambda (start-pos)
442 (declare (type fixnum start-pos))
443 (and (< start-pos *end-pos*)
444 (funcall next-fn (1+ start-pos))))
445 ;; not single-line-mode, so we have to make sure we don't match
446 ;; #\Newline
447 (lambda (start-pos)
448 (declare (type fixnum start-pos))
449 (and (< start-pos *end-pos*)
450 (char/= (schar *string* start-pos) #\Newline)
451 (funcall next-fn (1+ start-pos))))))
452
453 (defmethod create-matcher-aux ((anchor anchor) next-fn)
454 (declare (type function next-fn))
455 (let ((startp (startp anchor))
456 (multi-line-p (multi-line-p anchor)))
457 (cond ((no-newline-p anchor)
458 ;; this must be and end-anchor and it must be modeless, so
459 ;; we just have to check whether START-POS equals
460 ;; *END-POS*
461 (lambda (start-pos)
462 (declare (type fixnum start-pos))
463 (and (= start-pos *end-pos*)
464 (funcall next-fn start-pos))))
465 ((and startp multi-line-p)
466 ;; a start-anchor in multi-line-mode: check if we're at
467 ;; *START-POS* or if the last character was #\Newline
468 (lambda (start-pos)
469 (declare (type fixnum start-pos))
470 (let ((*start-pos* (or *real-start-pos* *start-pos*)))
471 (and (or (= start-pos *start-pos*)
472 (and (<= start-pos *end-pos*)
473 (> start-pos *start-pos*)
474 (char= #\Newline
475 (schar *string* (1- start-pos)))))
476 (funcall next-fn start-pos)))))
477 (startp
478 ;; a start-anchor which is not in multi-line-mode, so just
479 ;; check whether we're at *START-POS*
480 (lambda (start-pos)
481 (declare (type fixnum start-pos))
482 (and (= start-pos (or *real-start-pos* *start-pos*))
483 (funcall next-fn start-pos))))
484 (multi-line-p
485 ;; an end-anchor in multi-line-mode: check if we're at
486 ;; *END-POS* or if the character we're looking at is
487 ;; #\Newline
488 (lambda (start-pos)
489 (declare (type fixnum start-pos))
490 (and (or (= start-pos *end-pos*)
491 (and (< start-pos *end-pos*)
492 (char= #\Newline
493 (schar *string* start-pos))))
494 (funcall next-fn start-pos))))
495 (t
496 ;; an end-anchor which is not in multi-line-mode, so just
497 ;; check if we're at *END-POS* or if we're looking at
498 ;; #\Newline and there's nothing behind it
499 (lambda (start-pos)
500 (declare (type fixnum start-pos))
501 (and (or (= start-pos *end-pos*)
502 (and (= start-pos (1- *end-pos*))
503 (char= #\Newline
504 (schar *string* start-pos))))
505 (funcall next-fn start-pos)))))))
506
507 (defmethod create-matcher-aux ((back-reference back-reference) next-fn)
508 (declare (type function next-fn))
509 ;; the position of the corresponding REGISTER within the whole
510 ;; regex; we start to count at 0
511 (let ((num (num back-reference)))
512 (if (case-insensitive-p back-reference)
513 ;; the case-insensitive version
514 (lambda (start-pos)
515 (declare (type fixnum start-pos))
516 (let ((reg-start (svref *reg-starts* num))
517 (reg-end (svref *reg-ends* num)))
518 ;; only bother to check if the corresponding REGISTER as
519 ;; matched successfully already
520 (and reg-start
521 (let ((next-pos (+ start-pos (- (the fixnum reg-end)
522 (the fixnum reg-start)))))
523 (declare (type fixnum next-pos))
524 (and
525 (<= next-pos *end-pos*)
526 (*string*-equal *string* start-pos next-pos
527 reg-start reg-end)
528 (funcall next-fn next-pos))))))
529 ;; the case-sensitive version
530 (lambda (start-pos)
531 (declare (type fixnum start-pos))
532 (let ((reg-start (svref *reg-starts* num))
533 (reg-end (svref *reg-ends* num)))
534 ;; only bother to check if the corresponding REGISTER as
535 ;; matched successfully already
536 (and reg-start
537 (let ((next-pos (+ start-pos (- (the fixnum reg-end)
538 (the fixnum reg-start)))))
539 (declare (type fixnum next-pos))
540 (and
541 (<= next-pos *end-pos*)
542 (*string*= *string* start-pos next-pos
543 reg-start reg-end)
544 (funcall next-fn next-pos)))))))))
545
546 (defmethod create-matcher-aux ((branch branch) next-fn)
547 (let* ((test (test branch))
548 (then-matcher (create-matcher-aux (then-regex branch) next-fn))
549 (else-matcher (create-matcher-aux (else-regex branch) next-fn)))
550 (declare (type function then-matcher else-matcher))
551 (cond ((numberp test)
552 (lambda (start-pos)
553 (declare (type fixnum test))
554 (if (and (< test (length *reg-starts*))
555 (svref *reg-starts* test))
556 (funcall then-matcher start-pos)
557 (funcall else-matcher start-pos))))
558 (t
559 (let ((test-matcher (create-matcher-aux test #'identity)))
560 (declare (type function test-matcher))
561 (lambda (start-pos)
562 (if (funcall test-matcher start-pos)
563 (funcall then-matcher start-pos)
564 (funcall else-matcher start-pos))))))))
565
566 (defmethod create-matcher-aux ((standalone standalone) next-fn)
567 (let ((inner-matcher (create-matcher-aux (regex standalone) #'identity)))
568 (declare (type function next-fn inner-matcher))
569 (lambda (start-pos)
570 (let ((next-pos (funcall inner-matcher start-pos)))
571 (and next-pos
572 (funcall next-fn next-pos))))))
573
574 (defmethod create-matcher-aux ((void void) next-fn)
575 ;; optimize away VOIDs: don't create a closure, just return NEXT-FN
576 next-fn)

  ViewVC Help
Powered by ViewVC 1.1.5