Coverage report: /home/ellis/comp/ext/cl-ppcre/repetition-closures.lisp

KindCoveredAll%
expression145685 21.2
branch28142 19.7
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; $Header: /usr/local/cvsrep/cl-ppcre/repetition-closures.lisp,v 1.34 2009/09/17 19:17:31 edi Exp $
2
 
3
 ;;; This is actually a part of closures.lisp which we put into a
4
 ;;; separate file because it is rather complex. We only deal with
5
 ;;; REPETITIONs here. Note that this part of the code contains some
6
 ;;; rather crazy micro-optimizations which were introduced to be as
7
 ;;; competitive with Perl as possible in tight loops.
8
 
9
 ;;; Copyright (c) 2002-2009, Dr. Edmund Weitz. All rights reserved.
10
 
11
 ;;; Redistribution and use in source and binary forms, with or without
12
 ;;; modification, are permitted provided that the following conditions
13
 ;;; are met:
14
 
15
 ;;;   * Redistributions of source code must retain the above copyright
16
 ;;;     notice, this list of conditions and the following disclaimer.
17
 
18
 ;;;   * Redistributions in binary form must reproduce the above
19
 ;;;     copyright notice, this list of conditions and the following
20
 ;;;     disclaimer in the documentation and/or other materials
21
 ;;;     provided with the distribution.
22
 
23
 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
24
 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
25
 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
26
 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
27
 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
28
 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
29
 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
30
 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
31
 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32
 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33
 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34
 
35
 (in-package :cl-ppcre)
36
 
