cs: rewrite some error messages from Chez Scheme

At least interpose on the value->string part of constructing an
error message and use the Racket-level error-value->string handler.

racket/src/cs/Makefile

@@ -252,6 +252,7 @@ RUMBLE_SRCS = rumble/define.ss \
               rumble/engine.ss \
               rumble/source.ss \
               rumble/error.ss \
+              rumble/error-rewrite.ss \
               rumble/srcloc.ss \
               rumble/boolean.ss \
               rumble/bytes.ss \

racket/src/cs/rumble.sls

@@ -732,6 +732,7 @@
   (include "rumble/engine.ss")
   (include "rumble/source.ss")
   (include "rumble/error.ss")
+  (include "rumble/error-rewrite.ss")
   (include "rumble/srcloc.ss")
   (include "rumble/boolean.ss")
   (include "rumble/bytes.ss")

racket/src/cs/rumble/error-rewrite.ss

@@ -0,0 +1,92 @@
+
+(define (condition->exception-constructor v)
+  (cond
+   [(or (and (format-condition? v)
+             (or (string-prefix? "incorrect number of arguments" (condition-message v))
+                 (string-suffix? "values to single value return context" (condition-message v))
+                 (string-prefix? "incorrect number of values received in multiple value context" (condition-message v))))
+        (and (message-condition? v)
+             (or (string-prefix? "incorrect argument count in call" (condition-message v))
+                 (string-prefix? "incorrect number of values from rhs" (condition-message v)))))
+    exn:fail:contract:arity]
+   [(and (format-condition? v)
+         (who-condition? v)
+         (#%memq (condition-who v) '(/ modulo remainder quotient atan angle log))
+         (string=? "undefined for ~s" (condition-message v)))
+    exn:fail:contract:divide-by-zero]
+   [(and (format-condition? v)
+         (who-condition? v)
+         (#%memq (condition-who v) '(expt atan2))
+         (string=? "undefined for values ~s and ~s" (condition-message v)))
+    exn:fail:contract:divide-by-zero]
+   [(and (format-condition? v)
+         (or (string=? "attempt to reference undefined variable ~s" (condition-message v))
+             (string=? "attempt to assign undefined variable ~s" (condition-message v))))
+    (lambda (msg marks)
+      (|#%app| exn:fail:contract:variable msg marks (car (condition-irritants v))))]
+   [(and (format-condition? v)
+         (string-prefix? "~?.  Some debugging context lost" (condition-message v)))
+    exn:fail]
+   [else
+    exn:fail:contract]))
+
+(define rewrites-added? #f)
+
+(define rewrite-who
+  (lambda (n)
+    (unless rewrites-added?
+      (letrec-syntax ([rename
+                       (syntax-rules ()
+                         [(_) (void)]
+                         [(_ from to . args)
+                          (begin
+                            (putprop 'from 'error-rename 'to)
+                            (rename . args))])])
+        (rename bytevector-u8-ref bytes-ref
+                bytevector-u8-set! bytes-set!
+                bitwise-arithmetic-shift arithmetic-shift
+                fixnum->flonum fx->fl 
+                flonum->fixnum fl->fx
+                fxarithmetic-shift-right fxrshift
+                fxarithmetic-shift-left fxlshift
+                real->flonum ->fl)
+        (set! rewrites-added? #t)))
+    (getprop n 'error-rename n)))
+
+(define (rewrite-format str irritants)
+  (cond
+   [(equal? str "attempt to reference undefined variable ~s")
+    (values "~a: undefined;\n cannot reference an identifier before its definition"
+            irritants)]
+   [else
+    (let ([str (string-copy str)]
+          [len (string-length str)])
+      (let loop ([i 0] [accum-irritants '()] [irritants irritants])
+        (cond
+         [(fx= i len)
+          ;; `irritants` should be empty by now
+          (values str (append (reverse accum-irritants) irritants))]
+         [(and (char=? #\~ (string-ref str i))
+               (fx< (fx+ i 1) len))
+          (case (string-ref str (fx+ i 1))
+            [(#\~ #\%) (loop (fx+ i 2) accum-irritants irritants)]
+            [(#\s)
+             (string-set! str (fx+ i 1) #\a)
+             (loop (fx+ i 2)
+                   (cons (error-value->string (car irritants))
+                         accum-irritants)
+                   (cdr irritants))]
+            [else (loop (fx+ i 2)
+                        (cons (car irritants)
+                              accum-irritants)
+                        (cdr irritants))])]
+         [else (loop (fx+ i 1) accum-irritants irritants)])))]))
+
+(define (string-prefix? p str)
+  (and (>= (string-length str) (string-length p))
+       (string=? (substring str 0 (string-length p)) p)))
+
+(define (string-suffix? p str)
+  (and (>= (string-length str) (string-length p))
+       (string=? (substring str (- (string-length str) (string-length p)) (string-length str)) p)))
+

racket/src/cs/rumble/error.ss

@@ -639,15 +639,16 @@
 (define (exn->string v)
   (format "~a~a"
           (if (who-condition? v)
-              (format "~a: " (condition-who v))
+              (format "~a: " (rewrite-who (condition-who v)))
               "")
           (cond
            [(exn? v)
             (exn-message v)]
            [(format-condition? v)
-            (apply format
+            (let-values ([(fmt irritants)
-                   (condition-message v)
+                          (rewrite-format (condition-message v)
-                   (condition-irritants v))]
+                                          (condition-irritants v))])
+              (apply format fmt irritants))]
            [(syntax-violation? v)
             (let ([show (lambda (s)
                           (cond
@@ -679,47 +680,11 @@
               (make-arity-exn (cadr vs) (car vs))))]
        [else
         (|#%app|
-         (cond
+         (condition->exception-constructor v)
-          [(or (and (format-condition? v)
-                    (or (string-prefix? "incorrect number of arguments" (condition-message v))
-                        (string-suffix? "values to single value return context" (condition-message v))
-                        (string-prefix? "incorrect number of values received in multiple value context" (condition-message v))))
-               (and (message-condition? v)
-                    (or (string-prefix? "incorrect argument count in call" (condition-message v))
-                        (string-prefix? "incorrect number of values from rhs" (condition-message v)))))
-           exn:fail:contract:arity]
-          [(and (format-condition? v)
-                (who-condition? v)
-                (#%memq (condition-who v) '(/ modulo remainder quotient atan angle log))
-                (string=? "undefined for ~s" (condition-message v)))
-           exn:fail:contract:divide-by-zero]
-          [(and (format-condition? v)
-                (who-condition? v)
-                (#%memq (condition-who v) '(expt atan2))
-                (string=? "undefined for values ~s and ~s" (condition-message v)))
-           exn:fail:contract:divide-by-zero]
-          [(and (format-condition? v)
-                (or (string=? "attempt to reference undefined variable ~s" (condition-message v))
-                    (string=? "attempt to assign undefined variable ~s" (condition-message v))))
-           (lambda (msg marks)
-             (|#%app| exn:fail:contract:variable msg marks (car (condition-irritants v))))]
-          [(and (format-condition? v)
-                (string-prefix? "~?.  Some debugging context lost" (condition-message v)))
-           exn:fail]
-          [else
-           exn:fail:contract])
          (exn->string v)
          (current-continuation-marks))])
       v))
 
-(define (string-prefix? p str)
-  (and (>= (string-length str) (string-length p))
-       (string=? (substring str 0 (string-length p)) p)))
-
-(define (string-suffix? p str)
-  (and (>= (string-length str) (string-length p))
-       (string=? (substring str (- (string-length str) (string-length p)) (string-length str)) p)))
-
 (define (make-arity-exn proc n-args)
   (let* ([name (object-name proc)]
          [make-str (arity-string-maker proc)]