X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/9adccb27da69b60d058aa37867d55ea20ecf97ca..b8a9e4d372bce9188a094d07cc738554239d8470:/glib/genums.lisp diff --git a/glib/genums.lisp b/glib/genums.lisp index 4fb3c10..64dfd8a 100644 --- a/glib/genums.lisp +++ b/glib/genums.lisp @@ -1,214 +1,69 @@ -;; 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.4 2004-11-06 21:39:58 espen Exp $ +;; $Id: genums.lisp,v 1.22 2006-09-28 10:20:12 espen Exp $ (in-package "GLIB") - - -(defun %map-enum (args op) - (let ((current-value 0)) - (mapcar - #'(lambda (mapping) - (destructuring-bind (symbol &optional (value current-value)) - (mklist mapping) - (setf current-value (1+ value)) - (case op - (:enum-int (list symbol value)) - (:flags-int (list symbol value)) - (:int-enum (list value symbol)) - (:int-flags (list value symbol)) - (:symbols symbol)))) - args))) - -(defun %query-enum-or-flags-values (query-function class type) - (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))) - (dotimes (i length) - (with-slots (location nickname value) proxy - (setf location sap) - (setq sap (sap+ sap size)) - (push - (list - (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD") - value) - values))) - values))) - -;;;; Generic enum type - -(deftype enum (&rest args) - `(member ,@(%map-enum args :symbols))) - -(defmethod alien-type ((type (eql 'enum)) &rest args) - (declare (ignore type args)) - (alien-type 'signed)) - -(defmethod size-of ((type (eql 'enum)) &rest args) - (declare (ignore type args)) - (size-of 'signed)) - -(defmethod to-alien-form (form (type (eql 'enum)) &rest args) - (declare (ignore type)) - `(ecase ,form - ,@(%map-enum args :enum-int))) - -(defmethod from-alien-form (form (type (eql 'enum)) &rest args) - (declare (ignore type)) - `(ecase ,form - ,@(%map-enum args :int-enum))) - -(defmethod to-alien-function ((type (eql 'enum)) &rest args) - (let ((mappings (%map-enum args :enum-int))) - #'(lambda (enum) - (or - (second (assoc enum mappings)) - (error "~S is not of type ~S" enum (cons type args)))))) - -(defmethod from-alien-function ((type (eql 'enum)) &rest args) - (declare (ignore type)) - (let ((mappings (%map-enum args :int-enum))) - #'(lambda (int) - (second (assoc int mappings))))) - -(defmethod writer-function ((type (eql 'enum)) &rest args) - (declare (ignore type)) - (let ((writer (writer-function 'signed)) - (function (apply #'to-alien-function 'enum args))) - #'(lambda (enum location &optional (offset 0)) - (funcall writer (funcall function enum) location offset)))) - -(defmethod reader-function ((type (eql 'enum)) &rest args) - (declare (ignore type)) - (let ((reader (reader-function 'signed)) - (function (apply #'from-alien-function 'enum args))) - #'(lambda (location &optional (offset 0)) - (funcall function (funcall reader location offset))))) - - - -(defclass %enum-value (struct) - ((value :allocation :alien :type int) - (name :allocation :alien :type string) - (nickname :allocation :alien :type string)) - (:metaclass static-struct-class)) - -(defbinding %enum-class-values () pointer +;;;; Definition of enums and flags by introspection + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass enum-value (struct) + ((value :allocation :alien :type int) + (name :allocation :alien :type string) + (nickname :allocation :alien :type string)) + (:metaclass struct-class))) + +(defun map-enum-values (values symbolic-p) + (map 'list + #'(lambda (enum-value) + (with-slots (nickname name value) enum-value + (list + (cond + ((eq symbolic-p :nickname) nickname) + (symbolic-p + (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")) + (t name)) + value))) + values)) + +(defbinding enum-class-values () (static (vector (inlined enum-value) n-values)) (class pointer) (n-values unsigned-int :out)) -(defun query-enum-values (type) - (%query-enum-or-flags-values #'%enum-class-values '%enum-value type)) - - - -;;;; Generic flags type - -(deftype flags (&rest args) - `(or null (cons (member ,@(%map-enum args :symbols)) list))) - -(defmethod alien-type ((type (eql 'flags)) &rest args) - (declare (ignore type args)) - (alien-type 'unsigned)) - -(defmethod size-of ((type (eql 'flags)) &rest args) - (declare (ignore type args)) - (size-of 'unsigned)) - -(defmethod to-alien-form (flags (type (eql 'flags)) &rest args) - `(loop - with value = 0 - with flags = ,flags - for flag in (mklist flags) - do (let ((flagval - (or - (second (assoc flag ',(%map-enum args :flags-int))) - (error "~S is not of type ~S" flags '(,type ,@args))))) - (setq value (logior value flagval))) - finally (return value))) - -(defmethod from-alien-form (int (type (eql 'flags)) &rest args) - (declare (ignore type)) - `(loop - for mapping in ',(%map-enum args :int-flags) - unless (zerop (logand int (first mapping))) - collect (second mapping))) - -(defmethod to-alien-function ((type (eql 'flags)) &rest args) - (let ((mappings (%map-enum args :flags-int))) - #'(lambda (flags) - (loop - with value = 0 - for flag in (mklist flags) - do (let ((flagval (or - (second (assoc flag mappings)) - (error "~S is not of type ~S" flags (cons type args))))) - (setq value (logior value flagval))) - finally (return value))))) - -(defmethod from-alien-function ((type (eql 'flags)) &rest args) - (declare (ignore type)) - (let ((mappings (%map-enum args :int-flags))) - #'(lambda (int) - (loop - for mapping in mappings - unless (zerop (logand int (first mapping))) - collect (second mapping))))) - -(defmethod writer-function ((type (eql 'flags)) &rest args) - (declare (ignore type)) - (let ((writer (writer-function 'unsigned)) - (function (apply #'to-alien-function 'flags args))) - #'(lambda (flags location &optional (offset 0)) - (funcall writer (funcall function flags) location offset)))) - -(defmethod reader-function ((type (eql 'flags)) &rest args) - (declare (ignore type)) - (let ((reader (reader-function 'unsigned)) - (function (apply #'from-alien-function 'flags args))) - #'(lambda (location &optional (offset 0)) - (funcall function (funcall reader location offset))))) - - - -(defclass %flags-value (struct) - ((value :allocation :alien :type unsigned-int) - (name :allocation :alien :type string) - (nickname :allocation :alien :type string)) - (:metaclass static-struct-class)) - -(defbinding %flags-class-values () pointer +(defbinding flags-class-values () (static (vector (inlined enum-value) n-values)) (class pointer) (n-values unsigned-int :out)) -(defun query-flags-values (type) - (%query-enum-or-flags-values #'%flags-class-values '%flags-value type)) - - - -;;;; +(defun query-enum-values (type &optional (symbolic-p t)) + (let ((class (type-class-ref type))) + (map-enum-values (if (eq (supertype type) 'enum) + (enum-class-values class) + (flags-class-values class)) + symbolic-p))) -(defun expand-enum-type (type-number &optional options) - (let* ((super (supertype type-number)) - (type (type-from-number type-number)) +(defun expand-enum-type (type-number forward-p options) + (declare (ignore forward-p)) + (let* ((type (type-from-number type-number)) (mappings (getf options :mappings)) (expanded-mappings (append @@ -217,14 +72,14 @@ (defun expand-enum-type (type-number &optional options) (or (assoc (first mapping) mappings) (rassoc (cdr mapping) mappings :test #'equal))) - (if (eq super 'enum) - (query-enum-values type-number) - (query-flags-values type-number))) + (query-enum-values type-number)) (remove-if #'(lambda (mapping) (eq (second mapping) nil)) mappings)))) `(progn - (register-type ',type ,(find-type-name type-number)) - (deftype ,type () '(,super ,@expanded-mappings))))) + (register-type ',type ',(find-type-init-function type-number)) + ,(ecase (supertype type-number) + (enum `(define-enum-type ,type ,@expanded-mappings)) + (flags `(define-flags-type ,type ,@expanded-mappings)))))) (register-derivable-type 'enum "GEnum" 'expand-enum-type)