Added pseudo type 'referenced' and a few other changes

diff --git a/glib/gobject.lisp b/glib/gobject.lisp
index 50c29585efc9cf5741677d3e340f9e1371db450b..7eb4b4122064c2fa13da9c40221a70585767156b 100644 (file)
--- a/glib/gobject.lisp
+++ b/glib/gobject.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gobject.lisp,v 1.24 2004-12-21 00:04:48 espen Exp $
+;; $Id: gobject.lisp,v 1.25 2004-12-28 20:29:05 espen Exp $
 
 (in-package "GLIB")
 
@@ -103,7 +103,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de
        (let ((reader nil))
         #'(lambda (object)
             (unless reader
-              (setq reader (reader-function (type-from-number type-number))))
+              (setq reader (reader-function type))) ;(type-from-number type-number))))
             (let ((gvalue (gvalue-new type-number)))
               (%object-get-property object pname gvalue)
               (unwind-protect
@@ -116,7 +116,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de
        (let ((writer nil))
         #'(lambda (value object)
             (unless writer
-              (setq writer (writer-function (type-from-number type-number))))
+              (setq writer (writer-function type))) ;(type-from-number type-number))))
             (let ((gvalue (gvalue-new type-number)))
               (funcall writer value gvalue +gvalue-value-offset+)
               (%object-set-property object pname gvalue)
@@ -314,10 +314,8 @@ (defun slot-definition-from-property (class property &optional args)
       `(,slot-name
        :allocation :property :pname ,name
 
-       ;; temporary hack
        ,@(cond
-          ((find :unbound args) (list :unbound (getf args :unbound)))
-          ((type-is-p slot-type 'gobject) (list :unbound nil)))
+          ((find :unbound args) (list :unbound (getf args :unbound))))
        
        ;; accessors
        ,@(cond
@@ -380,3 +378,24 @@ (defun expand-gobject-type (type &optional options (metaclass 'gobject-class))
 
 
 (register-derivable-type 'gobject "GObject" 'expand-gobject-type)
+
+
+;;; Pseudo type for gobject instances which have their reference count
+;;; increased by the returning function
+
+(defmethod alien-type ((type (eql 'referenced)) &rest args)
+  (declare (ignore type args))
+  (alien-type 'gobject))
+
+(defmethod from-alien-form (form (type (eql 'referenced)) &rest args)
+  (declare (ignore type))
+  (destructuring-bind (type) args
+    (if (subtypep type 'gobject)
+       (let ((instance (make-symbol "INSTANCE")))
+         `(let ((,instance ,(from-alien-form form type)))
+            (when ,instance
+              (%object-unref (proxy-location ,instance)))
+            ,instance))
+      (error "~A is not a subclass of GOBJECT" type))))
+
+(export 'referenced)