X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/4de90d1003ebaa951a5b1473b5304e563be7c0c0..de8516caf7f9031a1cbffa1382c4a3f97a892350:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 8b9a651..6e4e4e0 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.8 2001-05-29 15:50:31 espen Exp $ +;; $Id: gobject.lisp,v 1.11 2002-03-24 12:50:30 espen Exp $ (in-package "GLIB") @@ -25,14 +25,12 @@ (defclass gobject (ginstance) () (:metaclass ginstance-class) (:alien-name "GObject") - (:ref "g_object_ref") - (:unref "g_object_unref"))) + (:copy %object-ref) + (:free %object-unref))) (defmethod initialize-instance ((object gobject) &rest initargs) (declare (ignore initargs)) - (setf - (slot-value object 'location) - (%gobject-new (type-number-of object))) + (setf (slot-value object 'location) (%gobject-new (type-number-of object))) (call-next-method)) (defbinding (%gobject-new "g_object_new") () pointer @@ -40,8 +38,22 @@ (defbinding (%gobject-new "g_object_new") () pointer (nil null)) +(defbinding %object-ref (type location) pointer + (location pointer)) -;;;; Parameter stuff +(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) @@ -94,7 +106,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defclass gobject-class (ginstance-class)) (defclass direct-gobject-slot-definition (direct-virtual-slot-definition) - ((param :reader slot-definition-param))) + ((pname :reader slot-definition-pname))) (defclass effective-gobject-slot-definition (effective-virtual-slot-definition))) @@ -110,37 +122,39 @@ (defclass effective-gobject-slot-definition ; (class pointer) ; (name string)) +(defun signal-name-to-string (name) + (substitute #\_ #\- (string-downcase (string name)))) (defmethod initialize-instance :after ((slotd direct-gobject-slot-definition) - &rest initargs &key param) + &rest initargs &key pname) (declare (ignore initargs)) - (when param + (when pname (setf - (slot-value slotd 'param) + (slot-value slotd 'pname) (signal-name-to-string (slot-definition-name slotd))))) (defmethod direct-slot-definition-class ((class gobject-class) initargs) (case (getf initargs :allocation) - (:param (find-class 'direct-gobject-slot-definition)) + (:property (find-class 'direct-gobject-slot-definition)) (t (call-next-method)))) (defmethod effective-slot-definition-class ((class gobject-class) initargs) (case (getf initargs :allocation) - (:param (find-class 'effective-gobject-slot-definition)) + (:property (find-class 'effective-gobject-slot-definition)) (t (call-next-method)))) (defmethod compute-virtual-slot-accessors ((class gobject-class) (slotd effective-gobject-slot-definition) direct-slotds) (with-slots (type) slotd - (let ((param-name (slot-definition-param (first direct-slotds))) + (let ((pname (slot-definition-pname (first direct-slotds))) (type-number (find-type-number type))) (list #'(lambda (object) (with-gc-disabled (let ((gvalue (gvalue-new type-number))) - (%object-get-property object param-name gvalue) - (prog1 + (%object-get-property object pname gvalue) + (unwind-protect (funcall (intern-reader-function type) gvalue +gvalue-value-offset+) (gvalue-free gvalue t))))) @@ -150,7 +164,7 @@ (defmethod compute-virtual-slot-accessors (funcall (intern-writer-function type) value gvalue +gvalue-value-offset+) - (%object-set-property object param-name gvalue) + (%object-set-property object pname gvalue) (funcall (intern-destroy-function type) gvalue +gvalue-value-offset+) @@ -166,29 +180,25 @@ (defmethod validate-superclass ((class gobject-class) ;;;; -(defbinding %object-class-properties () pointer +(defbinding %object-class-list-properties () pointer (class pointer) (n-properties unsigned-int :out)) -(defun query-object-class-properties (type-number) +(defun query-object-class-properties (type-number &optional + inherited-properties) (let ((class (type-class-ref type-number))) (multiple-value-bind (array length) - (%object-class-properties class) - (map-c-array 'list #'identity array 'param length)))) - -(defun query-object-type-dependencies (type-number) - (delete-duplicates - (reduce - #'nconc - (mapcar - #'(lambda (param) - ;; A gobject does not depend on it's supertypes due to forward - ;; referenced superclasses - (delete-if - #'(lambda (type) - (type-is-p type-number type)) - (type-hierarchy (param-type param)))) - (query-object-class-properties type-number))))) + (%object-class-list-properties class) + (unwind-protect + (let ((all-properties + (map-c-array 'list #'identity array 'param length))) + (if (not inherited-properties) + (delete-if + #'(lambda (param) + (not (eql type-number (param-owner-type param)))) + all-properties) + all-properties)) + (deallocate-memory array))))) (defun default-slot-name (name) @@ -200,21 +210,22 @@ (defun default-slot-accessor (class-name slot-name type) nil "~A-~A~A" class-name slot-name (if (eq 'boolean type) "-P" "")))) -(defun expand-gobject-type (type-number &optional slots +(defun expand-gobject-type (type-number &optional options (metaclass 'gobject-class)) - (let* ((super (supertype type-number)) + (let* ((supers (cons (supertype type-number) (implements type-number))) (class (type-from-number type-number)) + (override-slots (getf options :slots)) (expanded-slots (mapcar #'(lambda (param) - (with-slots (name flags type documentation) param + (with-slots (name flags value-type documentation) param (let* ((slot-name (default-slot-name name)) - (slot-type (type-from-number type #|t|#)) + (slot-type (type-from-number value-type #|t|#)) (accessor (default-slot-accessor class slot-name slot-type))) `(,slot-name - :allocation :param - :param ,name + :allocation :property + :pname ,name ,@(cond ((and (member :writable flags) @@ -233,13 +244,29 @@ (default-slot-accessor class slot-name slot-type))) (list :documentation documentation)))))) (query-object-class-properties type-number)))) - `(defclass ,class (,super) - ,expanded-slots - (:metaclass ,metaclass) - (:alien-name ,(find-type-name type-number))))) + (dolist (slot-def override-slots) + (let ((name (car slot-def)) + (pname (getf (cdr slot-def) :pname))) + (setq + expanded-slots + (delete-if + #'(lambda (expanded-slot-def) + (or + (eq name (car expanded-slot-def)) + (and + pname + (string= pname (getf (cdr expanded-slot-def) :pname))))) + expanded-slots)) + + (unless (getf (cdr slot-def) :ignore) + (push slot-def expanded-slots)))) -(register-derivable-type - 'gobject "GObject" - :query 'query-object-type-dependencies - :expand 'expand-gobject-type) + `(progn + (defclass ,class ,supers + ,expanded-slots + (:metaclass ,metaclass) + (:alien-name ,(find-type-name type-number)))))) + + +(register-derivable-type 'gobject "GObject" 'expand-gobject-type)