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

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

updateed copyright

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