From: Dmitry Kalyanov <Kalyanov.Dmitry@gmail.com>
Date: Fri, 29 Jan 2010 23:30:36 +0000 (+0300)
Subject: Add compiler-macro that handles gtype calls with constant args
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=de1956a3463b155adc867a914f0f4353ff567690;p=cl-gtk2.git

Add compiler-macro that handles gtype calls with constant args
---

diff --git a/glib/gobject.type-designator.lisp b/glib/gobject.type-designator.lisp
index d31af2e..ebd1925 100644
--- a/glib/gobject.type-designator.lisp
+++ b/glib/gobject.type-designator.lisp
@@ -75,13 +75,21 @@
             (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
diff --git a/glib/gobject.type-tests.lisp b/glib/gobject.type-tests.lisp
index b073963..7f61d01 100644
--- a/glib/gobject.type-tests.lisp
+++ b/glib/gobject.type-tests.lisp
@@ -1,7 +1,7 @@
 (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))
+  (:import-from #:gobject.ffi #:%gtype #:gtype #:gtype-name #:gtype-%id #:gtype-id #:invalidate-gtypes))
 
 (in-package #:gtype-tests)
 
@@ -15,50 +15,51 @@
 ;; Normal things
 
 (test normal.1
-  (finishes (gtype "gint"))
-  (finishes (gtype "glong"))
-  (finishes (gtype +g-type-pointer+)))
+  (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+))))
+  (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)))
+  (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+)))
+  (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")))
+  (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")))
+    (is (eq type (%gtype "gint")))
     (invalidate-gtypes)
-    (is (eq type (gtype +g-type-int+)))))
+    (is (eq type (%gtype +g-type-int+)))))
 
 (test clear.1
-  (let ((type (gtype "gint")))
+  (let ((type (%gtype "gint")))
     (invalidate-gtypes)
     (is (null (gtype-%id type)))
-    (gtype +g-type-int+)
+    (%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+))
+(defvar *gi* (%gtype +g-type-int+))
 
 (test core.saving
-  (is (eq *gi* (gtype +g-type-int+))))
+  (is (eq *gi* (%gtype +g-type-int+)))
+  (is (eq (gtype +g-type-int+) (%gtype +g-type-int+))))