Added gtype and tests

diff --git a/glib/gobject.ffi.package.lisp b/glib/gobject.ffi.package.lisp
index 7cfcc34..a2af983 100644 (file)
--- a/glib/gobject.ffi.package.lisp
+++ b/glib/gobject.ffi.package.lisp
@@ -1,5 +1,5 @@
 (defpackage :gobject.ffi
-  (:use :cl :cffi :glib :trivial-garbage)
+  (:use :cl :cffi :glib :trivial-garbage :iter)
   (:export #:g-type
            #:g-type-designator
            #:g-type-name

diff --git a/glib/gobject.type-designator.lisp b/glib/gobject.type-designator.lisp
index 5468403..d31af2e 100644 (file)
--- a/glib/gobject.type-designator.lisp
+++ b/glib/gobject.type-designator.lisp
@@ -2,6 +2,86 @@
 
 (defctype g-type gsize)
 
+(defstruct gtype name %id)
+
+(defvar *name-to-gtype* (make-hash-table :test 'equal))
+(defvar *id-to-gtype* (make-hash-table))
+(defvar *gtype-lock* (bt:make-lock "gtype lock"))
+
+(defun invalidate-gtypes ()
+  (bt:with-lock-held (*gtype-lock*)
+    (clrhash *id-to-gtype*)
+    (iter (for (name gtype) in-hashtable *name-to-gtype*)
+          (setf (gtype-%id gtype) nil))))
+
+(at-finalize () (invalidate-gtypes))
+
+(defcfun (%g-type-from-name "g_type_from_name") g-type
+  (name :string))
+
+(defcfun (%g-type-name "g_type_name") (:string :free-from-foreign nil)
+  (type g-type))
+
+(defun gtype-from-name (name)
+  (when (null name) (return-from gtype-from-name nil))
+  (bt:with-lock-held (*gtype-lock*)
+    (let ((type (gethash name *name-to-gtype*)))
+      (when type
+        (when (null (gtype-%id type))
+          (let ((n (%g-type-from-name name)))
+            (if (zerop n)
+                (warn "GType ~A is not known to GObject" name)
+                (progn
+                  (setf (gtype-%id type) n
+                        (gethash n *id-to-gtype*) type)))))
+        (return-from gtype-from-name type)))
+    (let ((n (%g-type-from-name name)))
+      (when (zerop n)
+        (warn "GType ~A is not known to GObject" name)
+        (setf n nil))
+      (let ((type (make-gtype :name (copy-seq name) :%id n)))
+        (setf (gethash n *id-to-gtype*) type
+              (gethash name *name-to-gtype*) type)
+        (return-from gtype-from-name type)))))
+
+(defun gtype-from-id (id)
+  (when (zerop id) (return-from gtype-from-id nil))
+  (bt:with-lock-held (*gtype-lock*)
+    (let ((type (gethash id *id-to-gtype*)))
+      (when type
+        (return-from gtype-from-id type)))
+    (let ((name (%g-type-name id)))
+      (unless name
+        (error "GType with ~A is not known to GObject" id))
+      (let ((type (gethash name *name-to-gtype*)))
+        (when type
+          (setf (gtype-%id type) id
+                (gethash id *id-to-gtype*) type)
+          (return-from gtype-from-id type))
+        (let ((type (make-gtype :name name :%id id)))
+          (setf (gethash id *id-to-gtype*) type
+                (gethash name *name-to-gtype*) type)
+          (return-from gtype-from-id type))))))
+
+(defun gtype-id (gtype)
+  (when (null gtype) (return-from gtype-id 0))
+  (when (gtype-%id gtype) (return-from gtype-id (gtype-%id gtype)))
+  (bt:with-lock-held (*gtype-lock*)
+    (let ((n (%g-type-from-name (gtype-name gtype))))
+      (when (zerop n)
+        (warn "GType ~A is not known to GObject" (gtype-name gtype))
+        (return-from gtype-id 0))
+      (setf (gtype-%id gtype) n
+            (gethash n *id-to-gtype*) gtype)
+      n)))
+
+(defun gtype (thing)
+  (etypecase thing
+    (null nil)
+    (gtype thing)
+    (string (gtype-from-name thing))
+    (integer (gtype-from-id thing))))
+
 (define-foreign-type g-type-designator ()
   ((mangled-p :initarg :mangled-p
               :reader g-type-designator-mangled-p

diff --git a/glib/gobject.type-tests.lisp b/glib/gobject.type-tests.lisp
new file mode 100644 (file)
index 0000000..b073963
--- /dev/null
+++ b/glib/gobject.type-tests.lisp
@@ -0,0 +1,64 @@
+(defpackage #:gtype-tests
+  (:use #:cl #:iter #:gobject #:gobject.ffi #:5am)
+  (:export #:run-all-tests)
+  (:import-from #:gobject.ffi #:gtype #:gtype-name #:gtype-%id #:gtype-id #:invalidate-gtypes))
+
+(in-package #:gtype-tests)
+
+(def-suite gtype)
+
+(in-suite gtype)
+
+(defun run-all-tests ()
+  (run! 'gtype))
+
+;; Normal things
+
+(test normal.1
+  (finishes (gtype "gint"))
+  (finishes (gtype "glong"))
+  (finishes (gtype +g-type-pointer+)))
+
+(test normal.eq
+  (is (eq (gtype "gint") (gtype "gint")))
+  (is (eq (gtype "GObject") (gtype "GObject")))
+  (is (not (eq (gtype "gint") (gtype "GObject"))))
+  (is (eq (gtype "gchararray") (gtype +g-type-string+))))
+
+(test normal.boundary
+  (is (null (gtype 0)))
+  (is (null (gtype nil)))
+  (signals warning (gtype "foobarbaz"))
+  (signals error (gtype 1)))
+
+(test normal.trans
+  (is (string= (gtype-name (gtype "gint")) "gint"))
+  (is (eql (gtype-id (gtype "gint")) +g-type-int+)))
+
+;; Clear mappings
+
+(test clear.simple
+  (let ((type (gtype "gint")))
+    (is (eql (gtype-id type) +g-type-int+))
+    (invalidate-gtypes)
+    (is (null (gtype-%id type)))
+    (is (eql (gtype-id type) +g-type-int+))
+    (invalidate-gtypes)
+    (is (eq type (gtype "gint")))
+    (invalidate-gtypes)
+    (is (eq type (gtype +g-type-int+)))))
+
+(test clear.1
+  (let ((type (gtype "gint")))
+    (invalidate-gtypes)
+    (is (null (gtype-%id type)))
+    (gtype +g-type-int+)
+    (is (not (null (gethash +g-type-int+ gobject.ffi::*id-to-gtype*))))
+    (is (not (null (gtype-%id type))))))
+
+;; Core saving
+
+(defvar *gi* (gtype +g-type-int+))
+
+(test core.saving
+  (is (eq *gi* (gtype +g-type-int+))))

diff --git a/glib/gobject.type-tests.sh b/glib/gobject.type-tests.sh
new file mode 100755 (executable)
index 0000000..807d9ae
--- /dev/null
+++ b/glib/gobject.type-tests.sh
@@ -0,0 +1,4 @@
+#!/bin/sh
+sbcl --eval "(asdf:oos 'asdf:load-op :cl-gtk2-gtk)" --eval "(asdf:oos 'asdf:load-op :fiveam)" --load gobject.type-tests.lisp --eval '(sb-ext:save-lisp-and-die "/tmp/sbcl-type-tests-core" :executable t)'
+/tmp/sbcl-type-tests-core --eval "(gtype-tests:run-all-tests)" --eval "(quit)"
+rm /tmp/sbcl-type-tests-core
\ No newline at end of file