X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.foreign-gobject-subclassing.lisp;h=991413530a5e041fb12eebbd9869ab452570b380;hb=02c0f62d617212f4e51224a2f7e76074dac1378e;hp=e9c74f949f1b131e53a319615ea84ff1f811bf0d;hpb=e6ec5def79916d6ecf3b1ea9aaecbbc295fdad95;p=cl-gtk2.git diff --git a/glib/gobject.foreign-gobject-subclassing.lisp b/glib/gobject.foreign-gobject-subclassing.lisp index e9c74f9..9914135 100644 --- a/glib/gobject.foreign-gobject-subclassing.lisp +++ b/glib/gobject.foreign-gobject-subclassing.lisp @@ -5,11 +5,13 @@ (defstruct object-type name class parent interfaces properties) (defun instance-init (instance class) + (log-for :subclass "(instance-init ~A ~A)~%" instance class) (log-for :subclass "Initializing instance ~A for type ~A (creating ~A)~%" instance (g-type-name (foreign-slot-value class 'g-type-class :type)) *current-creating-object*) (unless (or *current-creating-object* + *currently-making-object-p* (gethash (pointer-address instance) *foreign-gobjects-strong*) (gethash (pointer-address instance) *foreign-gobjects-weak*)) - (log-for :subclass " Proceeding with initialization...") + (log-for :subclass "Proceeding with initialization...~%") (let* ((g-type (foreign-slot-value class 'g-type-class :type)) (type-name (g-type-name g-type)) (lisp-type-info (gethash type-name *registered-types*)) @@ -76,37 +78,51 @@ (rest item) (list (first item) :pointer))) -(defstruct vtable-method-info name return-type args callback-name) +(defstruct vtable-method-info slot-name name return-type args callback-name) (defmethod make-load-form ((object vtable-method-info) &optional environment) (declare (ignore environment)) - `(make-vtable-method-info :name ',(vtable-method-info-name object) + `(make-vtable-method-info :slot-name ',(vtable-method-info-slot-name object) + :name ',(vtable-method-info-name object) :return-type ',(vtable-method-info-return-type object) :args ',(vtable-method-info-args object) :callback-name ',(vtable-method-info-callback-name object))) -(defun vtable-methods (items) +(defun vtable-methods (iface-name items) (iter (for item in items) (when (eq :skip (first item)) (next-iteration)) - (destructuring-bind (name callback-name return-type &rest args) item - (collect (make-vtable-method-info :name name :return-type return-type :args args :callback-name callback-name))))) + (destructuring-bind (name return-type &rest args) item + (for method-name = (intern (format nil "~A-~A-IMPL" (symbol-name iface-name) (symbol-name name)))) + (for callback-name = (intern (format nil "~A-~A-CALLBACK" (symbol-name iface-name) (symbol-name name)))) + (collect (make-vtable-method-info :slot-name name + :name method-name + :return-type return-type + :args args + :callback-name callback-name))))) (defvar *vtables* (make-hash-table :test 'equal)) (defstruct vtable-description type-name cstruct-name methods) -(defmacro define-vtable ((type-name cstruct-name) &body items) - `(progn - (defcstruct ,cstruct-name ,@(mapcar #'vtable-item->cstruct-item items)) - (setf (gethash ,type-name *vtables*) - (make-vtable-description :type-name ,type-name :cstruct-name ',cstruct-name :methods (list ,@(mapcar #'make-load-form (vtable-methods items))))) - ,@(iter (for method in (vtable-methods items)) - (collect `(defgeneric ,(vtable-method-info-name method) (,@(mapcar #'first (vtable-method-info-args method))))) - (collect `(glib-defcallback ,(vtable-method-info-callback-name method) ,(vtable-method-info-return-type method) - (,@(vtable-method-info-args method)) - (restart-case - (,(vtable-method-info-name method) ,@(mapcar #'first (vtable-method-info-args method))) - (return-from-interface-method-implementation (v) :interactive (lambda () (list (eval (read)))) v))))))) +(defmacro define-vtable ((type-name name) &body items) + (let ((cstruct-name (intern (format nil "~A-VTABLE" (symbol-name name)))) + (methods (vtable-methods name items))) + `(progn + (defcstruct ,cstruct-name ,@(mapcar #'vtable-item->cstruct-item items)) + (setf (gethash ,type-name *vtables*) + (make-vtable-description :type-name ,type-name + :cstruct-name ',cstruct-name + :methods (list ,@(mapcar #'make-load-form methods)))) + ,@(iter (for method in methods) + (collect `(defgeneric ,(vtable-method-info-name method) + (,@(mapcar #'first (vtable-method-info-args method))))) + (collect `(glib-defcallback ,(vtable-method-info-callback-name method) + ,(vtable-method-info-return-type method) + (,@(vtable-method-info-args method)) + (restart-case + (,(vtable-method-info-name method) ,@(mapcar #'first (vtable-method-info-args method))) + (return-from-interface-method-implementation (v) + :interactive (lambda () (list (eval (read)))) v)))))))) (defun interface-init (iface data) (destructuring-bind (class-name interface-name) (prog1 (get-stable-pointer-value data) (free-stable-pointer data)) @@ -115,7 +131,10 @@ (vtable-cstruct (vtable-description-cstruct-name vtable))) (log-for :subclass "interface-init for class ~A and interface ~A~%" class-name interface-name) (iter (for method in (vtable-description-methods vtable)) - (setf (foreign-slot-value iface vtable-cstruct (vtable-method-info-name method)) (get-callback (vtable-method-info-callback-name method))))))) + (for cb = (get-callback (vtable-method-info-callback-name method))) + (for slot-name = (vtable-method-info-slot-name method)) + (log-for :subclass "->setting method ~A to ~A~%" method cb) + (setf (foreign-slot-value iface vtable-cstruct slot-name) cb))))) (defcallback c-interface-init :void ((iface :pointer) (data :pointer)) (interface-init iface data)) @@ -198,12 +217,15 @@ (callback c-instance-init) nil)) (add-interfaces ,name)) (defmethod initialize-instance :before ((object ,class) &key pointer) + (log-for :subclass "(initialize-instance ~A :pointer ~A) :before~%" object pointer) (unless (or pointer (and (slot-boundp object 'gobject::pointer) (gobject::pointer object))) + (log-for :subclass "calling g-object-constructor~%") (setf (gobject::pointer object) (gobject::g-object-call-constructor ,name nil nil) (gobject::g-object-has-reference object) t))) (progn ,@(iter (for (prop-name prop-type prop-accessor prop-reader prop-writer) in properties) + (declare (ignorable prop-type)) (when prop-reader (collect `(defun ,prop-accessor (object) (g-object-call-get-property object ,prop-name)))) (when prop-writer