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

Last change on this file since 13074 was 13074, checked in by felix winkelmann, 11 years ago

applied regex patches fixing indices from chicken-3 branch by Ivan to trunk (not tested yet)

File size: 12.5 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 irregex? irregex-match-data?
45    irregex-new-matches irregex-reset-matches!
46    irregex-match-start irregex-match-end irregex-match-substring
47    irregex-match-num-submatches
48    irregex-search irregex-search/matches irregex-match irregex-match-string
49    irregex-replace irregex-replace/all
50    irregex-dfa irregex-dfa/search irregex-dfa/extract
51    irregex-nfa irregex-flags irregex-submatches irregex-lengths irregex-names
52    ))
53
54(cond-expand
55 [paranoia]
56 [else
57  (declare
58    (no-bound-checks)
59    (no-procedure-checks-for-usual-bindings) ) ] )
60
61(include "unsafe-declarations.scm")
62
63(register-feature! 'regex 'irregex)
64
65(include "irregex.scm")
66
67(define-record regexp x)
68
69(define (regexp pat #!optional caseless extended utf8)
70  (make-regexp
71   (apply
72    irregex 
73    pat 
74    (let ((opts '()))
75      (when caseless (set! opts (cons 'i opts)))
76      (when extended (set! opts (cons 'x opts)))
77      (when utf8 (set! opts (cons 'utf8 opts)))
78      opts))) )
79
80(define (unregexp x)
81  (cond ((regexp? x) (regexp-x x))
82        ((irregex? x) x)
83        (else (irregex x))))
84
85(define (string-match rx str)
86  (let ((rx (unregexp rx)))
87    (and-let* ((m (irregex-match rx str)))
88      (let loop ((i (irregex-match-num-submatches m))
89                 (res '()))
90        (if (fx<= i 0)
91            (cons str res)
92            (loop (fx- i 1) (cons (irregex-match-substring m i) res)))))))
93
94(define (string-match-positions rx str)
95  (let ((rx (unregexp rx)))
96    (and-let* ((m (irregex-match rx str)))
97      (let loop ((i (irregex-match-num-submatches m))
98                 (res '()))
99        (if (fx<= i 0)
100            (cons (list 0 (string-length str)) res)
101            (loop (fx- i 1) (cons (list (irregex-match-start-index m i)
102                                        (irregex-match-end-index m i))
103                                  res)))))))
104
105(define (string-search rx str #!optional (start 0) (range (string-length str)))
106  (let ((rx (unregexp rx)))
107    (and-let* ((n (string-length str))
108               (m (irregex-search rx str start (min n (fx+ start range)))))
109      (let loop ((i (irregex-match-num-submatches m))
110                 (res '()))
111        (if (fx< i 0)
112            res
113            (loop (fx- i 1) (cons (irregex-match-substring m i) res)))))))
114
115(define (string-search-positions rx str #!optional (start 0) (range (string-length str)))
116  (let ((rx (unregexp rx)))
117    (and-let* ((n (string-length str))
118               (m (irregex-search rx str start (min n (fx+ start (fx- n 1))))))
119      (let loop ((i (irregex-match-num-submatches m))
120                 (res '()))
121        (if (fx< i 0)
122            res
123            (loop (fx- i 1) (cons (list (irregex-match-start-index m i)
124                                        (irregex-match-end-index m i))
125                                  res)))))))
126
127
128
129;;; Split string into fields:
130
131(define string-split-fields
132  (let ([reverse reverse]
133        [substring substring]
134        [string-search-positions string-search-positions] )
135    (lambda (rgxp str . mode-and-start)
136      (##sys#check-string str 'string-split-fields)
137      (let* ([argc (length mode-and-start)]
138             [len (##sys#size str)]
139             [mode (if (fx> argc 0) (car mode-and-start) #t)]
140             [start (if (fx> argc 1) (cadr mode-and-start) 0)]
141             [fini (case mode
142                     [(#:suffix)
143                      (lambda (ms start)
144                        (if (fx< start len)
145                            (##sys#error 'string-split-fields
146                                         "record does not end with suffix" str rgxp)
147                            (reverse ms) ) ) ]
148                     [(#:infix)
149                      (lambda (ms start)
150                        (if (fx>= start len)
151                            (reverse (cons "" ms))
152                            (reverse (cons (substring str start len) ms)) ) ) ]
153                     [else (lambda (ms start) (reverse ms)) ] ) ]
154             [fetch (case mode
155                      [(#:infix #:suffix) (lambda (start from to) (substring str start from))]
156                      [else (lambda (start from to) (substring str from to))] ) ] )
157        (let loop ([ms '()] [start start])
158          (let ([m (string-search-positions rgxp str start)])
159            (if m
160                (let* ([mp (car m)]
161                       [from (car mp)]
162                       [to (cadr mp)] )
163                  (if (fx= from to)
164                      (if (fx= to len)
165                          (fini ms start)
166                          (loop (cons (fetch start (fx+ from 1) (fx+ to 2)) ms) (fx+ to 1)) )
167                      (loop (cons (fetch start from to) ms) to) ) )
168                (fini ms start) ) ) ) ) ) ) )
169
170
171;;; Substitute matching strings:
172
173(define string-substitute
174  (let ([substring substring]
175        [reverse reverse]
176        [make-string make-string]
177        [string-search-positions string-search-positions] )
178    (lambda (regex subst string . flag)
179      (##sys#check-string subst 'string-substitute)
180      (let* ([which (if (pair? flag) (car flag) 1)]
181             [substlen (##sys#size subst)]
182             (strlen (##sys#size string))
183             [substlen-1 (fx- substlen 1)]
184             [result '()]
185             [total 0] )
186        (define (push x)
187          (set! result (cons x result))
188          (set! total (fx+ total (##sys#size x))) )
189        (define (substitute matches)
190          (let loop ([start 0] [index 0])
191            (if (fx>= index substlen-1)
192                (push (if (fx= start 0) subst (substring subst start substlen)))
193                (let ([c (##core#inline "C_subchar" subst index)]
194                      [index+1 (fx+ index 1)] )
195                  (if (char=? c #\\)
196                      (let ([c2 (##core#inline "C_subchar" subst index+1)])
197                        (if (and (not (char=? #\\ c2)) (char-numeric? c2))
198                            (let ([mi (list-ref matches (fx- (char->integer c2) 48))])
199                              (push (substring subst start index))
200                              (push (substring string (car mi) (cadr mi)))
201                              (loop (fx+ index 2) index+1) )
202                            (loop start (fx+ index+1 1)) ) )
203                      (loop start index+1) ) ) ) ) )
204        (let loop ([index 0] [count 1])
205          (let ((matches (and (fx< index strlen) 
206                              (string-search-positions regex string index))))
207            (cond [matches
208                   (let* ([range (car matches)]
209                          [upto (cadr range)] )
210                     (cond ((fx= 0 (fx- (cadr range) (car range)))
211                            (##sys#error
212                             'string-substitute "empty substitution match"
213                             regex) )
214                           ((or (not (fixnum? which)) (fx= count which))
215                            (push (substring string index (car range)))
216                            (substitute matches)
217                            (loop upto #f) )
218                           (else
219                            (push (substring string index upto))
220                            (loop upto (fx+ count 1)) ) ) ) ]
221                  [else
222                   (push (substring string index (##sys#size string)))
223                   (##sys#fragments->string total (reverse result)) ] ) ) ) ) ) ) )
224
225(define string-substitute*
226  (let ([string-substitute string-substitute])
227    (lambda (str smap . mode)
228      (##sys#check-string str 'string-substitute*)
229      (##sys#check-list smap 'string-substitute*)
230      (let ((mode (and (pair? mode) (car mode))))
231        (let loop ((str str) (smap smap))
232          (if (null? smap)
233              str
234              (let ((sm (car smap)))
235                (loop (string-substitute (car sm) (cdr sm) str mode)
236                      (cdr smap) ) ) ) ) ) ) ) )
237
238
239;;; Glob support:
240
241;FIXME is it worthwhile making this accurate?
242(define (glob? str)
243  (##sys#check-string str 'glob?)
244  (let loop ([idx (fx- (string-length str) 1)])
245    (and (fx<= 0 idx)
246         (case (string-ref str idx)
247           [(#\* #\] #\?)
248             (or (fx= 0 idx)
249                 (not (char=? #\\ (string-ref str (fx- idx 1))))
250                 (loop (fx- idx 2)))]
251           [else
252             (loop (fx- idx 1))]) ) ) )
253
254(define glob->regexp
255  (let ([list->string list->string]
256        [string->list string->list] )
257    (lambda (s)
258      (##sys#check-string s 'glob->regexp)
259      (list->string
260       (let loop ((cs (string->list s)))
261         (if (null? cs)
262             '()
263             (let ([c (car cs)]
264                   [rest (cdr cs)] )
265               (cond [(char=? c #\*)  `(#\. #\* ,@(loop rest))]
266                     [(char=? c #\?)  (cons '#\. (loop rest))]
267                     [(char=? c #\[)
268                      (cons
269                       #\[
270                       (let loop2 ((rest rest))
271                         (if (pair? rest)
272                             (cond ((char=? #\] (car rest))
273                                    (cons #\] (loop (cdr rest))))
274                                   ((and (char=? #\- (car rest)) (pair? (cdr rest)))
275                                    `(#\- ,(cadr rest) ,@(loop2 (cddr rest))))
276                                   ((and (pair? (cdr rest)) (pair? (cddr rest))
277                                         (char=? #\- (cadr rest)) )
278                                    `(,(car rest) #\- ,(caddr rest)
279                                      ,@(loop2 (cdddr rest))))
280                                   ((pair? rest)
281                                    (cons (car rest) (loop2 (cdr rest))))
282                                   ((null? rest)
283                                    (error 'glob->regexp "unexpected end of character class" s))))))]
284                     [(or (char-alphabetic? c) (char-numeric? c)) (cons c (loop rest))]
285                     [else `(#\\ ,c ,@(loop rest))] ) ) ) ) ) ) ) )
286
287
288;;; Grep-like function on list:
289
290(define grep
291  (let ([string-search string-search])
292    (lambda (rgxp lst)
293      (##sys#check-list lst 'grep)
294      (let loop ([lst lst])
295        (if (null? lst)
296            '()
297            (let ([x (car lst)]
298                  [r (cdr lst)] )
299              (if (string-search rgxp x)
300                  (cons x (loop r))
301                  (loop r) ) ) ) ) ) ) )
302
303
304;;; Escape regular expression (suggested by Peter Bex):
305
306(define regexp-escape
307  (let ([open-output-string open-output-string]
308        [get-output-string get-output-string] )
309    (lambda (str)
310      (##sys#check-string str 'regexp-escape)
311      (let ([out (open-output-string)]
312            [len (##sys#size str)] )
313        (let loop ([i 0])
314          (cond [(fx>= i len) (get-output-string out)]
315                [(memq (##core#inline "C_subchar" str i)
316                       '(#\. #\\ #\? #\* #\+ #\^ #\$ #\( #\) #\[ #\] #\| #\{ #\}))
317                 (##sys#write-char-0 #\\ out)
318                 (##sys#write-char-0 (##core#inline "C_subchar" str i) out)
319                 (loop (fx+ i 1)) ]
320                [else
321                 (##sys#write-char-0 (##core#inline "C_subchar" str i) out)
322                 (loop (fx+ i 1)) ] ) ) ) ) ) )
Note: See TracBrowser for help on using the repository browser.