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

Last change on this file since 13137 was 13137, checked in by Alex Shinn, 11 years ago

Fixing silly bug that didn't allow mixing the : abbreviation for seq
with submatches in DFA regular expressions.

File size: 105.0 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       (>= 5 (vector-length obj))
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                    (error "bad character class" str)))))
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               ((seq : w/case w/nocase atomic)
1285                (let lp2 ((ls (cdr sre)) (n n) (lo2 0) (hi2 0))
1286                  (if (null? ls)
1287                      (return (+ lo lo2) (and hi hi2 (+ hi hi2)))
1288                      (lp (car ls) n 0 0
1289                          (lambda (lo3 hi3)
1290                            (lp2 (cdr ls)
1291                                 (+ n (sre-count-submatches (car ls)))
1292                                 (+ lo2 lo3)
1293                                 (and hi2 hi3 (+ hi2 hi3))))))))
1294               ((or)
1295                (let lp2 ((ls (cdr sre)) (n n) (lo2 #f) (hi2 0))
1296                  (if (null? ls)
1297                      (return (+ lo lo2) (and hi hi2 (+ hi hi2)))
1298                      (lp (car ls) n 0 0
1299                          (lambda (lo3 hi3)
1300                            (lp2 (cdr ls)
1301                                 (+ n (sre-count-submatches (car ls)))
1302                                 (if lo2 (min lo2 lo3) lo3)
1303                                 (and hi2 hi3 (max hi2 hi3))))))))
1304               ((if)
1305                (cond
1306                 ((or (null? (cdr sre)) (null? (cddr sre)))
1307                  (return lo hi))
1308                 (else
1309                  (let ((n1 (sre-count-submatches (car sre)))
1310                        (n2 (sre-count-submatches (cadr sre))))
1311                    (lp (if (or (number? (cadr sre)) (symbol? (cadr sre)))
1312                            'epsilon
1313                            (cadr sre))
1314                        n lo hi
1315                        (lambda (lo2 hi2)
1316                          (lp (caddr sre) (+ n n1) 0 0
1317                              (lambda (lo3 hi3)
1318                                (lp (if (pair? (cdddr sre))
1319                                        (cadddr sre)
1320                                        'epsilon)
1321                                    (+ n n1 n2) 0 0
1322                                    (lambda (lo4 hi4)
1323                                      (return (+ lo2 (min lo3 lo4))
1324                                              (and hi2 hi3 hi4
1325                                                   (+ hi2 (max hi3 hi4))
1326                                                   ))))))))))))
1327               ((dsm)
1328                (lp (sre-sequence (cdddr sre)) (+ n (cadr sre)) lo hi return))
1329               ((submatch submatch-named)
1330                (lp (sre-sequence
1331                     (if (eq? 'submatch (car sre)) (cdr sre) (cddr sre)))
1332                    (+ n 1) lo hi
1333                    (lambda (lo2 hi2)
1334                      (vector-set! sublens n (cons lo2 hi2))
1335                      (return lo2 hi2))))
1336               ((backref backref-ci)
1337                (let ((n (cond
1338                          ((number? (cadr sre)) (cadr sre))
1339                          ((assq (cadr sre) names) => cdr)
1340                          (else (error "unknown backreference" (cadr sre))))))
1341                  (cond
1342                   ((or (not (integer? n))
1343                        (not (< 0 n (vector-length sublens))))
1344                    (error "sre-length: invalid backreference" sre))
1345                   ((not (vector-ref sublens n))
1346                    (error "sre-length: invalid forward backreference" sre))
1347                   (else
1348                    (let ((lo2 (car (vector-ref sublens n)))
1349                          (hi2 (cdr (vector-ref sublens n))))
1350                      (return (+ lo lo2) (and hi hi2 (+ hi hi2))))))))
1351               ((* *?)
1352                (lp (sre-sequence (cdr sre)) n lo hi (lambda (lo hi) #f))
1353                (return lo #f))
1354               ((** **?)
1355                (cond
1356                 ((or (and (number? (cadr sre))
1357                           (number? (caddr sre))
1358                           (> (cadr sre) (caddr sre)))
1359                      (and (not (cadr sre)) (caddr sre)))
1360                  (return lo hi))
1361                 (else
1362                  (if (caddr sre)
1363                      (lp (sre-sequence (cdddr sre)) n 0 0
1364                          (lambda (lo2 hi2)
1365                            (return (+ lo (* (cadr sre) lo2))
1366                                    (and hi hi2 (+ hi (* (caddr sre) hi2))))))
1367                      (lp (sre-sequence (cdddr sre)) n 0 0
1368                          (lambda (lo2 hi2)
1369                            (return (+ lo (* (cadr sre) lo2)) #f)))))))
1370               ((+)
1371                (lp (sre-sequence (cdr sre)) n lo hi
1372                    (lambda (lo2 hi2)
1373                      (return (+ lo lo2) #f))))
1374               ((? ??)
1375                (lp (sre-sequence (cdr sre)) n lo hi
1376                    (lambda (lo2 hi2)
1377                      (return lo (and hi hi2 (+ hi hi2))))))
1378               ((= =? >= >=?)
1379                (lp `(** ,(cadr sre)
1380                         ,(if (memq (car sre) '(>= >=?)) #f (cadr sre))
1381                         ,@(cddr sre))
1382                    n lo hi return))
1383               ((look-ahead neg-look-ahead look-behind neg-look-behind)
1384                (return lo hi))
1385               (else
1386                (error "sre-length-ranges: unknown sre operator" sre)))))
1387        ((char? sre)
1388         (grow 1))
1389        ((string? sre)
1390         (grow (string-length sre)))
1391        ((memq sre '(any nonl))
1392         (grow 1))
1393        ((memq sre '(epsilon bos eos bol eol bow eow nwb commit))
1394         (return lo hi))
1395        (else
1396         (let ((cell (assq sre sre-named-definitions)))
1397           (if cell
1398               (lp (cdr cell) n lo hi return)
1399               (error "sre-length-ranges: unknown sre" sre)))))))
1400    sublens))
1401
1402;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1403;; sre manipulation
1404
1405;; build a (seq ls ...) sre from a list
1406(define (sre-sequence ls)
1407  (cond
1408   ((null? ls) 'epsilon)
1409   ((null? (cdr ls)) (car ls))
1410   (else (cons 'seq ls))))
1411
1412;; build a (or ls ...) sre from a list
1413(define (sre-alternate ls)
1414  (cond
1415   ((null? ls) 'epsilon)
1416   ((null? (cdr ls)) (car ls))
1417   (else (cons 'or ls))))
1418
1419;; returns an equivalent SRE without any match information
1420(define (sre-strip-submatches sre)
1421  (if (not (pair? sre))
1422      sre
1423      (case (car sre)
1424        ((submatch) (sre-strip-submatches (sre-sequence (cdr sre))))
1425        ((dsm) (sre-strip-submatches (sre-sequence (cdddr sre))))
1426        (else (map sre-strip-submatches sre)))))
1427
1428;; given a char-set list of chars and strings, flattens them into
1429;; chars only
1430(define (sre-flatten-ranges ls)
1431  (let lp ((ls ls) (res '()))
1432    (cond
1433     ((null? ls)
1434      (reverse res))
1435     ((string? (car ls))
1436      (lp (append (string->list (car ls)) (cdr ls)) res))
1437     (else
1438      (lp (cdr ls) (cons (car ls) res))))))
1439
1440(define (sre-names sre n names)
1441  (if (not (pair? sre))
1442      names
1443      (case (car sre)
1444        ((submatch)
1445         (sre-names (sre-sequence (cdr sre)) (+ n 1) names))
1446        ((submatch-named)
1447         (sre-names (sre-sequence (cddr sre))
1448                    (+ n 1)
1449                    (cons (cons (cadr sre) n) names)))
1450        ((dsm)
1451         (sre-names (sre-sequence (cdddr sre)) (+ n (cadr sre)) names))
1452        ((seq : or * + ? *? ?? w/case w/nocase atomic
1453              look-ahead look-behind neg-look-ahead neg-look-behind)
1454         (sre-sequence-names (cdr sre) n names))
1455        ((= >=)
1456         (sre-sequence-names (cddr sre) n names))
1457        ((** **?)
1458         (sre-sequence-names (cdddr sre) n names))
1459        (else
1460         names))))
1461
1462(define (sre-sequence-names ls n names)
1463  (if (null? ls)
1464      names
1465      (sre-sequence-names (cdr ls)
1466                          (+ n (sre-count-submatches (car ls)))
1467                          (sre-names (car ls) n names))))
1468
1469(define (sre-remove-initial-bos sre)
1470  (cond
1471   ((pair? sre)
1472    (case (car sre)
1473      ((seq : submatch * +)
1474       (cond
1475        ((not (pair? (cdr sre)))
1476         sre)
1477        ((eq? 'bos (cadr sre))
1478         (cons (car sre) (cddr sre)))
1479        (else
1480         (cons (car sre)
1481               (cons (sre-remove-initial-bos (cadr sre)) (cddr sre))))))
1482      ((or)
1483       (sre-alternate (map sre-remove-initial-bos (cdr sre))))
1484      (else
1485       sre)))
1486   (else
1487    sre)))
1488
1489;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1490;; matching
1491
1492(define (irregex-search x str . o)
1493  (let ((irx (irregex x)))
1494    (let ((start (if (pair? o) (car o) 0))
1495          (end   (if (and (pair? o) (pair? (cdr o)))
1496                     (cadr o) (string-length str)))
1497          (matches (irregex-new-matches irx)))
1498      (irregex-match-string-set! matches str)
1499      (irregex-search/matches irx str start end matches))))
1500
1501;; internal routine, can be used in loops to avoid reallocating the
1502;; match vector
1503(define (irregex-search/matches irx str start end matches)
1504  (cond
1505   ((irregex-dfa irx)
1506    (cond
1507     ((flag-set? (irregex-flags irx) ~searcher?)
1508      (let ((m-end (dfa-match/longest (irregex-dfa irx) str start end)))
1509        (cond
1510         (m-end
1511          (irregex-match-start-index-set! matches 0 start)
1512          (irregex-match-end-index-set! matches 0 m-end)
1513          ((irregex-dfa/extract irx) str start m-end matches)
1514          matches)
1515         (else
1516          #f))))
1517     (else
1518      (let ((first-match
1519             (dfa-match/shortest (irregex-dfa/search irx) str start end)))
1520        (and
1521         first-match
1522         (let* ((lo+hi (vector-ref (irregex-lengths irx) 0))
1523                (m-start (if (cdr lo+hi)
1524                             (max start (- first-match (cdr lo+hi)))
1525                             start))
1526                (m-limit (- first-match (car lo+hi)))
1527                (dfa (irregex-dfa irx)))
1528           (let lp ((m-start m-start))
1529             (and (<= m-start m-limit)
1530                  (let ((m-end (dfa-match/longest dfa str m-start end)))
1531                    (cond
1532                     (m-end
1533                      (irregex-match-start-index-set! matches 0 m-start)
1534                      (irregex-match-end-index-set! matches 0 m-end)
1535                      ((irregex-dfa/extract irx) str m-start m-end matches)
1536                      matches)
1537                     (else
1538                      (lp (+ m-start 1)))))))))))))
1539   (else
1540    (let ((matcher (irregex-nfa irx)))
1541      (let lp ((start start))
1542        (and (<= start end)
1543             (let ((i (matcher str start matches (lambda () #f))))
1544               (cond
1545                (i
1546                 (irregex-match-start-index-set! matches 0 start)
1547                 (irregex-match-end-index-set! matches 0 i)
1548                 matches)
1549                (else
1550                 (lp (+ start 1)))))))))))
1551
1552(define (irregex-match irx str)
1553  (let* ((irx (irregex irx))
1554         (matches (irregex-new-matches irx))
1555         (start 0)
1556         (end (string-length str)))
1557    (irregex-match-string-set! matches str)
1558    (cond
1559     ((irregex-dfa irx)
1560      (let ((m-end (dfa-match/longest (irregex-dfa irx) str start end)))
1561        (cond
1562         ((equal? m-end end)
1563          (irregex-match-start-index-set! matches 0 start)
1564          (irregex-match-end-index-set! matches 0 m-end)
1565          ((irregex-dfa/extract irx) str start m-end matches)
1566          matches)
1567         (else
1568          #f))))
1569     (else
1570      (let* ((matcher (irregex-nfa irx))
1571             (i (matcher str start matches (lambda () #f))))
1572        (cond
1573         ((equal? i end)
1574          (irregex-match-start-index-set! matches 0 start)
1575          (irregex-match-end-index-set! matches 0 i)
1576          matches)
1577         (else
1578          #f)))))))
1579
1580;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1581;; DFA matching
1582
1583;; inline these
1584(define (dfa-init-state dfa)
1585  (vector-ref dfa 0))
1586(define (dfa-next-state dfa node)
1587  (vector-ref dfa (cdr node)))
1588(define (dfa-final-state? dfa state)
1589  (car state))
1590
1591;; this searches for the first end index for which a match is possible
1592(define (dfa-match/shortest dfa str start end)
1593  (let lp ((i start) (state (dfa-init-state dfa)))
1594    (if (dfa-final-state? dfa state)
1595        i
1596        (and (< i end)
1597             (let* ((ch (string-ref str i))
1598                    (next (find (lambda (x)
1599                                  (or (eqv? ch (car x))
1600                                      (and (pair? (car x))
1601                                           (char<=? (caar x) ch)
1602                                           (char<=? ch (cdar x)))))
1603                                (cdr state))))
1604               (and next (lp (+ i 1) (dfa-next-state dfa next))))))))
1605
1606;; this finds the longest match starting at a given index
1607(define (dfa-match/longest dfa str start end)
1608  (let lp ((i start)
1609           (state (dfa-init-state dfa))
1610           (res (and (dfa-final-state? dfa (dfa-init-state dfa)) start)))
1611    (if (>= i end)
1612        res
1613        (let* ((ch (string-ref str i))
1614               (cell (find (lambda (x)
1615                             (or (eqv? ch (car x))
1616                                 (and (pair? (car x))
1617                                      (char<=? (caar x) ch)
1618                                      (char<=? ch (cdar x)))))
1619                           (cdr state))))
1620          (if cell
1621              (let ((next (dfa-next-state dfa cell)))
1622                (lp (+ i 1)
1623                    next
1624                    (if (dfa-final-state? dfa next) (+ i 1) res)))
1625              res)))))
1626
1627;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1628;; SRE->NFA compilation
1629;;
1630;; An NFA state is a numbered node with a list of patter->number
1631;; transitions, where pattern is either a character, (lo . hi)
1632;; character range, or epsilon (indicating an empty transition).
1633;; There may be duplicate characters and overlapping ranges - since
1634;; it's an NFA we process it by considering all possible transitions.
1635
1636(define sre-named-definitions
1637  `((any . ,*all-chars*)
1638    (nonl . (- ,*all-chars* (,(string #\newline))))
1639    (alphabetic . (/ #\a #\z #\A #\Z))
1640    (alpha . alphabetic)
1641    (alphanumeric . (/ #\a #\z #\A #\Z #\0 #\9))
1642    (alphanum . alphanumeric)
1643    (alnum . alphanumeric)
1644    (lower-case . (/ #\a #\z))
1645    (lower . lower-case)
1646    (upper-case . (/ #\A #\Z))
1647    (upper . upper-case)
1648    (numeric . (/ #\0 #\9))
1649    (num . numeric)
1650    (digit . numeric)
1651    (punctuation . (or #\! #\" #\# #\% #\& #\' #\( #\) #\* #\, #\- #\.
1652                       #\/ #\: #\; #\? #\@ #\[ #\\ #\] #\_ #\{ #\}))
1653    (punct . punctuation)
1654    (graphic
1655     . (or alphanumeric punctuation #\$ #\+ #\< #\= #\> #\^ #\` #\| #\~))
1656    (graph . graphic)
1657    (blank . (or #\space ,(integer->char (- (char->integer #\space) 23))))
1658    (whitespace . (or blank #\newline))
1659    (space . whitespace)
1660    (white . whitespace)
1661    (printing or graphic whitespace)
1662    (print . printing)
1663    ;; XXXX we assume a (possibly shifted) ASCII-based ordering
1664    (control . (/ ,(integer->char (- (char->integer #\space) 32))
1665                  ,(integer->char (- (char->integer #\space) 1))))
1666    (cntrl . control)
1667    (hex-digit . (or numeric (/ #\a #\f #\A #\F)))
1668    (xdigit . hex-digit)
1669    (ascii . (/ ,(integer->char (- (char->integer #\space) 32))
1670                ,(integer->char (+ (char->integer #\space) 95))))
1671    (ascii-nonl . (/ ,(integer->char (- (char->integer #\space) 32))
1672                     ,(integer->char (- (char->integer #\newline) 1))
1673                     ,(integer->char (+ (char->integer #\newline) 1))
1674                     ,(integer->char (+ (char->integer #\space) 95))))
1675    (newline . (or (seq ,(integer->char (+ (char->integer #\newline) 3))
1676                        #\newline)
1677                   (/ #\newline
1678                      ,(integer->char (+ (char->integer #\newline) 3)))))
1679
1680    ;; ... it's really annoying to support scheme48
1681    (word . (seq bow (+ (or alphanumeric #\_)) eow))
1682    (utf8-tail-char . (/ ,(integer->char (+ (char->integer #\space) #x60))
1683                         ,(integer->char (+ (char->integer #\space) #xA1))))
1684    (utf8-2-char . (seq (/ ,(integer->char (+ (char->integer #\space) #xA2))
1685                           ,(integer->char (+ (char->integer #\space) #xBF)))
1686                        utf8-tail-char))
1687    (utf8-3-char . (seq (/ ,(integer->char (+ (char->integer #\space) #xC0))
1688                           ,(integer->char (+ (char->integer #\space) #xCF)))
1689                        utf8-tail-char
1690                        utf8-tail-char))
1691    (utf8-4-char . (seq (/ ,(integer->char (+ (char->integer #\space) #xD0))
1692                           ,(integer->char (+ (char->integer #\space) #xD7)))
1693                        utf8-tail-char
1694                        utf8-tail-char
1695                        utf8-tail-char))
1696    (utf8-any . (or ascii utf8-2-char utf8-3-char utf8-4-char))
1697    (utf8-nonl . (or ascii-nonl utf8-2-char utf8-3-char utf8-4-char))
1698    ))
1699
1700;; Compile and return the list of NFA states.  The start state will be
1701;; at the head of the list, and all remaining states will be in
1702;; descending numeric order, with state 0 being the unique accepting
1703;; state.
1704(define (sre->nfa sre . o)
1705  ;; we loop over an implicit sequence list
1706  (let lp ((ls (list sre))
1707           (n 1)
1708           (flags (if (pair? o) (car o) ~none))
1709           (next (list (list 0))))
1710    (define (new-state-number state)
1711      (max n (+ 1 (caar state))))
1712    (define (extend-state next . trans)
1713      (and next
1714           (cons (cons (new-state-number next)
1715                       (map (lambda (x) (cons x (caar next))) trans))
1716                 next)))
1717    (if (null? ls)
1718        next
1719        (cond
1720         ((string? (car ls))
1721          ;; process literal strings a char at a time
1722          (lp (append (string->list (car ls)) (cdr ls)) n flags next))
1723         ((eq? 'epsilon (car ls))
1724          ;; chars and epsilons go directly into the transition table
1725          (extend-state (lp (cdr ls) n flags next) (car ls)))
1726         ((char? (car ls))
1727          (let ((alt (char-altcase (car ls))))
1728            (if (and (flag-set? flags ~case-insensitive?)
1729                     (not (eqv? (car ls) alt)))
1730                (extend-state (lp (cdr ls) n flags next) (car ls) alt)
1731                (extend-state (lp (cdr ls) n flags next) (car ls)))))
1732         ((symbol? (car ls))
1733          (let ((cell (assq (car ls) sre-named-definitions)))
1734            (and cell (lp (cons (cdr cell) (cdr ls)) n flags next))))
1735         ((pair? (car ls))
1736          (cond
1737           ((string? (caar ls))
1738            ;; enumerated character set
1739            (lp (cons (sre-alternate (string->list (caar ls))) (cdr ls))
1740                n
1741                flags
1742                next))
1743           (else
1744            (case (caar ls)
1745              ((seq :)
1746               ;; for an explicit sequence, just append to the list
1747               (lp (append (cdar ls) (cdr ls)) n flags next))
1748              ((w/case w/nocase w/utf8 w/noutf8)
1749               (let* ((next (lp (cdr ls) n flags next))
1750                      (flags ((if (memq (caar ls) '(w/case w/utf8))
1751                                  flag-clear
1752                                  flag-join)
1753                              flags
1754                              (if (memq (caar ls) '(w/case w/nocase))
1755                                  ~case-insensitive?
1756                                  ~utf8?))))
1757                 (and next (lp (cdar ls) (new-state-number next) flags next))))
1758              ((/ - & ~) 
1759               (let ((ranges (sre->cset (car ls)
1760                                        (flag-set? flags ~case-insensitive?))))
1761                 (case (length ranges)
1762                   ((1)
1763                    (extend-state (lp (cdr ls) n flags next) (car ranges)))
1764                   (else
1765                    (let ((next (lp (cdr ls) n flags next)))
1766                      (and
1767                       next
1768                       (lp (list (sre-alternate
1769                                  (map (lambda (x) (if (pair? x)
1770                                                  (list '/ (car x) (cdr x))
1771                                                  x))
1772                                       ranges)))
1773                           (new-state-number next)
1774                           (flag-clear flags ~case-insensitive?)
1775                           next)))))))
1776              ((or)
1777               (let* ((next (lp (cdr ls) n flags next))
1778                      (b (and next
1779                              (lp (list (sre-alternate (cddar ls)))
1780                                  (new-state-number next)
1781                                  flags
1782                                  next)))
1783                      (a (and b (lp (list (cadar ls))
1784                                    (new-state-number b)
1785                                    flags
1786                                    next))))
1787                 ;; compile both branches and insert epsilon
1788                 ;; transitions to either
1789                 (and a
1790                      `((,(new-state-number a)
1791                         (epsilon . ,(caar a))
1792                         (epsilon . ,(caar b)))
1793                        ,@(take-up-to a next)
1794                        ,@b))))
1795              ((?)
1796               (let ((next (lp (cdr ls) n flags next)))
1797                 ;; insert an epsilon transition directly to next
1798                 (and
1799                  next
1800                  (let ((a (lp (cdar ls) (new-state-number next) flags next)))
1801                    (cond
1802                     (a
1803                      (set-cdr! (car a) `((epsilon . ,(caar next)) ,@(cdar a)))
1804                      a)
1805                     (else
1806                      #f))))))
1807              ((+ *)
1808               (let ((next (lp (cdr ls) n flags next)))
1809                 (and
1810                  next
1811                  (let* ((new (lp '(epsilon)
1812                                  (new-state-number next)
1813                                  flags
1814                                  next))
1815                         (a (lp (cdar ls) (new-state-number new) flags new)))
1816                    (and
1817                     a
1818                     (begin
1819                       ;; for *, insert an epsilon transition as in ? above
1820                       (if (eq? '* (caar ls))
1821                           (set-cdr! (car a)
1822                                     `((epsilon . ,(caar new)) ,@(cdar a))))
1823                       ;; for both, insert a loop back to self
1824                       (set-cdr! (car new)
1825                                 `((epsilon . ,(caar a)) ,@(cdar new)))
1826                       a))))))
1827              ((submatch submatch-named)
1828               ;; ignore submatches altogether
1829               (lp (cons (sre-sequence (cdar ls)) (cdr ls)) n flags next))
1830              (else
1831               #f)))))
1832         (else
1833          #f)))))
1834
1835;; We don't really want to use this, we use the closure compilation
1836;; below instead, but this is included for reference and testing the
1837;; sre->nfa conversion.
1838
1839;; (define (nfa-match nfa str)
1840;;   (let lp ((ls (string->list str)) (state (car nfa)) (epsilons '()))
1841;;     (if (null? ls)
1842;;         (zero? (car state))
1843;;         (any (lambda (m)
1844;;                (if (eq? 'epsilon (car m))
1845;;                    (and (not (memv (cdr m) epsilons))
1846;;                         (lp ls (assv (cdr m) nfa) (cons (cdr m) epsilons)))
1847;;                    (and (or (eqv? (car m) (car ls))
1848;;                             (and (pair? (car m))
1849;;                                  (char<=? (caar m) (car ls))
1850;;                                  (char<=? (car ls) (cdar m))))
1851;;                         (lp (cdr ls) (assv (cdr m) nfa) '()))))
1852;;              (cdr state)))))
1853
1854;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1855;; NFA->DFA compilation
1856;;
1857;; During processing, the DFA is a list of the form:
1858;;
1859;;   ((NFA-states ...) accepting-state? transitions ...)
1860;;
1861;; where the transitions are as in the NFA, except there are no
1862;; epsilons, duplicate characters or overlapping char-set ranges, and
1863;; the states moved to are closures (sets of NFA states).  Multiple
1864;; DFA states may be accepting states.
1865
1866(define (nfa->dfa nfa . o)
1867  (let ((max-states (and (pair? o) (car o))))
1868    (let lp ((ls (list (nfa-closure nfa (list (caar nfa)))))
1869             (i 0)
1870             (res '()))
1871      (cond
1872       ((null? ls)
1873        (dfa-renumber (reverse res)))
1874       ((assoc (car ls) res)
1875        (lp (cdr ls) i res))
1876       (else
1877        (let* ((states (car ls))
1878               (trans (nfa-state-transitions nfa states))
1879               (accept? (and (memv 0 states) #t)))
1880          (and (or (not max-states) (< (+ i 1) max-states))
1881               (lp (append (map cdr trans) (cdr ls))
1882                   (+ i 1)
1883                   `((,states ,accept? ,@trans) ,@res)))))))))
1884
1885;; When the conversion is complete we renumber the DFA sets-of-states
1886;; in order and convert the result to a vector for fast lookup.
1887(define (dfa-renumber dfa)
1888  (let ((states (map cons (map car dfa) (zero-to (length dfa)))))
1889    (define (renumber state)
1890      (cdr (assoc state states)))
1891    (list->vector
1892     (map
1893      (lambda (node)
1894        (cons (cadr node)
1895              (map (lambda (x) (cons (car x) (renumber (cdr x))))
1896                   (cddr node)))) 
1897      dfa))))
1898
1899;; Extract all distinct characters or ranges and the potential states
1900;; they can transition to from a given set of states.  Any ranges that
1901;; would overlap with distinct characters are split accordingly.
1902(define (nfa-state-transitions nfa states)
1903  (let lp ((trans '())   ;; list of (char . state) or ((char . char) . state)
1904           (ls states)   ;; list of integers (remaining state numbers)
1905           (res '()))    ;; (char state ...) or ((char . char) state ...)
1906    (cond
1907     ((null? trans)
1908      (if (null? ls)
1909          (map (lambda (x) (cons (car x) (nfa-closure nfa (cdr x))))
1910               res)
1911          (let ((node (assv (car ls) nfa)))
1912            (lp (if node (cdr node) '()) (cdr ls) res))))
1913     ((eq? 'epsilon (caar trans))
1914      (lp (cdr trans) ls res))
1915     (else
1916      (lp (cdr trans) ls (nfa-join-transitions! res (car trans)))))))
1917
1918(define (nfa-join-transitions! existing new)
1919  (define (join ls elt state)
1920    (if (not elt)
1921        ls
1922        (nfa-join-transitions! ls (cons elt state))))
1923  (cond
1924   ((char? (car new))
1925    (let ((ch (car new)))
1926      (let lp ((ls existing) (res '()))
1927        (cond
1928         ((null? ls)
1929          ;; done, just cons this on to the original list
1930          (cons (list ch (cdr new)) existing))
1931         ((eqv? ch (caar ls))
1932          ;; add a new state to an existing char
1933          (set-cdr! (car ls) (insert-sorted (cdr new) (cdar ls)))
1934          existing)
1935         ((and (pair? (caar ls))
1936               (char<=? (caaar ls) ch)
1937               (char<=? ch (cdaar ls)))
1938          ;; split a range
1939          (apply
1940           (lambda (left right)
1941             (cons (cons ch (insert-sorted (cdr new) (cdar ls)))
1942                   (append (if left (list (cons left (cdar ls))) '())
1943                           (if right (list (cons right (cdar ls))) '())
1944                           res
1945                           (cdr ls))))
1946           (split-char-range (caar ls) (car new))))
1947         (else
1948          ;; keep looking
1949          (lp (cdr ls) (cons (car ls) res)))))))
1950   (else
1951    (let ((lo (caar new))
1952          (hi (cdar new)))
1953      (let lp ((ls existing) (res '()))
1954        (cond
1955         ((null? ls)
1956          (cons (list (car new) (cdr new)) existing))
1957         ((and (char? (caar ls)) (char<=? lo (caar ls)) (char<=? (caar ls) hi))
1958          ;; range enclosing a character
1959          (apply
1960           (lambda (left right)
1961             (set-cdr! (car ls) (insert-sorted (cdr new) (cdar ls)))
1962             (join (join existing left (cdr new)) right (cdr new)))
1963           (split-char-range (car new) (caar ls))))
1964         ((and (pair? (caar ls))
1965               (or (and (char<=? (caaar ls) hi) (char<=? lo (cdaar ls)))
1966                   (and (char<=? hi (caaar ls)) (char<=? (cdaar ls) lo))))
1967          ;; overlapping ranges
1968          (apply
1969           (lambda (left1 left2 same right1 right2)
1970             (let ((old-states (cdar ls)))
1971               (set-car! (car ls) same)
1972               (set-cdr! (car ls) (insert-sorted (cdr new) old-states))
1973               (let* ((res (if right1
1974                               (cons (cons right1 old-states) existing)
1975                               existing))
1976                      (res (if right2 (cons (cons right2 old-states) res) res)))
1977                 (join (join res left1 (cdr new)) left2 (cdr new)))))
1978           (intersect-char-ranges (car new) (caar ls))))
1979         (else
1980          (lp (cdr ls) (cons (car ls) res)))))))))
1981
1982(define (char-range c1 c2)
1983  (if (eqv? c1 c2) c1 (cons c1 c2)))
1984
1985;; assumes ch is included in the range
1986(define (split-char-range range ch)
1987  (list
1988   (and (not (eqv? ch (car range)))
1989        (char-range (car range) (integer->char (- (char->integer ch) 1))))
1990   (and (not (eqv? ch (cdr range)))
1991        (char-range (integer->char (+ (char->integer ch) 1)) (cdr range)))))
1992
1993;; returns (possibly #f) char ranges:
1994;;    a-only-1  a-only-2  a-and-b  b-only-1  b-only-2
1995(define (intersect-char-ranges a b)
1996  (if (char>? (car a) (car b))
1997      (reverse (intersect-char-ranges b a))
1998      (let ((a-lo (car a))
1999            (a-hi (cdr a))
2000            (b-lo (car b))
2001            (b-hi (cdr b)))
2002        (list
2003         (and (char<? a-lo b-lo)
2004              (char-range a-lo (integer->char (- (char->integer b-lo) 1))))
2005         (and (char>? a-hi b-hi)
2006              (char-range (integer->char (+ (char->integer b-hi) 1)) a-hi))
2007         (char-range b-lo (if (char<? b-hi a-hi) b-hi a-hi))
2008         #f
2009         (and (char>? b-hi a-hi)
2010              (char-range (integer->char (+ (char->integer a-hi) 1)) b-hi))))))
2011
2012;; The `closure' of a list of NFA states - all states that can be
2013;; reached from any of them using any number of epsilon transitions.
2014(define (nfa-closure nfa states)
2015  (let lp ((ls states)
2016           (res '()))
2017    (cond
2018     ((null? ls)
2019      res)
2020     ((memv (car ls) res)
2021      (lp (cdr ls) res))
2022     (else
2023      (lp (append (map cdr
2024                       (filter (lambda (trans) (eq? 'epsilon (car trans)))
2025                               (cdr (assv (car ls) nfa))))
2026                  (cdr ls))
2027          (insert-sorted (car ls) res))))))
2028
2029;; insert an integer uniquely into a sorted list
2030(define (insert-sorted n ls)
2031  (cond
2032   ((null? ls)
2033    (cons n '()))
2034   ((<= n (car ls))
2035    (if (= n (car ls))
2036        ls
2037        (cons n ls)))
2038   (else
2039    (cons (car ls) (insert-sorted n (cdr ls))))))
2040
2041;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2042;; DFAs don't give us match information, so once we match and
2043;; determine the start and end, we need to recursively break the
2044;; problem into smaller DFAs to get each submatch.
2045;;
2046;; See http://compilers.iecc.com/comparch/article/07-10-026
2047
2048(define (sre-match-extractor sre)
2049  (let lp ((sre sre) (n 1) (submatch-deps? #f))
2050    (cond
2051     ((not (sre-has-submatchs? sre))
2052      (if (not submatch-deps?)
2053          (lambda (str i j matches) j)
2054          (let ((dfa (nfa->dfa (sre->nfa sre))))
2055            (lambda (str i j matches)
2056              (dfa-match/longest dfa str i j)))))
2057     ((pair? sre)
2058      (case (car sre)
2059        ((: seq)
2060         (let* ((right (sre-sequence (cddr sre)))
2061                (match-left (lp (cadr sre) n #t))
2062                (match-right
2063                 (lp right (+ n (sre-count-submatches (cadr sre))) #t)))
2064           (lambda (str i j matches)
2065             (let lp ((k j) (best #f))
2066               (if (< k i)
2067                   best
2068                   (let* ((middle (match-left str i k matches))
2069                          (end (and middle
2070                                    (eqv? middle k)
2071                                    (match-right str middle j matches))))
2072                     (if (eqv? end j)
2073                         end
2074                         (lp (- k 1)
2075                             (if (or (not best) (and end (> end best)))
2076                                 end
2077                                 best)))))))))
2078        ((or)
2079         (let* ((rest (sre-alternate (cddr sre)))
2080                (match-first
2081                 (lp (cadr sre) n #t))
2082                (match-rest
2083                 (lp rest
2084                     (+ n (sre-count-submatches (cadr sre)))
2085                     submatch-deps?)))
2086           (lambda (str i j matches)
2087             (let ((k (match-first str i j matches)))
2088               (if (eqv? k j)
2089                   k
2090                   (match-rest str i j matches))))))
2091        ((* +)
2092         (letrec ((match-once
2093                   (lp (sre-sequence (cdr sre)) n #t))
2094                  (match-all
2095                   (lambda (str i j matches)
2096                     (let ((k (match-once str i j matches)))
2097                       (if (and k (< i k))
2098                           (match-all str k j matches)
2099                           i)))))
2100           (if (eq? '* (car sre))
2101               match-all
2102               (lambda (str i j matches)
2103                 (let ((k (match-once str i j matches)))
2104                   (and k
2105                        (match-all str k j matches)))))))
2106        ((?)
2107         (let ((match-once (lp (sre-sequence (cdr sre)) n #t)))
2108           (lambda (str i j matches)
2109             (let ((k (match-once str i j matches)))
2110               (or k i)))))
2111        ((submatch)
2112         (let ((match-one
2113                (lp (sre-sequence (cdr sre)) (+ n 1) #t)))
2114           (lambda (str i j matches)
2115             (let ((res (match-one str i j matches)))
2116               (cond
2117                ((number? res)
2118                 (irregex-match-start-index-set! matches n i)
2119                 (irregex-match-end-index-set! matches n res)))
2120               res))))
2121        (else
2122         (error "unknown regexp operator" (car sre)))))
2123     (else
2124      (error "unknown regexp" sre)))))
2125
2126;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2127;; closure compilation - we use this for non-regular expressions
2128;; instead of an interpreted NFA matcher
2129
2130(define (sre->procedure sre . o)
2131  (define names
2132    (if (and (pair? o) (pair? (cdr o))) (cadr o) (sre-names sre 1 '())))
2133  (let lp ((sre sre)
2134           (n 1)
2135           (flags (if (pair? o) (car o) ~none))
2136           (next (lambda (str i matches fail) i)))
2137    (define (rec sre) (lp sre n flags next))
2138    (cond
2139     ((pair? sre)
2140      (if (string? (car sre))
2141          (sre-cset->procedure
2142           (sre->cset (car sre) (flag-set? flags ~case-insensitive?))
2143           next)
2144          (case (car sre)
2145            ((~ - & /)
2146             (sre-cset->procedure
2147              (sre->cset sre (flag-set? flags ~case-insensitive?))
2148              next))
2149            ((or)
2150             (case (length (cdr sre))
2151               ((0) (lambda (str i matches fail) (fail)))
2152               ((1) (rec (cadr sre)))
2153               (else
2154                (let* ((first (rec (cadr sre)))
2155                       (rest (lp (sre-alternate (cddr sre))
2156                                 (+ n (sre-count-submatches (cadr sre)))
2157                                 flags
2158                                 next)))
2159                  (lambda (str i matches fail)
2160                    (first str i matches (lambda () (rest str i matches fail))))))))
2161            ((w/case)
2162             (lp (sre-sequence (cdr sre))
2163                 n
2164                 (flag-clear flags ~case-insensitive?)
2165                 next))
2166            ((w/nocase)
2167             (lp (sre-sequence (cdr sre))
2168                 n
2169                 (flag-join flags ~case-insensitive?)
2170                 next))
2171            ((w/utf8)
2172             (lp (sre-sequence (cdr sre)) n (flag-join flags ~utf8?) next))
2173            ((w/noutf8)
2174             (lp (sre-sequence (cdr sre)) n (flag-clear flags ~utf8?) next))
2175            ((seq :)
2176             (case (length (cdr sre))
2177               ((0) next)
2178               ((1) (rec (cadr sre)))
2179               (else
2180                (let ((rest (lp (sre-sequence (cddr sre))
2181                                (+ n (sre-count-submatches (cadr sre)))
2182                                flags
2183                                next)))
2184                  (lp (cadr sre) n flags rest)))))
2185            ((?)
2186             (let ((body (rec (sre-sequence (cdr sre)))))
2187               (lambda (str i matches fail)
2188                 (body str i matches (lambda () (next str i matches fail))))))
2189            ((??)
2190             (let ((body (rec (sre-sequence (cdr sre)))))
2191               (lambda (str i matches fail)
2192                 (next str i matches (lambda () (body str i matches fail))))))
2193            ((*)
2194             (cond
2195              ((sre-empty? (sre-sequence (cdr sre)))
2196               (error "invalid sre: empty *" sre))
2197              (else
2198               (letrec ((body
2199                         (lp (sre-sequence (cdr sre))
2200                             n
2201                             flags
2202                             (lambda (str i matches fail)
2203                               (body str
2204                                     i
2205                                     matches
2206                                     (lambda () (next str i matches fail)))))))
2207                 (lambda (str i matches fail)
2208                   (body str i matches (lambda () (next str i matches fail))))))))
2209            ((*?)
2210             (cond
2211              ((sre-empty? (sre-sequence (cdr sre)))
2212               (error "invalid sre: empty *?" sre))
2213              (else
2214               (letrec ((body
2215                         (lp (sre-sequence (cdr sre))
2216                             n
2217                             flags
2218                             (lambda (str i matches fail)
2219                               (next str
2220                                     i
2221                                     matches
2222                                     (lambda () (body str i matches fail)))))))
2223                 (lambda (str i matches fail)
2224                   (next str i matches (lambda () (body str i matches fail))))))))
2225            ((+)
2226             (lp (sre-sequence (cdr sre))
2227                 n
2228                 flags
2229                 (rec (list '* (sre-sequence (cdr sre))))))
2230            ((=)
2231             (rec `(** ,(cadr sre) ,(cadr sre) ,@(cddr sre))))
2232            ((>=)
2233             (rec `(** ,(cadr sre) #f ,@(cddr sre))))
2234            ((** **?)
2235             (cond
2236              ((or (and (number? (cadr sre))
2237                        (number? (caddr sre))
2238                        (> (cadr sre) (caddr sre)))
2239                   (and (not (cadr sre)) (caddr sre)))
2240               (lambda (str i matches fail) (fail)))
2241              (else
2242               (let* ((from (cadr sre))
2243                      (to (caddr sre))
2244                      (? (if (eq? '** (car sre)) '? '??))
2245                      (* (if (eq? '** (car sre)) '* '*?))
2246                      (sre (sre-sequence (cdddr sre)))
2247                      (x-sre (sre-strip-submatches sre))
2248                      (next (if to
2249                                (if (= from to)
2250                                    next
2251                                    (fold (lambda (x next)
2252                                            (lp `(,? ,sre) n flags next))
2253                                          next
2254                                          (zero-to (- to from))))
2255                                (rec `(,* ,sre)))))
2256                 (if (zero? from)
2257                     next
2258                     (lp `(seq ,@(map (lambda (x) x-sre) (zero-to (- from 1)))
2259                               ,sre)
2260                         n
2261                         flags
2262                         next))))))
2263            ((word)
2264             (rec `(seq bow ,@(cdr sre) eow)))
2265            ((word+)
2266             (rec `(seq bow (+ (& (or alphanumeric "_")
2267                                  (or ,@(cdr sre)))) eow)))
2268            ((posix-string)
2269             (rec (string->sre (cadr sre))))
2270            ((look-ahead)
2271             (let ((check
2272                    (lp (sre-sequence (cdr sre))
2273                        n
2274                        flags
2275                        (lambda (str i matches fail) i))))
2276               (lambda (str i matches fail)
2277                 (if (check str i matches (lambda () #f))
2278                     (next str i matches fail)
2279                     (fail)))))
2280            ((neg-look-ahead)
2281             (let ((check
2282                    (lp (sre-sequence (cdr sre))
2283                        n
2284                        flags
2285                        (lambda (str i matches fail) i))))
2286               (lambda (str i matches fail)
2287                 (if (check str i matches (lambda () #f))
2288                     (fail)
2289                     (next str i matches fail)))))
2290            ((look-behind)
2291             (let ((check
2292                    (lp (sre-sequence (cons '(* any) (cdr sre)))
2293                        n
2294                        flags
2295                        (lambda (str i matches fail) i))))
2296               (lambda (str i matches fail)
2297                 (if (eqv? i (check (substring str 0 i) 0 matches (lambda () #f)))
2298                     (next str i matches fail)
2299                     (fail)))))
2300            ((neg-look-behind)
2301             (let ((check
2302                    (lp (sre-sequence (cons '(* any) (cdr sre)))
2303                        n
2304                        flags
2305                        (lambda (str i matches fail) i))))
2306               (lambda (str i matches fail)
2307                 (if (eqv? i (check (substring str 0 i) 0 matches (lambda () #f)))
2308                     (fail)
2309                     (next str i matches fail)))))
2310            ((atomic)
2311             (let ((once
2312                    (lp (sre-sequence (cdr sre))
2313                        n
2314                        flags
2315                        (lambda (str i matches fail) i))))
2316               (lambda (str i matches fail)
2317                 (let ((j (once str i matches (lambda () #f))))
2318                   (if j
2319                       (next str j matches fail)
2320                       (fail))))))
2321            ((if)
2322             (let* ((test-submatches (sre-count-submatches (cadr sre)))
2323                    (pass (lp (caddr sre) flags (+ n test-submatches) next))
2324                    (fail (if (pair? (cdddr sre))
2325                              (lp (cadddr sre)
2326                                  (+ n test-submatches
2327                                     (sre-count-submatches (caddr sre)))
2328                                  flags
2329                                  next)
2330                              (lambda (str i matches fail) (fail)))))
2331               (cond
2332                ((or (number? (cadr sre)) (symbol? (cadr sre)))
2333                 (let ((index
2334                        (if (symbol? (cadr sre))
2335                            (cond
2336                             ((assq (cadr sre) names) => cdr)
2337                             (else
2338                              (error "unknown named backref in SRE IF" sre)))
2339                            (cadr sre))))
2340                   (lambda (str i matches fail2)
2341                     (if (irregex-match-end-index matches index)
2342                         (pass str i matches fail2)
2343                         (fail str i matches fail2)))))
2344                (else
2345                 (let ((test (lp (cadr sre) n flags pass)))
2346                   (lambda (str i matches fail2)
2347                     (test str i matches (lambda () (fail str i matches fail2)))
2348                     ))))))
2349            ((backref backref-ci)
2350             (let ((n (cond ((number? (cadr sre)) (cadr sre))
2351                            ((assq (cadr sre) names) => cdr)
2352                            (else (error "unknown backreference" (cadr sre)))))
2353                   (compare (if (or (eq? (car sre) 'backref-ci)
2354                                    (flag-set? flags ~case-insensitive?))
2355                                string-ci=?
2356                                string=?)))
2357               (lambda (str i matches fail)
2358                 (let ((s (irregex-match-substring matches n)))
2359                   (if (not s)
2360                       (fail)
2361                       (let ((j (+ i (string-length s))))
2362                         (if (and (<= j (string-length str))
2363                                  (compare s (substring str i j)))
2364                             (next str j matches fail)
2365                             (fail))))))))
2366            ((dsm)
2367             (lp (sre-sequence (cdddr sre)) (+ n (cadr sre)) flags next))
2368            ((submatch)
2369             (let ((body
2370                    (lp (sre-sequence (cdr sre))
2371                        (+ n 1)
2372                        flags
2373                        (lambda (str i matches fail)
2374                          (let ((old (irregex-match-end-index matches n)))
2375                            (irregex-match-end-index-set! matches n i)
2376                            (next str i matches
2377                                  (lambda ()
2378                                    (irregex-match-end-index-set! matches n old)
2379                                    (fail))))))))
2380               (lambda (str i matches fail)
2381                 (let ((old (irregex-match-start-index matches n)))
2382                   (irregex-match-start-index-set! matches n i)
2383                   (body str i matches
2384                         (lambda ()
2385                           (irregex-match-start-index-set! matches n old)
2386                           (fail)))))))
2387            ((submatch-named)
2388             (rec `(submatch ,@(cddr sre))))
2389            (else
2390             (error "unknown regexp operator" sre)))))
2391     ((symbol? sre)
2392      (case sre
2393        ((any)
2394         (lambda (str i matches fail)
2395           (if (< i (string-length str))
2396               (next str (+ i 1) matches fail)
2397               (fail))))
2398        ((nonl)
2399         (lambda (str i matches fail)
2400           (if (and (< i (string-length str))
2401                    (not (eqv? #\newline (string-ref str i))))
2402               (next str (+ i 1) matches fail)
2403               (fail))))
2404        ((bos)
2405         (lambda (str i matches fail)
2406           (if (zero? i) (next str i matches fail) (fail))))
2407        ((bol)
2408         (lambda (str i matches fail)
2409           (if (or (zero? i) (eqv? #\newline (string-ref str (- i 1))))
2410               (next str i matches fail)
2411               (fail))))
2412        ((bow)
2413         (lambda (str i matches fail)
2414           (if (and (or (zero? i)
2415                        (not (char-alphanumeric? (string-ref str (- i 1)))))
2416                    (< i (string-length str))
2417                    (char-alphanumeric? (string-ref str i)))
2418               (next str i matches fail)
2419               (fail))))
2420        ((eos)
2421         (lambda (str i matches fail)
2422           (if (>= i (string-length str)) (next str i matches fail) (fail))))
2423        ((eol)
2424         (lambda (str i matches fail)
2425           (if (or (>= i (string-length str))
2426                   (eqv? #\newline (string-ref str i)))
2427               (next str i matches fail)
2428               (fail))))
2429        ((eow)
2430         (lambda (str i matches fail)
2431           (if (and (or (>= i (string-length str))
2432                        (not (char-alphanumeric? (string-ref str i))))
2433                    (> i 0)
2434                    (char-alphanumeric? (string-ref str (- i 1))))
2435               (next str i matches fail)
2436               (fail))))
2437        ((nwb)  ;; non-word-boundary
2438         (lambda (str i matches fail)
2439           (if (and (not (zero? i))
2440                    (< i (string-length str))
2441                    (if (char-alphanumeric? (string-ref str (- i 1)))
2442                        (char-alphanumeric? (string-ref str i))
2443                        (not (char-alphanumeric? (string-ref str i)))))
2444               (next str i matches fail)
2445               (fail))))
2446        ((epsilon)
2447         next)
2448        (else
2449         (let ((cell (assq sre sre-named-definitions)))
2450           (if cell
2451               (rec (cdr cell))
2452               (error "unknown regexp" sre))))))
2453     ((char? sre)
2454      (if (flag-set? flags ~case-insensitive?)
2455          (lambda (str i matches fail)
2456            (if (and (< i (string-length str))
2457                     (char-ci=? sre (string-ref str i)))
2458                (next str (+ i 1) matches fail)
2459                (fail)))
2460          (lambda (str i matches fail)
2461            (if (and (< i (string-length str))
2462                     (eqv? sre (string-ref str i)))
2463                (next str (+ i 1) matches fail)
2464                (fail)))))
2465     ((string? sre)
2466      (rec (sre-sequence (string->list sre))))
2467     (else
2468      (error "unknown regexp" sre)))))
2469
2470;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2471;; Simple character sets as lists of ranges, as used in the NFA/DFA
2472;; compilation.  This is not especially efficient, but is portable and
2473;; scalable for any range of character sets.
2474
2475(define (sre-cset->procedure cset next)
2476  (lambda (str i matches fail)
2477    (if (and (< i (string-length str))
2478             (cset-contains? cset (string-ref str i)))
2479        (next str (+ i 1) matches fail)
2480        (fail))))
2481
2482(define (plist->alist ls)
2483  (let lp ((ls ls) (res '()))
2484    (if (null? ls)
2485        (reverse res)
2486        (lp (cddr ls) (cons (cons (car ls) (cadr ls)) res)))))
2487
2488(define (alist->plist ls)
2489  (let lp ((ls ls) (res '()))
2490    (if (null? ls)
2491        (reverse res)
2492        (lp (cdr ls) (cons (cdar ls) (cons (caar ls) res))))))
2493
2494(define (sre->cset sre . o)
2495  (let lp ((sre sre) (ci? (and (pair? o) (car o))))
2496    (define (rec sre) (lp sre ci?))
2497    (cond
2498     ((pair? sre)
2499      (if (string? (car sre))
2500          (if ci?
2501              (cset-case-insensitive (string->list (car sre)))
2502              (string->list (car sre)))
2503          (case (car sre)
2504            ((~)
2505             (cset-complement
2506              (fold cset-union (rec (cadr sre)) (map rec (cddr sre)))))
2507            ((&)
2508             (fold cset-intersection (rec (cadr sre)) (map rec (cddr sre))))
2509            ((-)
2510             (fold (lambda (x res) (cset-difference res x))
2511                   (rec (cadr sre))
2512                   (map rec (cddr sre))))
2513            ((/)
2514             (let ((res (plist->alist (sre-flatten-ranges (cdr sre)))))
2515               (if ci?
2516                   (cset-case-insensitive res)
2517                   res)))
2518            ((or)
2519             (fold cset-union (rec (cadr sre)) (map rec (cddr sre))))
2520            ((w/case)
2521             (lp (sre-alternate (cdr sre)) #f))
2522            ((w/nocase)
2523             (lp (sre-alternate (cdr sre)) #t))
2524            (else
2525             (error "not a valid sre char-set operator" sre)))))
2526     ((char? sre) (rec (list (string sre))))
2527     ((string? sre) (rec (list sre)))
2528     (else
2529      (let ((cell (assq sre sre-named-definitions)))
2530        (if cell
2531            (rec (cdr cell))
2532            (error "not a valid sre char-set" sre)))))))
2533
2534;;;; another debugging utility
2535;; (define (cset->sre cset)
2536;;   (let lp ((ls cset) (chars '()) (ranges '()))
2537;;     (cond
2538;;      ((null? ls)
2539;;       (sre-alternate
2540;;        (append
2541;;         (if (pair? chars) (list (list (list->string chars))) '())
2542;;         (if (pair? ranges) (list (cons '/ (alist->plist ranges))) '()))))
2543;;      ((char? (car ls)) (lp (cdr ls) (cons (car ls) chars) ranges))
2544;;      (else (lp (cdr ls) chars (cons (car ls) ranges))))))
2545
2546(define (cset-contains? cset ch)
2547  (find (lambda (x)
2548          (or (eqv? x ch)
2549              (and (pair? x) (char<=? (car x) ch) (char<=? ch (cdr x)))))
2550        cset))
2551
2552(define (cset-range x)
2553  (if (char? x) (cons x x) x))
2554
2555(define (char-ranges-overlap? a b)
2556  (if (pair? a)
2557      (if (pair? b)
2558          (or (and (char<=? (car a) (cdr b)) (char<=? (car b) (cdr a)))
2559              (and (char<=? (cdr b) (car a)) (char<=? (cdr a) (car b))))
2560          (and (char<=? (car a) b) (char<=? b (cdr a))))
2561      (if (pair? b)
2562          (char-ranges-overlap? b a)
2563          (eqv? a b))))
2564
2565(define (char-ranges-union a b)
2566  (cons (if (char<=? (car a) (car b)) (car a) (car b))
2567        (if (char>=? (cdr a) (cdr b)) (cdr a) (cdr b))))
2568
2569(define (cset-union a b)
2570  (cond ((null? b) a)
2571        ((find-tail (lambda (x) (char-ranges-overlap? x (car b))) a)
2572         => (lambda (ls)
2573              (cset-union
2574               (cset-union (append (take-up-to a ls) (cdr ls))
2575                           (list (char-ranges-union (cset-range (car ls))
2576                                                    (cset-range (car b)))))
2577               (cdr b))))
2578        (else (cset-union (cons (car b) a) (cdr b)))))
2579
2580(define (cset-difference a b)
2581  (cond ((null? b) a)
2582        ((not (car b)) (cset-difference a (cdr b)))
2583        ((find-tail (lambda (x) (char-ranges-overlap? x (car b))) a)
2584         => (lambda (ls)
2585              (apply
2586               (lambda (left1 left2 same right1 right2)
2587                 (let* ((a (append (take-up-to a ls) (cdr ls)))
2588                        (a (if left1 (cons left1 a) a))
2589                        (a (if left2 (cons left2 a) a))
2590                        (b (if right1 (cset-union b (list right1)) b))
2591                        (b (if right2 (cset-union b (list right2)) b)))
2592                   (cset-difference a b)))
2593               (intersect-char-ranges (cset-range (car ls))
2594                                      (cset-range (car b))))))
2595        (else (cset-difference a (cdr b)))))
2596
2597(define (cset-intersection a b)
2598  (let intersect ((a a) (b b) (res '()))
2599    (cond ((null? b) res)
2600          ((find-tail (lambda (x) (char-ranges-overlap? x (car b))) a)
2601           => (lambda (ls)
2602                (apply
2603                 (lambda (left1 left2 same right1 right2)
2604                   (let* ((a (append (take-up-to a ls) (cdr ls)))
2605                          (a (if left1 (cons left1 a) a))
2606                          (a (if left2 (cons left2 a) a))
2607                          (b (if right1 (cset-union b (list right1)) b))
2608                          (b (if right2 (cset-union b (list right2)) b)))
2609                     (intersect a b (cset-union res (list same)))))
2610                 (intersect-char-ranges (cset-range (car ls))
2611                                        (cset-range (car b))))))
2612          (else (intersect a (cdr b) res)))))
2613
2614(define (cset-complement a)
2615  (cset-difference (sre->cset *all-chars*) a))
2616
2617(define (cset-case-insensitive a)
2618  (let lp ((ls a) (res '()))
2619    (cond ((null? ls) (reverse res))
2620          ((and (char? (car ls)) (char-alphabetic? (car ls)))
2621           (let ((c2 (char-altcase (car ls)))
2622                 (res (cons (car ls) res)))
2623             (lp (cdr ls) (if (cset-contains? res c2) res (cons c2 res)))))
2624          ((and (pair? (car ls))
2625                (char-alphabetic? (caar ls))
2626                (char-alphabetic? (cdar ls)))
2627           (lp (cdr ls)
2628               (cset-union (cset-union res (list (car ls)))
2629                           (list (cons (char-altcase (caar ls))
2630                                       (char-altcase (cdar ls)))))))
2631          (else (lp (cdr ls) (cset-union res (list (car ls))))))))
2632
2633;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2634;; match and replace utilities
2635
2636(define (irregex-fold irx kons knil str . o)
2637  (let* ((irx (irregex irx))
2638         (matches (irregex-new-matches irx))
2639         (finish (if (pair? o) (car o) (lambda (i acc) acc)))
2640         (start (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
2641         (end (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
2642                  (caddr o)
2643                  (string-length str))))
2644    (irregex-match-string-set! matches str)
2645    (let lp ((i start) (acc knil))
2646      (if (>= i end)
2647          (finish i acc)
2648          (let ((m (irregex-search/matches irx str i end matches)))
2649            (if (not m)
2650                (finish i acc)
2651                (let* ((end (irregex-match-end m 0))
2652                       (acc (kons i m acc)))
2653                  (irregex-reset-matches! matches)
2654                  (lp end acc))))))))
2655
2656(define (irregex-replace irx str . o)
2657  (let ((m (irregex-search (irregex irx) str)))
2658    (and
2659     m
2660     (string-cat-reverse
2661      (cons (substring str (irregex-match-end m 0) (string-length str))
2662            (append (irregex-apply-match m o)
2663                    (list (substring str 0 (irregex-match-start m 0)))))))))
2664
2665(define (irregex-replace/all irx str . o)
2666  (irregex-fold
2667   irx
2668   (lambda (i m acc)
2669     (let ((m-start (irregex-match-start m 0)))
2670       (append (irregex-apply-match m o)
2671               (if (= i m-start)
2672                   acc
2673                   (cons (substring str i m-start) acc)))))
2674   '()
2675   str
2676   (lambda (i acc)
2677     (let ((end (string-length str)))
2678       (string-cat-reverse (if (= i end)
2679                               acc
2680                               (cons (substring str i end) acc)))))))
2681
2682(define (irregex-apply-match m ls)
2683  (let lp ((ls ls) (res '()))
2684    (if (null? ls)
2685        res
2686        (cond
2687         ((integer? (car ls))
2688          (lp (cdr ls)
2689              (cons (or (irregex-match-substring m (car ls)) "") res)))
2690         ((procedure? (car ls))
2691          (lp (cdr ls) (cons ((car ls) m) res)))
2692         ((symbol? (car ls))
2693          (case (car ls)
2694            ((pre)
2695             (lp (cdr ls)
2696                 (cons (substring (irregex-match-string m)
2697                                  0
2698                                  (irregex-match-start m 0))
2699                       res)))
2700            ((post)
2701             (lp (cdr ls)
2702                 (cons (substring (irregex-match-string m)
2703                                  (irregex-match-end m 0)
2704                                  (string-length (irregex-match-string m)))
2705                       res)))
2706            (else (error "unknown match replacement" (car ls)))))
2707         (else
2708          (lp (cdr ls) (cons (car ls) res)))))))
Note: See TracBrowser for help on using the repository browser.