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

fix context for instanceof/c

Browse Source 
also improve test suite to look for ellipses
(but not when using opt/c)
This commit is contained in:
Robby Findler 2015-01-04 15:09:37 -06:00
parent 2cd8e620d4
commit 2b07cc34f7
2 changed files with 20 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
pkgs/racket-test/tests/racket/contract/context.rkt
View File

@ -8,7 +8,7 @@
'racket/class
'racket/contract/private/blame)])
(contract-eval '(define (extract-context-lines thunk)
(contract-eval '(define (extract-context-lines opt/c? thunk)
(define str
(with-handlers ((exn:fail:contract:blame? exn-message))
(thunk)
@ -30,7 +30,11 @@
(cond
[(or (regexp-match #rx"^the " line)
(regexp-match #rx"^an " line)
(regexp-match #rx"^a " line))
(regexp-match #rx"^a " line)
;; opt/c needs to be fixed so it includes
;; the right context in the right places
(and (not opt/c?) (regexp-match #rx"^[.][.][.]$" line)))
(cons line (loop (cdr lines)))]
[else
(loop (cdr lines))])]))]
@ -51,7 +55,7 @@
(contract-eval
#:test-case-name name
`(,test #:test-case-name ',name
',context extract-context-lines
',context extract-context-lines #f
(lambda () ,expression)))
(let/ec k
(define rewritten (rewrite-to-add-opt/c expression k))
@ -60,7 +64,7 @@
(contract-eval
#:test-case-name opt-name
`(,test #:test-case-name ',opt-name
',context extract-context-lines (lambda () ,rewritten))))))
',context extract-context-lines #t (lambda () ,rewritten))))))
(context-test '("the 1st argument of")
'((contract (-> boolean? integer? integer?)
@ -476,6 +480,17 @@
'pos 'neg)
1))
(context-test '("the range of"
"the save-file method in")
'(send (contract (instanceof/c
(class/c [save-file (-> any/c number?)]))
(new
(class object%
(define/public (save-file) #f)
(super-new)))
'pos 'neg)
save-file))
(let* ([blame-pos (contract-eval '(make-blame (srcloc #f #f #f #f #f)
#f
(λ () 'integer?)

2
racket/collects/racket/private/class-c-old.rkt
View File

@ -1274,7 +1274,7 @@
(define (instanceof/c-proj ctc)
(define proj (contract-projection (base-instanceof/c-class-ctc ctc)))
(λ (blame)
(define p (proj blame))
(define p (proj (blame-add-context blame #f)))
(λ (val)
(unless (object? val)
(raise-blame-error blame val '(expected: "an object" given: "~e") val))