From 9b1db143283a96c548c33e04260e3379a2fbcebd Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 29 Jul 2012 06:52:47 -0600
Subject: [PATCH] ffi/com: fix clean-up of type descriptors

Merge to v5.3
---
 collects/ffi/unsafe/com.rkt   | 57 ++++++++++++++++++++++-------------
 collects/tests/racket/com.rkt |  4 +++
 2 files changed, 40 insertions(+), 21 deletions(-)

diff --git a/collects/ffi/unsafe/com.rkt b/collects/ffi/unsafe/com.rkt
index 5fa6b43a22..190ed51e23 100644
--- a/collects/ffi/unsafe/com.rkt
+++ b/collects/ffi/unsafe/com.rkt
@@ -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)
diff --git a/collects/tests/racket/com.rkt b/collects/tests/racket/com.rkt
index 9aa04d8578..ddca96bc06 100644
--- a/collects/tests/racket/com.rkt
+++ b/collects/tests/racket/com.rkt
@@ -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))