parent
82789a760b
commit
5dc5bd7ae9
|
@ -510,6 +510,27 @@
|
||||||
(test #t pair? (serialize (new s:bad% [foo 10])))
|
(test #t pair? (serialize (new s:bad% [foo 10])))
|
||||||
(err/rt-test (deserialize (serialize (new s:bad% [foo 10]))) exn:fail:object?)
|
(err/rt-test (deserialize (serialize (new s:bad% [foo 10]))) exn:fail:object?)
|
||||||
|
|
||||||
|
;; ----------------------------------------
|
||||||
|
;; Class contracts & serialization
|
||||||
|
|
||||||
|
(define class+contract+serialize-foo<%>
|
||||||
|
(interface ()
|
||||||
|
[foo-method (->m any/c)]))
|
||||||
|
(define-serializable-class* class+contract+serialize-foo% object% (class+contract+serialize-foo<%>)
|
||||||
|
(inspect #f)
|
||||||
|
(init-field [v #hasheq()])
|
||||||
|
(define/public (foo-method)
|
||||||
|
'result)
|
||||||
|
(super-new))
|
||||||
|
|
||||||
|
(let ()
|
||||||
|
(define inst
|
||||||
|
(new class+contract+serialize-foo%))
|
||||||
|
|
||||||
|
(test #t is-a? inst class+contract+serialize-foo%)
|
||||||
|
(test #t is-a? (deserialize (serialize inst)) class+contract+serialize-foo%)
|
||||||
|
(test 'result values (send (deserialize (serialize inst)) foo-method)))
|
||||||
|
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
|
|
||||||
;; Custom deserialize:
|
;; Custom deserialize:
|
||||||
|
|
|
@ -2808,7 +2808,7 @@ last few projections.
|
||||||
(send o internalize args)
|
(send o internalize args)
|
||||||
o))
|
o))
|
||||||
(lambda (args)
|
(lambda (args)
|
||||||
(let ([o (object-make)])
|
(let ([o (make-object-uninitialized c `(class ,name))])
|
||||||
((class-fixup c) o args)
|
((class-fixup c) o args)
|
||||||
o)))
|
o)))
|
||||||
(if (interface-extension? i externalizable<%>)
|
(if (interface-extension? i externalizable<%>)
|
||||||
|
@ -3547,6 +3547,9 @@ An example
|
||||||
(define neg-blame (cadddr info))
|
(define neg-blame (cadddr info))
|
||||||
(contract ctc meth pos-blame neg-blame m #f)))
|
(contract ctc meth pos-blame neg-blame m #f)))
|
||||||
|
|
||||||
|
(define (make-object-uninitialized class blame)
|
||||||
|
(do-make-object blame class 'uninit 'uninit))
|
||||||
|
|
||||||
(define (do-make-object blame class by-pos-args named-args)
|
(define (do-make-object blame class by-pos-args named-args)
|
||||||
(cond
|
(cond
|
||||||
[(impersonator-prop:has-wrapped-class-neg-party? class)
|
[(impersonator-prop:has-wrapped-class-neg-party? class)
|
||||||
|
@ -3585,8 +3588,9 @@ An example
|
||||||
;; Generate correct class by concretizing methods w/interface ctcs
|
;; Generate correct class by concretizing methods w/interface ctcs
|
||||||
(define concrete-class (fetch-concrete-class class blame))
|
(define concrete-class (fetch-concrete-class class blame))
|
||||||
(define o ((class-make-object concrete-class)))
|
(define o ((class-make-object concrete-class)))
|
||||||
|
(unless (eq? by-pos-args 'uninit)
|
||||||
(continue-make-object o concrete-class by-pos-args named-args #t
|
(continue-make-object o concrete-class by-pos-args named-args #t
|
||||||
wrapped-blame wrapped-neg-party init-proj-pairs)
|
wrapped-blame wrapped-neg-party init-proj-pairs))
|
||||||
o)
|
o)
|
||||||
|
|
||||||
(define (get-field-alist obj)
|
(define (get-field-alist obj)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user