repos / commonqt / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | headblob | headfilediff | filehistory
normal | plain | shade | zebra
#_ reader macro enum calls & cleanup
Annotate for file src/commonqt.lisp
2009-07-02 tobias 1 (in-package :cl-smoke.commonqt)
17:34:07 ' 2
' 3 ;;; calling methods
' 4 ;;;
' 5 (eval-when (:load-toplevel :compile-toplevel :execute)
2009-07-24 tobias 6 (defun read-perserving-case (stream)
13:39:55 ' 7 (let ((*readtable* (copy-readtable nil)))
' 8 (setf (readtable-case *readtable*) :preserve)
' 9 (read stream)))
2009-07-02 tobias 10
2009-07-24 tobias 11 (defun cl-smoke-funcall-form (stream subchar arg)
13:39:55 ' 12 (declare (ignore subchar arg))
' 13 (let ((method (read-perserving-case stream)))
' 14 (if (string= "new" (symbol-name method))
' 15 `(lambda (&rest args)
' 16 (make-instance
' 17 ',(smoke::lispify (symbol-name (read-perserving-case stream)) :cl-smoke.qt)
' 18 :args args))
' 19 (let ((object (read stream)))
' 20 (if (stringp object)
2009-07-02 tobias 21 (if (upper-case-p (char (symbol-name method) 0))
20:48:38 ' 22 `(lambda ()
' 23 ,(smoke::lispify
' 24 (concatenate 'string
' 25 (if (string= "Qt" object)
' 26 "+"
' 27 (concatenate 'string
' 28 object
' 29 ".+"))
' 30 (symbol-name method) "+")
' 31 :cl-smoke.qt))
' 32 `(lambda (&rest args)
' 33 (apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))
' 34 (find-class ',(smoke::lispify object :cl-smoke.qt))
' 35 args)))
2009-07-24 tobias 36 `(lambda (&rest args)
13:39:55 ' 37 (apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))
' 38 ,object
' 39 args))))))))
2009-07-02 tobias 40
17:34:07 ' 41 (eval-when (:load-toplevel :compile-toplevel)
' 42 (set-dispatch-macro-character #\# #\_ #'cl-smoke-funcall-form))
' 43
' 44 ;;; Instantiating
' 45 ;;;
' 46 (defun new (instance &rest arguments)
' 47 "Calls the C++ construor for INSTANCE with ARGUMENTS."
2009-07-24 tobias 48 (assert (null-pointer-p (smoke:pointer instance)))
2009-07-02 tobias 49 (setf (slot-value instance 'smoke:pointer)
2010-01-10 tobias 50 (smoke::call-constructor instance arguments))
2009-07-24 tobias 51 (assert (not (null-pointer-p (smoke:pointer instance))))
2009-07-02 tobias 52 (smoke::set-binding instance)
17:34:07 ' 53 (smoke::take-ownership instance)
' 54 (smoke::add-object instance)
' 55 instance)
' 56
' 57 ;;; Connecting signals and slots
' 58 ;;;
' 59 (defun qsignal (name)
' 60 (cl-smoke.qt:qsignal name))
' 61 (defun qslot (name)
' 62 (cl-smoke.qt:qslot name))
' 63
' 64 ;;; QApplication
' 65 ;;;
' 66 (defun make-qapplication (&rest arguments)
' 67 "Returns a new QApplication instance with ARGUMENTS as command line
' 68 arguments argv. argv[0] is set to (LISP-IMPLEMNTATION-TYPE)."
2009-07-02 tobias 69 (let* ((argc ;(smoke::make-auto-pointer
2009-07-02 tobias 70 (cffi:foreign-alloc :int
2009-07-02 tobias 71 :initial-element (1+ (length arguments))))
21:49:43 ' 72 (argv ;(smoke::make-auto-pointer
2009-07-02 tobias 73 (cffi:foreign-alloc :string
17:34:07 ' 74 :initial-contents
' 75 (cons (lisp-implementation-type) ;; arg0
2009-07-02 tobias 76 arguments)))
2009-07-02 tobias 77 (application (make-instance 'cl-smoke.qt:application :args
17:34:07 ' 78 (list argc argv))))
' 79 ;; argc & argv must remain valid during the lifetime of application.
' 80 (setf (cl-smoke.qt:property application 'arguments)
' 81 (cl-smoke.qt:make-lisp-variant (cons argc argv)))
' 82 application))
' 83
' 84 ;;; Overriding C++ methods
' 85 (defclass override-gf (standard-generic-function)
' 86 ((cxx-gf :initarg :cxx-gf
' 87 :reader cxx-gf))
' 88 (:metaclass closer-mop:funcallable-standard-class)
' 89 (:documentation "Redirects its methods to CXX-GF."))
' 90
' 91 (defmethod add-method ((gf override-gf) method)
' 92 (add-method (cxx-gf gf) method))
' 93
' 94 (defmethod remove-method ((gf override-gf) method)
' 95 (remove-method (cxx-gf gf) method))
' 96
' 97 ;;; Subclassing C++ & defining signals and slots
' 98 ;;;
' 99 (defclass qt-class (cxx:class)
2009-07-24 tobias 100 ((qt-slots :initarg :slots :initform nil) ;; FIXME remove this
13:39:55 ' 101 (signals :initarg :signals :initform nil) ;; FIXME remove this
' 102 (method-functions :documentation "The signals and slots.")
' 103 (meta-object)))
2009-07-02 tobias 104
2009-07-02 tobias 105 (defclass signal-slot-mixin ()
20:48:38 ' 106 ())
' 107
2009-07-24 tobias 108 (defun setup-meta-object (class qt-superclass)
13:39:55 ' 109 (let ((methods (make-array (+ (length (slot-value class 'signals))
' 110 (length (slot-value class 'qt-slots)))
2009-07-02 tobias 111 :element-type 'function
17:34:07 ' 112 :initial-element #'identity))
' 113 (index 0))
2009-07-24 tobias 114 (dolist (signal-name (slot-value class 'signals))
2009-07-02 tobias 115 (setf (aref methods index)
2009-07-02 tobias 116 #'(lambda (this &rest args)
2009-07-02 tobias 117 (apply #'emit-signal this signal-name args)))
20:48:38 ' 118 (incf index))
2009-07-24 tobias 119 (dolist (slot (slot-value class 'qt-slots))
2009-07-02 tobias 120 (setf (aref methods index)
17:34:07 ' 121 (if (symbolp (second slot))
' 122 (second slot)
' 123 (eval `(function ,(second slot)))))
' 124 (incf index))
2009-07-24 tobias 125 (setf (slot-value class 'method-functions) methods))
2009-07-02 tobias 126 (let ((signals (mapcar #'(lambda (s) (make-slot-or-signal (first s)))
2009-07-24 tobias 127 (slot-value class 'signals)))
2009-07-02 tobias 128 (slots (mapcar #'(lambda (s) (make-slot-or-signal (first s)))
2009-07-24 tobias 129 (slot-value class 'qt-slots)))
2009-07-02 tobias 130 (class-name (class-name class)))
17:34:07 ' 131 (setf (slot-value class 'meta-object)
' 132 (make-metaobject qt-superclass
' 133 (format nil "~A::~A"
' 134 (package-name (symbol-package class-name))
' 135 (symbol-name class-name))
' 136 nil
' 137 signals
' 138 slots))))
' 139
' 140 (defun setup-qt-class (qt-class next-method &rest args &key qt-superclass
' 141 direct-superclasses direct-default-initargs
' 142 override &allow-other-keys)
2009-07-24 tobias 143 (assert (null direct-superclasses))
2009-07-02 tobias 144 (dolist (method override)
17:34:07 ' 145 (ensure-generic-function
' 146 (second method)
' 147 :generic-function-class (find-class 'override-gf)
' 148 :lambda-list '(this &rest args)
' 149 :cxx-gf (fdefinition (smoke::lispify (first method) :cxx))))
' 150 (apply next-method qt-class
' 151 :direct-default-initargs ;; the C++ instance is constructed with #'NEW
' 152 (cons `(:pointer (null-pointer) ,#'null-pointer)
' 153 direct-default-initargs)
' 154 :direct-superclasses
2009-07-02 tobias 155 (list (find-qclass (first qt-superclass))
20:48:38 ' 156 (find-class 'signal-slot-mixin))
2009-07-02 tobias 157 args)
2009-07-24 tobias 158 (setup-meta-object qt-class (find-qclass (first qt-superclass))))
2009-07-02 tobias 159
2009-07-02 tobias 160 (defmethod cxx:meta-object ((this signal-slot-mixin))
20:48:38 ' 161 (slot-value (class-of this) 'meta-object))
' 162
' 163 (defmethod cxx:qt-metacall ((this signal-slot-mixin) call id arguments)
' 164 (let ((m-id (call-next-method)))
' 165 (if (< m-id 0)
' 166 m-id
' 167 (if (enum= call cl-smoke.qt:meta-object.+invoke-meta-method+)
' 168 (progn
' 169 (when (< m-id (length (slot-value (class-of this)
' 170 'method-functions)))
' 171 (with-simple-restart
' 172 (continue "Skip the method ~A of ~A."
' 173 (cxx:signature
' 174 (cxx:method (cxx:meta-object this) id))
' 175 this)
' 176 (apply (aref (slot-value (class-of this) 'method-functions)
' 177 m-id)
' 178 this
' 179 (cl-smoke.qt-impl::arguments-to-lisp
' 180 arguments
' 181 (cl-smoke.qt-impl::method-arguments-type
' 182 (cxx:meta-object this) id)))))
' 183 (- m-id
' 184 (length (slot-value (class-of this) 'method-functions))))
' 185 m-id))))
' 186
2009-07-02 tobias 187 (defmethod initialize-instance :around ((class qt-class)
2009-08-27 tobias 188 &rest args)
2009-07-02 tobias 189 (apply #'setup-qt-class class #'call-next-method args))
2009-07-02 tobias 190
2009-08-27 tobias 191 (defmethod reinitialize-instance :around ((qt-class qt-class) &rest args)
2009-07-02 tobias 192 (apply #'setup-qt-class qt-class #'call-next-method args))
17:34:07 ' 193
' 194 (defun emit-signal (object signal-name &rest arguments)
' 195 "Emits the signal SIGNAL-NAME of OBJECT using ARGUMENTS."
2009-07-24 tobias 196 (let* ((meta-object (slot-value (class-of object) 'meta-object))
13:39:55 ' 197 (id (#_indexOfSignal meta-object signal-name)))
2009-07-02 tobias 198 (assert (>= id 0)
17:34:07 ' 199 ()
' 200 "No signal ~A of ~A." signal-name object)
2010-01-10 tobias 201 (cl-smoke.qt-impl::activate
08:53:29 ' 202 object id (cl-smoke.qt-impl::method-arguments-type meta-object id)
2009-07-02 tobias 203 arguments)))
17:34:07 ' 204
' 205 (defmacro call-next-qmethod ()
' 206 "Calls the next method."
' 207 '(call-next-method))
' 208
2009-07-24 tobias 209
2009-07-02 tobias 210 ;;; Enum values
17:34:07 ' 211 ;;;
' 212 (defun primitive-value (enum)
' 213 "Returns the integer value of ENUM."
' 214 (cxx-support:value enum))
' 215
' 216 ;;; Type disambiguation
' 217 ;;;
' 218 ;; No-op since we have overload resolution.
' 219 (setf (fdefinition 'uint) #'identity
2009-07-02 tobias 220 (fdefinition 'int) #'identity
20:48:38 ' 221 (fdefinition 'bool) #'identity
' 222 (fdefinition 'qstring) #'identity)
2009-07-02 tobias 223
17:34:07 ' 224 (defun find-qclass (class-name)
' 225 "Returns the CLOS class for the C++ CLASS-NAME string."
' 226 (find-class (smoke::lispify class-name :cl-smoke.qt)))
Crece desde el pueblo el futuro / crece desde el pie