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

fix a #f/no-contract conflation in the init arg processing for class/c

Browse Source 
related to PR 14215
This commit is contained in:
Robby Findler 2013-12-01 18:39:28 -06:00
parent 72d4bf7a69
commit 15e6f4d38d
2 changed files with 57 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt
View File

@ -1710,6 +1710,55 @@
'pos
'neg)])
(send (new cls%) m 3 #t)))
;; test that unspecified inits and fields aren't internally conflating #f with the contract #f
(test/spec-passed
'false/no-contract-conflation1
'(new (contract (class/c (init x))
(class object% (init x) (super-new))
'pos
'neg)
[x 1]))
(test/neg-blame
'false/no-contract-conflation2
'(new (contract (class/c (init [x #f]))
(class object% (init x) (super-new))
'pos
'neg)
[x 1]))
(test/spec-passed
'false/no-contract-conflation3
'(new (contract (class/c (field x))
(class object% (field [x 1]) (super-new))
'pos
'neg)))
(test/pos-blame
'false/no-contract-conflation4
'(get-field x
(new (contract (class/c (field [x #f]))
(class object% (field [x 1]) (super-new))
'pos
'neg))))
(test/spec-passed
'false/no-contract-conflation5
'(new (contract (class/c (init-field x))
(class object% (init-field x) (super-new))
'pos
'neg)
[x 1]))
(test/neg-blame
'false/no-contract-conflation6
'(new (contract (class/c (init-field [x #f]))
(class object% (init-field x) (super-new))
'pos
'neg)
[x 1]))
(let ([expected-given?
(λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn))

12
racket/collects/racket/private/class-internal.rkt
View File

@ -2915,7 +2915,9 @@ An example
(define inits+contracts
(for/list ([init (in-list (class/c-inits ctc))]
[ctc (in-list (class/c-init-contracts ctc))])
(list init ((contract-projection ctc) bswap))))
(if ctc
(list init ((contract-projection ctc) bswap))
(list init #f))))
(λ (cls)
(class/c-check-first-order ctc cls (λ args (apply raise-blame-error blame cls args)))
@ -3188,7 +3190,7 @@ An example
[else (values (reverse prefix) inits/c)]))))
;; run through the list of init-args and apply contracts for same-named
;; init args
(define (apply-contracts inits/c init-args)
(define (apply-init-contracts inits/c init-args)
(let loop ([init-args init-args]
[inits/c inits/c]
[handled-args null])
@ -3202,7 +3204,9 @@ An example
[p (list-ref (car inits/c) 1)])
(loop (cdr init-args)
(cdr inits/c)
(cons (cons (car init-arg) (p (cdr init-arg)))
(cons (cons (car init-arg) (if p
(p (cdr init-arg))
(cdr init-arg)))
handled-args)))]
[else (loop (cdr init-args)
inits/c
@ -3217,7 +3221,7 @@ An example
handled-args
(let-values ([(prefix suffix) (grab-same-inits inits/c)])
(loop suffix
(apply-contracts prefix init-args)))))])
(apply-init-contracts prefix init-args)))))])
;; Since we never consume init args, we can ignore si_leftovers
;; since init-args is the same.
(if never-wrapped?