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]))
|
[x 2]))
|
||||||
|
|
||||||
(test/spec-passed/result
|
(test/spec-passed/result
|
||||||
'class-field-accessor
|
'class-field-accessor1
|
||||||
'(let ([c% (class object% (super-new) (field [f 1]))])
|
'(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))))
|
(new (contract (class/c) c% 'pos 'neg))))
|
||||||
1)
|
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
|
(test/spec-passed/result
|
||||||
'class-field-mutator
|
'class-field-mutator1
|
||||||
'(let* ([c% (class object% (super-new) (field [f 1]))]
|
'(let* ([c% (class object% (super-new) (field [f 1]))]
|
||||||
[o (new (contract (class/c) c% 'pos 'neg))])
|
[o (new (contract (class/c) c% 'pos 'neg))])
|
||||||
((class-field-mutator c% f) o 2)
|
((class-field-mutator c% f) o 2)
|
||||||
((class-field-accessor c% f) o))
|
((class-field-accessor c% f) o))
|
||||||
2)
|
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
|
(test/spec-passed/result
|
||||||
'order-of-evaluation
|
'order-of-evaluation
|
||||||
'(let ([x '()])
|
'(let ([x '()])
|
||||||
|
|
@ -2360,6 +2406,70 @@
|
||||||
[sub-c% (class c% (super-new))])
|
[sub-c% (class c% (super-new))])
|
||||||
(new sub-c% [f 1])))
|
(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?
|
(let ([expected-given?
|
||||||
(λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn))
|
(λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn))
|
||||||
|
|
|
||||||
|
|
@ -334,6 +334,24 @@
|
||||||
(class/c [m (->dm ([d integer?]) () [r integer?])]))
|
(class/c [m (->dm ([d integer?]) () [r integer?])]))
|
||||||
(test-name 'c%/c (let ([c%/c (class/c [m (->m integer? integer?)])])
|
(test-name 'c%/c (let ([c%/c (class/c [m (->m integer? integer?)])])
|
||||||
c%/c))
|
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
|
(test-name '(struct/dc s
|
||||||
[a integer?]
|
[a integer?]
|
||||||
|
|
|
||||||
|
|
@ -6,7 +6,8 @@
|
||||||
;; All of the implementation is actually in private/class-internal.rkt,
|
;; All of the implementation is actually in private/class-internal.rkt,
|
||||||
;; which provides extra (private) functionality to contract.rkt.
|
;; which provides extra (private) functionality to contract.rkt.
|
||||||
(require "private/class-internal.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-public-names)
|
||||||
(provide generic?)
|
(provide generic?)
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,7 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
(require "class-internal.rkt"
|
(require "class-internal.rkt"
|
||||||
"class-c-old.rkt"
|
"class-c-old.rkt"
|
||||||
|
"class-wrapped.rkt"
|
||||||
"../contract/base.rkt"
|
"../contract/base.rkt"
|
||||||
"../contract/combinator.rkt"
|
"../contract/combinator.rkt"
|
||||||
(only-in "../contract/private/guts.rkt"
|
(only-in "../contract/private/guts.rkt"
|
||||||
|
|
@ -88,6 +89,27 @@
|
||||||
(neg-accepter #f)
|
(neg-accepter #f)
|
||||||
(k neg-accepter)))
|
(k neg-accepter)))
|
||||||
(cond
|
(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)
|
[(class-struct-predicate? cls)
|
||||||
(define mtd-vec (class-methods cls))
|
(define mtd-vec (class-methods cls))
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -142,28 +164,6 @@
|
||||||
[else
|
[else
|
||||||
(build-neg-acceptor-proc this maybe-err blame cls #f '()
|
(build-neg-acceptor-proc this maybe-err blame cls #f '()
|
||||||
(make-hasheq) (make-hasheq))])]
|
(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
|
[else
|
||||||
(maybe-err
|
(maybe-err
|
||||||
(λ (neg-party)
|
(λ (neg-party)
|
||||||
|
|
@ -308,9 +308,14 @@
|
||||||
((get/build-val-first-projection ctc)
|
((get/build-val-first-projection ctc)
|
||||||
(blame-add-init-context blame (car ctc-pair)))))))
|
(blame-add-init-context blame (car ctc-pair)))))))
|
||||||
(define merged-init-pairs (merge-init-pairs old-init-pairs new-init-projs))
|
(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
|
pos-field-projs neg-field-projs
|
||||||
merged-init-pairs))
|
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)
|
(λ (neg-party)
|
||||||
;; run this for the side-effect of
|
;; run this for the side-effect of
|
||||||
|
|
@ -324,13 +329,17 @@
|
||||||
;; the internal projection should run
|
;; the internal projection should run
|
||||||
;; on the class only when it is
|
;; on the class only when it is
|
||||||
;; time to instantiate it; not here
|
;; time to instantiate it; not here
|
||||||
(define the-info/adjusted-cls
|
(define class+one-property/adjusted
|
||||||
(struct-copy wrapped-class-info
|
(chaperone-struct ((internal-proj (blame-add-missing-party blame neg-party))
|
||||||
the-info
|
cls)
|
||||||
[class ((internal-proj (blame-add-missing-party blame neg-party))
|
set-class-orig-cls! (λ (a b) b)
|
||||||
cls)]))
|
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)
|
(define (merge-init-pairs old-init-pairs new-init-pairs)
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -437,19 +446,54 @@
|
||||||
(cond
|
(cond
|
||||||
[(ext-class/c-contract-name c) => values]
|
[(ext-class/c-contract-name c) => values]
|
||||||
[else
|
[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
|
(define init-names
|
||||||
|
(filter
|
||||||
|
values
|
||||||
(for/list ([pr (in-list (ext-class/c-contract-init-ctc-pairs c))])
|
(for/list ([pr (in-list (ext-class/c-contract-init-ctc-pairs c))])
|
||||||
(define name (list-ref pr 0))
|
(define name (list-ref pr 0))
|
||||||
(define ctc (list-ref pr 1))
|
(define ctc (list-ref pr 1))
|
||||||
(if (just-check-existence? ctc)
|
(cond
|
||||||
name
|
[(just-check-existence? ctc)
|
||||||
`[,name ,(contract-name 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
|
(define meth-names
|
||||||
(for/list ([(name ctc) (in-hash (ext-class/c-contract-table-of-meths-to-ctcs c))])
|
(for/list ([(name ctc) (in-hash (ext-class/c-contract-table-of-meths-to-ctcs c))])
|
||||||
(if (just-check-existence? ctc)
|
(if (just-check-existence? ctc)
|
||||||
name
|
name
|
||||||
`[,name ,(contract-name ctc)])))
|
`[,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)
|
`(class/c ,@(if (null? init-names)
|
||||||
(list)
|
(list)
|
||||||
(list `(init ,@init-names)))
|
(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
|
racket/stxparam
|
||||||
syntax/parse)
|
syntax/parse)
|
||||||
racket/stxparam
|
racket/stxparam
|
||||||
|
"class-wrapped.rkt"
|
||||||
"class-internal.rkt"
|
"class-internal.rkt"
|
||||||
"../contract/base.rkt"
|
"../contract/base.rkt"
|
||||||
"../contract/combinator.rkt"
|
"../contract/combinator.rkt"
|
||||||
|
|
@ -16,7 +17,8 @@
|
||||||
(for-syntax parse-class/c-specs)
|
(for-syntax parse-class/c-specs)
|
||||||
(struct-out internal-class/c)
|
(struct-out internal-class/c)
|
||||||
just-check-existence just-check-existence?
|
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))
|
(define undefined (letrec ([x x]) x))
|
||||||
|
|
||||||
|
|
@ -35,7 +37,7 @@
|
||||||
(syntax-parameterize ([making-a-method #'this-param] [method-contract? #t]) (->d . stx)))
|
(syntax-parameterize ([making-a-method #'this-param] [method-contract? #t]) (->d . stx)))
|
||||||
|
|
||||||
(define (class/c-check-first-order ctc cls fail)
|
(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))
|
(fail '(expected: "a class" given: "~v") cls))
|
||||||
(define method-ht (class-method-ht cls))
|
(define method-ht (class-method-ht cls))
|
||||||
(define methods (class-methods cls))
|
(define methods (class-methods cls))
|
||||||
|
|
@ -180,13 +182,6 @@
|
||||||
(list init #f))))
|
(list init #f))))
|
||||||
|
|
||||||
(λ (cls)
|
(λ (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)))
|
(class/c-check-first-order ctc cls (λ args (apply raise-blame-error blame cls args)))
|
||||||
(let* ([name (class-name cls)]
|
(let* ([name (class-name cls)]
|
||||||
[never-wrapped? (eq? (class-orig-cls cls) cls)]
|
[never-wrapped? (eq? (class-orig-cls cls) cls)]
|
||||||
|
|
@ -759,39 +754,9 @@
|
||||||
[(just-check-existence? obj) #f]
|
[(just-check-existence? obj) #f]
|
||||||
[else (coerce-contract 'class/c obj)])))
|
[else (coerce-contract 'class/c obj)])))
|
||||||
|
|
||||||
(define-struct class/c
|
(define (build-class/c-name ctc)
|
||||||
(methods method-contracts fields field-contracts inits init-contracts
|
(or (build-class/c-name ctc)
|
||||||
absents absent-fields
|
(let* ([handled-methods
|
||||||
internal opaque? name)
|
|
||||||
#:omit-define-syntaxes
|
|
||||||
#: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))]
|
(for/list ([i (in-list (class/c-methods ctc))]
|
||||||
[ctc (in-list (class/c-method-contracts ctc))])
|
[ctc (in-list (class/c-method-contracts ctc))])
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -803,28 +768,61 @@
|
||||||
handled-methods
|
handled-methods
|
||||||
(handle-optional 'init (class/c-inits ctc) (class/c-init-contracts ctc))
|
(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 'field (class/c-fields ctc) (class/c-field-contracts ctc))
|
||||||
(handle-optional 'inherit
|
(class/c-internal-name-clauses (class/c-internal ctc))
|
||||||
(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)))))))
|
(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
|
||||||
|
internal opaque? name)
|
||||||
|
#:omit-define-syntaxes
|
||||||
|
#:property prop:contract
|
||||||
|
(build-contract-property
|
||||||
|
#:projection class/c-proj
|
||||||
|
#:name build-class/c-name
|
||||||
#:first-order
|
#:first-order
|
||||||
(λ (ctc)
|
(λ (ctc)
|
||||||
(λ (cls)
|
(λ (cls)
|
||||||
|
|
@ -1163,14 +1161,15 @@
|
||||||
(define original-obj (if (has-original-object? val) (original-object val) val))
|
(define original-obj (if (has-original-object? val) (original-object val) val))
|
||||||
(define new-cls (p (object-ref val)))
|
(define new-cls (p (object-ref val)))
|
||||||
(cond
|
(cond
|
||||||
[(wrapped-class? new-cls)
|
[(impersonator-prop:has-wrapped-class-neg-party? new-cls)
|
||||||
(define the-info (wrapped-class-the-info 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
|
(wrapped-object
|
||||||
val
|
val
|
||||||
(wrapped-class-info-neg-extra-arg-vec the-info)
|
(wrapped-class-info-neg-extra-arg-vec the-info)
|
||||||
(wrapped-class-info-pos-field-projs the-info)
|
(wrapped-class-info-pos-field-projs the-info)
|
||||||
(wrapped-class-info-neg-field-projs the-info)
|
(wrapped-class-info-neg-field-projs the-info)
|
||||||
(wrapped-class-neg-party new-cls))]
|
neg-party)]
|
||||||
[else
|
[else
|
||||||
(impersonate-struct val object-ref (λ (o c) new-cls)
|
(impersonate-struct val object-ref (λ (o c) new-cls)
|
||||||
impersonator-prop:contracted ctc
|
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
|
;; compose-class: produces one result if `deserialize-id' is #f, two
|
||||||
;; results if `deserialize-id' is not #f
|
;; results if `deserialize-id' is not #f
|
||||||
(define (compose-class name ; symbol
|
(define (compose-class name ; symbol
|
||||||
raw-super ; class, possibly wrapper-class
|
super ; class, possibly with contract impersonator properties
|
||||||
interfaces ; list of interfaces
|
interfaces ; list of interfaces
|
||||||
inspector ; inspector or #f
|
inspector ; inspector or #f
|
||||||
deserialize-id ; identifier or #f
|
deserialize-id ; identifier or #f
|
||||||
|
|
@ -2076,10 +2071,9 @@ last few projections.
|
||||||
meth-name
|
meth-name
|
||||||
(if name " in " "")
|
(if name " in " "")
|
||||||
(or name "")))))
|
(or name "")))))
|
||||||
(define super (unwrap-class raw-super))
|
|
||||||
|
|
||||||
;; -- Check superclass --
|
;; -- Check superclass --
|
||||||
(unless (-class? super)
|
(unless (class? super)
|
||||||
(obj-error 'class* "superclass expression result is not a class"
|
(obj-error 'class* "superclass expression result is not a class"
|
||||||
"result" super
|
"result" super
|
||||||
#:class-name name))
|
#:class-name name))
|
||||||
|
|
@ -2318,23 +2312,23 @@ last few projections.
|
||||||
;; --- Make the new external method contract records ---
|
;; --- Make the new external method contract records ---
|
||||||
;; (they are just copies of the super at this point, updated below)
|
;; (they are just copies of the super at this point, updated below)
|
||||||
(define wci-neg-extra-arg-vec
|
(define wci-neg-extra-arg-vec
|
||||||
(if (class? raw-super)
|
(if (impersonator-prop:has-wrapped-class-neg-party? super)
|
||||||
#f
|
(let* ([the-info (impersonator-prop:get-wrapped-class-info super)]
|
||||||
(let* ([the-info (wrapped-class-the-info raw-super)]
|
|
||||||
[ov (wrapped-class-info-neg-extra-arg-vec the-info)])
|
[ov (wrapped-class-info-neg-extra-arg-vec the-info)])
|
||||||
(if no-method-changes?
|
(if no-method-changes?
|
||||||
ov
|
ov
|
||||||
(let ([v (make-vector method-width #f)])
|
(let ([v (make-vector method-width #f)])
|
||||||
(vector-copy! v 0 ov)
|
(vector-copy! v 0 ov)
|
||||||
v)))))
|
v)))
|
||||||
|
#f))
|
||||||
(define wci-neg-acceptors-ht
|
(define wci-neg-acceptors-ht
|
||||||
(if (class? raw-super)
|
(if (impersonator-prop:has-wrapped-class-neg-party? super)
|
||||||
#f
|
(let* ([the-info (impersonator-prop:get-wrapped-class-info super)]
|
||||||
(let* ([the-info (wrapped-class-the-info raw-super)]
|
|
||||||
[oh (wrapped-class-info-neg-acceptors-ht the-info)])
|
[oh (wrapped-class-info-neg-acceptors-ht the-info)])
|
||||||
(if no-method-changes?
|
(if no-method-changes?
|
||||||
oh
|
oh
|
||||||
(hash-copy oh)))))
|
(hash-copy oh)))
|
||||||
|
#f))
|
||||||
|
|
||||||
;; --- Make the new object struct ---
|
;; --- Make the new object struct ---
|
||||||
(let*-values ([(prim-object-make prim-object? struct:prim-object)
|
(let*-values ([(prim-object-make prim-object? struct:prim-object)
|
||||||
|
|
@ -2641,22 +2635,63 @@ last few projections.
|
||||||
(loop (add1 i))))))))
|
(loop (add1 i))))))))
|
||||||
|
|
||||||
;; --- Install initializer into class ---
|
;; --- Install initializer into class ---
|
||||||
(set-class-init! c init)
|
;; and create contract-wrapped subclass
|
||||||
|
|
||||||
(define c+ctc
|
(define c+ctc
|
||||||
(if wci-neg-extra-arg-vec
|
(cond
|
||||||
(let ([info (wrapped-class-the-info raw-super)])
|
[wci-neg-extra-arg-vec
|
||||||
(wrapped-class
|
(define neg-party (impersonator-prop:get-wrapped-class-neg-party super))
|
||||||
(wrapped-class-info
|
(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
|
c
|
||||||
(wrapped-class-info-blame info)
|
(λ (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-extra-arg-vec
|
||||||
wci-neg-acceptors-ht
|
wci-neg-acceptors-ht
|
||||||
(wrapped-class-info-pos-field-projs info)
|
(wrapped-class-info-pos-field-projs info)
|
||||||
(wrapped-class-info-neg-field-projs info)
|
(wrapped-class-info-neg-field-projs info)
|
||||||
(wrapped-class-info-init-proj-pairs info))
|
sub-init-proj-pairs))]
|
||||||
(wrapped-class-neg-party raw-super)))
|
[else
|
||||||
c))
|
(set-class-init! c init)
|
||||||
|
c]))
|
||||||
|
|
||||||
;; -- result is the class, and maybe deserialize-info ---
|
;; -- result is the class, and maybe deserialize-info ---
|
||||||
(if deserialize-id
|
(if deserialize-id
|
||||||
|
|
@ -2812,7 +2847,8 @@ An example
|
||||||
(make-struct-type 'props struct-type 0 0 #f props #f)])
|
(make-struct-type 'props struct-type 0 0 #f props #f)])
|
||||||
struct:))))
|
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)
|
(define (object? o)
|
||||||
(or (_object? o)
|
(or (_object? o)
|
||||||
(wrapped-object? o)))
|
(wrapped-object? o)))
|
||||||
|
|
@ -2825,6 +2861,7 @@ An example
|
||||||
(object-ref o)]))
|
(object-ref o)]))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;--------------------------------------------------------------------
|
;;--------------------------------------------------------------------
|
||||||
;; interfaces
|
;; interfaces
|
||||||
;;--------------------------------------------------------------------
|
;;--------------------------------------------------------------------
|
||||||
|
|
@ -3269,22 +3306,22 @@ An example
|
||||||
|
|
||||||
(define (do-make-object blame class by-pos-args named-args)
|
(define (do-make-object blame class by-pos-args named-args)
|
||||||
(cond
|
(cond
|
||||||
[(class? class)
|
[(impersonator-prop:has-wrapped-class-neg-party? class)
|
||||||
(do-make-object/real-class blame class by-pos-args named-args #f #f '())]
|
(define the-info (impersonator-prop:get-wrapped-class-info class))
|
||||||
[(wrapped-class? class)
|
(define neg-party (impersonator-prop:get-wrapped-class-neg-party class))
|
||||||
(define the-info (wrapped-class-the-info class))
|
|
||||||
(define unwrapped-class (wrapped-class-info-class the-info))
|
|
||||||
(define unwrapped-o
|
(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-info-blame the-info)
|
||||||
(wrapped-class-neg-party class)
|
neg-party
|
||||||
(wrapped-class-info-init-proj-pairs the-info)))
|
(wrapped-class-info-init-proj-pairs the-info)))
|
||||||
(wrapped-object
|
(wrapped-object
|
||||||
unwrapped-o
|
unwrapped-o
|
||||||
(wrapped-class-info-neg-extra-arg-vec the-info)
|
(wrapped-class-info-neg-extra-arg-vec the-info)
|
||||||
(wrapped-class-info-pos-field-projs the-info)
|
(wrapped-class-info-pos-field-projs the-info)
|
||||||
(wrapped-class-info-neg-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
|
[else
|
||||||
(raise-argument-error 'instantiate "class?" class)]))
|
(raise-argument-error 'instantiate "class?" class)]))
|
||||||
|
|
||||||
|
|
@ -3645,41 +3682,69 @@ An example
|
||||||
#:class-name (class-name cls)))
|
#:class-name (class-name cls)))
|
||||||
|
|
||||||
(define-values (make-class-field-accessor make-class-field-mutator)
|
(define-values (make-class-field-accessor make-class-field-mutator)
|
||||||
(let ([check-and-get-index
|
(let ()
|
||||||
(λ (who class name)
|
(define (check-and-get-proc who class name get?)
|
||||||
(unless (-class? class)
|
(unless (class? class)
|
||||||
(raise-argument-error who "class?" class))
|
(raise-argument-error who "class?" class))
|
||||||
(unless (symbol? name)
|
(unless (symbol? name)
|
||||||
(raise-argument-error who "symbol?" name))
|
(raise-argument-error who "symbol?" name))
|
||||||
(hash-ref (class-field-ht (unwrap-class class)) 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 ()
|
(lambda ()
|
||||||
(obj-error who "no such field"
|
(obj-error who "no such field"
|
||||||
"field-name" (as-write name)
|
"field-name" (as-write name)
|
||||||
#:class-name (class-name (unwrap-class class))))))])
|
#: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)
|
(values (λ (class name)
|
||||||
(let* ([fi (check-and-get-index 'class-field-accessor class name)]
|
(define ref (check-and-get-proc 'class-field-accessor class name #t))
|
||||||
[ref (field-info-external-ref fi)])
|
|
||||||
(λ (o)
|
(λ (o)
|
||||||
(cond
|
(cond
|
||||||
[(_object? o)
|
[(_object? o)
|
||||||
(ref o)]
|
(ref o)]
|
||||||
|
[(wrapped-object? o)
|
||||||
|
(ref (wrapped-object-object o))]
|
||||||
[else
|
[else
|
||||||
(define uw (unwrap-object o))
|
(raise-argument-error 'class-field-accessor "object?" o)])))
|
||||||
(if (_object? uw)
|
|
||||||
(ref uw)
|
|
||||||
(raise-argument-error 'class-field-accessor "object?" o))]))))
|
|
||||||
(λ (class name)
|
(λ (class name)
|
||||||
(let* ([fi (check-and-get-index 'class-field-mutator class name)]
|
(define setter! (check-and-get-proc 'class-field-mutator class name #f))
|
||||||
[setter! (field-info-external-set! fi)])
|
|
||||||
(λ (o v)
|
(λ (o v)
|
||||||
(cond
|
(cond
|
||||||
[(_object? o)
|
[(_object? o)
|
||||||
(setter! o v)]
|
(setter! o v)]
|
||||||
|
[(wrapped-object? o)
|
||||||
|
(setter! (unwrap-object o) v)]
|
||||||
[else
|
[else
|
||||||
(define uw (unwrap-object o))
|
(raise-argument-error 'class-field-mutator "object?" o)]))))))
|
||||||
(if (_object? uw)
|
|
||||||
(setter! uw v)
|
|
||||||
(raise-argument-error 'class-field-mutator "object?" o))])))))))
|
|
||||||
|
|
||||||
(define-struct generic (name applicable))
|
(define-struct generic (name applicable))
|
||||||
|
|
||||||
|
|
@ -3689,7 +3754,7 @@ An example
|
||||||
(define make-generic/proc
|
(define make-generic/proc
|
||||||
(let ([make-generic
|
(let ([make-generic
|
||||||
(lambda (class name)
|
(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))
|
(raise-argument-error 'make-generic "(or/c class? interface?)" class))
|
||||||
(unless (symbol? name)
|
(unless (symbol? name)
|
||||||
(raise-argument-error 'make-generic "symbol?" name))
|
(raise-argument-error 'make-generic "symbol?" name))
|
||||||
|
|
@ -3709,8 +3774,7 @@ An example
|
||||||
"target" obj
|
"target" obj
|
||||||
#:intf-name (interface-name intf)))
|
#:intf-name (interface-name intf)))
|
||||||
(find-method/who 'make-generic obj name)))
|
(find-method/who 'make-generic obj name)))
|
||||||
(let* ([class (unwrap-class class)] ;; TODO: should this do checking?
|
(let* ([pos (hash-ref (class-method-ht class) name
|
||||||
[pos (hash-ref (class-method-ht class) name
|
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(obj-error 'make-generic "no such method"
|
(obj-error 'make-generic "no such method"
|
||||||
"method name" (as-write name)
|
"method name" (as-write name)
|
||||||
|
|
@ -4003,17 +4067,17 @@ An example
|
||||||
|
|
||||||
(define (is-a? v c)
|
(define (is-a? v c)
|
||||||
(cond
|
(cond
|
||||||
[(-class? c)
|
[(class? c)
|
||||||
(and (object? v) ((class-object? (class-orig-cls (unwrap-class c))) (unwrap-object v)))]
|
(and (object? v) ((class-object? (class-orig-cls c)) (unwrap-object v)))]
|
||||||
[(interface? c) (and (object? v) (implementation? (object-ref/unwrap v) c))]
|
[(interface? c) (and (object? v) (implementation? (object-ref/unwrap v) c))]
|
||||||
[else (raise-argument-error 'is-a? "(or/c class? interface?)" 1 v c)]))
|
[else (raise-argument-error 'is-a? "(or/c class? interface?)" 1 v c)]))
|
||||||
|
|
||||||
(define (subclass? v c)
|
(define (subclass? v c)
|
||||||
(unless (-class? c)
|
(unless (class? c)
|
||||||
(raise-argument-error 'subclass? "class?" 1 v c))
|
(raise-argument-error 'subclass? "class?" 1 v c))
|
||||||
(and (-class? v)
|
(and (class? v)
|
||||||
(let* ([c (class-orig-cls (unwrap-class c))]
|
(let* ([c (class-orig-cls c)]
|
||||||
[v (class-orig-cls (unwrap-class v))]
|
[v (class-orig-cls v)]
|
||||||
[p (class-pos c)])
|
[p (class-pos c)])
|
||||||
(and (<= p (class-pos v))
|
(and (<= p (class-pos v))
|
||||||
(eq? c (vector-ref (class-supers v) p))))))
|
(eq? c (vector-ref (class-supers v) p))))))
|
||||||
|
|
@ -4042,8 +4106,8 @@ An example
|
||||||
(define (implementation? v i)
|
(define (implementation? v i)
|
||||||
(unless (interface? i)
|
(unless (interface? i)
|
||||||
(raise-argument-error 'implementation? "interface?" 1 v i))
|
(raise-argument-error 'implementation? "interface?" 1 v i))
|
||||||
(and (-class? v)
|
(and (class? v)
|
||||||
(interface-extension? (class-self-interface (unwrap-class v)) i)))
|
(interface-extension? (class-self-interface v) i)))
|
||||||
|
|
||||||
(define (interface-extension? v i)
|
(define (interface-extension? v i)
|
||||||
(unless (interface? i)
|
(unless (interface? i)
|
||||||
|
|
@ -4059,9 +4123,9 @@ An example
|
||||||
(and (memq s (interface-public-ids i)) #t))
|
(and (memq s (interface-public-ids i)) #t))
|
||||||
|
|
||||||
(define (class->interface c)
|
(define (class->interface c)
|
||||||
(unless (-class? c)
|
(unless (class? c)
|
||||||
(raise-argument-error 'class->interface "class?" c))
|
(raise-argument-error 'class->interface "class?" c))
|
||||||
(class-self-interface (unwrap-class c)))
|
(class-self-interface c))
|
||||||
|
|
||||||
(define (interned? sym)
|
(define (interned? sym)
|
||||||
(eq? sym (string->symbol (symbol->string sym))))
|
(eq? sym (string->symbol (symbol->string sym))))
|
||||||
|
|
@ -4090,10 +4154,9 @@ An example
|
||||||
(string->symbol s)
|
(string->symbol s)
|
||||||
s))
|
s))
|
||||||
|
|
||||||
(define (class-info _c)
|
(define (class-info c)
|
||||||
(unless (-class? _c)
|
(unless (class? c)
|
||||||
(raise-argument-error 'class-info "class?" _c))
|
(raise-argument-error 'class-info "class?" c))
|
||||||
(define c (unwrap-class _c))
|
|
||||||
(if (struct? ((class-insp-mk c)))
|
(if (struct? ((class-insp-mk c)))
|
||||||
(let ([super (vector-ref (class-supers c) (sub1 (class-pos c)))])
|
(let ([super (vector-ref (class-supers c) (sub1 (class-pos c)))])
|
||||||
(let loop ([next super][skipped? #f])
|
(let loop ([next super][skipped? #f])
|
||||||
|
|
@ -4143,9 +4206,15 @@ An example
|
||||||
(raise-argument-error 'object=? "object?" o1))
|
(raise-argument-error 'object=? "object?" o1))
|
||||||
(unless (object? o2)
|
(unless (object? o2)
|
||||||
(raise-argument-error 'object=? "object?" o2))
|
(raise-argument-error 'object=? "object?" o2))
|
||||||
(let ([orig-o1 (if (has-original-object? o1) (original-object o1) o1)]
|
(let* ([orig-o1 (if (has-original-object? o1) (original-object o1) o1)]
|
||||||
[orig-o2 (if (has-original-object? o2) (original-object o2) o2)])
|
[orig-o2 (if (has-original-object? o2) (original-object o2) o2)]
|
||||||
(eq? orig-o1 orig-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
|
;; primitive classes
|
||||||
|
|
@ -4380,7 +4449,7 @@ An example
|
||||||
|
|
||||||
(define (check-mixin-super mixin-name super% from-ids)
|
(define (check-mixin-super mixin-name super% from-ids)
|
||||||
(let ([mixin-name (or mixin-name 'mixin)])
|
(let ([mixin-name (or mixin-name 'mixin)])
|
||||||
(unless (-class? super%)
|
(unless (class? super%)
|
||||||
(obj-error mixin-name
|
(obj-error mixin-name
|
||||||
"argument is not a class"
|
"argument is not a class"
|
||||||
"argument" super%))
|
"argument" super%))
|
||||||
|
|
@ -4530,7 +4599,7 @@ An example
|
||||||
(provide (protect-out get-field/proc)
|
(provide (protect-out get-field/proc)
|
||||||
|
|
||||||
;; for class-c-old.rkt:
|
;; 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
|
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
|
object-ref/unwrap impersonator-prop:original-object has-original-object? original-object
|
||||||
;; end class-c-old.rkt requirements
|
;; end class-c-old.rkt requirements
|
||||||
|
|
@ -4540,7 +4609,7 @@ An example
|
||||||
|
|
||||||
(rename-out [_class class]) class* class/derived
|
(rename-out [_class class]) class* class/derived
|
||||||
define-serializable-class define-serializable-class*
|
define-serializable-class define-serializable-class*
|
||||||
(rename-out [-class? class?])
|
class?
|
||||||
mixin
|
mixin
|
||||||
(rename-out [_interface interface]) interface* interface?
|
(rename-out [_interface interface]) interface* interface?
|
||||||
object% object? object=? externalizable<%> printable<%> writable<%> equal<%>
|
object% object? object=? externalizable<%> printable<%> writable<%> equal<%>
|
||||||
|
|
@ -4569,4 +4638,4 @@ An example
|
||||||
(for-syntax localize)
|
(for-syntax localize)
|
||||||
(except-out (struct-out class) class class?)
|
(except-out (struct-out class) class class?)
|
||||||
(rename-out [class? class-struct-predicate?])
|
(rename-out [class? class-struct-predicate?])
|
||||||
(struct-out wrapped-class) (struct-out wrapped-class-info) (struct-out wrapped-object))
|
(struct-out wrapped-object))
|
||||||
|
|
|
||||||
|
|
@ -1,21 +1,22 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
(provide (struct-out wrapped-class-info)
|
(provide (except-out (struct-out wrapped-class-info) wrapped-class-info?)
|
||||||
(struct-out wrapped-class)
|
|
||||||
(struct-out wrapped-object)
|
(struct-out wrapped-object)
|
||||||
unwrap-class
|
unwrap-object
|
||||||
unwrap-object)
|
|
||||||
|
|
||||||
(struct wrapped-class-info (class blame
|
impersonator-prop:wrapped-class-info
|
||||||
|
impersonator-prop:has-wrapped-class-info?
|
||||||
|
impersonator-prop:get-wrapped-class-info
|
||||||
|
|
||||||
|
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-extra-arg-vec ;; vector that parallels the class's vector of methods
|
||||||
neg-acceptors-ht ;; range of ht has curried (neg-pary -> mth) fns
|
neg-acceptors-ht ;; range of ht has curried (neg-pary -> mth) fns
|
||||||
pos-field-projs neg-field-projs
|
pos-field-projs neg-field-projs
|
||||||
init-proj-pairs)
|
init-proj-pairs)
|
||||||
#:transparent)
|
#: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))
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
(struct wrapped-object (object neg-extra-arg-vec pos-field-projs neg-field-projs neg-party)
|
(struct wrapped-object (object neg-extra-arg-vec pos-field-projs neg-field-projs neg-party)
|
||||||
#:transparent
|
#:transparent
|
||||||
|
|
@ -34,13 +35,17 @@
|
||||||
[else
|
[else
|
||||||
(print v port mode)]))
|
(print v port mode)]))
|
||||||
|
|
||||||
|
|
||||||
(define (unwrap-object o)
|
(define (unwrap-object o)
|
||||||
(cond
|
(cond
|
||||||
[(wrapped-object? o) (wrapped-object-object o)]
|
[(wrapped-object? o) (wrapped-object-object o)]
|
||||||
[else o]))
|
[else o]))
|
||||||
|
|
||||||
(define (unwrap-class cls)
|
(define-values (impersonator-prop:wrapped-class-info
|
||||||
(cond
|
impersonator-prop:has-wrapped-class-info?
|
||||||
[(wrapped-class? cls) (wrapped-class-info-class (wrapped-class-the-info cls))]
|
impersonator-prop:get-wrapped-class-info)
|
||||||
[else cls]))
|
(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