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

Last change on this file since 13169 was 13169, checked in by Jim Ursetto, 12 years ago

Expose string->sre in Chicken 4 irregex

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