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

ffi/com: fix clean-up of type descriptors

Browse Source 
Merge to v5.3
This commit is contained in:
Matthew Flatt 2012-07-29 06:52:47 -06:00
parent 9815822255
commit 9b1db14328
2 changed files with 40 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
collects/ffi/unsafe/com.rkt
View File

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

4
collects/tests/racket/com.rkt
View File

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