X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/21299acfbcc5b6ae8e0a7bc2a26c7f55bdfbcb0b..b8a9e4d372bce9188a094d07cc738554239d8470:/glib/ginterface.lisp diff --git a/glib/ginterface.lisp b/glib/ginterface.lisp index dcf74c6..a212fa5 100644 --- a/glib/ginterface.lisp +++ b/glib/ginterface.lisp @@ -1,109 +1,118 @@ -;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2001 Espen S. Johnsen +;; Common Lisp bindings for GTK+ v2.x +;; Copyright 2001-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: ginterface.lisp,v 1.8 2005-02-10 00:20:02 espen Exp $ +;; $Id: ginterface.lisp,v 1.19 2007-01-02 16:06:15 espen Exp $ (in-package "GLIB") (use-prefix "g") -;;;; +;;;; Superclass for interfaces -(defclass ginterface () +(defclass interface () ()) + ;;;; Metaclass for interfaces (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass ginterface-class (virtual-slots-class) + (defclass interface-class (virtual-slots-class) ())) -(defmethod direct-slot-definition-class ((class ginterface-class) &rest initargs) +(defmethod direct-slot-definition-class ((class interface-class) &rest initargs) (case (getf initargs :allocation) (:property (find-class 'direct-property-slot-definition)) + (:virtual (find-class 'direct-virtual-alien-slot-definition)) (t (call-next-method)))) -(defmethod effective-slot-definition-class ((class ginterface-class) &rest initargs) +(defmethod effective-slot-definition-class ((class interface-class) &rest initargs) (case (getf initargs :allocation) (:property (find-class 'effective-property-slot-definition)) + (:virtual (find-class 'effective-virtual-alien-slot-definition)) (t (call-next-method)))) -(defmethod compute-effective-slot-definition-initargs ((class ginterface-class) direct-slotds) - (if (eq (most-specific-slot-value direct-slotds 'allocation) :property) +(defmethod compute-effective-slot-definition-initargs ((class interface-class) direct-slotds) + (if (eq (slot-definition-allocation (first direct-slotds)) :property) (nconc (list :pname (signal-name-to-string (most-specific-slot-value direct-slotds 'pname)) :readable (most-specific-slot-value direct-slotds 'readable) :writable (most-specific-slot-value direct-slotds 'writable) - :construct (most-specific-slot-value direct-slotds 'construct)) + :construct-only (most-specific-slot-value direct-slotds 'construct)) (call-next-method)) (call-next-method))) -(defmethod shared-initialize ((class ginterface-class) names - &rest initargs &key name alien-name) - (declare (ignore initargs names)) - (let* ((class-name (or name (class-name class))) +(defmethod shared-initialize ((class interface-class) names &key name gtype) + (declare (ignore names)) + (let* ((class-name (or name (class-name class))) (type-number - (find-type-number - (or (first alien-name) (default-alien-type-name class-name)) t))) - (register-type class-name type-number)) + (or + (find-type-number class-name) + (register-type class-name + (or (first gtype) (default-type-init-name class-name)))))) + (type-default-interface-ref type-number)) (call-next-method)) -(defmethod validate-superclass ((class ginterface-class) (super standard-class)) - (subtypep (class-name super) 'ginterface)) +(defmethod validate-superclass ((class interface-class) (super standard-class)) + (subtypep (class-name super) 'interface)) -(defmethod alien-type ((class ginterface-class) &rest args) - (declare (ignore class args)) +(define-type-method alien-type ((type interface)) + (declare (ignore type)) (alien-type 'gobject)) -(defmethod size-of ((class ginterface-class) &rest args) - (declare (ignore class args)) +(define-type-method size-of ((type interface) &key inlined) + (assert-not-inlined type inlined) (size-of 'gobject)) -(defmethod from-alien-form (location (class ginterface-class) &rest args) - (declare (ignore class args)) - (from-alien-form location 'gobject)) +(define-type-method from-alien-form ((type interface) location &key (ref :copy)) + (declare (ignore type)) + (from-alien-form 'gobject location :ref ref)) -(defmethod from-alien-function ((class ginterface-class) &rest args) - (declare (ignore class args)) - (from-alien-function 'gobject)) +(define-type-method from-alien-function ((type interface) &key (ref :copy)) + (declare (ignore type)) + (from-alien-function 'gobject :ref ref)) -(defmethod to-alien-form (instance (class ginterface-class) &rest args) - (declare (ignore class args)) - (to-alien-form instance 'gobject)) +(define-type-method to-alien-form ((type interface) instance &optional copy-p) + (declare (ignore type)) + (to-alien-form 'gobject instance copy-p)) -(defmethod to-alien-function ((class ginterface-class) &rest args) - (declare (ignore class args)) - (to-alien-function 'gobject)) +(define-type-method to-alien-function ((type interface) &optional copy-p) + (declare (ignore type)) + (to-alien-function 'gobject copy-p)) -(defmethod reader-function ((class ginterface-class) &rest args) - (declare (ignore class args)) - (reader-function 'gobject)) +(define-type-method reader-function ((type interface) &key ref inlined) + (assert-not-inlined type inlined) + (reader-function 'gobject :ref ref)) -(defmethod writer-function ((class ginterface-class) &rest args) - (declare (ignore class args)) - (writer-function 'gobject)) +(define-type-method writer-function ((type interface) &key temp inlined) + (assert-not-inlined type inlined) + (writer-function 'gobject :temp temp)) -(defmethod destroy-function ((class ginterface-class) &rest args) - (declare (ignore class args)) - (destroy-function 'gobject)) +(define-type-method destroy-function ((type interface) &key temp inlined) + (assert-not-inlined type inlined) + (destroy-function 'gobject :temp temp)) ;;;; @@ -112,8 +121,8 @@ (defmethod destroy-function ((class ginterface-class) &rest args) (defbinding type-default-interface-ref (type) pointer ((find-type-number type t) type-number)) -(defbinding type-default-interface-unref (type) nil - ((find-type-number type t) type-number)) +(defbinding type-default-interface-unref () nil + (iface pointer)) (defbinding type-default-interface-peek (type) pointer ((find-type-number type t) type-number)) @@ -132,24 +141,30 @@ (defun query-object-interface-properties (type &optional inherited-p) (unwind-protect (%map-params array length type-number inherited-p) (deallocate-memory array)))) -; (type-default-interface-unref type-number) - ))) + (type-default-interface-unref iface)))) -(defun expand-ginterface-type (type forward-p options &rest args) +(defun expand-interface-type (type forward-p options &rest args) (declare (ignore args)) (let ((class (type-from-number type)) (slots (getf options :slots))) `(defclass ,class (,(supertype type)) ,(unless forward-p (slot-definitions class (query-object-interface-properties type) slots)) - (:metaclass ginterface-class) - (:alien-name ,(find-type-name type))))) + (:metaclass interface-class) + (:gtype ,(register-type-as type))))) -(defun ginterface-dependencies (type) +(defun interface-dependencies (type options) (delete-duplicates (cons (supertype type) - (mapcar #'param-value-type (query-object-interface-properties type))))) + (append + (mapcar #'param-value-type (query-object-interface-properties type)) + (loop + for slot in (getf options :slots) + as type = (getf (rest slot) :type) + when (and type (symbolp type) (find-type-number type)) + collect (find-type-number type)))))) + -(register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type 'ginterface-dependencies) +(register-derivable-type 'interface "GInterface" 'expand-interface-type 'interface-dependencies)