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
|
||||
'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
|
||||
'class/c-first-order-method-1
|
||||
'(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)])
|
||||
(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
|
||||
'class/c-higher-order-init-field-1
|
||||
'(let ([c% (contract (class/c (init-field [f (-> number? number?)]))
|
||||
|
|
@ -2085,6 +2108,44 @@
|
|||
x)
|
||||
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?
|
||||
(λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn))
|
||||
(regexp-match? #rx"expected: boolean[?]" (exn-message exn))
|
||||
|
|
|
|||
|
|
@ -203,8 +203,4 @@
|
|||
(ctest #t contract-first-order-passes?
|
||||
(class/c [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,
|
||||
;; 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?)
|
||||
|
|
|
|||
|
|
@ -11,126 +11,6 @@
|
|||
|
||||
(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-values (opaque? args)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -143,7 +23,6 @@
|
|||
(raise-syntax-error #f "unrecognized keyword" stx (car stx-args)))
|
||||
(values #f stx-args))]))
|
||||
(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)))]
|
||||
[method-ctcs #`(list #,@(reverse (hash-ref pfs 'method-contracts null)))]
|
||||
[fields #`(list #,@(reverse (hash-ref pfs 'fields null)))]
|
||||
|
|
@ -182,22 +61,23 @@
|
|||
[opaque? opaque?])
|
||||
(syntax/loc stx
|
||||
(let bindings
|
||||
; (let-values ([(inits init-ctcs) (sort-inits+contracts (list (cons i i-c) ...))])
|
||||
(make-an-ext-class/c-contract
|
||||
'opaque?
|
||||
methods method-ctcs
|
||||
fields field-ctcs
|
||||
(list 'i ...)
|
||||
(list i-c ...)
|
||||
'name
|
||||
(internal-class/c
|
||||
inherits inherit-ctcs
|
||||
inherit-fields inherit-field-ctcs
|
||||
supers super-ctcs
|
||||
inners inner-ctcs
|
||||
overrides override-ctcs
|
||||
augments augment-ctcs
|
||||
augrides augride-ctcs)))))))
|
||||
(make-an-ext-class/c-contract
|
||||
'opaque?
|
||||
methods method-ctcs
|
||||
fields field-ctcs
|
||||
(list i ...)
|
||||
(list i-c ...)
|
||||
absents
|
||||
absent-fields
|
||||
'name
|
||||
(build-internal-class/c
|
||||
inherits inherit-ctcs
|
||||
inherit-fields inherit-field-ctcs
|
||||
supers super-ctcs
|
||||
inners inner-ctcs
|
||||
overrides override-ctcs
|
||||
augments augment-ctcs
|
||||
augrides augride-ctcs)))))))
|
||||
|
||||
(define (class/c2-proj this)
|
||||
(λ (blame)
|
||||
|
|
@ -224,13 +104,23 @@
|
|||
(if (just-check-existence? ctc)
|
||||
any/c
|
||||
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
|
||||
(make-class/c
|
||||
;; methods
|
||||
(map car mth-lst)
|
||||
(map cdr mth-lst)
|
||||
|
||||
'() '() ;; fields
|
||||
fields field-ctcs
|
||||
|
||||
;; inits
|
||||
(map (λ (x) (list-ref x 0)) (ext-class/c-contract-init-ctc-pairs this))
|
||||
|
|
@ -241,14 +131,17 @@
|
|||
ctc))
|
||||
(ext-class/c-contract-init-ctc-pairs this))
|
||||
|
||||
'() '() ;; absent
|
||||
empty-internal-class/c
|
||||
#f ;; opaque?
|
||||
#f ;; name
|
||||
))
|
||||
(ext-class/c-contract-absent-methods this)
|
||||
(ext-class/c-contract-absent-fields this)
|
||||
|
||||
(ext-class/c-contract-internal-ctc this)
|
||||
(ext-class/c-contract-opaque? this)
|
||||
(ext-class/c-contract-name this)))
|
||||
(λ (neg-party)
|
||||
(((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)
|
||||
(define neg-acceptors-ht
|
||||
(wrapped-class-info-neg-acceptors-ht (wrapped-class-the-info cls)))
|
||||
|
|
@ -266,7 +159,9 @@
|
|||
(build-neg-acceptor-proc this maybe-err blame
|
||||
(wrapped-class-info-class the-info)
|
||||
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
|
||||
(maybe-err
|
||||
(λ (neg-party)
|
||||
|
|
@ -274,20 +169,13 @@
|
|||
blame #:missing-party neg-party cls
|
||||
'(expected: "a class"))))])))))
|
||||
|
||||
(define empty-internal-class/c
|
||||
(internal-class/c
|
||||
'() '() ;; 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 (build-neg-acceptor-proc this maybe-err blame cls new-mths-ht old-init-pairs
|
||||
old-pos-fld-ht old-neg-fld-ht)
|
||||
(define mth->idx (class-method-ht 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)
|
||||
(cond
|
||||
[(hash-ref new-mths-ht name #f) => values]
|
||||
|
|
@ -299,6 +187,9 @@
|
|||
(define neg-extra-arg-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 raw-proc (get-unwrapped-method mth))
|
||||
(make-keyword-procedure
|
||||
|
|
@ -322,7 +213,7 @@
|
|||
;; if we just check the method's existence,
|
||||
;; then make an inefficient wrapper for it
|
||||
;; that discards the neg-party argument
|
||||
(generic-wrapper mth)]
|
||||
(hash-set! neg-extra-arg-ht mth (generic-wrapper mth))]
|
||||
[else
|
||||
(define w/blame (proj (blame-add-method-context blame mth)))
|
||||
(define projd-mth (w/blame m-mth))
|
||||
|
|
@ -341,7 +232,16 @@
|
|||
(apply (projd-mth neg-party) args)))]))
|
||||
(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)])
|
||||
(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
|
||||
;; methods without explicit contracts are going to be slow
|
||||
(unless (hash-ref neg-extra-arg-ht mth #f)
|
||||
|
|
@ -353,7 +253,7 @@
|
|||
(format " ~a" mth)))
|
||||
(raise-blame-error
|
||||
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
|
||||
[(null? mth-names) "a class with no methods"]
|
||||
[(null? (cdr mth-names))
|
||||
|
|
@ -363,6 +263,58 @@
|
|||
(apply string-append mth-names))])
|
||||
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
|
||||
(for/list ([ctc-pair (in-list (ext-class/c-contract-init-ctc-pairs this))])
|
||||
(define ctc (list-ref ctc-pair 1))
|
||||
|
|
@ -374,14 +326,28 @@
|
|||
(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-ht neg-acceptors-ht
|
||||
pos-field-projs neg-field-projs
|
||||
merged-init-pairs))
|
||||
|
||||
(λ (neg-party)
|
||||
;; run this for the side-effect of
|
||||
;; checking that first-order tests on
|
||||
;; methods (arity, etc) all pass
|
||||
(for ([(mth neg-party-acceptor) (in-hash neg-acceptors-ht)])
|
||||
(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)
|
||||
(cond
|
||||
|
|
@ -410,32 +376,42 @@
|
|||
mth-names mth-ctcs
|
||||
fld-names fld-ctcs
|
||||
init-names init-ctcs
|
||||
absent-methods absent-fields
|
||||
ctc-name internal-ctc)
|
||||
(define ctc-hash
|
||||
(make-hash (for/list ([raw-ctc (in-list mth-ctcs)]
|
||||
[name (in-list mth-names)])
|
||||
(define (build-a-ctc-table names ctcs)
|
||||
(make-hash (for/list ([raw-ctc (in-list ctcs)]
|
||||
[name (in-list names)])
|
||||
(define ctc (if (just-check-existence? raw-ctc)
|
||||
raw-ctc
|
||||
(coerce-contract 'class/c raw-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
|
||||
opaque?
|
||||
ctc-hash
|
||||
(make-hash (for/list ([name (in-list mth-names)])
|
||||
(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)])))
|
||||
mth-ctc-hash mth-proj-hash
|
||||
fld-ctc-hash fld-proj-hash
|
||||
(for/list ([name (in-list init-names)]
|
||||
[ctc (in-list init-ctcs)])
|
||||
(list name
|
||||
(if (just-check-existence? ctc)
|
||||
ctc
|
||||
(coerce-contract 'class/c ctc))))
|
||||
ctc-name))
|
||||
absent-methods absent-fields
|
||||
ctc-name
|
||||
internal-ctc))
|
||||
|
||||
(define (class/c-first-order-passes? ctc cls)
|
||||
(cond
|
||||
|
|
@ -444,15 +420,26 @@
|
|||
(define mtd-vec (class-methods cls))
|
||||
(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))
|
||||
(and mth-idx
|
||||
(contract-first-order-passes? ctc (vector-ref mtd-vec mth-idx))))]
|
||||
(cond
|
||||
[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]))
|
||||
|
||||
(struct ext-class/c-contract (opaque?
|
||||
table-of-meths-to-ctcs
|
||||
table-of-meths-to-projs
|
||||
table-of-flds-to-ctcs
|
||||
table-of-flds-to-projs
|
||||
init-ctc-pairs
|
||||
name)
|
||||
absent-methods absent-fields
|
||||
name
|
||||
internal-ctc)
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection
|
||||
|
|
|
|||
|
|
@ -9,13 +9,14 @@
|
|||
(only-in "../contract/private/arrow.rkt" making-a-method method-contract?))
|
||||
|
||||
(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
|
||||
make-wrapper-object
|
||||
check-object-contract
|
||||
(for-syntax parse-class/c-specs)
|
||||
(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))
|
||||
|
||||
|
|
@ -153,7 +154,6 @@
|
|||
(define (class/c-external-proj ctc)
|
||||
(define ctc-methods (class/c-methods ctc))
|
||||
(λ (blame)
|
||||
(define bswap (blame-swap blame))
|
||||
(define public-method-projections
|
||||
(for/list ([name (in-list ctc-methods)]
|
||||
[c (in-list (class/c-method-contracts ctc))])
|
||||
|
|
@ -165,9 +165,9 @@
|
|||
[c (in-list (class/c-field-contracts ctc))])
|
||||
(and 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)
|
||||
(blame-add-context bswap (format "the ~a field in" f)))])
|
||||
(blame-add-field-context blame f #:swap? #t))])
|
||||
(cons p-pos p-neg)))))
|
||||
|
||||
;; zip the inits and contracts together for ordered selection
|
||||
|
|
@ -307,7 +307,7 @@
|
|||
(define mp (vector-ref methods i))
|
||||
(vector-set! methods i (make-method (p mp) m)))))
|
||||
|
||||
;; Handle both external field contracts
|
||||
;; Handle external field contracts
|
||||
(unless no-field-ctcs?
|
||||
(for ([f (in-list (class/c-fields ctc))]
|
||||
[p-pr (in-list external-field-projections)])
|
||||
|
|
@ -724,6 +724,9 @@
|
|||
(blame-add-context blame "an unnamed method in")]
|
||||
[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
|
||||
supers super-contracts inners inner-contracts
|
||||
overrides override-contracts augments augment-contracts
|
||||
|
|
@ -1161,9 +1164,12 @@
|
|||
(define new-cls (p (object-ref val)))
|
||||
(cond
|
||||
[(wrapped-class? new-cls)
|
||||
(define the-info (wrapped-class-the-info new-cls))
|
||||
(wrapped-object
|
||||
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))]
|
||||
[else
|
||||
(impersonate-struct val object-ref (λ (o c) new-cls)
|
||||
|
|
@ -1303,11 +1309,9 @@
|
|||
(for ([f (in-list fields)]
|
||||
[c (in-list field-contracts)])
|
||||
(when c
|
||||
(define fld-context (format "the ~a field in" f))
|
||||
(define bset (blame-add-context blame fld-context #:swap? #t))
|
||||
(let ([fi (hash-ref field-ht f)]
|
||||
[p-pos ((contract-projection c) (blame-add-context blame fld-context))]
|
||||
[p-neg ((contract-projection c) bset)])
|
||||
(hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))))
|
||||
(define fi (hash-ref field-ht f))
|
||||
(define p-pos ((contract-projection c) (blame-add-field-context blame f #:swap? #f)))
|
||||
(define p-neg ((contract-projection c) (blame-add-field-context blame f #:swap? #t)))
|
||||
(hash-set! field-ht f (field-info-extend-external fi p-pos p-neg)))))
|
||||
|
||||
c))
|
||||
|
|
|
|||
|
|
@ -3241,6 +3241,8 @@ An example
|
|||
(wrapped-object
|
||||
unwrapped-o
|
||||
(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))]
|
||||
[else
|
||||
(raise-argument-error 'instantiate "class?" class)]))
|
||||
|
|
@ -3763,22 +3765,43 @@ An example
|
|||
(do-set-field! 'set-field! id obj val))
|
||||
|
||||
(define (do-set-field! who id obj val)
|
||||
(unless (object? obj)
|
||||
(raise-argument-error who
|
||||
"object?"
|
||||
obj))
|
||||
(let* ([cls (object-ref/unwrap obj)]
|
||||
[field-ht (class-field-ht cls)]
|
||||
[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))))
|
||||
(cond
|
||||
[(_object? obj)
|
||||
(do-set-field!/raw-object who id obj val)]
|
||||
[(wrapped-object? obj)
|
||||
(define projs+set! (hash-ref (wrapped-object-neg-field-projs obj) id #f))
|
||||
(cond
|
||||
[projs+set!
|
||||
(define np (wrapped-object-neg-party obj))
|
||||
(let loop ([projs+set! projs+set!]
|
||||
[val val])
|
||||
(cond
|
||||
[(pair? projs+set!)
|
||||
(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)
|
||||
(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))
|
||||
|
||||
(define-syntax (get-field stx)
|
||||
|
|
@ -3796,19 +3819,40 @@ An example
|
|||
(do-get-field 'get-field id obj))
|
||||
|
||||
(define (do-get-field who id obj)
|
||||
(unless (object? obj)
|
||||
(raise-argument-error who
|
||||
"object?"
|
||||
obj))
|
||||
(let* ([cls (object-ref/unwrap obj)]
|
||||
[field-ht (class-field-ht cls)]
|
||||
[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))))
|
||||
(cond
|
||||
[(_object? obj)
|
||||
(do-field-get/raw-object who id obj)]
|
||||
[(wrapped-object? obj)
|
||||
(define projs+ref (hash-ref (wrapped-object-pos-field-projs obj) id #f))
|
||||
(cond
|
||||
[projs+ref
|
||||
(define np (wrapped-object-neg-party obj))
|
||||
(let loop ([projs+ref projs+ref])
|
||||
(cond
|
||||
[(pair? projs+ref)
|
||||
(define the-proj (car projs+ref))
|
||||
(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)
|
||||
(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
|
||||
;;--------------------------------------------------------------------
|
||||
|
||||
(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)
|
||||
(struct wrapped-class (the-info neg-party)
|
||||
#:property prop:custom-write
|
||||
|
|
@ -4183,7 +4230,8 @@ An example
|
|||
[(wrapped-class? class) (loop (wrapped-class-info-class (wrapped-class-the-info 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
|
||||
(λ (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)
|
||||
;; 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)
|
||||
(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
|
||||
object-ref/unwrap impersonator-prop:original-object has-original-object? original-object
|
||||
;; end class-c-old.rkt requirements
|
||||
|
||||
field-info-internal-ref
|
||||
field-info-internal-set!
|
||||
|
||||
(rename-out [_class class]) class* class/derived
|
||||
define-serializable-class define-serializable-class*
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user