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   (declare (optimize (safety 0) (speed 3)))
  27   (when (null name) (return-from gtype-from-name nil))
  28   (bt:with-lock-held (*gtype-lock*)
  29     (let ((type (gethash name *name-to-gtype*)))
  30       (when type
  31         (when (null (gtype-%id type))
  32           (let ((n (%g-type-from-name name)))
  33             (if (zerop n)
  34                 (warn "GType ~A is not known to GObject" name)
  35                 (progn
  36                   (setf (gtype-%id type) n
  37                         (gethash n *id-to-gtype*) type)))))
  38         (return-from gtype-from-name type)))
  39     (let ((n (%g-type-from-name name)))
  40       (when (zerop n)
  41         (warn "GType ~A is not known to GObject" name)
  42         (setf n nil))
  43       (let ((type (make-gtype :name (copy-seq name) :%id n)))
  44         (setf (gethash n *id-to-gtype*) type
  45               (gethash name *name-to-gtype*) type)
  46         (return-from gtype-from-name type)))))
  47
  48 (defun gtype-from-id (id)
  49   (declare (optimize (safety 0) (speed 3)))
  50   (when (zerop id) (return-from gtype-from-id nil))
  51   (bt:with-lock-held (*gtype-lock*)
  52     (let ((type (gethash id *id-to-gtype*)))
  53       (when type
  54         (return-from gtype-from-id type)))
  55     (let ((name (%g-type-name id)))
  56       (unless name
  57         (error "GType with ~A is not known to GObject" id))
  58       (let ((type (gethash name *name-to-gtype*)))
  59         (when type
  60           (setf (gtype-%id type) id
  61                 (gethash id *id-to-gtype*) type)
  62           (return-from gtype-from-id type))
  63         (let ((type (make-gtype :name name :%id id)))
  64           (setf (gethash id *id-to-gtype*) type
  65                 (gethash name *name-to-gtype*) type)
  66           (return-from gtype-from-id type))))))
  67
  68 (defun gtype-id (gtype)
  69   (when (null gtype) (return-from gtype-id 0))
  70   (when (gtype-%id gtype) (return-from gtype-id (gtype-%id gtype)))
  71   (bt:with-lock-held (*gtype-lock*)
  72     (let ((n (%g-type-from-name (gtype-name gtype))))
  73       (when (zerop n)
  74         (warn "GType ~A is not known to GObject" (gtype-name gtype))
  75         (return-from gtype-id 0))
  76       (setf (gtype-%id gtype) n
  77             (gethash n *id-to-gtype*) gtype)
  78       n)))
  79
  80 (defun %gtype (thing)
  81   (etypecase thing
  82     (null nil)
  83     (gtype thing)
  84     (string (gtype-from-name thing))
  85     (integer (gtype-from-id thing))))
  86
  87 (defun gtype (thing)
  88   (%gtype thing))
  89
  90 (define-compiler-macro gtype (&whole whole thing)
  91   (if (constantp thing)
  92       `(load-time-value (%gtype ,thing))
  93       whole))
  94
  95 (define-foreign-type g-type-designator ()
  96   ((mangled-p :initarg :mangled-p
  97               :reader g-type-designator-mangled-p
  98               :initform nil
  99               :documentation "Whether the type designator is mangled with G_SIGNAL_TYPE_STATIC_SCOPE flag"))
 100   (: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.
 101
 102 Numeric identifier of GType may be different between different program runs. But string identifier of GType does not change.")
 103   (:actual-type g-type)
 104   (:simple-parser g-type-designator))
 105
 106 (defun unmangle-g-type (g-type)
 107   (logxor g-type (ldb (byte 1 0) g-type)));;subtract the G_SIGNAL_TYPE_STATIC_SCOPE
 108
 109 (defmethod translate-from-foreign (value (type g-type-designator))
 110   (g-type-name (if (g-type-designator-mangled-p type)
 111                    (unmangle-g-type value)
 112                    value)))
 113
 114 (defmethod translate-to-foreign (value (type g-type-designator))
 115   (etypecase value
 116     (string (g-type-from-name value))
 117     (integer value)
 118     (null 0)))
 119
 120 (defun g-type-numeric (g-type-designator)
 121   (etypecase g-type-designator
 122     (string (g-type-from-name g-type-designator))
 123     (integer g-type-designator)
 124     (null 0)))
 125
 126 (defun g-type-string (g-type-designator)
 127   (etypecase g-type-designator
 128     (string (g-type-name g-type-designator))
 129     (integer (g-type-name g-type-designator))
 130     (null nil)))
 131
 132 (defcfun (g-type-name "g_type_name") :string
 133   "Returns the name of a GType.@see{g-type-from-name}
 134
 135 Example:
 136 @pre{
 137 \(g-type-from-name \"GtkLabel\")
 138 => 7151952
 139 \(g-type-name 7151952)
 140 => \"GtkLabel\"
 141 }
 142 @arg[type]{GType designator (see @class{g-type-designator})}
 143 @return{a string}"
 144   (type g-type-designator))
 145
 146 (defcfun (g-type-from-name "g_type_from_name") g-type
 147   "Returns the numeric identifier of a GType by its name. @see{g-type-name}
 148
 149 Example:
 150 @pre{
 151 \(g-type-from-name \"GtkLabel\")
 152 => 7151952
 153 \(g-type-name 7151952)
 154 => \"GtkLabel\"
 155 }
 156 @arg[name]{a string - name of GType}
 157 @return{an integer}"
 158   (name :string))
 159
 160 (defun g-type= (type-1 type-2)
 161   (= (g-type-numeric type-1)
 162      (g-type-numeric type-2)))
 163
 164 (defun g-type/= (type-1 type-2)
 165   (/= (g-type-numeric type-1)
 166       (g-type-numeric type-2)))