X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/33939600f4eeda6c3e54f575a633f1247cf4cbce..42e68ad2e0b1de35c307ac170d8e3c993baed6ac:/glib/genums.lisp diff --git a/glib/genums.lisp b/glib/genums.lisp index 1ed19c2..c1548e0 100644 --- a/glib/genums.lisp +++ b/glib/genums.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: genums.lisp,v 1.9 2005-02-11 19:09:38 espen Exp $ +;; $Id: genums.lisp,v 1.19 2006-02-26 15:30:01 espen Exp $ (in-package "GLIB") @@ -23,65 +28,60 @@ (defun %map-enum (mappings op) (loop - as value = 1 then (1+ value) + as value = 0 then (1+ value) for mapping in mappings collect (let ((symbol (if (atom mapping) mapping (first mapping)))) (unless (atom mapping) (setq value (second mapping))) (ecase op - (:symbol-int (list symbol value)) - (:int-symbol (list value symbol)) + (:symbol-int `(,symbol ,value)) + (:int-symbol `(,value ,symbol)) + (:int-quoted-symbol `(,value ',symbol)) (:symbols symbol))))) (deftype enum (&rest args) `(member ,@(%map-enum args :symbols))) -(defmethod alien-type ((type (eql 'enum)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type enum)) + (declare (ignore type)) (alien-type 'signed)) -(defmethod size-of ((type (eql 'enum)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type enum)) + (declare (ignore type)) (size-of 'signed)) -(defmethod to-alien-form (form (type (eql 'enum)) &rest args) - (declare (ignore type)) +(define-type-method to-alien-form ((type enum) form ) `(case ,form - ,@(%map-enum args :symbol-int) - (t (error 'type-error :datum ,form :expected-type '(enum ,@args))))) + ,@(%map-enum (rest (type-expand-to 'enum type)) :symbol-int) + (t (error 'type-error :datum ,form :expected-type ',type)))) +(define-type-method from-alien-form ((type enum) form) + `(case ,form + ,@(%map-enum (rest (type-expand-to 'enum type)) :int-quoted-symbol))) -(defmethod from-alien-form (form (type (eql 'enum)) &rest args) - (declare (ignore type)) - `(ecase ,form - ,@(%map-enum args :int-symbol))) - -(defmethod to-alien-function ((type (eql 'enum)) &rest args) - (declare (ignore type)) - (let ((mappings (%map-enum args :symbol-int))) +(define-type-method to-alien-function ((type enum)) + (let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :symbol-int))) #'(lambda (enum) (or (second (assoc enum mappings)) - (error 'type-error :datum enum :expected-type (cons 'enum args)))))) + (error 'type-error :datum enum :expected-type type))))) -(defmethod from-alien-function ((type (eql 'enum)) &rest args) - (declare (ignore type)) - (let ((mappings (%map-enum args :int-symbol))) +(define-type-method from-alien-function ((type enum)) + (let ((mappings (%map-enum (rest (type-expand-to 'enum type)) :int-symbol))) #'(lambda (int) (second (assoc int mappings))))) -(defmethod writer-function ((type (eql 'enum)) &rest args) - (declare (ignore type)) +(define-type-method writer-function ((type enum)) (let ((writer (writer-function 'signed)) - (function (apply #'to-alien-function 'enum args))) + (function (to-alien-function (type-expand-to 'enum type)))) #'(lambda (enum location &optional (offset 0)) (funcall writer (funcall function enum) location offset)))) -(defmethod reader-function ((type (eql 'enum)) &rest args) - (declare (ignore type)) +(define-type-method reader-function ((type enum)) (let ((reader (reader-function 'signed)) - (function (apply #'from-alien-function 'enum args))) - #'(lambda (location &optional (offset 0)) + (function (from-alien-function (type-expand-to 'enum type)))) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (funcall function (funcall reader location offset))))) (defun enum-int (enum type) @@ -106,29 +106,30 @@ ,@(%map-enum args :symbol-int) (t (error 'type-error :datum enum :expected-type ',name)))) (defun ,int-enum (value) - (ecase value - ,@(%map-enum args :int-symbol))) - (defmethod to-alien-form (form (type (eql ',name)) &rest args) - (declare (ignore type args)) + (case value + ,@(%map-enum args :int-quoted-symbol))) + (define-type-method to-alien-form ((type ,name) form) + (declare (ignore type)) (list ',enum-int form)) - (defmethod from-alien-form (form (type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method from-alien-form ((type ,name) form) + (declare (ignore type)) (list ',int-enum form)) - (defmethod to-alien-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method to-alien-function ((type ,name)) + (declare (ignore type)) #',enum-int) - (defmethod from-alien-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method from-alien-function ((type ,name)) + (declare (ignore type)) #',int-enum) - (defmethod writer-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method writer-function ((type ,name)) + (declare (ignore type)) (let ((writer (writer-function 'signed))) #'(lambda (enum location &optional (offset 0)) (funcall writer (,enum-int enum) location offset)))) - (defmethod reader-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method reader-function ((type ,name)) + (declare (ignore type)) (let ((reader (reader-function 'signed))) - #'(lambda (location &optional (offset 0)) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (,int-enum (funcall reader location offset)))))))) @@ -142,68 +143,62 @@ (unless (atom mapping) (setq value (second mapping))) (ecase op - (:symbol-int (list symbol value)) - (:int-symbol (list value symbol)) + (:symbol-int `(,symbol ,value)) + (:int-symbol `(,value ,symbol)) (:symbols symbol))))) (deftype flags (&rest args) `(or (member ,@(%map-flags args :symbols)) list)) -(defmethod alien-type ((type (eql 'flags)) &rest args) - (declare (ignore type args)) +(define-type-method alien-type ((type flags)) + (declare (ignore type)) (alien-type 'unsigned)) -(defmethod size-of ((type (eql 'flags)) &rest args) - (declare (ignore type args)) +(define-type-method size-of ((type flags)) + (declare (ignore type)) (size-of 'unsigned)) -(defmethod to-alien-form (flags (type (eql 'flags)) &rest args) +(define-type-method to-alien-form ((type flags) flags) `(reduce #'logior (mklist ,flags) :key #'(lambda (flag) (case flag - ,@(%map-flags args :symbol-int) - (t (error 'type-error :datum ,flags - :expected-type '(,type ,@args))))))) + ,@(%map-flags (rest (type-expand-to 'flags type)) :symbol-int) + (t (error 'type-error :datum ,flags :expected-type ',type)))))) -(defmethod from-alien-form (int (type (eql 'flags)) &rest args) - (declare (ignore type)) +(define-type-method from-alien-form ((type flags) value) `(loop - for mapping in ',(%map-flags args :int-symbol) - unless (zerop (logand ,int (first mapping))) - collect (second mapping))) + for (int symbol) in ',(%map-flags (rest (type-expand-to 'flags type)) :int-symbol) + when (= (logand ,value int) int) + collect symbol)) -(defmethod to-alien-function ((type (eql 'flags)) &rest args) - (declare (ignore type)) - (let ((mappings (%map-flags args :symbol-int))) +(define-type-method to-alien-function ((type flags)) + (let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :symbol-int))) #'(lambda (flags) (reduce #'logior (mklist flags) :key #'(lambda (flag) (or (second (assoc flag mappings)) - (error 'type-error :datum flags - :expected-type (cons 'flags args)))))))) + (error 'type-error :datum flags :expected-type type))))))) -(defmethod from-alien-function ((type (eql 'flags)) &rest args) - (declare (ignore type)) - (let ((mappings (%map-flags args :int-symbol))) - #'(lambda (int) +(define-type-method from-alien-function ((type flags)) + (let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :int-symbol))) + #'(lambda (value) (loop - for mapping in mappings - unless (zerop (logand int (first mapping))) - collect (second mapping))))) + for (int symbol) in mappings + when (= (logand value int) int) + collect symbol)))) -(defmethod writer-function ((type (eql 'flags)) &rest args) - (declare (ignore type)) +(define-type-method writer-function ((type flags)) (let ((writer (writer-function 'unsigned)) - (function (apply #'to-alien-function 'flags args))) + (function (to-alien-function (type-expand-to 'flags type)))) #'(lambda (flags location &optional (offset 0)) (funcall writer (funcall function flags) location offset)))) -(defmethod reader-function ((type (eql 'flags)) &rest args) - (declare (ignore type)) +(define-type-method reader-function ((type flags)) (let ((reader (reader-function 'unsigned)) - (function (apply #'from-alien-function 'flags args))) - #'(lambda (location &optional (offset 0)) + (function (from-alien-function (type-expand-to 'flags type)))) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (funcall function (funcall reader location offset))))) @@ -230,36 +225,37 @@ :expected-type ',name)))))) (defun ,int-flags (value) (loop - for mapping in ',(%map-flags args :int-symbol) - unless (zerop (logand value (first mapping))) - collect (second mapping))) - (defmethod alien-type ((type (eql ',name)) &rest args) - (declare (ignore type args)) + for (int symbol) in ',(%map-flags args :int-symbol) + when(= (logand value int) int) + collect symbol)) + (define-type-method alien-type ((type ,name)) + (declare (ignore type)) (alien-type 'flags)) - (defmethod size-of ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method size-of ((type ,name)) + (declare (ignore type)) (size-of 'flags)) - (defmethod to-alien-form (form (type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method to-alien-form ((type ,name) form) + (declare (ignore type)) (list ',flags-int form)) - (defmethod from-alien-form (form (type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method from-alien-form ((type ,name) form) + (declare (ignore type)) (list ',int-flags form)) - (defmethod to-alien-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method to-alien-function ((type ,name)) + (declare (ignore type)) #',flags-int) - (defmethod from-alien-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method from-alien-function ((type ,name)) + (declare (ignore type)) #',int-flags) - (defmethod writer-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (define-type-method writer-function ((type ,name)) + (declare (ignore type)) (let ((writer (writer-function 'signed))) #'(lambda (flags location &optional (offset 0)) - (funcall writer (,flags-int flags) location offset)))) - (defmethod reader-function ((type (eql ',name)) &rest args) - (declare (ignore type args)) + (funcall writer (,flags-int flags) location offset)))) + (define-type-method reader-function ((type ,name)) + (declare (ignore type)) (let ((reader (reader-function 'signed))) - #'(lambda (location &optional (offset 0)) + #'(lambda (location &optional (offset 0) weak-p) + (declare (ignore weak-p)) (,int-flags (funcall reader location offset)))))))) @@ -270,8 +266,8 @@ (multiple-value-bind (sap length) (funcall query-function (type-class-ref type)) (let ((values nil) - (size (proxy-instance-size (find-class class))) - (proxy (make-instance class :location sap))) + (size (foreign-size (find-class class))) + (proxy (ensure-proxy-instance class sap))) (dotimes (i length) (with-slots (location nickname value) proxy (setf location sap) @@ -330,7 +326,7 @@ (remove-if #'(lambda (mapping) (eq (second mapping) nil)) mappings)))) `(progn - (register-type ',type ,(find-type-name type-number)) + (register-type ',type ',(find-type-init-function type-number)) ,(ecase super (enum `(define-enum-type ,type ,@expanded-mappings)) (flags `(define-flags-type ,type ,@expanded-mappings))))))