X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/86d9d6ab4254f6f17fe7fbd15bee6b869ff8a145..82747bbd916a0478fa35a795bcdff4fcc463370a:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 09b7cf7..0284ed4 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,95 +15,52 @@ ;; 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.2 2000-08-23 21:40:38 espen Exp $ +;; $Id: gobject.lisp,v 1.5 2001-04-29 20:17:27 espen Exp $ (in-package "GLIB") (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass gobject (gtype) + (defclass gobject (ginstance) () - (:metaclass gtype-class) - (:alien-name "GObject")) - - (defclass gobject-class (gtype-class))) - - -;;;; 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) - -(define-foreign %object-ref () pointer - (object (or gobject pointer))) - -(define-foreign %object-unref () nil - (object (or gobject pointer))) - - -;; Parameter stuff not yet implemented - -; (define-foreign object-set-param () nil -; (object gobject) -; (name string) -; (value gvalue)) - -; (define-foreign object-get-param () nil -; (object gobject) -; (name string) -; (value gvalue :out)) - -; (define-foreign object-queue-param-changed () nil -; (object gobject) -; (name string)) + (:metaclass ginstance-class) + (:alien-name "GObject") + (:ref "g_object_ref") + (:unref "g_object_unref"))) + +(defmethod initialize-instance ((object gobject) &rest initargs) + (declare (ignore initargs)) + (setf + (slot-value object 'location) + (%gobject-new (type-number-of object))) + (call-next-method)) +(define-foreign ("g_object_new" %gobject-new) () gobject + (type type-number) + (nil null)) -;;;; User data mechanism -(declaim (fixnum *user-data-count*)) +;;;; Parameter stuff -(defvar *user-data* (make-hash-table)) -(defvar *user-data-count* 0) +(define-foreign %object-set-property () nil + (object gobject) + (name string) + (value gvalue)) -;; Until the callback mechanism is moved to glib, the value of -;; *destroy-marshal* is set in gtkobject.lisp -(defvar *destroy-marshal* nil) +(define-foreign %object-get-property () nil + (object gobject) + (name string) + (value gvalue)) -(defun register-user-data (object &optional destroy-function) - (check-type destroy-function (or null symbol function)) -; (incf *user-data-count*) - (setq *user-data-count* (the fixnum (1+ *user-data-count*))) - (setf - (gethash *user-data-count* *user-data*) - (cons object destroy-function)) - *user-data-count*) +(define-foreign %object-notify () nil + (object gobject) + (name string)) -(defun find-user-data (id) - (check-type id fixnum) - (multiple-value-bind (user-data p) (gethash id *user-data*) - (values (car user-data) p))) +(define-foreign object-freeze-notify () nil + (object gobject)) -(defun destroy-user-data (id) - (check-type id fixnum) - (let ((user-data (gethash id *user-data*))) - (when (cdr user-data) - (funcall (cdr user-data) (car user-data)))) - (remhash id *user-data*)) +(define-foreign object-thaw-notify () nil + (object gobject)) (define-foreign %object-set-qdata-full () nil (object gobject) @@ -111,10 +68,13 @@ (data unsigned-long) (destroy-marshal pointer)) + +;;;; User data + (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-marshal*) + (register-user-data data) *destroy-notify*) data) (define-foreign %object-get-qdata () unsigned-long @@ -127,23 +87,15 @@ -;;;; Methods for gobject-class +;;;; Metaclass used for subclasses of gobject -(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)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass gobject-class (ginstance-class)) + + (defclass direct-gobject-slot-definition (direct-virtual-slot-definition)) + + (defclass effective-gobject-slot-definition + (effective-virtual-slot-definition))) ; (define-foreign object-class-install-param () nil @@ -155,3 +107,59 @@ ; (class pointer) ; (name string)) + +(defmethod initialize-instance :after ((slotd direct-gobject-slot-definition) + &rest initargs &key) + (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))))) + +(defmethod direct-slot-definition-class ((class gobject-class) initargs) + (case (getf initargs :allocation) + (:param (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)) + (t (call-next-method)))) + +(defmethod compute-virtual-slot-location + ((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))) + (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+) + (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+) + (gvalue-free gvalue nil) + value))))))) + + +(defmethod validate-superclass ((class gobject-class) + (super pcl::standard-class)) + (subtypep (class-name super) 'gobject)) + + +;;;; + +; (defmacro defclass-by-query (name) +; (destructuring-bind (lisp-name alien-name) name + \ No newline at end of file