src/commonqt.lisp
Thu Jul 2 19:34:07 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
--- old-commonqt/src/commonqt.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-commonqt/src/commonqt.lisp 2014-10-30 07:09:36.000000000 +0100
@@ -0,0 +1,211 @@
+(in-package :cl-smoke.commonqt)
+
+;;; calling methods
+;;;
+(eval-when (:load-toplevel :compile-toplevel :execute)
+(defun read-perserving-case (stream)
+ (let ((*readtable* (copy-readtable nil)))
+ (setf (readtable-case *readtable*) :preserve)
+ (read stream)))
+
+(defun cl-smoke-funcall-form (stream subchar arg)
+ (declare (ignore subchar arg))
+ (let ((method (read-perserving-case stream)))
+ (if (string= "new" (symbol-name method))
+ `(lambda (&rest args)
+ (make-instance
+ ',(smoke::lispify (symbol-name (read-perserving-case stream)) :cl-smoke.qt)
+ :args args))
+ (let ((object (read stream)))
+ (if (stringp object)
+ `(lambda (&rest args)
+ (apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))
+ (find-class ',(smoke::lispify object :cl-smoke.qt))
+ args))
+ `(lambda (&rest args)
+ (apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))
+ ,object
+ args))))))))
+
+(eval-when (:load-toplevel :compile-toplevel)
+ (set-dispatch-macro-character #\# #\_ #'cl-smoke-funcall-form))
+
+;;; Instantiating
+;;;
+(defun new (instance &rest arguments)
+ "Calls the C++ construor for INSTANCE with ARGUMENTS."
+ (assert (null-pointer-p (smoke:pointer instance)))
+ (setf (slot-value instance 'smoke:pointer)
+ (smoke::call-constructor instance arguments))
+ (assert (not (null-pointer-p (smoke:pointer instance))))
+ (smoke::set-binding instance)
+ (smoke::take-ownership instance)
+ (smoke::add-object instance)
+ instance)
+
+;;; Connecting signals and slots
+;;;
+(defun qsignal (name)
+ (cl-smoke.qt:qsignal name))
+(defun qslot (name)
+ (cl-smoke.qt:qslot name))
+
+;;; QApplication
+;;;
+(defun make-qapplication (&rest arguments)
+ "Returns a new QApplication instance with ARGUMENTS as command line
+arguments argv. argv[0] is set to (LISP-IMPLEMNTATION-TYPE)."
+ (let* ((argc ;(smoke::make-auto-pointer
+ (cffi:foreign-alloc :int
+ :initial-element (1+ (length arguments))))
+ (argv ;(smoke::make-auto-pointer
+ (cffi:foreign-alloc :string
+ :initial-contents
+ (cons (lisp-implementation-type) ;; arg0
+ arguments)))
+ (application (make-instance 'cl-smoke.qt:application :args
+ (list argc argv))))
+ ;; argc & argv must remain valid during the lifetime of application.
+ (setf (cl-smoke.qt:property application 'arguments)
+ (cl-smoke.qt:make-lisp-variant (cons argc argv)))
+ application))
+
+;;; Overriding C++ methods
+(defclass override-gf (standard-generic-function)
+ ((cxx-gf :initarg :cxx-gf
+ :reader cxx-gf))
+ (:metaclass closer-mop:funcallable-standard-class)
+ (:documentation "Redirects its methods to CXX-GF."))
+
+(defmethod add-method ((gf override-gf) method)
+ (add-method (cxx-gf gf) method))
+
+(defmethod remove-method ((gf override-gf) method)
+ (remove-method (cxx-gf gf) method))
+
+;;; Subclassing C++ & defining signals and slots
+;;;
+(defclass qt-class (cxx:class)
+ ((qt-slots :initarg :slots :initform nil) ;; FIXME remove this
+ (signals :initarg :signals :initform nil) ;; FIXME remove this
+ (method-functions :documentation "The signals and slots.")
+ (meta-object)))
+
+(defun setup-meta-object (class qt-superclass)
+ (let ((methods (make-array (+ (length (slot-value class 'signals))
+ (length (slot-value class 'qt-slots)))
+ :element-type 'function
+ :initial-element #'identity))
+ (index 0))
+ (dolist (signal-name (slot-value class 'signals))
+ (incf index)
+ (setf (aref methods index)
+ #'(lambda (this &rest args)
+ (apply #'emit-signal this signal-name args))))
+ (dolist (slot (slot-value class 'qt-slots))
+ (setf (aref methods index)
+ (if (symbolp (second slot))
+ (second slot)
+ (eval `(function ,(second slot)))))
+ (incf index))
+ (setf (slot-value class 'method-functions) methods))
+ (let ((signals (mapcar #'(lambda (s) (make-slot-or-signal (first s)))
+ (slot-value class 'signals)))
+ (slots (mapcar #'(lambda (s) (make-slot-or-signal (first s)))
+ (slot-value class 'qt-slots)))
+ (class-name (class-name class)))
+ (setf (slot-value class 'meta-object)
+ (make-metaobject qt-superclass
+ (format nil "~A::~A"
+ (package-name (symbol-package class-name))
+ (symbol-name class-name))
+ nil
+ signals
+ slots))))
+
+(defun setup-qt-class (qt-class next-method &rest args &key qt-superclass
+ direct-superclasses direct-default-initargs
+ override &allow-other-keys)
+ (assert (null direct-superclasses))
+ (dolist (method override)
+ (ensure-generic-function
+ (second method)
+ :generic-function-class (find-class 'override-gf)
+ :lambda-list '(this &rest args)
+ :cxx-gf (fdefinition (smoke::lispify (first method) :cxx))))
+ (apply next-method qt-class
+ :direct-default-initargs ;; the C++ instance is constructed with #'NEW
+ (cons `(:pointer (null-pointer) ,#'null-pointer)
+ direct-default-initargs)
+ :direct-superclasses
+ (list (find-qclass (first qt-superclass)))
+ args)
+ (setup-meta-object qt-class (find-qclass (first qt-superclass))))
+
+(defmethod initialize-instance :around ((class qt-class)
+ &rest args)
+ (apply #'setup-qt-class class #'call-next-method args)
+ (closer-mop:ensure-method #'cxx:meta-object
+ '(lambda (this)
+ (slot-value (class-of this) 'meta-object))
+ :specializers (list class))
+ (closer-mop:ensure-method
+ #'cxx:qt-metacall
+ '(lambda (this call id arguments)
+ (let ((m-id (call-next-method)))
+ (if (< m-id 0)
+ m-id
+ (if (enum= call cl-smoke.qt:meta-object.+invoke-meta-method+)
+ (progn
+ (when (< m-id (length (slot-value (class-of this)
+ 'method-functions)))
+ (with-simple-restart
+ (continue "Skip the method ~A of ~A."
+ id
+ this)
+ (apply (aref (slot-value (class-of this) 'method-functions)
+ m-id)
+ this
+ (cl-smoke.qt-impl::arguments-to-lisp
+ arguments
+ (cl-smoke.qt-impl::method-arguments-type
+ (cxx:meta-object this) id)))))
+ (- m-id
+ (length (slot-value (class-of this) 'method-functions))))
+ m-id))))
+ :specializers (list class (find-class t) (find-class t) (find-class t))))
+
+(defmethod reinitialize-instance :around ((qt-class qt-class) &rest args)
+ (apply #'setup-qt-class qt-class #'call-next-method args))
+
+(defun emit-signal (object signal-name &rest arguments)
+ "Emits the signal SIGNAL-NAME of OBJECT using ARGUMENTS."
+ (let* ((meta-object (slot-value (class-of object) 'meta-object))
+ (id (#_indexOfSignal meta-object signal-name)))
+ (assert (>= id 0)
+ ()
+ "No signal ~A of ~A." signal-name object)
+ (cl-smoke.qt-impl::activate
+ object id (cl-smoke.qt-impl::method-arguments-type meta-object id)
+ arguments)))
+
+(defmacro call-next-qmethod ()
+ "Calls the next method."
+ '(call-next-method))
+
+
+;;; Enum values
+;;;
+(defun primitive-value (enum)
+ "Returns the integer value of ENUM."
+ (cxx-support:value enum))
+
+;;; Type disambiguation
+;;;
+;; No-op since we have overload resolution.
+(setf (fdefinition 'uint) #'identity
+ (fdefinition 'int) #'identity)
+
+(defun find-qclass (class-name)
+ "Returns the CLOS class for the C++ CLASS-NAME string."
+ (find-class (smoke::lispify class-name :cl-smoke.qt)))