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

Fix object/c multiple-wrapping optimization.

Browse Source 
A shortcut in the optimization made it drop all but the most recent contract.
This commit is contained in:
Vincent St-Amour 2016-03-08 15:51:51 -06:00
parent 509da64135
commit 686bc68b0a
2 changed files with 69 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
pkgs/racket-test/tests/racket/contract/object.rkt
View File

@ -217,4 +217,71 @@
(define/public (baz n) (list foo bar))))
'pos 'neg)
baz 1)
'(0 1)))
'(0 1))
(test/pos-blame
'object/c-multiple-wrapping-1
'(let ()
(define c%
(class object%
(define/public (m) (void))
(define/public (n) (void))
(define/public (p) (void))
(super-new)))
(define a/c (object/c [m (-> any/c symbol?)]))
(define b/c (object/c [n (-> any/c string?)]))
(define c/c (object/c [p (-> any/c vector?)]))
(define a-c (new c%))
(define x1 (contract a/c a-c 'pos 'neg))
(define x2 (contract b/c x1 'pos 'neg))
(define x3 (contract c/c x2 'pos 'neg))
(send x3 m)))
(test/pos-blame
'object/c-multiple-wrapping-2
'(let ()
(define c%
(class object%
(define/public (m) (void))
(define/public (n) (void))
(define/public (p) (void))
(super-new)))
(define a/c (object/c [m (-> any/c symbol?)]))
(define b/c (object/c [n (-> any/c string?)]))
(define c/c (object/c [p (-> any/c vector?)]))
(define a-c (new c%))
(define x1 (contract a/c a-c 'pos 'neg))
(define x2 (contract b/c x1 'pos 'neg))
(define x3 (contract c/c x2 'pos 'neg))
(send x3 n)))
(test/pos-blame
'object/c-multiple-wrapping-3
'(let ()
(define c%
(class object%
(define/public (m) (void))
(define/public (n) (void))
(define/public (p) (void))
(super-new)))
(define a/c (object/c [m (-> any/c symbol?)]))
(define b/c (object/c [n (-> any/c string?)]))
(define c/c (object/c [p (-> any/c vector?)]))
(define a-c (new c%))
(define x1 (contract a/c a-c 'pos 'neg))
(define x2 (contract b/c x1 'pos 'neg))
(define x3 (contract c/c x2 'pos 'neg))
(send x3 p)))
)

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

@ -1341,17 +1341,7 @@
[old-classes (reverse old-classes)])
(cond
[(null? projs) (list class)]
[else
(cons class
(cond
[(and (pair? old-ctcs) (eq? (car old-ctcs) (car ctcs)))
(loop (car old-classes)
(cdr ctcs)
(cdr projs)
(cdr old-ctcs)
(cdr old-classes))]
[else
(loop ((car projs) class) (cdr ctcs) (cdr projs) '() '())]))]))))
[else (loop ((car projs) class) (cdr ctcs) (cdr projs) '() '())]))))
(impersonate-struct
interposed-val object-ref