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

* Better dealing with errors in eval-string and read-from-string/-all

Browse Source 
* Made them work with byte strings too
* Added tests to the above

svn: r5081
This commit is contained in:
Eli Barzilay 2006-12-11 18:03:33 +00:00
parent 8ee09f09d8
commit a772fa8c84
5 changed files with 60 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/macro-debugger/syntax-browser/snipclass.ss
View File

@ -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%))

18
collects/mrlib/cache-image-snip.ss
View File

@ -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?)]))
[argb-width (argb? . -> . integer?)]))

4
collects/mrlib/syntax-browser.ss
View File

@ -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%))

42
collects/mzlib/string.ss
View File

@ -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

24
collects/tests/mzscheme/string.ss
View File

@ -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)