X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/4d83a8a641bfaeb0d858fbf37524f3d3b9b81a6e..d168bafdb3b5b6614755bb431778e895122f2be5:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index dc6bd78..620b7ba 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.13 2004-10-27 14:58:59 espen Exp $ +;; $Id: gobject.lisp,v 1.17 2004-11-06 21:39:58 espen Exp $ (in-package "GLIB") @@ -24,62 +24,90 @@ (defclass gobject (ginstance) () (:metaclass ginstance-class) - (:alien-name "GObject") - (:copy %object-ref) - (:free %object-unref))) + (:alien-name "GObject"))) + +(defmethod print-object ((instance gobject) stream) + (print-unreadable-object (instance stream :type t :identity nil) + (if (slot-boundp instance 'location) + (format stream "at 0x~X" (sap-int (proxy-location instance))) + (write-string "(destroyed)" stream)))) (defmethod initialize-instance ((object gobject) &rest initargs) - (let ((slotds (class-slots (class-of object))) - (names (make-array 0 :adjustable t :fill-pointer t)) - (values (make-array 0 :adjustable t :fill-pointer t))) - - (loop - as tmp = initargs then (cddr tmp) while tmp - as key = (first tmp) - as value = (second tmp) - as slotd = (find-if - #'(lambda (slotd) - (member key (slot-definition-initargs slotd))) - slotds) - when (and (typep slotd 'effective-gobject-slot-definition) - (slot-value slotd 'construct)) - do (let ((type (find-type-number (slot-definition-type slotd)))) - (vector-push-extend (slot-definition-pname slotd) names) - (vector-push-extend (gvalue-new type value) values) - (remf initargs key))) - - (setf - (slot-value object 'location) - (if (zerop (length names)) - (%gobject-new (type-number-of object)) - (%gobject-newvv (type-number-of object) (length names) names values)))) + ;; Extract initargs which we should pass directly to the GObeject + ;; constructor + (let* ((slotds (class-slots (class-of object))) + (args (loop + as tmp = initargs then (cddr tmp) while tmp + as key = (first tmp) + as value = (second tmp) + as slotd = (find-if + #'(lambda (slotd) + (member key (slot-definition-initargs slotd))) + slotds) + when (and (typep slotd 'effective-property-slot-definition) + (slot-value slotd 'construct)) + collect (progn + (remf initargs key) + (list + (slot-definition-pname slotd) + (slot-definition-type slotd) + value))))) + (if args + (let* ((string-size (size-of 'string)) + (string-writer (writer-function 'string)) + (string-destroy (destroy-function 'string)) + (params (allocate-memory + (* (length args) (+ string-size +gvalue-size+))))) + (loop + for (pname type value) in args + as tmp = params then (sap+ tmp (+ string-size +gvalue-size+)) + do (funcall string-writer pname tmp) + (gvalue-init (sap+ tmp string-size) type value)) + (unwind-protect + (setf + (slot-value object 'location) + (%gobject-newv (type-number-of object) (length args) params)) + (loop + repeat (length args) + as tmp = params then (sap+ tmp (+ string-size +gvalue-size+)) + do (funcall string-destroy tmp) + (gvalue-unset (sap+ tmp string-size))) + (deallocate-memory params))) + (setf + (slot-value object 'location) + (%gobject-new (type-number-of object))))) + + (%object-weak-ref object) (apply #'call-next-method object initargs)) +(defmethod initialize-instance :around ((object gobject) &rest initargs) + (declare (ignore initargs)) + (call-next-method) + (%object-weak-ref object)) + + +(def-callback weak-notify (c-call:void (data c-call:int) (location system-area-pointer)) + (let ((object (find-cached-instance location))) + (when object +;; (warn "~A being finalized by the GObject system while still in existence in lisp" object) + (slot-makunbound object 'location) + (remove-cached-instance location)))) + +(defbinding %object-weak-ref (object) nil + (object gobject) + ((callback weak-notify) pointer) + (0 unsigned-int)) (defbinding (%gobject-new "g_object_new") () pointer (type type-number) (nil null)) -(defbinding (%gobject-newvv "g_object_newvv") () pointer +(defbinding (%gobject-newv "g_object_newv") () pointer (type type-number) (n-parameters unsigned-int) - (names (vector string)) - (values (vector gvalue))) - - -(defbinding %object-ref (type location) pointer - (location pointer)) - - (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))) + (params pointer)) @@ -117,7 +145,7 @@ (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) *destroy-notify*) + (register-user-data data) (callback %destroy-user-data)) data) (defbinding %object-get-qdata () unsigned-long @@ -132,22 +160,35 @@ ;;;; Metaclass used for subclasses of gobject -(eval-when (:compile-toplevel :load-toplevel :execute) +;(eval-when (:compile-toplevel :load-toplevel :execute) (defclass gobject-class (ginstance-class) ()) - (defclass direct-gobject-slot-definition (direct-virtual-slot-definition) + (defclass direct-property-slot-definition (direct-virtual-slot-definition) ((pname :reader slot-definition-pname :initarg :pname) (readable :initform t :reader slot-readable-p :initarg :readable) (writable :initform t :reader slot-writable-p :initarg :writable) (construct :initform nil :initarg :construct))) - (defclass effective-gobject-slot-definition (effective-virtual-slot-definition) + (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)));) + +(defbinding %object-ref () pointer + (location pointer)) + +(defbinding %object-unref () nil + (location pointer)) + +(defmethod reference-foreign ((class gobject-class) location) + (declare (ignore class)) + (%object-ref location)) +(defmethod unreference-foreign ((class gobject-class) location) + (declare (ignore class)) + (%object-unref location)) ; (defbinding object-class-install-param () nil @@ -165,12 +206,12 @@ (defmethod direct-slot-definition-class ((class gobject-class) &rest initargs) (case (getf initargs :allocation) - (:property (find-class 'direct-gobject-slot-definition)) + (:property (find-class 'direct-property-slot-definition)) (t (call-next-method)))) (defmethod effective-slot-definition-class ((class gobject-class) &rest initargs) (case (getf initargs :allocation) - (:property (find-class 'effective-gobject-slot-definition)) + (:property (find-class 'effective-property-slot-definition)) (t (call-next-method)))) (defmethod compute-effective-slot-definition-initargs ((class gobject-class) direct-slotds) @@ -185,7 +226,7 @@ (call-next-method))) -(defmethod initialize-internal-slot-functions ((slotd effective-gobject-slot-definition)) +(defmethod initialize-internal-slot-functions ((slotd effective-property-slot-definition)) (let* ((type (slot-definition-type slotd)) (pname (slot-definition-pname slotd)) (type-number (find-type-number type))) @@ -193,14 +234,13 @@ (setf (slot-value slotd 'reader-function) (if (slot-readable-p slotd) - #'(lambda (object) - (with-gc-disabled - (let ((gvalue (gvalue-new type-number))) - (%object-get-property object pname gvalue) - (unwind-protect - (funcall - (intern-reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) ; temporary workaround for wrong topological sorting of types - (gvalue-free gvalue t))))) + (let () ;(reader (reader-function (type-from-number type-number)))) + #'(lambda (object) + (let ((gvalue (gvalue-new type-number))) + (%object-get-property object pname gvalue) + (unwind-protect + (funcall #|reader|# (reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) + (gvalue-free gvalue t))))) #'(lambda (value object) (error "Slot is not readable: ~A" (slot-definition-name slotd)))))) @@ -208,18 +248,15 @@ (setf (slot-value slotd 'writer-function) (if (slot-writable-p slotd) - #'(lambda (value object) - (with-gc-disabled - (let ((gvalue (gvalue-new type-number))) - (funcall - (intern-writer-function (type-from-number type-number)) ; temporary - value gvalue +gvalue-value-offset+) - (%object-set-property object pname gvalue) - (funcall - (intern-destroy-function (type-from-number type-number)) ; temporary - gvalue +gvalue-value-offset+) - (gvalue-free gvalue nil) - value))) + (let ();; (writer (writer-function (type-from-number type-number))) +;; (destroy (destroy-function (type-from-number type-number)))) + #'(lambda (value object) + (let ((gvalue (gvalue-new type-number))) + (funcall #|writer|# (writer-function (type-from-number type-number)) value gvalue +gvalue-value-offset+) + (%object-set-property object pname gvalue) +; (funcall #|destroy|#(destroy-function (type-from-number type-number)) gvalue +gvalue-value-offset+) + (gvalue-free gvalue t) + value))) #'(lambda (value object) (error "Slot is not writable: ~A" (slot-definition-name slotd)))))) @@ -245,21 +282,29 @@ (class pointer) (n-properties unsigned-int :out)) -(defun query-object-class-properties (type-number &optional - inherited-properties) - (let ((class (type-class-ref type-number))) - (multiple-value-bind (array length) - (%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 %map-params (params length type inherited-p) + (if inherited-p + (map-c-vector 'list #'identity params 'param length) + (let ((properties ())) + (map-c-vector 'list + #'(lambda (param) + (when (eql (param-owner-type param) type) + (push param properties))) + params 'param length) + (nreverse properties)))) + +(defun query-object-class-properties (type &optional inherited-p) + (let* ((type-number (find-type-number type)) + (class (type-class-ref type-number))) + (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))) +; (type-class-unref type-number) + ))) (defun default-slot-name (name) @@ -271,78 +316,70 @@ nil "~A-~A~A" class-name slot-name (if (eq type 'boolean) "-P" "")))) -(defun expand-gobject-type (type-number &optional options - (metaclass 'gobject-class)) - (let* ((supers (cons (supertype type-number) (implements type-number))) - (class (type-from-number type-number)) - (manual-slots (getf options :slots)) - (expanded-slots - (mapcar - #'(lambda (param) - (with-slots (name flags value-type documentation) param - (let* ((slot-name (default-slot-name name)) -; (slot-type value-type) ;(type-from-number value-type t)) - (slot-type (or (type-from-number value-type) value-type)) - (accessor - (default-slot-accessor class slot-name slot-type)));(type-from-number slot-type)))) ; temporary workaround for wrong topological sorting of types - - `(,slot-name - :allocation :property - :pname ,name - ,@(cond - ((and - (member :writable flags) - (member :readable flags) - (not (member :construct-only flags))) - (list :accessor accessor)) - ((and (member :writable flags) - (not (member :construct-only flags))) - (list :writer `(setf ,accessor))) - ((member :readable flags) - (list :reader accessor))) - ,@(when (or - (not (member :writable flags)) - (member :construct-only flags)) - (list :writable nil)) - ,@(when (not (member :readable flags)) - (list :readable nil)) - ,@(when (or - (member :construct flags) - (member :construct-only flags)) - (list :construct t)) - ,@(when (or - (member :construct flags) - (member :construct-only flags) - (member :writable flags)) - (list :initarg (intern (string slot-name) "KEYWORD"))) - :type ,slot-type - ,@(when documentation - (list :documentation documentation)))))) - (query-object-class-properties type-number)))) - - (dolist (slot-def (reverse manual-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)))) - - `(progn - (defclass ,class ,supers - ,expanded-slots - (:metaclass ,metaclass) - (:alien-name ,(find-type-name type-number)))))) +(defun slot-definition-from-property (class property) + (with-slots (name flags value-type documentation) property + (let* ((slot-name (default-slot-name name)) + (slot-type (or (type-from-number value-type) value-type)) + (accessor (default-slot-accessor class slot-name slot-type))) + + `(,slot-name + :allocation :property :pname ,name + + ;; accessors + ,@(cond + ((and + (member :writable flags) (member :readable flags) + (not (member :construct-only flags))) + (list :accessor accessor)) + ((and (member :writable flags) (not (member :construct-only flags))) + (list :writer `(setf ,accessor))) + ((member :readable flags) + (list :reader accessor))) + + ;; readable/writable/construct + ,@(when (or (not (member :writable flags)) + (member :construct-only flags)) + '(:writable nil)) + ,@(when (not (member :readable flags)) + '(:readable nil)) + ,@(when (or (member :construct flags) + (member :construct-only flags)) + '(:construct t)) + + ;; initargs + ,@(when (or (member :construct flags) + (member :construct-only flags) + (member :writable flags)) + (list :initarg (intern (string slot-name) "KEYWORD"))) + + :type ,slot-type + :documentation ,documentation)))) + + +(defun slot-definitions (class properties slots) + (loop + with manual-slots = slots + for property in properties + unless (find-if + #'(lambda (slot) + (destructuring-bind (name &rest args) slot + (or + (equal (param-name property) (getf args :pname)) + (eq (default-slot-name (param-name property)) name)))) + manual-slots) + do (push (slot-definition-from-property class property) slots)) + (delete-if #'(lambda (slot) (getf (rest slot) :ignore)) slots)) + + +(defun expand-gobject-type (type &optional options (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) + (:metaclass ,metaclass) + (:alien-name ,(find-type-name type))))) -(register-derivable-type 'gobject "GObject" 'expand-gobject-type) +(register-derivable-type 'gobject "GObject" 'expand-gobject-type)