ffi/com: fix clean-up of type descriptors
Merge to v5.3
This commit is contained in:
parent
9815822255
commit
9b1db14328
|
@ -247,12 +247,21 @@
|
|||
[(_ (#:release-with-method name) expr obj arg ...)
|
||||
(let ([self obj])
|
||||
(((allocator (lambda (v) (name self v)))
|
||||
expr)
|
||||
(let ([f expr])
|
||||
(lambda args
|
||||
(AddRef self)
|
||||
(apply f args))))
|
||||
self
|
||||
arg ...))]
|
||||
[(_ (#:releases) expr arg ...)
|
||||
(((deallocator cadr) expr) arg ...)]))
|
||||
|
||||
[(_ (#:releases) expr obj arg ...)
|
||||
(let ([self obj])
|
||||
(((deallocator cadr)
|
||||
(let ([f expr])
|
||||
(lambda args
|
||||
(Release self)
|
||||
(apply f args))))
|
||||
self arg ...))]))
|
||||
|
||||
(define (check-com-type who id id? obj)
|
||||
(unless (id? obj)
|
||||
(raise-type-error who (symbol->string id) obj)))
|
||||
|
@ -630,9 +639,27 @@
|
|||
set-com-object-connection-point!)
|
||||
(bye! com-object-sink
|
||||
set-com-object-sink!)
|
||||
(when (hash-count (com-object-types obj))
|
||||
(when (positive? (hash-count (com-object-types obj)))
|
||||
(for ([td (in-hash-values (com-object-types obj))])
|
||||
'(release-type-desc td))
|
||||
(set-com-object-types! obj (make-hash))))))
|
||||
|
||||
(define (release-type-desc td)
|
||||
;; call in atomic mode
|
||||
(define type-info (mx-com-type-desc-type-info td))
|
||||
(define type-info-impl (mx-com-type-desc-type-info-impl td))
|
||||
(define tdd (mx-com-type-desc-desc td))
|
||||
(cond
|
||||
[(list? tdd)
|
||||
(ReleaseFuncDesc type-info (car tdd))
|
||||
(when type-info-impl
|
||||
(ReleaseFuncDesc type-info-impl (cadr tdd)))]
|
||||
[else
|
||||
(ReleaseVarDesc type-info tdd)])
|
||||
(Release type-info)
|
||||
(when type-info-impl
|
||||
(Release type-info-impl)))
|
||||
|
||||
(define (gen->clsid who name)
|
||||
(cond
|
||||
[(clsid? name) name]
|
||||
|
@ -876,12 +903,9 @@
|
|||
string-ci<?)
|
||||
(ReleaseTypeAttr event-type-info type-attr)))
|
||||
|
||||
(struct mx-com-type-desc ([released? #:mutable]
|
||||
memid
|
||||
(struct mx-com-type-desc (memid
|
||||
type-info
|
||||
type-info-impl
|
||||
interface
|
||||
fun-ptr
|
||||
fun-offset
|
||||
impl-guid
|
||||
desc))
|
||||
|
@ -934,16 +958,13 @@
|
|||
[(mx-com-type-desc? found) found]
|
||||
[(not found) #f]
|
||||
[(VARDESC? found)
|
||||
(mx-com-type-desc #f
|
||||
(VARDESC-memid found)
|
||||
(mx-com-type-desc (VARDESC-memid found)
|
||||
(begin
|
||||
(AddRef type-info)
|
||||
type-info)
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
found)]
|
||||
[else
|
||||
(define ref-type (with-handlers ([exn:fail? (lambda (x) #f)])
|
||||
|
@ -963,16 +984,13 @@
|
|||
(begin0
|
||||
(if (or (= (FUNCDESC-funckind func-desc-impl) FUNC_VIRTUAL)
|
||||
(= (FUNCDESC-funckind func-desc-impl) FUNC_PUREVIRTUAL))
|
||||
(mx-com-type-desc #f
|
||||
(FUNCDESC-memid (car found))
|
||||
(mx-com-type-desc (FUNCDESC-memid (car found))
|
||||
(begin
|
||||
(AddRef type-info)
|
||||
type-info)
|
||||
(begin
|
||||
(AddRef type-info-impl)
|
||||
type-info-impl)
|
||||
#f
|
||||
#f
|
||||
(quotient (FUNCDESC-oVft func-desc-impl) (ctype-sizeof _pointer))
|
||||
(copy-guid (TYPEATTR-guid type-attr-impl))
|
||||
(list (car found)
|
||||
|
@ -984,16 +1002,13 @@
|
|||
(Release type-info-impl))))
|
||||
|
||||
(or mx-type-desc
|
||||
(mx-com-type-desc #f
|
||||
(FUNCDESC-memid (car found))
|
||||
(mx-com-type-desc (FUNCDESC-memid (car found))
|
||||
(begin
|
||||
(AddRef type-info)
|
||||
type-info)
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
(list (car found) #f)))]))
|
||||
|
||||
(define (event-type-info-from-com-type obj)
|
||||
|
|
|
@ -133,6 +133,10 @@
|
|||
(test '(-> () string) (com-get-property-type doc "title"))
|
||||
(test '(-> (string) void) (com-set-property-type doc "title"))
|
||||
|
||||
(test (void) (com-set-property! ie "Visible" #t))
|
||||
(test (void) (com-invoke ie "Quit"))
|
||||
|
||||
(test (void) (com-release doc))
|
||||
(test (void) (com-release ie))
|
||||
|
||||
(test #t (type-description? 'int))
|
||||
|
|
Loading…
Reference in New Issue
Block a user