Improvement and bug fixes to the new class/c; try again to re-enable it
Fixed: - class-field-accessor and class-field mutator, - the interaction between init args contracts and subclasses, - object=? on wrapped objects (ie if 'this' flows out and is compared to the object thatn 'new' returns) - contract-name for class/c Also, the code now uses impersonator properties internally to track a class that is wrapped (instead of a wrapper struct). This simplifies a bunch of places in the code and paves the way for classes that have a class/c contract to be chapeone-of the original class (altho that doesn't work yet)
This commit is contained in:
Robby Findler
parent
6c08632f35
commit
59f57b1bd1
|
|
@ -2051,20 +2051,66 @@
|
|||
[x 2]))
|
||||
|
||||
(test/spec-passed/result
|
||||
'class-field-accessor
|
||||
'class-field-accessor1
|
||||
'(let ([c% (class object% (super-new) (field [f 1]))])
|
||||
((class-field-accessor c% f)
|
||||
((class-field-accessor c% f)
|
||||
(new (contract (class/c) c% 'pos 'neg))))
|
||||
1)
|
||||
|
||||
(test/spec-passed
|
||||
'class-field-accessor2
|
||||
'(let* ([c% (class object% (field [f 1]) (super-new))]
|
||||
[c+c% (contract (class/c (field [f integer?])) c% 'pos 'neg)])
|
||||
((class-field-accessor c+c% f) (new c%))))
|
||||
|
||||
(test/pos-blame
|
||||
'class-field-accessor3
|
||||
'(let* ([c% (class object% (field [f #f]) (super-new))]
|
||||
[c+c% (contract (class/c (field [f integer?])) c% 'pos 'neg)])
|
||||
((class-field-accessor c+c% f) (new c%))))
|
||||
|
||||
(test/spec-passed
|
||||
'class-field-accessor4
|
||||
'(let* ([c% (class object% (field [f #f]) (super-new))]
|
||||
[c+c% (contract (class/c (field [f integer?])) c% 'pos 'neg)])
|
||||
((class-field-accessor c% f) (new c+c%))))
|
||||
|
||||
(test/spec-passed/result
|
||||
'class-field-mutator
|
||||
'class-field-mutator1
|
||||
'(let* ([c% (class object% (super-new) (field [f 1]))]
|
||||
[o (new (contract (class/c) c% 'pos 'neg))])
|
||||
((class-field-mutator c% f) o 2)
|
||||
((class-field-accessor c% f) o))
|
||||
2)
|
||||
|
||||
(test/spec-passed/result
|
||||
'class-field-mutator2
|
||||
'(let* ([c% (class object% (super-new) (field [f 1]))]
|
||||
[o (new (contract (class/c (field [f boolean?])) c% 'pos 'neg))])
|
||||
((class-field-mutator c% f) o #f)
|
||||
((class-field-accessor c% f) o))
|
||||
#f)
|
||||
|
||||
(test/spec-passed
|
||||
'class-field-mutator3
|
||||
'(let* ([c% (class object% (super-new) (field [f 1]))]
|
||||
[o (new (contract (class/c (field [f boolean?])) c% 'pos 'neg))])
|
||||
((class-field-mutator c% f) o 11)))
|
||||
|
||||
(test/neg-blame
|
||||
'class-field-mutator4
|
||||
'(let* ([c% (class object% (super-new) (field [f 1]))]
|
||||
[c%+c (contract (class/c (field [f boolean?])) c% 'pos 'neg)]
|
||||
[o (new c%+c)])
|
||||
((class-field-mutator c%+c f) o 11)))
|
||||
|
||||
(test/neg-blame
|
||||
'class-field-mutator5
|
||||
'(let* ([c% (class object% (super-new) (field [f 1]))]
|
||||
[c%+c (contract (class/c (field [f boolean?])) c% 'pos 'neg)]
|
||||
[o (new c%)])
|
||||
((class-field-mutator c%+c f) o 11)))
|
||||
|
||||
(test/spec-passed/result
|
||||
'order-of-evaluation
|
||||
'(let ([x '()])
|
||||
|
|
@ -2360,6 +2406,70 @@
|
|||
[sub-c% (class c% (super-new))])
|
||||
(new sub-c% [f 1])))
|
||||
|
||||
(test/neg-blame
|
||||
'subclass-and-external-contracts6
|
||||
'(let* ([c% (contract (class/c (init [f integer?]))
|
||||
(class object% (init f) (super-new))
|
||||
'pos 'neg)]
|
||||
[sub-c% (class c% (super-new))])
|
||||
(new sub-c% [f #f])))
|
||||
|
||||
(test/spec-passed
|
||||
'subclass-and-external-contracts7
|
||||
'(let* ([c% (contract (class/c (init [i integer?]))
|
||||
(class object% (init i) (super-new))
|
||||
'pos 'neg)]
|
||||
[sub-c% (class c% (init i) (super-new [i 2]))])
|
||||
(new sub-c% [i #f])))
|
||||
|
||||
(test/neg-blame
|
||||
'subclass-and-external-contracts8
|
||||
'(let* ([c%
|
||||
(contract (class/c (init [i integer?]))
|
||||
(class object% (init i) (super-new))
|
||||
'pos 'neg)]
|
||||
[d% (class c% (super-new [i #f]))])
|
||||
(new d%)))
|
||||
|
||||
(test/spec-passed
|
||||
'subclass-and-external-contracts9
|
||||
'(let* ([c%
|
||||
(contract (class/c (init [i integer?] [j integer?]))
|
||||
(class object% (init i) (init j) (super-new))
|
||||
'pos 'neg)]
|
||||
[d% (class c% (init i) (super-new [i 1]))])
|
||||
(new d% [i #f] [j 1])))
|
||||
|
||||
(test/neg-blame
|
||||
'subclass-and-external-contracts10
|
||||
'(let* ([c%
|
||||
(contract (class/c (init [i integer?] [j integer?]))
|
||||
(class object% (init i) (init j) (super-new))
|
||||
'pos 'neg)]
|
||||
[d% (class c% (init i) (super-new [i 1]))])
|
||||
(new d% [i #f] [j #f])))
|
||||
|
||||
(test/spec-passed/result
|
||||
'object=?
|
||||
'(let ([o (new (contract (class/c (m (->m integer? integer?)))
|
||||
(class object%
|
||||
(define/public (m x) x)
|
||||
(define/public (get-this) this)
|
||||
(super-new))
|
||||
'pos 'neg))])
|
||||
(object=? (send o get-this) o))
|
||||
#t)
|
||||
|
||||
;; this test case won't pass until the internal-ctc
|
||||
;; call is delayed in the new class/c projections
|
||||
;; (but otherwise it passes)
|
||||
#;
|
||||
(test/spec-passed/result
|
||||
'chaperone-of
|
||||
'(let* ([c% (class object% (define/public (m x) x))]
|
||||
[c+c% (contract (class/c (m (->m integer? integer?))) c% 'pos 'neg)])
|
||||
(chaperone-of? c+c% c%))
|
||||
#t)
|
||||
|
||||
(let ([expected-given?
|
||||
(λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn))
|
||||
|
|
|
|||
|
|
@ -334,6 +334,24 @@
|
|||
(class/c [m (->dm ([d integer?]) () [r integer?])]))
|
||||
(test-name 'c%/c (let ([c%/c (class/c [m (->m integer? integer?)])])
|
||||
c%/c))
|
||||
(test-name '(class/c (field [f integer?])) (class/c (field [f integer?])))
|
||||
(test-name '(class/c (field [f integer?])) (class/c (field [f integer?])))
|
||||
(test-name '(class/c (init-field [f integer?])) (class/c (init-field [f integer?])))
|
||||
(test-name '(class/c (inherit-field [f integer?])) (class/c (inherit-field [f integer?])))
|
||||
(test-name '(class/c (absent a b c (field d e f))) (class/c (absent a b c (field d e f))))
|
||||
(test-name '(class/c (absent a b c)) (class/c (absent a b c)))
|
||||
(test-name '(class/c (inherit [f integer?])
|
||||
(super [m (->m (<=/c 0) integer?)])
|
||||
(inner [n (->m (<=/c 1) integer?)])
|
||||
(override [o (->m (<=/c 2) integer?)])
|
||||
(augment [p (->m (<=/c 3) integer?)])
|
||||
(augride [q (->m (<=/c 4) integer?)]))
|
||||
(class/c (inherit [f integer?])
|
||||
(super [m (->m (<=/c 0) integer?)])
|
||||
(inner [n (->m (<=/c 1) integer?)])
|
||||
(override [o (->m (<=/c 2) integer?)])
|
||||
(augment [p (->m (<=/c 3) integer?)])
|
||||
(augride [q (->m (<=/c 4) integer?)])))
|
||||
|
||||
(test-name '(struct/dc s
|
||||
[a integer?]
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@
|
|||
;; All of the implementation is actually in private/class-internal.rkt,
|
||||
;; which provides extra (private) functionality to contract.rkt.
|
||||
(require "private/class-internal.rkt"
|
||||
"private/class-c-old.rkt")
|
||||
(except-in "private/class-c-old.rkt" class/c)
|
||||
(rename-in "private/class-c-new.rkt" [class/c2 class/c]))
|
||||
|
||||
(provide-public-names)
|
||||
(provide generic?)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang racket/base
|
||||
(require "class-internal.rkt"
|
||||
"class-c-old.rkt"
|
||||
"class-wrapped.rkt"
|
||||
"../contract/base.rkt"
|
||||
"../contract/combinator.rkt"
|
||||
(only-in "../contract/private/guts.rkt"
|
||||
|
|
@ -88,6 +89,27 @@
|
|||
(neg-accepter #f)
|
||||
(k neg-accepter)))
|
||||
(cond
|
||||
[(impersonator-prop:has-wrapped-class-neg-party? cls)
|
||||
(define wrapper-neg-party (impersonator-prop:get-wrapped-class-neg-party cls))
|
||||
(define the-info (impersonator-prop:get-wrapped-class-info cls))
|
||||
(define neg-acceptors (wrapped-class-info-neg-acceptors-ht the-info))
|
||||
(define mth->idx (class-method-ht cls))
|
||||
(define new-mths (make-vector (vector-length (class-methods cls)) #f))
|
||||
(for ([(mth neg-acceptor) (in-hash neg-acceptors)])
|
||||
(define mth-idx (hash-ref mth->idx mth))
|
||||
(vector-set! new-mths mth-idx (neg-acceptor wrapper-neg-party)))
|
||||
(define fixed-neg-init-projs
|
||||
(for/list ([proj-pair (wrapped-class-info-init-proj-pairs the-info)])
|
||||
(cons (list-ref proj-pair 0)
|
||||
(for/list ([func (in-list (cdr proj-pair))])
|
||||
(λ (val) (λ (neg-party)
|
||||
((func val) wrapper-neg-party)))))))
|
||||
(build-neg-acceptor-proc this maybe-err blame
|
||||
cls
|
||||
new-mths
|
||||
fixed-neg-init-projs
|
||||
(wrapped-class-info-pos-field-projs the-info)
|
||||
(wrapped-class-info-neg-field-projs the-info))]
|
||||
[(class-struct-predicate? cls)
|
||||
(define mtd-vec (class-methods cls))
|
||||
(cond
|
||||
|
|
@ -142,28 +164,6 @@
|
|||
[else
|
||||
(build-neg-acceptor-proc this maybe-err blame cls #f '()
|
||||
(make-hasheq) (make-hasheq))])]
|
||||
[(wrapped-class? cls)
|
||||
(define wrapper-neg-party (wrapped-class-neg-party cls))
|
||||
(define the-info (wrapped-class-the-info cls))
|
||||
(define neg-acceptors (wrapped-class-info-neg-acceptors-ht the-info))
|
||||
(define real-class (wrapped-class-info-class the-info))
|
||||
(define mth->idx (class-method-ht real-class))
|
||||
(define new-mths (make-vector (vector-length (class-methods real-class)) #f))
|
||||
(for ([(mth neg-acceptor) (in-hash neg-acceptors)])
|
||||
(define mth-idx (hash-ref mth->idx mth))
|
||||
(vector-set! new-mths mth-idx (neg-acceptor wrapper-neg-party)))
|
||||
(define fixed-neg-init-projs
|
||||
(for/list ([proj-pair (wrapped-class-info-init-proj-pairs the-info)])
|
||||
(cons (list-ref proj-pair 0)
|
||||
(for/list ([func (in-list (cdr proj-pair))])
|
||||
(λ (val) (λ (neg-party)
|
||||
((func val) wrapper-neg-party)))))))
|
||||
(build-neg-acceptor-proc this maybe-err blame
|
||||
(wrapped-class-info-class the-info)
|
||||
new-mths
|
||||
fixed-neg-init-projs
|
||||
(wrapped-class-info-pos-field-projs the-info)
|
||||
(wrapped-class-info-neg-field-projs the-info))]
|
||||
[else
|
||||
(maybe-err
|
||||
(λ (neg-party)
|
||||
|
|
@ -308,9 +308,14 @@
|
|||
((get/build-val-first-projection ctc)
|
||||
(blame-add-init-context blame (car ctc-pair)))))))
|
||||
(define merged-init-pairs (merge-init-pairs old-init-pairs new-init-projs))
|
||||
(define the-info (wrapped-class-info cls blame neg-extra-arg-vec neg-acceptors-ht
|
||||
(define the-info (wrapped-class-info blame neg-extra-arg-vec neg-acceptors-ht
|
||||
pos-field-projs neg-field-projs
|
||||
merged-init-pairs))
|
||||
(define class+one-property
|
||||
(chaperone-struct cls
|
||||
set-class-orig-cls! (λ (a b) b)
|
||||
impersonator-prop:wrapped-class-info
|
||||
the-info))
|
||||
|
||||
(λ (neg-party)
|
||||
;; run this for the side-effect of
|
||||
|
|
@ -324,13 +329,17 @@
|
|||
;; the internal projection should run
|
||||
;; on the class only when it is
|
||||
;; time to instantiate it; not here
|
||||
(define the-info/adjusted-cls
|
||||
(struct-copy wrapped-class-info
|
||||
the-info
|
||||
[class ((internal-proj (blame-add-missing-party blame neg-party))
|
||||
cls)]))
|
||||
(define class+one-property/adjusted
|
||||
(chaperone-struct ((internal-proj (blame-add-missing-party blame neg-party))
|
||||
cls)
|
||||
set-class-orig-cls! (λ (a b) b)
|
||||
impersonator-prop:wrapped-class-info
|
||||
the-info))
|
||||
|
||||
(wrapped-class the-info/adjusted-cls neg-party)))
|
||||
(chaperone-struct class+one-property/adjusted
|
||||
set-class-orig-cls! (λ (a b) b)
|
||||
impersonator-prop:wrapped-class-neg-party
|
||||
neg-party)))
|
||||
|
||||
(define (merge-init-pairs old-init-pairs new-init-pairs)
|
||||
(cond
|
||||
|
|
@ -437,19 +446,54 @@
|
|||
(cond
|
||||
[(ext-class/c-contract-name c) => values]
|
||||
[else
|
||||
(define field-names
|
||||
(for/list ([(fld ctc) (in-hash (ext-class/c-contract-table-of-flds-to-ctcs c))])
|
||||
`(,fld ,(contract-name ctc))))
|
||||
(define init-fields '())
|
||||
(define init-names
|
||||
(for/list ([pr (in-list (ext-class/c-contract-init-ctc-pairs c))])
|
||||
(define name (list-ref pr 0))
|
||||
(define ctc (list-ref pr 1))
|
||||
(if (just-check-existence? ctc)
|
||||
name
|
||||
`[,name ,(contract-name ctc)])))
|
||||
(filter
|
||||
values
|
||||
(for/list ([pr (in-list (ext-class/c-contract-init-ctc-pairs c))])
|
||||
(define name (list-ref pr 0))
|
||||
(define ctc (list-ref pr 1))
|
||||
(cond
|
||||
[(just-check-existence? ctc)
|
||||
name]
|
||||
[else
|
||||
(define c-name (contract-name ctc))
|
||||
(define clause `[,name ,c-name])
|
||||
(define fld-ctc (hash-ref (ext-class/c-contract-table-of-flds-to-ctcs c) name #f))
|
||||
(cond
|
||||
[(and fld-ctc (equal? c-name (contract-name fld-ctc)))
|
||||
(set! init-fields (cons clause init-fields))
|
||||
#f]
|
||||
[else clause])]))))
|
||||
(set! field-names (filter (λ (x) (not (member (car x) (map car init-fields))))
|
||||
field-names))
|
||||
|
||||
(define meth-names
|
||||
(for/list ([(name ctc) (in-hash (ext-class/c-contract-table-of-meths-to-ctcs c))])
|
||||
(if (just-check-existence? ctc)
|
||||
name
|
||||
`[,name ,(contract-name ctc)])))
|
||||
|
||||
(define absents
|
||||
(let ([ams (ext-class/c-contract-absent-methods c)]
|
||||
[afs (ext-class/c-contract-absent-fields c)])
|
||||
(cond
|
||||
[(and (null? ams) (null? afs)) '()]
|
||||
[(null? afs) (list `(absent ,@ams))]
|
||||
[else (list `(absent ,@ams (field ,@afs)))])))
|
||||
|
||||
`(class/c ,@(if (null? init-names)
|
||||
(list)
|
||||
(list `(init ,@init-names)))
|
||||
,@meth-names)]))))
|
||||
,@(if (null? field-names)
|
||||
(list)
|
||||
(list `(field ,@field-names)))
|
||||
,@(if (null? init-fields)
|
||||
(list)
|
||||
(list `(init-field ,@init-fields)))
|
||||
,@meth-names
|
||||
,@absents
|
||||
,@(class/c-internal-name-clauses (ext-class/c-contract-internal-ctc c)))]))))
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
racket/stxparam
|
||||
syntax/parse)
|
||||
racket/stxparam
|
||||
"class-wrapped.rkt"
|
||||
"class-internal.rkt"
|
||||
"../contract/base.rkt"
|
||||
"../contract/combinator.rkt"
|
||||
|
|
@ -16,7 +17,8 @@
|
|||
(for-syntax parse-class/c-specs)
|
||||
(struct-out internal-class/c)
|
||||
just-check-existence just-check-existence?
|
||||
build-internal-class/c internal-class/c-proj)
|
||||
build-internal-class/c internal-class/c-proj
|
||||
class/c-internal-name-clauses)
|
||||
|
||||
(define undefined (letrec ([x x]) x))
|
||||
|
||||
|
|
@ -35,7 +37,7 @@
|
|||
(syntax-parameterize ([making-a-method #'this-param] [method-contract? #t]) (->d . stx)))
|
||||
|
||||
(define (class/c-check-first-order ctc cls fail)
|
||||
(unless (-class? cls) ;; TODO: might be a wrapper class
|
||||
(unless (class? cls)
|
||||
(fail '(expected: "a class" given: "~v") cls))
|
||||
(define method-ht (class-method-ht cls))
|
||||
(define methods (class-methods cls))
|
||||
|
|
@ -180,13 +182,6 @@
|
|||
(list init #f))))
|
||||
|
||||
(λ (cls)
|
||||
;; TODO: hack! this drops the new-style contract
|
||||
;; from classes that are going thru the old-style contract
|
||||
(let loop ([a-class cls])
|
||||
(cond
|
||||
[(wrapped-class? a-class)
|
||||
(loop (wrapped-class-info-class (wrapped-class-the-info a-class)))]
|
||||
[else (set! cls a-class)]))
|
||||
(class/c-check-first-order ctc cls (λ args (apply raise-blame-error blame cls args)))
|
||||
(let* ([name (class-name cls)]
|
||||
[never-wrapped? (eq? (class-orig-cls cls) cls)]
|
||||
|
|
@ -759,6 +754,66 @@
|
|||
[(just-check-existence? obj) #f]
|
||||
[else (coerce-contract 'class/c obj)])))
|
||||
|
||||
(define (build-class/c-name ctc)
|
||||
(or (build-class/c-name ctc)
|
||||
(let* ([handled-methods
|
||||
(for/list ([i (in-list (class/c-methods ctc))]
|
||||
[ctc (in-list (class/c-method-contracts ctc))])
|
||||
(cond
|
||||
[ctc (build-compound-type-name i ctc)]
|
||||
[else i]))])
|
||||
(apply build-compound-type-name
|
||||
'class/c
|
||||
(append
|
||||
handled-methods
|
||||
(handle-optional 'init (class/c-inits ctc) (class/c-init-contracts ctc))
|
||||
(handle-optional 'field (class/c-fields ctc) (class/c-field-contracts ctc))
|
||||
(class/c-internal-name-clauses (class/c-internal ctc))
|
||||
(handle-absents (class/c-absents ctc) (class/c-absent-fields ctc)))))))
|
||||
|
||||
(define (class/c-internal-name-clauses internal-ctc)
|
||||
(append
|
||||
(handle-optional 'inherit
|
||||
(internal-class/c-inherits internal-ctc)
|
||||
(internal-class/c-inherit-contracts internal-ctc))
|
||||
(handle-optional 'inherit-field
|
||||
(internal-class/c-inherit-fields internal-ctc)
|
||||
(internal-class/c-inherit-field-contracts internal-ctc))
|
||||
(handle-optional 'super
|
||||
(internal-class/c-supers internal-ctc)
|
||||
(internal-class/c-super-contracts internal-ctc))
|
||||
(handle-optional 'inner
|
||||
(internal-class/c-inners internal-ctc)
|
||||
(internal-class/c-inner-contracts internal-ctc))
|
||||
(handle-optional 'override
|
||||
(internal-class/c-overrides internal-ctc)
|
||||
(internal-class/c-override-contracts internal-ctc))
|
||||
(handle-optional 'augment
|
||||
(internal-class/c-augments internal-ctc)
|
||||
(internal-class/c-augment-contracts internal-ctc))
|
||||
(handle-optional 'augride
|
||||
(internal-class/c-augrides internal-ctc)
|
||||
(internal-class/c-augride-contracts internal-ctc))))
|
||||
|
||||
(define (pair-ids-ctcs is ctcs)
|
||||
(for/list ([i (in-list is)]
|
||||
[ctc (in-list ctcs)])
|
||||
(if (not ctc)
|
||||
i
|
||||
(build-compound-type-name i ctc))))
|
||||
(define (handle-optional name is ctcs)
|
||||
(if (null? is)
|
||||
null
|
||||
(list (cons name (pair-ids-ctcs is ctcs)))))
|
||||
(define (handle-absents meths fields)
|
||||
(cond
|
||||
[(and (null? meths) (null? fields))
|
||||
null]
|
||||
[(null? fields)
|
||||
(list (cons 'absent meths))]
|
||||
[else
|
||||
(list (list* 'absent (cons 'field fields) meths))]))
|
||||
|
||||
(define-struct class/c
|
||||
(methods method-contracts fields field-contracts inits init-contracts
|
||||
absents absent-fields
|
||||
|
|
@ -767,64 +822,7 @@
|
|||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection class/c-proj
|
||||
#:name
|
||||
(λ (ctc)
|
||||
(or (class/c-name ctc)
|
||||
(let* ([pair-ids-ctcs
|
||||
(λ (is ctcs)
|
||||
(for/list ([i (in-list is)]
|
||||
[ctc (in-list ctcs)])
|
||||
(if (not ctc)
|
||||
i
|
||||
(build-compound-type-name i ctc))))]
|
||||
[handle-optional
|
||||
(λ (name is ctcs)
|
||||
(if (null? is)
|
||||
null
|
||||
(list (cons name (pair-ids-ctcs is ctcs)))))]
|
||||
[handle-absents
|
||||
(λ (meths fields)
|
||||
(cond
|
||||
[(and (null? meths) (null? fields))
|
||||
null]
|
||||
[(null? fields)
|
||||
(list (cons 'absent meths))]
|
||||
[else
|
||||
(list (list* 'absent (cons 'field fields) meths))]))]
|
||||
[handled-methods
|
||||
(for/list ([i (in-list (class/c-methods ctc))]
|
||||
[ctc (in-list (class/c-method-contracts ctc))])
|
||||
(cond
|
||||
[ctc (build-compound-type-name i ctc)]
|
||||
[else i]))])
|
||||
(apply build-compound-type-name
|
||||
'class/c
|
||||
(append
|
||||
handled-methods
|
||||
(handle-optional 'init (class/c-inits ctc) (class/c-init-contracts ctc))
|
||||
(handle-optional 'field (class/c-fields ctc) (class/c-field-contracts ctc))
|
||||
(handle-optional 'inherit
|
||||
(internal-class/c-inherits (class/c-internal ctc))
|
||||
(internal-class/c-inherit-contracts (class/c-internal ctc)))
|
||||
(handle-optional 'inherit-field
|
||||
(internal-class/c-inherit-fields (class/c-internal ctc))
|
||||
(internal-class/c-inherit-field-contracts (class/c-internal ctc)))
|
||||
(handle-optional 'super
|
||||
(internal-class/c-supers (class/c-internal ctc))
|
||||
(internal-class/c-super-contracts (class/c-internal ctc)))
|
||||
(handle-optional 'inner
|
||||
(internal-class/c-inners (class/c-internal ctc))
|
||||
(internal-class/c-inner-contracts (class/c-internal ctc)))
|
||||
(handle-optional 'override
|
||||
(internal-class/c-overrides (class/c-internal ctc))
|
||||
(internal-class/c-override-contracts (class/c-internal ctc)))
|
||||
(handle-optional 'augment
|
||||
(internal-class/c-augments (class/c-internal ctc))
|
||||
(internal-class/c-augment-contracts (class/c-internal ctc)))
|
||||
(handle-optional 'augride
|
||||
(internal-class/c-augrides (class/c-internal ctc))
|
||||
(internal-class/c-augride-contracts (class/c-internal ctc)))
|
||||
(handle-absents (class/c-absents ctc) (class/c-absent-fields ctc)))))))
|
||||
#:name build-class/c-name
|
||||
#:first-order
|
||||
(λ (ctc)
|
||||
(λ (cls)
|
||||
|
|
@ -1163,14 +1161,15 @@
|
|||
(define original-obj (if (has-original-object? val) (original-object val) val))
|
||||
(define new-cls (p (object-ref val)))
|
||||
(cond
|
||||
[(wrapped-class? new-cls)
|
||||
(define the-info (wrapped-class-the-info new-cls))
|
||||
[(impersonator-prop:has-wrapped-class-neg-party? new-cls)
|
||||
(define the-info (impersonator-prop:get-wrapped-class-info new-cls))
|
||||
(define neg-party (impersonator-prop:get-wrapped-class-neg-party new-cls))
|
||||
(wrapped-object
|
||||
val
|
||||
(wrapped-class-info-neg-extra-arg-vec the-info)
|
||||
(wrapped-class-info-pos-field-projs the-info)
|
||||
(wrapped-class-info-neg-field-projs the-info)
|
||||
(wrapped-class-neg-party new-cls))]
|
||||
neg-party)]
|
||||
[else
|
||||
(impersonate-struct val object-ref (λ (o c) new-cls)
|
||||
impersonator-prop:contracted ctc
|
||||
|
|
|
|||
|
|
@ -2031,15 +2031,10 @@ last few projections.
|
|||
|
||||
|#
|
||||
|
||||
(define -class?
|
||||
(let ([class?
|
||||
(λ (x) (or (class? x) (wrapped-class? x)))])
|
||||
class?))
|
||||
|
||||
;; compose-class: produces one result if `deserialize-id' is #f, two
|
||||
;; results if `deserialize-id' is not #f
|
||||
(define (compose-class name ; symbol
|
||||
raw-super ; class, possibly wrapper-class
|
||||
super ; class, possibly with contract impersonator properties
|
||||
interfaces ; list of interfaces
|
||||
inspector ; inspector or #f
|
||||
deserialize-id ; identifier or #f
|
||||
|
|
@ -2076,10 +2071,9 @@ last few projections.
|
|||
meth-name
|
||||
(if name " in " "")
|
||||
(or name "")))))
|
||||
(define super (unwrap-class raw-super))
|
||||
|
||||
;; -- Check superclass --
|
||||
(unless (-class? super)
|
||||
(unless (class? super)
|
||||
(obj-error 'class* "superclass expression result is not a class"
|
||||
"result" super
|
||||
#:class-name name))
|
||||
|
|
@ -2318,23 +2312,23 @@ last few projections.
|
|||
;; --- Make the new external method contract records ---
|
||||
;; (they are just copies of the super at this point, updated below)
|
||||
(define wci-neg-extra-arg-vec
|
||||
(if (class? raw-super)
|
||||
#f
|
||||
(let* ([the-info (wrapped-class-the-info raw-super)]
|
||||
(if (impersonator-prop:has-wrapped-class-neg-party? super)
|
||||
(let* ([the-info (impersonator-prop:get-wrapped-class-info super)]
|
||||
[ov (wrapped-class-info-neg-extra-arg-vec the-info)])
|
||||
(if no-method-changes?
|
||||
ov
|
||||
(let ([v (make-vector method-width #f)])
|
||||
(vector-copy! v 0 ov)
|
||||
v)))))
|
||||
v)))
|
||||
#f))
|
||||
(define wci-neg-acceptors-ht
|
||||
(if (class? raw-super)
|
||||
#f
|
||||
(let* ([the-info (wrapped-class-the-info raw-super)]
|
||||
(if (impersonator-prop:has-wrapped-class-neg-party? super)
|
||||
(let* ([the-info (impersonator-prop:get-wrapped-class-info super)]
|
||||
[oh (wrapped-class-info-neg-acceptors-ht the-info)])
|
||||
(if no-method-changes?
|
||||
oh
|
||||
(hash-copy oh)))))
|
||||
(hash-copy oh)))
|
||||
#f))
|
||||
|
||||
;; --- Make the new object struct ---
|
||||
(let*-values ([(prim-object-make prim-object? struct:prim-object)
|
||||
|
|
@ -2641,22 +2635,63 @@ last few projections.
|
|||
(loop (add1 i))))))))
|
||||
|
||||
;; --- Install initializer into class ---
|
||||
(set-class-init! c init)
|
||||
|
||||
;; and create contract-wrapped subclass
|
||||
(define c+ctc
|
||||
(if wci-neg-extra-arg-vec
|
||||
(let ([info (wrapped-class-the-info raw-super)])
|
||||
(wrapped-class
|
||||
(wrapped-class-info
|
||||
c
|
||||
(wrapped-class-info-blame info)
|
||||
wci-neg-extra-arg-vec
|
||||
wci-neg-acceptors-ht
|
||||
(wrapped-class-info-pos-field-projs info)
|
||||
(wrapped-class-info-neg-field-projs info)
|
||||
(wrapped-class-info-init-proj-pairs info))
|
||||
(wrapped-class-neg-party raw-super)))
|
||||
c))
|
||||
(cond
|
||||
[wci-neg-extra-arg-vec
|
||||
(define neg-party (impersonator-prop:get-wrapped-class-neg-party super))
|
||||
(define info (impersonator-prop:get-wrapped-class-info super))
|
||||
(define blame (wrapped-class-info-blame info))
|
||||
(define sub-init-proj-pairs
|
||||
(let loop ([proj-pairs (wrapped-class-info-init-proj-pairs info)])
|
||||
(cond
|
||||
[(null? proj-pairs) '()]
|
||||
[else
|
||||
(define pr (car proj-pairs))
|
||||
(if (member (list-ref pr 0) init-args)
|
||||
(loop (cdr proj-pairs))
|
||||
(cons pr (loop (cdr proj-pairs))))])))
|
||||
(define super-init-proj-pairs (wrapped-class-info-init-proj-pairs info))
|
||||
|
||||
;; use an init that checks the super contracts on a super call
|
||||
(set-class-init!
|
||||
c
|
||||
(λ (o continue-make-super c inited? leftovers named-args)
|
||||
(define (contract-checking-continue-make-super o c inited?
|
||||
leftovers
|
||||
by-pos-args
|
||||
new-named-args)
|
||||
(check-arg-contracts blame neg-party c
|
||||
super-init-proj-pairs
|
||||
new-named-args)
|
||||
(continue-make-super o c inited?
|
||||
leftovers
|
||||
by-pos-args
|
||||
new-named-args))
|
||||
(init o contract-checking-continue-make-super
|
||||
c inited? leftovers named-args)))
|
||||
|
||||
;; add properties to the subclass that
|
||||
;; check the residual external contracts
|
||||
(impersonate-struct
|
||||
c
|
||||
|
||||
set-class-orig-cls! (λ (a b) b)
|
||||
|
||||
impersonator-prop:wrapped-class-neg-party
|
||||
neg-party
|
||||
|
||||
impersonator-prop:wrapped-class-info
|
||||
(wrapped-class-info
|
||||
blame
|
||||
wci-neg-extra-arg-vec
|
||||
wci-neg-acceptors-ht
|
||||
(wrapped-class-info-pos-field-projs info)
|
||||
(wrapped-class-info-neg-field-projs info)
|
||||
sub-init-proj-pairs))]
|
||||
[else
|
||||
(set-class-init! c init)
|
||||
c]))
|
||||
|
||||
;; -- result is the class, and maybe deserialize-info ---
|
||||
(if deserialize-id
|
||||
|
|
@ -2812,7 +2847,8 @@ An example
|
|||
(make-struct-type 'props struct-type 0 0 #f props #f)])
|
||||
struct:))))
|
||||
|
||||
(define-values (prop:object _object? object-ref) (make-struct-type-property 'object 'can-impersonate))
|
||||
(define-values (prop:object _object? object-ref)
|
||||
(make-struct-type-property 'object 'can-impersonate))
|
||||
(define (object? o)
|
||||
(or (_object? o)
|
||||
(wrapped-object? o)))
|
||||
|
|
@ -2825,6 +2861,7 @@ An example
|
|||
(object-ref o)]))
|
||||
|
||||
|
||||
|
||||
;;--------------------------------------------------------------------
|
||||
;; interfaces
|
||||
;;--------------------------------------------------------------------
|
||||
|
|
@ -3269,22 +3306,22 @@ An example
|
|||
|
||||
(define (do-make-object blame class by-pos-args named-args)
|
||||
(cond
|
||||
[(class? class)
|
||||
(do-make-object/real-class blame class by-pos-args named-args #f #f '())]
|
||||
[(wrapped-class? class)
|
||||
(define the-info (wrapped-class-the-info class))
|
||||
(define unwrapped-class (wrapped-class-info-class the-info))
|
||||
[(impersonator-prop:has-wrapped-class-neg-party? class)
|
||||
(define the-info (impersonator-prop:get-wrapped-class-info class))
|
||||
(define neg-party (impersonator-prop:get-wrapped-class-neg-party class))
|
||||
(define unwrapped-o
|
||||
(do-make-object/real-class blame unwrapped-class by-pos-args named-args
|
||||
(do-make-object/real-class blame class by-pos-args named-args
|
||||
(wrapped-class-info-blame the-info)
|
||||
(wrapped-class-neg-party class)
|
||||
neg-party
|
||||
(wrapped-class-info-init-proj-pairs the-info)))
|
||||
(wrapped-object
|
||||
unwrapped-o
|
||||
(wrapped-class-info-neg-extra-arg-vec the-info)
|
||||
(wrapped-class-info-pos-field-projs the-info)
|
||||
(wrapped-class-info-neg-field-projs the-info)
|
||||
(wrapped-class-neg-party class))]
|
||||
neg-party)]
|
||||
[(class? class)
|
||||
(do-make-object/real-class blame class by-pos-args named-args #f #f '())]
|
||||
[else
|
||||
(raise-argument-error 'instantiate "class?" class)]))
|
||||
|
||||
|
|
@ -3645,41 +3682,69 @@ An example
|
|||
#:class-name (class-name cls)))
|
||||
|
||||
(define-values (make-class-field-accessor make-class-field-mutator)
|
||||
(let ([check-and-get-index
|
||||
(λ (who class name)
|
||||
(unless (-class? class)
|
||||
(raise-argument-error who "class?" class))
|
||||
(unless (symbol? name)
|
||||
(raise-argument-error who "symbol?" name))
|
||||
(hash-ref (class-field-ht (unwrap-class class)) name
|
||||
(lambda ()
|
||||
(obj-error who "no such field"
|
||||
"field-name" (as-write name)
|
||||
#:class-name (class-name (unwrap-class class))))))])
|
||||
(let ()
|
||||
(define (check-and-get-proc who class name get?)
|
||||
(unless (class? class)
|
||||
(raise-argument-error who "class?" class))
|
||||
(unless (symbol? name)
|
||||
(raise-argument-error who "symbol?" name))
|
||||
(define field-info-external-X (if get? field-info-external-ref field-info-external-set!))
|
||||
(define wrapped-class-info-X-field-projs
|
||||
(if get?
|
||||
wrapped-class-info-pos-field-projs
|
||||
wrapped-class-info-neg-field-projs))
|
||||
(define (get-accessor)
|
||||
(field-info-external-X
|
||||
(hash-ref (class-field-ht class) name
|
||||
(lambda ()
|
||||
(obj-error who "no such field"
|
||||
"field-name" (as-write name)
|
||||
#:class-name (class-name class))))))
|
||||
(cond
|
||||
[(impersonator-prop:has-wrapped-class-neg-party? class)
|
||||
(define the-info (impersonator-prop:get-wrapped-class-info class))
|
||||
(define projs (hash-ref (wrapped-class-info-X-field-projs the-info) name #f))
|
||||
(define np (impersonator-prop:get-wrapped-class-neg-party class))
|
||||
(cond
|
||||
[projs
|
||||
(if get?
|
||||
(let loop ([projs projs])
|
||||
(cond
|
||||
[(pair? projs)
|
||||
(define f-rest (loop (cdr projs)))
|
||||
(define f-this (car projs))
|
||||
(λ (val) ((f-this (f-rest val)) np))]
|
||||
[else projs]))
|
||||
(let loop ([projs projs])
|
||||
(cond
|
||||
[(pair? projs)
|
||||
(define f-rest (loop (cdr projs)))
|
||||
(define f-this (car projs))
|
||||
(λ (o val) ((f-this (f-rest o val)) np))]
|
||||
[else projs])))]
|
||||
[else (get-accessor)])]
|
||||
[else
|
||||
(get-accessor)]))
|
||||
(values (λ (class name)
|
||||
(let* ([fi (check-and-get-index 'class-field-accessor class name)]
|
||||
[ref (field-info-external-ref fi)])
|
||||
(λ (o)
|
||||
(cond
|
||||
[(_object? o)
|
||||
(ref o)]
|
||||
[else
|
||||
(define uw (unwrap-object o))
|
||||
(if (_object? uw)
|
||||
(ref uw)
|
||||
(raise-argument-error 'class-field-accessor "object?" o))]))))
|
||||
(define ref (check-and-get-proc 'class-field-accessor class name #t))
|
||||
(λ (o)
|
||||
(cond
|
||||
[(_object? o)
|
||||
(ref o)]
|
||||
[(wrapped-object? o)
|
||||
(ref (wrapped-object-object o))]
|
||||
[else
|
||||
(raise-argument-error 'class-field-accessor "object?" o)])))
|
||||
(λ (class name)
|
||||
(let* ([fi (check-and-get-index 'class-field-mutator class name)]
|
||||
[setter! (field-info-external-set! fi)])
|
||||
(λ (o v)
|
||||
(cond
|
||||
[(_object? o)
|
||||
(setter! o v)]
|
||||
[else
|
||||
(define uw (unwrap-object o))
|
||||
(if (_object? uw)
|
||||
(setter! uw v)
|
||||
(raise-argument-error 'class-field-mutator "object?" o))])))))))
|
||||
(define setter! (check-and-get-proc 'class-field-mutator class name #f))
|
||||
(λ (o v)
|
||||
(cond
|
||||
[(_object? o)
|
||||
(setter! o v)]
|
||||
[(wrapped-object? o)
|
||||
(setter! (unwrap-object o) v)]
|
||||
[else
|
||||
(raise-argument-error 'class-field-mutator "object?" o)]))))))
|
||||
|
||||
(define-struct generic (name applicable))
|
||||
|
||||
|
|
@ -3689,7 +3754,7 @@ An example
|
|||
(define make-generic/proc
|
||||
(let ([make-generic
|
||||
(lambda (class name)
|
||||
(unless (or (-class? class) (interface? class))
|
||||
(unless (or (class? class) (interface? class))
|
||||
(raise-argument-error 'make-generic "(or/c class? interface?)" class))
|
||||
(unless (symbol? name)
|
||||
(raise-argument-error 'make-generic "symbol?" name))
|
||||
|
|
@ -3709,8 +3774,7 @@ An example
|
|||
"target" obj
|
||||
#:intf-name (interface-name intf)))
|
||||
(find-method/who 'make-generic obj name)))
|
||||
(let* ([class (unwrap-class class)] ;; TODO: should this do checking?
|
||||
[pos (hash-ref (class-method-ht class) name
|
||||
(let* ([pos (hash-ref (class-method-ht class) name
|
||||
(lambda ()
|
||||
(obj-error 'make-generic "no such method"
|
||||
"method name" (as-write name)
|
||||
|
|
@ -4003,17 +4067,17 @@ An example
|
|||
|
||||
(define (is-a? v c)
|
||||
(cond
|
||||
[(-class? c)
|
||||
(and (object? v) ((class-object? (class-orig-cls (unwrap-class c))) (unwrap-object v)))]
|
||||
[(class? c)
|
||||
(and (object? v) ((class-object? (class-orig-cls c)) (unwrap-object v)))]
|
||||
[(interface? c) (and (object? v) (implementation? (object-ref/unwrap v) c))]
|
||||
[else (raise-argument-error 'is-a? "(or/c class? interface?)" 1 v c)]))
|
||||
|
||||
(define (subclass? v c)
|
||||
(unless (-class? c)
|
||||
(unless (class? c)
|
||||
(raise-argument-error 'subclass? "class?" 1 v c))
|
||||
(and (-class? v)
|
||||
(let* ([c (class-orig-cls (unwrap-class c))]
|
||||
[v (class-orig-cls (unwrap-class v))]
|
||||
(and (class? v)
|
||||
(let* ([c (class-orig-cls c)]
|
||||
[v (class-orig-cls v)]
|
||||
[p (class-pos c)])
|
||||
(and (<= p (class-pos v))
|
||||
(eq? c (vector-ref (class-supers v) p))))))
|
||||
|
|
@ -4042,8 +4106,8 @@ An example
|
|||
(define (implementation? v i)
|
||||
(unless (interface? i)
|
||||
(raise-argument-error 'implementation? "interface?" 1 v i))
|
||||
(and (-class? v)
|
||||
(interface-extension? (class-self-interface (unwrap-class v)) i)))
|
||||
(and (class? v)
|
||||
(interface-extension? (class-self-interface v) i)))
|
||||
|
||||
(define (interface-extension? v i)
|
||||
(unless (interface? i)
|
||||
|
|
@ -4059,9 +4123,9 @@ An example
|
|||
(and (memq s (interface-public-ids i)) #t))
|
||||
|
||||
(define (class->interface c)
|
||||
(unless (-class? c)
|
||||
(unless (class? c)
|
||||
(raise-argument-error 'class->interface "class?" c))
|
||||
(class-self-interface (unwrap-class c)))
|
||||
(class-self-interface c))
|
||||
|
||||
(define (interned? sym)
|
||||
(eq? sym (string->symbol (symbol->string sym))))
|
||||
|
|
@ -4090,10 +4154,9 @@ An example
|
|||
(string->symbol s)
|
||||
s))
|
||||
|
||||
(define (class-info _c)
|
||||
(unless (-class? _c)
|
||||
(raise-argument-error 'class-info "class?" _c))
|
||||
(define c (unwrap-class _c))
|
||||
(define (class-info c)
|
||||
(unless (class? c)
|
||||
(raise-argument-error 'class-info "class?" c))
|
||||
(if (struct? ((class-insp-mk c)))
|
||||
(let ([super (vector-ref (class-supers c) (sub1 (class-pos c)))])
|
||||
(let loop ([next super][skipped? #f])
|
||||
|
|
@ -4143,9 +4206,15 @@ An example
|
|||
(raise-argument-error 'object=? "object?" o1))
|
||||
(unless (object? o2)
|
||||
(raise-argument-error 'object=? "object?" o2))
|
||||
(let ([orig-o1 (if (has-original-object? o1) (original-object o1) o1)]
|
||||
[orig-o2 (if (has-original-object? o2) (original-object o2) o2)])
|
||||
(eq? orig-o1 orig-o2)))
|
||||
(let* ([orig-o1 (if (has-original-object? o1) (original-object o1) o1)]
|
||||
[orig-o2 (if (has-original-object? o2) (original-object o2) o2)]
|
||||
[orig-orig-o1 (if (wrapped-object? orig-o1)
|
||||
(wrapped-object-object orig-o1)
|
||||
orig-o1)]
|
||||
[orig-orig-o2 (if (wrapped-object? orig-o2)
|
||||
(wrapped-object-object orig-o2)
|
||||
orig-o2)])
|
||||
(eq? orig-orig-o1 orig-orig-o2)))
|
||||
|
||||
;;--------------------------------------------------------------------
|
||||
;; primitive classes
|
||||
|
|
@ -4380,7 +4449,7 @@ An example
|
|||
|
||||
(define (check-mixin-super mixin-name super% from-ids)
|
||||
(let ([mixin-name (or mixin-name 'mixin)])
|
||||
(unless (-class? super%)
|
||||
(unless (class? super%)
|
||||
(obj-error mixin-name
|
||||
"argument is not a class"
|
||||
"argument" super%))
|
||||
|
|
@ -4530,7 +4599,7 @@ An example
|
|||
(provide (protect-out get-field/proc)
|
||||
|
||||
;; for class-c-old.rkt:
|
||||
-class? make-naming-constructor prop:object _object? object-ref replace-ictc-blame
|
||||
make-naming-constructor prop:object _object? object-ref replace-ictc-blame
|
||||
concretize-ictc-method field-info-extend-external field-info-extend-internal this-param
|
||||
object-ref/unwrap impersonator-prop:original-object has-original-object? original-object
|
||||
;; end class-c-old.rkt requirements
|
||||
|
|
@ -4540,7 +4609,7 @@ An example
|
|||
|
||||
(rename-out [_class class]) class* class/derived
|
||||
define-serializable-class define-serializable-class*
|
||||
(rename-out [-class? class?])
|
||||
class?
|
||||
mixin
|
||||
(rename-out [_interface interface]) interface* interface?
|
||||
object% object? object=? externalizable<%> printable<%> writable<%> equal<%>
|
||||
|
|
@ -4569,4 +4638,4 @@ An example
|
|||
(for-syntax localize)
|
||||
(except-out (struct-out class) class class?)
|
||||
(rename-out [class? class-struct-predicate?])
|
||||
(struct-out wrapped-class) (struct-out wrapped-class-info) (struct-out wrapped-object))
|
||||
(struct-out wrapped-object))
|
||||
|
|
|
|||
|
|
@ -1,20 +1,21 @@
|
|||
#lang racket/base
|
||||
(provide (struct-out wrapped-class-info)
|
||||
(struct-out wrapped-class)
|
||||
(provide (except-out (struct-out wrapped-class-info) wrapped-class-info?)
|
||||
(struct-out wrapped-object)
|
||||
unwrap-class
|
||||
unwrap-object)
|
||||
unwrap-object
|
||||
|
||||
impersonator-prop:wrapped-class-info
|
||||
impersonator-prop:has-wrapped-class-info?
|
||||
impersonator-prop:get-wrapped-class-info
|
||||
|
||||
(struct wrapped-class-info (class blame
|
||||
neg-extra-arg-vec ;; vector that parallels the class's vector of methods
|
||||
neg-acceptors-ht ;; range of ht has curried (neg-pary -> mth) fns
|
||||
pos-field-projs neg-field-projs
|
||||
init-proj-pairs)
|
||||
#:transparent)
|
||||
(struct wrapped-class (the-info neg-party)
|
||||
#:property prop:custom-write
|
||||
(λ (stct port mode)
|
||||
(do-custom-write (wrapped-class-info-class (wrapped-class-the-info stct)) port mode))
|
||||
impersonator-prop:wrapped-class-neg-party
|
||||
impersonator-prop:has-wrapped-class-neg-party?
|
||||
impersonator-prop:get-wrapped-class-neg-party)
|
||||
|
||||
(struct wrapped-class-info (blame
|
||||
neg-extra-arg-vec ;; vector that parallels the class's vector of methods
|
||||
neg-acceptors-ht ;; range of ht has curried (neg-pary -> mth) fns
|
||||
pos-field-projs neg-field-projs
|
||||
init-proj-pairs)
|
||||
#:transparent)
|
||||
|
||||
(struct wrapped-object (object neg-extra-arg-vec pos-field-projs neg-field-projs neg-party)
|
||||
|
|
@ -34,13 +35,17 @@
|
|||
[else
|
||||
(print v port mode)]))
|
||||
|
||||
|
||||
(define (unwrap-object o)
|
||||
(cond
|
||||
[(wrapped-object? o) (wrapped-object-object o)]
|
||||
[else o]))
|
||||
|
||||
(define (unwrap-class cls)
|
||||
(cond
|
||||
[(wrapped-class? cls) (wrapped-class-info-class (wrapped-class-the-info cls))]
|
||||
[else cls]))
|
||||
(define-values (impersonator-prop:wrapped-class-info
|
||||
impersonator-prop:has-wrapped-class-info?
|
||||
impersonator-prop:get-wrapped-class-info)
|
||||
(make-impersonator-property 'wrapped-class-info))
|
||||
|
||||
(define-values (impersonator-prop:wrapped-class-neg-party
|
||||
impersonator-prop:has-wrapped-class-neg-party?
|
||||
impersonator-prop:get-wrapped-class-neg-party)
|
||||
(make-impersonator-property 'wrapped-class-neg-party))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user