From 533f953b4dd068e1c76c67e7c27e820606f649bf Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Sat, 4 Aug 2007 14:20:27 +0200
Subject: CMUCL compatibility.

darcs-hash:f82c7674248388347ac58aabef930fb2b77f3364
---
 objcl.lisp | 70 +++++++++++++++++++++++++++++++++++++++++++++++---------------
 1 file changed, 53 insertions(+), 17 deletions(-)

diff --git a/objcl.lisp b/objcl.lisp
index 609b88f..44467e8 100644
--- a/objcl.lisp
+++ b/objcl.lisp
@@ -51,23 +51,49 @@
                       (objcl-invoke-class-method condition "reason")
                       "UTF8String")))))
 
-(defvar *skip-finalization* nil)
-(defvar *skip-retaining*    nil)
 
-(defvar *id-objects*
-  (trivial-garbage:make-weak-hash-table :weakness :value
-                                        :test 'eql))
+#+cmu
+(progn
+  (declaim (inline make-weak-value-hash-table))
+
+  (defun make-weak-value-hash-table ()
+    (make-hash-table :test 'eql))
+
+  (defun weak-gethash (key hash-table &optional (default nil))
+    (let ((pointer (gethash key hash-table default)))
+      (or (and (trivial-garbage:weak-pointer-p pointer)
+               (trivial-garbage:weak-pointer-value pointer))
+          (prog1 default
+            ;; Clean up.
+            (remhash key hash-table)))))
+
+  (defun (setf weak-gethash) (value key hash-table)
+    (setf (gethash key hash-table)
+          (trivial-garbage:make-weak-pointer value))))
+
+#-cmu
+(progn
+  (declaim (inline make-weak-value-hash-table))
 
-(defvar *class-objects*
-  (trivial-garbage:make-weak-hash-table :weakness :value
-                                        :test 'eql))
+  (defun make-weak-value-hash-table ()
+    (trivial-garbage:make-weak-hash-table :weakness :value
+                                          :test 'eql))
+
+  (setf (fdefinition 'weak-gethash)        (fdefinition 'gethash)
+        (fdefinition '(setf weak-gethash)) (fdefinition '(setf gethash))))
+
+
+(defvar *skip-finalization* nil)
+(defvar *skip-retaining*    nil)
 
-(defvar *exception-objects*
-  (trivial-garbage:make-weak-hash-table :weakness :value
-                                        :test 'eql))
+(defvar *id-objects* (make-weak-value-hash-table))
+(defvar *class-objects* (make-weak-value-hash-table))
+(defvar *exception-objects* (make-weak-value-hash-table))
 
-;; We call the `retain' method on every object that is garbage collected
-;; on our side.  Upon finalization, wie `release' it.
+;; We call the `retain' method on every object that we receive from a
+;; method call or otherwise except non-convenience constructor methods
+;; (i.e. those whose name starts with `alloc' or `new').  Upon
+;; Lisp-side finalization of an object, wie `release' it.
 (eval-when (:load-toplevel)
   (dolist (type '(objc-id objc-class objc-exception))
     (funcall
@@ -75,19 +101,19 @@
       nil
       `(lambda ()
          (defmethod make-instance ((class (eql ',type)) &rest initargs &key)
-           (let* ((hash-table ,(case type
+           (let* ((hash-table ,(ecase type
                                  ((objc-id)        '*id-objects*)
                                  ((objc-class)     '*class-objects*)
                                  ((objc-exception) '*exception-objects*)))
                   (hash-key (pointer-address (getf initargs :pointer)))
-                  (obj (gethash hash-key hash-table nil)))
+                  (obj (weak-gethash hash-key hash-table nil)))
              (typecase obj
                (keyword (assert (eq :incomplete obj))
                         (call-next-method))
-               (null (setf (gethash hash-key hash-table)
+               (null (setf (weak-gethash hash-key hash-table)
                            :incomplete)
                      (let ((new-obj (call-next-method)))
-                       (setf (gethash hash-key hash-table) new-obj)
+                       (setf (weak-gethash hash-key hash-table) new-obj)
                        (unless *skip-retaining*
                          (objcl-invoke-class-method new-obj "retain"))
                        (unless *skip-finalization*
@@ -95,6 +121,16 @@
                          (let ((saved-pointer (pointer-to new-obj))
                                (saved-type    (type-of new-obj)))
                            (flet ((finalizer ()
+                                    ;; In order to send the `release'
+                                    ;; message to the newly GC'd object,
+                                    ;; we have to create a temporary
+                                    ;; container object for the final
+                                    ;; message delivery.  Note that this
+                                    ;; can cause an infinite recursion
+                                    ;; or even memory corruption if we
+                                    ;; don't take measure to skip both
+                                    ;; finalization and retaining of the
+                                    ;; temporary object.
                                     (let ((temp (let ((*skip-finalization* t)
                                                       (*skip-retaining*    t))
                                                   (make-instance saved-type
-- 
cgit v1.2.3