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.21 2006-09-05 13:20:08 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           (if symbolic-p
  42               (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD")
  43             name)
  44           value)))
  45    values))
  46
  47 (defbinding enum-class-values () (static (vector (inlined enum-value) n-values))
  48   (class pointer)
  49   (n-values unsigned-int :out))
  50
  51 (defbinding flags-class-values () (static (vector (inlined enum-value) n-values))
  52   (class pointer)
  53   (n-values unsigned-int :out))
  54
  55 (defun query-enum-values (type &optional (symbolic-p t))
  56   (let ((class (type-class-ref type)))
  57     (map-enum-values (if (eq (supertype type) 'enum)
  58                          (enum-class-values class)
  59                        (flags-class-values class))
  60                      symbolic-p)))
  61
  62 (defun expand-enum-type (type-number forward-p options)
  63   (declare (ignore forward-p))
  64   (let* ((type (type-from-number type-number))
  65          (mappings (getf options :mappings))
  66          (expanded-mappings
  67           (append
  68            (delete-if
  69             #'(lambda (mapping)
  70                 (or
  71                  (assoc (first mapping) mappings)
  72                  (rassoc (cdr mapping) mappings :test #'equal)))
  73             (query-enum-values type-number))
  74            (remove-if
  75             #'(lambda (mapping) (eq (second mapping) nil)) mappings))))
  76     `(progn
  77        (register-type ',type ',(find-type-init-function type-number))
  78        ,(ecase (supertype type-number)
  79           (enum `(define-enum-type ,type ,@expanded-mappings))
  80           (flags `(define-flags-type ,type ,@expanded-mappings))))))
  81
  82
  83 (register-derivable-type 'enum "GEnum" 'expand-enum-type)
  84 (register-derivable-type 'flags "GFlags" 'expand-enum-type)
  85