X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/573b21cca20711ae540d40f9d38051072147a7e7..c046c2f653233b4e09830f672159ae205f59c6f6:/glib/ginterface.lisp diff --git a/glib/ginterface.lisp b/glib/ginterface.lisp index ca61631..64cc0b6 100644 --- a/glib/ginterface.lisp +++ b/glib/ginterface.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: ginterface.lisp,v 1.1 2002-01-20 14:05:27 espen Exp $ +;; $Id: ginterface.lisp,v 1.10 2005-03-11 10:56:58 espen Exp $ (in-package "GLIB") @@ -23,58 +23,134 @@ ;;;; -(defclass ginterface ()) +(defclass ginterface () + ()) -(deftype-method translate-type-spec ginterface (type-spec) - (declare (ignore type-spec)) - (translate-type-spec 'gobject)) +;;;; Metaclass for interfaces -(deftype-method size-of ginterface (type-spec) - (declare (ignore type-spec)) - (size-of 'gobject)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass ginterface-class (virtual-slots-class) + ())) + +(defmethod direct-slot-definition-class ((class ginterface-class) &rest initargs) + (case (getf initargs :allocation) + (:property (find-class 'direct-property-slot-definition)) + (t (call-next-method)))) + +(defmethod effective-slot-definition-class ((class ginterface-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 ginterface-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 shared-initialize ((class ginterface-class) names &key name gtype) + (declare (ignore names)) + (let* ((class-name (or name (class-name class))) + (type-number + (or + (find-type-number class-name) + (register-type class-name + (or (first gtype) (default-type-init-name class-name)))))) + (type-default-interface-ref type-number)) + (call-next-method)) -(deftype-method translate-from-alien - ginterface (type-spec location &optional weak-ref) - (declare (ignore type-spec)) - (translate-from-alien 'gobject location weak-ref)) -(deftype-method translate-to-alien - ginterface (type-spec instance &optional weak-ref) - (declare (ignore type-spec)) - (translate-to-alien 'gobject instance weak-ref)) +(defmethod validate-superclass ((class ginterface-class) (super standard-class)) + (subtypep (class-name super) 'ginterface)) +(defmethod alien-type ((class ginterface-class) &rest args) + (declare (ignore class args)) + (alien-type 'gobject)) -;;;; Metaclass for interfaces +(defmethod size-of ((class ginterface-class) &rest args) + (declare (ignore class args)) + (size-of 'gobject)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass ginterface-class (pcl::standard-class))) +(defmethod from-alien-form (location (class ginterface-class) &rest args) + (declare (ignore class args)) + (from-alien-form location 'gobject)) +(defmethod from-alien-function ((class ginterface-class) &rest args) + (declare (ignore class args)) + (from-alien-function 'gobject)) -(defmethod shared-initialize ((class ginterface-class) names - &rest initargs &key name alien-name) - (declare (ignore initargs names)) - (let* ((class-name (or name (class-name class))) - (type-number - (find-type-number - (or (first alien-name) (default-alien-type-name class-name)) t))) - (register-type class-name type-number)) - (call-next-method)) +(defmethod to-alien-form (instance (class ginterface-class) &rest args) + (declare (ignore class args)) + (to-alien-form instance 'gobject)) +(defmethod to-alien-function ((class ginterface-class) &rest args) + (declare (ignore class args)) + (to-alien-function 'gobject)) -(defmethod validate-superclass - ((class ginterface-class) (super pcl::standard-class)) - (subtypep (class-name super) 'ginterface)) +(defmethod reader-function ((class ginterface-class) &rest args) + (declare (ignore class args)) + (reader-function 'gobject)) + +(defmethod writer-function ((class ginterface-class) &rest args) + (declare (ignore class args)) + (writer-function 'gobject)) + +(defmethod destroy-function ((class ginterface-class) &rest args) + (declare (ignore class args)) + (destroy-function 'gobject)) ;;;; -(defun expand-ginterface-type (type-number &rest args) - (declare (ignore args)) - `(defclass ,(type-from-number type-number) (ginterface) - () - (:metaclass ginterface-class) - (:alien-name ,(find-type-name type-number)))) +(defbinding type-default-interface-ref (type) pointer + ((find-type-number type t) type-number)) + +(defbinding type-default-interface-unref (type) nil + ((find-type-number type t) type-number)) -(register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type) +(defbinding type-default-interface-peek (type) pointer + ((find-type-number type t) type-number)) + +(defbinding %object-interface-list-properties () pointer + (iface pointer) + (n-properties unsigned-int :out)) + +(defun query-object-interface-properties (type &optional inherited-p) + (let* ((type-number (find-type-number type)) + (iface (type-default-interface-ref type-number))) + (unwind-protect + (multiple-value-bind (array length) + (%object-interface-list-properties iface) + (unless (null-pointer-p array) + (unwind-protect + (%map-params array length type-number inherited-p) + (deallocate-memory array)))) +; (type-default-interface-unref type-number) + ))) + + +(defun expand-ginterface-type (type forward-p options &rest args) + (declare (ignore args)) + (let ((class (type-from-number type)) + (slots (getf options :slots))) + `(defclass ,class (,(supertype type)) + ,(unless forward-p + (slot-definitions class (query-object-interface-properties type) slots)) + (:metaclass ginterface-class) + (:gtype ,(register-type-as type))))) + +(defun ginterface-dependencies (type) + (delete-duplicates + (cons + (supertype type) + (mapcar #'param-value-type (query-object-interface-properties type))))) + +(register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type 'ginterface-dependencies)