Adjust class/c to use the new strategy for the external
parts of a contract (field, method, init, absent clauses) Still to do: - delay the creation of the class that checks internal contracts until a new derived class is created from a contracted class. - extend the new implementation so it handles interface contracts (currently the old version of the external contracts is still there, just to handle this case) The first of those is what (I hope) will bring down the memory footprint for class/c contracts.
This commit is contained in:
Robby Findler
parent
41fa9dfac9
commit
4f65d57f80
|
|
@ -33,6 +33,13 @@
|
||||||
'pos
|
'pos
|
||||||
'neg))
|
'neg))
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'class/c-first-order-opaque-class-3
|
||||||
|
'(contract (class/c #:opaque m)
|
||||||
|
(class object% (super-new) (define/public (m) 3))
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
|
||||||
(test/pos-blame
|
(test/pos-blame
|
||||||
'class/c-first-order-method-1
|
'class/c-first-order-method-1
|
||||||
'(contract (class/c [m (-> any/c number? number?)])
|
'(contract (class/c [m (-> any/c number? number?)])
|
||||||
|
|
@ -1108,6 +1115,22 @@
|
||||||
[d%/c/c (contract (class/c (init [a number?])) d%/c 'pos 'neg)])
|
[d%/c/c (contract (class/c (init [a number?])) d%/c 'pos 'neg)])
|
||||||
(new d%/c/c [a #t] [a "foo"])))
|
(new d%/c/c [a #t] [a "foo"])))
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'class/c-higher-order-init-9
|
||||||
|
'(let ([c% (contract (class/c (init [a number?]))
|
||||||
|
(class object% (super-new) (init a))
|
||||||
|
'pos
|
||||||
|
'neg)])
|
||||||
|
(make-object c% 3)))
|
||||||
|
|
||||||
|
(test/neg-blame
|
||||||
|
'class/c-higher-order-init-10
|
||||||
|
'(let ([c% (contract (class/c (init [a number?]))
|
||||||
|
(class object% (super-new) (init a))
|
||||||
|
'pos
|
||||||
|
'neg)])
|
||||||
|
(make-object c% #f)))
|
||||||
|
|
||||||
(test/spec-passed
|
(test/spec-passed
|
||||||
'class/c-higher-order-init-field-1
|
'class/c-higher-order-init-field-1
|
||||||
'(let ([c% (contract (class/c (init-field [f (-> number? number?)]))
|
'(let ([c% (contract (class/c (init-field [f (-> number? number?)]))
|
||||||
|
|
@ -2085,6 +2108,44 @@
|
||||||
x)
|
x)
|
||||||
1)
|
1)
|
||||||
|
|
||||||
|
(test/pos-blame
|
||||||
|
'class/c-field-in-class-with-interface-ctc
|
||||||
|
'(get-field f (new (contract (class/c (field [f integer?]))
|
||||||
|
(class* object% ((interface () [m (-> any/c integer?)]))
|
||||||
|
(field [f #f])
|
||||||
|
(define/public (m) 1)
|
||||||
|
(super-new))
|
||||||
|
'pos
|
||||||
|
'neg))))
|
||||||
|
|
||||||
|
(test/pos-blame
|
||||||
|
'class/c-field-in-class-with-interface-ctc2
|
||||||
|
'(new (contract (class/c (field f))
|
||||||
|
(class* object% ((interface () [m (-> any/c integer?)]))
|
||||||
|
(define/public (m) 1)
|
||||||
|
(super-new))
|
||||||
|
'pos
|
||||||
|
'neg)))
|
||||||
|
|
||||||
|
(test/pos-blame
|
||||||
|
'class/c-absent-in-class-with-interface-ctc
|
||||||
|
'(contract (class/c (absent m))
|
||||||
|
(class* object% ((interface () [m (-> any/c integer?)]))
|
||||||
|
(define/public (m) 1)
|
||||||
|
(super-new))
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
|
||||||
|
(test/pos-blame
|
||||||
|
'class/c-absent-in-class-with-interface-ctc
|
||||||
|
'(contract (class/c (absent (field f)))
|
||||||
|
(class* object% ((interface () [m (-> any/c integer?)]))
|
||||||
|
(define/public (m) 1)
|
||||||
|
(field [f 1])
|
||||||
|
(super-new))
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
|
||||||
(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))
|
||||||
(regexp-match? #rx"expected: boolean[?]" (exn-message exn))
|
(regexp-match? #rx"expected: boolean[?]" (exn-message exn))
|
||||||
|
|
|
||||||
|
|
@ -203,8 +203,4 @@
|
||||||
(ctest #t contract-first-order-passes?
|
(ctest #t contract-first-order-passes?
|
||||||
(class/c [m (-> any/c integer? integer?)])
|
(class/c [m (-> any/c integer? integer?)])
|
||||||
(class* object% ((interface () [m (-> any/c integer? integer?)]))
|
(class* object% ((interface () [m (-> any/c integer? integer?)]))
|
||||||
(define/public (m x) x)))
|
(define/public (m x) x))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
|
||||||
|
|
@ -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?)
|
||||||
|
|
|
||||||
|
|
@ -11,126 +11,6 @@
|
||||||
|
|
||||||
(provide class/c2)
|
(provide class/c2)
|
||||||
|
|
||||||
(define-for-syntax (parse-class/c stx)
|
|
||||||
(define (give-up) (values #f #f #f #f #f))
|
|
||||||
(define-values (opaque? args)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ #:opaque args ...)
|
|
||||||
(values #t #'(args ...))]
|
|
||||||
[(_ args ...)
|
|
||||||
(let ()
|
|
||||||
(define stx-args #'(args ...))
|
|
||||||
(define l (syntax->list stx-args))
|
|
||||||
(printf "l ~\n" l)
|
|
||||||
(when (and (pair? l) (keyword? (syntax-e (car l))))
|
|
||||||
(raise-syntax-error #f "unrecognized keyword" stx (car l)))
|
|
||||||
(values #f stx-args))]))
|
|
||||||
(syntax-case args ()
|
|
||||||
[(clauses ...)
|
|
||||||
(let loop ([clauses (syntax->list #'(clauses ...))]
|
|
||||||
[mths '()]
|
|
||||||
[flds '()]
|
|
||||||
[inits '()]
|
|
||||||
[let-bindings '()])
|
|
||||||
(cond
|
|
||||||
[(null? clauses)
|
|
||||||
(values opaque?
|
|
||||||
(reverse mths)
|
|
||||||
(reverse flds)
|
|
||||||
(reverse inits)
|
|
||||||
(reverse let-bindings))]
|
|
||||||
[else
|
|
||||||
(syntax-case (car clauses) (field inherit inherit-field init init-field super inner
|
|
||||||
override augment augride absent)
|
|
||||||
[(super . x) (give-up)]
|
|
||||||
[(inner . x) (give-up)]
|
|
||||||
[(override . x) (give-up)]
|
|
||||||
[(augment . x) (give-up)]
|
|
||||||
[(augride . x) (give-up)]
|
|
||||||
[(absent . x) (give-up)]
|
|
||||||
[(inherit . x) (give-up)]
|
|
||||||
[(inherit-field . x) (give-up)]
|
|
||||||
[(field x ...) (give-up)]
|
|
||||||
[(init x ...)
|
|
||||||
(let ()
|
|
||||||
(define new-let-bindings let-bindings)
|
|
||||||
(define new-inits '())
|
|
||||||
(for ([clause (in-list (syntax->list #'(x ...)))])
|
|
||||||
(syntax-case clause ()
|
|
||||||
[(id ctc)
|
|
||||||
(with-syntax ([(x) (generate-temporaries #'(id))])
|
|
||||||
(set! new-let-bindings (cons #`[x ctc] new-let-bindings))
|
|
||||||
(set! new-inits (cons #`[id x] new-inits)))]
|
|
||||||
[id
|
|
||||||
(identifier? #'id)
|
|
||||||
(begin
|
|
||||||
(set! new-inits (cons #`[id just-check-existence] new-inits)))]
|
|
||||||
[_
|
|
||||||
(raise-syntax-error 'class/c "expected a field-spec" stx clause)]))
|
|
||||||
(loop (cdr clauses)
|
|
||||||
mths flds (append new-inits inits) new-let-bindings))]
|
|
||||||
[(init-field x ...)
|
|
||||||
(let ()
|
|
||||||
(define new-let-bindings let-bindings)
|
|
||||||
(define clauses '())
|
|
||||||
(for ([cl (in-list (syntax->list #'(x ...)))])
|
|
||||||
(syntax-case cl ()
|
|
||||||
[(id ctc)
|
|
||||||
(identifier? #'id)
|
|
||||||
(with-syntax ([(x) (generate-temporaries (list #'id))])
|
|
||||||
(set! new-let-bindings (cons #`[x ctc] new-let-bindings))
|
|
||||||
(set! clauses (cons #'[id x] clauses)))]
|
|
||||||
[id
|
|
||||||
(identifier? #'id)
|
|
||||||
(begin
|
|
||||||
(set! clauses (cons #'[id just-check-existence] clauses)))]
|
|
||||||
[_
|
|
||||||
(raise-syntax-error 'class/c "expected a field-spec" stx cl)]))
|
|
||||||
(loop (cdr clauses) mths (append clauses flds) (append clauses inits)
|
|
||||||
new-let-bindings))]
|
|
||||||
|
|
||||||
[x (identifier? #'x)
|
|
||||||
(loop (cdr clauses)
|
|
||||||
(cons #`[#,(car clauses) just-check-existence] mths)
|
|
||||||
flds inits let-bindings)]
|
|
||||||
[[mth ctc]
|
|
||||||
(identifier? #'mth)
|
|
||||||
(with-syntax ([(x) (generate-temporaries #'(mth))])
|
|
||||||
(loop (cdr clauses)
|
|
||||||
(cons #`[mth x] mths)
|
|
||||||
flds
|
|
||||||
inits
|
|
||||||
(cons #`[x ctc] let-bindings)))]
|
|
||||||
[else (give-up)])]))]))
|
|
||||||
|
|
||||||
#;
|
|
||||||
(define-syntax (class/c2 stx)
|
|
||||||
(define-values (opaque? mths flds inits let-bindings) (parse-class/c stx))
|
|
||||||
(cond
|
|
||||||
[(and mths (null? flds))
|
|
||||||
(syntax-case (list mths inits) ()
|
|
||||||
[(((mth-name mth-ctc) ...)
|
|
||||||
((init-name init-ctc) ...))
|
|
||||||
;(printf " yup: ~a:~a\n" (syntax-source stx) (syntax-line stx))
|
|
||||||
(with-syntax ([(lmth-name ...) (for/list ([m (in-list (syntax->list #'(mth-name ...)))])
|
|
||||||
(localize m))]
|
|
||||||
[name (syntax-local-infer-name stx)])
|
|
||||||
;#'(class/c [m ctc] ...)
|
|
||||||
#`(let #,let-bindings
|
|
||||||
(make-an-ext-class/c-contract '#,opaque?
|
|
||||||
(list `lmth-name ...)
|
|
||||||
(list mth-ctc ...)
|
|
||||||
'() '()
|
|
||||||
(list 'init-name ...)
|
|
||||||
(list init-ctc ...)
|
|
||||||
'name
|
|
||||||
empty-internal/c)))])]
|
|
||||||
[else
|
|
||||||
;(printf "nope: ~a:~a\n" (syntax-source stx) (syntax-line stx))
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ args ...)
|
|
||||||
#'(class/c args ...)])]))
|
|
||||||
|
|
||||||
(define-syntax (class/c2 stx)
|
(define-syntax (class/c2 stx)
|
||||||
(define-values (opaque? args)
|
(define-values (opaque? args)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
|
|
@ -143,7 +23,6 @@
|
||||||
(raise-syntax-error #f "unrecognized keyword" stx (car stx-args)))
|
(raise-syntax-error #f "unrecognized keyword" stx (car stx-args)))
|
||||||
(values #f stx-args))]))
|
(values #f stx-args))]))
|
||||||
(define-values (bindings pfs) (parse-class/c-specs args #f))
|
(define-values (bindings pfs) (parse-class/c-specs args #f))
|
||||||
(printf ">> ~s ~s\n" bindings (hash-ref pfs 'methods null))
|
|
||||||
(with-syntax ([methods #`(list #,@(reverse (hash-ref pfs 'methods null)))]
|
(with-syntax ([methods #`(list #,@(reverse (hash-ref pfs 'methods null)))]
|
||||||
[method-ctcs #`(list #,@(reverse (hash-ref pfs 'method-contracts null)))]
|
[method-ctcs #`(list #,@(reverse (hash-ref pfs 'method-contracts null)))]
|
||||||
[fields #`(list #,@(reverse (hash-ref pfs 'fields null)))]
|
[fields #`(list #,@(reverse (hash-ref pfs 'fields null)))]
|
||||||
|
|
@ -182,22 +61,23 @@
|
||||||
[opaque? opaque?])
|
[opaque? opaque?])
|
||||||
(syntax/loc stx
|
(syntax/loc stx
|
||||||
(let bindings
|
(let bindings
|
||||||
; (let-values ([(inits init-ctcs) (sort-inits+contracts (list (cons i i-c) ...))])
|
(make-an-ext-class/c-contract
|
||||||
(make-an-ext-class/c-contract
|
'opaque?
|
||||||
'opaque?
|
methods method-ctcs
|
||||||
methods method-ctcs
|
fields field-ctcs
|
||||||
fields field-ctcs
|
(list i ...)
|
||||||
(list 'i ...)
|
(list i-c ...)
|
||||||
(list i-c ...)
|
absents
|
||||||
'name
|
absent-fields
|
||||||
(internal-class/c
|
'name
|
||||||
inherits inherit-ctcs
|
(build-internal-class/c
|
||||||
inherit-fields inherit-field-ctcs
|
inherits inherit-ctcs
|
||||||
supers super-ctcs
|
inherit-fields inherit-field-ctcs
|
||||||
inners inner-ctcs
|
supers super-ctcs
|
||||||
overrides override-ctcs
|
inners inner-ctcs
|
||||||
augments augment-ctcs
|
overrides override-ctcs
|
||||||
augrides augride-ctcs)))))))
|
augments augment-ctcs
|
||||||
|
augrides augride-ctcs)))))))
|
||||||
|
|
||||||
(define (class/c2-proj this)
|
(define (class/c2-proj this)
|
||||||
(λ (blame)
|
(λ (blame)
|
||||||
|
|
@ -224,13 +104,23 @@
|
||||||
(if (just-check-existence? ctc)
|
(if (just-check-existence? ctc)
|
||||||
any/c
|
any/c
|
||||||
ctc))))
|
ctc))))
|
||||||
|
|
||||||
|
(define fields
|
||||||
|
(for/list ([(fld ctc) (in-hash (ext-class/c-contract-table-of-flds-to-ctcs this))])
|
||||||
|
fld))
|
||||||
|
(define field-ctcs
|
||||||
|
(for/list ([(fld ctc) (in-hash (ext-class/c-contract-table-of-flds-to-ctcs this))])
|
||||||
|
(if (just-check-existence? ctc)
|
||||||
|
#f
|
||||||
|
ctc)))
|
||||||
|
|
||||||
(define ctc
|
(define ctc
|
||||||
(make-class/c
|
(make-class/c
|
||||||
;; methods
|
;; methods
|
||||||
(map car mth-lst)
|
(map car mth-lst)
|
||||||
(map cdr mth-lst)
|
(map cdr mth-lst)
|
||||||
|
|
||||||
'() '() ;; fields
|
fields field-ctcs
|
||||||
|
|
||||||
;; inits
|
;; inits
|
||||||
(map (λ (x) (list-ref x 0)) (ext-class/c-contract-init-ctc-pairs this))
|
(map (λ (x) (list-ref x 0)) (ext-class/c-contract-init-ctc-pairs this))
|
||||||
|
|
@ -241,14 +131,17 @@
|
||||||
ctc))
|
ctc))
|
||||||
(ext-class/c-contract-init-ctc-pairs this))
|
(ext-class/c-contract-init-ctc-pairs this))
|
||||||
|
|
||||||
'() '() ;; absent
|
(ext-class/c-contract-absent-methods this)
|
||||||
empty-internal-class/c
|
(ext-class/c-contract-absent-fields this)
|
||||||
#f ;; opaque?
|
|
||||||
#f ;; name
|
(ext-class/c-contract-internal-ctc this)
|
||||||
))
|
(ext-class/c-contract-opaque? this)
|
||||||
|
(ext-class/c-contract-name this)))
|
||||||
(λ (neg-party)
|
(λ (neg-party)
|
||||||
(((class/c-proj ctc) (blame-add-missing-party blame neg-party)) cls))]
|
(((class/c-proj ctc) (blame-add-missing-party blame neg-party)) cls))]
|
||||||
[else (build-neg-acceptor-proc this maybe-err blame cls (make-hash) '())])]
|
[else
|
||||||
|
(build-neg-acceptor-proc this maybe-err blame cls (make-hash) '()
|
||||||
|
(make-hasheq) (make-hasheq))])]
|
||||||
[(wrapped-class? cls)
|
[(wrapped-class? cls)
|
||||||
(define neg-acceptors-ht
|
(define neg-acceptors-ht
|
||||||
(wrapped-class-info-neg-acceptors-ht (wrapped-class-the-info cls)))
|
(wrapped-class-info-neg-acceptors-ht (wrapped-class-the-info cls)))
|
||||||
|
|
@ -266,7 +159,9 @@
|
||||||
(build-neg-acceptor-proc this maybe-err blame
|
(build-neg-acceptor-proc this maybe-err blame
|
||||||
(wrapped-class-info-class the-info)
|
(wrapped-class-info-class the-info)
|
||||||
new-mths-ht
|
new-mths-ht
|
||||||
fixed-neg-init-projs)]
|
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)
|
||||||
|
|
@ -274,20 +169,13 @@
|
||||||
blame #:missing-party neg-party cls
|
blame #:missing-party neg-party cls
|
||||||
'(expected: "a class"))))])))))
|
'(expected: "a class"))))])))))
|
||||||
|
|
||||||
(define empty-internal-class/c
|
(define (build-neg-acceptor-proc this maybe-err blame cls new-mths-ht old-init-pairs
|
||||||
(internal-class/c
|
old-pos-fld-ht old-neg-fld-ht)
|
||||||
'() '() ;; inherit
|
|
||||||
'() '() ;; inherit fields
|
|
||||||
'() '() ;; super
|
|
||||||
'() '() ;; inner
|
|
||||||
'() '() ;; override
|
|
||||||
'() '() ;; augment
|
|
||||||
'() '())) ;; augride
|
|
||||||
|
|
||||||
(define (build-neg-acceptor-proc this maybe-err blame cls new-mths-ht old-init-pairs)
|
|
||||||
(define mth->idx (class-method-ht cls))
|
(define mth->idx (class-method-ht cls))
|
||||||
(define mtd-vec (class-methods cls))
|
(define mtd-vec (class-methods cls))
|
||||||
|
|
||||||
|
(define internal-proj (internal-class/c-proj (ext-class/c-contract-internal-ctc this)))
|
||||||
|
|
||||||
(define (get-unwrapped-method name)
|
(define (get-unwrapped-method name)
|
||||||
(cond
|
(cond
|
||||||
[(hash-ref new-mths-ht name #f) => values]
|
[(hash-ref new-mths-ht name #f) => values]
|
||||||
|
|
@ -299,6 +187,9 @@
|
||||||
(define neg-extra-arg-ht (make-hash))
|
(define neg-extra-arg-ht (make-hash))
|
||||||
(define neg-acceptors-ht (make-hash))
|
(define neg-acceptors-ht (make-hash))
|
||||||
|
|
||||||
|
(define pos-field-projs (hash-copy old-pos-fld-ht))
|
||||||
|
(define neg-field-projs (hash-copy old-neg-fld-ht))
|
||||||
|
|
||||||
(define (generic-wrapper mth)
|
(define (generic-wrapper mth)
|
||||||
(define raw-proc (get-unwrapped-method mth))
|
(define raw-proc (get-unwrapped-method mth))
|
||||||
(make-keyword-procedure
|
(make-keyword-procedure
|
||||||
|
|
@ -322,7 +213,7 @@
|
||||||
;; if we just check the method's existence,
|
;; if we just check the method's existence,
|
||||||
;; then make an inefficient wrapper for it
|
;; then make an inefficient wrapper for it
|
||||||
;; that discards the neg-party argument
|
;; that discards the neg-party argument
|
||||||
(generic-wrapper mth)]
|
(hash-set! neg-extra-arg-ht mth (generic-wrapper mth))]
|
||||||
[else
|
[else
|
||||||
(define w/blame (proj (blame-add-method-context blame mth)))
|
(define w/blame (proj (blame-add-method-context blame mth)))
|
||||||
(define projd-mth (w/blame m-mth))
|
(define projd-mth (w/blame m-mth))
|
||||||
|
|
@ -341,7 +232,16 @@
|
||||||
(apply (projd-mth neg-party) args)))]))
|
(apply (projd-mth neg-party) args)))]))
|
||||||
(hash-set! neg-extra-arg-ht mth neg-acceptor)]))
|
(hash-set! neg-extra-arg-ht mth neg-acceptor)]))
|
||||||
|
|
||||||
|
(define absent-methods (ext-class/c-contract-absent-methods this))
|
||||||
(for ([(mth _) (in-hash mth->idx)])
|
(for ([(mth _) (in-hash mth->idx)])
|
||||||
|
(when (member mth absent-methods)
|
||||||
|
(maybe-err
|
||||||
|
(λ (neg-party)
|
||||||
|
(raise-blame-error
|
||||||
|
blame #:missing-party neg-party cls
|
||||||
|
'(expected: "a class that does not have the method ~a")
|
||||||
|
mth))))
|
||||||
|
|
||||||
;; use a generic wrapper to drop the neg-party argument, which means
|
;; use a generic wrapper to drop the neg-party argument, which means
|
||||||
;; methods without explicit contracts are going to be slow
|
;; methods without explicit contracts are going to be slow
|
||||||
(unless (hash-ref neg-extra-arg-ht mth #f)
|
(unless (hash-ref neg-extra-arg-ht mth #f)
|
||||||
|
|
@ -353,7 +253,7 @@
|
||||||
(format " ~a" mth)))
|
(format " ~a" mth)))
|
||||||
(raise-blame-error
|
(raise-blame-error
|
||||||
blame #:missing-party neg-party cls
|
blame #:missing-party neg-party cls
|
||||||
'(expected: "~a" given: "a class that has a method ~a")
|
'(expected: "~a" given: "a class that has a method: ~a")
|
||||||
(cond
|
(cond
|
||||||
[(null? mth-names) "a class with no methods"]
|
[(null? mth-names) "a class with no methods"]
|
||||||
[(null? (cdr mth-names))
|
[(null? (cdr mth-names))
|
||||||
|
|
@ -363,6 +263,58 @@
|
||||||
(apply string-append mth-names))])
|
(apply string-append mth-names))])
|
||||||
mth)))
|
mth)))
|
||||||
(hash-set! neg-extra-arg-ht mth (generic-wrapper mth)))))
|
(hash-set! neg-extra-arg-ht mth (generic-wrapper mth)))))
|
||||||
|
|
||||||
|
(for ([(fld proj) (in-hash (ext-class/c-contract-table-of-flds-to-projs this))])
|
||||||
|
(define field-ht (class-field-ht cls))
|
||||||
|
(define fi (hash-ref field-ht fld #f))
|
||||||
|
(unless fi
|
||||||
|
(maybe-err
|
||||||
|
(λ (neg-party)
|
||||||
|
(raise-blame-error
|
||||||
|
blame #:missing-party neg-party cls
|
||||||
|
'(expected: "a class with a public field named ~a")
|
||||||
|
fld))))
|
||||||
|
|
||||||
|
(unless (just-check-existence? proj)
|
||||||
|
(define (update-ht field-projs field-info-internal-ref/set! swap?)
|
||||||
|
(define prior (hash-ref field-projs fld (λ () (field-info-internal-ref/set! fi))))
|
||||||
|
(define w-blame (proj (blame-add-field-context blame proj #:swap? swap?)))
|
||||||
|
(hash-set! field-projs fld (cons w-blame prior)))
|
||||||
|
(update-ht pos-field-projs field-info-internal-ref #f)
|
||||||
|
(update-ht neg-field-projs field-info-internal-set! #t)))
|
||||||
|
|
||||||
|
(define absent-fields (ext-class/c-contract-absent-fields this))
|
||||||
|
(unless (null? absent-fields)
|
||||||
|
(for ([(fld proj) (in-hash (class-field-ht cls))])
|
||||||
|
(when (member fld absent-fields)
|
||||||
|
(maybe-err
|
||||||
|
(λ (neg-party)
|
||||||
|
(raise-blame-error
|
||||||
|
blame #:missing-party neg-party cls
|
||||||
|
'(expected: "a class that does not have the field ~a")
|
||||||
|
fld))))))
|
||||||
|
|
||||||
|
(when (ext-class/c-contract-opaque? this)
|
||||||
|
(define allowed-flds (ext-class/c-contract-table-of-flds-to-projs this))
|
||||||
|
(for ([(fld proj) (in-hash (class-field-ht cls))])
|
||||||
|
(unless (hash-ref allowed-flds fld #f)
|
||||||
|
(maybe-err
|
||||||
|
(λ (neg-party)
|
||||||
|
(define fld-names
|
||||||
|
(for/list ([(fld proj) (in-hash allowed-flds)])
|
||||||
|
(format " ~a" fld)))
|
||||||
|
(raise-blame-error
|
||||||
|
blame #:missing-party neg-party cls
|
||||||
|
'(expected: "~a" given: "a class that has the field: ~a")
|
||||||
|
(cond
|
||||||
|
[(null? fld-names) "a class with no fields"]
|
||||||
|
[(null? (cdr fld-names))
|
||||||
|
(format "a class with only one field:~a" (car fld-names))]
|
||||||
|
[else
|
||||||
|
(format "a class with only the fields:~a"
|
||||||
|
(apply string-append fld-names))])
|
||||||
|
fld))))))
|
||||||
|
|
||||||
(define new-init-projs
|
(define new-init-projs
|
||||||
(for/list ([ctc-pair (in-list (ext-class/c-contract-init-ctc-pairs this))])
|
(for/list ([ctc-pair (in-list (ext-class/c-contract-init-ctc-pairs this))])
|
||||||
(define ctc (list-ref ctc-pair 1))
|
(define ctc (list-ref ctc-pair 1))
|
||||||
|
|
@ -374,14 +326,28 @@
|
||||||
(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-ht neg-acceptors-ht
|
(define the-info (wrapped-class-info cls blame neg-extra-arg-ht neg-acceptors-ht
|
||||||
|
pos-field-projs neg-field-projs
|
||||||
merged-init-pairs))
|
merged-init-pairs))
|
||||||
|
|
||||||
(λ (neg-party)
|
(λ (neg-party)
|
||||||
;; run this for the side-effect of
|
;; run this for the side-effect of
|
||||||
;; checking that first-order tests on
|
;; checking that first-order tests on
|
||||||
;; methods (arity, etc) all pass
|
;; methods (arity, etc) all pass
|
||||||
(for ([(mth neg-party-acceptor) (in-hash neg-acceptors-ht)])
|
(for ([(mth neg-party-acceptor) (in-hash neg-acceptors-ht)])
|
||||||
(neg-party-acceptor neg-party))
|
(neg-party-acceptor neg-party))
|
||||||
(wrapped-class the-info neg-party)))
|
|
||||||
|
;; XXX: we have to not do this;
|
||||||
|
;; (instead we should use just the-info)
|
||||||
|
;; 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)]))
|
||||||
|
|
||||||
|
(wrapped-class the-info/adjusted-cls neg-party)))
|
||||||
|
|
||||||
(define (merge-init-pairs old-init-pairs new-init-pairs)
|
(define (merge-init-pairs old-init-pairs new-init-pairs)
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -410,32 +376,42 @@
|
||||||
mth-names mth-ctcs
|
mth-names mth-ctcs
|
||||||
fld-names fld-ctcs
|
fld-names fld-ctcs
|
||||||
init-names init-ctcs
|
init-names init-ctcs
|
||||||
|
absent-methods absent-fields
|
||||||
ctc-name internal-ctc)
|
ctc-name internal-ctc)
|
||||||
(define ctc-hash
|
(define (build-a-ctc-table names ctcs)
|
||||||
(make-hash (for/list ([raw-ctc (in-list mth-ctcs)]
|
(make-hash (for/list ([raw-ctc (in-list ctcs)]
|
||||||
[name (in-list mth-names)])
|
[name (in-list names)])
|
||||||
(define ctc (if (just-check-existence? raw-ctc)
|
(define ctc (if (just-check-existence? raw-ctc)
|
||||||
raw-ctc
|
raw-ctc
|
||||||
(coerce-contract 'class/c raw-ctc)))
|
(coerce-contract 'class/c raw-ctc)))
|
||||||
(cons name ctc))))
|
(cons name ctc))))
|
||||||
|
(define (build-a-proj-table hash names)
|
||||||
|
(make-hash
|
||||||
|
(for/list ([name (in-list names)])
|
||||||
|
(define ctc (hash-ref hash name))
|
||||||
|
(cond
|
||||||
|
[(just-check-existence? ctc)
|
||||||
|
(cons name ctc)]
|
||||||
|
[else
|
||||||
|
(define proj (get/build-val-first-projection ctc))
|
||||||
|
(cons name proj)]))))
|
||||||
|
(define mth-ctc-hash (build-a-ctc-table mth-names mth-ctcs))
|
||||||
|
(define fld-ctc-hash (build-a-ctc-table fld-names fld-ctcs))
|
||||||
|
(define mth-proj-hash (build-a-proj-table mth-ctc-hash mth-names))
|
||||||
|
(define fld-proj-hash (build-a-proj-table fld-ctc-hash fld-names))
|
||||||
(ext-class/c-contract
|
(ext-class/c-contract
|
||||||
opaque?
|
opaque?
|
||||||
ctc-hash
|
mth-ctc-hash mth-proj-hash
|
||||||
(make-hash (for/list ([name (in-list mth-names)])
|
fld-ctc-hash fld-proj-hash
|
||||||
(define ctc (hash-ref ctc-hash name))
|
|
||||||
(cond
|
|
||||||
[(just-check-existence? ctc)
|
|
||||||
(cons name ctc)]
|
|
||||||
[else
|
|
||||||
(define proj (get/build-val-first-projection ctc))
|
|
||||||
(cons name proj)])))
|
|
||||||
(for/list ([name (in-list init-names)]
|
(for/list ([name (in-list init-names)]
|
||||||
[ctc (in-list init-ctcs)])
|
[ctc (in-list init-ctcs)])
|
||||||
(list name
|
(list name
|
||||||
(if (just-check-existence? ctc)
|
(if (just-check-existence? ctc)
|
||||||
ctc
|
ctc
|
||||||
(coerce-contract 'class/c ctc))))
|
(coerce-contract 'class/c ctc))))
|
||||||
ctc-name))
|
absent-methods absent-fields
|
||||||
|
ctc-name
|
||||||
|
internal-ctc))
|
||||||
|
|
||||||
(define (class/c-first-order-passes? ctc cls)
|
(define (class/c-first-order-passes? ctc cls)
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -444,15 +420,26 @@
|
||||||
(define mtd-vec (class-methods cls))
|
(define mtd-vec (class-methods cls))
|
||||||
(for/and ([(name ctc) (in-hash (ext-class/c-contract-table-of-meths-to-ctcs ctc))])
|
(for/and ([(name ctc) (in-hash (ext-class/c-contract-table-of-meths-to-ctcs ctc))])
|
||||||
(define mth-idx (hash-ref mth->idx name #f))
|
(define mth-idx (hash-ref mth->idx name #f))
|
||||||
(and mth-idx
|
(cond
|
||||||
(contract-first-order-passes? ctc (vector-ref mtd-vec mth-idx))))]
|
[mth-idx
|
||||||
|
(define mth-record (vector-ref mtd-vec mth-idx))
|
||||||
|
(contract-first-order-passes?
|
||||||
|
ctc
|
||||||
|
(if (pair? mth-record)
|
||||||
|
(car mth-record)
|
||||||
|
mth-record))]
|
||||||
|
[else #f]))]
|
||||||
[else #f]))
|
[else #f]))
|
||||||
|
|
||||||
(struct ext-class/c-contract (opaque?
|
(struct ext-class/c-contract (opaque?
|
||||||
table-of-meths-to-ctcs
|
table-of-meths-to-ctcs
|
||||||
table-of-meths-to-projs
|
table-of-meths-to-projs
|
||||||
|
table-of-flds-to-ctcs
|
||||||
|
table-of-flds-to-projs
|
||||||
init-ctc-pairs
|
init-ctc-pairs
|
||||||
name)
|
absent-methods absent-fields
|
||||||
|
name
|
||||||
|
internal-ctc)
|
||||||
#:property prop:contract
|
#:property prop:contract
|
||||||
(build-contract-property
|
(build-contract-property
|
||||||
#:projection
|
#:projection
|
||||||
|
|
|
||||||
|
|
@ -9,13 +9,14 @@
|
||||||
(only-in "../contract/private/arrow.rkt" making-a-method method-contract?))
|
(only-in "../contract/private/arrow.rkt" making-a-method method-contract?))
|
||||||
|
|
||||||
(provide make-class/c class/c-proj
|
(provide make-class/c class/c-proj
|
||||||
blame-add-method-context blame-add-init-context
|
blame-add-method-context blame-add-field-context blame-add-init-context
|
||||||
class/c ->m ->*m ->dm case->m object/c instanceof/c
|
class/c ->m ->*m ->dm case->m object/c instanceof/c
|
||||||
make-wrapper-object
|
make-wrapper-object
|
||||||
check-object-contract
|
check-object-contract
|
||||||
(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)
|
||||||
|
|
||||||
(define undefined (letrec ([x x]) x))
|
(define undefined (letrec ([x x]) x))
|
||||||
|
|
||||||
|
|
@ -153,7 +154,6 @@
|
||||||
(define (class/c-external-proj ctc)
|
(define (class/c-external-proj ctc)
|
||||||
(define ctc-methods (class/c-methods ctc))
|
(define ctc-methods (class/c-methods ctc))
|
||||||
(λ (blame)
|
(λ (blame)
|
||||||
(define bswap (blame-swap blame))
|
|
||||||
(define public-method-projections
|
(define public-method-projections
|
||||||
(for/list ([name (in-list ctc-methods)]
|
(for/list ([name (in-list ctc-methods)]
|
||||||
[c (in-list (class/c-method-contracts ctc))])
|
[c (in-list (class/c-method-contracts ctc))])
|
||||||
|
|
@ -165,9 +165,9 @@
|
||||||
[c (in-list (class/c-field-contracts ctc))])
|
[c (in-list (class/c-field-contracts ctc))])
|
||||||
(and c
|
(and c
|
||||||
(let ([p-pos ((contract-projection c)
|
(let ([p-pos ((contract-projection c)
|
||||||
(blame-add-context blame (format "the ~a field in" f)))]
|
(blame-add-field-context blame f #:swap? #f))]
|
||||||
[p-neg ((contract-projection c)
|
[p-neg ((contract-projection c)
|
||||||
(blame-add-context bswap (format "the ~a field in" f)))])
|
(blame-add-field-context blame f #:swap? #t))])
|
||||||
(cons p-pos p-neg)))))
|
(cons p-pos p-neg)))))
|
||||||
|
|
||||||
;; zip the inits and contracts together for ordered selection
|
;; zip the inits and contracts together for ordered selection
|
||||||
|
|
@ -307,7 +307,7 @@
|
||||||
(define mp (vector-ref methods i))
|
(define mp (vector-ref methods i))
|
||||||
(vector-set! methods i (make-method (p mp) m)))))
|
(vector-set! methods i (make-method (p mp) m)))))
|
||||||
|
|
||||||
;; Handle both external field contracts
|
;; Handle external field contracts
|
||||||
(unless no-field-ctcs?
|
(unless no-field-ctcs?
|
||||||
(for ([f (in-list (class/c-fields ctc))]
|
(for ([f (in-list (class/c-fields ctc))]
|
||||||
[p-pr (in-list external-field-projections)])
|
[p-pr (in-list external-field-projections)])
|
||||||
|
|
@ -724,6 +724,9 @@
|
||||||
(blame-add-context blame "an unnamed method in")]
|
(blame-add-context blame "an unnamed method in")]
|
||||||
[else (error 'blame-add-method-context "uhoh ~s" name)]))
|
[else (error 'blame-add-method-context "uhoh ~s" name)]))
|
||||||
|
|
||||||
|
(define (blame-add-field-context blame f #:swap? swap?)
|
||||||
|
(blame-add-context blame (format "the ~a field in" f) #:swap? swap?))
|
||||||
|
|
||||||
(define (build-internal-class/c inherits inherit-contracts inherit-fields inherit-field-contracts
|
(define (build-internal-class/c inherits inherit-contracts inherit-fields inherit-field-contracts
|
||||||
supers super-contracts inners inner-contracts
|
supers super-contracts inners inner-contracts
|
||||||
overrides override-contracts augments augment-contracts
|
overrides override-contracts augments augment-contracts
|
||||||
|
|
@ -1161,9 +1164,12 @@
|
||||||
(define new-cls (p (object-ref val)))
|
(define new-cls (p (object-ref val)))
|
||||||
(cond
|
(cond
|
||||||
[(wrapped-class? new-cls)
|
[(wrapped-class? new-cls)
|
||||||
|
(define the-info (wrapped-class-the-info new-cls))
|
||||||
(wrapped-object
|
(wrapped-object
|
||||||
val
|
val
|
||||||
(wrapped-class-info-neg-extra-arg-ht (wrapped-class-the-info new-cls))
|
(wrapped-class-info-neg-extra-arg-ht the-info)
|
||||||
|
(wrapped-class-info-pos-field-projs the-info)
|
||||||
|
(wrapped-class-info-neg-field-projs the-info)
|
||||||
(wrapped-class-neg-party new-cls))]
|
(wrapped-class-neg-party new-cls))]
|
||||||
[else
|
[else
|
||||||
(impersonate-struct val object-ref (λ (o c) new-cls)
|
(impersonate-struct val object-ref (λ (o c) new-cls)
|
||||||
|
|
@ -1303,11 +1309,9 @@
|
||||||
(for ([f (in-list fields)]
|
(for ([f (in-list fields)]
|
||||||
[c (in-list field-contracts)])
|
[c (in-list field-contracts)])
|
||||||
(when c
|
(when c
|
||||||
(define fld-context (format "the ~a field in" f))
|
(define fi (hash-ref field-ht f))
|
||||||
(define bset (blame-add-context blame fld-context #:swap? #t))
|
(define p-pos ((contract-projection c) (blame-add-field-context blame f #:swap? #f)))
|
||||||
(let ([fi (hash-ref field-ht f)]
|
(define p-neg ((contract-projection c) (blame-add-field-context blame f #:swap? #t)))
|
||||||
[p-pos ((contract-projection c) (blame-add-context blame fld-context))]
|
(hash-set! field-ht f (field-info-extend-external fi p-pos p-neg)))))
|
||||||
[p-neg ((contract-projection c) bset)])
|
|
||||||
(hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))))
|
|
||||||
|
|
||||||
c))
|
c))
|
||||||
|
|
|
||||||
|
|
@ -3241,6 +3241,8 @@ An example
|
||||||
(wrapped-object
|
(wrapped-object
|
||||||
unwrapped-o
|
unwrapped-o
|
||||||
(wrapped-class-info-neg-extra-arg-ht the-info)
|
(wrapped-class-info-neg-extra-arg-ht the-info)
|
||||||
|
(wrapped-class-info-pos-field-projs the-info)
|
||||||
|
(wrapped-class-info-neg-field-projs the-info)
|
||||||
(wrapped-class-neg-party class))]
|
(wrapped-class-neg-party class))]
|
||||||
[else
|
[else
|
||||||
(raise-argument-error 'instantiate "class?" class)]))
|
(raise-argument-error 'instantiate "class?" class)]))
|
||||||
|
|
@ -3763,22 +3765,43 @@ An example
|
||||||
(do-set-field! 'set-field! id obj val))
|
(do-set-field! 'set-field! id obj val))
|
||||||
|
|
||||||
(define (do-set-field! who id obj val)
|
(define (do-set-field! who id obj val)
|
||||||
(unless (object? obj)
|
(cond
|
||||||
(raise-argument-error who
|
[(_object? obj)
|
||||||
"object?"
|
(do-set-field!/raw-object who id obj val)]
|
||||||
obj))
|
[(wrapped-object? obj)
|
||||||
(let* ([cls (object-ref/unwrap obj)]
|
(define projs+set! (hash-ref (wrapped-object-neg-field-projs obj) id #f))
|
||||||
[field-ht (class-field-ht cls)]
|
(cond
|
||||||
[fi (hash-ref field-ht id #f)])
|
[projs+set!
|
||||||
(if fi
|
(define np (wrapped-object-neg-party obj))
|
||||||
((field-info-external-set! fi) obj val)
|
(let loop ([projs+set! projs+set!]
|
||||||
(obj-error who
|
[val val])
|
||||||
"given object does not have the requested field"
|
(cond
|
||||||
"field name" (as-write id)
|
[(pair? projs+set!)
|
||||||
"object" obj))))
|
(define the-proj (car projs+set!))
|
||||||
|
(loop (cdr projs+set!)
|
||||||
|
((the-proj val) np))]
|
||||||
|
[else
|
||||||
|
(projs+set! (wrapped-object-object obj) val)]))]
|
||||||
|
[else
|
||||||
|
(do-field-get/raw-object who id (wrapped-object-object obj))])]
|
||||||
|
[else
|
||||||
|
(raise-argument-error who
|
||||||
|
"object?"
|
||||||
|
obj)]))
|
||||||
|
|
||||||
|
(define (do-set-field!/raw-object who id obj val)
|
||||||
|
(define cls (object-ref obj))
|
||||||
|
(define field-ht (class-field-ht cls))
|
||||||
|
(define fi (hash-ref field-ht id #f))
|
||||||
|
(if fi
|
||||||
|
((field-info-external-set! fi) obj val)
|
||||||
|
(obj-error who
|
||||||
|
"given object does not have the requested field"
|
||||||
|
"field name" (as-write id)
|
||||||
|
"object" obj)))
|
||||||
|
|
||||||
(define (dynamic-set-field! id obj val)
|
(define (dynamic-set-field! id obj val)
|
||||||
(unless (symbol? id) (raise-argument-error 'dynamic-get-field "symbol?" id))
|
(unless (symbol? id) (raise-argument-error 'dynamic-set-field! "symbol?" id))
|
||||||
(do-set-field! 'dynamic-set-field! id obj val))
|
(do-set-field! 'dynamic-set-field! id obj val))
|
||||||
|
|
||||||
(define-syntax (get-field stx)
|
(define-syntax (get-field stx)
|
||||||
|
|
@ -3796,19 +3819,40 @@ An example
|
||||||
(do-get-field 'get-field id obj))
|
(do-get-field 'get-field id obj))
|
||||||
|
|
||||||
(define (do-get-field who id obj)
|
(define (do-get-field who id obj)
|
||||||
(unless (object? obj)
|
(cond
|
||||||
(raise-argument-error who
|
[(_object? obj)
|
||||||
"object?"
|
(do-field-get/raw-object who id obj)]
|
||||||
obj))
|
[(wrapped-object? obj)
|
||||||
(let* ([cls (object-ref/unwrap obj)]
|
(define projs+ref (hash-ref (wrapped-object-pos-field-projs obj) id #f))
|
||||||
[field-ht (class-field-ht cls)]
|
(cond
|
||||||
[fi (hash-ref field-ht id #f)])
|
[projs+ref
|
||||||
(if fi
|
(define np (wrapped-object-neg-party obj))
|
||||||
((field-info-external-ref fi) obj)
|
(let loop ([projs+ref projs+ref])
|
||||||
(obj-error who
|
(cond
|
||||||
"given object does not have the requested field"
|
[(pair? projs+ref)
|
||||||
"field name" (as-write id)
|
(define the-proj (car projs+ref))
|
||||||
"object" obj))))
|
(define field-val-with-other-contracts (loop (cdr projs+ref)))
|
||||||
|
((the-proj field-val-with-other-contracts) np)]
|
||||||
|
[else
|
||||||
|
;; projs+ref is the struct field accessor
|
||||||
|
(projs+ref (wrapped-object-object obj))]))]
|
||||||
|
[else
|
||||||
|
(do-field-get/raw-object who id (wrapped-object-object obj))])]
|
||||||
|
[else
|
||||||
|
(raise-argument-error who
|
||||||
|
"object?"
|
||||||
|
obj)]))
|
||||||
|
|
||||||
|
(define (do-field-get/raw-object who id obj)
|
||||||
|
(define cls (object-ref obj))
|
||||||
|
(define field-ht (class-field-ht cls))
|
||||||
|
(define fi (hash-ref field-ht id #f))
|
||||||
|
(if fi
|
||||||
|
((field-info-external-ref fi) obj)
|
||||||
|
(obj-error who
|
||||||
|
"given object does not have the requested field"
|
||||||
|
"field name" (as-write id)
|
||||||
|
"object" obj)))
|
||||||
|
|
||||||
(define (dynamic-get-field id obj)
|
(define (dynamic-get-field id obj)
|
||||||
(unless (symbol? id) (raise-argument-error 'dynamic-get-field "symbol?" id))
|
(unless (symbol? id) (raise-argument-error 'dynamic-get-field "symbol?" id))
|
||||||
|
|
@ -4170,7 +4214,10 @@ An example
|
||||||
;; runtime wrappers to support contracts with better space properties
|
;; runtime wrappers to support contracts with better space properties
|
||||||
;;--------------------------------------------------------------------
|
;;--------------------------------------------------------------------
|
||||||
|
|
||||||
(struct wrapped-class-info (class blame neg-extra-arg-ht neg-acceptors-ht init-proj-pairs)
|
(struct wrapped-class-info (class blame
|
||||||
|
neg-extra-arg-ht neg-acceptors-ht
|
||||||
|
pos-field-projs neg-field-projs
|
||||||
|
init-proj-pairs)
|
||||||
#:transparent)
|
#:transparent)
|
||||||
(struct wrapped-class (the-info neg-party)
|
(struct wrapped-class (the-info neg-party)
|
||||||
#:property prop:custom-write
|
#:property prop:custom-write
|
||||||
|
|
@ -4183,7 +4230,8 @@ An example
|
||||||
[(wrapped-class? class) (loop (wrapped-class-info-class (wrapped-class-the-info class)))]
|
[(wrapped-class? class) (loop (wrapped-class-info-class (wrapped-class-the-info class)))]
|
||||||
[else class])))
|
[else class])))
|
||||||
|
|
||||||
(struct wrapped-object (object method-wrappers neg-party) #:transparent
|
(struct wrapped-object (object method-wrappers pos-field-projs neg-field-projs neg-party)
|
||||||
|
#:transparent
|
||||||
#:property prop:custom-write
|
#:property prop:custom-write
|
||||||
(λ (stct port mode)
|
(λ (stct port mode)
|
||||||
(do-custom-write (wrapped-object-object stct) port mode)))
|
(do-custom-write (wrapped-object-object stct) port mode)))
|
||||||
|
|
@ -4205,7 +4253,7 @@ An example
|
||||||
|
|
||||||
(define (check-arg-contracts wrapped-blame wrapped-neg-party val init-proj-pairs orig-named-args)
|
(define (check-arg-contracts wrapped-blame wrapped-neg-party val init-proj-pairs orig-named-args)
|
||||||
;; blame will be #f only when init-ctc-pairs is '()
|
;; blame will be #f only when init-ctc-pairs is '()
|
||||||
(define arg-blame (and wrapped-blame (blame-swap wrapped-blame)))
|
(define arg-blame (and wrapped-blame (blame-swap wrapped-blame)))
|
||||||
|
|
||||||
(define (missing-one init-ctc-pair)
|
(define (missing-one init-ctc-pair)
|
||||||
(raise-blame-error arg-blame #:missing-party wrapped-neg-party val
|
(raise-blame-error arg-blame #:missing-party wrapped-neg-party val
|
||||||
|
|
@ -4487,6 +4535,9 @@ An example
|
||||||
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
|
||||||
|
|
||||||
|
field-info-internal-ref
|
||||||
|
field-info-internal-set!
|
||||||
|
|
||||||
(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*
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user