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

KindCoveredAll%
expression464499 93.0
branch5972 81.9
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/optimize.lisp,v 1.26 2005/04/13 15:35:57 edi Exp $
3
 
4
 ;;; This file contains optimizations which can be applied to converted
5
 ;;; parse trees.
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
 (defgeneric flatten (regex)
36
   (declare #.*standard-optimize-settings*)
37
   (:documentation "Merges adjacent sequences and alternations, i.e. it
38
 transforms #<SEQ #<STR \"a\"> #<SEQ #<STR \"b\"> #<STR \"c\">>> to
39
 #<SEQ #<STR \"a\"> #<STR \"b\"> #<STR \"c\">>. This is a destructive
40
 operation on REGEX."))
41
 
42
 (defmethod flatten ((seq seq))
43
   ;; this looks more complicated than it is because we modify SEQ in
44
   ;; place to avoid unnecessary consing
45
   (let ((elements-rest (elements seq)))
46
     (loop
47
       (unless elements-rest
48
         (return))
49
       (let ((flattened-element (flatten (car elements-rest)))
50
             (next-elements-rest (cdr elements-rest)))
51
         (cond ((typep flattened-element 'seq)
52
                 ;; FLATTENED-ELEMENT is a SEQ object, so we "splice"
53
                 ;; it into out list of elements
54
                 (let ((flattened-element-elements
55
                         (elements flattened-element)))
56
                   (setf (car elements-rest)
57
                           (car flattened-element-elements)
58
                         (cdr elements-rest)
59
                           (nconc (cdr flattened-element-elements)
60
                                  (cdr elements-rest)))))
61
               (t
62
                 ;; otherwise we just replace the current element with
63
                 ;; its flattened counterpart
64
                 (setf (car elements-rest) flattened-element)))
65
         (setq elements-rest next-elements-rest))))
66
   (let ((elements (elements seq)))
67
     (cond ((cadr elements)
68
             seq)
69
           ((cdr elements)
70
             (first elements))
71
           (t (make-instance 'void)))))
72
 
73
 (defmethod flatten ((alternation alternation))
74
   ;; same algorithm as above
75
   (let ((choices-rest (choices alternation)))
76
     (loop
77
       (unless choices-rest
78
         (return))
79
       (let ((flattened-choice (flatten (car choices-rest)))
80
             (next-choices-rest (cdr choices-rest)))
81
         (cond ((typep flattened-choice 'alternation)
82
                 (let ((flattened-choice-choices
83
                         (choices flattened-choice)))
84
                   (setf (car choices-rest)
85
                           (car flattened-choice-choices)
86
                         (cdr choices-rest)
87
                           (nconc (cdr flattened-choice-choices)
88
                                  (cdr choices-rest)))))
89
               (t
90
                 (setf (car choices-rest) flattened-choice)))
91
         (setq choices-rest next-choices-rest))))
92
   (let ((choices (choices alternation)))
93
     (cond ((cadr choices)
94
             alternation)
95
           ((cdr choices)
96
             (first choices))
97
           (t (signal-ppcre-syntax-error
98
               "Encountered alternation without choices.")))))
99
 
100
 (defmethod flatten ((branch branch))
101
   (with-slots ((test test)
102
                (then-regex then-regex)
103
                (else-regex else-regex))
104
       branch
105
     (setq test
106
             (if (numberp test)
107
               test
108
               (flatten test))
109
           then-regex (flatten then-regex)
110
           else-regex (flatten else-regex))
111
     branch))
112
 
113
 (defmethod flatten ((regex regex))
114
   (typecase regex
115
     ((or repetition register lookahead lookbehind standalone)
116
       ;; if REGEX contains exactly one inner REGEX object flatten it
117
       (setf (regex regex)
118
               (flatten (regex regex)))
119
       regex)
120
     (t
121
       ;; otherwise (ANCHOR, BACK-REFERENCE, CHAR-CLASS, EVERYTHING,
122
       ;; LOOKAHEAD, LOOKBEHIND, STR, VOID, FILTER, and WORD-BOUNDARY)
123
       ;; do nothing
124
       regex)))
125
 
126
 (defgeneric gather-strings (regex)
127
     (declare #.*standard-optimize-settings*)
128
   (:documentation "Collects adjacent strings or characters into one
129
 string provided they have the same case mode. This is a destructive
130
 operation on REGEX."))
131
 
132
 (defmethod gather-strings ((seq seq))
133
   ;; note that GATHER-STRINGS is to be applied after FLATTEN, i.e. it
134
   ;; expects SEQ to be flattened already; in particular, SEQ cannot be
135
   ;; empty and cannot contain embedded SEQ objects
136
   (let* ((start-point (cons nil (elements seq)))
137
          (curr-point start-point)
138
          old-case-mode
139
          collector
140
          collector-start
141
          (collector-length 0)
142
          skip)
143
     (declare (type fixnum collector-length))
144
     (loop
145
       (let ((elements-rest (cdr curr-point)))
146
         (unless elements-rest
147
           (return))
148
         (let* ((element (car elements-rest))
149
                (case-mode (case-mode element old-case-mode)))
150
           (cond ((and case-mode
151
                       (eq case-mode old-case-mode))
152
                   ;; if ELEMENT is a STR and we have collected a STR of
153
                   ;; the same case mode in the last iteration we
154
                   ;; concatenate ELEMENT onto COLLECTOR and remember the
155
                   ;; value of its SKIP slot
156
                   (let ((old-collector-length collector-length))
157
                     (unless (and (adjustable-array-p collector)
158
                                  (array-has-fill-pointer-p collector))
159
                       (setq collector
160
                               (make-array collector-length
161
                                           :initial-contents collector
162
                                           :element-type 'character
163
                                           :fill-pointer t
164
                                           :adjustable t)
165
                             collector-start nil))
166
                     (adjust-array collector
167
                                   (incf collector-length (len element))
168
                                   :fill-pointer t)
169
                     (setf (subseq collector
170
                                   old-collector-length)
171
                             (str element)
172
                           ;; it suffices to remember the last SKIP slot
173
                           ;; because due to the way MAYBE-ACCUMULATE
174
                           ;; works adjacent STR objects have the same
175
                           ;; SKIP value
176
                           skip (skip element)))
177
                   (setf (cdr curr-point) (cdr elements-rest)))
178
                 (t
179
                   (let ((collected-string
180
                           (cond (collector-start
181
                                   collector-start)
182
                                 (collector
183
                                   ;; if we have collected something already
184
                                   ;; we convert it into a STR
185
                                   (make-instance 'str
186
                                                  :skip skip
187
                                                  :str collector
188
                                                  :case-insensitive-p
189
                                                  (eq old-case-mode
190
                                                      :case-insensitive)))
191
                                 (t nil))))
192
                     (cond (case-mode
193
                             ;; if ELEMENT is a string with a different case
194
                             ;; mode than the last one we have either just
195
                             ;; converted COLLECTOR into a STR or COLLECTOR
196
                             ;; is still empty; in both cases we can now
197
                             ;; begin to fill it anew
198
                             (setq collector (str element)
199
                                   collector-start element
200
                                   ;; and we remember the SKIP value as above
201
                                   skip (skip element)
202
                                   collector-length (len element))
203
                             (cond (collected-string
204
                                     (setf (car elements-rest)
205
                                             collected-string
206
                                           curr-point
207
                                             (cdr curr-point)))
208
                                   (t
209
                                     (setf (cdr curr-point)
210
                                             (cdr elements-rest)))))
211
                           (t
212
                             ;; otherwise this is not a STR so we apply
213
                             ;; GATHER-STRINGS to it and collect it directly
214
                             ;; into RESULT
215
                             (cond (collected-string
216
                                     (setf (car elements-rest)
217
                                             collected-string
218
                                           curr-point
219
                                             (cdr curr-point)
220
                                           (cdr curr-point)
221
                                             (cons (gather-strings element)
222
                                                   (cdr curr-point))
223
                                           curr-point
224
                                             (cdr curr-point)))
225
                                   (t
226
                                     (setf (car elements-rest)
227
                                             (gather-strings element)
228
                                           curr-point
229
                                             (cdr curr-point))))
230
                             ;; we also have to empty COLLECTOR here in case
231
                             ;; it was still filled from the last iteration
232
                             (setq collector nil
233
                                   collector-start nil))))))
234
           (setq old-case-mode case-mode))))
235
     (when collector
236
       (setf (cdr curr-point)
237
               (cons
238
                (make-instance 'str
239
                               :skip skip
240
                               :str collector
241
                               :case-insensitive-p
242
                               (eq old-case-mode
243
                                   :case-insensitive))
244
                nil)))
245
     (setf (elements seq) (cdr start-point))
246
     seq))
247
 
248
 (defmethod gather-strings ((alternation alternation))
249
   ;; loop ON the choices of ALTERNATION so we can modify them directly
250
   (loop for choices-rest on (choices alternation)
251
         while choices-rest
252
         do (setf (car choices-rest)
253
                    (gather-strings (car choices-rest))))
254
   alternation)
255
 
256
 (defmethod gather-strings ((branch branch))
257
   (with-slots ((test test)
258
                (then-regex then-regex)
259
                (else-regex else-regex))
260
       branch
261
     (setq test
262
             (if (numberp test)
263
               test
264
               (gather-strings test))
265
           then-regex (gather-strings then-regex)
266
           else-regex (gather-strings else-regex))
267
     branch))
268
 
269
 (defmethod gather-strings ((regex regex))
270
   (typecase regex
271
     ((or repetition register lookahead lookbehind standalone)
272
       ;; if REGEX contains exactly one inner REGEX object apply
273
       ;; GATHER-STRINGS to it
274
       (setf (regex regex)
275
               (gather-strings (regex regex)))
276
       regex)
277
     (t
278
       ;; otherwise (ANCHOR, BACK-REFERENCE, CHAR-CLASS, EVERYTHING,
279
       ;; LOOKAHEAD, LOOKBEHIND, STR, VOID, FILTER, and WORD-BOUNDARY)
280
       ;; do nothing
281
       regex)))
282
 
283
 ;; Note that START-ANCHORED-P will be called after FLATTEN and GATHER-STRINGS.
284
 
285
 (defgeneric start-anchored-p (regex &optional in-seq-p)
286
     (declare #.*standard-optimize-settings*)
287
   (:documentation "Returns T if REGEX starts with a \"real\" start
288
 anchor, i.e. one that's not in multi-line mode, NIL otherwise. If
289
 IN-SEQ-P is true the function will return :ZERO-LENGTH if REGEX is a
290
 zero-length assertion."))
291
 
292
 (defmethod start-anchored-p ((seq seq) &optional in-seq-p)
293
   (declare (ignore in-seq-p))
294
   ;; note that START-ANCHORED-P is to be applied after FLATTEN and
295
   ;; GATHER-STRINGS, i.e. SEQ cannot be empty and cannot contain
296
   ;; embedded SEQ objects
297
   (loop for element in (elements seq)
298
         for anchored-p = (start-anchored-p element t)
299
         ;; skip zero-length elements because they won't affect the
300
         ;; "anchoredness" of the sequence
301
         while (eq anchored-p :zero-length)
302
         finally (return (and anchored-p (not (eq anchored-p :zero-length))))))
303
 
304
 (defmethod start-anchored-p ((alternation alternation) &optional in-seq-p)
305
   (declare (ignore in-seq-p))
306
   ;; clearly an alternation can only be start-anchored if all of its
307
   ;; choices are start-anchored
308
   (loop for choice in (choices alternation)
309
         always (start-anchored-p choice)))
310
 
311
 (defmethod start-anchored-p ((branch branch) &optional in-seq-p)
312
   (declare (ignore in-seq-p))
313
   (and (start-anchored-p (then-regex branch))
314
        (start-anchored-p (else-regex branch))))
315
 
316
 (defmethod start-anchored-p ((repetition repetition) &optional in-seq-p)
317
   (declare (ignore in-seq-p))
318
   ;; well, this wouldn't make much sense, but anyway...
319
   (and (plusp (minimum repetition))
320
        (start-anchored-p (regex repetition))))
321
 
322
 (defmethod start-anchored-p ((register register) &optional in-seq-p)
323
   (declare (ignore in-seq-p))
324
   (start-anchored-p (regex register)))
325
 
326
 (defmethod start-anchored-p ((standalone standalone) &optional in-seq-p)
327
   (declare (ignore in-seq-p))
328
   (start-anchored-p (regex standalone)))
329
 
330
 (defmethod start-anchored-p ((anchor anchor) &optional in-seq-p)
331
   (declare (ignore in-seq-p))
332
   (and (startp anchor)
333
        (not (multi-line-p anchor))))
334
 
335
 (defmethod start-anchored-p ((regex regex) &optional in-seq-p)
336
   (typecase regex
337
     ((or lookahead lookbehind word-boundary void)
338
       ;; zero-length assertions
339
       (if in-seq-p
340
         :zero-length
341
         nil))
342
     (filter
343
       (if (and in-seq-p
344
                (len regex)
345
                (zerop (len regex)))
346
         :zero-length
347
         nil))
348
     (t
349
       ;; BACK-REFERENCE, CHAR-CLASS, EVERYTHING, and STR
350
       nil)))
351
 
352
 ;; Note that END-STRING-AUX will be called after FLATTEN and GATHER-STRINGS.
353
 
354
 (defgeneric end-string-aux (regex &optional old-case-insensitive-p)
355
     (declare #.*standard-optimize-settings*)
356
   (:documentation "Returns the constant string (if it exists) REGEX
357
 ends with wrapped into a STR object, otherwise NIL.
358
 OLD-CASE-INSENSITIVE-P is the CASE-INSENSITIVE-P slot of the last STR
359
 collected or :VOID if no STR has been collected yet. (This is a helper
360
 function called by END-STRIN.)"))
361
 
362
 (defmethod end-string-aux ((str str)
363
                            &optional (old-case-insensitive-p :void))
364
   (declare (special last-str))
365
   (cond ((and (not (skip str))          ; avoid constituents of STARTS-WITH
366
               ;; only use STR if nothing has been collected yet or if
367
               ;; the collected string has the same value for
368
               ;; CASE-INSENSITIVE-P
369
               (or (eq old-case-insensitive-p :void)
370
                   (eq (case-insensitive-p str) old-case-insensitive-p)))
371
           (setf last-str str
372
                 ;; set the SKIP property of this STR
373
                 (skip str) t)
374
           str)
375
         (t nil)))
376
 
377
 (defmethod end-string-aux ((seq seq)
378
                            &optional (old-case-insensitive-p :void))
379
   (declare (special continuep))
380
   (let (case-insensitive-p
381
         concatenated-string
382
         concatenated-start
383
         (concatenated-length 0))
384
     (declare (type fixnum concatenated-length))
385
     (loop for element in (reverse (elements seq))
386
           ;; remember the case-(in)sensitivity of the last relevant
387
           ;; STR object
388
           for loop-old-case-insensitive-p = old-case-insensitive-p
389
             then (if skip
390
                    loop-old-case-insensitive-p
391
                    (case-insensitive-p element-end))
392
           ;; the end-string of the current element
393
           for element-end = (end-string-aux element
394
                                             loop-old-case-insensitive-p)
395
           ;; whether we encountered a zero-length element
396
           for skip = (if element-end
397
                        (zerop (len element-end))
398
                        nil)
399
           ;; set CONTINUEP to NIL if we have to stop collecting to
400
           ;; alert END-STRING-AUX methods on enclosing SEQ objects
401
           unless element-end
402
             do (setq continuep nil)
403
           ;; end loop if we neither got a STR nor a zero-length
404
           ;; element
405
           while element-end
406
           ;; only collect if not zero-length
407
           unless skip
408
             do (cond (concatenated-string
409
                        (when concatenated-start
410
                          (setf concatenated-string
411
                                  (make-array concatenated-length
412
                                              :initial-contents (reverse (str concatenated-start))
413
                                              :element-type 'character
414
                                              :fill-pointer t
415
                                              :adjustable t)
416
                                concatenated-start nil))
417
                        (let ((len (len element-end))
418
                              (str (str element-end)))
419
                          (declare (type fixnum len))
420
                          (incf concatenated-length len)
421
                          (loop for i of-type fixnum downfrom (1- len) to 0
422
                                do (vector-push-extend (char str i)
423
                                                       concatenated-string))))
424
                      (t
425
                        (setf concatenated-string
426
                                t
427
                              concatenated-start
428
                                element-end
429
                              concatenated-length
430
                                (len element-end)
431
                              case-insensitive-p
432
                                (case-insensitive-p element-end))))
433
           ;; stop collecting if END-STRING-AUX on inner SEQ has said so
434
           while continuep)
435
     (cond ((zerop concatenated-length)
436
             ;; don't bother to return zero-length strings
437
             nil)
438
           (concatenated-start
439
             concatenated-start)
440
           (t
441
             (make-instance 'str
442
                            :str (nreverse concatenated-string)
443
                            :case-insensitive-p case-insensitive-p)))))
444
 
445
 (defmethod end-string-aux ((register register)
446
                            &optional (old-case-insensitive-p :void))
447
   (end-string-aux (regex register) old-case-insensitive-p))
448
     
449
 (defmethod end-string-aux ((standalone standalone)
450
                            &optional (old-case-insensitive-p :void))
451
   (end-string-aux (regex standalone) old-case-insensitive-p))
452
     
453
 (defmethod end-string-aux ((regex regex)
454
                            &optional (old-case-insensitive-p :void))
455
   (declare (special last-str end-anchored-p continuep))
456
   (typecase regex
457
     ((or anchor lookahead lookbehind word-boundary void)
458
       ;; a zero-length REGEX object - for the sake of END-STRING-AUX
459
       ;; this is a zero-length string
460
       (when (and (typep regex 'anchor)
461
                  (not (startp regex))
462
                  (or (no-newline-p regex)
463
                      (not (multi-line-p regex)))
464
                  (eq old-case-insensitive-p :void))
465
         ;; if this is a "real" end-anchor and we haven't collected
466
         ;; anything so far we can set END-ANCHORED-P (where 1 or 0
467
         ;; indicate whether we accept a #\Newline at the end or not)
468
         (setq end-anchored-p (if (no-newline-p regex) 0 1)))
469
       (make-instance 'str
470
                      :str ""
471
                      :case-insensitive-p :void))
472
     (t
473
       ;; (ALTERNATION, BACK-REFERENCE, BRANCH, CHAR-CLASS, EVERYTHING,
474
       ;; REPETITION, FILTER)
475
       nil)))
476
 
477
 (defgeneric end-string (regex)
478
   (declare #.*standard-optimize-settings*)
479
   (:documentation "Returns the constant string (if it exists) REGEX ends with wrapped
480
 into a STR object, otherwise NIL."))
481
 
482
 (defmethod end-string ((regex regex))
483
   (declare (special end-string-offset))
484
     (declare #.*standard-optimize-settings*)
485
   ;; LAST-STR points to the last STR object (seen from the end) that's
486
   ;; part of END-STRING; CONTINUEP is set to T if we stop collecting
487
   ;; in the middle of a SEQ
488
   (let ((continuep t)
489
         last-str)
490
     (declare (special continuep last-str))
491
     (prog1
492
       (end-string-aux regex)
493
       (when last-str
494
         ;; if we've found something set the START-OF-END-STRING-P of
495
         ;; the leftmost STR collected accordingly and remember the
496
         ;; OFFSET of this STR (in a special variable provided by the
497
         ;; caller of this function)
498
         (setf (start-of-end-string-p last-str) t
499
               end-string-offset (offset last-str))))))
500
 
501
 (defgeneric compute-min-rest (regex current-min-rest)
502
     (declare #.*standard-optimize-settings*)
503
   (:documentation "Returns the minimal length of REGEX plus
504
 CURRENT-MIN-REST. This is similar to REGEX-MIN-LENGTH except that it
505
 recurses down into REGEX and sets the MIN-REST slots of REPETITION
506
 objects."))
507
 
508
 (defmethod compute-min-rest ((seq seq) current-min-rest)
509
   (loop for element in (reverse (elements seq))
510
         for last-min-rest = current-min-rest then this-min-rest
511
         for this-min-rest = (compute-min-rest element last-min-rest)
512
         finally (return this-min-rest)))
513
     
514
 (defmethod compute-min-rest ((alternation alternation) current-min-rest)
515
   (loop for choice in (choices alternation)
516
         minimize (compute-min-rest choice current-min-rest)))
517
 
518
 (defmethod compute-min-rest ((branch branch) current-min-rest)
519
   (min (compute-min-rest (then-regex branch) current-min-rest)
520
        (compute-min-rest (else-regex branch) current-min-rest)))
521
 
522
 (defmethod compute-min-rest ((str str) current-min-rest)
523
   (+ current-min-rest (len str)))
524
     
525
 (defmethod compute-min-rest ((filter filter) current-min-rest)
526
   (+ current-min-rest (or (len filter) 0)))
527
     
528
 (defmethod compute-min-rest ((repetition repetition) current-min-rest)
529
   (setf (min-rest repetition) current-min-rest)
530
   (compute-min-rest (regex repetition) current-min-rest)
531
   (+ current-min-rest (* (minimum repetition) (min-len repetition))))
532
 
533
 (defmethod compute-min-rest ((register register) current-min-rest)
534
   (compute-min-rest (regex register) current-min-rest))
535
     
536
 (defmethod compute-min-rest ((standalone standalone) current-min-rest)
537
   (declare (ignore current-min-rest))
538
   (compute-min-rest (regex standalone) 0))
539
     
540
 (defmethod compute-min-rest ((lookahead lookahead) current-min-rest)
541
   (compute-min-rest (regex lookahead) 0)
542
   current-min-rest)
543
     
544
 (defmethod compute-min-rest ((lookbehind lookbehind) current-min-rest)
545
   (compute-min-rest (regex lookbehind) (+ current-min-rest (len lookbehind)))
546
   current-min-rest)
547
     
548
 (defmethod compute-min-rest ((regex regex) current-min-rest)
549
   (typecase regex
550
     ((or char-class everything)
551
       (1+ current-min-rest))
552
     (t
553
       ;; zero min-len and no embedded regexes (ANCHOR,
554
       ;; BACK-REFERENCE, VOID, and WORD-BOUNDARY)
555
       current-min-rest)))