X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/dfa4f31424800fdb6fb63514121b9cc893269276..5c9cc66aa5fa72f1edce094b9c3fe476705de040:/glib/gtype.lisp diff --git a/glib/gtype.lisp b/glib/gtype.lisp index 33c8baf..ea24580 100644 --- a/glib/gtype.lisp +++ b/glib/gtype.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: gtype.lisp,v 1.27 2005-03-06 17:26:23 espen Exp $ +;; $Id: gtype.lisp,v 1.32 2005-04-23 16:48:51 espen Exp $ (in-package "GLIB") @@ -201,7 +206,7 @@ (process-close process))))) -(defmacro init-types-in-library (filename &key (prefix "") ignore) +(defmacro init-types-in-library (filename &key prefix ignore) (let ((names (%find-types-in-library filename prefix ignore))) `(progn ,@(mapcar #'(lambda (name) @@ -212,12 +217,16 @@ names)))) (defun find-type-init-function (type-number) - (or - (loop - for type-init in *type-initializers* - when (= type-number (funcall type-init)) - do (return type-init)) - (error "Can't find init function for type number ~D" type-number))) + (loop + for type-init in *type-initializers* + when (= type-number (funcall type-init)) + do (return type-init))) + +(defun register-type-as (type-number) + (or + (find-type-init-function type-number) + (find-foreign-type-name type-number) + (error "Unknown type-number: ~A" type-number))) (defun default-type-init-name (type) (find-symbol (format nil "~A_~A_get_type" @@ -233,7 +242,7 @@ ())) -(defmethod shared-initialize ((class ginstance-class) names &key name gtype) +(defmethod shared-initialize ((class ginstance-class) names &rest initargs &key name gtype) (declare (ignore names)) (let* ((class-name (or name (class-name class))) (type-number @@ -241,9 +250,10 @@ (find-type-number class-name) (register-type class-name (or (first gtype) (default-type-init-name class-name)))))) - (call-next-method) - (when (slot-boundp class 'size) - (setf (slot-value class 'size) (type-instance-size type-number))))) + (if (getf initargs :size) + (call-next-method) + (let ((size (type-instance-size type-number))) + (apply #'call-next-method class names :size (list size) initargs))))) (defmethod validate-superclass ((class ginstance-class) (super standard-class)) @@ -257,17 +267,22 @@ ((class :allocation :alien :type pointer)) (:metaclass proxy-class))) -(defun %type-of-ginstance (location) +(defun %type-number-of-ginstance (location) (let ((class (sap-ref-sap location 0))) - (type-from-number (sap-ref-32 class 0)))) + (sap-ref-32 class 0))) (defmethod ensure-proxy-instance ((class ginstance-class) location) (declare (ignore class)) - (let ((class (find-class (%type-of-ginstance location)))) + (let ((class (labels ((find-known-class (type-number) + (or + (find-class (type-from-number type-number) nil) + (unless (zerop type-number) + (find-known-class (type-parent type-number)))))) + (find-known-class (%type-number-of-ginstance location))))) (if class (make-instance class :location (reference-foreign class location)) - ;; TODO: (make-instance 'ginstance ...) - location))) + (error "Object at ~A has an unkown type number: ~A" + location (%type-number-of-ginstance location))))) (defmethod copy-from-alien-form (location (class ginstance-class) &rest args) (declare (ignore location class args)) @@ -291,6 +306,7 @@ (register-type 'unsigned-char "guchar") (register-type 'boolean "gboolean") (register-type 'int "gint") +(register-type-alias 'integer 'int) (register-type-alias 'fixnum 'int) (register-type 'unsigned-int "guint") (register-type 'long "glong") @@ -442,7 +458,7 @@ (let ((name (find-foreign-type-name type-number))) (register-type (getf (type-options type-number) :type (default-type-name name)) - (find-type-init-function type-number)))) + (register-type-as type-number)))) (let ((sorted-type-list (%sort-types-topologicaly type-list))) `(progn