diff --git a/collects/macro-debugger/syntax-browser/snipclass.ss b/collects/macro-debugger/syntax-browser/snipclass.ss index 50ac9b3e7b..ce5854c702 100644 --- a/collects/macro-debugger/syntax-browser/snipclass.ss +++ b/collects/macro-debugger/syntax-browser/snipclass.ss @@ -16,9 +16,8 @@ (define syntax-snipclass% (class snip-class% (define/override (read stream) - (let ([str (send stream get-bytes)]) - (make-object syntax-snip% - (unmarshall-syntax (read-from-string (bytes->string/utf-8 str)))))) + (make-object syntax-snip% + (unmarshall-syntax (read-from-string (send stream get-bytes))))) (super-instantiate ()))) (define snip-class (make-object syntax-snipclass%)) diff --git a/collects/mrlib/cache-image-snip.ss b/collects/mrlib/cache-image-snip.ss index 4fdc9d4a03..fd2b60d818 100644 --- a/collects/mrlib/cache-image-snip.ss +++ b/collects/mrlib/cache-image-snip.ss @@ -139,20 +139,18 @@ ;; ;; snip-class ;; - + (define cache-image-snip-class% (class snip-class% (define/override (read f) - (let ([data (read-from-string (bytes->string/utf-8 (send f get-bytes)) - void - (lambda (x) #f))]) + (let ([data (read-from-string (send f get-bytes) (lambda () #f))]) (if data - (argb->cache-image-snip (make-argb (first data) (second data)) - (third data) - (fourth data)) - (make-null-cache-image-snip)))) + (argb->cache-image-snip (make-argb (first data) (second data)) + (third data) + (fourth data)) + (make-null-cache-image-snip)))) (super-new))) - + (define snip-class (new cache-image-snip-class%)) (send snip-class set-version 1) (send snip-class set-classname (format "~s" `(lib "cache-image-snip.ss" "mrlib"))) @@ -655,4 +653,4 @@ for b3, we have: [argb? (any/c . -> . boolean?)] [make-argb ((vectorof (integer-in 0 255)) integer? . -> . argb?)] [argb-vector (argb? . -> . (vectorof (integer-in 0 255)))] - [argb-width (argb? . -> . integer?)])) \ No newline at end of file + [argb-width (argb? . -> . integer?)])) diff --git a/collects/mrlib/syntax-browser.ss b/collects/mrlib/syntax-browser.ss index f3486f3ddd..1254119479 100644 --- a/collects/mrlib/syntax-browser.ss +++ b/collects/mrlib/syntax-browser.ss @@ -36,8 +36,8 @@ needed to really make this work: (define syntax-snipclass% (class snip-class% (define/override (read stream) - (let ([str (send stream get-bytes)]) - (make-object syntax-snip% (unmarshall-syntax (read-from-string (bytes->string/utf-8 str)))))) + (make-object syntax-snip% + (unmarshall-syntax (read-from-string (send stream get-bytes))))) (super-instantiate ()))) (define snip-class (make-object syntax-snipclass%)) diff --git a/collects/mzlib/string.ss b/collects/mzlib/string.ss index 3eaf88a0d9..50ff96534b 100644 --- a/collects/mzlib/string.ss +++ b/collects/mzlib/string.ss @@ -26,23 +26,28 @@ (define string-lowercase! (make-string-do! char-downcase)) (define string-uppercase! (make-string-do! char-upcase)) - ;; helper for eval-string and read-from-string-one-or-all + ;; helpers for eval-string and read-from-string-one-or-all (define-syntax wrap-errors (syntax-rules () - [(wrap-errors error-display error-result body ...) - (if (or error-display error-result) + [(wrap-errors who error-handler body ...) + (if error-handler (with-handlers - ([void (lambda (exn) - ((or error-display - (lambda (x) ((error-display-handler) x exn))) - (exn-message exn)) - (and error-result (error-result)))]) + ([void + (cond [(not (procedure? error-handler)) + (error who "bad error handler: ~e" error-handler)] + [(procedure-arity-includes? error-handler 1) + error-handler] + [(procedure-arity-includes? error-handler 0) + (lambda (exn) (error-handler))] + [else (error who "bad error handler: ~e" error-handler)])]) body ...) (begin body ...))])) + (define (open-input-bstring s) + (if (bytes? s) (open-input-bytes s) (open-input-string s))) - (define/kw (eval-string str #:optional error-display error-result) - (wrap-errors error-display error-result - (let ([p (open-input-string str)]) + (define/kw (eval-string str #:optional error-handler) + (wrap-errors 'eval-string error-handler + (let ([p (open-input-bstring str)]) (apply values (let loop () (let ([e (read p)]) @@ -52,12 +57,13 @@ (lambda () (eval e)) (lambda vals (append vals (loop))))))))))) - (define/kw (read-from-string str #:optional error-display error-result) - (wrap-errors error-display error-result (read (open-input-string str)))) + (define/kw (read-from-string str #:optional error-handler) + (wrap-errors 'read-from-string error-handler + (read (open-input-bstring str)))) - (define/kw (read-from-string-all str #:optional error-display error-result) - (let ([p (open-input-string str)]) - (wrap-errors error-display error-result + (define/kw (read-from-string-all str #:optional error-handler) + (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)))))))) @@ -85,10 +91,10 @@ ;; Regexp helpers (define (bstring-length s) - (if (string? s) (string-length s) (bytes-length s))) + (if (bytes? s) (bytes-length s) (string-length s))) (define (subbstring s st e) - (if (string? s) (substring s st e) (subbytes s st e))) + (if (bytes? s) (subbytes s st e) (substring s st e))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Regexp helpers diff --git a/collects/tests/mzscheme/string.ss b/collects/tests/mzscheme/string.ss index e26c578cda..6a0eea43e5 100644 --- a/collects/tests/mzscheme/string.ss +++ b/collects/tests/mzscheme/string.ss @@ -11,6 +11,30 @@ (string-uppercase! s1) (test "HELLO!" 'uppercase s1)) + +(test 1 read-from-string "1") +(test #f read-from-string "#f (2 3) (") +(test #f read-from-string #"#f (2 3) (") +(test 1 read-from-string "(" (lambda () 1)) +(test 1 read-from-string "(" (lambda (_) 1)) +(test '(1) read-from-string-all "1") +(test '(#f (2 3)) read-from-string-all "#f (2 3)") +(test '(#f (2 3)) read-from-string-all #"#f (2 3)") +(test 1 read-from-string-all "(" (lambda () 1)) +(test 1 read-from-string-all "(" (lambda (_) 1)) + + +(test '1 eval-string "1") +(test-values '(1 2 3) (lambda () (eval-string "1 2 3"))) +(test-values '(1 2 3) (lambda () (eval-string #"1 2 3"))) +(test-values '(1 2 3) (lambda () (eval-string "(values 1 2 3)"))) +(test-values '() (lambda () (eval-string "(values)"))) +(test-values '(1 2 3) (lambda () (eval-string "1 (values 2 3)"))) +(test-values '(1 2 3) (lambda () (eval-string "(values 1 2) 3"))) +(test-values '(1 2 3 4 5) + (lambda () + (eval-string "(values 1 2) 3 (values) (values 4 5)"))) + (let ([s (list->string (let loop ([i 0]) (if (= i 256)