X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/040579dd743ad0bb0b4fcd1b763864f15ff4308d..266ca870fe9634f59ea740e2a5ba62eb30adf5ca:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 50c2958..0014b4d 100644 --- 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.33 2005-02-27 15:14:38 espen Exp $ (in-package "GLIB") @@ -26,8 +26,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defclass gobject-class (ginstance-class) ()) - (defmethod validate-superclass ((class gobject-class) - (super pcl::standard-class)) + (defmethod validate-superclass ((class gobject-class) (super standard-class)) ; (subtypep (class-name super) 'gobject) t)) @@ -41,7 +40,14 @@ (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)));) + (construct :initarg :construct))) + +(defclass direct-user-data-slot-definition (direct-virtual-slot-definition) + ()) + +(defclass effective-user-data-slot-definition (effective-virtual-slot-definition) + ()) + (defbinding %object-ref () pointer (location pointer)) @@ -74,11 +80,13 @@ (defun signal-name-to-string (name) (defmethod direct-slot-definition-class ((class gobject-class) &rest initargs) (case (getf initargs :allocation) (:property (find-class 'direct-property-slot-definition)) + (:user-data (find-class 'direct-user-data-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)) + (:user-data (find-class 'effective-user-data-slot-definition)) (t (call-next-method)))) (defmethod compute-effective-slot-definition-initargs ((class gobject-class) direct-slotds) @@ -100,10 +108,10 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de (when (and (not (slot-boundp slotd 'getter)) (slot-readable-p slotd)) (setf (slot-value slotd 'getter) - (let ((reader nil)) + (let ((reader nil)) ;(reader-function type))) #'(lambda (object) (unless reader - (setq reader (reader-function (type-from-number type-number)))) + (setq reader (reader-function type))) (let ((gvalue (gvalue-new type-number))) (%object-get-property object pname gvalue) (unwind-protect @@ -113,10 +121,10 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de (when (and (not (slot-boundp slotd 'setter)) (slot-writable-p slotd)) (setf (slot-value slotd 'setter) - (let ((writer nil)) + (let ((writer nil)) ;(writer-function type))) #'(lambda (value object) (unless writer - (setq writer (writer-function (type-from-number type-number)))) + (setq writer (writer-function type))) (let ((gvalue (gvalue-new type-number))) (funcall writer value gvalue +gvalue-value-offset+) (%object-set-property object pname gvalue) @@ -125,6 +133,25 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de (call-next-method)) +(defmethod initialize-internal-slot-functions ((slotd effective-user-data-slot-definition)) + (let ((slot-name (slot-definition-name slotd))) + (unless (slot-boundp slotd 'getter) + (setf + (slot-value slotd 'getter) + #'(lambda (object) + (prog1 (user-data object slot-name))))) + (unless (slot-boundp slotd 'setter) + (setf + (slot-value slotd 'setter) + #'(lambda (value object) + (setf (user-data object slot-name) value)))) + (unless (slot-boundp slotd 'boundp) + (setf + (slot-value slotd 'boundp) + #'(lambda (object) + (user-data-p object slot-name))))) + (call-next-method)) + ;;;; Super class for all classes in the GObject type hierarchy @@ -240,28 +267,51 @@ (defbinding object-freeze-notify () nil (defbinding object-thaw-notify () nil (object gobject)) + +;;;; User data + (defbinding %object-set-qdata-full () nil (object gobject) (id quark) (data unsigned-long) (destroy-marshal pointer)) +(defcallback user-data-destroy-func (nil (id unsigned-int)) + (destroy-user-data id)) -;;;; User data +(export 'user-data-destroy-func) -(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)) +(defun (setf user-data) (data object key) + (%object-set-qdata-full object (quark-intern key) + (register-user-data data) (callback user-data-destroy-func)) data) +;; deprecated +(defun (setf object-data) (data object key &key (test #'eq)) + (assert (eq test #'eq)) + (setf (user-data object key) data)) + (defbinding %object-get-qdata () unsigned-long (object gobject) (id quark)) +(defun user-data (object key) + (find-user-data (%object-get-qdata object (quark-intern key)))) + +;; deprecated (defun object-data (object key &key (test #'eq)) - (find-user-data - (%object-get-qdata object (quark-from-object key :test test)))) + (assert (eq test #'eq)) + (user-data object key)) + +(defun user-data-p (object key) + (user-data-exists-p (%object-get-qdata object (quark-intern key)))) + +(defbinding %object-steal-qdata () unsigned-long + (object gobject) + (id quark)) + +(defun unset-user-data (object key) + (destroy-user-data (%object-steal-qdata object (quark-intern key)))) ;;;; @@ -288,9 +338,10 @@ (defun query-object-class-properties (type &optional inherited-p) (unwind-protect (multiple-value-bind (array length) (%object-class-list-properties class) - (unwind-protect - (%map-params array length type-number inherited-p) - (deallocate-memory array))) + (unless (null-pointer-p array) + (unwind-protect + (%map-params array length type-number inherited-p) + (deallocate-memory array)))) ; (type-class-unref type-number) ))) @@ -305,19 +356,17 @@ (defun default-slot-accessor (class-name slot-name type) (if (eq type 'boolean) "-P" "")))) -(defun slot-definition-from-property (class property &optional args) +(defun slot-definition-from-property (class property &optional slot-name args) (with-slots (name flags value-type documentation) property - (let* ((slot-name (default-slot-name name)) - (slot-type (or (getf args :type) (type-from-number value-type) value-type)) + (let* ((slot-name (or slot-name (default-slot-name name))) + (slot-type (or (getf args :type) (type-from-number value-type) 'pointer)) (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))) + ((find :unbound args) (list :unbound (getf args :unbound)))) ;; accessors ,@(cond @@ -341,10 +390,15 @@ (defun slot-definition-from-property (class property &optional args) '(:construct t)) ;; initargs - ,@(when (or (member :construct flags) - (member :construct-only flags) - (member :writable flags)) - (list :initarg (intern (string slot-name) "KEYWORD"))) + ,@(if (find :initarg args) + (let ((initarg (getf args :initarg))) + (etypecase initarg + (null ()) + (symbol `(:initarg ,initarg)))) + (when (or (member :construct flags) + (member :construct-only flags) + (member :writable flags)) + (list :initarg (intern (string slot-name) "KEYWORD")))) :type ,slot-type :documentation ,documentation)))) @@ -365,18 +419,48 @@ (defun slot-definitions (class properties slots) ((getf (rest slot) :merge) (setf (rest slot) - (rest (slot-definition-from-property class property (rest slot))))))) + (rest (slot-definition-from-property class property (first slot) (rest slot))))))) (delete-if #'(lambda (slot) (getf (rest slot) :ignore)) slots)) -(defun expand-gobject-type (type &optional options (metaclass 'gobject-class)) +(defun expand-gobject-type (type forward-p options &optional (metaclass 'gobject-class)) (let ((supers (cons (supertype type) (implements type))) (class (type-from-number type)) (slots (getf options :slots))) `(defclass ,class ,supers - ,(slot-definitions class (query-object-class-properties type) slots) + ,(unless forward-p + (slot-definitions class (query-object-class-properties type) slots)) (:metaclass ,metaclass) (:alien-name ,(find-type-name type))))) +(defun gobject-dependencies (type) + (delete-duplicates + (cons + (supertype type) + (append + (type-interfaces type) + (mapcar #'param-value-type (query-object-class-properties type)))))) + + +(register-derivable-type 'gobject "GObject" 'expand-gobject-type 'gobject-dependencies) + + +;;; 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)))) -(register-derivable-type 'gobject "GObject" 'expand-gobject-type) +(export 'referenced)