suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed some stuff, added tests, added simple option (no ranges)

Browse Source 
svn: r4935

original commit: f902ea5ba94950312a65b4e053cce635f8ecefe2
This commit is contained in:
Eli Barzilay 2006-11-23 17:38:53 +00:00
parent 28a09920e8
commit b5e99cbd94
1 changed files with 37 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
collects/mzlib/string.ss
View File

@ -404,34 +404,35 @@
#f)) #f))
(wrap regexp-match* -regexp-match*) (wrap regexp-match* -regexp-match*)
(define regexp-match-exact? (define (regexp-match-exact? p s)
(lambda (p s)
(let ([m (regexp-match-positions p s)]) (let ([m (regexp-match-positions p s)])
(and m (and m
(zero? (caar m)) (zero? (caar m))
(if (or (byte-regexp? p) (if (or (byte-regexp? p) (bytes? p) (bytes? s))
(bytes? p)
(bytes? s))
(= (cdar m) (if (bytes? s) (= (cdar m) (if (bytes? s)
(bytes-length s) (bytes-length s)
(string-utf-8-length s))) (string-utf-8-length s)))
(= (cdar m) (string-length s))))))) (= (cdar m) (string-length s))))))
(define glob->regexp (define glob->regexp
(let-values (let-values
([(def-case-sens) (not (memq (system-type) '(windows macos macosx)))] ([(def-case-sens) (not (memq (system-type) '(windows macos macosx)))]
[(item:s item:b) [(item:s item:b simple-item:s simple-item:b)
(let ([rx (string-append (let ([rx (lambda (s)
(string-append
"(?:" "(?:"
"[\\]." ; escaped item "[\\]." ; escaped item
"|" "|"
"[*?]" ; wildcards -- the only 1-character match "[*?]" ; wildcards -- the only 1-character match
"|" s ; [*] more stuff here
"\\[(?:\\^?\\]|\\^?[^]^])[^]]*\\]" ; range
")" ")"
)]) ))]
(values (regexp rx) (byte-regexp (string->bytes/utf-8 rx))))]) [range "|\\[(?:\\^?\\]|\\^?[^]^])[^]]*\\]"]) ; goes in [*]
(opt-lambda (glob [hide-dots? #t] [case-sens? def-case-sens]) (values (regexp (rx range))
(byte-regexp (string->bytes/utf-8 (rx range)))
(regexp (rx ""))
(byte-regexp (string->bytes/utf-8 (rx "")))))])
(opt-lambda (glob [hide-dots? #t] [case-sens? def-case-sens] [simple? #f])
(let*-values ([(b?) (cond [(bytes? glob) #t] (let*-values ([(b?) (cond [(bytes? glob) #t]
[(string? glob) #f] [(string? glob) #f]
[else (raise-type-error [else (raise-type-error
@ -440,9 +441,11 @@
[(app sub ref rx item star any one) [(app sub ref rx item star any one)
(if b? (if b?
(values bytes-append subbytes bytes-ref byte-regexp (values bytes-append subbytes bytes-ref byte-regexp
item:b (char->integer #\*) #".*" #".") (if simple? simple-item:b item:b)
(char->integer #\*) #".*" #".")
(values string-append substring string-ref regexp (values string-append substring string-ref regexp
item:s #\* ".*" "."))] (if simple? simple-item:s item:s)
#\* ".*" "."))]
[(pfx sfx) (if case-sens? [(pfx sfx) (if case-sens?
(if b? (values #"^" #"^") (if b? (values #"^" #"^")
(values "^" "$")) (values "^" "$"))
@ -450,21 +453,22 @@
(values "^(?i:" ")$")))] (values "^(?i:" ")$")))]
[(pfx) (if hide-dots? [(pfx) (if hide-dots?
(app pfx (if b? #"(?![.])" "(?![.])")) (app pfx (if b? #"(?![.])" "(?![.])"))
pfx)]) pfx)]
[(subq) (lambda xs (regexp-quote (apply sub xs)))])
(let loop ([i 0] [ps (regexp-match-positions* item glob)] [r '()]) (let loop ([i 0] [ps (regexp-match-positions* item glob)] [r '()])
(cond [(null? ps) (cond [(null? ps)
(rx (app pfx (let ([r (apply app (reverse! (cons (subq glob i) r)))])
(apply app (reverse! (cons (sub glob i) r))) (rx (app pfx r sfx)))]
sfx))]
[(= 1 (- (cdar ps) (caar ps))) [(= 1 (- (cdar ps) (caar ps)))
(loop (cdar ps) (loop (cdar ps)
(cdr ps) (cdr ps)
(cons (if (equal? star (ref glob (caar ps))) any one) (cons (if (equal? star (ref glob (caar ps))) any one)
(if (= i (caar ps)) (if (= i (caar ps))
r r (cons (subq glob i (caar ps)) r))))]
(cons (sub glob i (caar ps)) r))))]
[else (loop (cdar ps) [else (loop (cdar ps)
(cdr ps) (cdr ps)
(cons (sub glob i (cdar ps)) r))])))))) (cons (sub glob (caar ps) (cdar ps))
(if (= i (caar ps))
r (cons (subq glob i (caar ps)) r))))]))))))
) )