1 (in-package :gobject.ffi)
3 (defctype g-type gsize)
5 (defstruct gtype name %id)
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"))
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))))
17 (at-finalize () (invalidate-gtypes))
19 (defcfun (%g-type-from-name "g_type_from_name") g-type
22 (defcfun (%g-type-name "g_type_name") (:string :free-from-foreign nil)
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*)))
31 (when (null (gtype-%id type))
32 (let ((n (%g-type-from-name name)))
34 (warn "GType ~A is not known to GObject" name)
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)))
41 (warn "GType ~A is not known to GObject" name)
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)))))
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*)))
54 (return-from gtype-from-id type)))
55 (let ((name (%g-type-name id)))
57 (error "GType with ~A is not known to GObject" id))
58 (let ((type (gethash name *name-to-gtype*)))
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))))))
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))))
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)
84 (string (gtype-from-name thing))
85 (integer (gtype-from-id thing))))
90 (define-compiler-macro gtype (&whole whole thing)
92 `(load-time-value (%gtype ,thing))
95 (define-foreign-type g-type-designator ()
96 ((mangled-p :initarg :mangled-p
97 :reader g-type-designator-mangled-p
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.
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))
106 (defun unmangle-g-type (g-type)
107 (logxor g-type (ldb (byte 1 0) g-type)));;subtract the G_SIGNAL_TYPE_STATIC_SCOPE
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)
114 (defmethod translate-to-foreign (value (type g-type-designator))
116 (string (g-type-from-name value))
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)
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))
132 (defcfun (g-type-name "g_type_name") :string
133 "Returns the name of a GType.@see{g-type-from-name}
137 \(g-type-from-name \"GtkLabel\")
139 \(g-type-name 7151952)
142 @arg[type]{GType designator (see @class{g-type-designator})}
144 (type g-type-designator))
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}
151 \(g-type-from-name \"GtkLabel\")
153 \(g-type-name 7151952)
156 @arg[name]{a string - name of GType}
160 (defun g-type= (type-1 type-2)
161 (= (g-type-numeric type-1)
162 (g-type-numeric type-2)))
164 (defun g-type/= (type-1 type-2)
165 (/= (g-type-numeric type-1)
166 (g-type-numeric type-2)))