X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/a905f5d98e5623f6a6be5508600427d33c780b07..d59045234b5dffd33c0010c9f63c7d2d0d9f09d8:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 8f9b611..1d6128f 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 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,18 +15,23 @@ ;; 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.4 2001/01/28 14:17:12 espen Exp $ (in-package "GLIB") (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass gobject (gtype) + (defclass gobject (ginstance) () - (:metaclass gtype-class) - (:alien-name "GObject")) + (:metaclass ginstance-class) + (:alien-name "GObject"))) - (defclass gobject-class (gtype-class))) + +;;;; Object construction + +(define-foreign ("g_object_new" %gobject-new) () gobject + (type type-number) + (nil null)) ;;;; Reference counting for gobject @@ -56,54 +61,27 @@ (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)) - - -;;;; User data mechanism +;;;; Parameter stuff -(declaim (fixnum *user-data-count*)) - -(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 +89,13 @@ (define-foreign %object-set-qdata-full () nil (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,7 +108,18 @@ (defun object-data (object key &key (test #'eq)) -;;;; Methods for gobject-class +;;;; Metaclass used for subclasses of gobject + +(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))) + +(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) @@ -155,3 +147,52 @@ (default-alien-func-name ; (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 (get-reader-function type)) + (writer (get-writer-function type)) + (destroy (get-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))