X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/7479d92c2e0ee576d0d376bbbbb72a9dcb948e4b..6dfb20397142408cc4adfa437bb12d8aa300270e:/glib/gboxed.lisp diff --git a/glib/gboxed.lisp b/glib/gboxed.lisp index e2dac5c..1981347 100644 --- a/glib/gboxed.lisp +++ b/glib/gboxed.lisp @@ -1,107 +1,92 @@ -;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2001 Espen S. Johnsen +;; Common Lisp bindings for GTK+ v2.x +;; Copyright 2001-2006 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: gboxed.lisp,v 1.2 2001-04-30 11:25:25 espen Exp $ +;; $Id: gboxed.lisp,v 1.21 2006-04-25 21:55:42 espen Exp $ (in-package "GLIB") -(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass boxed (proxy) - () - (:metaclass proxy-class))) - -(defmethod initialize-proxy ((boxed boxed) &rest initargs - &key location weak-ref) - (declare (ignore initargs)) - (setf - (slot-value boxed 'location) - (if weak-ref - (%boxed-copy (find-type-number (class-of boxed)) location) - location)) - (call-next-method)) +(defclass boxed (struct) + () + (:metaclass struct-class)) -(defmethod instance-finalizer ((boxed boxed)) - (let ((location (proxy-location boxed)) - (type-number (find-type-number (class-of boxed)))) - (declare (type system-area-pointer location)) +(defmethod instance-finalizer ((instance boxed)) + (let ((location (foreign-location instance)) + (type-number (type-number-of instance))) #'(lambda () - (%boxed-free type-number location) - (remove-cached-instance location)))) + (%boxed-free type-number location)))) + +;;;; Metaclass for boxed classes -(deftype-method translate-to-alien boxed (type-spec boxed &optional weak-ref) - (if weak-ref - `(proxy-location ,boxed) - `(let ((boxed ,boxed)) - (%boxed-copy - (find-type-number type-spec) - (proxy-location boxed))))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass boxed-class (struct-class) + ()) -(deftype-method unreference-alien boxed (type-spec c-struct) - `(%boxed-free ,(find-type-number type-spec) ,c-struct)) + (defmethod validate-superclass ((class boxed-class) (super standard-class)) + (subtypep (class-name super) 'boxed))) (defbinding %boxed-copy () pointer - (type type-number) + (type-number type-number) (location pointer)) (defbinding %boxed-free () nil - (type type-number) + (type-number type-number) (location pointer)) +(defmethod shared-initialize ((class boxed-class) names + &key name gtype ref unref) + (declare (ignore names)) + (let* ((class-name (or name (class-name class))) + (type-number + (register-type class-name + (or + (first gtype) + (default-type-init-name class-name))))) + (unless (or ref (slot-boundp class 'ref)) + (setf + (slot-value class 'ref) + #'(lambda (location) + (%boxed-copy type-number location)))) + (unless (or unref (slot-boundp class 'unref)) + (setf + (slot-value class 'unref) + #'(lambda (location) + (%boxed-free type-number location))))) + (call-next-method)) -;;;; Metaclass for boxed classes -(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass boxed-class (proxy-class))) +(defun expand-boxed-type (type-number forward-p slots) + `(defclass ,(type-from-number type-number) (boxed) + ,(unless forward-p + slots) + (:metaclass boxed-class) + (:gtype ,(register-type-as type-number)))) +(register-derivable-type 'boxed "GBoxed" 'expand-boxed-type) -(defmethod shared-initialize ((class boxed-class) names - &rest initargs - &key name alien-name type-init) - (declare (ignore initargs names)) - (call-next-method) - (let* ((class-name (or name (class-name class))) - (type-number - (cond - ((and alien-name type-init) - (error - "Specify either :type-init or :alien-name for class ~A" - class-name)) - (alien-name (type-number-from-alien-name (first alien-name))) - (type-init (funcall (mkbinding (first type-init) 'type-number))) - (t - (or - (type-number-from-alien-name - (default-alien-type-name class-name) nil) - (funcall - (mkbinding - (default-alien-fname (format nil "~A_get_type" class-name)) - 'type-number))))))) - (setf (find-type-number class) type-number))) - - -(defmethod validate-superclass - ((class boxed-class) (super pcl::standard-class)) - (subtypep (class-name super) 'boxed)) - - -;;;; Initializing type numbers - -(setf (alien-type-name 'boxed) "GBoxed") +;;;; NULL terminated vector of strings + +(deftype strings () '(null-terminated-vector string)) +(register-type 'strings '|g_strv_get_type|)