cs: don't treat crashes as constract errors

Converting "invalid memory reference" to an `exn:fail:contract` (which
is the default conversion) hides crashes as success when a test
expects an error.

Also, fix a bug that was hiding as an expected excdeption.
This commit is contained in:
Matthew Flatt 2018-11-21 09:26:43 -07:00
parent 701854a404
commit 7231f11b60
3 changed files with 8 additions and 5 deletions

View File

@ -147,7 +147,7 @@
c))]
[(a)
(check who bytes? a)
(#2%bytevector-copy a)]
(#3%bytevector-copy a)]
[() #vu8()]
[args
(let* ([size (let loop ([args args])

View File

@ -682,6 +682,9 @@
(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)

View File

@ -37,18 +37,18 @@
(case-lambda
[(proc args)
(if (#%procedure? proc)
(chez:apply proc args)
(chez:apply (extract-procedure proc (length args)) args))]
(#2%apply proc args)
(#2%apply (extract-procedure proc (length args)) args))]
[(proc)
(raise-arity-error 'apply (|#%app| arity-at-least 2) proc)]
[(proc . argss)
(if (#%procedure? proc)
(chez:apply chez:apply proc argss)
(#2%apply #2%apply proc argss)
(let ([len (let loop ([argss argss])
(cond
[(null? (cdr argss)) (length (car argss))]
[else (fx+ 1 (loop (cdr argss)))]))])
(chez:apply chez:apply (extract-procedure proc len) argss)))]))
(#2%apply #2%apply (extract-procedure proc len) argss)))]))
;; See copy in "expander.sls"
(define-syntax (|#%app| stx)