change class/c to keep a vector of wrapper methods, not a hash table
this change is mostly motivated by improving how generics work on contracted objects. Also fix dynamic-send TR's optimizer seems to get angry at the new send expansion, so disable optimizations auto-language.rkt and insert-large-letters.rkt (for now)
This commit is contained in:
Robby Findler
parent
615f2150de
commit
e47c0efa1f
|
|
@ -1,4 +1,4 @@
|
|||
#lang typed/racket/base
|
||||
#lang typed/racket/base #:no-optimize
|
||||
|
||||
(require typed/framework/framework
|
||||
typed/mred/mred
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang typed/racket/base
|
||||
#lang typed/racket/base #:no-optimize
|
||||
|
||||
(require typed/mred/mred
|
||||
typed/framework/framework
|
||||
|
|
|
|||
|
|
@ -2146,6 +2146,155 @@
|
|||
'pos
|
||||
'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'generic1
|
||||
'(let* ([c% (class object%
|
||||
(super-new)
|
||||
(define/public (m x) x))])
|
||||
(send-generic (new (contract (class/c
|
||||
(m (->m integer? integer?)))
|
||||
c%
|
||||
'pos 'neg))
|
||||
(generic c% m)
|
||||
5)))
|
||||
|
||||
(test/neg-blame
|
||||
'generic2
|
||||
'(let* ([c% (class object%
|
||||
(super-new)
|
||||
(define/public (m x) x))])
|
||||
(send-generic (new (contract (class/c
|
||||
(m (->m integer? integer?)))
|
||||
c%
|
||||
'pos 'neg))
|
||||
(generic c% m)
|
||||
#f)))
|
||||
|
||||
(test/spec-passed
|
||||
'generic3
|
||||
'(let* ([i<%> (interface () m)]
|
||||
[c% (class* object% (i<%>)
|
||||
(super-new)
|
||||
(define/public (m x) x))])
|
||||
(send-generic (new (contract (class/c
|
||||
(m (->m integer? integer?)))
|
||||
c%
|
||||
'pos 'neg))
|
||||
(generic i<%> m)
|
||||
5)))
|
||||
|
||||
(test/neg-blame
|
||||
'generic4
|
||||
'(let* ([i<%> (interface () m)]
|
||||
[c% (class* object% (i<%>)
|
||||
(super-new)
|
||||
(define/public (m x) x))])
|
||||
(send-generic (new (contract (class/c
|
||||
(m (->m integer? integer?)))
|
||||
c%
|
||||
'pos 'neg))
|
||||
(generic i<%> m)
|
||||
#f)))
|
||||
|
||||
(test/spec-passed
|
||||
'generic5
|
||||
'(let* ([c% (class object%
|
||||
(super-new)
|
||||
(define/public (m x) x))]
|
||||
[c%+c (contract (class/c (m (->m integer? integer?)))
|
||||
c%
|
||||
'pos 'neg)]
|
||||
[o (new c%)]
|
||||
[g (generic c%+c m)])
|
||||
(send-generic o g #f)))
|
||||
|
||||
(test/neg-blame
|
||||
'generic6
|
||||
'(let* ([c% (class object%
|
||||
(super-new)
|
||||
(define/public (m x) x))]
|
||||
[c%+c (contract (class/c (m (->m integer? integer?)))
|
||||
c%
|
||||
'pos 'neg)]
|
||||
[o (new c%+c)]
|
||||
[g (generic c% m)])
|
||||
(send-generic o g #f)))
|
||||
|
||||
(test/spec-passed
|
||||
'generic7
|
||||
'(let* ([i<%> (interface () m)]
|
||||
[c% (class* object% (i<%>)
|
||||
(super-new)
|
||||
(define/public (m x) x))])
|
||||
(send-generic (new (contract (class/c m)
|
||||
c%
|
||||
'pos 'neg))
|
||||
(generic c% m)
|
||||
5)))
|
||||
|
||||
(test/spec-passed
|
||||
'generic8
|
||||
'(let* ([i<%> (interface () n)]
|
||||
[c% (class* object% (i<%>)
|
||||
(super-new)
|
||||
(define/public (m x) x)
|
||||
(define/public (n x) x))])
|
||||
(send-generic (new (contract (class/c m)
|
||||
c%
|
||||
'pos 'neg))
|
||||
(generic c% n)
|
||||
5)))
|
||||
|
||||
(test/spec-passed
|
||||
'dynamic-send1
|
||||
'(dynamic-send (new (contract (class/c [m (->m integer? integer?)])
|
||||
(class object% (define/public (m x) x) (super-new))
|
||||
'pos
|
||||
'neg))
|
||||
'm 1))
|
||||
(test/spec-passed
|
||||
'dynamic-send2
|
||||
'(dynamic-send (new (contract (class/c m)
|
||||
(class object% (define/public (m x) x) (super-new))
|
||||
'pos
|
||||
'neg))
|
||||
'm 1))
|
||||
(test/spec-passed
|
||||
'dynamic-send3
|
||||
'(dynamic-send (new (contract (class/c m)
|
||||
(class object%
|
||||
(define/public (m x) x)
|
||||
(define/public (n x) x)
|
||||
(super-new))
|
||||
'pos
|
||||
'neg))
|
||||
'n 1))
|
||||
(test/neg-blame
|
||||
'dynamic-send4
|
||||
'(dynamic-send (new (contract (class/c [m (->m integer? integer?)])
|
||||
(class object% (define/public (m x) x) (super-new))
|
||||
'pos
|
||||
'neg))
|
||||
'm #f))
|
||||
|
||||
(test/spec-passed
|
||||
'with-method1
|
||||
'(let ([o (new (contract (class/c [m (->m integer? integer?)])
|
||||
(class object% (define/public (m x) x) (super-new))
|
||||
'pos
|
||||
'neg))])
|
||||
(with-method ([m (o m)])
|
||||
(m 1))))
|
||||
|
||||
(test/neg-blame
|
||||
'with-method1
|
||||
'(let ([o (new (contract (class/c [m (->m integer? integer?)])
|
||||
(class object% (define/public (m x) x) (super-new))
|
||||
'pos
|
||||
'neg))])
|
||||
(with-method ([m (o m)])
|
||||
(m #f))))
|
||||
|
||||
(let ([expected-given?
|
||||
(λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn))
|
||||
(regexp-match? #rx"expected: boolean[?]" (exn-message exn))
|
||||
|
|
|
|||
|
|
@ -1885,16 +1885,23 @@
|
|||
(super-new)
|
||||
(define/public (m x) x)))
|
||||
|
||||
(define i<%> (interface () m))
|
||||
(define c/i% (class* object% (i<%>)
|
||||
(super-new)
|
||||
(define/public (m x) x)))
|
||||
|
||||
(define c%/c
|
||||
(class/c
|
||||
(m (->m integer? integer?))))
|
||||
|
||||
(provide
|
||||
(contract-out
|
||||
[c% c%/c])
|
||||
[c% c%/c]
|
||||
[c/i% (class/c [m (-> any/c integer? integer?)])])
|
||||
is-c%?
|
||||
c%-is?
|
||||
is-a-c%?)
|
||||
is-a-c%?
|
||||
i<%>)
|
||||
|
||||
(define (is-c%? c)
|
||||
(c . subclass? . c%))
|
||||
|
|
@ -1913,6 +1920,7 @@
|
|||
(test #t is-a-c%? (new c%))
|
||||
|
||||
(test 5 'send-generic (send-generic (new c%) (generic c% m) 5))
|
||||
(test 6 'send-generic-interface (send-generic (new c/i%) (generic i<%> m) 6))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
|||
|
|
@ -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?)
|
||||
|
|
|
|||
|
|
@ -140,16 +140,18 @@
|
|||
(λ (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) '()
|
||||
(build-neg-acceptor-proc this maybe-err blame cls #f '()
|
||||
(make-hasheq) (make-hasheq))])]
|
||||
[(wrapped-class? cls)
|
||||
(define neg-acceptors-ht
|
||||
(wrapped-class-info-neg-acceptors-ht (wrapped-class-the-info cls)))
|
||||
(define wrapper-neg-party (wrapped-class-neg-party cls))
|
||||
(define new-mths-ht
|
||||
(for/hash ([(mth neg-acceptor) (in-hash neg-acceptors-ht)])
|
||||
(values mth (neg-acceptor wrapper-neg-party))))
|
||||
(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)
|
||||
|
|
@ -158,7 +160,7 @@
|
|||
((func val) wrapper-neg-party)))))))
|
||||
(build-neg-acceptor-proc this maybe-err blame
|
||||
(wrapped-class-info-class the-info)
|
||||
new-mths-ht
|
||||
new-mths
|
||||
fixed-neg-init-projs
|
||||
(wrapped-class-info-pos-field-projs the-info)
|
||||
(wrapped-class-info-neg-field-projs the-info))]
|
||||
|
|
@ -169,56 +171,40 @@
|
|||
blame #:missing-party neg-party cls
|
||||
'(expected: "a class"))))])))))
|
||||
|
||||
(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 old-mths-vec 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]
|
||||
[else
|
||||
(define mth-idx (hash-ref mth->idx name #f))
|
||||
(and mth-idx
|
||||
(vector-ref mtd-vec mth-idx))]))
|
||||
|
||||
(define neg-extra-arg-ht (make-hash))
|
||||
;; The #f may survive if the method is just-check-existence or
|
||||
;; if the contract doesn't mention the method (and it isn't opaque)
|
||||
(define neg-extra-arg-vec (make-vector (vector-length mtd-vec) #f))
|
||||
(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
|
||||
(λ (kwds kwd-args neg-party . args)
|
||||
(keyword-apply raw-proc kwds kwd-args args))
|
||||
(λ (neg-party . args)
|
||||
(apply raw-proc args))))
|
||||
|
||||
(for ([(mth proj) (in-hash (ext-class/c-contract-table-of-meths-to-projs this))])
|
||||
(define m-mth (get-unwrapped-method mth))
|
||||
(unless m-mth
|
||||
(for ([(mth-name proj) (in-hash (ext-class/c-contract-table-of-meths-to-projs this))])
|
||||
(define mth-idx (hash-ref mth->idx mth-name #f))
|
||||
(unless mth-idx
|
||||
(maybe-err
|
||||
(λ (neg-party)
|
||||
(raise-blame-error
|
||||
blame #:missing-party neg-party cls
|
||||
'(expected: "a class with a public method named ~a")
|
||||
mth))))
|
||||
mth-name))))
|
||||
|
||||
(cond
|
||||
[(just-check-existence? proj)
|
||||
;; if we just check the method's existence,
|
||||
;; then make an inefficient wrapper for it
|
||||
;; that discards the neg-party argument
|
||||
(hash-set! neg-extra-arg-ht mth (generic-wrapper mth))]
|
||||
[else
|
||||
(define w/blame (proj (blame-add-method-context blame mth)))
|
||||
(unless (just-check-existence? proj)
|
||||
(define w/blame (proj (blame-add-method-context blame mth-name)))
|
||||
(define m-mth (if old-mths-vec
|
||||
(or (vector-ref old-mths-vec mth-idx)
|
||||
(vector-ref mtd-vec mth-idx))
|
||||
(vector-ref mtd-vec mth-idx)))
|
||||
(define projd-mth (w/blame m-mth))
|
||||
(hash-set! neg-acceptors-ht mth projd-mth)
|
||||
(define neg-acceptor
|
||||
(hash-set! neg-acceptors-ht mth-name projd-mth)
|
||||
(define neg-extra-arg
|
||||
(cond
|
||||
[(wrapped-extra-arg-arrow? projd-mth)
|
||||
(wrapped-extra-arg-arrow-extra-neg-party-argument projd-mth)]
|
||||
|
|
@ -230,22 +216,20 @@
|
|||
(keyword-apply (projd-mth neg-party) kwds kwd-args args))
|
||||
(λ (neg-party . args)
|
||||
(apply (projd-mth neg-party) args)))]))
|
||||
(hash-set! neg-extra-arg-ht mth neg-acceptor)]))
|
||||
(vector-set! neg-extra-arg-vec mth-idx neg-extra-arg)))
|
||||
|
||||
(define absent-methods (ext-class/c-contract-absent-methods this))
|
||||
(for ([(mth _) (in-hash mth->idx)])
|
||||
(when (member mth absent-methods)
|
||||
(for ([(mth-name mth-idx) (in-hash mth->idx)])
|
||||
(when (member mth-name 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))))
|
||||
mth-name))))
|
||||
|
||||
;; 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)
|
||||
(if (ext-class/c-contract-opaque? this)
|
||||
(when (ext-class/c-contract-opaque? this)
|
||||
(unless (hash-ref (ext-class/c-contract-table-of-meths-to-projs this) mth-name #f)
|
||||
(maybe-err
|
||||
(λ (neg-party)
|
||||
(define mth-names
|
||||
|
|
@ -261,8 +245,7 @@
|
|||
[else
|
||||
(format "a class with only the methods:~a"
|
||||
(apply string-append mth-names))])
|
||||
mth)))
|
||||
(hash-set! neg-extra-arg-ht mth (generic-wrapper mth)))))
|
||||
mth-name))))))
|
||||
|
||||
(for ([(fld proj) (in-hash (ext-class/c-contract-table-of-flds-to-projs this))])
|
||||
(define field-ht (class-field-ht cls))
|
||||
|
|
@ -325,7 +308,7 @@
|
|||
((get/build-val-first-projection ctc)
|
||||
(blame-add-init-context blame (car ctc-pair)))))))
|
||||
(define merged-init-pairs (merge-init-pairs old-init-pairs new-init-projs))
|
||||
(define the-info (wrapped-class-info cls blame neg-extra-arg-ht neg-acceptors-ht
|
||||
(define the-info (wrapped-class-info cls blame neg-extra-arg-vec neg-acceptors-ht
|
||||
pos-field-projs neg-field-projs
|
||||
merged-init-pairs))
|
||||
|
||||
|
|
@ -333,7 +316,7 @@
|
|||
;; 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)])
|
||||
(for ([(mth-name neg-party-acceptor) (in-hash neg-acceptors-ht)])
|
||||
(neg-party-acceptor neg-party))
|
||||
|
||||
;; XXX: we have to not do this;
|
||||
|
|
|
|||
|
|
@ -1167,7 +1167,7 @@
|
|||
(define the-info (wrapped-class-the-info new-cls))
|
||||
(wrapped-object
|
||||
val
|
||||
(wrapped-class-info-neg-extra-arg-ht the-info)
|
||||
(wrapped-class-info-neg-extra-arg-vec the-info)
|
||||
(wrapped-class-info-pos-field-projs the-info)
|
||||
(wrapped-class-info-neg-field-projs the-info)
|
||||
(wrapped-class-neg-party new-cls))]
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
racket/stxparam
|
||||
racket/unsafe/ops
|
||||
"serialize-structs.rkt"
|
||||
"class-wrapped.rkt"
|
||||
racket/runtime-path
|
||||
(only-in "../contract/region.rkt" current-contract-region)
|
||||
"../contract/base.rkt"
|
||||
|
|
@ -3240,7 +3241,7 @@ An example
|
|||
(wrapped-class-info-init-proj-pairs the-info)))
|
||||
(wrapped-object
|
||||
unwrapped-o
|
||||
(wrapped-class-info-neg-extra-arg-ht the-info)
|
||||
(wrapped-class-info-neg-extra-arg-vec the-info)
|
||||
(wrapped-class-info-pos-field-projs the-info)
|
||||
(wrapped-class-info-neg-field-projs the-info)
|
||||
(wrapped-class-neg-party class))]
|
||||
|
|
@ -3464,44 +3465,15 @@ An example
|
|||
(let*-values ([(sym) (quasiquote (unsyntax (localize name)))]
|
||||
[(receiver) (unsyntax obj)]
|
||||
[(method) (find-method/who '(unsyntax form) receiver sym)])
|
||||
|
||||
#;(unsyntax
|
||||
(make-method-call
|
||||
stx
|
||||
(syntax/loc stx receiver)
|
||||
(syntax/loc stx method)
|
||||
(syntax/loc stx sym)
|
||||
args
|
||||
rest-arg?
|
||||
kw-args/var))
|
||||
|
||||
|
||||
(let (#,@(if kw-args
|
||||
(list #`[kw-arg-tmp #,(cadr kw-args)])
|
||||
(list))
|
||||
#,@let-bindings)
|
||||
(if (wrapped-object? receiver)
|
||||
;; this is kind of a hack: passing the neg party in
|
||||
;; as the object to 'make-method-call' so that the
|
||||
;; arguments end up in the right order.
|
||||
(unsyntax
|
||||
(make-method-call
|
||||
stx
|
||||
#`(wrapped-object-neg-party receiver)
|
||||
(syntax/loc stx method)
|
||||
(syntax/loc stx sym)
|
||||
#`((wrapped-object-object #,(syntax/loc stx receiver)) #,@arg-list)
|
||||
rest-arg?
|
||||
kw-args/var))
|
||||
(unsyntax
|
||||
(make-method-call
|
||||
stx
|
||||
(syntax/loc stx receiver)
|
||||
(syntax/loc stx method)
|
||||
(syntax/loc stx sym)
|
||||
arg-list
|
||||
rest-arg?
|
||||
kw-args/var))))))))
|
||||
(make-method-call-to-possibly-wrapped-object
|
||||
stx kw-args/var arg-list rest-arg?
|
||||
#'sym #'method #'receiver
|
||||
(quasisyntax/loc stx (find-method/who '(unsyntax form) receiver sym)))))))))
|
||||
|
||||
(define (core-send apply? kws?)
|
||||
(lambda (stx)
|
||||
|
|
@ -3553,7 +3525,20 @@ An example
|
|||
(lambda (kws kw-vals obj method-name . args)
|
||||
(unless (object? obj) (raise-argument-error 'dynamic-send "object?" obj))
|
||||
(unless (symbol? method-name) (raise-argument-error 'dynamic-send "symbol?" method-name))
|
||||
(keyword-apply (find-method/who 'dynamic-send obj method-name) kws kw-vals obj args))))
|
||||
(define mtd (find-method/who 'dynamic-send obj method-name))
|
||||
(cond
|
||||
[(wrapped-object? obj)
|
||||
(if mtd
|
||||
(keyword-apply mtd kws kw-vals
|
||||
(wrapped-object-neg-party obj)
|
||||
(wrapped-object-object obj)
|
||||
args)
|
||||
(keyword-apply dynamic-send kws kw-vals
|
||||
(wrapped-object-object obj)
|
||||
method-name
|
||||
args))]
|
||||
[else
|
||||
(keyword-apply mtd kws kw-vals obj args)]))))
|
||||
|
||||
;; imperative chained send
|
||||
(define-syntax (send* stx)
|
||||
|
|
@ -3594,13 +3579,20 @@ An example
|
|||
(cond
|
||||
[(_object? in-object)
|
||||
(define cls (object-ref in-object #f))
|
||||
(define pos (hash-ref (class-method-ht cls) name #f))
|
||||
(if pos
|
||||
(vector-ref (class-methods cls) pos)
|
||||
(define mth-idx (hash-ref (class-method-ht cls) name #f))
|
||||
(if mth-idx
|
||||
(vector-ref (class-methods cls) mth-idx)
|
||||
(no-such-method who name cls))]
|
||||
[(wrapped-object? in-object)
|
||||
(or (hash-ref (wrapped-object-method-wrappers in-object) name #f)
|
||||
(no-such-method who name (object-ref in-object)))]
|
||||
(define cls
|
||||
(let loop ([obj in-object])
|
||||
(cond
|
||||
[(wrapped-object? obj) (loop (wrapped-object-object obj))]
|
||||
[else
|
||||
(object-ref obj #f)])))
|
||||
(define mth-idx (hash-ref (class-method-ht cls) name #f))
|
||||
(unless mth-idx (no-such-method who name (object-ref in-object)))
|
||||
(vector-ref (wrapped-object-neg-extra-arg-vec in-object) mth-idx)]
|
||||
[else
|
||||
(obj-error who "target is not an object"
|
||||
"target" in-object
|
||||
|
|
@ -3684,20 +3676,24 @@ An example
|
|||
"method name" (as-write name)
|
||||
#:class-name (class-name class))))]
|
||||
[instance? (class-object? (class-orig-cls class))]
|
||||
[dynamic-generic
|
||||
(lambda (obj)
|
||||
(unless (instance? obj)
|
||||
[fail (λ (obj)
|
||||
(obj-error
|
||||
(string->symbol (format "generic:~a" name))
|
||||
"target is not an instance of the generic's class"
|
||||
"target" obj
|
||||
#:class-name (class-name class)))
|
||||
(vector-ref (class-methods (object-ref obj)) pos))]) ;; TODO: object-ref audit
|
||||
#:class-name (class-name class)))]
|
||||
[dynamic-generic
|
||||
(lambda (obj)
|
||||
(cond
|
||||
[(wrapped-object? obj)
|
||||
(vector-ref (wrapped-object-neg-extra-arg-vec obj) pos)]
|
||||
[(instance? obj)
|
||||
(vector-ref (class-methods (object-ref obj)) pos)]
|
||||
[else (fail obj)]))])
|
||||
(if (eq? 'final (vector-ref (class-meth-flags class) pos))
|
||||
(let ([method (vector-ref (class-methods class) pos)])
|
||||
(lambda (obj)
|
||||
(unless (instance? obj)
|
||||
(dynamic-generic obj))
|
||||
(unless (instance? obj) (fail obj))
|
||||
method))
|
||||
dynamic-generic)))))])
|
||||
make-generic))
|
||||
|
|
@ -3713,15 +3709,18 @@ An example
|
|||
(quasisyntax/loc stx
|
||||
(let* ([obj object]
|
||||
[gen generic])
|
||||
;(check-generic gen)
|
||||
(unsyntax
|
||||
(make-method-call
|
||||
stx
|
||||
(syntax obj)
|
||||
(syntax/loc stx ((generic-applicable gen) obj))
|
||||
(syntax/loc stx (generic-name gen))
|
||||
flat-stx
|
||||
(not proper?)
|
||||
#f))))))]))
|
||||
(make-method-call-to-possibly-wrapped-object
|
||||
stx #f flat-stx (not proper?)
|
||||
#'(generic-name gen)
|
||||
#'((generic-applicable gen) obj)
|
||||
#'obj
|
||||
#'((generic-applicable gen) obj)))))))]))
|
||||
|
||||
(define (check-generic gen)
|
||||
(unless (generic? gen)
|
||||
(raise-argument-error 'send-generic "generic?" gen)))
|
||||
|
||||
(define-syntaxes (class-field-accessor class-field-mutator generic/form)
|
||||
(let ([mk
|
||||
|
|
@ -4210,46 +4209,6 @@ An example
|
|||
(define-values (impersonator-prop:original-object has-original-object? original-object)
|
||||
(make-impersonator-property 'impersonator-prop:original-object))
|
||||
|
||||
;;--------------------------------------------------------------------
|
||||
;; runtime wrappers to support contracts with better space properties
|
||||
;;--------------------------------------------------------------------
|
||||
|
||||
(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
|
||||
(λ (stct port mode)
|
||||
(do-custom-write (wrapped-class-info-class (wrapped-class-the-info stct)) port mode))
|
||||
#:transparent)
|
||||
(define (unwrap-class cls)
|
||||
(let loop ([class cls])
|
||||
(cond
|
||||
[(wrapped-class? class) (loop (wrapped-class-info-class (wrapped-class-the-info class)))]
|
||||
[else class])))
|
||||
|
||||
(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)))
|
||||
|
||||
(define (do-custom-write v port mode)
|
||||
(cond
|
||||
[(custom-write? v)
|
||||
((custom-write-accessor v) v port mode)]
|
||||
[(equal? mode #t)
|
||||
(write v port)]
|
||||
[(equal? mode #f)
|
||||
(display v port)]
|
||||
[else
|
||||
(print v port mode)]))
|
||||
(define (unwrap-object o)
|
||||
(cond
|
||||
[(wrapped-object? o) (unwrap-object (wrapped-object-object o))]
|
||||
[else o]))
|
||||
|
||||
(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 '()
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
|
||||
(require syntax/stx
|
||||
(for-syntax racket/base)
|
||||
(for-template racket/base))
|
||||
(for-template racket/base
|
||||
"class-wrapped.rkt"))
|
||||
|
||||
(define insp (variable-reference->module-declaration-inspector
|
||||
(#%variable-reference)))
|
||||
|
|
@ -282,14 +283,9 @@
|
|||
(let* ([args-stx (syntax args)]
|
||||
[proper? (stx-list? args-stx)]
|
||||
[flat-args-stx (if proper? args-stx (flatten-args args-stx))])
|
||||
(make-method-call
|
||||
stx
|
||||
method-obj-stx
|
||||
method-stx
|
||||
(syntax (quote id))
|
||||
flat-args-stx
|
||||
(not proper?)
|
||||
#f))]
|
||||
(make-method-call-to-possibly-wrapped-object
|
||||
stx #f flat-args-stx (not proper?)
|
||||
#''id method-stx method-obj-stx method-obj-stx))]
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
(raise-syntax-error
|
||||
|
|
@ -364,12 +360,55 @@
|
|||
[args args-stx])
|
||||
(qstx (app method kw-arg ... object . args)))))
|
||||
|
||||
(define (make-method-call-to-possibly-wrapped-object
|
||||
stx kw-args/var arg-list rest-arg?
|
||||
sym method receiver method-in-wrapper-fallback-case)
|
||||
(with-syntax ([sym sym]
|
||||
[method method]
|
||||
[receiver receiver]
|
||||
[method-in-wrapper-fallback-case method-in-wrapper-fallback-case])
|
||||
(quasisyntax/loc stx
|
||||
(if (wrapped-object? receiver)
|
||||
(if method
|
||||
;; this is a hack: passing the neg party in
|
||||
;; as the object to 'make-method-call' so that the
|
||||
;; arguments end up in the right order.
|
||||
(unsyntax
|
||||
(make-method-call
|
||||
stx
|
||||
#`(wrapped-object-neg-party receiver)
|
||||
(syntax/loc stx method)
|
||||
(syntax/loc stx sym)
|
||||
#`((wrapped-object-object #,(syntax/loc stx receiver)) #,@arg-list)
|
||||
rest-arg?
|
||||
kw-args/var))
|
||||
(let ([receiver (wrapped-object-object receiver)])
|
||||
(unsyntax
|
||||
(make-method-call
|
||||
stx
|
||||
(syntax/loc stx receiver)
|
||||
(syntax/loc stx method-in-wrapper-fallback-case)
|
||||
(syntax/loc stx sym)
|
||||
arg-list
|
||||
rest-arg?
|
||||
kw-args/var))))
|
||||
(unsyntax
|
||||
(make-method-call
|
||||
stx
|
||||
(syntax/loc stx receiver)
|
||||
(syntax/loc stx method)
|
||||
(syntax/loc stx sym)
|
||||
arg-list
|
||||
rest-arg?
|
||||
kw-args/var))))))
|
||||
|
||||
(provide (protect-out make-this-map make-this%-map make-field-map make-method-map
|
||||
make-direct-method-map
|
||||
make-rename-super-map make-rename-inner-map
|
||||
make-init-error-map make-init-redirect super-error-map
|
||||
make-with-method-map
|
||||
flatten-args make-method-call
|
||||
make-method-call-to-possibly-wrapped-object
|
||||
do-localize make-private-name
|
||||
generate-super-call generate-inner-call
|
||||
generate-class-expand-context class-top-level-context?))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user