suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

change class/c to keep a vector of wrapper methods, not a hash table

Browse Source 
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 2014-02-07 07:51:46 -06:00
parent 615f2150de
commit e47c0efa1f
9 changed files with 331 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/drracket-pkgs/drracket/drracket/private/auto-language.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket/base #lang typed/racket/base #:no-optimize
(require typed/framework/framework (require typed/framework/framework
typed/mred/mred typed/mred/mred

2
pkgs/drracket-pkgs/drracket/drracket/private/insert-large-letters.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket/base #lang typed/racket/base #:no-optimize
(require typed/mred/mred (require typed/mred/mred
typed/framework/framework typed/framework/framework

149
pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt
View File

@ -2146,6 +2146,155 @@
'pos 'pos
'neg)) '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? (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))

12
pkgs/racket-pkgs/racket-test/tests/racket/object.rktl
View File

@ -1885,16 +1885,23 @@
(super-new) (super-new)
(define/public (m x) x))) (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 (define c%/c
(class/c (class/c
(m (->m integer? integer?)))) (m (->m integer? integer?))))
(provide (provide
(contract-out (contract-out
[c% c%/c]) [c% c%/c]
[c/i% (class/c [m (-> any/c integer? integer?)])])
is-c%? is-c%?
c%-is? c%-is?
is-a-c%?) is-a-c%?
i<%>)
(define (is-c%? c) (define (is-c%? c)
(c . subclass? . c%)) (c . subclass? . c%))
@ -1913,6 +1920,7 @@
(test #t is-a-c%? (new c%)) (test #t is-a-c%? (new c%))
(test 5 'send-generic (send-generic (new c%) (generic c% m) 5)) (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))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

3
racket/collects/racket/class.rkt
View File

@ -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?)

139
racket/collects/racket/private/class-c-new.rkt
View File

@ -140,16 +140,18 @@
(λ (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 [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))])] (make-hasheq) (make-hasheq))])]
[(wrapped-class? cls) [(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 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 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 (define fixed-neg-init-projs
(for/list ([proj-pair (wrapped-class-info-init-proj-pairs the-info)]) (for/list ([proj-pair (wrapped-class-info-init-proj-pairs the-info)])
(cons (list-ref proj-pair 0) (cons (list-ref proj-pair 0)
@ -158,7 +160,7 @@
((func val) wrapper-neg-party))))))) ((func val) wrapper-neg-party)))))))
(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
fixed-neg-init-projs fixed-neg-init-projs
(wrapped-class-info-pos-field-projs the-info) (wrapped-class-info-pos-field-projs the-info)
(wrapped-class-info-neg-field-projs the-info))] (wrapped-class-info-neg-field-projs the-info))]
@ -169,100 +171,81 @@
blame #:missing-party neg-party cls blame #:missing-party neg-party cls
'(expected: "a class"))))]))))) '(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) old-pos-fld-ht old-neg-fld-ht)
(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 internal-proj (internal-class/c-proj (ext-class/c-contract-internal-ctc this)))
(define (get-unwrapped-method name) ;; The #f may survive if the method is just-check-existence or
(cond ;; if the contract doesn't mention the method (and it isn't opaque)
[(hash-ref new-mths-ht name #f) => values] (define neg-extra-arg-vec (make-vector (vector-length mtd-vec) #f))
[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))
(define neg-acceptors-ht (make-hash)) (define neg-acceptors-ht (make-hash))
(define pos-field-projs (hash-copy old-pos-fld-ht)) (define pos-field-projs (hash-copy old-pos-fld-ht))
(define neg-field-projs (hash-copy old-neg-fld-ht)) (define neg-field-projs (hash-copy old-neg-fld-ht))
(define (generic-wrapper mth) (for ([(mth-name proj) (in-hash (ext-class/c-contract-table-of-meths-to-projs this))])
(define raw-proc (get-unwrapped-method mth)) (define mth-idx (hash-ref mth->idx mth-name #f))
(make-keyword-procedure (unless mth-idx
(λ (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
(maybe-err (maybe-err
(λ (neg-party) (λ (neg-party)
(raise-blame-error (raise-blame-error
blame #:missing-party neg-party cls blame #:missing-party neg-party cls
'(expected: "a class with a public method named ~a") '(expected: "a class with a public method named ~a")
mth)))) mth-name))))
(cond (unless (just-check-existence? proj)
[(just-check-existence? proj) (define w/blame (proj (blame-add-method-context blame mth-name)))
;; if we just check the method's existence, (define m-mth (if old-mths-vec
;; then make an inefficient wrapper for it (or (vector-ref old-mths-vec mth-idx)
;; that discards the neg-party argument (vector-ref mtd-vec mth-idx))
(hash-set! neg-extra-arg-ht mth (generic-wrapper mth))] (vector-ref mtd-vec mth-idx)))
[else (define projd-mth (w/blame m-mth))
(define w/blame (proj (blame-add-method-context blame mth))) (hash-set! neg-acceptors-ht mth-name projd-mth)
(define projd-mth (w/blame m-mth)) (define neg-extra-arg
(hash-set! neg-acceptors-ht mth projd-mth) (cond
(define neg-acceptor [(wrapped-extra-arg-arrow? projd-mth)
(cond (wrapped-extra-arg-arrow-extra-neg-party-argument projd-mth)]
[(wrapped-extra-arg-arrow? projd-mth) [else
(wrapped-extra-arg-arrow-extra-neg-party-argument projd-mth)] ;; if some contract doesn't subscribe to the wrapped-extra-arg-arrow
[else ;; protocol, then make an inefficient wrapper for it.
;; if some contract doesn't subscribe to the wrapped-extra-arg-arrow (make-keyword-procedure
;; protocol, then make an inefficient wrapper for it. (λ (kwds kwd-args neg-party . args)
(make-keyword-procedure (keyword-apply (projd-mth neg-party) kwds kwd-args args))
(λ (kwds kwd-args neg-party . args) (λ (neg-party . args)
(keyword-apply (projd-mth neg-party) kwds kwd-args args)) (apply (projd-mth neg-party) args)))]))
(λ (neg-party . args) (vector-set! neg-extra-arg-vec mth-idx neg-extra-arg)))
(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)) (define absent-methods (ext-class/c-contract-absent-methods this))
(for ([(mth _) (in-hash mth->idx)]) (for ([(mth-name mth-idx) (in-hash mth->idx)])
(when (member mth absent-methods) (when (member mth-name absent-methods)
(maybe-err (maybe-err
(λ (neg-party) (λ (neg-party)
(raise-blame-error (raise-blame-error
blame #:missing-party neg-party cls blame #:missing-party neg-party cls
'(expected: "a class that does not have the method ~a") '(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 (when (ext-class/c-contract-opaque? this)
;; methods without explicit contracts are going to be slow (unless (hash-ref (ext-class/c-contract-table-of-meths-to-projs this) mth-name #f)
(unless (hash-ref neg-extra-arg-ht mth #f) (maybe-err
(if (ext-class/c-contract-opaque? this) (λ (neg-party)
(maybe-err (define mth-names
(λ (neg-party) (for/list ([(mth proj) (in-hash (ext-class/c-contract-table-of-meths-to-projs this))])
(define mth-names (format " ~a" mth)))
(for/list ([(mth proj) (in-hash (ext-class/c-contract-table-of-meths-to-projs this))]) (raise-blame-error
(format " ~a" mth))) blame #:missing-party neg-party cls
(raise-blame-error '(expected: "~a" given: "a class that has a method: ~a")
blame #:missing-party neg-party cls (cond
'(expected: "~a" given: "a class that has a method: ~a") [(null? mth-names) "a class with no methods"]
(cond [(null? (cdr mth-names))
[(null? mth-names) "a class with no methods"] (format "a class with only one method:~a" (car mth-names))]
[(null? (cdr mth-names)) [else
(format "a class with only one method:~a" (car mth-names))] (format "a class with only the methods:~a"
[else (apply string-append mth-names))])
(format "a class with only the methods:~a" mth-name))))))
(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))]) (for ([(fld proj) (in-hash (ext-class/c-contract-table-of-flds-to-projs this))])
(define field-ht (class-field-ht cls)) (define field-ht (class-field-ht cls))
@ -325,7 +308,7 @@
((get/build-val-first-projection ctc) ((get/build-val-first-projection ctc)
(blame-add-init-context blame (car ctc-pair))))))) (blame-add-init-context blame (car ctc-pair)))))))
(define merged-init-pairs (merge-init-pairs old-init-pairs new-init-projs)) (define merged-init-pairs (merge-init-pairs old-init-pairs new-init-projs))
(define the-info (wrapped-class-info cls blame neg-extra-arg-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 pos-field-projs neg-field-projs
merged-init-pairs)) merged-init-pairs))
@ -333,7 +316,7 @@
;; 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-name neg-party-acceptor) (in-hash neg-acceptors-ht)])
(neg-party-acceptor neg-party)) (neg-party-acceptor neg-party))
;; XXX: we have to not do this; ;; XXX: we have to not do this;

2
racket/collects/racket/private/class-c-old.rkt
View File

@ -1167,7 +1167,7 @@
(define the-info (wrapped-class-the-info new-cls)) (define the-info (wrapped-class-the-info new-cls))
(wrapped-object (wrapped-object
val 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-pos-field-projs the-info)
(wrapped-class-info-neg-field-projs the-info) (wrapped-class-info-neg-field-projs the-info)
(wrapped-class-neg-party new-cls))] (wrapped-class-neg-party new-cls))]

155
racket/collects/racket/private/class-internal.rkt
View File

@ -4,6 +4,7 @@
racket/stxparam racket/stxparam
racket/unsafe/ops racket/unsafe/ops
"serialize-structs.rkt" "serialize-structs.rkt"
"class-wrapped.rkt"
racket/runtime-path racket/runtime-path
(only-in "../contract/region.rkt" current-contract-region) (only-in "../contract/region.rkt" current-contract-region)
"../contract/base.rkt" "../contract/base.rkt"
@ -3240,7 +3241,7 @@ An example
(wrapped-class-info-init-proj-pairs the-info))) (wrapped-class-info-init-proj-pairs the-info)))
(wrapped-object (wrapped-object
unwrapped-o unwrapped-o
(wrapped-class-info-neg-extra-arg-ht the-info) (wrapped-class-info-neg-extra-arg-vec the-info)
(wrapped-class-info-pos-field-projs the-info) (wrapped-class-info-pos-field-projs the-info)
(wrapped-class-info-neg-field-projs the-info) (wrapped-class-info-neg-field-projs the-info)
(wrapped-class-neg-party class))] (wrapped-class-neg-party class))]
@ -3464,44 +3465,15 @@ An example
(let*-values ([(sym) (quasiquote (unsyntax (localize name)))] (let*-values ([(sym) (quasiquote (unsyntax (localize name)))]
[(receiver) (unsyntax obj)] [(receiver) (unsyntax obj)]
[(method) (find-method/who '(unsyntax form) receiver sym)]) [(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 (let (#,@(if kw-args
(list #`[kw-arg-tmp #,(cadr kw-args)]) (list #`[kw-arg-tmp #,(cadr kw-args)])
(list)) (list))
#,@let-bindings) #,@let-bindings)
(if (wrapped-object? receiver) (unsyntax
;; this is kind of a hack: passing the neg party in (make-method-call-to-possibly-wrapped-object
;; as the object to 'make-method-call' so that the stx kw-args/var arg-list rest-arg?
;; arguments end up in the right order. #'sym #'method #'receiver
(unsyntax (quasisyntax/loc stx (find-method/who '(unsyntax form) receiver sym)))))))))
(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))))))))
(define (core-send apply? kws?) (define (core-send apply? kws?)
(lambda (stx) (lambda (stx)
@ -3553,7 +3525,20 @@ An example
(lambda (kws kw-vals obj method-name . args) (lambda (kws kw-vals obj method-name . args)
(unless (object? obj) (raise-argument-error 'dynamic-send "object?" obj)) (unless (object? obj) (raise-argument-error 'dynamic-send "object?" obj))
(unless (symbol? method-name) (raise-argument-error 'dynamic-send "symbol?" method-name)) (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 ;; imperative chained send
(define-syntax (send* stx) (define-syntax (send* stx)
@ -3594,13 +3579,20 @@ An example
(cond (cond
[(_object? in-object) [(_object? in-object)
(define cls (object-ref in-object #f)) (define cls (object-ref in-object #f))
(define pos (hash-ref (class-method-ht cls) name #f)) (define mth-idx (hash-ref (class-method-ht cls) name #f))
(if pos (if mth-idx
(vector-ref (class-methods cls) pos) (vector-ref (class-methods cls) mth-idx)
(no-such-method who name cls))] (no-such-method who name cls))]
[(wrapped-object? in-object) [(wrapped-object? in-object)
(or (hash-ref (wrapped-object-method-wrappers in-object) name #f) (define cls
(no-such-method who name (object-ref in-object)))] (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 [else
(obj-error who "target is not an object" (obj-error who "target is not an object"
"target" in-object "target" in-object
@ -3684,20 +3676,24 @@ An example
"method name" (as-write name) "method name" (as-write name)
#:class-name (class-name class))))] #:class-name (class-name class))))]
[instance? (class-object? (class-orig-cls class))] [instance? (class-object? (class-orig-cls class))]
[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)))]
[dynamic-generic [dynamic-generic
(lambda (obj) (lambda (obj)
(unless (instance? obj) (cond
(obj-error [(wrapped-object? obj)
(string->symbol (format "generic:~a" name)) (vector-ref (wrapped-object-neg-extra-arg-vec obj) pos)]
"target is not an instance of the generic's class" [(instance? obj)
"target" obj (vector-ref (class-methods (object-ref obj)) pos)]
#:class-name (class-name class))) [else (fail obj)]))])
(vector-ref (class-methods (object-ref obj)) pos))]) ;; TODO: object-ref audit
(if (eq? 'final (vector-ref (class-meth-flags class) pos)) (if (eq? 'final (vector-ref (class-meth-flags class) pos))
(let ([method (vector-ref (class-methods class) pos)]) (let ([method (vector-ref (class-methods class) pos)])
(lambda (obj) (lambda (obj)
(unless (instance? obj) (unless (instance? obj) (fail obj))
(dynamic-generic obj))
method)) method))
dynamic-generic)))))]) dynamic-generic)))))])
make-generic)) make-generic))
@ -3713,15 +3709,18 @@ An example
(quasisyntax/loc stx (quasisyntax/loc stx
(let* ([obj object] (let* ([obj object]
[gen generic]) [gen generic])
;(check-generic gen)
(unsyntax (unsyntax
(make-method-call (make-method-call-to-possibly-wrapped-object
stx stx #f flat-stx (not proper?)
(syntax obj) #'(generic-name gen)
(syntax/loc stx ((generic-applicable gen) obj)) #'((generic-applicable gen) obj)
(syntax/loc stx (generic-name gen)) #'obj
flat-stx #'((generic-applicable gen) obj)))))))]))
(not proper?)
#f))))))])) (define (check-generic gen)
(unless (generic? gen)
(raise-argument-error 'send-generic "generic?" gen)))
(define-syntaxes (class-field-accessor class-field-mutator generic/form) (define-syntaxes (class-field-accessor class-field-mutator generic/form)
(let ([mk (let ([mk
@ -4210,46 +4209,6 @@ An example
(define-values (impersonator-prop:original-object has-original-object? original-object) (define-values (impersonator-prop:original-object has-original-object? original-object)
(make-impersonator-property 'impersonator-prop: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) (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 '()

59
racket/collects/racket/private/classidmap.rkt
View File

@ -2,7 +2,8 @@
(require syntax/stx (require syntax/stx
(for-syntax racket/base) (for-syntax racket/base)
(for-template racket/base)) (for-template racket/base
"class-wrapped.rkt"))
(define insp (variable-reference->module-declaration-inspector (define insp (variable-reference->module-declaration-inspector
(#%variable-reference))) (#%variable-reference)))
@ -282,14 +283,9 @@
(let* ([args-stx (syntax args)] (let* ([args-stx (syntax args)]
[proper? (stx-list? args-stx)] [proper? (stx-list? args-stx)]
[flat-args-stx (if proper? args-stx (flatten-args args-stx))]) [flat-args-stx (if proper? args-stx (flatten-args args-stx))])
(make-method-call (make-method-call-to-possibly-wrapped-object
stx stx #f flat-args-stx (not proper?)
method-obj-stx #''id method-stx method-obj-stx method-obj-stx))]
method-stx
(syntax (quote id))
flat-args-stx
(not proper?)
#f))]
[id [id
(identifier? (syntax id)) (identifier? (syntax id))
(raise-syntax-error (raise-syntax-error
@ -364,12 +360,55 @@
[args args-stx]) [args args-stx])
(qstx (app method kw-arg ... object . args))))) (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 (provide (protect-out make-this-map make-this%-map make-field-map make-method-map
make-direct-method-map make-direct-method-map
make-rename-super-map make-rename-inner-map make-rename-super-map make-rename-inner-map
make-init-error-map make-init-redirect super-error-map make-init-error-map make-init-redirect super-error-map
make-with-method-map make-with-method-map
flatten-args make-method-call flatten-args make-method-call
make-method-call-to-possibly-wrapped-object
do-localize make-private-name do-localize make-private-name
generate-super-call generate-inner-call generate-super-call generate-inner-call
generate-class-expand-context class-top-level-context?)) generate-class-expand-context class-top-level-context?))