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

class/c: Fix init arg contract projections being dropped

Browse Source 
Previously, all init arg contracts’ first order checks were always
checked, but a typo meant all but one of the projections was always
dropped! This fixes that, and it removes a little nearby dead code while
we’re at it.
This commit is contained in:
Alexis King 2019-04-04 15:27:14 -05:00
parent 1795bcb924
commit b6db4f7be1
2 changed files with 46 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2712,4 +2712,40 @@
(lambda (e)
(regexp-match? "a method that accepts the #:x keyword argument"
(exn-message e))))
(test/spec-passed
'multiple-init-args-1
'(let ([c% (contract (class/c (init [a (-> integer?)]
[b (-> symbol?)]))
(class object%
(init a b)
(super-new)
(void (a) (b)))
'pos 'neg)])
(new c% [a (lambda () 1)]
[b (lambda () 'x)])))
(test/neg-blame
'multiple-init-args-2
'(let ([c% (contract (class/c (init [a (-> integer?)]
[b (-> symbol?)]))
(class object%
(init a b)
(super-new)
(void (a) (b)))
'pos 'neg)])
(new c% [a (lambda () #f)]
[b (lambda () 'x)])))
(test/neg-blame
'multiple-init-args-3
'(let ([c% (contract (class/c (init [a (-> integer?)]
[b (-> symbol?)]))
(class object%
(init a b)
(super-new)
(void (a) (b)))
'pos 'neg)])
(new c% [a (lambda () 1)]
[b (lambda () #f)])))
)

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

@ -428,7 +428,7 @@
handled-args
(let-values ([(prefix suffix) (grab-same-inits inits/c)])
(loop suffix
(apply-init-contracts prefix init-args)))))])
(apply-init-contracts prefix handled-args)))))])
;; Since we never consume init args, we can ignore si_leftovers
;; since init-args is the same.
(if never-wrapped?
@ -769,53 +769,15 @@
;; Unlike the others, we always want to do this, even if there are no init contracts,
;; since we still need to handle either calling the previous class/c's init or
;; calling continue-make-super appropriately.
(let ()
;; grab all the inits+contracts that involve the same init arg
;; (assumes that inits and contracts were sorted in class/c creation)
(define (grab-same-inits lst)
(if (null? lst)
(values null null)
(let loop ([inits/c (cdr lst)]
[prefix (list (car lst))])
(cond
[(null? inits/c)
(values (reverse prefix) inits/c)]
[(eq? (list-ref (car inits/c) 0) (list-ref (car prefix) 0))
(loop (cdr inits/c)
(cons (car inits/c) prefix))]
[else (values (reverse prefix) inits/c)]))))
;; run through the list of init-args and apply contracts for same-named
;; init args
(define (apply-init-contracts inits/c init-args)
(let loop ([init-args init-args]
[inits/c inits/c]
[handled-args null])
(cond
[(null? init-args)
(reverse handled-args)]
[(null? inits/c)
(append (reverse handled-args) init-args)]
[(eq? (list-ref (car inits/c) 0) (car (car init-args)))
(let ([init-arg (car init-args)]
[p (list-ref (car inits/c) 1)])
(loop (cdr init-args)
(cdr inits/c)
(cons (cons (car init-arg) (if p
(p (cdr init-arg))
(cdr init-arg)))
handled-args)))]
[else (loop (cdr init-args)
inits/c
(cons (car init-args) handled-args))])))
(set-class-init!
c
(lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
;; Since we never consume init args, we can ignore si_leftovers
;; since init-args is the same.
(if never-wrapped?
(super-go the-obj si_c si_inited? init-args null null)
(init the-obj super-go si_c si_inited? init-args init-args)))))
(set-class-init!
c
(lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
;; Since we never consume init args, we can ignore si_leftovers
;; since init-args is the same.
(if never-wrapped?
(super-go the-obj si_c si_inited? init-args null null)
(init the-obj super-go si_c si_inited? init-args init-args))))
(copy-seals cls c)))))
(define (blame-add-init-context blame name)