X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/92a07e637d009189bcadeae5d1ef9e9634c8d9ec..5de2b5f6a587aff7590db74f3aa7eb622cd8904c:/glib/gtype.lisp diff --git a/glib/gtype.lisp b/glib/gtype.lisp index 783a6a7..866b437 100644 --- a/glib/gtype.lisp +++ b/glib/gtype.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtype.lisp,v 1.35 2006-02-01 17:46:11 espen Exp $ +;; $Id: gtype.lisp,v 1.46 2006-02-19 22:25:31 espen Exp $ (in-package "GLIB") @@ -69,7 +69,8 @@ (defmethod writer-function ((type (eql 'gtype)) &rest args) (defmethod reader-function ((type (eql 'gtype)) &rest args) (declare (ignore type args)) (let ((reader (reader-function 'type-number))) - #'(lambda (location &optional (offset 0)) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (type-from-number (funcall reader location offset))))) @@ -106,6 +107,7 @@ (defbinding type-class-peek (type) pointer (defvar *registered-types* ()) (defvar *registered-type-aliases* ()) +(defvar *registered-static-types* ()) (defvar *lisp-type-to-type-number* (make-hash-table)) (defvar *type-number-to-lisp-type* (make-hash-table)) @@ -171,7 +173,7 @@ (defun type-from-number (type-number &optional error) type (let ((name (find-foreign-type-name type-number))) (cond - ((and name (type-number-from-glib-name name nil)) + ((and name (not (= (type-number-from-glib-name name nil) type-number))) ;; This is a hack because GdkEvent seems to be registered ;; multiple times (type-from-number (type-number-from-glib-name name))) @@ -269,9 +271,10 @@ (defun register-new-type (type parent &optional foreign-name) parent-number (or foreign-name (default-alien-type-name type)) (make-instance 'type-info :class-size class-size :instance-size instance-size)))) - (setf (gethash type *lisp-type-to-type-number*) type-number) - (setf (gethash type-number *type-number-to-lisp-type*) type) - type-number)))) + (pushnew (list type parent foreign-name) *registered-static-types* :key #'car) + (setf (gethash type *lisp-type-to-type-number*) type-number) + (setf (gethash type-number *type-number-to-lisp-type*) type) + type-number)))) @@ -279,25 +282,52 @@ (defun register-new-type (type parent &optional foreign-name) (eval-when (:compile-toplevel :load-toplevel :execute) (defclass ginstance-class (proxy-class) - ())) + ((gtype :initarg :gtype :initform nil :reader ginstance-class-gtype)))) + + +(defun update-size (class) + (let ((type-number (find-type-number class))) + (cond + ((not (slot-boundp class 'size)) + (setf (slot-value class 'size) (type-instance-size type-number))) + ((and + (slot-boundp class 'size) + (not (= (type-instance-size type-number) (slot-value class 'size)))) + (warn "Size mismatch for class ~A" class))))) -(defmethod shared-initialize :after ((class ginstance-class) names &key name gtype) - (let* ((class-name (or name (class-name class))) +(defmethod finalize-inheritance ((class ginstance-class)) + (call-next-method) + (let* ((class-name (class-name class)) (super (most-specific-proxy-superclass class)) - (foreign-name (or (first gtype) (default-type-init-name class-name))) - (type-number + (gtype (or + (first (ginstance-class-gtype class)) + (default-alien-type-name class-name))) + (type-number (or (find-type-number class-name) - (if (type-number-from-glib-name foreign-name nil) - (register-type class-name foreign-name) - (register-new-type class-name (class-name super) foreign-name))))) - (unless (eq (class-name super) (supertype type-number)) + (let ((type-number + (if (or + (symbolp gtype) + (type-number-from-glib-name gtype nil)) + (register-type class-name gtype) + (register-new-type class-name (class-name super) gtype)))) + (type-class-ref type-number) + type-number)))) + (when (and + (supertype type-number) + (not (eq (class-name super) (supertype type-number)))) (warn "~A is the super type for ~A in the gobject type system." - (supertype type-number) class-name)) + (supertype type-number) class-name))) + + (update-size class)) - (unless (slot-boundp class 'size) - (setf (slot-value class 'size) (type-instance-size type-number))))) + +(defmethod shared-initialize ((class ginstance-class) names &rest initargs) + (declare (ignore initargs)) + (call-next-method) + (when (class-finalized-p class) + (update-size class))) (defmethod validate-superclass ((class ginstance-class) (super standard-class)) @@ -308,14 +338,16 @@ (defmethod validate-superclass ((class ginstance-class) (super standard-class)) (eval-when (:compile-toplevel :load-toplevel :execute) (defclass ginstance (proxy) - ((class :allocation :alien :type pointer)) - (:metaclass proxy-class))) + (;(class :allocation :alien :type pointer :offset 0) + ) + (:metaclass proxy-class) + (:size #.(size-of 'pointer)))) (defun %type-number-of-ginstance (location) (let ((class (sap-ref-sap location 0))) (sap-ref-32 class 0))) -(defmethod ensure-proxy-instance ((class ginstance-class) location) +(defmethod make-proxy-instance :around ((class ginstance-class) location &rest initargs) (declare (ignore class)) (let ((class (labels ((find-known-class (type-number) (or @@ -323,10 +355,30 @@ (defmethod ensure-proxy-instance ((class ginstance-class) location) (unless (zerop type-number) (find-known-class (type-parent type-number)))))) (find-known-class (%type-number-of-ginstance location))))) + ;; Note that chancing the class argument must not alter "the + ;; ordered set of applicable methods" as specified in the + ;; Hyperspec (if class - (make-instance class :location (reference-foreign class location)) - (error "Object at ~A has an unkown type number: ~A" - location (%type-number-of-ginstance location))))) + (apply #'call-next-method class location initargs) + (error "Object at ~A has an unkown type number: ~A" + location (%type-number-of-ginstance location))))) + +(defmethod make-proxy-instance ((class ginstance-class) location &rest initargs) + (declare (ignore initargs)) + (reference-foreign class location) + ;; Since we make an explicit reference to the foreign object, we + ;; always have to release it when the proxy is garbage collected + ;; and therefor ignore the weak-p argument. + (call-next-method class location :weak nil)) + +(defmethod invalidate-instance ((instance ginstance)) + (declare (ignore instance)) + ;; A ginstance should never be invalidated since it is ref counted + nil) + +(defmethod callback-from-alien-form (form (class ginstance-class) &rest args) + (declare (ignore args)) + (from-alien-form form class)) (defmethod copy-from-alien-form (location (class ginstance-class) &rest args) (declare (ignore location class args)) @@ -338,7 +390,8 @@ (defmethod copy-from-alien-function ((class ginstance-class) &rest args) (defmethod reader-function ((class ginstance-class) &rest args) (declare (ignore args)) - #'(lambda (location &optional (offset 0)) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (ensure-proxy-instance class (sap-ref-sap location offset))))