X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/9adccb27da69b60d058aa37867d55ea20ecf97ca..eeda1c2da2663832d114329d58e92f77c86cf2fa:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 620b7ba..8292772 100644 --- a/glib/gobject.lisp +++ b/glib/gobject.lisp @@ -15,44 +15,162 @@ ;; 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.17 2004-11-06 21:39:58 espen Exp $ +;; $Id: gobject.lisp,v 1.23 2004-12-16 23:19:17 espen Exp $ (in-package "GLIB") +;;;; Metaclass used for subclasses of gobject + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass gobject-class (ginstance-class) + ()) + + (defmethod validate-superclass ((class gobject-class) + (super pcl::standard-class)) +; (subtypep (class-name super) 'gobject) + t)) + +(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)) + +(defbinding %object-unref () nil + (location pointer)) + +(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 +; (class pointer) +; (id unsigned-int) +; (parameter parameter)) + +; (defbinding object-class-find-param-spec () parameter +; (class pointer) +; (name string)) + +(defun signal-name-to-string (name) + (substitute #\_ #\- (string-downcase (string name)))) + + +(defmethod direct-slot-definition-class ((class gobject-class) &rest initargs) + (case (getf initargs :allocation) + (:property (find-class 'direct-property-slot-definition)) + (t (call-next-method)))) + +(defmethod effective-slot-definition-class ((class gobject-class) &rest initargs) + (case (getf initargs :allocation) + (:property (find-class 'effective-property-slot-definition)) + (t (call-next-method)))) + +(defmethod compute-effective-slot-definition-initargs ((class gobject-class) direct-slotds) + (if (typep (first direct-slotds) 'direct-property-slot-definition) + (nconc + (list :pname (signal-name-to-string + (most-specific-slot-value direct-slotds 'pname)) + :readable (most-specific-slot-value direct-slotds 'readable) + :writable (most-specific-slot-value direct-slotds 'writable) + :construct (most-specific-slot-value direct-slotds 'construct)) + (call-next-method)) + (call-next-method))) + + +(defmethod initialize-internal-slot-functions ((slotd effective-property-slot-definition)) + (let* ((type (slot-definition-type slotd)) + (pname (slot-definition-pname slotd)) + (type-number (find-type-number type))) + (when (and (not (slot-boundp slotd 'getter)) (slot-readable-p slotd)) + (setf + (slot-value slotd 'getter) + (let ((reader nil)) + #'(lambda (object) + (unless reader + (setq reader (reader-function (type-from-number type-number)))) + (let ((gvalue (gvalue-new type-number))) + (%object-get-property object pname gvalue) + (unwind-protect + (funcall reader gvalue +gvalue-value-offset+) + (gvalue-free gvalue t))))))) + + (when (and (not (slot-boundp slotd 'setter)) (slot-writable-p slotd)) + (setf + (slot-value slotd 'setter) + (let ((writer nil)) + #'(lambda (value object) + (unless writer + (setq writer (writer-function (type-from-number type-number)))) + (let ((gvalue (gvalue-new type-number))) + (funcall writer value gvalue +gvalue-value-offset+) + (%object-set-property object pname gvalue) + (gvalue-free gvalue t) + value)))))) + + (call-next-method)) + + +;;;; Super class for all classes in the GObject type hierarchy + (eval-when (:compile-toplevel :load-toplevel :execute) (defclass gobject (ginstance) () - (:metaclass ginstance-class) + (:metaclass gobject-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)))) + +(defun initial-add (object function initargs key pkey) + (loop + as (initarg value . rest) = initargs then rest + do (cond + ((eq initarg key) (funcall function object value)) + ((eq initarg pkey) (mapc #'(lambda (value) + (funcall function object value)) + value))) + while rest)) + +(defun initial-apply-add (object function initargs key pkey) + (initial-add object #'(lambda (object value) + (apply function object (mklist value))) + initargs key pkey)) (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))))) + (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)) @@ -63,7 +181,7 @@ (defmethod initialize-instance ((object gobject) &rest initargs) 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)) + (gvalue-init (sap+ tmp string-size) type value)) (unwind-protect (setf (slot-value object 'location) @@ -72,33 +190,21 @@ (defmethod initialize-instance ((object gobject) &rest initargs) repeat (length args) as tmp = params then (sap+ tmp (+ string-size +gvalue-size+)) do (funcall string-destroy tmp) - (gvalue-unset (sap+ tmp string-size))) + (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)) + (setf + (slot-value object 'location) + (%gobject-new (type-number-of 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)) +(defmethod instance-finalizer ((instance gobject)) + (let ((location (proxy-location instance))) + #'(lambda () + (remove-cached-instance location) + (%object-unref location)))) -(def-callback weak-notify (c-call:void (data c-call:int) (location system-area-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) @@ -157,125 +263,6 @@ (defun object-data (object key &key (test #'eq)) (%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))) - - (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)) - -(defbinding %object-unref () nil - (location pointer)) - -(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 -; (class pointer) -; (id unsigned-int) -; (parameter parameter)) - -; (defbinding object-class-find-param-spec () parameter -; (class pointer) -; (name string)) - -(defun signal-name-to-string (name) - (substitute #\_ #\- (string-downcase (string name)))) - - -(defmethod direct-slot-definition-class ((class gobject-class) &rest initargs) - (case (getf initargs :allocation) - (:property (find-class 'direct-property-slot-definition)) - (t (call-next-method)))) - -(defmethod effective-slot-definition-class ((class gobject-class) &rest initargs) - (case (getf initargs :allocation) - (:property (find-class 'effective-property-slot-definition)) - (t (call-next-method)))) - -(defmethod compute-effective-slot-definition-initargs ((class gobject-class) direct-slotds) - (if (eq (most-specific-slot-value direct-slotds 'allocation) :property) - (nconc - (list :pname (signal-name-to-string - (most-specific-slot-value direct-slotds 'pname)) - :readable (most-specific-slot-value direct-slotds 'readable) - :writable (most-specific-slot-value direct-slotds 'writable) - :construct (most-specific-slot-value direct-slotds 'construct)) - (call-next-method)) - (call-next-method))) - - -(defmethod initialize-internal-slot-functions ((slotd effective-property-slot-definition)) - (let* ((type (slot-definition-type slotd)) - (pname (slot-definition-pname slotd)) - (type-number (find-type-number type))) - (unless (slot-boundp slotd 'reader-function) - (setf - (slot-value slotd 'reader-function) - (if (slot-readable-p slotd) - (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)))))) - - (unless (slot-boundp slotd 'writer-function) - (setf - (slot-value slotd 'writer-function) - (if (slot-writable-p slotd) - (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)))))) - - (unless (slot-boundp slotd 'boundp-function) - (setf - (slot-value slotd 'boundp-function) - #'(lambda (object) - (declare (ignore object)) - t)))) - (call-next-method)) - - -(defmethod validate-superclass ((class gobject-class) - (super pcl::standard-class)) -; (subtypep (class-name super) 'gobject) - t) - - - ;;;; (defbinding %object-class-list-properties () pointer @@ -317,14 +304,19 @@ (defun default-slot-accessor (class-name slot-name type) (if (eq type 'boolean) "-P" "")))) -(defun slot-definition-from-property (class property) +(defun slot-definition-from-property (class property &optional args) (with-slots (name flags value-type documentation) property (let* ((slot-name (default-slot-name name)) - (slot-type (or (type-from-number value-type) value-type)) + (slot-type (or (getf args :type) (type-from-number value-type) value-type)) (accessor (default-slot-accessor class slot-name slot-type))) `(,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))) ;; accessors ,@(cond @@ -359,16 +351,20 @@ (defun slot-definition-from-property (class property) (defun slot-definitions (class properties slots) (loop - with manual-slots = slots for property in properties - unless (find-if - #'(lambda (slot) - (destructuring-bind (name &rest args) slot - (or - (equal (param-name property) (getf args :pname)) - (eq (default-slot-name (param-name property)) name)))) - manual-slots) - do (push (slot-definition-from-property class property) slots)) + as slot = (or + (find (param-name property) slots + :key #'(lambda (slot) (getf (rest slot) :pname)) + :test #'string=) + (find (param-name property) slots + :key #'first :test #'string-equal)) + do (cond + ((not slot) + (push (slot-definition-from-property class property) slots)) + ((getf (rest slot) :merge) + (setf + (rest slot) + (rest (slot-definition-from-property class property (rest slot))))))) (delete-if #'(lambda (slot) (getf (rest slot) :ignore)) slots))