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

cs: fix value formatting in car, etc., exceptions

Browse Source
This commit is contained in:
Matthew Flatt 2019-10-12 15:33:55 -06:00
parent 77cdfde679
commit a85a915f88
1 changed files with 29 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
racket/src/cs/rumble/error-rewrite.ss
View File

@ -67,36 +67,39 @@
(equal? irritants '(0))) (equal? irritants '(0)))
(values "division by zero" null)] (values "division by zero" null)]
[(equal? str "~s is not a pair") [(equal? str "~s is not a pair")
(values "contract violation\n expected: pair?\n given: ~s" (format-error-values "contract violation\n expected: pair?\n given: ~s"
irritants)] irritants)]
[(and (equal? str "incorrect list structure ~s") [(and (equal? str "incorrect list structure ~s")
(cxr->contract who)) (cxr->contract who))
=> (lambda (ctc) => (lambda (ctc)
(values (string-append "contract violation\n expected: " ctc "\n given: ~s") (format-error-values (string-append "contract violation\n expected: " ctc "\n given: ~s")
irritants))] irritants))]
[else [else
(let ([str (string-copy str)] (format-error-values str irritants)]))
[len (string-length str)])
(let loop ([i 0] [accum-irritants '()] [irritants irritants]) (define (format-error-values str irritants)
(cond (let ([str (string-copy str)]
[(fx= i len) [len (string-length str)])
;; `irritants` should be empty by now (let loop ([i 0] [accum-irritants '()] [irritants irritants])
(values str (append (reverse accum-irritants) irritants))] (cond
[(and (char=? #\~ (string-ref str i)) [(fx= i len)
(fx< (fx+ i 1) len)) ;; `irritants` should be empty by now
(case (string-ref str (fx+ i 1)) (values str (append (reverse accum-irritants) irritants))]
[(#\~ #\%) (loop (fx+ i 2) accum-irritants irritants)] [(and (char=? #\~ (string-ref str i))
[(#\s) (fx< (fx+ i 1) len))
(string-set! str (fx+ i 1) #\a) (case (string-ref str (fx+ i 1))
(loop (fx+ i 2) [(#\~ #\%) (loop (fx+ i 2) accum-irritants irritants)]
(cons (error-value->string (car irritants)) [(#\s)
accum-irritants) (string-set! str (fx+ i 1) #\a)
(cdr irritants))] (loop (fx+ i 2)
[else (loop (fx+ i 2) (cons (error-value->string (car irritants))
(cons (car irritants) accum-irritants)
accum-irritants) (cdr irritants))]
(cdr irritants))])] [else (loop (fx+ i 2)
[else (loop (fx+ i 1) accum-irritants irritants)])))])) (cons (car irritants)
accum-irritants)
(cdr irritants))])]
[else (loop (fx+ i 1) accum-irritants irritants)]))))
(define (string-prefix? p str) (define (string-prefix? p str)
(and (>= (string-length str) (string-length p)) (and (>= (string-length str) (string-length p))