source: project/chicken/trunk/regex.scm @ 15164

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

applied string-substitute patch by zb

File size: 12.6 KB
Line 
1;;;; regex.scm
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(cond-expand
29 [chicken-compile-shared]
30 [else (declare (unit regex))] )
31
32(declare
33  (usual-integrations)
34  (disable-interrupts)
35;  (disable-warning var)
36  (export
37    regexp? regexp
38    string-match string-match-positions string-search string-search-positions
39    string-split-fields string-substitute string-substitute*
40    glob? glob->regexp
41    grep
42    regexp-escape 
43
44    irregex string->irregex sre->irregex string->sre
45    irregex? irregex-match-data?
46    irregex-new-matches irregex-reset-matches!
47    irregex-match-start irregex-match-end irregex-match-substring
48    irregex-match-num-submatches
49    irregex-search irregex-search/matches irregex-match irregex-match-string
50    irregex-fold irregex-replace irregex-replace/all irregex-apply-match
51    irregex-dfa irregex-dfa/search irregex-dfa/extract
52    irregex-nfa irregex-flags irregex-submatches irregex-lengths irregex-names
53    ))
54
55(cond-expand
56 [paranoia]
57 [else
58  (declare
59    (no-bound-checks)
60    (no-procedure-checks-for-usual-bindings) ) ] )
61
62(include "unsafe-declarations.scm")
63
64(register-feature! 'regex 'irregex)
65
66(include "irregex.scm")
67
68
69;;; Record `regexp'
70
71(define-record regexp x)
72
73(define (regexp pat #!optional caseless extended utf8)
74  (make-regexp
75   (apply
76    irregex 
77    pat 
78    (let ((opts '()))
79      (when caseless (set! opts (cons 'i opts)))
80      (when extended (set! opts (cons 'x opts)))
81      (when utf8 (set! opts (cons 'utf8 opts)))
82      opts))) )
83
84(define (unregexp x)
85  (cond ((regexp? x) (regexp-x x))
86        ((irregex? x) x)
87        (else (irregex x))))
88
89
90;;; Basic `regexp' operations
91
92(define (string-match rx str)
93  (let ((rx (unregexp rx)))
94    (and-let* ((m (irregex-match rx str)))
95      (let loop ((i (irregex-match-num-submatches m))
96                 (res '()))
97        (if (fx<= i 0)
98            (cons str res)
99            (loop (fx- i 1) (cons (irregex-match-substring m i) res)))))))
100
101(define (string-match-positions rx str)
102  (let ((rx (unregexp rx)))
103    (and-let* ((m (irregex-match rx str)))
104      (let loop ((i (irregex-match-num-submatches m))
105                 (res '()))
106        (if (fx<= i 0)
107            (cons (list 0 (string-length str)) res)
108            (loop (fx- i 1) (cons (list (irregex-match-start-index m i)
109                                        (irregex-match-end-index m i))
110                                  res)))))))
111
112(define (string-search rx str #!optional (start 0) (range (string-length str)))
113  (let ((rx (unregexp rx)))
114    (and-let* ((n (string-length str))
115               (m (irregex-search rx str start (min n (fx+ start range)))))
116      (let loop ((i (irregex-match-num-submatches m))
117                 (res '()))
118        (if (fx< i 0)
119            res
120            (loop (fx- i 1) (cons (irregex-match-substring m i) res)))))))
121
122(define (string-search-positions rx str #!optional (start 0) (range (string-length str)))
123  (let ((rx (unregexp rx)))
124    (and-let* ((n (string-length str))
125               (m (irregex-search rx str start (min n (fx+ start range)))))
126      (let loop ((i (irregex-match-num-submatches m))
127                 (res '()))
128        (if (fx< i 0)
129            res
130            (loop (fx- i 1) (cons (list (irregex-match-start-index m i)
131                                        (irregex-match-end-index m i))
132                                  res)))))))
133
134
135;;; Split string into fields:
136
137(define string-split-fields
138  (let ([reverse reverse]
139        [substring substring]
140        [string-search-positions string-search-positions] )
141    (lambda (rx str . mode-and-start)
142      (##sys#check-string str 'string-split-fields)
143      (let* ([argc (length mode-and-start)]
144             [len (##sys#size str)]
145             [mode (if (fx> argc 0) (car mode-and-start) #t)]
146             [start (if (fx> argc 1) (cadr mode-and-start) 0)]
147             [fini (case mode
148                     [(#:suffix)
149                      (lambda (ms start)
150                        (if (fx< start len)
151                            (##sys#error 'string-split-fields
152                                         "record does not end with suffix" str rx)
153                            (reverse ms) ) ) ]
154                     [(#:infix)
155                      (lambda (ms start)
156                        (if (fx>= start len)
157                            (reverse (cons "" ms))
158                            (reverse (cons (substring str start len) ms)) ) ) ]
159                     [else (lambda (ms start) (reverse ms)) ] ) ]
160             [fetch (case mode
161                      [(#:infix #:suffix) (lambda (start from to) (substring str start from))]
162                      [else (lambda (start from to) (substring str from to))] ) ] )
163        (let loop ([ms '()] [start start])
164          (let ([m (string-search-positions rx str start)])
165            (if m
166                (let* ([mp (car m)]
167                       [from (car mp)]
168                       [to (cadr mp)] )
169                  (if (fx= from to)
170                      (if (fx= to len)
171                          (fini ms start)
172                          (loop (cons (fetch start (fx+ from 1) (fx+ to 2)) ms) (fx+ to 1)) )
173                      (loop (cons (fetch start from to) ms) to) ) )
174                (fini ms start) ) ) ) ) ) ) )
175
176
177;;; Substitute matching strings:
178
179(define string-substitute
180  (let ([substring substring]
181        [reverse reverse]
182        [make-string make-string]
183        [string-search-positions string-search-positions] )
184    (lambda (rx subst string . flag)
185      (##sys#check-string subst 'string-substitute)
186      (##sys#check-string string 'string-substitute)
187      (let* ([which (if (pair? flag) (car flag) 1)]
188             [substlen (##sys#size subst)]
189             (strlen (##sys#size string))
190             [substlen-1 (fx- substlen 1)]
191             [result '()]
192             [total 0] )
193        (define (push x)
194          (set! result (cons x result))
195          (set! total (fx+ total (##sys#size x))) )
196        (define (substitute matches)
197          (let loop ([start 0] [index 0])
198            (if (fx>= index substlen-1)
199                (push (if (fx= start 0) subst (substring subst start substlen)))
200                (let ([c (##core#inline "C_subchar" subst index)]
201                      [index+1 (fx+ index 1)] )
202                  (if (char=? c #\\)
203                      (let ([c2 (##core#inline "C_subchar" subst index+1)])
204                        (if (and (not (char=? #\\ c2)) (char-numeric? c2))
205                            (let ([mi (list-ref matches (fx- (char->integer c2) 48))])
206                              (push (substring subst start index))
207                              (push (substring string (car mi) (cadr mi)))
208                              (loop (fx+ index 2) index+1) )
209                            (loop start (fx+ index+1 1)) ) )
210                      (loop start index+1) ) ) ) ) )
211        (let loop ([index 0] [count 1])
212          (let ((matches (and (fx< index strlen) 
213                              (string-search-positions rx string index))))
214            (cond [matches
215                   (let* ([range (car matches)]
216                          [upto (cadr range)] )
217                     (cond ((fx= 0 (fx- (cadr range) (car range)))
218                            (##sys#error
219                             'string-substitute "empty substitution match"
220                             rx) )
221                           ((or (not (fixnum? which)) (fx= count which))
222                            (push (substring string index (car range)))
223                            (substitute matches)
224                            (loop upto #f) )
225                           (else
226                            (push (substring string index upto))
227                            (loop upto (fx+ count 1)) ) ) ) ]
228                  [else
229                   (push (substring string index (##sys#size string)))
230                   (##sys#fragments->string total (reverse result)) ] ) ) ) ) ) ) )
231
232(define string-substitute*
233  (let ([string-substitute string-substitute])
234    (lambda (str smap . mode)
235      (##sys#check-string str 'string-substitute*)
236      (##sys#check-list smap 'string-substitute*)
237      (let ((mode (and (pair? mode) (car mode))))
238        (let loop ((str str) (smap smap))
239          (if (null? smap)
240              str
241              (let ((sm (car smap)))
242                (loop (string-substitute (car sm) (cdr sm) str mode)
243                      (cdr smap) ) ) ) ) ) ) ) )
244
245
246;;; Glob support:
247
248;FIXME is it worthwhile making this accurate?
249(define (glob? str)
250  (##sys#check-string str 'glob?)
251  (let loop ([idx (fx- (string-length str) 1)])
252    (and (fx<= 0 idx)
253         (case (string-ref str idx)
254           [(#\* #\] #\?)
255             (or (fx= 0 idx)
256                 (not (char=? #\\ (string-ref str (fx- idx 1))))
257                 (loop (fx- idx 2)))]
258           [else
259             (loop (fx- idx 1))]) ) ) )
260
261(define glob->regexp
262  (let ([list->string list->string]
263        [string->list string->list] )
264    (lambda (s)
265      (##sys#check-string s 'glob->regexp)
266      (list->string
267       (let loop ((cs (string->list s)))
268         (if (null? cs)
269             '()
270             (let ([c (car cs)]
271                   [rest (cdr cs)] )
272               (cond [(char=? c #\*)  `(#\. #\* ,@(loop rest))]
273                     [(char=? c #\?)  (cons '#\. (loop rest))]
274                     [(char=? c #\[)
275                      (cons
276                       #\[
277                       (let loop2 ((rest rest))
278                         (if (pair? rest)
279                             (cond ((char=? #\] (car rest))
280                                    (cons #\] (loop (cdr rest))))
281                                   ((and (char=? #\- (car rest)) (pair? (cdr rest)))
282                                    `(#\- ,(cadr rest) ,@(loop2 (cddr rest))))
283                                   ((and (pair? (cdr rest)) (pair? (cddr rest))
284                                         (char=? #\- (cadr rest)) )
285                                    `(,(car rest) #\- ,(caddr rest)
286                                      ,@(loop2 (cdddr rest))))
287                                   ((pair? rest)
288                                    (cons (car rest) (loop2 (cdr rest))))
289                                   ((null? rest)
290                                    (error 'glob->regexp "unexpected end of character class" s))))))]
291                     [(or (char-alphabetic? c) (char-numeric? c)) (cons c (loop rest))]
292                     [else `(#\\ ,c ,@(loop rest))] ) ) ) ) ) ) ) )
293
294
295;;; Grep-like function on list:
296
297(define grep
298  (let ([string-search string-search])
299    (lambda (rx lst)
300      (##sys#check-list lst 'grep)
301      (let loop ([lst lst])
302        (if (null? lst)
303            '()
304            (let ([x (car lst)]
305                  [r (cdr lst)] )
306              (if (string-search rx x)
307                  (cons x (loop r))
308                  (loop r) ) ) ) ) ) ) )
309
310
311;;; Escape regular expression (suggested by Peter Bex):
312
313(define regexp-escape
314  (let ([open-output-string open-output-string]
315        [get-output-string get-output-string] )
316    (lambda (str)
317      (##sys#check-string str 'regexp-escape)
318      (let ([out (open-output-string)]
319            [len (##sys#size str)] )
320        (let loop ([i 0])
321          (cond [(fx>= i len) (get-output-string out)]
322                [(memq (##core#inline "C_subchar" str i)
323                       '(#\. #\\ #\? #\* #\+ #\^ #\$ #\( #\) #\[ #\] #\| #\{ #\}))
324                 (##sys#write-char-0 #\\ out)
325                 (##sys#write-char-0 (##core#inline "C_subchar" str i) out)
326                 (loop (fx+ i 1)) ]
327                [else
328                 (##sys#write-char-0 (##core#inline "C_subchar" str i) out)
329                 (loop (fx+ i 1)) ] ) ) ) ) ) )
Note: See TracBrowser for help on using the repository browser.