repos / commonqt / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | headblob | headfilediff | filehistory
normal | plain | shade | zebra
modular smoke & test system.
Annotate for file /src/commonqt.lisp
2010-01-10 tobias 1 ;;; Copyright (C) 2009, 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
2009-07-24 tobias 2 ;;;
13:39:55 ' 3 ;;; This program is free software: you can redistribute it and/or modify
' 4 ;;; it under the terms of the GNU General Public License as published by
' 5 ;;; the Free Software Foundation, either version 3 of the License, or
' 6 ;;; (at your option) any later version.
' 7 ;;;
' 8 ;;; This program is distributed in the hope that it will be useful,
' 9 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
' 10 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
' 11 ;;; GNU General Public License for more details.
' 12 ;;;
' 13 ;;; You should have received a copy of the GNU General Public License
' 14 ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
' 15 ;;;
' 16 ;;; As a special exception, the copyright holders of this library give you
' 17 ;;; permission to link this library with independent modules to produce an
' 18 ;;; executable, regardless of the license terms of these independent
' 19 ;;; modules, and to copy and distribute the resulting executable under
' 20 ;;; terms of your choice, provided that you also meet, for each linked
' 21 ;;; independent module, the terms and conditions of the license of that
' 22 ;;; module. An independent module is a module which is not derived from or
' 23 ;;; based on this library. If you modify this library, you may extend this
' 24 ;;; exception to your version of the library, but you are not obligated to
' 25 ;;; do so. If you do not wish to do so, delete this exception statement
' 26 ;;; from your version.
' 27
2009-07-02 tobias 28 (in-package :cl-smoke.commonqt)
17:34:07 ' 29
2010-01-10 tobias 30 ;; FIXME
08:53:29 ' 31 ;; There is a GLOBAL-SPACE class per module, for now we just use the :qt.core one.
' 32 ;; But it should be selected in the method call. e.g.: (#_qVersion "GlobalSpace")
' 33 (eval-when (:compile-toplevel :load-toplevel :execute)
' 34 (import 'cl-smoke.qt.core::global-space :cl-smoke.qt))
' 35
2009-07-24 tobias 36 ;;; initialization
13:39:55 ' 37 (defun ensure-smoke ())
' 38 (defun enable-syntax ())
' 39
2009-07-02 tobias 40 ;;; calling methods
2009-07-24 tobias 41 ;;;
13:39:55 ' 42 ;;; #_ reader macro
' 43 ;;;
' 44 ;;; FIXME: Return reference arguments using multiple return values.
2009-07-02 tobias 45 ;;;
17:34:07 ' 46 (eval-when (:load-toplevel :compile-toplevel :execute)
2009-07-24 tobias 47 (defun read-perserving-case (stream)
13:39:55 ' 48 (let ((*readtable* (copy-readtable nil)))
' 49 (setf (readtable-case *readtable*) :preserve)
' 50 (read stream)))
2009-07-02 tobias 51
2009-07-24 tobias 52 (defun cl-smoke-funcall-form (stream subchar arg)
13:39:55 ' 53 (declare (ignore subchar arg))
' 54 (let ((method (read-perserving-case stream)))
' 55 (if (string= "new" (symbol-name method))
' 56 `(lambda (&rest args)
' 57 (make-instance
' 58 ',(smoke::lispify (symbol-name (read-perserving-case stream)) :cl-smoke.qt)
' 59 :args args))
' 60 (let ((object (read stream)))
' 61 (if (stringp object)
' 62 (if (upper-case-p (char (symbol-name method) 0))
' 63 `(lambda ()
' 64 ,(smoke::lispify
' 65 (concatenate 'string
' 66 (if (string= "Qt" object)
' 67 "+"
' 68 (concatenate 'string
' 69 object
' 70 ".+"))
' 71 (symbol-name method) "+")
' 72 :cl-smoke.qt))
' 73 `(lambda (&rest args)
' 74 (apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))
' 75 (find-class ',(smoke::lispify object :cl-smoke.qt))
' 76 args)))
' 77 `(lambda (&rest args)
' 78 (apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))
' 79 ,object
' 80 args))))))))
2009-07-02 tobias 81
17:34:07 ' 82 (eval-when (:load-toplevel :compile-toplevel)
' 83 (set-dispatch-macro-character #\# #\_ #'cl-smoke-funcall-form))
' 84
' 85 ;;; Instantiating
' 86 ;;;
' 87 (defun new (instance &rest arguments)
' 88 "Calls the C++ construor for INSTANCE with ARGUMENTS."
2009-07-24 tobias 89 (assert (null-pointer-p (smoke:pointer instance))
13:39:55 ' 90 (instance)
' 91 "The instance ~A is already constructed." instance)
2009-07-02 tobias 92 (setf (slot-value instance 'smoke:pointer)
2010-01-10 tobias 93 (smoke::call-constructor (class-of instance) arguments))
2009-07-02 tobias 94 (smoke::set-binding instance)
17:34:07 ' 95 (smoke::take-ownership instance)
' 96 (smoke::add-object instance)
' 97 instance)
' 98
' 99 ;;; Connecting signals and slots
' 100 ;;;
' 101 (defun qsignal (name)
' 102 (cl-smoke.qt:qsignal name))
' 103 (defun qslot (name)
' 104 (cl-smoke.qt:qslot name))
' 105
' 106 ;;; QApplication
' 107 ;;;
' 108 (defun make-qapplication (&rest arguments)
' 109 "Returns a new QApplication instance with ARGUMENTS as command line
' 110 arguments argv. argv[0] is set to (LISP-IMPLEMNTATION-TYPE)."
2009-07-24 tobias 111 (let* ((argc (smoke:make-auto-pointer
2009-07-02 tobias 112 (cffi:foreign-alloc :int
2009-07-02 tobias 113 :initial-element (1+ (length arguments)))))
2009-07-24 tobias 114 (argv (smoke:make-auto-pointer
2009-07-02 tobias 115 (cffi:foreign-alloc :string
17:34:07 ' 116 :initial-contents
' 117 (cons (lisp-implementation-type) ;; arg0
2009-07-02 tobias 118 arguments))))
2009-07-02 tobias 119 (application (make-instance 'cl-smoke.qt:application :args
17:34:07 ' 120 (list argc argv))))
' 121 ;; argc & argv must remain valid during the lifetime of application.
' 122 (setf (cl-smoke.qt:property application 'arguments)
' 123 (cl-smoke.qt:make-lisp-variant (cons argc argv)))
' 124 application))
' 125
' 126 ;;; Overriding C++ methods
' 127 (defclass override-gf (standard-generic-function)
' 128 ((cxx-gf :initarg :cxx-gf
' 129 :reader cxx-gf))
' 130 (:metaclass closer-mop:funcallable-standard-class)
' 131 (:documentation "Redirects its methods to CXX-GF."))
' 132
' 133 (defmethod add-method ((gf override-gf) method)
' 134 (add-method (cxx-gf gf) method))
' 135
' 136 (defmethod remove-method ((gf override-gf) method)
' 137 (remove-method (cxx-gf gf) method))
' 138
' 139 ;;; Subclassing C++ & defining signals and slots
' 140 ;;;
' 141 (defclass qt-class (cxx:class)
2009-07-24 tobias 142 ((method-functions :accessor method-functions
13:39:55 ' 143 :documentation "The signals and slots.")
' 144 (meta-object :reader class-meta-object))
' 145 (:documentation "Metaclass for a class derived from QObject, that allows
' 146 adding signals and slots to the class."))
2009-07-02 tobias 147
2009-07-02 tobias 148 (defclass signal-slot-mixin ()
2009-07-24 tobias 149 ()
13:39:55 ' 150 (:documentation "Mixin for a class with metaclass QT-CLASS, that overwrites
' 151 the metaObject and qtMetacall methods."))
2009-07-02 tobias 152
2009-07-24 tobias 153 (defun setup-meta-object (class qt-superclass signals slots)
13:39:55 ' 154 (let ((methods (make-array (+ (length signals)
' 155 (length slots))
2009-07-02 tobias 156 :element-type 'function
17:34:07 ' 157 :initial-element #'identity))
' 158 (index 0))
2009-07-24 tobias 159 (dolist (signal-name signals)
2009-07-02 tobias 160 (setf (aref methods index)
2009-07-02 tobias 161 (let ((signal-name (first signal-name)))
21:49:43 ' 162 #'(lambda (this &rest args)
' 163 (apply #'emit-signal this signal-name args))))
2009-07-02 tobias 164 (incf index))
2009-07-24 tobias 165 (dolist (slot slots)
2009-07-02 tobias 166 (setf (aref methods index)
17:34:07 ' 167 (if (symbolp (second slot))
' 168 (second slot)
' 169 (eval `(function ,(second slot)))))
' 170 (incf index))
2009-07-24 tobias 171 (setf (method-functions class) methods))
2009-07-02 tobias 172 (let ((signals (mapcar #'(lambda (s) (make-slot-or-signal (first s)))
2009-07-24 tobias 173 signals))
2009-07-02 tobias 174 (slots (mapcar #'(lambda (s) (make-slot-or-signal (first s)))
2009-07-24 tobias 175 slots))
2009-07-02 tobias 176 (class-name (class-name class)))
17:34:07 ' 177 (setf (slot-value class 'meta-object)
' 178 (make-metaobject qt-superclass
' 179 (format nil "~A::~A"
' 180 (package-name (symbol-package class-name))
' 181 (symbol-name class-name))
' 182 nil
' 183 signals
' 184 slots))))
' 185
' 186 (defun setup-qt-class (qt-class next-method &rest args &key qt-superclass
' 187 direct-superclasses direct-default-initargs
2009-07-24 tobias 188 slots signals
2009-07-02 tobias 189 override &allow-other-keys)
17:34:07 ' 190 (dolist (method override)
' 191 (ensure-generic-function
' 192 (second method)
' 193 :generic-function-class (find-class 'override-gf)
' 194 :lambda-list '(this &rest args)
' 195 :cxx-gf (fdefinition (smoke::lispify (first method) :cxx))))
' 196 (apply next-method qt-class
' 197 :direct-default-initargs ;; the C++ instance is constructed with #'NEW
' 198 (cons `(:pointer (null-pointer) ,#'null-pointer)
' 199 direct-default-initargs)
' 200 :direct-superclasses
2009-07-24 tobias 201 (append (list (find-qclass (first qt-superclass))
13:39:55 ' 202 (find-class 'signal-slot-mixin))
' 203 direct-superclasses)
2009-07-02 tobias 204 args)
2009-07-24 tobias 205 (setup-meta-object qt-class (find-qclass (first qt-superclass))
13:39:55 ' 206 signals slots))
2009-07-02 tobias 207
2009-07-02 tobias 208 (defmethod cxx:meta-object ((this signal-slot-mixin))
2009-07-24 tobias 209 (class-meta-object (class-of this)))
2009-07-02 tobias 210
20:48:38 ' 211 (defmethod cxx:qt-metacall ((this signal-slot-mixin) call id arguments)
' 212 (let ((m-id (call-next-method)))
' 213 (if (< m-id 0)
' 214 m-id
' 215 (if (enum= call cl-smoke.qt:meta-object.+invoke-meta-method+)
' 216 (progn
2009-07-24 tobias 217 (when (< m-id (length (method-functions (class-of this))))
2009-07-02 tobias 218 (with-simple-restart
20:48:38 ' 219 (continue "Skip the method ~A of ~A."
' 220 (cxx:signature
' 221 (cxx:method (cxx:meta-object this) id))
' 222 this)
2009-07-24 tobias 223 (apply (aref (method-functions (class-of this)) m-id)
2009-07-02 tobias 224 this
2010-01-10 tobias 225 (cl-smoke.qt.core::arguments-to-lisp
2009-07-02 tobias 226 arguments
2010-01-10 tobias 227 (cl-smoke.qt.core::method-arguments-type this id)))))
2009-07-02 tobias 228 (- m-id
2009-07-24 tobias 229 (length (method-functions (class-of this)))))
2009-07-02 tobias 230 m-id))))
20:48:38 ' 231
2009-07-02 tobias 232 (defmethod initialize-instance :around ((class qt-class)
2009-08-27 tobias 233 &rest args &key &allow-other-keys)
2009-07-02 tobias 234 (apply #'setup-qt-class class #'call-next-method args))
2009-07-02 tobias 235
2009-08-27 tobias 236 (defmethod reinitialize-instance :around ((qt-class qt-class)
11:17:58 ' 237 &rest args &key &allow-other-keys)
2009-07-02 tobias 238 (apply #'setup-qt-class qt-class #'call-next-method args))
17:34:07 ' 239
' 240 (defun emit-signal (object signal-name &rest arguments)
' 241 "Emits the signal SIGNAL-NAME of OBJECT using ARGUMENTS."
2009-07-02 tobias 242 (declare (string signal-name))
2009-07-24 tobias 243 (let* ((meta-object (class-meta-object (class-of object)))
13:39:55 ' 244 (id (#_indexOfSignal meta-object
' 245 (#_normalizedSignature "QMetaObject"
' 246 signal-name))))
2009-07-02 tobias 247 (assert (>= id 0)
17:34:07 ' 248 ()
' 249 "No signal ~A of ~A." signal-name object)
2010-01-10 tobias 250 (cl-smoke.qt.core::activate
08:53:29 ' 251 object id (cl-smoke.qt.core::method-arguments-type object id)
2009-07-02 tobias 252 arguments)))
17:34:07 ' 253
' 254 (defmacro call-next-qmethod ()
' 255 "Calls the next method."
' 256 '(call-next-method))
' 257
' 258 ;;; Enum values
' 259 ;;;
' 260 (defun primitive-value (enum)
' 261 "Returns the integer value of ENUM."
' 262 (cxx-support:value enum))
' 263
' 264 ;;; Type disambiguation
' 265 ;;;
2009-07-02 tobias 266 (defun bool (value)
2009-07-24 tobias 267 "Returns true when VALUE is not 0 and false when it is 0."
13:39:55 ' 268 (not (zerop value)))
2009-07-02 tobias 269
2009-07-02 tobias 270 ;; No-op since we have overload resolution.
17:34:07 ' 271 (setf (fdefinition 'uint) #'identity
2009-07-02 tobias 272 (fdefinition 'int) #'identity
20:48:38 ' 273 (fdefinition 'qstring) #'identity)
2009-07-02 tobias 274
17:34:07 ' 275 (defun find-qclass (class-name)
' 276 "Returns the CLOS class for the C++ CLASS-NAME string."
' 277 (find-class (smoke::lispify class-name :cl-smoke.qt)))
2009-07-24 tobias 278
13:39:55 ' 279 ;;; Documentation
' 280 ;;;
' 281
' 282 (defun qapropos (name)
2010-01-10 tobias 283 (smoke::fgrep-classes cl-smoke.qt.core::*smoke-module* name)
08:53:29 ' 284 (smoke::fgrep-classes cl-smoke.qt.gui::*smoke-module* name)
' 285 (smoke::fgrep-methods cl-smoke.qt.core::*smoke-module* name)
' 286 (smoke::fgrep-methods cl-smoke.qt.gui::*smoke-module* name))
2009-07-24 tobias 287
13:39:55 ' 288 ;; FIXME: implement QDESCRIBE
' 289 (defun qdescribe (name)
' 290 (declare (ignore name))
' 291 (warn "QDESCRIBE not implemented."))
Crece desde el pueblo el futuro / crece desde el pie