X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/82747bbd916a0478fa35a795bcdff4fcc463370a..c630da1bd52d451992a9b135a4099fd09520cab4:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 0284ed4..8c54999 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.5 2001-04-29 20:17:27 espen Exp $ +;; $Id: gobject.lisp,v 1.9 2001-10-21 21:52:53 espen Exp $ (in-package "GLIB") @@ -33,36 +33,40 @@ (setf (slot-value object 'location) (%gobject-new (type-number-of object))) - (call-next-method)) +; (funcall (proxy-class-copy (class-of object)) nil (proxy-location object)) + (call-next-method) +; (funcall (proxy-class-free (class-of object)) nil (proxy-location object)) + ) -(define-foreign ("g_object_new" %gobject-new) () gobject +(defbinding (%gobject-new "g_object_new") () pointer (type type-number) (nil null)) -;;;; Parameter stuff -(define-foreign %object-set-property () nil +;;;; Property stuff + +(defbinding %object-set-property () nil (object gobject) (name string) (value gvalue)) -(define-foreign %object-get-property () nil +(defbinding %object-get-property () nil (object gobject) (name string) (value gvalue)) -(define-foreign %object-notify () nil +(defbinding %object-notify () nil (object gobject) (name string)) -(define-foreign object-freeze-notify () nil +(defbinding object-freeze-notify () nil (object gobject)) -(define-foreign object-thaw-notify () nil +(defbinding object-thaw-notify () nil (object gobject)) -(define-foreign %object-set-qdata-full () nil +(defbinding %object-set-qdata-full () nil (object gobject) (id quark) (data unsigned-long) @@ -77,7 +81,7 @@ (register-user-data data) *destroy-notify*) data) -(define-foreign %object-get-qdata () unsigned-long +(defbinding %object-get-qdata () unsigned-long (object gobject) (id quark)) @@ -92,74 +96,166 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defclass gobject-class (ginstance-class)) - (defclass direct-gobject-slot-definition (direct-virtual-slot-definition)) + (defclass direct-gobject-slot-definition (direct-virtual-slot-definition) + ((pname :reader slot-definition-pname))) (defclass effective-gobject-slot-definition (effective-virtual-slot-definition))) + -; (define-foreign object-class-install-param () nil +; (defbinding object-class-install-param () nil ; (class pointer) ; (id unsigned-int) ; (parameter parameter)) -; (define-foreign object-class-find-param-spec () parameter +; (defbinding object-class-find-param-spec () parameter ; (class pointer) ; (name string)) (defmethod initialize-instance :after ((slotd direct-gobject-slot-definition) - &rest initargs &key) + &rest initargs &key pname) (declare (ignore initargs)) - (unless (slot-boundp slotd 'location) - ;; Find parameter name from slot name - (with-slots (pcl::name location) slotd - (setf location (signal-name-to-string pcl::name))))) + (when pname + (setf + (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-location +(defmethod compute-virtual-slot-accessors ((class gobject-class) (slotd effective-gobject-slot-definition) direct-slotds) (with-slots (type) slotd - (let ((param-name (slot-definition-location (first direct-slotds))) - (type-number (find-type-number type)) - (reader (intern-reader-function type)) - (writer (intern-writer-function type)) - (destroy (intern-destroy-function type))) + (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 - (funcall reader gvalue +gvalue-value-offset+) + (%object-get-property object pname gvalue) + (unwind-protect + (funcall + (intern-reader-function type) gvalue +gvalue-value-offset+) (gvalue-free gvalue t))))) #'(lambda (value object) (with-gc-disabled (let ((gvalue (gvalue-new type-number))) - (funcall writer value gvalue +gvalue-value-offset+) - (%object-set-property object param-name gvalue) - (funcall destroy gvalue +gvalue-value-offset+) + (funcall + (intern-writer-function type) + value gvalue +gvalue-value-offset+) + (%object-set-property object pname gvalue) + (funcall + (intern-destroy-function type) + gvalue +gvalue-value-offset+) (gvalue-free gvalue nil) value))))))) - (defmethod validate-superclass ((class gobject-class) (super pcl::standard-class)) - (subtypep (class-name super) 'gobject)) +; (subtypep (class-name super) 'gobject) + t) + ;;;; -; (defmacro defclass-by-query (name) -; (destructuring-bind (lisp-name alien-name) name - \ No newline at end of file +(defbinding %object-class-list-properties () pointer + (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 default-slot-name (name) + (intern (substitute #\- #\_ (string-upcase (string-upcase name))))) + +(defun default-slot-accessor (class-name slot-name type) + (intern + (format + nil "~A-~A~A" class-name slot-name + (if (eq 'boolean type) "-P" "")))) + +(defun expand-gobject-type (type-number &optional options + (metaclass 'gobject-class)) + (let* ((super (supertype type-number)) + (class (type-from-number type-number)) + (override-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 (type-from-number value-type #|t|#)) + (accessor + (default-slot-accessor class slot-name slot-type))) + `(,slot-name + :allocation :property + :pname ,name + ,@(cond + ((and + (member :writable flags) + (member :readable flags)) + (list :accessor accessor)) + ((member :writable flags) + (list :writer `(setf ,accessor))) + ((member :readable flags) + (list :reader accessor))) + ,@(when (or + (member :construct 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 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)))) + + `(progn + (defclass ,class (,super) + ,expanded-slots + (:metaclass ,metaclass) + (:alien-name ,(find-type-name type-number)))))) + + +(register-derivable-type 'gobject "GObject" 'expand-gobject-type) +