X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/94f15c3c3cc7b65dd194b6c10bad3b19a3e31f53..050f6c9f2af72fa8a1114b02e823118ef258e08a:/glib/genums.lisp diff --git a/glib/genums.lisp b/glib/genums.lisp index d2cbe4a..64dfd8a 100644 --- a/glib/genums.lisp +++ b/glib/genums.lisp @@ -1,190 +1,87 @@ -;; 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.1 2001-04-29 20:19:25 espen Exp $ +;; $Id: genums.lisp,v 1.22 2006-09-28 10:20:12 espen Exp $ (in-package "GLIB") - - -(defun %map-mappings (args op) - (let ((current-value 0)) - (map - 'list - #'(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 #|(ash 1 value)|#)) - (:int-enum (list value symbol)) - (:int-flags (list value #|(ash 1 value)|# symbol)) - (:symbols symbol)))) - (if (integerp (first args)) - (rest args) - args)))) - - -;;;; Enum type - -(deftype enum (&rest args) - `(member ,@(%map-mappings args :symbols))) - -(deftype-method translate-type-spec enum (type-spec) - (let ((args (cdr (type-expand-to 'enum type-spec)))) - (if (integerp (first args)) - (translate-type-spec `(signed ,(first args))) - (translate-type-spec 'signed)))) - -(deftype-method size-of enum (type-spec) - (let ((args (cdr (type-expand-to 'enum type-spec)))) - (if (integerp (first args)) - (size-of `(signed ,(first args))) - (size-of 'signed)))) - -(deftype-method translate-to-alien enum (type-spec expr &optional weak-ref) - (declare (ignore weak-ref)) - (let ((args (cdr (type-expand-to 'enum type-spec)))) - `(ecase ,expr - ,@(%map-mappings args :enum-int)))) - -(deftype-method translate-from-alien enum (type-spec expr &optional weak-ref) - (declare (ignore weak-ref)) - (destructuring-bind (name &rest args) (type-expand-to 'enum type-spec) - (declare (ignore name)) - `(ecase ,expr - ,@(%map-mappings args :int-enum)))) - -(setf (alien-type-name 'enum) "GEnum") + +;;;; Definition of enums and flags by introspection (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass %enum-value (alien-structure) + (defclass enum-value (struct) ((value :allocation :alien :type int) (name :allocation :alien :type string) (nickname :allocation :alien :type string)) - (:metaclass proxy-class))) - -(defbinding %enum-class-values () (glist %enum-value) - (class pointer)) + (:metaclass struct-class))) -(defun %query-enum-values (type-number) - (mapcar +(defun map-enum-values (values symbolic-p) + (map 'list #'(lambda (enum-value) - (list - (intern - (substitute - #\- #\_ (string-upcase (slot-value enum-value 'nickname))) "KEYWORD") - (slot-value enum-value 'value))) - (%enum-class-values (type-class-peek type-number)))) - -(defun define-enum-by-query (init-fname &optional name) - (let ((type-number (type-init name init-fname))) - (unless (= (type-parent type-number) (find-type-number 'enum)) - (error "~A is not an enum type" (alien-type-name type-number))) - - (type-class-ref type-number) - (setf (find-type-number name) type-number) - (let ((expanded (cons 'enum (%query-enum-values type-number))) - (name (or name (default-type-name (alien-type-name type-number))))) - (lisp::%deftype - name - #'(lambda (whole) - (unless (zerop (length (cdr whole))) - (lisp::do-arg-count-error 'deftype name (cdr whole) nil 0 0)) - expanded))))) - - -;;;; Flags type - -(deftype flags (&rest args) - `(or - null - (cons - (member ,@(%map-mappings args :symbols)) - list))) - -(deftype-method translate-type-spec flags (type-spec) - (let ((args (cdr (type-expand-to 'flags type-spec)))) - (if (integerp (first args)) - (translate-type-spec `(unsigned ,(first args))) - (translate-type-spec 'unsigned)))) - -(deftype-method size-of flags (type-spec) - (let ((args (cdr (type-expand-to 'flags type-spec)))) - (if (integerp (first args)) - (size-of `(unsigned ,(first args))) - (size-of 'unsigned)))) - -(deftype-method translate-to-alien flags (type-spec expr &optional weak-ref) - (declare (ignore weak-ref)) - (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec) - (declare (ignore name)) - (let ((mappings (%map-mappings args :flags-int)) - (value (make-symbol "VALUE"))) - `(let ((,value 0)) - (dolist (flag ,expr ,value) - (setq ,value (logior ,value (second (assoc flag ',mappings))))))))) - -(deftype-method translate-from-alien flags (type-spec expr &optional weak-ref) - (declare (ignore weak-ref)) - (destructuring-bind (name &rest args) (type-expand-to 'flags type-spec) - (declare (ignore name)) - (let ((mappings (%map-mappings args :int-flags)) - (result (make-symbol "RESULT"))) - `(let ((,result nil)) - (dolist (mapping ',mappings ,result) - (unless (zerop (logand ,expr (first mapping))) - (push (second mapping) ,result))))))) - -(setf (alien-type-name 'flags) "GFlags") - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass %flags-value (alien-structure) - ((value :allocation :alien :type unsigned-int) - (name :allocation :alien :type string) - (nickname :allocation :alien :type string)) - (:metaclass proxy-class))) - -(defbinding %flags-class-values () (glist %flags-value) - (class pointer)) - -(defun %query-flags-values (type-number) - (mapcar - #'(lambda (flags-value) - (list - (intern - (substitute - #\- #\_ (string-upcase (slot-value flags-value 'nickname))) "KEYWORD") - (slot-value flags-value 'value))) - (%flags-class-values (type-class-peek type-number)))) + (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)) + +(defbinding flags-class-values () (static (vector (inlined enum-value) n-values)) + (class pointer) + (n-values unsigned-int :out)) + +(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 forward-p options) + (declare (ignore forward-p)) + (let* ((type (type-from-number type-number)) + (mappings (getf options :mappings)) + (expanded-mappings + (append + (delete-if + #'(lambda (mapping) + (or + (assoc (first mapping) mappings) + (rassoc (cdr mapping) mappings :test #'equal))) + (query-enum-values type-number)) + (remove-if + #'(lambda (mapping) (eq (second mapping) nil)) mappings)))) + `(progn + (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) +(register-derivable-type 'flags "GFlags" 'expand-enum-type) -(defun define-flags-by-query (init-fname &optional name) - (let ((type-number (type-init nil init-fname))) - (unless (= (type-parent type-number) (find-type-number 'flags)) - (error "~A is not a flags type" (alien-type-name type-number))) - - (type-class-ref type-number) - (setf (find-type-number name) type-number) - (let ((expanded (cons 'flags (%query-flags-values type-number))) - (name (or name (default-type-name (alien-type-name type-number))))) - (lisp::%deftype - name - #'(lambda (whole) - (unless (zerop (length (cdr whole))) - (lisp::do-arg-count-error 'deftype name (cdr whole) nil 0 0)) - expanded)))))