X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/81594ec43a7a4ce2021f6c0f385460d6bc6ac187..5de2b5f6a587aff7590db74f3aa7eb622cd8904c:/glib/gboxed.lisp diff --git a/glib/gboxed.lisp b/glib/gboxed.lisp index 1da0bed..78fd62b 100644 --- a/glib/gboxed.lisp +++ b/glib/gboxed.lisp @@ -1,102 +1,119 @@ -;; 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: gboxed.lisp,v 1.8 2002-01-20 14:52:04 espen Exp $ +;; $Id: gboxed.lisp,v 1.20 2006-02-04 12:15:31 espen Exp $ (in-package "GLIB") -(eval-when (:compile-toplevel :load-toplevel :execute) - (init-types-in-library "libgobject-1.3.so") - (defclass boxed (proxy) - () - (:metaclass proxy-class) - (:copy %boxed-copy) - (:free %boxed-free))) - -(defbinding %boxed-copy (type location) pointer - ((find-type-number type) type-number) - (location pointer)) +(defclass boxed (struct) + () + (:metaclass struct-class)) -(defbinding %boxed-free (type location) nil - ((find-type-number type) type-number) - (location pointer)) +(defmethod instance-finalizer ((instance boxed)) + (let ((location (foreign-location instance)) + (type-number (type-number-of instance))) + #'(lambda () + (remove-cached-instance location) + (%boxed-free type-number location)))) ;;;; Metaclass for boxed classes (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass boxed-class (proxy-class)) + (defclass boxed-class (struct-class) + ()) + (defmethod validate-superclass ((class boxed-class) (super standard-class)) + (subtypep (class-name super) 'boxed))) - (defmethod shared-initialize ((class boxed-class) names - &rest initargs &key name alien-name) - (declare (ignore initargs names)) - (call-next-method) - - (let* ((class-name (or name (class-name class))) - (type-number - (find-type-number - (or (first alien-name) (default-alien-type-name class-name))))) - (register-type class-name type-number))) +(defmethod shared-initialize ((class boxed-class) names &key name gtype) + (declare (ignore names)) + (call-next-method) + (let ((class-name (or name (class-name class)))) + (unless (find-type-number class-name) + (register-type class-name + (or (first gtype) (default-type-init-name class-name)))))) - (defmethod validate-superclass - ((class boxed-class) (super pcl::standard-class)) - (subtypep (class-name super) 'boxed))) +(defbinding %boxed-copy () pointer + (type-number type-number) + (location pointer)) + +(defbinding %boxed-free () nil + (type-number type-number) + (location pointer)) + +(defmethod reference-foreign ((class boxed-class) location) + (%boxed-copy (find-type-number class) location)) + +(defmethod unreference-foreign ((class boxed-class) location) + (%boxed-free (find-type-number class) location)) ;;;; -(defun expand-boxed-type (type-number &optional slots) +(defun expand-boxed-type (type-number forward-p slots) `(defclass ,(type-from-number type-number) (boxed) - ,slots + ,(unless forward-p + slots) (:metaclass boxed-class) - (:alien-name ,(find-type-name type-number)))) + (:gtype ,(register-type-as type-number)))) (register-derivable-type 'boxed "GBoxed" 'expand-boxed-type) ;;;; Special boxed types -(defclass gstring (boxed) - () - (:metaclass boxed-class) - (:alien-name "GString")) - -(deftype-method translate-from-alien - gstring (type-spec location &optional weak-ref) - `(let ((location ,location)) - (unless (null-pointer-p location) - (prog1 - (c-call::%naturalize-c-string location) - ,(unless weak-ref - (unreference-alien type-spec location)))))) - -(deftype-method translate-to-alien - gstring (type-spec string &optional weak-ref) - (declare (ignore weak-ref)) - `(let ((string ,string)) - ;; Always copy strings to prevent seg fault due to GC - (funcall - ',(proxy-class-copy (find-class type-spec)) - ',type-spec - (make-pointer (1+ (kernel:get-lisp-obj-address string)))))) - -(deftype-method cleanup-alien gstring (type-spec c-string &optional weak-ref) - (when weak-ref - (unreference-alien type-spec c-string))) +;; (defclass gstring (boxed) +;; () +;; (:metaclass boxed-class) +;; (:alien-name "GString")) + +;; (deftype-method translate-from-alien +;; gstring (type-spec location &optional weak-ref) +;; `(let ((location ,location)) +;; (unless (null-pointer-p location) +;; (prog1 +;; (c-call::%naturalize-c-string location) +;; ,(unless weak-ref +;; (unreference-alien type-spec location)))))) + +;; (deftype-method translate-to-alien +;; gstring (type-spec string &optional weak-ref) +;; (declare (ignore weak-ref)) +;; `(let ((string ,string)) +;; ;; Always copy strings to prevent seg fault due to GC +;; (funcall +;; ',(proxy-class-copy (find-class type-spec)) +;; ',type-spec +;; (make-pointer (1+ (kernel:get-lisp-obj-address string)))))) + +;; (deftype-method cleanup-alien gstring (type-spec c-string &optional weak-ref) +;; (when weak-ref +;; (unreference-alien type-spec c-string))) + + + +;;;; NULL terminated vector of strings +(deftype strings () '(null-terminated-vector string)) +(register-type 'strings '|g_strv_get_type|)