glib/gobject.type-designator.lisp

   1 (in-package :gobject.ffi)
   2
   3 (defctype g-type gsize)
   4
   5 (defstruct gtype name %id)
   6
   7 (defvar *name-to-gtype* (make-hash-table :test 'equal))
   8 (defvar *id-to-gtype* (make-hash-table))
   9 (defvar *gtype-lock* (bt:make-lock "gtype lock"))
  10
  11 (defun invalidate-gtypes ()
  12   (bt:with-lock-held (*gtype-lock*)
  13     (clrhash *id-to-gtype*)
  14     (iter (for (name gtype) in-hashtable *name-to-gtype*)
  15           (setf (gtype-%id gtype) nil))))
  16
  17 (at-finalize () (invalidate-gtypes))
  18
  19 (defcfun (%g-type-from-name "g_type_from_name") g-type
  20   (name :string))
  21
  22 (defcfun (%g-type-name "g_type_name") (:string :free-from-foreign nil)
  23   (type g-type))
  24
  25 (defun gtype-from-name (name)
  26   (when (null name) (return-from gtype-from-name nil))
  27   (bt:with-lock-held (*gtype-lock*)
  28     (let ((type (gethash name *name-to-gtype*)))
  29       (when type
  30         (when (null (gtype-%id type))
  31           (let ((n (%g-type-from-name name)))
  32             (if (zerop n)
  33                 (warn "GType ~A is not known to GObject" name)
  34                 (progn
  35                   (setf (gtype-%id type) n
  36                         (gethash n *id-to-gtype*) type)))))
  37         (return-from gtype-from-name type)))
  38     (let ((n (%g-type-from-name name)))
  39       (when (zerop n)
  40         (warn "GType ~A is not known to GObject" name)
  41         (setf n nil))
  42       (let ((type (make-gtype :name (copy-seq name) :%id n)))
  43         (setf (gethash n *id-to-gtype*) type
  44               (gethash name *name-to-gtype*) type)
  45         (return-from gtype-from-name type)))))
  46
  47 (defun gtype-from-id (id)
  48   (when (zerop id) (return-from gtype-from-id nil))
  49   (bt:with-lock-held (*gtype-lock*)
  50     (let ((type (gethash id *id-to-gtype*)))
  51       (when type
  52         (return-from gtype-from-id type)))
  53     (let ((name (%g-type-name id)))
  54       (unless name
  55         (error "GType with ~A is not known to GObject" id))
  56       (let ((type (gethash name *name-to-gtype*)))
  57         (when type
  58           (setf (gtype-%id type) id
  59                 (gethash id *id-to-gtype*) type)
  60           (return-from gtype-from-id type))
  61         (let ((type (make-gtype :name name :%id id)))
  62           (setf (gethash id *id-to-gtype*) type
  63                 (gethash name *name-to-gtype*) type)
  64           (return-from gtype-from-id type))))))
  65
  66 (defun gtype-id (gtype)
  67   (when (null gtype) (return-from gtype-id 0))
  68   (when (gtype-%id gtype) (return-from gtype-id (gtype-%id gtype)))
  69   (bt:with-lock-held (*gtype-lock*)
  70     (let ((n (%g-type-from-name (gtype-name gtype))))
  71       (when (zerop n)
  72         (warn "GType ~A is not known to GObject" (gtype-name gtype))
  73         (return-from gtype-id 0))
  74       (setf (gtype-%id gtype) n
  75             (gethash n *id-to-gtype*) gtype)
  76       n)))
  77
  78 (defun %gtype (thing)
  79   (etypecase thing
  80     (null nil)
  81     (gtype thing)
  82     (string (gtype-from-name thing))
  83     (integer (gtype-from-id thing))))
  84
  85 (defun gtype (thing)
  86   (%gtype thing))
  87
  88 (define-compiler-macro gtype (&whole whole thing)
  89   (if (constantp thing)
  90       `(load-time-value (%gtype ,thing))
  91       whole))
  92
  93 (define-foreign-type g-type-designator ()
  94   ((mangled-p :initarg :mangled-p
  95               :reader g-type-designator-mangled-p
  96               :initform nil
  97               :documentation "Whether the type designator is mangled with G_SIGNAL_TYPE_STATIC_SCOPE flag"))
  98   (:documentation "Values of this CFFI foreign type identify the GType. GType is designated by a its name (a string) or a numeric identifier. Functions accept GType designators as a string or integer and return them as a string. Functions @fun{g-type-name} and @fun{g-type-from-name} are used to convert between name and numeric identifier.
  99
 100 Numeric identifier of GType may be different between different program runs. But string identifier of GType does not change.")
 101   (:actual-type g-type)
 102   (:simple-parser g-type-designator))
 103
 104 (defun unmangle-g-type (g-type)
 105   (logxor g-type (ldb (byte 1 0) g-type)));;subtract the G_SIGNAL_TYPE_STATIC_SCOPE
 106
 107 (defmethod translate-from-foreign (value (type g-type-designator))
 108   (g-type-name (if (g-type-designator-mangled-p type)
 109                    (unmangle-g-type value)
 110                    value)))
 111
 112 (defmethod translate-to-foreign (value (type g-type-designator))
 113   (etypecase value
 114     (string (g-type-from-name value))
 115     (integer value)
 116     (null 0)))
 117
 118 (defun g-type-numeric (g-type-designator)
 119   (etypecase g-type-designator
 120     (string (g-type-from-name g-type-designator))
 121     (integer g-type-designator)
 122     (null 0)))
 123
 124 (defun g-type-string (g-type-designator)
 125   (etypecase g-type-designator
 126     (string (g-type-name g-type-designator))
 127     (integer (g-type-name g-type-designator))
 128     (null nil)))
 129
 130 (defcfun (g-type-name "g_type_name") :string
 131   "Returns the name of a GType.@see{g-type-from-name}
 132
 133 Example:
 134 @pre{
 135 \(g-type-from-name \"GtkLabel\")
 136 => 7151952
 137 \(g-type-name 7151952)
 138 => \"GtkLabel\"
 139 }
 140 @arg[type]{GType designator (see @class{g-type-designator})}
 141 @return{a string}"
 142   (type g-type-designator))
 143
 144 (defcfun (g-type-from-name "g_type_from_name") g-type
 145   "Returns the numeric identifier of a GType by its name. @see{g-type-name}
 146
 147 Example:
 148 @pre{
 149 \(g-type-from-name \"GtkLabel\")
 150 => 7151952
 151 \(g-type-name 7151952)
 152 => \"GtkLabel\"
 153 }
 154 @arg[name]{a string - name of GType}
 155 @return{an integer}"
 156   (name :string))
 157
 158 (defun g-type= (type-1 type-2)
 159   (= (g-type-numeric type-1)
 160      (g-type-numeric type-2)))
 161
 162 (defun g-type/= (type-1 type-2)
 163   (/= (g-type-numeric type-1)
 164       (g-type-numeric type-2)))