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

Further cleanup and robustness.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-03-08 16:51:41 -06:00
parent b5503151ac
commit 9fdffc446a
1 changed files with 11 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1305,6 +1305,11 @@
(get-impersonator-prop:instanceof/c-projs val) (get-impersonator-prop:instanceof/c-projs val)
'()))) '())))
(define (stronger? x y)
(and (contract? x) ; could instead get a `just-check-existence`
(contract? y)
(contract-stronger? x y)))
(define-values (reverse-without-redundant-ctcs reverse-without-redundant-projs) (define-values (reverse-without-redundant-ctcs reverse-without-redundant-projs)
(let loop ([prior-ctcs '()] (let loop ([prior-ctcs '()]
[prior-projs '()] [prior-projs '()]
@ -1316,8 +1321,8 @@
[(null? next-ctcs) (values (cons this-ctc prior-ctcs) [(null? next-ctcs) (values (cons this-ctc prior-ctcs)
(cons this-proj prior-projs))] (cons this-proj prior-projs))]
[else [else
(if (and (ormap (λ (x) (contract-stronger? x this-ctc)) prior-ctcs) (if (and (ormap (λ (x) (stronger? x this-ctc)) prior-ctcs)
(ormap (λ (x) (contract-stronger? this-ctc x)) next-ctcs)) (ormap (λ (x) (stronger? this-ctc x)) next-ctcs))
(loop prior-ctcs prior-projs (loop prior-ctcs prior-projs
(car next-ctcs) (cdr next-ctcs) (car next-projs) (cdr next-projs)) (car next-ctcs) (cdr next-ctcs) (car next-projs) (cdr next-projs))
(loop (cons this-ctc prior-ctcs) (cons this-proj prior-projs) (loop (cons this-ctc prior-ctcs) (cons this-proj prior-projs)
@ -1328,12 +1333,9 @@
(get-impersonator-prop:instanceof/c-unwrapped-class val) (get-impersonator-prop:instanceof/c-unwrapped-class val)
(object-ref val))) (object-ref val)))
(define wrapped-class (define wrapped-class
(let loop ([class unwrapped-class] (for/fold ([class unwrapped-class])
[ctcs reverse-without-redundant-ctcs] ([proj (in-list reverse-without-redundant-projs)])
[projs reverse-without-redundant-projs]) (proj class)))
(cond
[(null? projs) class]
[else (loop ((car projs) class) (cdr ctcs) (cdr projs))])))
(impersonate-struct (impersonate-struct
interposed-val object-ref interposed-val object-ref