source: project/chicken/branches/scrutiny/irregex.scm @ 14827

Last change on this file since 14827 was 14827, checked in by felix winkelmann, 10 years ago

merged trunk changes until 14826 into scrutiny branch

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