(defvar *foreign-gobjects-strong* (make-hash-table :test 'equal))
(defvar *current-creating-object* nil)
(defvar *current-object-from-pointer* nil)
+(defvar *currently-making-object-p* nil)
+
+(at-finalize ()
+ (clrhash *foreign-gobjects-weak*)
+ (clrhash *foreign-gobjects-strong*)
+ (setf *current-creating-object* nil
+ *current-object-from-pointer* nil
+ *currently-making-object-p* nil))
(defun ref-count (pointer)
(foreign-slot-value (if (pointerp pointer) pointer (pointer pointer)) 'g-object-struct :ref-count))
+(defmethod release ((obj g-object))
+ (cancel-finalization obj)
+ (let ((p (pointer obj)))
+ (setf (pointer obj) nil)
+ (g-object-dispose-carefully p)))
+
(defmethod initialize-instance :around ((obj g-object) &key)
+ (when *currently-making-object-p*
+ (setf *currently-making-object-p* t))
(let ((*current-creating-object* obj))
+ (log-for :subclass "initialize-instance :around; *current-creating-object* = ~A~%" obj)
(call-next-method)))
(defmethod initialize-instance :after ((obj g-object) &key &allow-other-keys)
(make-instance lisp-type :pointer pointer))))
(define-foreign-type foreign-g-object-type ()
- ((sub-type :reader sub-type :initarg :sub-type :initform 'g-object))
+ ((sub-type :reader sub-type :initarg :sub-type :initform 'g-object)
+ (already-referenced :reader foreign-g-object-type-already-referenced :initarg :already-referenced :initform nil))
(:actual-type :pointer))
-(define-parse-method g-object (&optional (sub-type 'g-object))
- (make-instance 'foreign-g-object-type :sub-type sub-type))
+(define-parse-method g-object (&rest args)
+ (let* ((sub-type (first (remove-if #'keywordp args)))
+ (flags (remove-if-not #'keywordp args))
+ (already-referenced (not (null (find :already-referenced flags)))))
+ (make-instance 'foreign-g-object-type :sub-type sub-type :already-referenced already-referenced)))
(defmethod translate-to-foreign (object (type foreign-g-object-type))
(cond
((null (pointer object))
(error "Object ~A has been disposed" object))
((typep object 'g-object)
- (assert (typep object (sub-type type))
- nil
- "Object ~A is not a subtype of ~A" object (sub-type type))
+ (when (sub-type type)
+ (assert (typep object (sub-type type))
+ nil
+ "Object ~A is not a subtype of ~A" object (sub-type type)))
(pointer object))
(t (error "Object ~A is not translatable as GObject*" object))))
(make-g-object-from-pointer pointer)))))
(defmethod translate-from-foreign (pointer (type foreign-g-object-type))
- (get-g-object-for-pointer pointer))
+ (let ((object (get-g-object-for-pointer pointer)))
+ (when (foreign-g-object-type-already-referenced type)
+ (g-object-unref (pointer object)))
+ object))
(register-object-type "GObject" 'g-object)