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

ffi/com: fix interaction with `racket/gui'

Browse Source 
... and other things that use the Windows message
queue by not providing GCable arguments to
IDispatch::Invoke().

Merge to v5.3
(cherry picked from commit 66eaa191e5)
This commit is contained in:
Matthew Flatt 2012-08-02 19:17:22 -06:00 committed by Ryan Culpepper
parent bfc256270b
commit 76d2de4855
1 changed files with 22 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1606,7 +1606,9 @@
(define (make-a-VARIANT [mode 'atomic-interior]) (define (make-a-VARIANT [mode 'atomic-interior])
(define var (cast (malloc _VARIANT mode) (define var (cast (malloc _VARIANT mode)
_pointer _pointer
(_gcable _VARIANT-pointer))) (if (eq? mode 'raw)
_VARIANT-pointer
(_gcable _VARIANT-pointer))))
(VariantInit var) (VariantInit var)
var) var)
@ -1773,7 +1775,10 @@
(define var (ptr-ref vars _VARIANT (- count i 1))) ; reverse order (define var (ptr-ref vars _VARIANT (- count i 1))) ; reverse order
(VariantInit var) (VariantInit var)
(scheme-to-variant! var a (and func-desc (elem-desc-ref func-desc i)) scheme-type))) (scheme-to-variant! var a (and func-desc (elem-desc-ref func-desc i)) scheme-type)))
(values count (define disp-params (cast (malloc _DISPPARAMS 'raw)
_pointer
_DISPPARAMS-pointer))
(memcpy disp-params
(make-DISPPARAMS vars (make-DISPPARAMS vars
(if (= inv-kind INVOKE_PROPERTYPUT) (if (= inv-kind INVOKE_PROPERTYPUT)
prop-put-long prop-put-long
@ -1782,7 +1787,10 @@
(if (= inv-kind INVOKE_PROPERTYPUT) (if (= inv-kind INVOKE_PROPERTYPUT)
count count
0)) 0))
(unbox cleanup) (ctype-sizeof _DISPPARAMS))
(values count
disp-params
(cons (lambda () (free disp-params)) (unbox cleanup))
(unbox commit))) (unbox commit)))
(define (variant-to-scheme var) (define (variant-to-scheme var)
@ -1840,7 +1848,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 commits) (define-values (num-params-passed method-arguments arg-cleanups commits)
(build-method-arguments type-desc (build-method-arguments type-desc
(cadr t) (cadr t)
inv-kind inv-kind
@ -1855,12 +1863,19 @@
(variant-to-scheme (ptr-ref (DISPPARAMS-rgvarg method-arguments) (variant-to-scheme (ptr-ref (DISPPARAMS-rgvarg method-arguments)
_VARIANT _VARIANT
i)))))) i))))))
(define method-result (define-values (method-result cleanups)
(if (= inv-kind INVOKE_PROPERTYPUT) (if (= inv-kind INVOKE_PROPERTYPUT)
#f (values #f arg-cleanups)
(make-a-VARIANT 'atomic))) (let ([r (make-a-VARIANT 'raw)])
(values r (cons (lambda () (free r))
arg-cleanups)))))
(for ([proc (in-list commits)]) (proc)) (for ([proc (in-list commits)]) (proc))
(define-values (hr exn-info error-index) (define-values (hr exn-info error-index)
;; Note that all arguments to `Invoke' should
;; not be movable by a GC. A call to `Invoke'
;; may use the Windows message queue, and other
;; libraries (notably `racket/gui') may have
;; callbacks triggered via messages.
(Invoke (com-object-get-dispatch obj) (Invoke (com-object-get-dispatch obj)
memid IID_NULL LOCALE_SYSTEM_DEFAULT memid IID_NULL LOCALE_SYSTEM_DEFAULT
inv-kind method-arguments inv-kind method-arguments