X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/a5c3a5974e1ae2bd11b2a381850639586e466469..58ddfaacc6d76829342be5712a7d92af1d597091:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index aa59439..6da4db0 100644 --- a/glib/gobject.lisp +++ b/glib/gobject.lisp @@ -15,161 +15,47 @@ ;; 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.16 2004/11/03 16:18:16 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") - (:copy %object-ref) - (:free %object-unref))) - - -(defmethod initialize-instance ((object gobject) &rest initargs) - (let ((slotds (class-slots (class-of object))) - (names (make-array 0 :adjustable t :fill-pointer t)) - (values (make-array 0 :adjustable t :fill-pointer t))) - - (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)) - do (let ((type (find-type-number (slot-definition-type slotd)))) - (vector-push-extend (slot-definition-pname slotd) names) - (vector-push-extend (gvalue-new type value) values) - (remf initargs key))) - - (setf - (slot-value object 'location) - (if (zerop (length names)) - (%gobject-new (type-number-of object)) - (%gobject-newvv (type-number-of object) (length names) names values))) - -; (map 'nil #'gvalue-free values) - ) - - (%object-weak-ref object) - (apply #'call-next-method object initargs)) - - -(defmethod initialize-proxy ((object gobject) &rest initargs &key weak-ref) - (declare (ignore initargs)) - (call-next-method) - (%object-weak-ref object) - (unless weak-ref - (object-ref object))) - -(def-callback weak-notify (void (data int) (location system-area-pointer)) - (when (instance-cached-p location) - (warn "~A being finalized by the GObject system while still in existence in lisp" (find-cached-instance location)) - (remove-cached-instance location))) - -(defbinding %object-weak-ref (object) nil - (object gobject) - ((callback weak-notify) pointer) - (0 unsigned-int)) +;;;; Metaclass used for subclasses of gobject +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass gobject-class (ginstance-class) + ()) -(defbinding (%gobject-new "g_object_new") () pointer - (type type-number) - (nil null)) + (defmethod validate-superclass ((class gobject-class) + (super pcl::standard-class)) +; (subtypep (class-name super) 'gobject) + t)) -(defbinding (%gobject-newvv "g_object_newvv") () pointer - (type type-number) - (n-parameters unsigned-int) - (names (vector string)) - (values (vector gvalue))) +(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 (type location) pointer +(defbinding %object-ref () pointer (location pointer)) - (defbinding %object-unref (type location) nil - (location pointer)) - -(defun object-ref (object) - (%object-ref nil (proxy-location object))) - -(defun object-unref (object) - (%object-unref nil (proxy-location object))) - - - -;;;; 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) - (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))) +(defbinding %object-unref () nil + (location pointer)) - (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)))) +(defmethod reference-foreign ((class gobject-class) location) + (declare (ignore class)) + (%object-ref location)) +(defmethod unreference-foreign ((class gobject-class) location) + (declare (ignore class)) + (%object-unref location)) ; (defbinding object-class-install-param () nil @@ -215,14 +101,13 @@ (setf (slot-value slotd 'reader-function) (if (slot-readable-p slotd) - #'(lambda (object) - (with-gc-disabled - (let ((gvalue (gvalue-new type-number))) - (%object-get-property object pname gvalue) - (unwind-protect - (funcall - (intern-reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) ; temporary workaround for wrong topological sorting of types - (gvalue-free gvalue t))))) + (let () ;(reader (reader-function (type-from-number type-number)))) + #'(lambda (object) + (let ((gvalue (gvalue-new type-number))) + (%object-get-property object pname gvalue) + (unwind-protect + (funcall #|reader|# (reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) + (gvalue-free gvalue t))))) #'(lambda (value object) (error "Slot is not readable: ~A" (slot-definition-name slotd)))))) @@ -230,18 +115,15 @@ (setf (slot-value slotd 'writer-function) (if (slot-writable-p slotd) - #'(lambda (value object) - (with-gc-disabled - (let ((gvalue (gvalue-new type-number))) - (funcall - (intern-writer-function (type-from-number type-number)) ; temporary - value gvalue +gvalue-value-offset+) - (%object-set-property object pname gvalue) - (funcall - (intern-destroy-function (type-from-number type-number)) ; temporary - gvalue +gvalue-value-offset+) - (gvalue-free gvalue nil) - value))) + (let ();; (writer (writer-function (type-from-number type-number))) +;; (destroy (destroy-function (type-from-number type-number)))) + #'(lambda (value object) + (let ((gvalue (gvalue-new type-number))) + (funcall #|writer|# (writer-function (type-from-number type-number)) value gvalue +gvalue-value-offset+) + (%object-set-property object pname gvalue) +; (funcall #|destroy|#(destroy-function (type-from-number type-number)) gvalue +gvalue-value-offset+) + (gvalue-free gvalue t) + value))) #'(lambda (value object) (error "Slot is not writable: ~A" (slot-definition-name slotd)))))) @@ -254,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)))) ;;;; @@ -270,9 +265,9 @@ (defun %map-params (params length type inherited-p) (if inherited-p - (map-c-array 'list #'identity params 'param length) + (map-c-vector 'list #'identity params 'param length) (let ((properties ())) - (map-c-array 'list + (map-c-vector 'list #'(lambda (param) (when (eql (param-owner-type param) type) (push param properties)))