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 warn-unknown-gtype (name)
  26   (warn "GType ~A is not known to GObject" name))
  27
  28 (defun gtype-from-name (name)
  29   (declare (optimize (safety 0) (speed 3)))
  30   (when (null name) (return-from gtype-from-name nil))
  31   (bt:with-lock-held (*gtype-lock*)
  32     (let ((type (gethash name *name-to-gtype*)))
  33       (when type
  34         (when (null (gtype-%id type))
  35           (let ((n (%g-type-from-name name)))
  36             (if (zerop n)
  37                 (warn-unknown-gtype name)
  38                 (progn
  39                   (setf (gtype-%id type) n
  40                         (gethash n *id-to-gtype*) type)))))
  41         (return-from gtype-from-name type)))
  42     (let ((n (%g-type-from-name name)))
  43       (when (zerop n)
  44         (warn-unknown-gtype name)
  45         (setf n nil))
  46       (let ((type (make-gtype :name (copy-seq (the string name)) :%id n)))
  47         (setf (gethash n *id-to-gtype*) type
  48               (gethash name *name-to-gtype*) type)
  49         (return-from gtype-from-name type)))))
  50
  51 (defun gtype-from-id (id)
  52   (declare (optimize (safety 0) (speed 3)))
  53   (declare (integer id))
  54   (when (zerop id) (return-from gtype-from-id nil))
  55   (bt:with-lock-held (*gtype-lock*)
  56     (let ((type (gethash id *id-to-gtype*)))
  57       (when type
  58         (return-from gtype-from-id type)))
  59     (let ((name (%g-type-name id)))
  60       (unless name
  61         (warn-unknown-gtype id))
  62       (let ((type (gethash name *name-to-gtype*)))
  63         (when type
  64           (setf (gtype-%id type) id
  65                 (gethash id *id-to-gtype*) type)
  66           (return-from gtype-from-id type))
  67         (let ((type (make-gtype :name name :%id id)))
  68           (setf (gethash id *id-to-gtype*) type
  69                 (gethash name *name-to-gtype*) type)
  70           (return-from gtype-from-id type))))))
  71
  72 (defun gtype-id (gtype)
  73   (when (null gtype) (return-from gtype-id 0))
  74   (when (gtype-%id gtype) (return-from gtype-id (gtype-%id gtype)))
  75   (bt:with-lock-held (*gtype-lock*)
  76     (let ((n (%g-type-from-name (gtype-name gtype))))
  77       (when (zerop n)
  78         (warn-unknown-gtype (gtype-name gtype))
  79         (return-from gtype-id 0))
  80       (setf (gtype-%id gtype) n
  81             (gethash n *id-to-gtype*) gtype)
  82       n)))
  83
  84 (defun %gtype (thing)
  85   (etypecase thing
  86     (null nil)
  87     (gtype thing)
  88     (string (gtype-from-name thing))
  89     (integer (gtype-from-id thing))))
  90
  91 (defun gtype (thing)
  92   (%gtype thing))
  93
  94 (define-compiler-macro gtype (&whole whole thing)
  95   (if (constantp thing)
  96       `(load-time-value (%gtype ,thing))
  97       whole))
  98
  99 (define-foreign-type g-type-designator ()
 100   ((mangled-p :initarg :mangled-p
 101               :reader g-type-designator-mangled-p
 102               :initform nil
 103               :documentation "Whether the type designator is mangled with G_SIGNAL_TYPE_STATIC_SCOPE flag"))
 104   (: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.
 105
 106 Numeric identifier of GType may be different between different program runs. But string identifier of GType does not change.")
 107   (:actual-type g-type)
 108   (:simple-parser g-type-designator))
 109
 110 (defun unmangle-g-type (g-type)
 111   (logxor g-type (ldb (byte 1 0) g-type)));;subtract the G_SIGNAL_TYPE_STATIC_SCOPE
 112
 113 (defmethod translate-from-foreign (value (type g-type-designator))
 114   (gtype (if (g-type-designator-mangled-p type)
 115              (unmangle-g-type value)
 116              value)))
 117
 118 (defmethod translate-to-foreign (value (type g-type-designator))
 119   (gtype-id (gtype value)))
 120
 121 (defun g-type= (type-1 type-2)
 122   (eq (gtype type-1) (gtype type-2)))
 123
 124 (defun g-type/= (type-1 type-2)
 125   (not (eq (gtype type-1) (gtype type-2))))