X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/73572c12ccd49c661d06287903bfa725f5fd93a5..5c9cc66aa5fa72f1edce094b9c3fe476705de040:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 811c837..f0b0ef1 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.31 2005-02-03 23:09:04 espen Exp $ +;; $Id: gobject.lisp,v 1.36 2005-04-23 16:48:51 espen Exp $ (in-package "GLIB") @@ -102,15 +107,16 @@ (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 (reader-function type))) + (let ((reader nil)) #'(lambda (object) - (let ((gvalue (gvalue-new type-number))) + (unless reader + (setq reader (reader-function type))) + (let ((gvalue (gvalue-new type))) (%object-get-property object pname gvalue) (unwind-protect (funcall reader gvalue +gvalue-value-offset+) @@ -119,9 +125,11 @@ (when (and (not (slot-boundp slotd 'setter)) (slot-writable-p slotd)) (setf (slot-value slotd 'setter) - (let ((writer (writer-function type))) + (let ((writer nil)) #'(lambda (value object) - (let ((gvalue (gvalue-new type-number))) + (unless writer + (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) @@ -155,7 +163,7 @@ (defclass gobject (ginstance) () (:metaclass gobject-class) - (:alien-name "GObject"))) + (:gtype "GObject"))) (defun initial-add (object function initargs key pkey) @@ -329,14 +337,15 @@ (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) ))) @@ -360,8 +369,9 @@ `(,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 @@ -385,12 +395,15 @@ '(:construct t)) ;; initargs - ,@(when (or (member :construct flags) - (member :construct-only flags) - (member :writable flags)) - (list :initarg (intern (string slot-name) "KEYWORD"))) - ,@(cond - ((find :initarg args) (list :initarg (getf args :initarg)))) + ,@(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)))) @@ -420,13 +433,18 @@ (class (type-from-number type)) (slots (getf options :slots))) `(defclass ,class ,supers - ,(unless forward-p - (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 (mapcar #'param-value-type (query-object-class-properties 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 'gobject-dependencies)