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

ffi/com: AddRef on IUnknown arguments to COM methods

Browse Source 
Merge to v5.3
This commit is contained in:
Matthew Flatt 2012-07-23 10:03:28 -05:00
parent ea1636d4f1
commit cd90510f07
1 changed files with 26 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -132,12 +132,18 @@
(lambda (p) (cast p _pointer _string/utf-16)))) (lambda (p) (cast p _pointer _string/utf-16))))
(define current-cleanup (make-parameter #f)) (define current-cleanup (make-parameter #f))
(define current-commit (make-parameter #f))
(define (register-cleanup! proc) (define (register-cleanup! proc)
(let ([c (current-cleanup)]) (let ([c (current-cleanup)])
(when c (when c
(set-box! c (cons proc (unbox c)))))) (set-box! c (cons proc (unbox c))))))
(define (register-commit! proc)
(let ([c (current-commit)])
(when c
(set-box! c (cons proc (unbox c))))))
;; ---------------------------------------- ;; ----------------------------------------
;; Describing COM interfaces for direct calls ;; Describing COM interfaces for direct calls
@ -285,12 +291,14 @@
refiid)) refiid))
(and p (cast p _pointer _type))))) (and p (cast p _pointer _type)))))
(define AddRef/no-release
(lambda (obj)
(check-com-type 'AddRef 'IUknown IUnknown? obj)
((IUnknown_vt-AddRef (cast (IUnknown-vt obj) _pointer _IUnknown_vt-pointer))
obj)))
(define AddRef (define AddRef
((retainer Release) ((retainer Release) AddRef/no-release))
(lambda (obj)
(check-com-type 'AddRef 'IUknown IUnknown? obj)
((IUnknown_vt-AddRef (cast (IUnknown-vt obj) _pointer _IUnknown_vt-pointer))
obj))))
;; -------------------------------------------------- ;; --------------------------------------------------
;; IDispatch ;; IDispatch
@ -1591,9 +1599,12 @@
(make-ctype (make-ctype
_IUnknown-pointer _IUnknown-pointer
(lambda (v) (lambda (v)
(if (com-object? v) (define p
(com-object-get-iunknown v) (if (com-object? v)
v)) (com-object-get-iunknown v)
v))
(register-commit! (lambda () (AddRef/no-release p)))
p)
(lambda (p) (lambda (p)
(((allocator Release) (lambda () p))) (((allocator Release) (lambda () p)))
(define obj (make-com-object p #f)) (define obj (make-com-object p #f))
@ -1691,7 +1702,9 @@
(define cleanup (box (if vars (define cleanup (box (if vars
(list (lambda () (free vars))) (list (lambda () (free vars)))
null))) null)))
(parameterize ([current-cleanup cleanup]) (define commit (box null))
(parameterize ([current-cleanup cleanup]
[current-commit commit])
(for ([i (in-range count)] (for ([i (in-range count)]
[a (in-sequences (in-list args) [a (in-sequences (in-list args)
(in-cycle (list com-omit)))] (in-cycle (list com-omit)))]
@ -1708,7 +1721,8 @@
(if (= inv-kind INVOKE_PROPERTYPUT) (if (= inv-kind INVOKE_PROPERTYPUT)
count count
0)) 0))
(unbox cleanup))) (unbox cleanup)
(unbox commit)))
(define (variant-to-scheme var) (define (variant-to-scheme var)
(define _t (to-ctype (vt-to-scheme-type (VARIANT-vt var)))) (define _t (to-ctype (vt-to-scheme-type (VARIANT-vt var))))
@ -1761,7 +1775,7 @@
(mx-com-type-desc-memid type-desc) (mx-com-type-desc-memid type-desc)
(find-memid who obj name)) (find-memid who obj name))
=> (lambda (memid) => (lambda (memid)
(define-values (num-params-passed method-arguments cleanups) (define-values (num-params-passed method-arguments cleanups commits)
(build-method-arguments type-desc (build-method-arguments type-desc
(cadr t) (cadr t)
inv-kind inv-kind
@ -1780,6 +1794,7 @@
(if (= inv-kind INVOKE_PROPERTYPUT) (if (= inv-kind INVOKE_PROPERTYPUT)
#f #f
(make-a-VARIANT 'atomic))) (make-a-VARIANT 'atomic)))
(for ([proc (in-list commits)]) (proc))
(define-values (hr exn-info error-index) (define-values (hr exn-info error-index)
(Invoke (com-object-get-dispatch obj) (Invoke (com-object-get-dispatch obj)
memid IID_NULL LOCALE_SYSTEM_DEFAULT memid IID_NULL LOCALE_SYSTEM_DEFAULT