X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/174e8a5c912f039536d7362ba566d15463106537..c0e198829957eb9122532707013fb324f4ef1d14:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 01f3998..bd0151f 100644 --- a/glib/gobject.lisp +++ b/glib/gobject.lisp @@ -1,21 +1,26 @@ -;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2000-2001 Espen S. Johnsen +;; Common Lisp bindings for GTK+ v2.x +;; Copyright 2000-2005 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 -;; License as published by the Free Software Foundation; either -;; version 2 of the License, or (at your option) any later version. +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: ;; -;; This library is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; Lesser General Public License for more details. +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. ;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gobject.lisp,v 1.26 2004-12-29 21:07:46 espen Exp $ +;; $Id: gobject.lisp,v 1.45 2006-02-08 22:10:47 espen Exp $ (in-package "GLIB") @@ -23,11 +28,12 @@ (in-package "GLIB") ;;;; Metaclass used for subclasses of gobject (eval-when (:compile-toplevel :load-toplevel :execute) +;; (push :debug-ref-counting *features*) (defclass gobject-class (ginstance-class) - ()) + ((instance-slots-p :initform nil + :documentation "Non NIL if the class has slots with instance allocation"))) - (defmethod validate-superclass ((class gobject-class) - (super pcl::standard-class)) + (defmethod validate-superclass ((class gobject-class) (super standard-class)) ; (subtypep (class-name super) 'gobject) t)) @@ -56,6 +62,27 @@ (defbinding %object-ref () pointer (defbinding %object-unref () nil (location pointer)) +#+glib2.8 +(progn + (defcallback toggle-ref-callback (nil (data pointer) (location pointer) (last-ref-p boolean)) + #+debug-ref-counting + (if last-ref-p + (format t "Object at 0x~8,'0X has no foreign references~%" (sap-int location)) + (format t "Foreign reference added to object at 0x~8,'0X~%" (sap-int location))) + (if last-ref-p + (cache-instance (find-cached-instance location) t) + (cache-instance (find-cached-instance location) nil))) + + (defbinding %object-add-toggle-ref () pointer + (location pointer) + ((callback toggle-ref-callback) pointer) + (nil null)) + + (defbinding %object-remove-toggle-ref () pointer + (location pointer) + ((callback toggle-ref-callback) pointer) + (nil null))) + (defmethod reference-foreign ((class gobject-class) location) (declare (ignore class)) (%object-ref location)) @@ -64,6 +91,16 @@ (defmethod unreference-foreign ((class gobject-class) location) (declare (ignore class)) (%object-unref location)) +#+debug-ref-counting +(progn + (defcallback weak-ref-callback (nil (data pointer) (location pointer)) + (format t "Object at 0x~8,'0X being finalized~%" (sap-int location))) + + (defbinding %object-weak-ref () pointer + (location pointer) + ((callback weak-ref-callback) pointer) + (nil null))) + ; (defbinding object-class-install-param () nil ; (class pointer) @@ -103,17 +140,16 @@ (defmethod compute-effective-slot-definition-initargs ((class gobject-class) dir (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))) + (let ((type (slot-definition-type slotd)) + (pname (slot-definition-pname slotd))) (when (and (not (slot-boundp slotd 'getter)) (slot-readable-p slotd)) (setf (slot-value slotd 'getter) (let ((reader nil)) #'(lambda (object) (unless reader - (setq reader (reader-function type))) ;(type-from-number type-number)))) - (let ((gvalue (gvalue-new type-number))) + (setq reader (reader-function type))) + (let ((gvalue (gvalue-new type))) (%object-get-property object pname gvalue) (unwind-protect (funcall reader gvalue +gvalue-value-offset+) @@ -125,8 +161,8 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de (let ((writer nil)) #'(lambda (value object) (unless writer - (setq writer (writer-function type))) ;(type-from-number type-number)))) - (let ((gvalue (gvalue-new type-number))) + (setq writer (writer-function type))) + (let ((gvalue (gvalue-new type))) (funcall writer value gvalue +gvalue-value-offset+) (%object-set-property object pname gvalue) (gvalue-free gvalue t) @@ -136,28 +172,49 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de (defmethod initialize-internal-slot-functions ((slotd effective-user-data-slot-definition)) (let ((slot-name (slot-definition-name slotd))) - (setf - (slot-value slotd 'getter) - #'(lambda (object) - (prog1 (user-data object slot-name)))) - (setf - (slot-value slotd 'setter) - #'(lambda (value object) - (setf (user-data object slot-name) value))) - (setf - (slot-value slotd 'boundp) - #'(lambda (object) - (user-data-p object slot-name)))) + (unless (slot-boundp slotd 'getter) + (setf + (slot-value slotd 'getter) + #'(lambda (object) + (prog1 (user-data object slot-name))))) + (unless (slot-boundp slotd 'setter) + (setf + (slot-value slotd 'setter) + #'(lambda (value object) + (setf (user-data object slot-name) value)))) + (unless (slot-boundp slotd 'boundp) + (setf + (slot-value slotd 'boundp) + #'(lambda (object) + (user-data-p object slot-name))))) (call-next-method)) +(defmethod shared-initialize :after ((class gobject-class) names &rest initargs) + (declare (ignore initargs)) + (when (some #'(lambda (slotd) + (and + (eq (slot-definition-allocation slotd) :instance) + (not (typep slotd 'effective-special-slot-definition)))) + (class-slots class)) + (setf (slot-value class 'instance-slots-p) t))) + + ;;;; Super class for all classes in the GObject type hierarchy (eval-when (:compile-toplevel :load-toplevel :execute) (defclass gobject (ginstance) - () + (#+debug-ref-counting + (ref-count :allocation :alien :type int :reader ref-count)) (:metaclass gobject-class) - (:alien-name "GObject"))) + (:gtype "GObject"))) + +#+debug-ref-counting +(defmethod print-object ((instance gobject) stream) + (print-unreadable-object (instance stream :type t :identity nil) + (if (proxy-valid-p instance) + (format stream "at 0x~X (~D)" (sap-int (foreign-location instance)) (ref-count instance)) + (write-string "at \"unbound\"" stream)))) (defun initial-add (object function initargs key pkey) @@ -176,9 +233,26 @@ (defun initial-apply-add (object function initargs key pkey) initargs key pkey)) +(defmethod make-proxy-instance ((class gobject-class) location &rest initargs) + (declare (ignore location initargs)) + (if (slot-value class 'instance-slots-p) + (error "An object of class ~A has instance slots and should only be created with MAKE-INSTANCE" class) + (call-next-method))) + +(defmethod initialize-instance :around ((object gobject) &rest initargs) + (declare (ignore initargs)) + (call-next-method) + #+debug-ref-counting(%object-weak-ref (foreign-location object)) + #+glib2.8 + (when (slot-value (class-of object) 'instance-slots-p) + (with-slots (location) object + (%object-add-toggle-ref location) + (%object-unref location)))) + + (defmethod initialize-instance ((object gobject) &rest initargs) - (unless (slot-boundp object 'location) - ;; Extract initargs which we should pass directly to the GObeject + (unless (proxy-valid-p object) + ;; Extract initargs which we should pass directly to the GObject ;; constructor (let* ((slotds (class-slots (class-of object))) (args (when initargs @@ -210,7 +284,7 @@ (defmethod initialize-instance ((object gobject) &rest initargs) (gvalue-init (sap+ tmp string-size) type value)) (unwind-protect (setf - (slot-value object 'location) + (foreign-location object) (%gobject-newv (type-number-of object) (length args) params)) (loop repeat (length args) @@ -219,17 +293,30 @@ (defmethod initialize-instance ((object gobject) &rest initargs) (gvalue-unset (sap+ tmp string-size))) (deallocate-memory params))) (setf - (slot-value object 'location) + (foreign-location object) (%gobject-new (type-number-of object)))))) (apply #'call-next-method object initargs)) (defmethod instance-finalizer ((instance gobject)) - (let ((location (proxy-location instance))) + (let ((location (foreign-location instance))) + #+glib2.8 + (if (slot-value (class-of instance) 'instance-slots-p) + #'(lambda () + #+debug-ref-counting + (format t "Finalizing proxy for 0x~8,'0X~%" (sap-int location)) + (remove-cached-instance location) + (%object-remove-toggle-ref location)) + #'(lambda () + #+debug-ref-counting + (format t "Finalizing proxy for 0x~8,'0X~%" (sap-int location)) + (remove-cached-instance location) + (%object-unref location))) + #-glib2.8 #'(lambda () (remove-cached-instance location) - (%object-unref location)))) + (%object-unref location)))) (defbinding (%gobject-new "g_object_new") () pointer @@ -265,22 +352,26 @@ (defbinding object-freeze-notify () nil (defbinding object-thaw-notify () nil (object gobject)) + +;;;; User data + (defbinding %object-set-qdata-full () nil (object gobject) (id quark) (data unsigned-long) (destroy-marshal pointer)) +(defcallback user-data-destroy-func (nil (id unsigned-int)) + (destroy-user-data id)) -;;;; User data +(export 'user-data-destroy-func) (defun (setf user-data) (data object key) - (%object-set-qdata-full - object (quark-from-object key) - (register-user-data data) (callback %destroy-user-data)) + (%object-set-qdata-full object (quark-intern key) + (register-user-data data) (callback user-data-destroy-func)) data) -;; depecated +;; deprecated (defun (setf object-data) (data object key &key (test #'eq)) (assert (eq test #'eq)) (setf (user-data object key) data)) @@ -290,15 +381,22 @@ (defbinding %object-get-qdata () unsigned-long (id quark)) (defun user-data (object key) - (find-user-data (%object-get-qdata object (quark-from-object key)))) + (find-user-data (%object-get-qdata object (quark-intern key)))) -;; depecated +;; deprecated (defun object-data (object key &key (test #'eq)) (assert (eq test #'eq)) (user-data object key)) (defun user-data-p (object key) - (nth-value 1 (find-user-data (%object-get-qdata object (quark-from-object key))))) + (user-data-exists-p (%object-get-qdata object (quark-intern key)))) + +(defbinding %object-steal-qdata () unsigned-long + (object gobject) + (id quark)) + +(defun unset-user-data (object key) + (destroy-user-data (%object-steal-qdata object (quark-intern key)))) ;;;; @@ -320,14 +418,15 @@ (defun %map-params (params length type inherited-p) (nreverse properties)))) (defun query-object-class-properties (type &optional inherited-p) - (let* ((type-number (find-type-number type)) + (let* ((type-number (find-type-number type t)) (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))) + (unless (null-pointer-p array) + (unwind-protect + (%map-params array length type-number inherited-p) + (deallocate-memory array)))) ; (type-class-unref type-number) ))) @@ -342,17 +441,18 @@ (defun default-slot-accessor (class-name slot-name type) (if (eq type 'boolean) "-P" "")))) -(defun slot-definition-from-property (class property &optional args) +(defun slot-definition-from-property (class property &optional slot-name args) (with-slots (name flags value-type documentation) property - (let* ((slot-name (default-slot-name name)) - (slot-type (or (getf args :type) (type-from-number value-type) value-type)) + (let* ((slot-name (or slot-name (default-slot-name name))) + (slot-type (or (getf args :type) (type-from-number value-type) 'pointer)) (accessor (default-slot-accessor class slot-name slot-type))) `(,slot-name :allocation :property :pname ,name - ,@(cond - ((find :unbound args) (list :unbound (getf args :unbound)))) + ,@(when (find :unbound args) (list :unbound (getf args :unbound))) + ,@(when (find :getter args) (list :getter (getf args :getter))) + ,@(when (find :setter args) (list :setter (getf args :setter))) ;; accessors ,@(cond @@ -376,10 +476,15 @@ (defun slot-definition-from-property (class property &optional args) '(:construct t)) ;; initargs - ,@(when (or (member :construct flags) - (member :construct-only flags) - (member :writable flags)) - (list :initarg (intern (string slot-name) "KEYWORD"))) + ,@(if (find :initarg args) + (let ((initarg (getf args :initarg))) + (etypecase initarg + (null ()) + (symbol `(:initarg ,initarg)))) + (when (or (member :construct flags) + (member :construct-only flags) + (member :writable flags)) + (list :initarg (intern (string slot-name) "KEYWORD")))) :type ,slot-type :documentation ,documentation)))) @@ -400,21 +505,30 @@ (defun slot-definitions (class properties slots) ((getf (rest slot) :merge) (setf (rest slot) - (rest (slot-definition-from-property class property (rest slot))))))) + (rest (slot-definition-from-property class property (first slot) (rest slot))))))) (delete-if #'(lambda (slot) (getf (rest slot) :ignore)) slots)) -(defun expand-gobject-type (type &optional options (metaclass 'gobject-class)) +(defun expand-gobject-type (type forward-p options &optional (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))))) + ,(unless forward-p + (slot-definitions class (query-object-class-properties type) slots)) + (:metaclass ,metaclass) + (:gtype ,(register-type-as type))))) + +(defun gobject-dependencies (type) + (delete-duplicates + (cons + (supertype type) + (append + (type-interfaces type) + (mapcar #'param-value-type (query-object-class-properties type)))))) -(register-derivable-type 'gobject "GObject" 'expand-gobject-type) +(register-derivable-type 'gobject "GObject" 'expand-gobject-type 'gobject-dependencies) ;;; Pseudo type for gobject instances which have their reference count @@ -431,7 +545,7 @@ (defmethod from-alien-form (form (type (eql 'referenced)) &rest args) (let ((instance (make-symbol "INSTANCE"))) `(let ((,instance ,(from-alien-form form type))) (when ,instance - (%object-unref (proxy-location ,instance))) + (%object-unref (foreign-location ,instance))) ,instance)) (error "~A is not a subclass of GOBJECT" type))))