summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libobjcl.m5
-rw-r--r--objcl.lisp69
2 files changed, 52 insertions, 22 deletions
diff --git a/libobjcl.m b/libobjcl.m
index a32ea1f..41d165c 100644
--- a/libobjcl.m
+++ b/libobjcl.m
@@ -178,7 +178,7 @@ objcl_invoke_instance_method (OBJCL_OBJ_DATA receiver,
NS_DURING
{
- fprintf (stderr, "! ---------> %s <--------\n", receiver->type);
+ /* fprintf (stderr, "! ---------> %s <--------\n", receiver->type); */
assert (receiver->type[0] == '#'
|| receiver->type[0] == '@'
|| receiver->type[0] == 'E');
@@ -225,6 +225,7 @@ objcl_invoke_class_method (OBJCL_OBJ_DATA class,
NS_DURING
{
+ /* fprintf (stderr, "? ---------> %s <--------\n", class->type); */
assert (class->type[0] == '#'
|| class->type[0] == '@'
|| class->type[0] == 'E');
@@ -278,7 +279,7 @@ objcl_class_name (OBJCL_OBJ_DATA class)
{
Class cls = NULL;
- fprintf (stderr, "---------> %s <--------\n", class->type);
+ /* fprintf (stderr, "---------> %s <--------\n", class->type); */
fflush (stderr);
assert (class->type[0] == '#'
|| class->type[0] == '@'
diff --git a/objcl.lisp b/objcl.lisp
index 1684ba0..7027bd1 100644
--- a/objcl.lisp
+++ b/objcl.lisp
@@ -29,7 +29,8 @@
(defclass c-pointer-wrapper ()
((pointer :type c-pointer
:reader pointer-to
- :initarg :pointer)))
+ :initarg :pointer
+ :initform nil)))
(defclass objc-selector (c-pointer-wrapper) ())
@@ -56,28 +57,57 @@
(defvar *skip-finalization* nil)
(defvar *skip-retaining* nil)
+(defvar *id-objects*
+ (trivial-garbage:make-weak-hash-table :weakness :value
+ :test 'eql))
+
+(defvar *class-objects*
+ (trivial-garbage:make-weak-hash-table :weakness :value
+ :test 'eql))
+
+(defvar *exception-objects*
+ (trivial-garbage:make-weak-hash-table :weakness :value
+ :test 'eql))
+
;; We call the `retain' method on every object that is garbage collected
;; on our side. Upon finalization, wie `release' it.
(eval-when (:load-toplevel)
(dolist (type '(objc-id objc-class objc-exception))
(funcall
- (compile nil
- `(lambda ()
- (defmethod initialize-instance ((obj ,type) &key)
- (call-next-method)
- (unless *skip-retaining*
- (let ((*skip-retaining* t))
- (objcl-invoke-class-method obj "retain")))
- (unless *skip-finalization*
- (assert (not (null (pointer-to obj))))
- (let ((saved-pointer (pointer-to obj))
- (saved-type (type-of obj)))
- (flet ((finalizer ()
- (let ((temp (let ((*skip-finalization* t))
- (make-instance saved-type
- :pointer saved-pointer))))
- (objcl-invoke-class-method temp "release"))))
- (trivial-garbage:finalize obj #'finalizer))))))))))
+ (compile
+ nil
+ `(lambda ()
+ (defmethod make-instance ((class (eql ',type)) &rest initargs &key)
+ (let* ((hash-table ,(case 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)))
+ (typecase obj
+ (keyword (assert (eq :incomplete obj))
+ (call-next-method))
+ (null (setf (gethash hash-key hash-table)
+ :incomplete)
+ (let ((new-obj (call-next-method)))
+ (setf (gethash hash-key hash-table) new-obj)
+ (unless *skip-retaining*
+ (objcl-invoke-class-method new-obj "retain"))
+ (unless *skip-finalization*
+ (assert (not (null (pointer-to new-obj))))
+ (let ((saved-pointer (pointer-to new-obj))
+ (saved-type (type-of new-obj)))
+ (flet ((finalizer ()
+ (let ((temp (let ((*skip-finalization* t))
+ (make-instance saved-type
+ :pointer saved-pointer))))
+ (objcl-invoke-class-method temp "release"))))
+ (trivial-garbage:finalize new-obj #'finalizer))))
+ new-obj))
+ (t obj))))
+
+ (defmethod initialize-instance ((obj ,type) &key)
+ (call-next-method)))))))
(defgeneric objcl-eql (obj1 obj2))
@@ -330,8 +360,7 @@
(string (foreign-string-alloc value))
(otherwise value)))
(setf type
- (foreign-string-alloc (type-name->type-id type-name)))
- #+nil (print (foreign-string-to-lisp type)))
+ (foreign-string-alloc (type-name->type-id type-name))))
obj-data))