Coverage report: /home/jsnell/.sbcl/site/cl-ppcre-1.2.13/closures.lisp

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