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

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

@ -67,14 +67,17 @@
(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
(format-error-values str irritants)]))
(define (format-error-values str irritants)
(let ([str (string-copy str)] (let ([str (string-copy str)]
[len (string-length str)]) [len (string-length str)])
(let loop ([i 0] [accum-irritants '()] [irritants irritants]) (let loop ([i 0] [accum-irritants '()] [irritants irritants])
@ -96,7 +99,7 @@
(cons (car irritants) (cons (car irritants)
accum-irritants) accum-irritants)
(cdr irritants))])] (cdr irritants))])]
[else (loop (fx+ i 1) accum-irritants 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))