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

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

svn: r5081

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%
-              (make-object syntax-snip% 
+              (unmarshall-syntax (read-from-string (send stream get-bytes)))))
-                (unmarshall-syntax (read-from-string (bytes->string/utf-8 str))))))
           (super-instantiate ())))
       
       (define snip-class (make-object syntax-snipclass%))

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))
+        (let ([data (read-from-string (send f get-bytes) (lambda () #f))])
-                                      void
-                                      (lambda (x) #f))])
           (if data
-              (argb->cache-image-snip (make-argb (first data) (second data))
+            (argb->cache-image-snip (make-argb (first data) (second data))
-                                      (third data)
+                                    (third data)
-                                      (fourth data))
+                                    (fourth data))
-              (make-null-cache-image-snip))))
+            (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?)]))

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%
-          (make-object syntax-snip% (unmarshall-syntax (read-from-string (bytes->string/utf-8 str))))))
+          (unmarshall-syntax (read-from-string (send stream get-bytes)))))
       (super-instantiate ())))
   
   (define snip-class (make-object syntax-snipclass%))

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 ...)
+      [(wrap-errors who error-handler body ...)
-       (if (or error-display error-result)
+       (if error-handler
          (with-handlers
-             ([void (lambda (exn)
+             ([void
-                      ((or error-display
+               (cond [(not (procedure? error-handler))
-                           (lambda (x) ((error-display-handler) x exn)))
+                      (error who "bad error handler: ~e" error-handler)]
-                       (exn-message exn))
+                     [(procedure-arity-includes? error-handler 1)
-                      (and error-result (error-result)))])
+                      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)
+  (define/kw (eval-string str #:optional error-handler)
-    (wrap-errors error-display error-result
+    (wrap-errors 'eval-string error-handler
-      (let ([p (open-input-string str)])
+      (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)
+  (define/kw (read-from-string str #:optional error-handler)
-    (wrap-errors error-display error-result (read (open-input-string str))))
+    (wrap-errors 'read-from-string error-handler
+      (read (open-input-bstring str))))
 
-  (define/kw (read-from-string-all str #:optional error-display error-result)
+  (define/kw (read-from-string-all str #:optional error-handler)
-    (let ([p (open-input-string str)])
+    (let ([p (open-input-bstring str)])
-      (wrap-errors error-display error-result
+      (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

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)