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

* Factor out zipping of inits/contracts of the init closure

Browse Source 
* Add tests for higher-order behavior

svn: r18538
This commit is contained in:
Stevie Strickland 2010-03-15 07:37:25 +00:00
parent f9e404afbc
commit 7ec061cdbf
2 changed files with 46 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/scheme/private/class-internal.ss
View File

@ -2862,6 +2862,7 @@
(unless (null? (class/c-inits ctc))
(let ()
(define inits+contracts (map cons (class/c-inits ctc) (class/c-init-contracts ctc)))
(define (grab-same-inits lst)
(if (null? lst)
(values null null)
@ -2889,8 +2890,7 @@
(blame-swap blame))])
(loop (cdr init-args)
(cdr inits/c)
(cons (cons (car init-arg)
(p (cdr init-arg)))
(cons (cons (car init-arg) (p (cdr init-arg)))
handled-args)))]
[else (loop (cdr init-args)
inits/c
@ -2899,7 +2899,7 @@
c
(lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
(let ([init-args
(let loop ([inits/c (map cons (class/c-inits ctc) (class/c-init-contracts ctc))]
(let loop ([inits/c inits+contracts]
[handled-args init-args])
(if (null? inits/c)
handled-args

43
collects/tests/mzscheme/contract-test.ss
View File

@ -4650,6 +4650,49 @@
'neg)]
[d% (class c% (super-new) (inherit m) (define/public (f) (m 5)))])
(send (new d%) f)))
(test/spec-passed
'class/c-higher-order-init-1
'(let ([c% (contract (class/c (init [a number?]))
(class object% (super-new) (init a))
'pos
'neg)])
(new c% [a 3])))
(test/neg-blame
'class/c-higher-order-init-2
'(let ([c% (contract (class/c (init [a number?]))
(class object% (super-new) (init a))
'pos
'neg)])
(new c% [a #t])))
(test/spec-passed
'class/c-higher-order-init-3
'(let ([c% (class object% (super-new) (init a))]
[d% (contract (class/c (init [a number?] [a string?]))
(class a% (super-new) (init a))
'pos
'neg)])
(new c% [a 3] [a "foo"])))
(test/neg-blame
'class/c-higher-order-init-4
'(let ([c% (class object% (super-new) (init a))]
[d% (contract (class/c (init [a number?] [a string?]))
(class a% (super-new) (init a))
'pos
'neg)])
(new c% [a 3] [a 4])))
(test/spec-blame
'class/c-higher-order-init-5
'(let ([c% (class object% (super-new) (init a))]
[d% (contract (class/c (init [a number?] [a string?]))
(class a% (super-new) (init a))
'pos
'neg)])
(new c% [a "bar"] [a "foo"])))
(test/spec-passed
'class/c-higher-order-method-1