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

cs: rewrite some error messages from Chez Scheme

Browse Source 
At least interpose on the value->string part of constructing an
error message and use the Racket-level error-value->string handler.
This commit is contained in:
Matthew Flatt 2019-01-20 17:20:48 -07:00
parent 218ed485e1
commit 299d80e830
4 changed files with 100 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
racket/src/cs/Makefile
View File

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

1
racket/src/cs/rumble.sls
View File

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

92
racket/src/cs/rumble/error-rewrite.ss Normal file
View File

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

47
racket/src/cs/rumble/error.ss
View File

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