repos / commonqt / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | headblob | headfilediff | filehistory
normal | plain | shade | zebra
Fix invalid keyword argument errors in defclass qt-class.
Annotate for file src/commonqt.lisp
2010-01-10 tobias 1 ;;; Copyright (C) 2009 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
2009-07-24 tobias 30 ;;; initialization
13:39:55 ' 31 (defun ensure-smoke ())
' 32 (defun enable-syntax ())
' 33
2009-07-02 tobias 34 ;;; calling methods
2009-07-24 tobias 35 ;;;
13:39:55 ' 36 ;;; #_ reader macro
' 37 ;;;
' 38 ;;; FIXME: Return reference arguments using multiple return values.
2009-07-02 tobias 39 ;;;
17:34:07 ' 40 (eval-when (:load-toplevel :compile-toplevel :execute)
2009-07-24 tobias 41 (defun read-perserving-case (stream)
13:39:55 ' 42 (let ((*readtable* (copy-readtable nil)))
' 43 (setf (readtable-case *readtable*) :preserve)
' 44 (read stream)))
2009-07-02 tobias 45
2009-07-24 tobias 46 (defun cl-smoke-funcall-form (stream subchar arg)
13:39:55 ' 47 (declare (ignore subchar arg))
' 48 (let ((method (read-perserving-case stream)))
' 49 (if (string= "new" (symbol-name method))
' 50 `(lambda (&rest args)
' 51 (make-instance
' 52 ',(smoke::lispify (symbol-name (read-perserving-case stream)) :cl-smoke.qt)
' 53 :args args))
' 54 (let ((object (read stream)))
' 55 (if (stringp object)
' 56 (if (upper-case-p (char (symbol-name method) 0))
' 57 `(lambda ()
' 58 ,(smoke::lispify
' 59 (concatenate 'string
' 60 (if (string= "Qt" object)
' 61 "+"
' 62 (concatenate 'string
' 63 object
' 64 ".+"))
' 65 (symbol-name method) "+")
' 66 :cl-smoke.qt))
' 67 `(lambda (&rest args)
' 68 (apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))
' 69 (find-class ',(smoke::lispify object :cl-smoke.qt))
' 70 args)))
' 71 `(lambda (&rest args)
' 72 (apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))
' 73 ,object
' 74 args))))))))
2009-07-02 tobias 75
17:34:07 ' 76 (eval-when (:load-toplevel :compile-toplevel)
' 77 (set-dispatch-macro-character #\# #\_ #'cl-smoke-funcall-form))
' 78
' 79 ;;; Instantiating
' 80 ;;;
' 81 (defun new (instance &rest arguments)
' 82 "Calls the C++ construor for INSTANCE with ARGUMENTS."
2009-07-24 tobias 83 (assert (null-pointer-p (smoke:pointer instance))
13:39:55 ' 84 (instance)
' 85 "The instance ~A is already constructed." instance)
2009-07-02 tobias 86 (setf (slot-value instance 'smoke:pointer)
2010-01-10 tobias 87 (smoke::call-constructor instance arguments))
2009-07-02 tobias 88 (smoke::set-binding instance)
17:34:07 ' 89 (smoke::take-ownership instance)
' 90 (smoke::add-object instance)
' 91 instance)
' 92
' 93 ;;; Connecting signals and slots
' 94 ;;;
' 95 (defun qsignal (name)
' 96 (cl-smoke.qt:qsignal name))
' 97 (defun qslot (name)
' 98 (cl-smoke.qt:qslot name))
' 99
' 100 ;;; QApplication
' 101 ;;;
' 102 (defun make-qapplication (&rest arguments)
' 103 "Returns a new QApplication instance with ARGUMENTS as command line
' 104 arguments argv. argv[0] is set to (LISP-IMPLEMNTATION-TYPE)."
2009-07-24 tobias 105 (let* ((argc (smoke:make-auto-pointer
2009-07-02 tobias 106 (cffi:foreign-alloc :int
2009-07-02 tobias 107 :initial-element (1+ (length arguments)))))
2009-07-24 tobias 108 (argv (smoke:make-auto-pointer
2009-07-02 tobias 109 (cffi:foreign-alloc :string
17:34:07 ' 110 :initial-contents
' 111 (cons (lisp-implementation-type) ;; arg0
2009-07-02 tobias 112 arguments))))
2009-07-02 tobias 113 (application (make-instance 'cl-smoke.qt:application :args
17:34:07 ' 114 (list argc argv))))
' 115 ;; argc & argv must remain valid during the lifetime of application.
' 116 (setf (cl-smoke.qt:property application 'arguments)
' 117 (cl-smoke.qt:make-lisp-variant (cons argc argv)))
' 118 application))
' 119
' 120 ;;; Overriding C++ methods
' 121 (defclass override-gf (standard-generic-function)
' 122 ((cxx-gf :initarg :cxx-gf
' 123 :reader cxx-gf))
' 124 (:metaclass closer-mop:funcallable-standard-class)
' 125 (:documentation "Redirects its methods to CXX-GF."))
' 126
' 127 (defmethod add-method ((gf override-gf) method)
' 128 (add-method (cxx-gf gf) method))
' 129
' 130 (defmethod remove-method ((gf override-gf) method)
' 131 (remove-method (cxx-gf gf) method))
' 132
' 133 ;;; Subclassing C++ & defining signals and slots
' 134 ;;;
' 135 (defclass qt-class (cxx:class)
2009-07-24 tobias 136 ((method-functions :accessor method-functions
13:39:55 ' 137 :documentation "The signals and slots.")
' 138 (meta-object :reader class-meta-object))
' 139 (:documentation "Metaclass for a class derived from QObject, that allows
' 140 adding signals and slots to the class."))
2009-07-02 tobias 141
2009-07-02 tobias 142 (defclass signal-slot-mixin ()
2009-07-24 tobias 143 ()
13:39:55 ' 144 (:documentation "Mixin for a class with metaclass QT-CLASS, that overwrites
' 145 the metaObject and qtMetacall methods."))
2009-07-02 tobias 146
2009-07-24 tobias 147 (defun setup-meta-object (class qt-superclass signals slots)
13:39:55 ' 148 (let ((methods (make-array (+ (length signals)
' 149 (length slots))
2009-07-02 tobias 150 :element-type 'function
17:34:07 ' 151 :initial-element #'identity))
' 152 (index 0))
2009-07-24 tobias 153 (dolist (signal-name signals)
2009-07-02 tobias 154 (setf (aref methods index)
2009-07-02 tobias 155 (let ((signal-name (first signal-name)))
21:49:43 ' 156 #'(lambda (this &rest args)
' 157 (apply #'emit-signal this signal-name args))))
2009-07-02 tobias 158 (incf index))
2009-07-24 tobias 159 (dolist (slot slots)
2009-07-02 tobias 160 (setf (aref methods index)
17:34:07 ' 161 (if (symbolp (second slot))
' 162 (second slot)
' 163 (eval `(function ,(second slot)))))
' 164 (incf index))
2009-07-24 tobias 165 (setf (method-functions class) methods))
2009-07-02 tobias 166 (let ((signals (mapcar #'(lambda (s) (make-slot-or-signal (first s)))
2009-07-24 tobias 167 signals))
2009-07-02 tobias 168 (slots (mapcar #'(lambda (s) (make-slot-or-signal (first s)))
2009-07-24 tobias 169 slots))
2009-07-02 tobias 170 (class-name (class-name class)))
17:34:07 ' 171 (setf (slot-value class 'meta-object)
' 172 (make-metaobject qt-superclass
' 173 (format nil "~A::~A"
' 174 (package-name (symbol-package class-name))
' 175 (symbol-name class-name))
' 176 nil
' 177 signals
' 178 slots))))
' 179
' 180 (defun setup-qt-class (qt-class next-method &rest args &key qt-superclass
' 181 direct-superclasses direct-default-initargs
2009-07-24 tobias 182 slots signals
2009-07-02 tobias 183 override &allow-other-keys)
17:34:07 ' 184 (dolist (method override)
' 185 (ensure-generic-function
' 186 (second method)
' 187 :generic-function-class (find-class 'override-gf)
' 188 :lambda-list '(this &rest args)
' 189 :cxx-gf (fdefinition (smoke::lispify (first method) :cxx))))
' 190 (apply next-method qt-class
' 191 :direct-default-initargs ;; the C++ instance is constructed with #'NEW
' 192 (cons `(:pointer (null-pointer) ,#'null-pointer)
' 193 direct-default-initargs)
' 194 :direct-superclasses
2009-07-24 tobias 195 (append (list (find-qclass (first qt-superclass))
13:39:55 ' 196 (find-class 'signal-slot-mixin))
' 197 direct-superclasses)
2009-07-02 tobias 198 args)
2009-07-24 tobias 199 (setup-meta-object qt-class (find-qclass (first qt-superclass))
13:39:55 ' 200 signals slots))
2009-07-02 tobias 201
2009-07-02 tobias 202 (defmethod cxx:meta-object ((this signal-slot-mixin))
2009-07-24 tobias 203 (class-meta-object (class-of this)))
2009-07-02 tobias 204
20:48:38 ' 205 (defmethod cxx:qt-metacall ((this signal-slot-mixin) call id arguments)
' 206 (let ((m-id (call-next-method)))
' 207 (if (< m-id 0)
' 208 m-id
' 209 (if (enum= call cl-smoke.qt:meta-object.+invoke-meta-method+)
' 210 (progn
2009-07-24 tobias 211 (when (< m-id (length (method-functions (class-of this))))
2009-07-02 tobias 212 (with-simple-restart
20:48:38 ' 213 (continue "Skip the method ~A of ~A."
' 214 (cxx:signature
' 215 (cxx:method (cxx:meta-object this) id))
' 216 this)
2009-07-24 tobias 217 (apply (aref (method-functions (class-of this)) m-id)
2009-07-02 tobias 218 this
2010-01-10 tobias 219 (cl-smoke.qt-impl::arguments-to-lisp
2009-07-02 tobias 220 arguments
2010-01-10 tobias 221 (cl-smoke.qt-impl::method-arguments-type
08:53:29 ' 222 (cxx:meta-object this) id)))))
2009-07-02 tobias 223 (- m-id
2009-07-24 tobias 224 (length (method-functions (class-of this)))))
2009-07-02 tobias 225 m-id))))
20:48:38 ' 226
2009-07-02 tobias 227 (defmethod initialize-instance :around ((class qt-class)
2009-08-27 tobias 228 &rest args &key &allow-other-keys)
2009-07-02 tobias 229 (apply #'setup-qt-class class #'call-next-method args))
2009-07-02 tobias 230
2009-08-27 tobias 231 (defmethod reinitialize-instance :around ((qt-class qt-class)
11:17:58 ' 232 &rest args &key &allow-other-keys)
2009-07-02 tobias 233 (apply #'setup-qt-class qt-class #'call-next-method args))
17:34:07 ' 234
' 235 (defun emit-signal (object signal-name &rest arguments)
' 236 "Emits the signal SIGNAL-NAME of OBJECT using ARGUMENTS."
2009-07-02 tobias 237 (declare (string signal-name))
2009-07-24 tobias 238 (let* ((meta-object (class-meta-object (class-of object)))
13:39:55 ' 239 (id (#_indexOfSignal meta-object
' 240 (#_normalizedSignature "QMetaObject"
' 241 signal-name))))
2009-07-02 tobias 242 (assert (>= id 0)
17:34:07 ' 243 ()
' 244 "No signal ~A of ~A." signal-name object)
2010-01-10 tobias 245 (cl-smoke.qt-impl::activate
08:53:29 ' 246 object id (cl-smoke.qt-impl::method-arguments-type meta-object id)
2009-07-02 tobias 247 arguments)))
17:34:07 ' 248
' 249 (defmacro call-next-qmethod ()
' 250 "Calls the next method."
' 251 '(call-next-method))
' 252
' 253 ;;; Enum values
' 254 ;;;
' 255 (defun primitive-value (enum)
' 256 "Returns the integer value of ENUM."
' 257 (cxx-support:value enum))
' 258
' 259 ;;; Type disambiguation
' 260 ;;;
2009-07-02 tobias 261 (defun bool (value)
2009-07-24 tobias 262 "Returns true when VALUE is not 0 and false when it is 0."
13:39:55 ' 263 (not (zerop value)))
2009-07-02 tobias 264
2009-07-02 tobias 265 ;; No-op since we have overload resolution.
17:34:07 ' 266 (setf (fdefinition 'uint) #'identity
2009-07-02 tobias 267 (fdefinition 'int) #'identity
20:48:38 ' 268 (fdefinition 'qstring) #'identity)
2009-07-02 tobias 269
17:34:07 ' 270 (defun find-qclass (class-name)
' 271 "Returns the CLOS class for the C++ CLASS-NAME string."
' 272 (find-class (smoke::lispify class-name :cl-smoke.qt)))
2009-07-24 tobias 273
13:39:55 ' 274 ;;; Documentation
' 275 ;;;
' 276
' 277 (defun qapropos (name)
2010-01-10 tobias 278 (smoke::fgrep-classes cl-smoke.qt-impl::*smoke-module* name)
08:53:29 ' 279 (smoke::fgrep-methods cl-smoke.qt-impl::*smoke-module* name))
2009-07-24 tobias 280
13:39:55 ' 281 ;; FIXME: implement QDESCRIBE
' 282 (defun qdescribe (name)
' 283 (declare (ignore name))
' 284 (warn "QDESCRIBE not implemented."))
Crece desde el pueblo el futuro / crece desde el pie