X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/8755b1a5d37f2f4b853c01f0d8b121ab9ee4093a..e74cfcab32b6d3328acdad68b4acc087c6375fb6:/glib/gobject.lisp

diff --git a/glib/gobject.lisp b/glib/gobject.lisp
index 0985786..f888cc6 100644
--- a/glib/gobject.lisp
+++ b/glib/gobject.lisp
@@ -15,166 +15,33 @@
 ;; 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.18 2004-11-07 01:23:38 espen Exp $
+;; $Id: gobject.lisp,v 1.22 2004-11-12 14:24:17 espen Exp $
 
 (in-package "GLIB")
 
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defclass gobject (ginstance)
-    ()
-    (:metaclass ginstance-class)
-    (:alien-name "GObject")))
-
-(defmethod print-object ((instance gobject) stream)
-  (print-unreadable-object (instance stream :type t :identity nil)
-    (if (slot-boundp instance 'location)
-	(format stream "at 0x~X" (sap-int (proxy-location instance)))
-      (write-string "(destroyed)" stream))))
-
-
-(defmethod initialize-instance ((object gobject) &rest initargs)
-  ;; Extract initargs which we should pass directly to the GObeject
-  ;; constructor
-  (let* ((slotds (class-slots (class-of object)))
-	 (args (loop 
-		as tmp = initargs then (cddr tmp) while tmp
-		as key = (first tmp)
-		as value = (second tmp)
-		as slotd = (find-if
-			    #'(lambda (slotd)
-				(member key (slot-definition-initargs slotd)))
-			    slotds)
-		when (and (typep slotd 'effective-property-slot-definition)
-			  (slot-value slotd 'construct))
-		collect (progn 
-			  (remf initargs key)
-			  (list 
-			   (slot-definition-pname slotd)
-			   (slot-definition-type slotd)
-			   value)))))
-    (if args
-	(let* ((string-size (size-of 'string))
-	       (string-writer (writer-function 'string))
-	       (string-destroy (destroy-function 'string))
-	       (params (allocate-memory 
-			(* (length args) (+ string-size +gvalue-size+)))))
-	  (loop
-	   for (pname type value) in args
-	   as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
-	   do (funcall string-writer pname tmp)
-	   (gvalue-init (sap+ tmp string-size) type value))
-	  (unwind-protect
-	       (setf  
-		(slot-value object 'location) 
-		(%gobject-newv (type-number-of object) (length args) params))
-	    (loop
-	     repeat (length args)
-	     as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
-	     do (funcall string-destroy tmp)
-	     (gvalue-unset (sap+ tmp string-size)))
-	    (deallocate-memory params)))
-	(setf  
-	 (slot-value object 'location) 
-	 (%gobject-new (type-number-of object)))))
-
-  (%object-weak-ref object)
-  (apply #'call-next-method object initargs))
-
-
-(defmethod initialize-instance :around ((object gobject) &rest initargs)
-  (declare (ignore initargs))
-  (call-next-method)
-  (%object-weak-ref object))
-
-
-(defcallback weak-notify (nil (data int) (location pointer))
-  (let ((object (find-cached-instance location)))
-    (when object
-;;       (warn "~A being finalized by the GObject system while still in existence in lisp" object)
-      (slot-makunbound object 'location)
-      (remove-cached-instance location))))
-
-(defbinding %object-weak-ref (object) nil
-  (object gobject)
-  ((callback weak-notify) pointer)
-  (0 unsigned-int))
-
-(defbinding (%gobject-new "g_object_new") () pointer
-  (type type-number)
-  (nil null))
-
-(defbinding (%gobject-newv "g_object_newv") () pointer
-  (type type-number)
-  (n-parameters unsigned-int)
-  (params pointer))
-
-
-
-;;;; Property stuff
-
-(defbinding %object-set-property () nil
-  (object gobject)
-  (name string)
-  (value gvalue))
-
-(defbinding %object-get-property () nil
-  (object gobject)
-  (name string)
-  (value gvalue))
-
-(defbinding %object-notify () nil
-  (object gobject)
-  (name string))
-
-(defbinding object-freeze-notify () nil
-  (object gobject))
-
-(defbinding object-thaw-notify () nil
-  (object gobject))
-
-(defbinding %object-set-qdata-full () nil
-  (object gobject)
-  (id quark)
-  (data unsigned-long)
-  (destroy-marshal pointer))
-
-
-;;;; User data
-
-(defun (setf object-data) (data object key &key (test #'eq))
-  (%object-set-qdata-full
-   object (quark-from-object key :test test)
-   (register-user-data data) (callback %destroy-user-data))
-  data)
-
-(defbinding %object-get-qdata () unsigned-long
-  (object gobject)		 
-  (id quark))
-
-(defun object-data (object key &key (test #'eq))
-  (find-user-data
-   (%object-get-qdata object (quark-from-object key :test test))))
-
-
-
 ;;;; Metaclass used for subclasses of gobject
 
-;(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (:compile-toplevel :load-toplevel :execute)
   (defclass gobject-class (ginstance-class)
     ())
 
-  (defclass direct-property-slot-definition (direct-virtual-slot-definition)
-    ((pname :reader slot-definition-pname :initarg :pname)
-     (readable :initform t :reader slot-readable-p :initarg :readable)
-     (writable :initform t :reader slot-writable-p :initarg :writable)
-     (construct :initform nil :initarg :construct)))
+  (defmethod validate-superclass ((class gobject-class)
+				(super pcl::standard-class))
+;  (subtypep (class-name super) 'gobject)
+    t))
 
-  (defclass effective-property-slot-definition (effective-virtual-slot-definition)
-    ((pname :reader slot-definition-pname :initarg :pname)
-     (readable :reader slot-readable-p :initarg :readable)
-     (writable :reader slot-writable-p :initarg :writable)
-     (construct :initarg :construct)));)
+(defclass direct-property-slot-definition (direct-virtual-slot-definition)
+  ((pname :reader slot-definition-pname :initarg :pname)
+   (readable :initform t :reader slot-readable-p :initarg :readable)
+   (writable :initform t :reader slot-writable-p :initarg :writable)
+   (construct :initform nil :initarg :construct)))
+
+(defclass effective-property-slot-definition (effective-virtual-slot-definition)
+  ((pname :reader slot-definition-pname :initarg :pname)
+   (readable :reader slot-readable-p :initarg :readable)
+   (writable :reader slot-writable-p :initarg :writable)
+   (construct :initarg :construct)));)
 
 (defbinding %object-ref () pointer
   (location pointer))
@@ -269,11 +136,124 @@
   (call-next-method))
 
 
-(defmethod validate-superclass ((class gobject-class)
-				(super pcl::standard-class))
-;  (subtypep (class-name super) 'gobject)
-  t)
+;;;; Super class for all classes in the GObject type hierarchy
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defclass gobject (ginstance)
+    ()
+    (:metaclass gobject-class)
+    (:alien-name "GObject")))
+
+(defmethod initialize-instance ((object gobject) &rest initargs)
+  ;; Extract initargs which we should pass directly to the GObeject
+  ;; constructor
+  (let* ((slotds (class-slots (class-of object)))
+	 (args (when initargs
+		 (loop 
+		  as (key value . rest) = initargs then rest
+		  as slotd = (find-if
+			      #'(lambda (slotd)
+				  (member key (slot-definition-initargs slotd)))
+			      slotds)
+		  when (and (typep slotd 'effective-property-slot-definition)
+			    (slot-value slotd 'construct))
+		  collect (progn 
+			    (remf initargs key)
+			    (list 
+			     (slot-definition-pname slotd)
+			     (slot-definition-type slotd)
+			     value))
+		  while rest))))
+    (if args
+	(let* ((string-size (size-of 'string))
+	       (string-writer (writer-function 'string))
+	       (string-destroy (destroy-function 'string))
+	       (params (allocate-memory 
+			(* (length args) (+ string-size +gvalue-size+)))))
+	  (loop
+	   for (pname type value) in args
+	   as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
+	   do (funcall string-writer pname tmp)
+	   (gvalue-init (sap+ tmp string-size) type value))
+	  (unwind-protect
+	       (setf  
+		(slot-value object 'location) 
+		(%gobject-newv (type-number-of object) (length args) params))
+	    (loop
+	     repeat (length args)
+	     as tmp = params then (sap+ tmp (+ string-size +gvalue-size+))
+	     do (funcall string-destroy tmp)
+	     (gvalue-unset (sap+ tmp string-size)))
+	    (deallocate-memory params)))
+	(setf  
+	 (slot-value object 'location) 
+	 (%gobject-new (type-number-of object)))))
+
+  (apply #'call-next-method object initargs))
+
+
+(defmethod instance-finalizer ((instance gobject))
+  (let ((location (proxy-location instance)))
+    #'(lambda ()
+	(remove-cached-instance location)
+	(%object-unref location))))
+
+
+(defbinding (%gobject-new "g_object_new") () pointer
+  (type type-number)
+  (nil null))
+
+(defbinding (%gobject-newv "g_object_newv") () pointer
+  (type type-number)
+  (n-parameters unsigned-int)
+  (params pointer))
+
+
+
+;;;; Property stuff
+
+(defbinding %object-set-property () nil
+  (object gobject)
+  (name string)
+  (value gvalue))
+
+(defbinding %object-get-property () nil
+  (object gobject)
+  (name string)
+  (value gvalue))
+
+(defbinding %object-notify () nil
+  (object gobject)
+  (name string))
+
+(defbinding object-freeze-notify () nil
+  (object gobject))
+
+(defbinding object-thaw-notify () nil
+  (object gobject))
+
+(defbinding %object-set-qdata-full () nil
+  (object gobject)
+  (id quark)
+  (data unsigned-long)
+  (destroy-marshal pointer))
+
+
+;;;; User data
+
+(defun (setf object-data) (data object key &key (test #'eq))
+  (%object-set-qdata-full
+   object (quark-from-object key :test test)
+   (register-user-data data) (callback %destroy-user-data))
+  data)
+
+(defbinding %object-get-qdata () unsigned-long
+  (object gobject)		 
+  (id quark))
+
+(defun object-data (object key &key (test #'eq))
+  (find-user-data
+   (%object-get-qdata object (quark-from-object key :test test))))
 
 
 ;;;;