37
 (defmacro incf-after (place &optional (delta 1) &environment env)
38
   "Utility macro inspired by C's \"place++\", i.e. first return the
39
 value of PLACE and afterwards increment it by DELTA."
40
   (with-unique-names (%temp)
41
     (multiple-value-bind (vars vals store-vars writer-form reader-form)
42
         (get-setf-expansion place env)
43
       `(let* (,@(mapcar #'list vars vals)
44
               (,%temp ,reader-form)
45
               (,(car store-vars) (+ ,%temp ,delta)))
46
         ,writer-form
47
         ,%temp))))
48
 
49
 ;; code for greedy repetitions with minimum zero
50
 
51
 (defmacro greedy-constant-length-closure (check-curr-pos)
52
   "This is the template for simple greedy repetitions (where simple
53
 means that the minimum number of repetitions is zero, that the inner
54
 regex to be checked is of fixed length LEN, and that it doesn't
55
 contain registers, i.e. there's no need for backtracking).
56
 CHECK-CURR-POS is a form which checks whether the inner regex of the
57
 repetition matches at CURR-POS."
58
   `(if maximum
59
     (lambda (start-pos)
60
       (declare (fixnum start-pos maximum))
61
       ;; because we know LEN we know in advance where to stop at the
62
       ;; latest; we also take into consideration MIN-REST, i.e. the
63
       ;; minimal length of the part behind the repetition
64
       (let ((target-end-pos (min (1+ (- *end-pos* len min-rest))
65
                                  ;; don't go further than MAXIMUM
66
                                  ;; repetitions, of course
67
                                  (+ start-pos
68
                                     (the fixnum (* len maximum)))))
69
             (curr-pos start-pos))
70
         (declare (fixnum target-end-pos curr-pos))
71
         (block greedy-constant-length-matcher
72
           ;; we use an ugly TAGBODY construct because this might be a
73
           ;; tight loop and this version is a bit faster than our LOOP
74
           ;; version (at least in CMUCL)
75
           (tagbody
76
             forward-loop
77
             ;; first go forward as far as possible, i.e. while
78
             ;; the inner regex matches
79
             (when (>= curr-pos target-end-pos)
80
               (go backward-loop))
81
             (when ,check-curr-pos
82
               (incf curr-pos len)
83
               (go forward-loop))
84
             backward-loop
85
             ;; now go back LEN steps each until we're able to match
86
             ;; the rest of the regex
87
             (when (< curr-pos start-pos)
88
               (return-from greedy-constant-length-matcher nil))
89
             (let ((result (funcall next-fn curr-pos)))
90
               (when result
91
                 (return-from greedy-constant-length-matcher result)))
92
             (decf curr-pos len)
93
             (go backward-loop)))))
94
     ;; basically the same code; it's just a bit easier because we're
95
     ;; not bounded by MAXIMUM
96
     (lambda (start-pos)
97
       (declare (fixnum start-pos))
98
       (let ((target-end-pos (1+ (- *end-pos* len min-rest)))
99
             (curr-pos start-pos))
100
         (declare (fixnum target-end-pos curr-pos))
101
         (block greedy-constant-length-matcher
102
           (tagbody
103
             forward-loop
104
             (when (>= curr-pos target-end-pos)
105
               (go backward-loop))
106
             (when ,check-curr-pos
107
               (incf curr-pos len)
108
               (go forward-loop))
109
             backward-loop
110
             (when (< curr-pos start-pos)
111
               (return-from greedy-constant-length-matcher nil))
112
             (let ((result (funcall next-fn curr-pos)))
113
               (when result
114
                 (return-from greedy-constant-length-matcher result)))
115
             (decf curr-pos len)
116
             (go backward-loop)))))))
117
 
118
 (defun create-greedy-everything-matcher (maximum min-rest next-fn)
119
   "Creates a closure which just matches as far ahead as possible,
120
 i.e. a closure for a dot in single-line mode."
121
   (declare #.*standard-optimize-settings*)
122
   (declare (fixnum min-rest) (function next-fn))
123
   (if maximum
124
     (lambda (start-pos)
125
       (declare (fixnum start-pos maximum))
126
       ;; because we know LEN we know in advance where to stop at the
127
       ;; latest; we also take into consideration MIN-REST, i.e. the
128
       ;; minimal length of the part behind the repetition
129
       (let ((target-end-pos (min (+ start-pos maximum)
130
                                  (- *end-pos* min-rest))))
131
         (declare (fixnum target-end-pos))
132
         ;; start from the highest possible position and go backward
133
         ;; until we're able to match the rest of the regex
134
         (loop for curr-pos of-type fixnum from target-end-pos downto start-pos
135
               thereis (funcall next-fn curr-pos))))
136
     ;; basically the same code; it's just a bit easier because we're
137
     ;; not bounded by MAXIMUM
138
     (lambda (start-pos)
139
       (declare (fixnum start-pos))
140
       (let ((target-end-pos (- *end-pos* min-rest)))
141
         (declare (fixnum target-end-pos))
142
         (loop for curr-pos of-type fixnum from target-end-pos downto start-pos
143
               thereis (funcall next-fn curr-pos))))))
144
 
145
 (defgeneric create-greedy-constant-length-matcher (repetition next-fn)
146
   (declare #.*standard-optimize-settings*)
147
   (:documentation "Creates a closure which tries to match REPETITION.
148
 It is assumed that REPETITION is greedy and the minimal number of
149
 repetitions is zero.  It is furthermore assumed that the inner regex
150
 of REPETITION is of fixed length and doesn't contain registers."))
151
 
152
 (defmethod create-greedy-constant-length-matcher ((repetition repetition)
153
                                                   next-fn)
154
   (declare #.*standard-optimize-settings*)
155
   (let ((len (len repetition))
156
         (maximum (maximum repetition))
157
         (regex (regex repetition))
158
         (min-rest (min-rest repetition)))
159
     (declare (fixnum len min-rest)
160
              (function next-fn))
161
     (cond ((zerop len)
162
             ;; inner regex has zero-length, so we can discard it
163
             ;; completely
164
             next-fn)
165
           (t
166
             ;; now first try to optimize for a couple of common cases
167
             (typecase regex
168
               (str
169
                 (let ((str (str regex)))
170
                   (if (= 1 len)
171
                     ;; a single character
172
                     (let ((chr (schar str 0)))
173
                       (if (case-insensitive-p regex)
174
                         (greedy-constant-length-closure
175
                          (char-equal chr (schar *string* curr-pos)))
176
                         (greedy-constant-length-closure
177
                          (char= chr (schar *string* curr-pos)))))
178
                     ;; a string
179
                     (if (case-insensitive-p regex)
180
                       (greedy-constant-length-closure
181
                        (*string*-equal str curr-pos (+ curr-pos len) 0 len))
182
                       (greedy-constant-length-closure
183
                        (*string*= str curr-pos (+ curr-pos len) 0 len))))))
184
               (char-class
185
                 ;; a character class
186
                 (insert-char-class-tester (regex (schar *string* curr-pos))
187
                   (greedy-constant-length-closure
188
                    (char-class-test))))
189
               (everything
190
                 ;; an EVERYTHING object, i.e. a dot
191
                 (if (single-line-p regex)
192
                   (create-greedy-everything-matcher maximum min-rest next-fn)
193
                   (greedy-constant-length-closure
194
                    (char/= #\Newline (schar *string* curr-pos)))))
195
               (t
196
                 ;; the general case - we build an inner matcher which
197
                 ;; just checks for immediate success, i.e. NEXT-FN is
198
                 ;; #'IDENTITY
199
                 (let ((inner-matcher (create-matcher-aux regex #'identity)))
200
                   (declare (function inner-matcher))
201
                   (greedy-constant-length-closure
202
                    (funcall inner-matcher curr-pos)))))))))
203
 
204
 (defgeneric create-greedy-no-zero-matcher (repetition next-fn)
205
   (declare #.*standard-optimize-settings*)
206
   (:documentation "Creates a closure which tries to match REPETITION.
207
 It is assumed that REPETITION is greedy and the minimal number of
208
 repetitions is zero.  It is furthermore assumed that the inner regex
209
 of REPETITION can never match a zero-length string \(or instead the
210
 maximal number of repetitions is 1)."))
211
 
212
 (defmethod create-greedy-no-zero-matcher ((repetition repetition) next-fn)
213
   (declare #.*standard-optimize-settings*)
214
   (let ((maximum (maximum repetition))
215
         ;; REPEAT-MATCHER is part of the closure's environment but it
216
         ;; can only be defined after GREEDY-AUX is defined
217
         repeat-matcher)
218
     (declare (function next-fn))
219
     (cond
220
       ((eql maximum 1)
221
         ;; this is essentially like the next case but with a known
222
         ;; MAXIMUM of 1 we can get away without a counter; note that
223
         ;; we always arrive here if CONVERT optimizes <regex>* to
224
         ;; (?:<regex'>*<regex>)?
225
         (setq repeat-matcher
226
                 (create-matcher-aux (regex repetition) next-fn))
227
         (lambda (start-pos)
228
           (declare (function repeat-matcher))
229
           (or (funcall repeat-matcher start-pos)
230
               (funcall next-fn start-pos))))
231
       (maximum
232
         ;; we make a reservation for our slot in *REPEAT-COUNTERS*
233
         ;; because we need to keep track whether we've reached MAXIMUM
234
         ;; repetitions
235
         (let ((rep-num (incf-after *rep-num*)))
236
           (flet ((greedy-aux (start-pos)
237
                    (declare (fixnum start-pos maximum rep-num)
238
                             (function repeat-matcher))
239
                    ;; the actual matcher which first tries to match the
240
                    ;; inner regex of REPETITION (if we haven't done so
241
                    ;; too often) and on failure calls NEXT-FN
242
                    (or (and (< (aref *repeat-counters* rep-num) maximum)
243
                             (incf (aref *repeat-counters* rep-num))
244
                             ;; note that REPEAT-MATCHER will call
245
                             ;; GREEDY-AUX again recursively
246
                             (prog1
247
                               (funcall repeat-matcher start-pos)
248
                               (decf (aref *repeat-counters* rep-num))))
249
                        (funcall next-fn start-pos))))
250
             ;; create a closure to match the inner regex and to
251
             ;; implement backtracking via GREEDY-AUX
252
             (setq repeat-matcher
253
                     (create-matcher-aux (regex repetition) #'greedy-aux))
254
             ;; the closure we return is just a thin wrapper around
255
             ;; GREEDY-AUX to initialize the repetition counter
256
             (lambda (start-pos)
257
               (declare (fixnum start-pos))
258
               (setf (aref *repeat-counters* rep-num) 0)
259
               (greedy-aux start-pos)))))
260
       (t
261
         ;; easier code because we're not bounded by MAXIMUM, but
262
         ;; basically the same
263
         (flet ((greedy-aux (start-pos)
264
                  (declare (fixnum start-pos)
265
                           (function repeat-matcher))
266
                  (or (funcall repeat-matcher start-pos)
267
                      (funcall next-fn start-pos))))
268
           (setq repeat-matcher
269
                   (create-matcher-aux (regex repetition) #'greedy-aux))
270
           #'greedy-aux)))))
271
 
272
 (defgeneric create-greedy-matcher (repetition next-fn)
273
   (declare #.*standard-optimize-settings*)
274
   (:documentation "Creates a closure which tries to match REPETITION.
275
 It is assumed that REPETITION is greedy and the minimal number of
276
 repetitions is zero."))
277
 
278
 (defmethod create-greedy-matcher ((repetition repetition) next-fn)
279
   (declare #.*standard-optimize-settings*)
280
   (let ((maximum (maximum repetition))
281
         ;; we make a reservation for our slot in *LAST-POS-STORES* because
282
         ;; we have to watch out for endless loops as the inner regex might
283
         ;; match zero-length strings
284
         (zero-length-num (incf-after *zero-length-num*))
285
         ;; REPEAT-MATCHER is part of the closure's environment but it
286
         ;; can only be defined after GREEDY-AUX is defined
287
         repeat-matcher)
288
     (declare (fixnum zero-length-num)
289
              (function next-fn))
290
     (cond
291
       (maximum
292
         ;; we make a reservation for our slot in *REPEAT-COUNTERS*
293
         ;; because we need to keep track whether we've reached MAXIMUM
294
         ;; repetitions
295
         (let ((rep-num (incf-after *rep-num*)))
296
           (flet ((greedy-aux (start-pos)
297
                    ;; the actual matcher which first tries to match the
298
                    ;; inner regex of REPETITION (if we haven't done so
299
                    ;; too often) and on failure calls NEXT-FN
300
                    (declare (fixnum start-pos maximum rep-num)
301
                             (function repeat-matcher))
302
                    (let ((old-last-pos
303
                            (svref *last-pos-stores* zero-length-num)))
304
                      (when (and old-last-pos
305
                                 (= (the fixnum old-last-pos) start-pos))
306
                        ;; stop immediately if we've been here before,
307
                        ;; i.e. if the last attempt matched a zero-length
308
                        ;; string
309
                        (return-from greedy-aux (funcall next-fn start-pos)))
310
                      ;; otherwise remember this position for the next
311
                      ;; repetition
312
                      (setf (svref *last-pos-stores* zero-length-num) start-pos)
313
                      (or (and (< (aref *repeat-counters* rep-num) maximum)
314
                               (incf (aref *repeat-counters* rep-num))
315
                               ;; note that REPEAT-MATCHER will call
316
                               ;; GREEDY-AUX again recursively
317
                               (prog1
318
                                 (funcall repeat-matcher start-pos)
319
                                 (decf (aref *repeat-counters* rep-num))
320
                                 (setf (svref *last-pos-stores* zero-length-num)
321
                                         old-last-pos)))
322
                          (funcall next-fn start-pos)))))
323
             ;; create a closure to match the inner regex and to
324
             ;; implement backtracking via GREEDY-AUX
325
             (setq repeat-matcher
326
                     (create-matcher-aux (regex repetition) #'greedy-aux))
327
             ;; the closure we return is just a thin wrapper around
328
             ;; GREEDY-AUX to initialize the repetition counter and our
329
             ;; slot in *LAST-POS-STORES*
330
             (lambda (start-pos)
331
               (declare (fixnum start-pos))
332
               (setf (aref *repeat-counters* rep-num) 0
333
                     (svref *last-pos-stores* zero-length-num) nil)
334
               (greedy-aux start-pos)))))
335
       (t
336
         ;; easier code because we're not bounded by MAXIMUM, but
337
         ;; basically the same
338
         (flet ((greedy-aux (start-pos)
339
                  (declare (fixnum start-pos)
340
                           (function repeat-matcher))
341
                  (let ((old-last-pos
342
                          (svref *last-pos-stores* zero-length-num)))
343
                    (when (and old-last-pos
344
                               (= (the fixnum old-last-pos) start-pos))
345
                      (return-from greedy-aux (funcall next-fn start-pos)))
346
                    (setf (svref *last-pos-stores* zero-length-num) start-pos)
347
                    (or (prog1
348
                          (funcall repeat-matcher start-pos)
349
                          (setf (svref *last-pos-stores* zero-length-num) old-last-pos))
350
                        (funcall next-fn start-pos)))))
351
           (setq repeat-matcher
352
                   (create-matcher-aux (regex repetition) #'greedy-aux))
353
           (lambda (start-pos)
354
             (declare (fixnum start-pos))
355
             (setf (svref *last-pos-stores* zero-length-num) nil)
356
             (greedy-aux start-pos)))))))
357
   
358
 ;; code for non-greedy repetitions with minimum zero
359
 
360
 (defmacro non-greedy-constant-length-closure (check-curr-pos)
361
   "This is the template for simple non-greedy repetitions \(where
362
 simple means that the minimum number of repetitions is zero, that the
363
 inner regex to be checked is of fixed length LEN, and that it doesn't
364
 contain registers, i.e. there's no need for backtracking).
365
 CHECK-CURR-POS is a form which checks whether the inner regex of the
366
 repetition matches at CURR-POS."
367
   `(if maximum
368
     (lambda (start-pos)
369
       (declare (fixnum start-pos maximum))
370
       ;; because we know LEN we know in advance where to stop at the
371
       ;; latest; we also take into consideration MIN-REST, i.e. the
372
       ;; minimal length of the part behind the repetition
373
       (let ((target-end-pos (min (1+ (- *end-pos* len min-rest))
374
                                  (+ start-pos
375
                                     (the fixnum (* len maximum))))))
376
         ;; move forward by LEN and always try NEXT-FN first, then
377
         ;; CHECK-CUR-POS
378
         (loop for curr-pos of-type fixnum from start-pos
379
                                           below target-end-pos
380
                                           by len
381
               thereis (funcall next-fn curr-pos)
382
               while ,check-curr-pos
383
               finally (return (funcall next-fn curr-pos)))))
384
   ;; basically the same code; it's just a bit easier because we're
385
   ;; not bounded by MAXIMUM
386
   (lambda (start-pos)
387
     (declare (fixnum start-pos))
388
     (let ((target-end-pos (1+ (- *end-pos* len min-rest))))
389
       (loop for curr-pos of-type fixnum from start-pos
390
                                         below target-end-pos
391
                                         by len
392
             thereis (funcall next-fn curr-pos)
393
             while ,check-curr-pos
394
             finally (return (funcall next-fn curr-pos)))))))
395
 
396
 (defgeneric create-non-greedy-constant-length-matcher (repetition next-fn)
397
   (declare #.*standard-optimize-settings*)
398
   (:documentation "Creates a closure which tries to match REPETITION.
399
 It is assumed that REPETITION is non-greedy and the minimal number of
400
 repetitions is zero.  It is furthermore assumed that the inner regex
401
 of REPETITION is of fixed length and doesn't contain registers."))
402
 
403
 (defmethod create-non-greedy-constant-length-matcher ((repetition repetition) next-fn)
404
   (declare #.*standard-optimize-settings*)
405
   (let ((len (len repetition))
406
         (maximum (maximum repetition))
407
         (regex (regex repetition))
408
         (min-rest (min-rest repetition)))
409
     (declare (fixnum len min-rest)
410
              (function next-fn))
411
     (cond ((zerop len)
412
             ;; inner regex has zero-length, so we can discard it
413
             ;; completely
414
             next-fn)
415
           (t
416
             ;; now first try to optimize for a couple of common cases
417
             (typecase regex
418
               (str
419
                 (let ((str (str regex)))
420
                   (if (= 1 len)
421
                     ;; a single character
422
                     (let ((chr (schar str 0)))
423
                       (if (case-insensitive-p regex)
424
                         (non-greedy-constant-length-closure
425
                          (char-equal chr (schar *string* curr-pos)))
426
                         (non-greedy-constant-length-closure
427
                          (char= chr (schar *string* curr-pos)))))
428
                     ;; a string
429
                     (if (case-insensitive-p regex)
430
                       (non-greedy-constant-length-closure
431
                        (*string*-equal str curr-pos (+ curr-pos len) 0 len))
432
                       (non-greedy-constant-length-closure
433
                        (*string*= str curr-pos (+ curr-pos len) 0 len))))))
434
               (char-class
435
                 ;; a character class
436
                 (insert-char-class-tester (regex (schar *string* curr-pos))
437
                   (non-greedy-constant-length-closure
438
                    (char-class-test))))
439
               (everything
440
                 (if (single-line-p regex)
441
                   ;; a dot which really can match everything; we rely
442
                   ;; on the compiler to optimize this away
443
                   (non-greedy-constant-length-closure
444
                    t)
445
                   ;; a dot which has to watch out for #\Newline
446
                   (non-greedy-constant-length-closure
447
                    (char/= #\Newline (schar *string* curr-pos)))))
448
               (t
449
                 ;; the general case - we build an inner matcher which
450
                 ;; just checks for immediate success, i.e. NEXT-FN is
451
                 ;; #'IDENTITY
452
                 (let ((inner-matcher (create-matcher-aux regex #'identity)))
453
                   (declare (function inner-matcher))
454
                   (non-greedy-constant-length-closure
455
                    (funcall inner-matcher curr-pos)))))))))
456
 
457
 (defgeneric create-non-greedy-no-zero-matcher (repetition next-fn)
458
   (declare #.*standard-optimize-settings*)
459
   (:documentation "Creates a closure which tries to match REPETITION.
460
 It is assumed that REPETITION is non-greedy and the minimal number of
461
 repetitions is zero.  It is furthermore assumed that the inner regex
462
 of REPETITION can never match a zero-length string \(or instead the
463
 maximal number of repetitions is 1)."))
464
 
465
 (defmethod create-non-greedy-no-zero-matcher ((repetition repetition) next-fn)
466
   (declare #.*standard-optimize-settings*)
467
   (let ((maximum (maximum repetition))
468
         ;; REPEAT-MATCHER is part of the closure's environment but it
469
         ;; can only be defined after NON-GREEDY-AUX is defined
470
         repeat-matcher)
471
     (declare (function next-fn))
472
     (cond
473
       ((eql maximum 1)
474
         ;; this is essentially like the next case but with a known
475
         ;; MAXIMUM of 1 we can get away without a counter
476
         (setq repeat-matcher
477
                 (create-matcher-aux (regex repetition) next-fn))
478
         (lambda (start-pos)
479
           (declare (function repeat-matcher))
480
           (or (funcall next-fn start-pos)
481
               (funcall repeat-matcher start-pos))))
482
       (maximum
483
         ;; we make a reservation for our slot in *REPEAT-COUNTERS*
484
         ;; because we need to keep track whether we've reached MAXIMUM
485
         ;; repetitions
486
         (let ((rep-num (incf-after *rep-num*)))
487
           (flet ((non-greedy-aux (start-pos)
488
                    ;; the actual matcher which first calls NEXT-FN and
489
                    ;; on failure tries to match the inner regex of
490
                    ;; REPETITION (if we haven't done so too often)
491
                    (declare (fixnum start-pos maximum rep-num)
492
                             (function repeat-matcher))
493
                    (or (funcall next-fn start-pos)
494
                        (and (< (aref *repeat-counters* rep-num) maximum)
495
                             (incf (aref *repeat-counters* rep-num))
496
                             ;; note that REPEAT-MATCHER will call
497
                             ;; NON-GREEDY-AUX again recursively
498
                             (prog1
499
                               (funcall repeat-matcher start-pos)
500
                               (decf (aref *repeat-counters* rep-num)))))))
501
             ;; create a closure to match the inner regex and to
502
             ;; implement backtracking via NON-GREEDY-AUX
503
             (setq repeat-matcher
504
                     (create-matcher-aux (regex repetition) #'non-greedy-aux))
505
             ;; the closure we return is just a thin wrapper around
506
             ;; NON-GREEDY-AUX to initialize the repetition counter
507
             (lambda (start-pos)
508
               (declare (fixnum start-pos))
509
               (setf (aref *repeat-counters* rep-num) 0)
510
               (non-greedy-aux start-pos)))))
511
       (t
512
         ;; easier code because we're not bounded by MAXIMUM, but
513
         ;; basically the same
514
         (flet ((non-greedy-aux (start-pos)
515
                  (declare (fixnum start-pos)
516
                           (function repeat-matcher))
517
                  (or (funcall next-fn start-pos)
518
                      (funcall repeat-matcher start-pos))))
519
           (setq repeat-matcher
520
                   (create-matcher-aux (regex repetition) #'non-greedy-aux))
521
           #'non-greedy-aux)))))
522
   
523
 (defgeneric create-non-greedy-matcher (repetition next-fn)
524
   (declare #.*standard-optimize-settings*)
525
   (:documentation "Creates a closure which tries to match REPETITION.
526
 It is assumed that REPETITION is non-greedy and the minimal number of
527
 repetitions is zero."))
528
 
529
 (defmethod create-non-greedy-matcher ((repetition repetition) next-fn)
530
   (declare #.*standard-optimize-settings*)
531
   ;; we make a reservation for our slot in *LAST-POS-STORES* because
532
   ;; we have to watch out for endless loops as the inner regex might
533
   ;; match zero-length strings
534
   (let ((zero-length-num (incf-after *zero-length-num*))
535
         (maximum (maximum repetition))
536
         ;; REPEAT-MATCHER is part of the closure's environment but it
537
         ;; can only be defined after NON-GREEDY-AUX is defined
538
         repeat-matcher)
539
     (declare (fixnum zero-length-num)
540
              (function next-fn))
541
     (cond
542
       (maximum
543
         ;; we make a reservation for our slot in *REPEAT-COUNTERS*
544
         ;; because we need to keep track whether we've reached MAXIMUM
545
         ;; repetitions
546
         (let ((rep-num (incf-after *rep-num*)))
547
           (flet ((non-greedy-aux (start-pos)
548
                    ;; the actual matcher which first calls NEXT-FN and
549
                    ;; on failure tries to match the inner regex of
550
                    ;; REPETITION (if we haven't done so too often)
551
                    (declare (fixnum start-pos maximum rep-num)
552
                             (function repeat-matcher))
553
                    (let ((old-last-pos
554
                            (svref *last-pos-stores* zero-length-num)))
555
                      (when (and old-last-pos
556
                                 (= (the fixnum old-last-pos) start-pos))
557
                        ;; stop immediately if we've been here before,
558
                        ;; i.e. if the last attempt matched a zero-length
559
                        ;; string
560
                        (return-from non-greedy-aux (funcall next-fn start-pos)))
561
                      ;; otherwise remember this position for the next
562
                      ;; repetition
563
                      (setf (svref *last-pos-stores* zero-length-num) start-pos)
564
                      (or (funcall next-fn start-pos)
565
                          (and (< (aref *repeat-counters* rep-num) maximum)
566
                               (incf (aref *repeat-counters* rep-num))
567
                               ;; note that REPEAT-MATCHER will call
568
                               ;; NON-GREEDY-AUX again recursively
569
                               (prog1
570
                                 (funcall repeat-matcher start-pos)
571
                                 (decf (aref *repeat-counters* rep-num))
572
                                 (setf (svref *last-pos-stores* zero-length-num)
573
                                         old-last-pos)))))))
574
             ;; create a closure to match the inner regex and to
575
             ;; implement backtracking via NON-GREEDY-AUX
576
             (setq repeat-matcher
577
                     (create-matcher-aux (regex repetition) #'non-greedy-aux))
578
             ;; the closure we return is just a thin wrapper around
579
             ;; NON-GREEDY-AUX to initialize the repetition counter and our
580
             ;; slot in *LAST-POS-STORES*
581
             (lambda (start-pos)
582
               (declare (fixnum start-pos))
583
               (setf (aref *repeat-counters* rep-num) 0
584
                     (svref *last-pos-stores* zero-length-num) nil)
585
               (non-greedy-aux start-pos)))))
586
       (t
587
         ;; easier code because we're not bounded by MAXIMUM, but
588
         ;; basically the same
589
         (flet ((non-greedy-aux (start-pos)
590
                  (declare (fixnum start-pos)
591
                           (function repeat-matcher))
592
                  (let ((old-last-pos
593
                          (svref *last-pos-stores* zero-length-num)))
594
                    (when (and old-last-pos
595
                               (= (the fixnum old-last-pos) start-pos))
596
                      (return-from non-greedy-aux (funcall next-fn start-pos)))
597
                    (setf (svref *last-pos-stores* zero-length-num) start-pos)
598
                    (or (funcall next-fn start-pos)
599
                        (prog1
600
                          (funcall repeat-matcher start-pos)
601
                          (setf (svref *last-pos-stores* zero-length-num)
602
                                  old-last-pos))))))
603
           (setq repeat-matcher
604
                   (create-matcher-aux (regex repetition) #'non-greedy-aux))
605
           (lambda (start-pos)
606
             (declare (fixnum start-pos))
607
             (setf (svref *last-pos-stores* zero-length-num) nil)
608
             (non-greedy-aux start-pos)))))))
609
   
610
 ;; code for constant repetitions, i.e. those with a fixed number of repetitions
611
                       
612
 (defmacro constant-repetition-constant-length-closure (check-curr-pos)
613
   "This is the template for simple constant repetitions (where simple
614
 means that the inner regex to be checked is of fixed length LEN, and
615
 that it doesn't contain registers, i.e. there's no need for
616
 backtracking) and where constant means that MINIMUM is equal to
617
 MAXIMUM.  CHECK-CURR-POS is a form which checks whether the inner
618
 regex of the repetition matches at CURR-POS."
619
   `(lambda (start-pos)
620
     (declare (fixnum start-pos))
621
       (let ((target-end-pos (+ start-pos
622
                                (the fixnum (* len repetitions)))))
623
         (declare (fixnum target-end-pos))
624
         ;; first check if we won't go beyond the end of the string
625
         (and (>= *end-pos* target-end-pos)
626
              ;; then loop through all repetitions step by step
627
              (loop for curr-pos of-type fixnum from start-pos
628
                                                below target-end-pos
629
                                                by len
630
                    always ,check-curr-pos)
631
              ;; finally call NEXT-FN if we made it that far
632
              (funcall next-fn target-end-pos)))))
633
 
634
 (defgeneric create-constant-repetition-constant-length-matcher
635
     (repetition next-fn)
636
   (declare #.*standard-optimize-settings*)
637
   (:documentation "Creates a closure which tries to match REPETITION.
638
 It is assumed that REPETITION has a constant number of repetitions.
639
 It is furthermore assumed that the inner regex of REPETITION is of
640
 fixed length and doesn't contain registers."))
641
 
642
 (defmethod create-constant-repetition-constant-length-matcher
643
        ((repetition repetition) next-fn)
644
   (declare #.*standard-optimize-settings*)
645
   (let ((len (len repetition))
646
         (repetitions (minimum repetition))
647
         (regex (regex repetition)))
648
     (declare (fixnum len repetitions)
649
              (function next-fn))
650
     (if (zerop len)
651
       ;; if the length is zero it suffices to try once
652
       (create-matcher-aux regex next-fn)
653
       ;; otherwise try to optimize for a couple of common cases
654
       (typecase regex
655
         (str
656
           (let ((str (str regex)))
657
             (if (= 1 len)
658
               ;; a single character
659
               (let ((chr (schar str 0)))
660
                 (if (case-insensitive-p regex)
661
                   (constant-repetition-constant-length-closure
662
                    (and (char-equal chr (schar *string* curr-pos))
663
                         (1+ curr-pos)))
664
                   (constant-repetition-constant-length-closure
665
                    (and (char= chr (schar *string* curr-pos))
666
                         (1+ curr-pos)))))
667
               ;; a string
668
               (if (case-insensitive-p regex)
669
                 (constant-repetition-constant-length-closure
670
                  (let ((next-pos (+ curr-pos len)))
671
                    (declare (fixnum next-pos))
672
                    (and (*string*-equal str curr-pos next-pos 0 len)
673
                         next-pos)))
674
                 (constant-repetition-constant-length-closure
675
                  (let ((next-pos (+ curr-pos len)))
676
                    (declare (fixnum next-pos))
677
                    (and (*string*= str curr-pos next-pos 0 len)
678
                         next-pos)))))))
679
         (char-class
680
           ;; a character class
681
           (insert-char-class-tester (regex (schar *string* curr-pos))
682
             (constant-repetition-constant-length-closure
683
              (and (char-class-test)
684
                   (1+ curr-pos)))))
685
         (everything
686
           (if (single-line-p regex)
687
             ;; a dot which really matches everything - we just have to
688
             ;; advance the index into *STRING* accordingly and check
689
             ;; if we didn't go past the end
690
             (lambda (start-pos)
691
               (declare (fixnum start-pos))
692
               (let ((next-pos (+ start-pos repetitions)))
693
                 (declare (fixnum next-pos))
694
                 (and (<= next-pos *end-pos*)
695
                      (funcall next-fn next-pos))))
696
             ;; a dot which is not in single-line-mode - make sure we
697
             ;; don't match #\Newline
698
             (constant-repetition-constant-length-closure
699
              (and (char/= #\Newline (schar *string* curr-pos))
700
                   (1+ curr-pos)))))
701
         (t
702
           ;; the general case - we build an inner matcher which just
703
           ;; checks for immediate success, i.e. NEXT-FN is #'IDENTITY
704
           (let ((inner-matcher (create-matcher-aux regex #'identity)))
705
             (declare (function inner-matcher))
706
             (constant-repetition-constant-length-closure
707
              (funcall inner-matcher curr-pos))))))))
708
   
709
 (defgeneric create-constant-repetition-matcher (repetition next-fn)
710
   (declare #.*standard-optimize-settings*)
711
   (:documentation "Creates a closure which tries to match REPETITION.
712
 It is assumed that REPETITION has a constant number of repetitions."))
713
 
714
 (defmethod create-constant-repetition-matcher ((repetition repetition) next-fn)
715
   (declare #.*standard-optimize-settings*)
716
   (let ((repetitions (minimum repetition))
717
         ;; we make a reservation for our slot in *REPEAT-COUNTERS*
718
         ;; because we need to keep track of the number of repetitions
719
         (rep-num (incf-after *rep-num*))
720
         ;; REPEAT-MATCHER is part of the closure's environment but it
721
         ;; can only be defined after NON-GREEDY-AUX is defined
722
         repeat-matcher)
723
     (declare (fixnum repetitions rep-num)
724
              (function next-fn))
725
     (if (zerop (min-len repetition))
726
       ;; we make a reservation for our slot in *LAST-POS-STORES*
727
       ;; because we have to watch out for needless loops as the inner
728
       ;; regex might match zero-length strings
729
       (let ((zero-length-num (incf-after *zero-length-num*)))
730
         (declare (fixnum zero-length-num))
731
         (flet ((constant-aux (start-pos)
732
                  ;; the actual matcher which first calls NEXT-FN and
733
                  ;; on failure tries to match the inner regex of
734
                  ;; REPETITION (if we haven't done so too often)
735
                  (declare (fixnum start-pos)
736
                           (function repeat-matcher))
737
                  (let ((old-last-pos
738
                          (svref *last-pos-stores* zero-length-num)))
739
                    (when (and old-last-pos
740
                               (= (the fixnum old-last-pos) start-pos))
741
                      ;; if we've been here before we matched a
742
                      ;; zero-length string the last time, so we can
743
                      ;; just carry on because we will definitely be
744
                      ;; able to do this again often enough
745
                      (return-from constant-aux (funcall next-fn start-pos)))
746
                    ;; otherwise remember this position for the next
747
                    ;; repetition
748
                    (setf (svref *last-pos-stores* zero-length-num) start-pos)
749
                    (cond ((< (aref *repeat-counters* rep-num) repetitions)
750
                            ;; not enough repetitions yet, try it again
751
                            (incf (aref *repeat-counters* rep-num))
752
                            ;; note that REPEAT-MATCHER will call
753
                            ;; CONSTANT-AUX again recursively
754
                            (prog1
755
                              (funcall repeat-matcher start-pos)
756
                              (decf (aref *repeat-counters* rep-num))
757
                              (setf (svref *last-pos-stores* zero-length-num)
758
                                      old-last-pos)))
759
                          (t
760
                            ;; we're done - call NEXT-FN
761
                            (funcall next-fn start-pos))))))
762
           ;; create a closure to match the inner regex and to
763
           ;; implement backtracking via CONSTANT-AUX
764
           (setq repeat-matcher
765
                   (create-matcher-aux (regex repetition) #'constant-aux))
766
           ;; the closure we return is just a thin wrapper around
767
           ;; CONSTANT-AUX to initialize the repetition counter
768
           (lambda (start-pos)
769
             (declare (fixnum start-pos))
770
             (setf (aref *repeat-counters* rep-num) 0
771
                   (aref *last-pos-stores* zero-length-num) nil)
772
             (constant-aux start-pos))))
773
       ;; easier code because we don't have to care about zero-length
774
       ;; matches but basically the same
775
       (flet ((constant-aux (start-pos)
776
                (declare (fixnum start-pos)
777
                         (function repeat-matcher))
778
                (cond ((< (aref *repeat-counters* rep-num) repetitions)
779
                        (incf (aref *repeat-counters* rep-num))
780
                        (prog1
781
                          (funcall repeat-matcher start-pos)
782
                          (decf (aref *repeat-counters* rep-num))))
783
                      (t (funcall next-fn start-pos)))))
784
         (setq repeat-matcher
785
                 (create-matcher-aux (regex repetition) #'constant-aux))
786
         (lambda (start-pos)
787
           (declare (fixnum start-pos))
788
           (setf (aref *repeat-counters* rep-num) 0)
789
           (constant-aux start-pos))))))
790
   
791
 ;; the actual CREATE-MATCHER-AUX method for REPETITION objects which
792
 ;; utilizes all the functions and macros defined above
793
 
794
 (defmethod create-matcher-aux ((repetition repetition) next-fn)
795
   (declare #.*standard-optimize-settings*)
796
   (with-slots (minimum maximum len min-len greedyp contains-register-p)
797
       repetition
798
     (cond ((and maximum
799
                 (zerop maximum))
800
            ;; this should have been optimized away by CONVERT but just
801
            ;; in case...
802
            (error "Got REPETITION with MAXIMUM 0 \(should not happen)"))
803
           ((and maximum
804
                 (= minimum maximum 1))
805
            ;; this should have been optimized away by CONVERT but just
806
            ;; in case...
807
            (error "Got REPETITION with MAXIMUM 1 and MINIMUM 1 \(should not happen)"))
808
           ((and (eql minimum maximum)
809
                 len
810
                 (not contains-register-p))
811
            (create-constant-repetition-constant-length-matcher repetition next-fn))
812
           ((eql minimum maximum)
813
            (create-constant-repetition-matcher repetition next-fn))
814
           ((and greedyp
815
                 len
816
                 (not contains-register-p))
817
            (create-greedy-constant-length-matcher repetition next-fn))
818
           ((and greedyp
819
                 (or (plusp min-len)
820
                     (eql maximum 1)))
821
            (create-greedy-no-zero-matcher repetition next-fn))
822
           (greedyp
823
            (create-greedy-matcher repetition next-fn))
824
           ((and len
825
                 (plusp len)
826
                 (not contains-register-p))
827
            (create-non-greedy-constant-length-matcher repetition next-fn))
828
           ((or (plusp min-len)
829
                (eql maximum 1))
830
            (create-non-greedy-no-zero-matcher repetition next-fn))
831
           (t
832
            (create-non-greedy-matcher repetition next-fn)))))