chiark - git - mdw - clg/blob - glib/genums.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2000-2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: genums.lisp,v 1.22 2006-09-28 10:20:12 espen Exp $
  24
  25 (in-package "GLIB")
  26
  27 ;;;; Definition of enums and flags by introspection
  28
  29 (eval-when (:compile-toplevel :load-toplevel :execute)
  30   (defclass enum-value (struct)
  31     ((value :allocation :alien :type int)
  32      (name :allocation :alien :type string)
  33      (nickname :allocation :alien :type string))
  34     (:metaclass struct-class)))
  35
  36 (defun map-enum-values (values symbolic-p)
  37   (map 'list
  38    #'(lambda (enum-value)
  39        (with-slots (nickname name value) enum-value
  40          (list
  41           (cond
  42            ((eq symbolic-p :nickname) nickname)
  43            (symbolic-p
  44             (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD"))
  45            (t name))
  46           value)))
  47    values))
  48
  49 (defbinding enum-class-values () (static (vector (inlined enum-value) n-values))
  50   (class pointer)
  51   (n-values unsigned-int :out))
  52
  53 (defbinding flags-class-values () (static (vector (inlined enum-value) n-values))
  54   (class pointer)
  55   (n-values unsigned-int :out))
  56
  57 (defun query-enum-values (type &optional (symbolic-p t))
  58   (let ((class (type-class-ref type)))
  59     (map-enum-values (if (eq (supertype type) 'enum)
  60                          (enum-class-values class)
  61                        (flags-class-values class))
  62                      symbolic-p)))
  63
  64 (defun expand-enum-type (type-number forward-p options)
  65   (declare (ignore forward-p))
  66   (let* ((type (type-from-number type-number))
  67          (mappings (getf options :mappings))
  68          (expanded-mappings
  69           (append
  70            (delete-if
  71             #'(lambda (mapping)
  72                 (or
  73                  (assoc (first mapping) mappings)
  74                  (rassoc (cdr mapping) mappings :test #'equal)))
  75             (query-enum-values type-number))
  76            (remove-if
  77             #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
  78     `(progn
  79        (register-type ',type ',(find-type-init-function type-number))
  80        ,(ecase (supertype type-number)
  81           (enum `(define-enum-type ,type ,@expanded-mappings))
  82           (flags `(define-flags-type ,type ,@expanded-mappings))))))
  83
  84
  85 (register-derivable-type 'enum "GEnum" 'expand-enum-type)
  86 (register-derivable-type 'flags "GFlags" 'expand-enum-type)
  87