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