diff --git a/racket/src/cs/Makefile b/racket/src/cs/Makefile index 18b4743f01..dfea94d2e8 100644 --- a/racket/src/cs/Makefile +++ b/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 \ diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index d0cc485e8a..d6719c8a37 100644 --- a/racket/src/cs/rumble.sls +++ b/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") diff --git a/racket/src/cs/rumble/error-rewrite.ss b/racket/src/cs/rumble/error-rewrite.ss new file mode 100644 index 0000000000..199ed0d1fa --- /dev/null +++ b/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))) + diff --git a/racket/src/cs/rumble/error.ss b/racket/src/cs/rumble/error.ss index b8d38af682..05df920e6f 100644 --- a/racket/src/cs/rumble/error.ss +++ b/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 - (condition-message v) - (condition-irritants v))] + (let-values ([(fmt irritants) + (rewrite-format (condition-message 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 - [(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]) + (condition->exception-constructor v) (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)]