From: Dmitry Kalyanov 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+))))