X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/a90441812ae6371c08c3e3cb6eac47168115b9c7..c630da1bd52d451992a9b135a4099fd09520cab4:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index f0d33b4..8c54999 100644 --- a/glib/gobject.lisp +++ b/glib/gobject.lisp @@ -1,5 +1,5 @@ ;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2000 Espen S. Johnsen +;; Copyright (C) 2000-2001 Espen S. Johnsen ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -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.4 2001-01-28 14:17:12 espen Exp $ +;; $Id: gobject.lisp,v 1.9 2001-10-21 21:52:53 espen Exp $ (in-package "GLIB") @@ -24,66 +24,49 @@ (defclass gobject (ginstance) () (:metaclass ginstance-class) - (:alien-name "GObject"))) + (:alien-name "GObject") + (:ref "g_object_ref") + (:unref "g_object_unref"))) - -;;;; Object construction - -(define-foreign ("g_object_new" %gobject-new) () gobject +(defmethod initialize-instance ((object gobject) &rest initargs) + (declare (ignore initargs)) + (setf + (slot-value object 'location) + (%gobject-new (type-number-of object))) +; (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)) + ) + +(defbinding (%gobject-new "g_object_new") () pointer (type type-number) (nil null)) -;;;; Reference counting for gobject - -;; Specializing reference-instance and unreference-instance on gobject -;; is not really necessary but done for efficiency - -(defmethod reference-instance ((object gobject)) - (%object-ref object) - object) - -(defmethod unreference-instance ((object gobject)) - (%object-unref object)) - -(deftype-method alien-ref gobject (type-spec) - (declare (ignore type-spec)) - '%object-ref) -(deftype-method alien-unref gobject (type-spec) - (declare (ignore type-spec)) - '%object-unref) +;;;; Property stuff -(define-foreign %object-ref () pointer - (object (or gobject pointer))) - -(define-foreign %object-unref () nil - (object (or gobject pointer))) - - -;;;; Parameter stuff - -(define-foreign %object-set-property () nil +(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) @@ -98,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)) @@ -113,86 +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))) -(defmethod allocate-alien-storage ((class gobject-class)) - (alien-instance-location (%gobject-new (find-type-number class)))) - -(defmethod shared-initialize ((class gobject-class) names &rest initargs - &key type-init name) - (declare (ignore initargs names)) - (let ((alien - (alien::%heap-alien - (alien::make-heap-alien-info - :type (alien::parse-alien-type '(function (unsigned 32))) - :sap-form (system:foreign-symbol-address - (or - (first type-init) - (default-alien-func-name - (format - nil "~A_get_type" (or name (class-name class)))))))))) - (alien:alien-funcall alien)) - (call-next-method)) - - -; (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 (get-reader-function type)) - (writer (get-writer-function type)) - (destroy (get-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) + + + +;;;; + +(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) +