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

Split impersonator property into two.

Browse Source 
To avoid future confusion.
This commit is contained in:
Vincent St-Amour 2016-03-08 16:31:20 -06:00
parent d80a8244a2
commit b5503151ac
1 changed files with 25 additions and 28 deletions

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

@ -1274,7 +1274,7 @@
(get-impersonator-prop:instanceof/c-original-object val)
(impersonate-struct
val object-ref
(λ (o c) (car (get-impersonator-prop:instanceof/c-wrapped-classes o))))))
(λ (o c) (get-impersonator-prop:instanceof/c-wrapped-class o)))))
;; this code is doing a fairly complicated dance to
@ -1305,11 +1305,6 @@
(get-impersonator-prop:instanceof/c-projs val)
'())))
(define old-classes
(if (has-impersonator-prop:instanceof/c-wrapped-classes? val)
(get-impersonator-prop:instanceof/c-wrapped-classes val)
'()))
(define-values (reverse-without-redundant-ctcs reverse-without-redundant-projs)
(let loop ([prior-ctcs '()]
[prior-projs '()]
@ -1327,22 +1322,18 @@
(car next-ctcs) (cdr next-ctcs) (car next-projs) (cdr next-projs))
(loop (cons this-ctc prior-ctcs) (cons this-proj prior-projs)
(car next-ctcs) (cdr next-ctcs) (car next-projs) (cdr next-projs)))])))
(define wrapped-classes
(reverse
(let loop ([class (if (has-impersonator-prop:instanceof/c-wrapped-classes? val)
(car (reverse
(get-impersonator-prop:instanceof/c-wrapped-classes val)))
(object-ref val))]
[ctcs reverse-without-redundant-ctcs]
[projs reverse-without-redundant-projs]
[old-ctcs (reverse (cdr all-new-ctcs))]
[old-classes (reverse old-classes)])
(cond
[(null? projs) (list class)]
[else (cons class
(loop ((car projs) class) (cdr ctcs) (cdr projs) '() '()))]))))
(define unwrapped-class
(if (has-impersonator-prop:instanceof/c-unwrapped-class? val)
(get-impersonator-prop:instanceof/c-unwrapped-class val)
(object-ref val)))
(define wrapped-class
(let loop ([class unwrapped-class]
[ctcs reverse-without-redundant-ctcs]
[projs reverse-without-redundant-projs])
(cond
[(null? projs) class]
[else (loop ((car projs) class) (cdr ctcs) (cdr projs))])))
(impersonate-struct
interposed-val object-ref
@ -1354,7 +1345,8 @@
impersonator-prop:instanceof/c-original-object interposed-val
impersonator-prop:instanceof/c-ctcs (reverse reverse-without-redundant-ctcs)
impersonator-prop:instanceof/c-projs (reverse reverse-without-redundant-projs)
impersonator-prop:instanceof/c-wrapped-classes wrapped-classes
impersonator-prop:instanceof/c-wrapped-class wrapped-class
impersonator-prop:instanceof/c-unwrapped-class unwrapped-class
impersonator-prop:contracted ctc
impersonator-prop:original-object original-obj)]))))
@ -1368,15 +1360,20 @@
get-impersonator-prop:instanceof/c-projs)
(make-impersonator-property 'impersonator-prop:instanceof/c-projs))
(define-values (impersonator-prop:instanceof/c-wrapped-classes
has-impersonator-prop:instanceof/c-wrapped-classes?
get-impersonator-prop:instanceof/c-wrapped-classes)
(make-impersonator-property 'impersonator-prop:instanceof/c-wrapped-classes))
(define-values (impersonator-prop:instanceof/c-unwrapped-class
has-impersonator-prop:instanceof/c-unwrapped-class?
get-impersonator-prop:instanceof/c-unwrapped-class)
(make-impersonator-property 'impersonator-prop:instanceof/c-unwrapped-class))
(define-values (impersonator-prop:instanceof/c-wrapped-class
has-impersonator-prop:instanceof/c-wrapped-class?
get-impersonator-prop:instanceof/c-wrapped-class)
(make-impersonator-property 'impersonator-prop:instanceof/c-wrapped-class))
;; when an object has the original-object property,
;; then we also know that value of this property is
;; an object whose object-ref has been redirected to
;; use impersonator-prop:instanceof/c-wrapped-classes
;; use impersonator-prop:instanceof/c-wrapped-class
(define-values (impersonator-prop:instanceof/c-original-object
has-impersonator-prop:instanceof/c-original-object?
get-impersonator-prop:instanceof/c-original-object)