source: project/chicken/trunk/irregex.scm @ 14377

Last change on this file since 14377 was 14377, checked in by Alex Shinn, 12 years ago

Adding bugfix from upstream to irregex-match-data?.

File size: 105.1 KB
Line 
1;;;; irregex.scm -- IrRegular Expressions
2;;
3;; Copyright (c) 2005-2008 Alex Shinn.  All rights reserved.
4;; BSD-style license: http://synthcode.com/license.txt
5
6;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7;; At this moment there was a loud ring at the bell, and I could
8;; hear Mrs. Hudson, our landlady, raising her voice in a wail of
9;; expostulation and dismay.
10;;
11;; "By heaven, Holmes," I said, half rising, "I believe that
12;; they are really after us."
13;;
14;; "No, it's not quite so bad as that.  It is the unofficial
15;; force, -- the Baker Street irregulars."
16
17;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
18;; History
19;;
20;; 0.6.2: 2008/07/26 - minor bugfixes, allow global disabling of utf8 mode,
21;;                     friendlier error messages in parsing, \Q..\E support
22;; 0.6.1: 2008/07/21 - added utf8 mode, more utils, bugfixes
23;;   0.6: 2008/05/01 - most of PCRE supported
24;;   0.5: 2008/04/24 - fully portable R4RS, many PCRE features implemented
25;;   0.4: 2008/04/17 - rewriting NFA to use efficient closure compilation,
26;;                     normal strings only, but all of the spencer tests pass
27;;   0.3: 2008/03/10 - adding DFA converter (normal strings only)
28;;   0.2: 2005/09/27 - adding irregex-opt (like elisp's regexp-opt) utility
29;;   0.1: 2005/08/18 - simple NFA interpreter over abstract chunked strings
30
31;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32
33(define irregex-tag '*irregex-tag*)
34
35(define (make-irregex dfa dfa/search dfa/extract nfa flags
36                      submatches lengths names)
37  (vector irregex-tag dfa dfa/search dfa/extract nfa flags
38          submatches lengths names))
39
40(define (irregex? obj)
41  (and (vector? obj)
42       (= 9 (vector-length obj))
43       (eq? irregex-tag (vector-ref obj 0))))
44
45(define (irregex-dfa x) (vector-ref x 1))
46(define (irregex-dfa/search x) (vector-ref x 2))
47(define (irregex-dfa/extract x) (vector-ref x 3))
48(define (irregex-nfa x) (vector-ref x 4))
49(define (irregex-flags x) (vector-ref x 5))
50(define (irregex-submatches x) (vector-ref x 6))
51(define (irregex-lengths x) (vector-ref x 7))
52(define (irregex-names x) (vector-ref x 8))
53
54(define (irregex-new-matches irx)
55  (make-irregex-match #f (irregex-submatches irx) (irregex-names irx)))
56(define (irregex-reset-matches! m)
57  (do ((i (- (vector-length m) 1) (- i 1)))
58      ((<= i 3) m)
59    (vector-set! m i #f)))
60
61(define irregex-match-tag '*irregex-match-tag*)
62
63(define (irregex-match-data? obj)
64  (and (vector? obj)
65       (>= (vector-length obj) 5)
66       (eq? irregex-match-tag (vector-ref obj 0))))
67
68(define (make-irregex-match str count names)
69  (let ((res (make-vector (+ (* 2 (+ 1 count)) 3) #f)))
70    (vector-set! res 0 irregex-match-tag)
71    (vector-set! res 1 str)
72    (vector-set! res 2 names)
73    res))
74
75(define (irregex-match-num-submatches m)
76  (- (quotient (- (vector-length m) 3) 2) 1))
77
78(define (irregex-match-string m)
79  (vector-ref m 1))
80(define (irregex-match-names m)
81  (vector-ref m 2))
82(define (irregex-match-string-set! m str)
83  (vector-set! m 1 str))
84
85(define (irregex-match-start-index m n)
86  (vector-ref m (+ 3 (* n 2))))
87(define (irregex-match-end-index m n)
88  (vector-ref m (+ 4 (* n 2))))
89
90(define (irregex-match-start-index-set! m n start)
91  (vector-set! m (+ 3 (* n 2)) start))
92(define (irregex-match-end-index-set! m n end)
93  (vector-set! m (+ 4 (* n 2)) end))
94
95(define (irregex-match-index m opt)
96  (if (pair? opt)
97      (cond ((number? (car opt)) (car opt))
98            ((assq (car opt) (irregex-match-names m)) => cdr)
99            (else (error "unknown match name" (car opt))))
100      0))
101
102(define (irregex-match-valid-index? m n)
103  (and (< (+ 3 (* n 2)) (vector-length m))
104       (vector-ref m (+ 4 (* n 2)))))
105
106(define (irregex-match-substring m . opt)
107  (let ((n (irregex-match-index m opt)))
108    (and (irregex-match-valid-index? m n)
109         (substring (irregex-match-string m)
110                    (vector-ref m (+ 3 (* n 2)))
111                    (vector-ref m (+ 4 (* n 2)))))))
112
113(define (irregex-match-start m . opt)
114  (let ((n (irregex-match-index m opt)))
115    (and (irregex-match-valid-index? m n)
116         (vector-ref m (+ 3 (* n 2))))))
117
118(define (irregex-match-end m . opt)
119  (irregex-match-valid-index? m (irregex-match-index m opt)))
120
121;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
122;; string utilities
123
124;;;; Unicode version (skip surrogates)
125(define *all-chars*
126  `(/ ,(integer->char 0) ,(integer->char #xD7FF)
127      ,(integer->char #xE000) ,(integer->char #x10FFFF)))
128
129;;;; ASCII version, offset to not assume 0-255
130;; (define *all-chars* `(/ ,(integer->char (- (char->integer #\space) 32)) ,(integer->char (+ (char->integer #\space) 223))))
131
132;; set to #f to ignore even an explicit request for utf8 handling
133(define *allow-utf8-mode?* #t)
134
135;; (define *named-char-properties* '())
136
137(define (string-scan-char str c . o)
138  (let ((end (string-length str)))
139    (let scan ((i (if (pair? o) (car o) 0)))
140      (cond ((= i end) #f)
141            ((eqv? c (string-ref str i)) i)
142            (else (scan (+ i 1)))))))
143
144(define (string-scan-char-escape str c . o)
145  (let ((end (string-length str)))
146    (let scan ((i (if (pair? o) (car o) 0)))
147      (cond ((= i end) #f)
148            ((eqv? c (string-ref str i)) i)
149            ((eqv? c #\\) (scan (+ i 2)))
150            (else (scan (+ i 1)))))))
151
152(define (string-scan-pred str pred . o)
153  (let ((end (string-length str)))
154    (let scan ((i (if (pair? o) (car o) 0)))
155      (cond ((= i end) #f)
156            ((pred (string-ref str i)) i)
157            (else (scan (+ i 1)))))))
158
159(define (string-split-char str c)
160  (let ((end (string-length str)))
161    (let lp ((i 0) (from 0) (res '()))
162      (define (collect) (cons (substring str from i) res))
163      (cond ((>= i end) (reverse (collect)))
164            ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (collect)))
165            (else (lp (+ i 1) from res))))))
166
167(define (char-alphanumeric? c)
168  (or (char-alphabetic? c) (char-numeric? c)))
169
170;; SRFI-13 extracts
171
172(define (%%string-copy! to tstart from fstart fend)
173  (do ((i fstart (+ i 1))
174       (j tstart (+ j 1)))
175      ((>= i fend))
176    (string-set! to j (string-ref from i))))
177
178(define (string-cat-reverse string-list)
179  (string-cat-reverse/aux
180   (fold (lambda (s a) (+ (string-length s) a)) 0 string-list)
181   string-list))
182
183(define (string-cat-reverse/aux len string-list)
184  (let ((res (make-string len)))
185    (let lp ((i len) (ls string-list))
186      (if (pair? ls)
187          (let* ((s (car ls))
188                 (slen (string-length s))
189                 (i (- i slen)))
190            (%%string-copy! res i s 0 slen)
191            (lp i (cdr ls)))))
192    res))
193
194;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
195;; list utilities
196
197;; like the one-arg IOTA case
198(define (zero-to n)
199  (if (<= n 0)
200      '()
201      (let lp ((i (- n 1)) (res '()))
202        (if (zero? i) (cons 0 res) (lp (- i 1) (cons i res))))))
203
204;; take the head of list FROM up to but not including TO, which must
205;; be a tail of the list
206(define (take-up-to from to)
207  (let lp ((ls from) (res '()))
208    (if (and (pair? ls) (not (eq? ls to)))
209        (lp (cdr ls) (cons (car ls) res))
210        (reverse res))))
211
212;; SRFI-1 extracts (simplified 1-ary versions)
213
214(define (find pred ls)
215  (cond ((find-tail pred ls) => car)
216        (else #f)))
217
218(define (find-tail pred ls)
219  (let lp ((ls ls))
220    (cond ((null? ls) #f)
221          ((pred (car ls)) ls)
222          (else (lp (cdr ls))))))
223
224(define (last ls)
225  (if (not (pair? ls))
226      (error "can't take last of empty list" ls)
227      (let lp ((ls ls))
228        (if (pair? (cdr ls))
229            (lp (cdr ls))
230            (car ls)))))
231
232(define (any pred ls)
233  (and (pair? ls)
234       (let lp ((head (car ls)) (tail (cdr ls)))
235         (if (null? tail)
236             (pred head)
237             (or (pred head) (lp (car tail) (cdr tail)))))))
238
239(define (every pred ls)
240  (or (null? ls)
241      (let lp ((head (car ls))  (tail (cdr ls)))
242        (if (null? tail)
243            (pred head)
244            (and (pred head) (lp (car tail) (cdr tail)))))))
245
246(define (fold kons knil ls)
247  (let lp ((ls ls) (res knil))
248    (if (null? ls)
249        res
250        (lp (cdr ls) (kons (car ls) res)))))
251
252(define (filter pred ls)
253  (let lp ((ls ls) (res '()))
254    (if (null? ls)
255        (reverse res)
256        (lp (cdr ls) (if (pred (car ls)) (cons (car ls) res) res)))))
257
258(define (remove pred ls)
259  (let lp ((ls ls) (res '()))
260    (if (null? ls)
261        (reverse res)
262        (lp (cdr ls) (if (pred (car ls)) res (cons (car ls) res))))))
263
264;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
265;; flags
266
267(define (bit-shr n i)
268  (quotient n (expt 2 i)))
269
270(define (bit-shl n i)
271  (* n (expt 2 i)))
272
273(define (bit-not n) (- #xFFFF n))
274
275(define (bit-ior a b)
276  (cond
277   ((zero? a) b)
278   ((zero? b) a)
279   (else
280    (+ (if (or (odd? a) (odd? b)) 1 0)
281       (* 2 (bit-ior (quotient a 2) (quotient b 2)))))))
282
283(define (bit-and a b)
284  (cond
285   ((zero? a) 0)
286   ((zero? b) 0)
287   (else
288    (+ (if (and (odd? a) (odd? b)) 1 0)
289       (* 2 (bit-and (quotient a 2) (quotient b 2)))))))
290
291(define (flag-set? flags i)
292  (= i (bit-and flags i)))
293(define (flag-join a b)
294  (if b (bit-ior a b) a))
295(define (flag-clear a b)
296  (bit-and a (bit-not b)))
297
298(define ~none 0)
299(define ~searcher? 1)
300(define ~consumer? 2)
301
302;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
303;; parsing
304
305(define ~save? 1)
306(define ~case-insensitive? 2)
307(define ~multi-line? 4)
308(define ~single-line? 8)
309(define ~ignore-space? 16)
310(define ~utf8? 32)
311
312(define (symbol-list->flags ls)
313  (let lp ((ls ls) (res ~none))
314    (if (not (pair? ls))
315        res
316        (lp (cdr ls)
317            (flag-join
318             res
319             (case (car ls)
320               ((i ci case-insensitive) ~case-insensitive?)
321               ((m multi-line) ~multi-line?)
322               ((s single-line) ~single-line?)
323               ((x ignore-space) ~ignore-space?)
324               ((u utf8) ~utf8?)
325               (else #f)))))))
326
327(define (string->sre str . o)
328  (let ((end (string-length str))
329        (flags (symbol-list->flags o)))
330
331    (let lp ((i 0) (from 0) (flags flags) (res '()) (st '()))
332
333      ;; handle case sensitivity at the literal char/string level
334      (define (cased-char ch)
335        (if (and (flag-set? flags ~case-insensitive?)
336                 (char-alphabetic? ch))
337            `(or ,ch ,(char-altcase ch))
338            ch))
339      (define (cased-string str)
340        (if (flag-set? flags ~case-insensitive?)
341            (sre-sequence (map cased-char (string->list str)))
342            str))
343      ;; accumulate the substring from..i as literal text
344      (define (collect)
345        (if (= i from) res (cons (cased-string (substring str from i)) res)))
346      ;; like collect but breaks off the last single character when
347      ;; collecting literal data, as the argument to ?/*/+ etc.
348      (define (collect/single)
349        (let* ((utf8? (flag-set? flags ~utf8?))
350               (j (if (and utf8? (> i 1))
351                      (utf8-backup-to-initial-char str (- i 1))
352                      (- i 1))))
353          (cond
354           ((< j from)
355            res)
356           (else
357            (let ((c (cased-char (if utf8?
358                                     (utf8-string-ref str j (- i j) )
359                                     (string-ref str j)))))
360              (cond
361               ((= j from)
362                (cons c res))
363               (else
364                (cons c
365                      (cons (cased-string (substring str from j))
366                            res)))))))))
367      ;; collects for use as a result, reversing and grouping OR
368      ;; terms, and some ugly tweaking of `function-like' groups and
369      ;; conditionals
370      (define (collect/terms)
371        (let* ((ls (collect))
372               (func
373                (and (pair? ls)
374                     (memq (last ls)
375                           '(atomic if look-ahead neg-look-ahead
376                                    look-behind neg-look-behind submatch-named
377                                    w/utf8 w/noutf8))))
378               (prefix (if (and func (eq? 'submatch-named (car func)))
379                           (list 'submatch-named (cadr (reverse ls)))
380                           (and func (list (car func)))))
381               (ls (if func
382                       (if (eq? 'submatch-named (car func))
383                           (reverse (cddr (reverse ls)))
384                           (reverse (cdr (reverse ls))))
385                       ls)))
386          (let lp ((ls ls) (term '()) (res '()))
387            (define (shift)
388              (cons (sre-sequence term) res))
389            (cond
390             ((null? ls)
391              (let* ((res (sre-alternate (shift)))
392                     (res (if (flag-set? flags ~save?)
393                              (list 'submatch res)
394                              res)))
395                (if prefix
396                    (if (eq? 'if (car prefix))
397                        (cond
398                         ((not (pair? res))
399                          'epsilon)
400                         ((memq (car res)
401                                '(look-ahead neg-look-ahead
402                                             look-behind neg-look-behind))
403                          res)
404                         ((eq? 'seq (car res))
405                          `(if ,(cadr res)
406                               ,(if (pair? (cdr res))
407                                    (sre-sequence (cddr res))
408                                    'epsilon)))
409                         (else
410                          `(if ,(cadadr res)
411                               ,(if (pair? (cdr res))
412                                    (sre-sequence (cddadr res))
413                                    'epsilon)
414                               ,(sre-alternate
415                                 (if (pair? (cdr res)) (cddr res) '())))))
416                        `(,@prefix ,res))
417                    res)))
418             ((eq? 'or (car ls)) (lp (cdr ls) '() (shift)))
419             (else (lp (cdr ls) (cons (car ls) term) res))))))
420      (define (save)
421        (cons (cons flags (collect)) st))
422
423      ;; main parsing
424      (if (>= i end)
425          (if (pair? st)
426              (error "unterminated parenthesis in regexp" str)
427              (collect/terms))
428          (let ((c (string-ref str i)))
429            (case c
430              ((#\.)
431               (lp (+ i 1) (+ i 1) flags
432                   (cons (if (flag-set? flags ~single-line?) 'any 'nonl)
433                         (collect))
434                   st))
435              ((#\?)
436               (let ((res (collect/single)))
437                 (if (null? res)
438                     (error "? can't follow empty sre" str res)
439                     (let ((x (car res)))
440                       (lp (+ i 1)
441                           (+ i 1)
442                           flags
443                           (cons
444                            (if (pair? x)
445                                (case (car x)
446                                  ((*)  `(*? ,@(cdr x)))
447                                  ((+)  `(**? 1 #f ,@(cdr x)))
448                                  ((?)  `(?? ,@(cdr x)))
449                                  ((**) `(**? ,@(cdr x)))
450                                  ((=)  `(**? ,(cadr x) ,@(cdr x)))
451                                  ((>=)  `(**? ,(cadr x) #f ,@(cddr x)))
452                                  (else `(? ,x)))
453                                `(? ,x))
454                            (cdr res))
455                           st)))))
456              ((#\+ #\*)
457               (let* ((res (collect/single))
458                      (x (car res))
459                      (op (string->symbol (string c))))
460                 (cond
461                  ((sre-repeater? x)
462                   (error "duplicate repetition (e.g. **) in sre" str res))
463                  ((sre-empty? x)
464                   (error "can't repeat empty sre (e.g. ()*)" str res))
465                  (else
466                   (lp (+ i 1) (+ i 1) flags
467                       (cons (list op x) (cdr res))
468                       st)))))
469              ((#\()
470               (cond
471                ((>= (+ i 1) end)
472                 (error "unterminated parenthesis in regexp" str))
473                ((not (eqv? #\? (string-ref str (+ i 1))))
474                 (lp (+ i 1) (+ i 1) (flag-join flags ~save?) '() (save)))
475                ((>= (+ i 2) end)
476                 (error "unterminated parenthesis in regexp" str))
477                (else
478                 (case (string-ref str (+ i 2))
479                   ((#\#)
480                    (let ((j (string-scan-char str #\) (+ i 3))))
481                      (lp (+ j i) (+ j 1) flags (collect) st)))
482                   ((#\:)
483                    (lp (+ i 3) (+ i 3) (flag-clear flags ~save?) '() (save)))
484                   ((#\=)
485                    (lp (+ i 3) (+ i 3) (flag-clear flags ~save?)
486                        '(look-ahead) (save)))
487                   ((#\!)
488                    (lp (+ i 3) (+ i 3) (flag-clear flags ~save?)
489                        '(neg-look-ahead) (save)))
490                   ((#\<)
491                    (cond
492                     ((>= (+ i 3) end)
493                      (error "unterminated parenthesis in regexp" str))
494                     (else
495                      (case (string-ref str (+ i 3))
496                        ((#\=)
497                         (lp (+ i 4) (+ i 4) (flag-clear flags ~save?)
498                             '(look-behind) (save)))
499                        ((#\!)
500                         (lp (+ i 4) (+ i 4) (flag-clear flags ~save?)
501                             '(neg-look-behind) (save)))
502                        (else
503                         (let ((j (and (char-alphabetic?
504                                        (string-ref str (+ i 3)))
505                                       (string-scan-char str #\> (+ i 4)))))
506                           (if j
507                               (lp (+ j 1) (+ j 1) (flag-clear flags ~save?)
508                                   `(,(string->symbol (substring str (+ i 3) j))
509                                     submatch-named)
510                                   (save))
511                               (error "invalid (?< sequence" str))))))))
512                   ((#\>)
513                    (lp (+ i 3) (+ i 3) (flag-clear flags ~save?)
514                        '(atomic) (save)))
515                   ;;((#\' #\P) ; named subpatterns
516                   ;; )
517                   ;;((#\R) ; recursion
518                   ;; )
519                   ((#\()
520                    (cond
521                     ((>= (+ i 3) end)
522                      (error "unterminated parenthesis in regexp" str))
523                     ((char-numeric? (string-ref str (+ i 3)))
524                      (let* ((j (string-scan-char str #\) (+ i 3)))
525                             (n (string->number (substring str (+ i 3) j))))
526                        (if (not n)
527                            (error "invalid conditional reference" str)
528                            (lp (+ j 1) (+ j 1) (flag-clear flags ~save?)
529                                `(,n if) (save)))))
530                     ((char-alphabetic? (string-ref str (+ i 3)))
531                      (let* ((j (string-scan-char str #\) (+ i 3)))
532                             (s (string->symbol (substring str (+ i 3) j))))
533                        (lp (+ j 1) (+ j 1) (flag-clear flags ~save?)
534                            `(,s if) (save))))
535                     (else
536                      (lp (+ i 2) (+ i 2) (flag-clear flags ~save?)
537                          '(if) (save)))))
538                   ((#\{)
539                    (error "unsupported Perl-style cluster" str))
540                   (else
541                    (let ((old-flags flags))
542                      (let lp2 ((j (+ i 2)) (flags flags) (invert? #f))
543                        (define (join x)
544                          ((if invert? flag-clear flag-join) flags x))
545                        (define (new-res res)
546                          (let ((before (flag-set? old-flags ~utf8?))
547                                (after (flag-set? flags ~utf8?)))
548                            (if (eq? before after)
549                                res
550                                (cons (if after 'w/utf8 'w/noutf8) res))))
551                        (cond
552                         ((>= j end)
553                          (error "incomplete cluster" str i))
554                         (else
555                          (case (string-ref str j)
556                            ((#\i)
557                             (lp2 (+ j 1) (join ~case-insensitive?) invert?))
558                            ((#\m)
559                             (lp2 (+ j 1) (join ~multi-line?) invert?))
560                            ((#\x)
561                             (lp2 (+ j 1) (join ~ignore-space?) invert?))
562                            ((#\u)
563                             (if *allow-utf8-mode?*
564                                 (lp2 (+ j 1) (join ~utf8?) invert?)
565                                 (lp2 (+ j 1) flags invert?)))
566                            ((#\-)
567                             (lp2 (+ j 1) flags (not invert?)))
568                            ((#\))
569                             (lp (+ j 1) (+ j 1) flags (new-res (collect))
570                                 st))
571                            ((#\:)
572                             (lp (+ j 1) (+ j 1) flags (new-res '())
573                                 (cons (cons old-flags (collect)) st)))
574                            (else
575                             (error "unknown regex cluster modifier" str)
576                             )))))))))))
577              ((#\))
578               (if (null? st)
579                   (error "too many )'s in regexp" str)
580                   (lp (+ i 1)
581                       (+ i 1)
582                       (caar st)
583                       (cons (collect/terms) (cdar st))
584                       (cdr st))))
585              ((#\[)
586               (apply
587                (lambda (sre j)
588                  (lp (+ j 1) (+ j 1) flags (cons sre (collect)) st))
589                (string-parse-cset str (+ i 1) flags)))
590              ((#\{)
591               (if (or (>= (+ i 1) end)
592                       (not (or (char-numeric? (string-ref str (+ i 1)))
593                                (eqv? #\, (string-ref str (+ i 1))))))
594                   (lp (+ i 1) from flags res st)
595                   (let* ((res (collect/single))
596                          (x (car res))
597                          (tail (cdr res))
598                          (j (string-scan-char str #\} (+ i 1)))
599                          (s2 (string-split-char (substring str (+ i 1) j) #\,))
600                          (n (or (string->number (car s2)) 0))
601                          (m (and (pair? (cdr s2)) (string->number (cadr s2)))))
602                     (cond
603                      ((null? (cdr s2))
604                       (lp (+ j 1) (+ j 1) flags `((= ,n ,x) ,@tail) st))
605                      (m
606                       (lp (+ j 1) (+ j 1) flags `((** ,n ,m ,x) ,@tail) st))
607                      (else
608                       (lp (+ j 1) (+ j 1) flags `((>= ,n ,x) ,@tail) st)
609                       )))))
610              ((#\\)
611               (cond
612                ((>= (+ i 1) end)
613                 (error "incomplete escape sequence" str))
614                (else
615                 (let ((c (string-ref str (+ i 1))))
616                   (case c
617                     ((#\d)
618                      (lp (+ i 2) (+ i 2) flags `(numeric ,@(collect)) st))
619                     ((#\D)
620                      (lp (+ i 2) (+ i 2) flags `((~ numeric) ,@(collect)) st))
621                     ((#\s)
622                      (lp (+ i 2) (+ i 2) flags `(space ,@(collect)) st))
623                     ((#\S)
624                      (lp (+ i 2) (+ i 2) flags `((~ space) ,@(collect)) st))
625                     ((#\w)
626                      (lp (+ i 2) (+ i 2) flags
627                          `((or alphanumeric ("_")) ,@(collect)) st))
628                     ((#\W)
629                      (lp (+ i 2) (+ i 2) flags
630                          `((~ (or alphanumeric ("_"))) ,@(collect)) st))
631                     ((#\b)
632                      (lp (+ i 2) (+ i 2) flags
633                          `((or bow eow) ,@(collect)) st))
634                     ((#\B)
635                      (lp (+ i 2) (+ i 2) flags `(nwb ,@(collect)) st))
636                     ((#\A)
637                      (lp (+ i 2) (+ i 2) flags `(bos ,@(collect)) st))
638                     ((#\Z)
639                      (lp (+ i 2) (+ i 2) flags
640                          `((? #\newline) eos ,@(collect)) st))
641                     ((#\z)
642                      (lp (+ i 2) (+ i 2) flags `(eos ,@(collect)) st))
643                     ((#\R)
644                      (lp (+ i 2) (+ i 2) flags `(newline ,@(collect)) st))
645                     ((#\K)
646                      (lp (+ i 2) (+ i 2) flags `(reset ,@(collect)) st))
647                     ;; these two are from Emacs and TRE, but not PCRE
648                     ((#\<)
649                      (lp (+ i 2) (+ i 2) flags `(bow ,@(collect)) st))
650                     ((#\>)
651                      (lp (+ i 2) (+ i 2) flags `(eow ,@(collect)) st))
652                     ((#\x)
653                      (apply
654                       (lambda (ch j)
655                         (lp (+ j 1) (+ j 1) flags `(,ch ,@(collect)) st))
656                       (string-parse-hex-escape str (+ i 2) end)))
657                     ((#\k)
658                      (let ((c (string-ref str (+ i 2))))
659                        (if (not (memv c '(#\< #\{ #\')))
660                            (error "bad \\k usage, expected \\k<...>" str)
661                            (let* ((terminal (char-mirror c))
662                                   (j (string-scan-char str terminal (+ i 2)))
663                                   (s (and j (substring str (+ i 3) j)))
664                                   (backref
665                                    (if (flag-set? flags ~case-insensitive?)
666                                        'backref-ci
667                                        'backref)))
668                              (if (not j)
669                                  (error "interminated named backref" str)
670                                  (lp (+ j 1) (+ j 1) flags
671                                      `((,backref ,(string->symbol s))
672                                        ,@(collect))
673                                      st))))))
674                     ((#\Q)  ;; \Q..\E escapes
675                      (let ((res (collect)))
676                        (let lp2 ((j (+ i 2)))
677                          (cond
678                           ((>= j end)
679                            (lp j (+ i 2) flags res st))
680                           ((eqv? #\\ (string-ref str j))
681                            (cond
682                             ((>= (+ j 1) end)
683                              (lp (+ j 1) (+ i 2) flags res st))
684                             ((eqv? #\E (string-ref str (+ j 1)))
685                              (lp (+ j 2) (+ j 2) flags
686                                  (cons (substring str (+ i 2) j) res) st))
687                             (else
688                              (lp2 (+ j 2)))))
689                           (else
690                            (lp2 (+ j 1)))))))
691                     ;;((#\p)  ; XXXX unicode properties
692                     ;; )
693                     ;;((#\P)
694                     ;; )
695                     (else
696                      (cond
697                       ((char-numeric? c)
698                        (let* ((j (or (string-scan-pred
699                                       str
700                                       (lambda (c) (not (char-numeric? c)))
701                                       (+ i 2))
702                                      end))
703                               (backref
704                                (if (flag-set? flags ~case-insensitive?)
705                                    'backref-ci
706                                    'backref))
707                               (res `((,backref ,(string->number
708                                                  (substring str (+ i 1) j)))
709                                      ,@(collect))))
710                          (lp j j flags res st)))
711                       ((char-alphabetic? c)
712                        (let ((cell (assv c posix-escape-sequences)))
713                          (if cell
714                              (lp (+ i 2) (+ i 2) flags
715                                  (cons (cdr cell) (collect)) st)
716                              (error "unknown escape sequence" str c))))
717                       (else
718                        (lp (+ i 2) (+ i 1) flags (collect) st)))))))))
719              ((#\|)
720               (lp (+ i 1) (+ i 1) flags (cons 'or (collect)) st))
721              ((#\^)
722               (let ((sym (if (flag-set? flags ~multi-line?) 'bol 'bos)))
723                 (lp (+ i 1) (+ i 1) flags (cons sym (collect)) st)))
724              ((#\$)
725               (let ((sym (if (flag-set? flags ~multi-line?) 'eol 'eos)))
726                 (lp (+ i 1) (+ i 1) flags (cons sym (collect)) st)))
727              ((#\space)
728               (if (flag-set? flags ~ignore-space?)
729                   (lp (+ i 1) (+ i 1) flags (collect) st)
730                   (lp (+ i 1) from flags res st)))
731              ((#\#)
732               (if (flag-set? flags ~ignore-space?)
733                   (let ((j (or (string-scan-char str #\newline (+ i 1))
734                                (- end 1))))
735                     (lp (+ j 1) (+ j 1) flags (collect) st))
736                   (lp (+ i 1) from flags res st)))
737              (else
738               (lp (+ i 1) from flags res st))))))))
739
740(define posix-escape-sequences
741  `((#\n . #\newline)
742    (#\r . ,(integer->char (+ (char->integer #\newline) 3)))
743    (#\t . ,(integer->char (- (char->integer #\newline) 1)))
744    (#\a . ,(integer->char (- (char->integer #\newline) 3)))
745    (#\e . ,(integer->char (+ (char->integer #\newline) #x11)))
746    (#\f . ,(integer->char (+ (char->integer #\newline) 2)))
747    ))
748
749(define (char-altcase c)
750  (if (char-upper-case? c) (char-downcase c) (char-upcase c)))
751
752(define (char-mirror c)
753  (case c ((#\<) #\>) ((#\{) #\}) ((#\() #\)) ((#\[) #\]) (else c)))
754
755(define (string-parse-hex-escape str i end)
756  (cond
757   ((>= i end)
758    (error "incomplete hex escape" str i))
759   ((eqv? #\{ (string-ref str i))
760    (let ((j (string-scan-char-escape str #\} (+ i 1))))
761      (if (not j)
762          (error "incomplete hex brace escape" str i)
763          (let* ((s (substring str (+ i 1) j))
764                 (n (string->number s 16)))
765            (if n
766                (list (integer->char n) j)
767                (error "bad hex brace escape" s))))))
768   ((>= (+ i 1) end)
769    (error "incomplete hex escape" str i))
770   (else
771    (let* ((s (substring str i (+ i 2)))
772           (n (string->number s 16)))
773      (if n
774          (list (integer->char n) (+ i 2))
775          (error "bad hex escape" s))))))
776
777(define (string-parse-cset str start flags)
778  (let ((end (string-length str))
779        (invert? (eqv? #\^ (string-ref str start)))
780        (utf8? (flag-set? flags ~utf8?)))
781    (define (go i chars ranges)
782      (if (>= i end)
783          (error "incomplete char set")
784          (let ((c (string-ref str i)))
785            (case c
786              ((#\])
787               (if (and (null? chars) (null? ranges))
788                   (go (+ i 1) (cons #\] chars) ranges)
789                   (let ((ci? (flag-set? flags ~case-insensitive?))
790                         (hi-chars (if utf8? (filter high-char? chars) '()))
791                         (chars (if utf8? (remove high-char? chars) chars)))
792                     (list
793                      ((lambda (res)
794                         (if invert? (cons '~ res) (sre-alternate res)))
795                       (append
796                        hi-chars
797                        (if (pair? chars)
798                            (list
799                             (list (list->string
800                                    ((if ci?
801                                         cset-case-insensitive
802                                         (lambda (x) x))
803                                     (reverse chars)))))
804                            '())
805                        (if (pair? ranges)
806                            (let ((res (if ci?
807                                           (cset-case-insensitive
808                                            (reverse ranges))
809                                           (reverse ranges))))
810                              (list (cons '/ (alist->plist res))))
811                            '())))
812                      i))))
813              ((#\-)
814               (cond
815                ((or (= i start)
816                     (and (= i (+ start 1)) (eqv? #\^ (string-ref str start)))
817                     (eqv? #\] (string-ref str (+ i 1))))
818                 (go (+ i 1) (cons c chars) ranges))
819                ((null? chars)
820                 (error "bad char-set"))
821                (else
822                 (let* ((c1 (car chars))
823                        (c2 (string-ref str (+ i 1)))
824                        (len (if utf8? (utf8-start-char->length c2) 1))
825                        (c2 (if (and utf8? (<= #x80 (char->integer c2) #xFF))
826                                (utf8-string-ref str (+ i 1) len)
827                                c2)))
828                   (if (char<? c2 c1)
829                       (error "inverted range in char-set" c1 c2)
830                       (go (+ i 1 len) (cdr chars) (cons (cons c1 c2) ranges))
831                     )))))
832              ((#\[)
833               (let* ((inv? (eqv? #\^ (string-ref str (+ i 1))))
834                      (i2 (if inv? (+ i 2) (+ i 1))))
835                 (case (string-ref str i2)
836                   ((#\:)
837                    (let ((j (string-scan-char str #\: (+ i2 1))))
838                      (if (or (not j) (not (eqv? #\] (string-ref str (+ j 1)))))
839                          (error "incomplete character class" str)
840                          (let* ((cset (sre->cset
841                                        (string->symbol
842                                         (substring str (+ i2 1) j))))
843                                 (cset (if inv? (cset-complement cset) cset)))
844                            (go (+ j 2)
845                                (append (filter char? cset) chars)
846                                (append (filter pair? cset) ranges))))))
847                   ((#\= #\.)
848                    (error "collating sequences not supported" str))
849                   (else
850                    (go (+ i 1) (cons #\[ chars) ranges)))))
851              ((#\\)
852               (let ((c (string-ref str (+ i 1))))
853                 (case c
854                   ((#\d #\D #\s #\S #\w #\W)
855                    (let ((cset (sre->cset (string->sre (string #\\ c)))))
856                      (go (+ i 2)
857                          (append (filter char? cset) chars)
858                          (append (filter pair? cset) ranges))))
859                   ((#\x)
860                    (apply
861                     (lambda (ch j)
862                       (go (+ j 1) (cons ch chars) ranges))
863                     (string-parse-hex-escape str (+ i 2) end)))
864                   (else
865                    (let ((c (cond ((assv c posix-escape-sequences) => cdr)
866                                   (else c))))
867                      (go (+ i 2)
868                          (cons (string-ref str (+ i 1)) (cons c chars))
869                          ranges))))))
870              (else
871               (if (and utf8? (<= #x80 (char->integer c) #xFF))
872                   (let ((len (utf8-start-char->length c)))
873                     (go (+ i len)
874                         (cons (utf8-string-ref str i len) chars)
875                         ranges))
876                   (go (+ i 1) (cons c chars) ranges)))))))
877    (if invert?
878        (go (+ start 1)
879            (if (flag-set? flags ~multi-line?) '(#\newline) '())
880            '())
881        (go start '() '()))))
882
883;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
884;; utf8 utilities
885
886;; Here are some hairy optimizations that need to be documented
887;; better.  Thanks to these, we never do any utf8 processing once the
888;; regexp is compiled.
889
890;; two chars: ab..ef
891;;            a[b..xFF]|[b-d][x80..xFF]|e[x80..xFF]
892
893;; three chars: abc..ghi
894;;              ab[c..xFF]|a[d..xFF][x80..xFF]|
895;;              [b..f][x80..xFF][x80..xFF]|
896;;              g[x80..g][x80..xFF]|gh[x80..i]
897
898;; four chars: abcd..ghij
899;;             abc[d..xFF]|ab[d..xFF][x80..xFF]|a[c..xFF][x80..xFF][x80..xFF]|
900;;             [b..f][x80..xFF][x80..xFF][x80..xFF]|
901;;             g[x80..g][x80..xFF][x80..xFF]|gh[x80..h][x80..xFF]|ghi[x80..j]
902
903(define (high-char? c) (<= #x80 (char->integer c)))
904
905;; number of total bytes in a utf8 char given the 1st byte
906
907(define utf8-start-char->length
908  (let ((table '#(
9091 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 0x
9101 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 1x
9111 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 2x
9121 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 3x
9131 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 4x
9141 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 5x
9151 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 6x
9161 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 7x
9171 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 8x
9181 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 9x
9191 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; ax
9201 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; bx
9212 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ; cx
9222 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ; dx
9233 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 ; ex
9244 4 4 4 4 4 4 4 5 5 5 5 6 6 0 0 ; fx
925)))
926    (lambda (c) (vector-ref table (char->integer c)))))
927
928(define (utf8-string-ref str i len)
929  (define (byte n) (char->integer (string-ref str n)))
930  (case len
931    ((1) ; shouldn't happen in this module
932     (string-ref str i))
933    ((2)
934     (integer->char
935      (+ (bit-shl (bit-and (byte i) #b00011111) 6)
936         (bit-and (byte (+ i 1)) #b00111111))))
937    ((3)
938     (integer->char
939      (+ (bit-shl (bit-and (byte i) #b00001111) 12)
940         (bit-shl (bit-and (byte (+ i 1)) #b00111111) 6)
941         (bit-and (byte (+ i 2)) #b00111111))))
942    ((4)
943     (integer->char
944      (+ (bit-shl (bit-and (byte i) #b00000111) 18)
945         (bit-shl (bit-and (byte (+ i 1)) #b00111111) 12)
946         (bit-shl (bit-and (byte (+ i 2)) #b00111111) 6)
947         (bit-and (byte (+ i 3)) #b00111111))))
948    (else
949     (error "invalid utf8 length" str len i))))
950
951(define (utf8-backup-to-initial-char str i)
952  (let lp ((i i))
953    (if (= i 0)
954        0
955        (let ((c (char->integer (string-ref str i))))
956          (if (or (< c #x80) (>= c #xC0))
957              i
958              (lp (- i 1)))))))
959
960(define (utf8-lowest-digit-of-length len)
961  (case len
962    ((1) 0) ((2) #xC0) ((3) #xE0) ((4) #xF0)
963    (else (error "invalid utf8 length" len))))
964
965(define (utf8-highest-digit-of-length len)
966  (case len
967    ((1) #x7F) ((2) #xDF) ((3) #xEF) ((4) #xF7)
968    (else (error "invalid utf8 length" len))))
969
970(define (char->utf8-list c)
971  (let ((i (char->integer c)))
972    (cond
973     ((<= i #x7F) (list i))
974     ((<= i #x7FF)
975      (list (bit-ior #b11000000 (bit-shr i 6))
976            (bit-ior #b10000000 (bit-and i #b111111))))
977     ((<= i #xFFFF)
978      (list (bit-ior #b11100000 (bit-shr i 12))
979            (bit-ior #b10000000 (bit-and (bit-shr i 6) #b111111))
980            (bit-ior #b10000000 (bit-and i #b111111))))
981     ((<= i #x1FFFFF)
982      (list (bit-ior #b11110000 (bit-shr i 18))
983            (bit-ior #b10000000 (bit-and (bit-shr i 12) #b111111))
984            (bit-ior #b10000000 (bit-and (bit-shr i 6) #b111111))
985            (bit-ior #b10000000 (bit-and i #b111111))))
986     (else (error "unicode codepoint out of range:" i)))))
987
988(define (unicode-range->utf8-pattern lo hi)
989  (let ((lo-ls (char->utf8-list lo))
990        (hi-ls (char->utf8-list hi)))
991    (if (not (= (length lo-ls) (length hi-ls)))
992        (sre-alternate (list (unicode-range-climb-digits lo-ls hi-ls)
993                             (unicode-range-up-to hi-ls)))
994        (let lp ((lo-ls lo-ls) (hi-ls hi-ls))
995          (cond
996           ((null? lo-ls)
997            '())
998           ((= (car lo-ls) (car hi-ls))
999            (sre-sequence
1000             (list (integer->char (car lo-ls))
1001                   (lp (cdr lo-ls) (cdr hi-ls)))))
1002           ((= (+ (car lo-ls) 1) (car hi-ls))
1003            (sre-alternate (list (unicode-range-up-from lo-ls)
1004                                 (unicode-range-up-to hi-ls))))
1005           (else
1006            (sre-alternate (list (unicode-range-up-from lo-ls)
1007                                 (unicode-range-middle lo-ls hi-ls)
1008                                 (unicode-range-up-to hi-ls)))))))))
1009
1010(define (unicode-range-helper one ls prefix res)
1011  (if (null? ls)
1012      res
1013      (unicode-range-helper
1014       one
1015       (cdr ls)
1016       (cons (car ls) prefix)
1017       (cons (sre-sequence
1018              `(,@(map integer->char prefix)
1019                ,(one (car ls))
1020                ,@(map (lambda (_)
1021                         `(/ ,(integer->char #x80)
1022                             ,(integer->char #xFF)))
1023                       (cdr ls))))
1024             res))))
1025
1026(define (unicode-range-up-from lo-ls)
1027  (sre-sequence
1028   (list (integer->char (car lo-ls))
1029         (sre-alternate
1030          (unicode-range-helper
1031           (lambda (c)
1032             `(/ ,(integer->char (+ (car lo-ls) 1)) ,(integer->char #xFF)))
1033           (cdr (reverse (cdr lo-ls)))
1034           '()
1035           (list
1036            (sre-sequence
1037             (append
1038              (map integer->char (reverse (cdr (reverse (cdr lo-ls)))))
1039              `((/ ,(integer->char (last lo-ls))
1040                   ,(integer->char #xFF)))))))))))
1041
1042(define (unicode-range-up-to hi-ls)
1043  (sre-sequence
1044   (list (integer->char (car hi-ls))
1045         (sre-alternate
1046          (unicode-range-helper
1047           (lambda (c)
1048             `(/ ,(integer->char #x80) ,(integer->char (- (car hi-ls) 1))))
1049           (cdr (reverse (cdr hi-ls)))
1050           '()
1051           (list
1052            (sre-sequence
1053             (append
1054              (map integer->char (reverse (cdr (reverse (cdr hi-ls)))))
1055              `((/ ,(integer->char #x80)
1056                   ,(integer->char (last hi-ls))))))))))))
1057
1058(define (unicode-range-climb-digits lo-ls hi-ls)
1059  (let ((lo-len (length lo-ls)))
1060    (sre-alternate
1061     (append
1062      (list
1063       (sre-sequence
1064        (cons `(/ ,(integer->char (car lo-ls))
1065                  ,(integer->char (if (<= (car lo-ls) #x7F) #x7F #xFF)))
1066              (map (lambda (_)
1067                     `(/ ,(integer->char #x80) ,(integer->char #xFF)))
1068                   (cdr lo-ls)))))
1069      (map
1070       (lambda (i)
1071         (sre-sequence
1072          (cons
1073           `(/ ,(integer->char (utf8-lowest-digit-of-length (+ i lo-len 1)))
1074               ,(integer->char (utf8-highest-digit-of-length (+ i lo-len 1))))
1075           (map (lambda (_)
1076                  `(/ ,(integer->char #x80) ,(integer->char #xFF)))
1077                (zero-to (+ i lo-len))))))
1078       (zero-to (- (length hi-ls) lo-len 1)))
1079      (list
1080       (sre-sequence
1081        (cons `(/ ,(integer->char
1082                    (utf8-lowest-digit-of-length
1083                     (utf8-start-char->length
1084                      (integer->char (- (car hi-ls) 1)))))
1085                  ,(integer->char (- (car hi-ls) 1)))
1086              (map (lambda (_)
1087                     `(/ ,(integer->char #x80) ,(integer->char #xFF)))
1088                   (cdr hi-ls)))))))))
1089
1090(define (unicode-range-middle lo-ls hi-ls)
1091  (let ((lo (integer->char (+ (car lo-ls) 1)))
1092        (hi (integer->char (- (car hi-ls) 1))))
1093    (sre-sequence
1094     (cons (if (char=? lo hi) lo `(/ ,lo ,hi))
1095           (map (lambda (_) `(/ ,(integer->char #x80) ,(integer->char #xFF)))
1096                (cdr lo-ls))))))
1097
1098(define (cset->utf8-pattern cset)
1099  (let lp ((ls cset) (alts '()) (lo-cset '()))
1100    (cond
1101     ((null? ls)
1102      (sre-alternate (append (reverse alts)
1103                             (if (null? lo-cset)
1104                                 '()
1105                                 (list (cons '/ (reverse lo-cset)))))))
1106     ((char? (car ls))
1107      (if (high-char? (car ls))
1108          (lp (cdr ls) (cons (car ls) alts) lo-cset)
1109          (lp (cdr ls) alts (cons (car ls) lo-cset))))
1110     (else
1111      (if (or (high-char? (caar ls))  (high-char? (cdar ls)))
1112          (lp (cdr ls)
1113              (cons (unicode-range->utf8-pattern (caar ls) (cdar ls)) alts)
1114              lo-cset)
1115          (lp (cdr ls) alts (cons (cdar ls) (cons (caar ls) lo-cset))))))))
1116
1117(define (sre-adjust-utf8 sre flags)
1118  (let adjust ((sre sre)
1119               (utf8? (flag-set? flags ~utf8?))
1120               (ci? (flag-set? flags ~case-insensitive?)))
1121    (define (rec sre) (adjust sre utf8? ci?))
1122    (cond
1123     ((pair? sre)
1124      (case (car sre)
1125        ((w/utf8) (adjust (sre-sequence (cdr sre)) #t ci?))
1126        ((w/noutf8) (adjust (sre-sequence (cdr sre)) #f ci?))
1127        ((w/case)
1128         (cons (car sre) (map (lambda (s) (adjust s utf8? #f)) (cdr sre))))
1129        ((w/nocase)
1130         (cons (car sre) (map (lambda (s) (adjust s utf8? #t)) (cdr sre))))
1131        ((/ ~ & -)
1132         (if (not utf8?)
1133             sre
1134             (let ((cset (sre->cset sre ci?)))
1135               (if (any (lambda (x)
1136                          (if (pair? x)
1137                              (or (high-char? (car x)) (high-char? (cdr x)))
1138                              (high-char? x)))
1139                        cset)
1140                   (if ci?
1141                       (list 'w/case (cset->utf8-pattern cset))
1142                       (cset->utf8-pattern cset))
1143                   sre))))
1144        ((*)
1145         (case (sre-sequence (cdr sre))
1146           ;; special case optimization: .* w/utf8 == .* w/noutf8
1147           ((any) '(* any))
1148           ((nonl) '(* nonl))
1149           (else (cons '* (map rec (cdr sre))))))
1150        (else
1151         (cons (car sre) (map rec (cdr sre))))))
1152     (else
1153      (case sre
1154        ((any) 'utf8-any)
1155        ((nonl) 'utf8-nonl)
1156        (else
1157         (if (and utf8? (char? sre) (high-char? sre))
1158             (sre-sequence (map integer->char (char->utf8-list sre)))
1159             sre)))))))
1160
1161;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1162;; compilation
1163
1164(define (irregex x . o)
1165  (cond
1166   ((irregex? x) x)
1167   ((string? x) (apply string->irregex x o))
1168   (else (apply sre->irregex x o))))
1169
1170(define (string->irregex str . o)
1171  (apply sre->irregex (apply string->sre str o) o))
1172
1173(define (sre->irregex sre . o)
1174  (let* ((pat-flags (symbol-list->flags o))
1175         (sre (if *allow-utf8-mode?*
1176                  (sre-adjust-utf8 sre pat-flags)
1177                  sre))
1178         (searcher? (sre-searcher? sre))
1179         (sre-dfa (if searcher? (sre-remove-initial-bos sre) sre))
1180         (dfa-limit (cond ((memq 'small o) 1) ((memq 'fast o) 50) (else 10)))
1181         (dfa/search
1182          (if searcher?
1183              #t
1184              (cond ((sre->nfa `(seq (* any) ,sre-dfa) pat-flags)
1185                     => (lambda (nfa) (nfa->dfa nfa (* dfa-limit (length nfa)))))
1186                    (else #f))))
1187         (dfa (cond ((and dfa/search (sre->nfa sre-dfa pat-flags))
1188                     => (lambda (nfa) (nfa->dfa nfa (* dfa-limit (length nfa)))))
1189                    (else #f)))
1190         (extractor (and dfa dfa/search (sre-match-extractor sre-dfa)))
1191         (submatches (sre-count-submatches sre-dfa))
1192         (names (sre-names sre-dfa 1 '()))
1193         (lens (sre-length-ranges sre-dfa names))
1194         (flags (flag-join
1195                 (flag-join ~none (and searcher? ~searcher?))
1196                 (and (sre-consumer? sre) ~consumer?))))
1197    (cond
1198     (dfa
1199      (make-irregex dfa dfa/search extractor #f flags submatches lens names))
1200     (else
1201      (let ((f (sre->procedure sre pat-flags names)))
1202        (make-irregex #f #f #f f flags submatches lens names))))))
1203
1204;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1205;; sre analysis
1206
1207;; returns #t if the sre can ever be empty
1208(define (sre-empty? sre)
1209  (if (pair? sre)
1210      (case (car sre)
1211        ((* ? look-ahead look-behind neg-look-ahead neg-look-behind) #t)
1212        ((**) (or (not (number? (cadr sre))) (zero? (cadr sre))))
1213        ((or) (any sre-empty? (cdr sre)))
1214        ((: seq submatch + atomic) (every sre-empty? (cdr sre)))
1215        (else #f))
1216      (memq sre '(epsilon bos eos bol eol bow eow commit))))
1217
1218(define (sre-any? sre)
1219  (or (eq? sre 'any)
1220      (and (pair? sre)
1221           (case (car sre)
1222             ((seq : submatch)
1223              (and (pair? (cdr sre)) (null? (cddr sre)) (sre-any? (cadr sre))))
1224             ((or) (every sre-any? (cdr sre)))
1225             (else #f)))))
1226
1227(define (sre-repeater? sre)
1228  (and (pair? sre)
1229       (or (memq (car sre) '(* +))
1230           (and (memq (car sre) '(submatch seq :))
1231                (pair? (cdr sre))
1232                (null? (cddr sre))
1233                (sre-repeater? (cadr sre))))))
1234
1235(define (sre-searcher? sre)
1236  (if (pair? sre)
1237      (case (car sre)
1238        ((* +) (sre-any? (sre-sequence (cdr sre))))
1239        ((seq : submatch) (and (pair? (cdr sre)) (sre-searcher? (cadr sre))))
1240        ((or) (every sre-searcher? (cdr sre)))
1241        (else #f))
1242      (eq? 'bos sre)))
1243
1244(define (sre-consumer? sre)
1245  (if (pair? sre)
1246      (case (car sre)
1247        ((* +) (sre-any? (sre-sequence (cdr sre))))
1248        ((seq : submatch) (and (pair? (cdr sre)) (sre-consumer? (last sre))))
1249        ((or) (every sre-consumer? (cdr sre)))
1250        (else #f))
1251      (eq? 'eos sre)))
1252
1253(define (sre-has-submatchs? sre)
1254  (and (pair? sre)
1255       (or (eq? 'submatch (car sre))
1256           (any sre-has-submatchs? (cdr sre)))))
1257
1258(define (sre-count-submatches sre)
1259  (let count ((sre sre) (sum 0))
1260    (if (pair? sre)
1261        (fold count
1262              (+ sum (case (car sre)
1263                       ((submatch submatch-named) 1)
1264                       ((dsm) (+ (cadr sre) (caddr sre)))
1265                       (else 0)))
1266              (cdr sre))
1267        sum)))
1268
1269(define (sre-length-ranges sre . o)
1270  (let ((names (if (pair? o) (car o) (sre-names sre 1 '())))
1271        (sublens (make-vector (+ 1 (sre-count-submatches sre)) #f)))
1272    (vector-set!
1273     sublens
1274     0
1275     (let lp ((sre sre) (n 1) (lo 0) (hi 0) (return cons))
1276       (define (grow i) (return (+ lo i) (and hi (+ hi i))))
1277       (cond
1278        ((pair? sre)
1279         (if (string? (car sre))
1280             (grow 1)
1281             (case (car sre)
1282               ((/ ~ & -)
1283                (grow 1))
1284               ((posix-string)
1285                (lp (string->sre (cadr sre)) n lo hi return))
1286               ((seq : w/case w/nocase atomic)
1287                (let lp2 ((ls (cdr sre)) (n n) (lo2 0) (hi2 0))
1288                  (if (null? ls)
1289                      (return (+ lo lo2) (and hi hi2 (+ hi hi2)))
1290                      (lp (car ls) n 0 0
1291                          (lambda (lo3 hi3)
1292                            (lp2 (cdr ls)
1293                                 (+ n (sre-count-submatches (car ls)))
1294                                 (+ lo2 lo3)
1295                                 (and hi2 hi3 (+ hi2 hi3))))))))
1296               ((or)
1297                (let lp2 ((ls (cdr sre)) (n n) (lo2 #f) (hi2 0))
1298                  (if (null? ls)
1299                      (return (+ lo lo2) (and hi hi2 (+ hi hi2)))
1300                      (lp (car ls) n 0 0
1301                          (lambda (lo3 hi3)
1302                            (lp2 (cdr ls)
1303                                 (+ n (sre-count-submatches (car ls)))
1304                                 (if lo2 (min lo2 lo3) lo3)
1305                                 (and hi2 hi3 (max hi2 hi3))))))))
1306               ((if)
1307                (cond
1308                 ((or (null? (cdr sre)) (null? (cddr sre)))
1309                  (return lo hi))
1310                 (else
1311                  (let ((n1 (sre-count-submatches (car sre)))
1312                        (n2 (sre-count-submatches (cadr sre))))
1313                    (lp (if (or (number? (cadr sre)) (symbol? (cadr sre)))
1314                            'epsilon
1315                            (cadr sre))
1316                        n lo hi
1317                        (lambda (lo2 hi2)
1318                          (lp (caddr sre) (+ n n1) 0 0
1319                              (lambda (lo3 hi3)
1320                                (lp (if (pair? (cdddr sre))
1321                                        (cadddr sre)
1322                                        'epsilon)
1323                                    (+ n n1 n2) 0 0
1324                                    (lambda (lo4 hi4)
1325                                      (return (+ lo2 (min lo3 lo4))
1326                                              (and hi2 hi3 hi4
1327                                                   (+ hi2 (max hi3 hi4))
1328                                                   ))))))))))))
1329               ((dsm)
1330                (lp (sre-sequence (cdddr sre)) (+ n (cadr sre)) lo hi return))
1331               ((submatch submatch-named)
1332                (lp (sre-sequence
1333                     (if (eq? 'submatch (car sre)) (cdr sre) (cddr sre)))
1334                    (+ n 1) lo hi
1335                    (lambda (lo2 hi2)
1336                      (vector-set! sublens n (cons lo2 hi2))
1337                      (return lo2 hi2))))
1338               ((backref backref-ci)
1339                (let ((n (cond
1340                          ((number? (cadr sre)) (cadr sre))
1341                          ((assq (cadr sre) names) => cdr)
1342                          (else (error "unknown backreference" (cadr sre))))))
1343                  (cond
1344                   ((or (not (integer? n))
1345                        (not (< 0 n (vector-length sublens))))
1346                    (error "sre-length: invalid backreference" sre))
1347                   ((not (vector-ref sublens n))
1348                    (error "sre-length: invalid forward backreference" sre))
1349                   (else
1350                    (let ((lo2 (car (vector-ref sublens n)))
1351                          (hi2 (cdr (vector-ref sublens n))))
1352                      (return (+ lo lo2) (and hi hi2 (+ hi hi2))))))))
1353               ((* *?)
1354                (lp (sre-sequence (cdr sre)) n lo hi (lambda (lo hi) #f))
1355                (return lo #f))
1356               ((** **?)
1357                (cond
1358                 ((or (and (number? (cadr sre))
1359                           (number? (caddr sre))
1360                           (> (cadr sre) (caddr sre)))
1361                      (and (not (cadr sre)) (caddr sre)))
1362                  (return lo hi))
1363                 (else
1364                  (if (caddr sre)
1365                      (lp (sre-sequence (cdddr sre)) n 0 0
1366                          (lambda (lo2 hi2)
1367                            (return (+ lo (* (cadr sre) lo2))
1368                                    (and hi hi2 (+ hi (* (caddr sre) hi2))))))
1369                      (lp (sre-sequence (cdddr sre)) n 0 0
1370                          (lambda (lo2 hi2)
1371                            (return (+ lo (* (cadr sre) lo2)) #f)))))))
1372               ((+)
1373                (lp (sre-sequence (cdr sre)) n lo hi
1374                    (lambda (lo2 hi2)
1375                      (return (+ lo lo2) #f))))
1376               ((? ??)
1377                (lp (sre-sequence (cdr sre)) n lo hi
1378                    (lambda (lo2 hi2)
1379                      (return lo (and hi hi2 (+ hi hi2))))))
1380               ((= =? >= >=?)
1381                (lp `(** ,(cadr sre)
1382                         ,(if (memq (car sre) '(>= >=?)) #f (cadr sre))
1383                         ,@(cddr sre))
1384                    n lo hi return))
1385               ((look-ahead neg-look-ahead look-behind neg-look-behind)
1386                (return lo hi))
1387               (else
1388                (error "sre-length-ranges: unknown sre operator" sre)))))
1389        ((char? sre)
1390         (grow 1))
1391        ((string? sre)
1392         (grow (string-length sre)))
1393        ((memq sre '(any nonl))
1394         (grow 1))
1395        ((memq sre '(epsilon bos eos bol eol bow eow nwb commit))
1396         (return lo hi))
1397        (else
1398         (let ((cell (assq sre sre-named-definitions)))
1399           (if cell
1400               (lp (cdr cell) n lo hi return)
1401               (error "sre-length-ranges: unknown sre" sre)))))))
1402    sublens))
1403
1404;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1405;; sre manipulation
1406
1407;; build a (seq ls ...) sre from a list
1408(define (sre-sequence ls)
1409  (cond
1410   ((null? ls) 'epsilon)
1411   ((null? (cdr ls)) (car ls))
1412   (else (cons 'seq ls))))
1413
1414;; build a (or ls ...) sre from a list
1415(define (sre-alternate ls)
1416  (cond
1417   ((null? ls) 'epsilon)
1418   ((null? (cdr ls)) (car ls))
1419   (else (cons 'or ls))))
1420
1421;; returns an equivalent SRE without any match information
1422(define (sre-strip-submatches sre)
1423  (if (not (pair? sre))
1424      sre
1425      (case (car sre)
1426        ((submatch) (sre-strip-submatches (sre-sequence (cdr sre))))
1427        ((dsm) (sre-strip-submatches (sre-sequence (cdddr sre))))
1428        (else (map sre-strip-submatches sre)))))
1429
1430;; given a char-set list of chars and strings, flattens them into
1431;; chars only
1432(define (sre-flatten-ranges ls)
1433  (let lp ((ls ls) (res '()))
1434    (cond
1435     ((null? ls)
1436      (reverse res))
1437     ((string? (car ls))
1438      (lp (append (string->list (car ls)) (cdr ls)) res))
1439     (else
1440      (lp (cdr ls) (cons (car ls) res))))))
1441
1442(define (sre-names sre n names)
1443  (if (not (pair? sre))
1444      names
1445      (case (car sre)
1446        ((submatch)
1447         (sre-names (sre-sequence (cdr sre)) (+ n 1) names))
1448        ((submatch-named)
1449         (sre-names (sre-sequence (cddr sre))
1450                    (+ n 1)
1451                    (cons (cons (cadr sre) n) names)))
1452        ((dsm)
1453         (sre-names (sre-sequence (cdddr sre)) (+ n (cadr sre)) names))
1454        ((seq : or * + ? *? ?? w/case w/nocase atomic
1455              look-ahead look-behind neg-look-ahead neg-look-behind)
1456         (sre-sequence-names (cdr sre) n names))
1457        ((= >=)
1458         (sre-sequence-names (cddr sre) n names))
1459        ((** **?)
1460         (sre-sequence-names (cdddr sre) n names))
1461        (else
1462         names))))
1463
1464(define (sre-sequence-names ls n names)
1465  (if (null? ls)
1466      names
1467      (sre-sequence-names (cdr ls)
1468                          (+ n (sre-count-submatches (car ls)))
1469                          (sre-names (car ls) n names))))
1470
1471(define (sre-remove-initial-bos sre)
1472  (cond
1473   ((pair? sre)
1474    (case (car sre)
1475      ((seq : submatch * +)
1476       (cond
1477        ((not (pair? (cdr sre)))
1478         sre)
1479        ((eq? 'bos (cadr sre))
1480         (cons (car sre) (cddr sre)))
1481        (else
1482         (cons (car sre)
1483               (cons (sre-remove-initial-bos (cadr sre)) (cddr sre))))))
1484      ((or)
1485       (sre-alternate (map sre-remove-initial-bos (cdr sre))))
1486      (else
1487       sre)))
1488   (else
1489    sre)))
1490
1491;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1492;; matching
1493
1494(define (irregex-search x str . o)
1495  (let ((irx (irregex x)))
1496    (let ((start (if (pair? o) (car o) 0))
1497          (end   (if (and (pair? o) (pair? (cdr o)))
1498                     (cadr o) (string-length str)))
1499          (matches (irregex-new-matches irx)))
1500      (irregex-match-string-set! matches str)
1501      (irregex-search/matches irx str start end matches))))
1502
1503;; internal routine, can be used in loops to avoid reallocating the
1504;; match vector
1505(define (irregex-search/matches irx str start end matches)
1506  (cond
1507   ((irregex-dfa irx)
1508    (cond
1509     ((flag-set? (irregex-flags irx) ~searcher?)
1510      (let ((m-end (dfa-match/longest (irregex-dfa irx) str start end)))
1511        (cond
1512         (m-end
1513          (irregex-match-start-index-set! matches 0 start)
1514          (irregex-match-end-index-set! matches 0 m-end)
1515          ((irregex-dfa/extract irx) str start m-end matches)
1516          matches)
1517         (else
1518          #f))))
1519     (else
1520      (let ((first-match
1521             (dfa-match/shortest (irregex-dfa/search irx) str start end)))
1522        (and
1523         first-match
1524         (let* ((lo+hi (vector-ref (irregex-lengths irx) 0))
1525                (m-start (if (cdr lo+hi)
1526                             (max start (- first-match (cdr lo+hi)))
1527                             start))
1528                (m-limit (- first-match (car lo+hi)))
1529                (dfa (irregex-dfa irx)))
1530           (let lp ((m-start m-start))
1531             (and (<= m-start m-limit)
1532                  (let ((m-end (dfa-match/longest dfa str m-start end)))
1533                    (cond
1534                     (m-end
1535                      (irregex-match-start-index-set! matches 0 m-start)
1536                      (irregex-match-end-index-set! matches 0 m-end)
1537                      ((irregex-dfa/extract irx) str m-start m-end matches)
1538                      matches)
1539                     (else
1540                      (lp (+ m-start 1)))))))))))))
1541   (else
1542    (let ((matcher (irregex-nfa irx)))
1543      (let lp ((start start))
1544        (and (<= start end)
1545             (let ((i (matcher str start matches (lambda () #f))))
1546               (cond
1547                (i
1548                 (irregex-match-start-index-set! matches 0 start)
1549                 (irregex-match-end-index-set! matches 0 i)
1550                 matches)
1551                (else
1552                 (lp (+ start 1)))))))))))
1553
1554(define (irregex-match irx str)
1555  (let* ((irx (irregex irx))
1556         (matches (irregex-new-matches irx))
1557         (start 0)
1558         (end (string-length str)))
1559    (irregex-match-string-set! matches str)
1560    (cond
1561     ((irregex-dfa irx)
1562      (let ((m-end (dfa-match/longest (irregex-dfa irx) str start end)))
1563        (cond
1564         ((equal? m-end end)
1565          (irregex-match-start-index-set! matches 0 start)
1566          (irregex-match-end-index-set! matches 0 m-end)
1567          ((irregex-dfa/extract irx) str start m-end matches)
1568          matches)
1569         (else
1570          #f))))
1571     (else
1572      (let* ((matcher (irregex-nfa irx))
1573             (i (matcher str start matches (lambda () #f))))
1574        (cond
1575         ((equal? i end)
1576          (irregex-match-start-index-set! matches 0 start)
1577          (irregex-match-end-index-set! matches 0 i)
1578          matches)
1579         (else
1580          #f)))))))
1581
1582;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1583;; DFA matching
1584
1585;; inline these
1586(define (dfa-init-state dfa)
1587  (vector-ref dfa 0))
1588(define (dfa-next-state dfa node)
1589  (vector-ref dfa (cdr node)))
1590(define (dfa-final-state? dfa state)
1591  (car state))
1592
1593;; this searches for the first end index for which a match is possible
1594(define (dfa-match/shortest dfa str start end)
1595  (let lp ((i start) (state (dfa-init-state dfa)))
1596    (if (dfa-final-state? dfa state)
1597        i
1598        (and (< i end)
1599             (let* ((ch (string-ref str i))
1600                    (next (find (lambda (x)
1601                                  (or (eqv? ch (car x))
1602                                      (and (pair? (car x))
1603                                           (char<=? (caar x) ch)
1604                                           (char<=? ch (cdar x)))))
1605                                (cdr state))))
1606               (and next (lp (+ i 1) (dfa-next-state dfa next))))))))
1607
1608;; this finds the longest match starting at a given index
1609(define (dfa-match/longest dfa str start end)
1610  (let lp ((i start)
1611           (state (dfa-init-state dfa))
1612           (res (and (dfa-final-state? dfa (dfa-init-state dfa)) start)))
1613    (if (>= i end)
1614        res
1615        (let* ((ch (string-ref str i))
1616               (cell (find (lambda (x)
1617                             (or (eqv? ch (car x))
1618                                 (and (pair? (car x))
1619                                      (char<=? (caar x) ch)
1620                                      (char<=? ch (cdar x)))))
1621                           (cdr state))))
1622          (if cell
1623              (let ((next (dfa-next-state dfa cell)))
1624                (lp (+ i 1)
1625                    next
1626                    (if (dfa-final-state? dfa next) (+ i 1) res)))
1627              res)))))
1628
1629;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1630;; SRE->NFA compilation
1631;;
1632;; An NFA state is a numbered node with a list of patter->number
1633;; transitions, where pattern is either a character, (lo . hi)
1634;; character range, or epsilon (indicating an empty transition).
1635;; There may be duplicate characters and overlapping ranges - since
1636;; it's an NFA we process it by considering all possible transitions.
1637
1638(define sre-named-definitions
1639  `((any . ,*all-chars*)
1640    (nonl . (- ,*all-chars* (,(string #\newline))))
1641    (alphabetic . (/ #\a #\z #\A #\Z))
1642    (alpha . alphabetic)
1643    (alphanumeric . (/ #\a #\z #\A #\Z #\0 #\9))
1644    (alphanum . alphanumeric)
1645    (alnum . alphanumeric)
1646    (lower-case . (/ #\a #\z))
1647    (lower . lower-case)
1648    (upper-case . (/ #\A #\Z))
1649    (upper . upper-case)
1650    (numeric . (/ #\0 #\9))
1651    (num . numeric)
1652    (digit . numeric)
1653    (punctuation . (or #\! #\" #\# #\% #\& #\' #\( #\) #\* #\, #\- #\.
1654                       #\/ #\: #\; #\? #\@ #\[ #\\ #\] #\_ #\{ #\}))
1655    (punct . punctuation)
1656    (graphic
1657     . (or alphanumeric punctuation #\$ #\+ #\< #\= #\> #\^ #\` #\| #\~))
1658    (graph . graphic)
1659    (blank . (or #\space ,(integer->char (- (char->integer #\space) 23))))
1660    (whitespace . (or blank #\newline))
1661    (space . whitespace)
1662    (white . whitespace)
1663    (printing or graphic whitespace)
1664    (print . printing)
1665    ;; XXXX we assume a (possibly shifted) ASCII-based ordering
1666    (control . (/ ,(integer->char (- (char->integer #\space) 32))
1667                  ,(integer->char (- (char->integer #\space) 1))))
1668    (cntrl . control)
1669    (hex-digit . (or numeric (/ #\a #\f #\A #\F)))
1670    (xdigit . hex-digit)
1671    (ascii . (/ ,(integer->char (- (char->integer #\space) 32))
1672                ,(integer->char (+ (char->integer #\space) 95))))
1673    (ascii-nonl . (/ ,(integer->char (- (char->integer #\space) 32))
1674                     ,(integer->char (- (char->integer #\newline) 1))
1675                     ,(integer->char (+ (char->integer #\newline) 1))
1676                     ,(integer->char (+ (char->integer #\space) 95))))
1677    (newline . (or (seq ,(integer->char (+ (char->integer #\newline) 3))
1678                        #\newline)
1679                   (/ #\newline
1680                      ,(integer->char (+ (char->integer #\newline) 3)))))
1681
1682    ;; ... it's really annoying to support scheme48
1683    (word . (seq bow (+ (or alphanumeric #\_)) eow))
1684    (utf8-tail-char . (/ ,(integer->char (+ (char->integer #\space) #x60))
1685                         ,(integer->char (+ (char->integer #\space) #xA1))))
1686    (utf8-2-char . (seq (/ ,(integer->char (+ (char->integer #\space) #xA2))
1687                           ,(integer->char (+ (char->integer #\space) #xBF)))
1688                        utf8-tail-char))
1689    (utf8-3-char . (seq (/ ,(integer->char (+ (char->integer #\space) #xC0))
1690                           ,(integer->char (+ (char->integer #\space) #xCF)))
1691                        utf8-tail-char
1692                        utf8-tail-char))
1693    (utf8-4-char . (seq (/ ,(integer->char (+ (char->integer #\space) #xD0))
1694                           ,(integer->char (+ (char->integer #\space) #xD7)))
1695                        utf8-tail-char
1696                        utf8-tail-char
1697                        utf8-tail-char))
1698    (utf8-any . (or ascii utf8-2-char utf8-3-char utf8-4-char))
1699    (utf8-nonl . (or ascii-nonl utf8-2-char utf8-3-char utf8-4-char))
1700    ))
1701
1702;; Compile and return the list of NFA states.  The start state will be
1703;; at the head of the list, and all remaining states will be in
1704;; descending numeric order, with state 0 being the unique accepting
1705;; state.
1706(define (sre->nfa sre . o)
1707  ;; we loop over an implicit sequence list
1708  (let lp ((ls (list sre))
1709           (n 1)
1710           (flags (if (pair? o) (car o) ~none))
1711           (next (list (list 0))))
1712    (define (new-state-number state)
1713      (max n (+ 1 (caar state))))
1714    (define (extend-state next . trans)
1715      (and next
1716           (cons (cons (new-state-number next)
1717                       (map (lambda (x) (cons x (caar next))) trans))
1718                 next)))
1719    (if (null? ls)
1720        next
1721        (cond
1722         ((string? (car ls))
1723          ;; process literal strings a char at a time
1724          (lp (append (string->list (car ls)) (cdr ls)) n flags next))
1725         ((eq? 'epsilon (car ls))
1726          ;; chars and epsilons go directly into the transition table
1727          (extend-state (lp (cdr ls) n flags next) (car ls)))
1728         ((char? (car ls))
1729          (let ((alt (char-altcase (car ls))))
1730            (if (and (flag-set? flags ~case-insensitive?)
1731                     (not (eqv? (car ls) alt)))
1732                (extend-state (lp (cdr ls) n flags next) (car ls) alt)
1733                (extend-state (lp (cdr ls) n flags next) (car ls)))))
1734         ((symbol? (car ls))
1735          (let ((cell (assq (car ls) sre-named-definitions)))
1736            (and cell (lp (cons (cdr cell) (cdr ls)) n flags next))))
1737         ((pair? (car ls))
1738          (cond
1739           ((string? (caar ls))
1740            ;; enumerated character set
1741            (lp (cons (sre-alternate (string->list (caar ls))) (cdr ls))
1742                n
1743                flags
1744                next))
1745           (else
1746            (case (caar ls)
1747              ((seq :)
1748               ;; for an explicit sequence, just append to the list
1749               (lp (append (cdar ls) (cdr ls)) n flags next))
1750              ((w/case w/nocase w/utf8 w/noutf8)
1751               (let* ((next (lp (cdr ls) n flags next))
1752                      (flags ((if (memq (caar ls) '(w/case w/utf8))
1753                                  flag-clear
1754                                  flag-join)
1755                              flags
1756                              (if (memq (caar ls) '(w/case w/nocase))
1757                                  ~case-insensitive?
1758                                  ~utf8?))))
1759                 (and next (lp (cdar ls) (new-state-number next) flags next))))
1760              ((/ - & ~) 
1761               (let ((ranges (sre->cset (car ls)
1762                                        (flag-set? flags ~case-insensitive?))))
1763                 (case (length ranges)
1764                   ((1)
1765                    (extend-state (lp (cdr ls) n flags next) (car ranges)))
1766                   (else
1767                    (let ((next (lp (cdr ls) n flags next)))
1768                      (and
1769                       next
1770                       (lp (list (sre-alternate
1771                                  (map (lambda (x) (if (pair? x)
1772                                                  (list '/ (car x) (cdr x))
1773                                                  x))
1774                                       ranges)))
1775                           (new-state-number next)
1776                           (flag-clear flags ~case-insensitive?)
1777                           next)))))))
1778              ((or)
1779               (let* ((next (lp (cdr ls) n flags next))
1780                      (b (and next
1781                              (lp (list (sre-alternate (cddar ls)))
1782                                  (new-state-number next)
1783                                  flags
1784                                  next)))
1785                      (a (and b (lp (list (cadar ls))
1786                                    (new-state-number b)
1787                                    flags
1788                                    next))))
1789                 ;; compile both branches and insert epsilon
1790                 ;; transitions to either
1791                 (and a
1792                      `((,(new-state-number a)
1793                         (epsilon . ,(caar a))
1794                         (epsilon . ,(caar b)))
1795                        ,@(take-up-to a next)
1796                        ,@b))))
1797              ((?)
1798               (let ((next (lp (cdr ls) n flags next)))
1799                 ;; insert an epsilon transition directly to next
1800                 (and
1801                  next
1802                  (let ((a (lp (cdar ls) (new-state-number next) flags next)))
1803                    (cond
1804                     (a
1805                      (set-cdr! (car a) `((epsilon . ,(caar next)) ,@(cdar a)))
1806                      a)
1807                     (else
1808                      #f))))))
1809              ((+ *)
1810               (let ((next (lp (cdr ls) n flags next)))
1811                 (and
1812                  next
1813                  (let* ((new (lp '(epsilon)
1814                                  (new-state-number next)
1815                                  flags
1816                                  next))
1817                         (a (lp (cdar ls) (new-state-number new) flags new)))
1818                    (and
1819                     a
1820                     (begin
1821                       ;; for *, insert an epsilon transition as in ? above
1822                       (if (eq? '* (caar ls))
1823                           (set-cdr! (car a)
1824                                     `((epsilon . ,(caar new)) ,@(cdar a))))
1825                       ;; for both, insert a loop back to self
1826                       (set-cdr! (car new)
1827                                 `((epsilon . ,(caar a)) ,@(cdar new)))
1828                       a))))))
1829              ((submatch submatch-named)
1830               ;; ignore submatches altogether
1831               (lp (cons (sre-sequence (cdar ls)) (cdr ls)) n flags next))
1832              (else
1833               #f)))))
1834         (else
1835          #f)))))
1836
1837;; We don't really want to use this, we use the closure compilation
1838;; below instead, but this is included for reference and testing the
1839;; sre->nfa conversion.
1840
1841;; (define (nfa-match nfa str)
1842;;   (let lp ((ls (string->list str)) (state (car nfa)) (epsilons '()))
1843;;     (if (null? ls)
1844;;         (zero? (car state))
1845;;         (any (lambda (m)
1846;;                (if (eq? 'epsilon (car m))
1847;;                    (and (not (memv (cdr m) epsilons))
1848;;                         (lp ls (assv (cdr m) nfa) (cons (cdr m) epsilons)))
1849;;                    (and (or (eqv? (car m) (car ls))
1850;;                             (and (pair? (car m))
1851;;                                  (char<=? (caar m) (car ls))
1852;;                                  (char<=? (car ls) (cdar m))))
1853;;                         (lp (cdr ls) (assv (cdr m) nfa) '()))))
1854;;              (cdr state)))))
1855
1856;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1857;; NFA->DFA compilation
1858;;
1859;; During processing, the DFA is a list of the form:
1860;;
1861;;   ((NFA-states ...) accepting-state? transitions ...)
1862;;
1863;; where the transitions are as in the NFA, except there are no
1864;; epsilons, duplicate characters or overlapping char-set ranges, and
1865;; the states moved to are closures (sets of NFA states).  Multiple
1866;; DFA states may be accepting states.
1867
1868(define (nfa->dfa nfa . o)
1869  (let ((max-states (and (pair? o) (car o))))
1870    (let lp ((ls (list (nfa-closure nfa (list (caar nfa)))))
1871             (i 0)
1872             (res '()))
1873      (cond
1874       ((null? ls)
1875        (dfa-renumber (reverse res)))
1876       ((assoc (car ls) res)
1877        (lp (cdr ls) i res))
1878       (else
1879        (let* ((states (car ls))
1880               (trans (nfa-state-transitions nfa states))
1881               (accept? (and (memv 0 states) #t)))
1882          (and (or (not max-states) (< (+ i 1) max-states))
1883               (lp (append (map cdr trans) (cdr ls))
1884                   (+ i 1)
1885                   `((,states ,accept? ,@trans) ,@res)))))))))
1886
1887;; When the conversion is complete we renumber the DFA sets-of-states
1888;; in order and convert the result to a vector for fast lookup.
1889(define (dfa-renumber dfa)
1890  (let ((states (map cons (map car dfa) (zero-to (length dfa)))))
1891    (define (renumber state)
1892      (cdr (assoc state states)))
1893    (list->vector
1894     (map
1895      (lambda (node)
1896        (cons (cadr node)
1897              (map (lambda (x) (cons (car x) (renumber (cdr x))))
1898                   (cddr node)))) 
1899      dfa))))
1900
1901;; Extract all distinct characters or ranges and the potential states
1902;; they can transition to from a given set of states.  Any ranges that
1903;; would overlap with distinct characters are split accordingly.
1904(define (nfa-state-transitions nfa states)
1905  (let lp ((trans '())   ;; list of (char . state) or ((char . char) . state)
1906           (ls states)   ;; list of integers (remaining state numbers)
1907           (res '()))    ;; (char state ...) or ((char . char) state ...)
1908    (cond
1909     ((null? trans)
1910      (if (null? ls)
1911          (map (lambda (x) (cons (car x) (nfa-closure nfa (cdr x))))
1912               res)
1913          (let ((node (assv (car ls) nfa)))
1914            (lp (if node (cdr node) '()) (cdr ls) res))))
1915     ((eq? 'epsilon (caar trans))
1916      (lp (cdr trans) ls res))
1917     (else
1918      (lp (cdr trans) ls (nfa-join-transitions! res (car trans)))))))
1919
1920(define (nfa-join-transitions! existing new)
1921  (define (join ls elt state)
1922    (if (not elt)
1923        ls
1924        (nfa-join-transitions! ls (cons elt state))))
1925  (cond
1926   ((char? (car new))
1927    (let ((ch (car new)))
1928      (let lp ((ls existing) (res '()))
1929        (cond
1930         ((null? ls)
1931          ;; done, just cons this on to the original list
1932          (cons (list ch (cdr new)) existing))
1933         ((eqv? ch (caar ls))
1934          ;; add a new state to an existing char
1935          (set-cdr! (car ls) (insert-sorted (cdr new) (cdar ls)))
1936          existing)
1937         ((and (pair? (caar ls))
1938               (char<=? (caaar ls) ch)
1939               (char<=? ch (cdaar ls)))
1940          ;; split a range
1941          (apply
1942           (lambda (left right)
1943             (cons (cons ch (insert-sorted (cdr new) (cdar ls)))
1944                   (append (if left (list (cons left (cdar ls))) '())
1945                           (if right (list (cons right (cdar ls))) '())
1946                           res
1947                           (cdr ls))))
1948           (split-char-range (caar ls) (car new))))
1949         (else
1950          ;; keep looking
1951          (lp (cdr ls) (cons (car ls) res)))))))
1952   (else
1953    (let ((lo (caar new))
1954          (hi (cdar new)))
1955      (let lp ((ls existing) (res '()))
1956        (cond
1957         ((null? ls)
1958          (cons (list (car new) (cdr new)) existing))
1959         ((and (char? (caar ls)) (char<=? lo (caar ls)) (char<=? (caar ls) hi))
1960          ;; range enclosing a character
1961          (apply
1962           (lambda (left right)
1963             (set-cdr! (car ls) (insert-sorted (cdr new) (cdar ls)))
1964             (join (join existing left (cdr new)) right (cdr new)))
1965           (split-char-range (car new) (caar ls))))
1966         ((and (pair? (caar ls))
1967               (or (and (char<=? (caaar ls) hi) (char<=? lo (cdaar ls)))
1968                   (and (char<=? hi (caaar ls)) (char<=? (cdaar ls) lo))))
1969          ;; overlapping ranges
1970          (apply
1971           (lambda (left1 left2 same right1 right2)
1972             (let ((old-states (cdar ls)))
1973               (set-car! (car ls) same)
1974               (set-cdr! (car ls) (insert-sorted (cdr new) old-states))
1975               (let* ((res (if right1
1976                               (cons (cons right1 old-states) existing)
1977                               existing))
1978                      (res (if right2 (cons (cons right2 old-states) res) res)))
1979                 (join (join res left1 (cdr new)) left2 (cdr new)))))
1980           (intersect-char-ranges (car new) (caar ls))))
1981         (else
1982          (lp (cdr ls) (cons (car ls) res)))))))))
1983
1984(define (char-range c1 c2)
1985  (if (eqv? c1 c2) c1 (cons c1 c2)))
1986
1987;; assumes ch is included in the range
1988(define (split-char-range range ch)
1989  (list
1990   (and (not (eqv? ch (car range)))
1991        (char-range (car range) (integer->char (- (char->integer ch) 1))))
1992   (and (not (eqv? ch (cdr range)))
1993        (char-range (integer->char (+ (char->integer ch) 1)) (cdr range)))))
1994
1995;; returns (possibly #f) char ranges:
1996;;    a-only-1  a-only-2  a-and-b  b-only-1  b-only-2
1997(define (intersect-char-ranges a b)
1998  (if (char>? (car a) (car b))
1999      (reverse (intersect-char-ranges b a))
2000      (let ((a-lo (car a))
2001            (a-hi (cdr a))
2002            (b-lo (car b))
2003            (b-hi (cdr b)))
2004        (list
2005         (and (char<? a-lo b-lo)
2006              (char-range a-lo (integer->char (- (char->integer b-lo) 1))))
2007         (and (char>? a-hi b-hi)
2008              (char-range (integer->char (+ (char->integer b-hi) 1)) a-hi))
2009         (char-range b-lo (if (char<? b-hi a-hi) b-hi a-hi))
2010         #f
2011         (and (char>? b-hi a-hi)
2012              (char-range (integer->char (+ (char->integer a-hi) 1)) b-hi))))))
2013
2014;; The `closure' of a list of NFA states - all states that can be
2015;; reached from any of them using any number of epsilon transitions.
2016(define (nfa-closure nfa states)
2017  (let lp ((ls states)
2018           (res '()))
2019    (cond
2020     ((null? ls)
2021      res)
2022     ((memv (car ls) res)
2023      (lp (cdr ls) res))
2024     (else
2025      (lp (append (map cdr
2026                       (filter (lambda (trans) (eq? 'epsilon (car trans)))
2027                               (cdr (assv (car ls) nfa))))
2028                  (cdr ls))
2029          (insert-sorted (car ls) res))))))
2030
2031;; insert an integer uniquely into a sorted list
2032(define (insert-sorted n ls)
2033  (cond
2034   ((null? ls)
2035    (cons n '()))
2036   ((<= n (car ls))
2037    (if (= n (car ls))
2038        ls
2039        (cons n ls)))
2040   (else
2041    (cons (car ls) (insert-sorted n (cdr ls))))))
2042
2043;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2044;; DFAs don't give us match information, so once we match and
2045;; determine the start and end, we need to recursively break the
2046;; problem into smaller DFAs to get each submatch.
2047;;
2048;; See http://compilers.iecc.com/comparch/article/07-10-026
2049
2050(define (sre-match-extractor sre)
2051  (let lp ((sre sre) (n 1) (submatch-deps? #f))
2052    (cond
2053     ((not (sre-has-submatchs? sre))
2054      (if (not submatch-deps?)
2055          (lambda (str i j matches) j)
2056          (let ((dfa (nfa->dfa (sre->nfa sre))))
2057            (lambda (str i j matches)
2058              (dfa-match/longest dfa str i j)))))
2059     ((pair? sre)
2060      (case (car sre)
2061        ((: seq)
2062         (let* ((right (sre-sequence (cddr sre)))
2063                (match-left (lp (cadr sre) n #t))
2064                (match-right
2065                 (lp right (+ n (sre-count-submatches (cadr sre))) #t)))
2066           (lambda (str i j matches)
2067             (let lp ((k j) (best #f))
2068               (if (< k i)
2069                   best
2070                   (let* ((middle (match-left str i k matches))
2071                          (end (and middle
2072                                    (eqv? middle k)
2073                                    (match-right str middle j matches))))
2074                     (if (eqv? end j)
2075                         end
2076                         (lp (- k 1)
2077                             (if (or (not best) (and end (> end best)))
2078                                 end
2079                                 best)))))))))
2080        ((or)
2081         (let* ((rest (sre-alternate (cddr sre)))
2082                (match-first
2083                 (lp (cadr sre) n #t))
2084                (match-rest
2085                 (lp rest
2086                     (+ n (sre-count-submatches (cadr sre)))
2087                     submatch-deps?)))
2088           (lambda (str i j matches)
2089             (let ((k (match-first str i j matches)))
2090               (if (eqv? k j)
2091                   k
2092                   (match-rest str i j matches))))))
2093        ((* +)
2094         (letrec ((match-once
2095                   (lp (sre-sequence (cdr sre)) n #t))
2096                  (match-all
2097                   (lambda (str i j matches)
2098                     (let ((k (match-once str i j matches)))
2099                       (if (and k (< i k))
2100                           (match-all str k j matches)
2101                           i)))))
2102           (if (eq? '* (car sre))
2103               match-all
2104               (lambda (str i j matches)
2105                 (let ((k (match-once str i j matches)))
2106                   (and k
2107                        (match-all str k j matches)))))))
2108        ((?)
2109         (let ((match-once (lp (sre-sequence (cdr sre)) n #t)))
2110           (lambda (str i j matches)
2111             (let ((k (match-once str i j matches)))
2112               (or k i)))))
2113        ((submatch)
2114         (let ((match-one
2115                (lp (sre-sequence (cdr sre)) (+ n 1) #t)))
2116           (lambda (str i j matches)
2117             (let ((res (match-one str i j matches)))
2118               (cond
2119                ((number? res)
2120                 (irregex-match-start-index-set! matches n i)
2121                 (irregex-match-end-index-set! matches n res)))
2122               res))))
2123        (else
2124         (error "unknown regexp operator" (car sre)))))
2125     (else
2126      (error "unknown regexp" sre)))))
2127
2128;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2129;; closure compilation - we use this for non-regular expressions
2130;; instead of an interpreted NFA matcher
2131
2132(define (sre->procedure sre . o)
2133  (define names
2134    (if (and (pair? o) (pair? (cdr o))) (cadr o) (sre-names sre 1 '())))
2135  (let lp ((sre sre)
2136           (n 1)
2137           (flags (if (pair? o) (car o) ~none))
2138           (next (lambda (str i matches fail) i)))
2139    (define (rec sre) (lp sre n flags next))
2140    (cond
2141     ((pair? sre)
2142      (if (string? (car sre))
2143          (sre-cset->procedure
2144           (sre->cset (car sre) (flag-set? flags ~case-insensitive?))
2145           next)
2146          (case (car sre)
2147            ((~ - & /)
2148             (sre-cset->procedure
2149              (sre->cset sre (flag-set? flags ~case-insensitive?))
2150              next))
2151            ((or)
2152             (case (length (cdr sre))
2153               ((0) (lambda (str i matches fail) (fail)))
2154               ((1) (rec (cadr sre)))
2155               (else
2156                (let* ((first (rec (cadr sre)))
2157                       (rest (lp (sre-alternate (cddr sre))
2158                                 (+ n (sre-count-submatches (cadr sre)))
2159                                 flags
2160                                 next)))
2161                  (lambda (str i matches fail)
2162                    (first str i matches (lambda () (rest str i matches fail))))))))
2163            ((w/case)
2164             (lp (sre-sequence (cdr sre))
2165                 n
2166                 (flag-clear flags ~case-insensitive?)
2167                 next))
2168            ((w/nocase)
2169             (lp (sre-sequence (cdr sre))
2170                 n
2171                 (flag-join flags ~case-insensitive?)
2172                 next))
2173            ((w/utf8)
2174             (lp (sre-sequence (cdr sre)) n (flag-join flags ~utf8?) next))
2175            ((w/noutf8)
2176             (lp (sre-sequence (cdr sre)) n (flag-clear flags ~utf8?) next))
2177            ((seq :)
2178             (case (length (cdr sre))
2179               ((0) next)
2180               ((1) (rec (cadr sre)))
2181               (else
2182                (let ((rest (lp (sre-sequence (cddr sre))
2183                                (+ n (sre-count-submatches (cadr sre)))
2184                                flags
2185                                next)))
2186                  (lp (cadr sre) n flags rest)))))
2187            ((?)
2188             (let ((body (rec (sre-sequence (cdr sre)))))
2189               (lambda (str i matches fail)
2190                 (body str i matches (lambda () (next str i matches fail))))))
2191            ((??)
2192             (let ((body (rec (sre-sequence (cdr sre)))))
2193               (lambda (str i matches fail)
2194                 (next str i matches (lambda () (body str i matches fail))))))
2195            ((*)
2196             (cond
2197              ((sre-empty? (sre-sequence (cdr sre)))
2198               (error "invalid sre: empty *" sre))
2199              (else
2200               (letrec ((body
2201                         (lp (sre-sequence (cdr sre))
2202                             n
2203                             flags
2204                             (lambda (str i matches fail)
2205                               (body str
2206                                     i
2207                                     matches
2208                                     (lambda () (next str i matches fail)))))))
2209                 (lambda (str i matches fail)
2210                   (body str i matches (lambda () (next str i matches fail))))))))
2211            ((*?)
2212             (cond
2213              ((sre-empty? (sre-sequence (cdr sre)))
2214               (error "invalid sre: empty *?" sre))
2215              (else
2216               (letrec ((body
2217                         (lp (sre-sequence (cdr sre))
2218                             n
2219                             flags
2220                             (lambda (str i matches fail)
2221                               (next str
2222                                     i
2223                                     matches
2224                                     (lambda () (body str i matches fail)))))))
2225                 (lambda (str i matches fail)
2226                   (next str i matches (lambda () (body str i matches fail))))))))
2227            ((+)
2228             (lp (sre-sequence (cdr sre))
2229                 n
2230                 flags
2231                 (rec (list '* (sre-sequence (cdr sre))))))
2232            ((=)
2233             (rec `(** ,(cadr sre) ,(cadr sre) ,@(cddr sre))))
2234            ((>=)
2235             (rec `(** ,(cadr sre) #f ,@(cddr sre))))
2236            ((** **?)
2237             (cond
2238              ((or (and (number? (cadr sre))
2239                        (number? (caddr sre))
2240                        (> (cadr sre) (caddr sre)))
2241                   (and (not (cadr sre)) (caddr sre)))
2242               (lambda (str i matches fail) (fail)))
2243              (else
2244               (let* ((from (cadr sre))
2245                      (to (caddr sre))
2246                      (? (if (eq? '** (car sre)) '? '??))
2247                      (* (if (eq? '** (car sre)) '* '*?))
2248                      (sre (sre-sequence (cdddr sre)))
2249                      (x-sre (sre-strip-submatches sre))
2250                      (next (if to
2251                                (if (= from to)
2252                                    next
2253                                    (fold (lambda (x next)
2254                                            (lp `(,? ,sre) n flags next))
2255                                          next
2256                                          (zero-to (- to from))))
2257                                (rec `(,* ,sre)))))
2258                 (if (zero? from)
2259                     next
2260                     (lp `(seq ,@(map (lambda (x) x-sre) (zero-to (- from 1)))
2261                               ,sre)
2262                         n
2263                         flags
2264                         next))))))
2265            ((word)
2266             (rec `(seq bow ,@(cdr sre) eow)))
2267            ((word+)
2268             (rec `(seq bow (+ (& (or alphanumeric "_")
2269                                  (or ,@(cdr sre)))) eow)))
2270            ((posix-string)
2271             (rec (string->sre (cadr sre))))
2272            ((look-ahead)
2273             (let ((check
2274                    (lp (sre-sequence (cdr sre))
2275                        n
2276                        flags
2277                        (lambda (str i matches fail) i))))
2278               (lambda (str i matches fail)
2279                 (if (check str i matches (lambda () #f))
2280                     (next str i matches fail)
2281                     (fail)))))
2282            ((neg-look-ahead)
2283             (let ((check
2284                    (lp (sre-sequence (cdr sre))
2285                        n
2286                        flags
2287                        (lambda (str i matches fail) i))))
2288               (lambda (str i matches fail)
2289                 (if (check str i matches (lambda () #f))
2290                     (fail)
2291                     (next str i matches fail)))))
2292            ((look-behind)
2293             (let ((check
2294                    (lp (sre-sequence (cons '(* any) (cdr sre)))
2295                        n
2296                        flags
2297                        (lambda (str i matches fail) i))))
2298               (lambda (str i matches fail)
2299                 (if (eqv? i (check (substring str 0 i) 0 matches (lambda () #f)))
2300                     (next str i matches fail)
2301                     (fail)))))
2302            ((neg-look-behind)
2303             (let ((check
2304                    (lp (sre-sequence (cons '(* any) (cdr sre)))
2305                        n
2306                        flags
2307                        (lambda (str i matches fail) i))))
2308               (lambda (str i matches fail)
2309                 (if (eqv? i (check (substring str 0 i) 0 matches (lambda () #f)))
2310                     (fail)
2311                     (next str i matches fail)))))
2312            ((atomic)
2313             (let ((once
2314                    (lp (sre-sequence (cdr sre))
2315                        n
2316                        flags
2317                        (lambda (str i matches fail) i))))
2318               (lambda (str i matches fail)
2319                 (let ((j (once str i matches (lambda () #f))))
2320                   (if j
2321                       (next str j matches fail)
2322                       (fail))))))
2323            ((if)
2324             (let* ((test-submatches (sre-count-submatches (cadr sre)))
2325                    (pass (lp (caddr sre) flags (+ n test-submatches) next))
2326                    (fail (if (pair? (cdddr sre))
2327                              (lp (cadddr sre)
2328                                  (+ n test-submatches
2329                                     (sre-count-submatches (caddr sre)))
2330                                  flags
2331                                  next)
2332                              (lambda (str i matches fail) (fail)))))
2333               (cond
2334                ((or (number? (cadr sre)) (symbol? (cadr sre)))
2335                 (let ((index
2336                        (if (symbol? (cadr sre))
2337                            (cond
2338                             ((assq (cadr sre) names) => cdr)
2339                             (else
2340                              (error "unknown named backref in SRE IF" sre)))
2341                            (cadr sre))))
2342                   (lambda (str i matches fail2)
2343                     (if (irregex-match-end-index matches index)
2344                         (pass str i matches fail2)
2345                         (fail str i matches fail2)))))
2346                (else
2347                 (let ((test (lp (cadr sre) n flags pass)))
2348                   (lambda (str i matches fail2)
2349                     (test str i matches (lambda () (fail str i matches fail2)))
2350                     ))))))
2351            ((backref backref-ci)
2352             (let ((n (cond ((number? (cadr sre)) (cadr sre))
2353                            ((assq (cadr sre) names) => cdr)
2354                            (else (error "unknown backreference" (cadr sre)))))
2355                   (compare (if (or (eq? (car sre) 'backref-ci)
2356                                    (flag-set? flags ~case-insensitive?))
2357                                string-ci=?
2358                                string=?)))
2359               (lambda (str i matches fail)
2360                 (let ((s (irregex-match-substring matches n)))
2361                   (if (not s)
2362                       (fail)
2363                       (let ((j (+ i (string-length s))))
2364                         (if (and (<= j (string-length str))
2365                                  (compare s (substring str i j)))
2366                             (next str j matches fail)
2367                             (fail))))))))
2368            ((dsm)
2369             (lp (sre-sequence (cdddr sre)) (+ n (cadr sre)) flags next))
2370            ((submatch)
2371             (let ((body
2372                    (lp (sre-sequence (cdr sre))
2373                        (+ n 1)
2374                        flags
2375                        (lambda (str i matches fail)
2376                          (let ((old (irregex-match-end-index matches n)))
2377                            (irregex-match-end-index-set! matches n i)
2378                            (next str i matches
2379                                  (lambda ()
2380                                    (irregex-match-end-index-set! matches n old)
2381                                    (fail))))))))
2382               (lambda (str i matches fail)
2383                 (let ((old (irregex-match-start-index matches n)))
2384                   (irregex-match-start-index-set! matches n i)
2385                   (body str i matches
2386                         (lambda ()
2387                           (irregex-match-start-index-set! matches n old)
2388                           (fail)))))))
2389            ((submatch-named)
2390             (rec `(submatch ,@(cddr sre))))
2391            (else
2392             (error "unknown regexp operator" sre)))))
2393     ((symbol? sre)
2394      (case sre
2395        ((any)
2396         (lambda (str i matches fail)
2397           (if (< i (string-length str))
2398               (next str (+ i 1) matches fail)
2399               (fail))))
2400        ((nonl)
2401         (lambda (str i matches fail)
2402           (if (and (< i (string-length str))
2403                    (not (eqv? #\newline (string-ref str i))))
2404               (next str (+ i 1) matches fail)
2405               (fail))))
2406        ((bos)
2407         (lambda (str i matches fail)
2408           (if (zero? i) (next str i matches fail) (fail))))
2409        ((bol)
2410         (lambda (str i matches fail)
2411           (if (or (zero? i) (eqv? #\newline (string-ref str (- i 1))))
2412               (next str i matches fail)
2413               (fail))))
2414        ((bow)
2415         (lambda (str i matches fail)
2416           (if (and (or (zero? i)
2417                        (not (char-alphanumeric? (string-ref str (- i 1)))))
2418                    (< i (string-length str))
2419                    (char-alphanumeric? (string-ref str i)))
2420               (next str i matches fail)
2421               (fail))))
2422        ((eos)
2423         (lambda (str i matches fail)
2424           (if (>= i (string-length str)) (next str i matches fail) (fail))))
2425        ((eol)
2426         (lambda (str i matches fail)
2427           (if (or (>= i (string-length str))
2428                   (eqv? #\newline (string-ref str i)))
2429               (next str i matches fail)
2430               (fail))))
2431        ((eow)
2432         (lambda (str i matches fail)
2433           (if (and (or (>= i (string-length str))
2434                        (not (char-alphanumeric? (string-ref str i))))
2435                    (> i 0)
2436                    (char-alphanumeric? (string-ref str (- i 1))))
2437               (next str i matches fail)
2438               (fail))))
2439        ((nwb)  ;; non-word-boundary
2440         (lambda (str i matches fail)
2441           (if (and (not (zero? i))
2442                    (< i (string-length str))
2443                    (if (char-alphanumeric? (string-ref str (- i 1)))
2444                        (char-alphanumeric? (string-ref str i))
2445                        (not (char-alphanumeric? (string-ref str i)))))
2446               (next str i matches fail)
2447               (fail))))
2448        ((epsilon)
2449         next)
2450        (else
2451         (let ((cell (assq sre sre-named-definitions)))
2452           (if cell
2453               (rec (cdr cell))
2454               (error "unknown regexp" sre))))))
2455     ((char? sre)
2456      (if (flag-set? flags ~case-insensitive?)
2457          (lambda (str i matches fail)
2458            (if (and (< i (string-length str))
2459                     (char-ci=? sre (string-ref str i)))
2460                (next str (+ i 1) matches fail)
2461                (fail)))
2462          (lambda (str i matches fail)
2463            (if (and (< i (string-length str))
2464                     (eqv? sre (string-ref str i)))
2465                (next str (+ i 1) matches fail)
2466                (fail)))))
2467     ((string? sre)
2468      (rec (sre-sequence (string->list sre))))
2469     (else
2470      (error "unknown regexp" sre)))))
2471
2472;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2473;; Simple character sets as lists of ranges, as used in the NFA/DFA
2474;; compilation.  This is not especially efficient, but is portable and
2475;; scalable for any range of character sets.
2476
2477(define (sre-cset->procedure cset next)
2478  (lambda (str i matches fail)
2479    (if (and (< i (string-length str))
2480             (cset-contains? cset (string-ref str i)))
2481        (next str (+ i 1) matches fail)
2482        (fail))))
2483
2484(define (plist->alist ls)
2485  (let lp ((ls ls) (res '()))
2486    (if (null? ls)
2487        (reverse res)
2488        (lp (cddr ls) (cons (cons (car ls) (cadr ls)) res)))))
2489
2490(define (alist->plist ls)
2491  (let lp ((ls ls) (res '()))
2492    (if (null? ls)
2493        (reverse res)
2494        (lp (cdr ls) (cons (cdar ls) (cons (caar ls) res))))))
2495
2496(define (sre->cset sre . o)
2497  (let lp ((sre sre) (ci? (and (pair? o) (car o))))
2498    (define (rec sre) (lp sre ci?))
2499    (cond
2500     ((pair? sre)
2501      (if (string? (car sre))
2502          (if ci?
2503              (cset-case-insensitive (string->list (car sre)))
2504              (string->list (car sre)))
2505          (case (car sre)
2506            ((~)
2507             (cset-complement
2508              (fold cset-union (rec (cadr sre)) (map rec (cddr sre)))))
2509            ((&)
2510             (fold cset-intersection (rec (cadr sre)) (map rec (cddr sre))))
2511            ((-)
2512             (fold (lambda (x res) (cset-difference res x))
2513                   (rec (cadr sre))
2514                   (map rec (cddr sre))))
2515            ((/)
2516             (let ((res (plist->alist (sre-flatten-ranges (cdr sre)))))
2517               (if ci?
2518                   (cset-case-insensitive res)
2519                   res)))
2520            ((or)
2521             (fold cset-union (rec (cadr sre)) (map rec (cddr sre))))
2522            ((w/case)
2523             (lp (sre-alternate (cdr sre)) #f))
2524            ((w/nocase)
2525             (lp (sre-alternate (cdr sre)) #t))
2526            (else
2527             (error "not a valid sre char-set operator" sre)))))
2528     ((char? sre) (rec (list (string sre))))
2529     ((string? sre) (rec (list sre)))
2530     (else
2531      (let ((cell (assq sre sre-named-definitions)))
2532        (if cell
2533            (rec (cdr cell))
2534            (error "not a valid sre char-set" sre)))))))
2535
2536;;;; another debugging utility
2537;; (define (cset->sre cset)
2538;;   (let lp ((ls cset) (chars '()) (ranges '()))
2539;;     (cond
2540;;      ((null? ls)
2541;;       (sre-alternate
2542;;        (append
2543;;         (if (pair? chars) (list (list (list->string chars))) '())
2544;;         (if (pair? ranges) (list (cons '/ (alist->plist ranges))) '()))))
2545;;      ((char? (car ls)) (lp (cdr ls) (cons (car ls) chars) ranges))
2546;;      (else (lp (cdr ls) chars (cons (car ls) ranges))))))
2547
2548(define (cset-contains? cset ch)
2549  (find (lambda (x)
2550          (or (eqv? x ch)
2551              (and (pair? x) (char<=? (car x) ch) (char<=? ch (cdr x)))))
2552        cset))
2553
2554(define (cset-range x)
2555  (if (char? x) (cons x x) x))
2556
2557(define (char-ranges-overlap? a b)
2558  (if (pair? a)
2559      (if (pair? b)
2560          (or (and (char<=? (car a) (cdr b)) (char<=? (car b) (cdr a)))
2561              (and (char<=? (cdr b) (car a)) (char<=? (cdr a) (car b))))
2562          (and (char<=? (car a) b) (char<=? b (cdr a))))
2563      (if (pair? b)
2564          (char-ranges-overlap? b a)
2565          (eqv? a b))))
2566
2567(define (char-ranges-union a b)
2568  (cons (if (char<=? (car a) (car b)) (car a) (car b))
2569        (if (char>=? (cdr a) (cdr b)) (cdr a) (cdr b))))
2570
2571(define (cset-union a b)
2572  (cond ((null? b) a)
2573        ((find-tail (lambda (x) (char-ranges-overlap? x (car b))) a)
2574         => (lambda (ls)
2575              (cset-union
2576               (cset-union (append (take-up-to a ls) (cdr ls))
2577                           (list (char-ranges-union (cset-range (car ls))
2578                                                    (cset-range (car b)))))
2579               (cdr b))))
2580        (else (cset-union (cons (car b) a) (cdr b)))))
2581
2582(define (cset-difference a b)
2583  (cond ((null? b) a)
2584        ((not (car b)) (cset-difference a (cdr b)))
2585        ((find-tail (lambda (x) (char-ranges-overlap? x (car b))) a)
2586         => (lambda (ls)
2587              (apply
2588               (lambda (left1 left2 same right1 right2)
2589                 (let* ((a (append (take-up-to a ls) (cdr ls)))
2590                        (a (if left1 (cons left1 a) a))
2591                        (a (if left2 (cons left2 a) a))
2592                        (b (if right1 (cset-union b (list right1)) b))
2593                        (b (if right2 (cset-union b (list right2)) b)))
2594                   (cset-difference a b)))
2595               (intersect-char-ranges (cset-range (car ls))
2596                                      (cset-range (car b))))))
2597        (else (cset-difference a (cdr b)))))
2598
2599(define (cset-intersection a b)
2600  (let intersect ((a a) (b b) (res '()))
2601    (cond ((null? b) res)
2602          ((find-tail (lambda (x) (char-ranges-overlap? x (car b))) a)
2603           => (lambda (ls)
2604                (apply
2605                 (lambda (left1 left2 same right1 right2)
2606                   (let* ((a (append (take-up-to a ls) (cdr ls)))
2607                          (a (if left1 (cons left1 a) a))
2608                          (a (if left2 (cons left2 a) a))
2609                          (b (if right1 (cset-union b (list right1)) b))
2610                          (b (if right2 (cset-union b (list right2)) b)))
2611                     (intersect a b (cset-union res (list same)))))
2612                 (intersect-char-ranges (cset-range (car ls))
2613                                        (cset-range (car b))))))
2614          (else (intersect a (cdr b) res)))))
2615
2616(define (cset-complement a)
2617  (cset-difference (sre->cset *all-chars*) a))
2618
2619(define (cset-case-insensitive a)
2620  (let lp ((ls a) (res '()))
2621    (cond ((null? ls) (reverse res))
2622          ((and (char? (car ls)) (char-alphabetic? (car ls)))
2623           (let ((c2 (char-altcase (car ls)))
2624                 (res (cons (car ls) res)))
2625             (lp (cdr ls) (if (cset-contains? res c2) res (cons c2 res)))))
2626          ((and (pair? (car ls))
2627                (char-alphabetic? (caar ls))
2628                (char-alphabetic? (cdar ls)))
2629           (lp (cdr ls)
2630               (cset-union (cset-union res (list (car ls)))
2631                           (list (cons (char-altcase (caar ls))
2632                                       (char-altcase (cdar ls)))))))
2633          (else (lp (cdr ls) (cset-union res (list (car ls))))))))
2634
2635;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2636;; match and replace utilities
2637
2638(define (irregex-fold irx kons knil str . o)
2639  (let* ((irx (irregex irx))
2640         (matches (irregex-new-matches irx))
2641         (finish (if (pair? o) (car o) (lambda (i acc) acc)))
2642         (start (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
2643         (end (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
2644                  (caddr o)
2645                  (string-length str))))
2646    (irregex-match-string-set! matches str)
2647    (let lp ((i start) (acc knil))
2648      (if (>= i end)
2649          (finish i acc)
2650          (let ((m (irregex-search/matches irx str i end matches)))
2651            (if (not m)
2652                (finish i acc)
2653                (let* ((end (irregex-match-end m 0))
2654                       (acc (kons i m acc)))
2655                  (irregex-reset-matches! matches)
2656                  (lp end acc))))))))
2657
2658(define (irregex-replace irx str . o)
2659  (let ((m (irregex-search (irregex irx) str)))
2660    (and
2661     m
2662     (string-cat-reverse
2663      (cons (substring str (irregex-match-end m 0) (string-length str))
2664            (append (irregex-apply-match m o)
2665                    (list (substring str 0 (irregex-match-start m 0)))))))))
2666
2667(define (irregex-replace/all irx str . o)
2668  (irregex-fold
2669   irx
2670   (lambda (i m acc)
2671     (let ((m-start (irregex-match-start m 0)))
2672       (append (irregex-apply-match m o)
2673               (if (= i m-start)
2674                   acc
2675                   (cons (substring str i m-start) acc)))))
2676   '()
2677   str
2678   (lambda (i acc)
2679     (let ((end (string-length str)))
2680       (string-cat-reverse (if (= i end)
2681                               acc
2682                               (cons (substring str i end) acc)))))))
2683
2684(define (irregex-apply-match m ls)
2685  (let lp ((ls ls) (res '()))
2686    (if (null? ls)
2687        res
2688        (cond
2689         ((integer? (car ls))
2690          (lp (cdr ls)
2691              (cons (or (irregex-match-substring m (car ls)) "") res)))
2692         ((procedure? (car ls))
2693          (lp (cdr ls) (cons ((car ls) m) res)))
2694         ((symbol? (car ls))
2695          (case (car ls)
2696            ((pre)
2697             (lp (cdr ls)
2698                 (cons (substring (irregex-match-string m)
2699                                  0
2700                                  (irregex-match-start m 0))
2701                       res)))
2702            ((post)
2703             (lp (cdr ls)
2704                 (cons (substring (irregex-match-string m)
2705                                  (irregex-match-end m 0)
2706                                  (string-length (irregex-match-string m)))
2707                       res)))
2708            (else (error "unknown match replacement" (car ls)))))
2709         (else
2710          (lp (cdr ls) (cons (car ls) res)))))))
Note: See TracBrowser for help on using the repository browser.