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

move to scheme/base

Browse Source 
svn: r16404

original commit: 6c33216f0ad212815adbf8504f2e29c122d3e978
This commit is contained in:
Eli Barzilay 2009-10-21 21:08:57 +00:00
parent b04eb5c240
commit dfab129cf3
1 changed files with 112 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
collects/mzlib/string.ss
View File

@ -1,39 +1,27 @@
(module string mzscheme
(require (only scheme/base
real->decimal-string
regexp-quote
regexp-replace-quote
regexp-match*
regexp-match-positions*
regexp-match-peek-positions*
regexp-split
regexp-match-exact?
regexp-try-match)
"kw.ss")
#lang scheme/base
(provide string-lowercase!
(provide string-lowercase!
string-uppercase!
eval-string
read-from-string
read-from-string-all
expr->string
(all-from-except scheme/base regexp-try-match)
(rename regexp-try-match regexp-match/fail-without-reading)
(except-out (all-from-out scheme/base) regexp-try-match)
(rename-out [regexp-try-match regexp-match/fail-without-reading])
glob->regexp)
(define ((make-string-do! translate who) s)
(define ((make-string-do! translate who) s)
(if (and (string? s) (not (immutable? s)))
(let loop ([n (sub1 (string-length s))])
(unless (negative? n)
(string-set! s n (translate (string-ref s n)))
(loop (sub1 n))))
(raise-type-error who "mutable string" s)))
(define string-lowercase! (make-string-do! char-downcase 'string-lowercase!))
(define string-uppercase! (make-string-do! char-upcase 'string-uppercase!))
(define string-lowercase! (make-string-do! char-downcase 'string-lowercase!))
(define string-uppercase! (make-string-do! char-upcase 'string-uppercase!))
;; helpers for eval-string and read-from-string-one-or-all
(define-syntax wrap-errors
;; helpers for eval-string and read-from-string-one-or-all
(define-syntax wrap-errors
(syntax-rules ()
[(wrap-errors who error-handler body ...)
(if error-handler
@ -48,10 +36,10 @@
[else (error who "bad error handler: ~e" error-handler)])])
body ...)
(begin body ...))]))
(define (open-input-bstring s)
(define (open-input-bstring s)
(if (bytes? s) (open-input-bytes s) (open-input-string s)))
(define/kw (eval-string str #:optional error-handler)
(define (eval-string str [error-handler #f])
(wrap-errors 'eval-string error-handler
(let ([p (open-input-bstring str)])
(apply values
@ -63,27 +51,27 @@
(lambda () (eval e))
(lambda vals (append vals (loop)))))))))))
(define/kw (read-from-string str #:optional error-handler)
(define (read-from-string str [error-handler #f])
(wrap-errors 'read-from-string error-handler
(read (open-input-bstring str))))
(define/kw (read-from-string-all str #:optional error-handler)
(define (read-from-string-all str [error-handler #f])
(let ([p (open-input-bstring str)])
(wrap-errors 'read-from-string-all error-handler
(let loop ([r '()])
(let ([v (read p)])
(if (eof-object? v) (reverse r) (loop (cons v r))))))))
(define (expr->string v)
(define (expr->string v)
(let ([port (open-output-string)])
(write v port)
(get-output-string port)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define glob->regexp
(define glob->regexp
(let-values
([(def-case-sens) (eq? (system-path-convention-type)'unix)]
([(def-case-sens) (eq? (system-path-convention-type) 'unix)]
[(item:s item:b simple-item:s simple-item:b)
(let ([rx (lambda (s)
(string-append
@ -99,8 +87,7 @@
(byte-regexp (string->bytes/utf-8 (rx range)))
(regexp (rx ""))
(byte-regexp (string->bytes/utf-8 (rx "")))))])
(lambda/kw (glob #:optional
[hide-dots? #t] [case-sens? def-case-sens] [simple? #f])
(lambda (glob [hide-dots? #t] [case-sens? def-case-sens] [simple? #f])
(let*-values ([(b?) (cond [(bytes? glob) #t]
[(string? glob) #f]
[else (raise-type-error
@ -134,5 +121,3 @@
(sub glob (caar ps) (cdar ps)))
(if (= i (caar ps))
r (cons (subq glob i (caar ps)) r))))))))))
)