X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.type-designator.lisp;h=98a48082b1b5cdaed272572ab2c1d5195646958f;hb=96aa7293addaacdfe29ce32e60e2feac7df6ffce;hp=d31af2e57f42e32398c92067fa46cad1cbcce4dc;hpb=f5e6811113fdb4f0a9d63c89546a748f376df737;p=cl-gtk2.git

diff --git a/glib/gobject.type-designator.lisp b/glib/gobject.type-designator.lisp
index d31af2e..98a4808 100644
--- a/glib/gobject.type-designator.lisp
+++ b/glib/gobject.type-designator.lisp
@@ -22,7 +22,11 @@
 (defcfun (%g-type-name "g_type_name") (:string :free-from-foreign nil)
   (type g-type))
 
+(defun warn-unknown-gtype (name)
+  (warn "GType ~A is not known to GObject" name))
+
 (defun gtype-from-name (name)
+  (declare (optimize (safety 0) (speed 3)))
   (when (null name) (return-from gtype-from-name nil))
   (bt:with-lock-held (*gtype-lock*)
     (let ((type (gethash name *name-to-gtype*)))
@@ -30,14 +34,14 @@
         (when (null (gtype-%id type))
           (let ((n (%g-type-from-name name)))
             (if (zerop n)
-                (warn "GType ~A is not known to GObject" name)
+                (warn-unknown-gtype 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)
+        (warn-unknown-gtype name)
         (setf n nil))
       (let ((type (make-gtype :name (copy-seq name) :%id n)))
         (setf (gethash n *id-to-gtype*) type
@@ -45,6 +49,7 @@
         (return-from gtype-from-name type)))))
 
 (defun gtype-from-id (id)
+  (declare (optimize (safety 0) (speed 3)))
   (when (zerop id) (return-from gtype-from-id nil))
   (bt:with-lock-held (*gtype-lock*)
     (let ((type (gethash id *id-to-gtype*)))
@@ -52,7 +57,7 @@
         (return-from gtype-from-id type)))
     (let ((name (%g-type-name id)))
       (unless name
-        (error "GType with ~A is not known to GObject" id))
+        (warn-unknown-gtype id))
       (let ((type (gethash name *name-to-gtype*)))
         (when type
           (setf (gtype-%id type) id
@@ -69,19 +74,27 @@
   (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))
+        (warn-unknown-gtype (gtype-name gtype))
         (return-from gtype-id 0))
       (setf (gtype-%id gtype) n
             (gethash n *id-to-gtype*) gtype)
       n)))
 
-(defun gtype (thing)
+(defun %gtype (thing)
   (etypecase thing
     (null nil)
     (gtype thing)
     (string (gtype-from-name thing))
     (integer (gtype-from-id thing))))
 
+(defun gtype (thing)
+  (%gtype thing))
+
+(define-compiler-macro gtype (&whole whole thing)
+  (if (constantp thing)
+      `(load-time-value (%gtype ,thing))
+      whole))
+
 (define-foreign-type g-type-designator ()
   ((mangled-p :initarg :mangled-p
               :reader g-type-designator-mangled-p
@@ -97,60 +110,15 @@ Numeric identifier of GType may be different between different program runs. But
   (logxor g-type (ldb (byte 1 0) g-type)));;subtract the G_SIGNAL_TYPE_STATIC_SCOPE
 
 (defmethod translate-from-foreign (value (type g-type-designator))
-  (g-type-name (if (g-type-designator-mangled-p type)
-                   (unmangle-g-type value)
-                   value)))
+  (gtype (if (g-type-designator-mangled-p type)
+             (unmangle-g-type value)
+             value)))
 
 (defmethod translate-to-foreign (value (type g-type-designator))
-  (etypecase value
-    (string (g-type-from-name value))
-    (integer value)
-    (null 0)))
-
-(defun g-type-numeric (g-type-designator)
-  (etypecase g-type-designator
-    (string (g-type-from-name g-type-designator))
-    (integer g-type-designator)
-    (null 0)))
-
-(defun g-type-string (g-type-designator)
-  (etypecase g-type-designator
-    (string (g-type-name g-type-designator))
-    (integer (g-type-name g-type-designator))
-    (null nil)))
-
-(defcfun (g-type-name "g_type_name") :string
-  "Returns the name of a GType.@see{g-type-from-name}
-
-Example:
-@pre{
-\(g-type-from-name \"GtkLabel\")
-=> 7151952
-\(g-type-name 7151952)
-=> \"GtkLabel\"
-}
-@arg[type]{GType designator (see @class{g-type-designator})}
-@return{a string}"
-  (type g-type-designator))
-
-(defcfun (g-type-from-name "g_type_from_name") g-type
-  "Returns the numeric identifier of a GType by its name. @see{g-type-name}
-
-Example:
-@pre{
-\(g-type-from-name \"GtkLabel\")
-=> 7151952
-\(g-type-name 7151952)
-=> \"GtkLabel\"
-}
-@arg[name]{a string - name of GType}
-@return{an integer}"
-  (name :string))
+  (gtype-id (gtype value)))
 
 (defun g-type= (type-1 type-2)
-  (= (g-type-numeric type-1)
-     (g-type-numeric type-2)))
+  (eq (gtype type-1) (gtype type-2)))
 
 (defun g-type/= (type-1 type-2)
-  (/= (g-type-numeric type-1)
-      (g-type-numeric type-2)))
+  (not (eq (gtype type-1) (gtype type-2))))