projects
/
cl-gtk2.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
b1f9aa6
)
Add :already-referenced flag to g-object foreign type
author
Dmitry Kalyanov
<Kalyanov.Dmitry@gmail.com>
Sun, 6 Sep 2009 13:26:03 +0000
(17:26 +0400)
committer
Dmitry Kalyanov
<Kalyanov.Dmitry@gmail.com>
Sun, 6 Sep 2009 13:26:03 +0000
(17:26 +0400)
glib/gobject.object.high.lisp
patch
|
blob
|
history
diff --git
a/glib/gobject.object.high.lisp
b/glib/gobject.object.high.lisp
index
2a3c751
..
099bf5f
100644
(file)
--- a/
glib/gobject.object.high.lisp
+++ b/
glib/gobject.object.high.lisp
@@
-164,11
+164,15
@@
(make-instance lisp-type :pointer pointer))))
(define-foreign-type foreign-g-object-type ()
(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))
(: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
(defmethod translate-to-foreign (object (type foreign-g-object-type))
(cond
@@
-178,9
+182,10
@@
((null (pointer object))
(error "Object ~A has been disposed" object))
((typep object 'g-object)
((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))))
(pointer object))
(t (error "Object ~A is not translatable as GObject*" object))))
@@
-192,7
+197,10
@@
(make-g-object-from-pointer pointer)))))
(defmethod translate-from-foreign (pointer (type foreign-g-object-type))
(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)
(register-object-type "GObject" 'g-object)