src/signal-slot/translate.lisp
Sun Apr 5 19:56:16 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial import
--- old-qt.core/src/signal-slot/translate.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-qt.core/src/signal-slot/translate.lisp 2014-11-11 13:38:03.000000000 +0100
@@ -0,0 +1,83 @@
+(in-package :qt)
+
+(defun method-argument-count (metaobject index)
+ "Returns the number of arguments the method INDEX of METAOBJECT."
+ (let ((signature (cxx:signature (cxx:method metaobject index))))
+ (setf signature (subseq signature (1+ (position #\( signature))
+ (position #\) signature :from-end t)))
+ (if (= 0 (length signature))
+ 0
+ (1+ (count #\, signature)))))
+
+(defun find-type (name &optional start end)
+ (smoke::make-smoke-type *qt-smoke* (subseq name start end)))
+
+(defun method-arguments-type (metaobject index)
+ "Returns a type name list for the arguments of method INDEX of METAOBJECT."
+ (let* ((signature (cxx:signature (cxx:method metaobject index)))
+ (arguments (subseq signature (1+ (position #\( signature))
+ (position #\) signature :from-end t)))
+ (argument-types ())
+ (last-pos (length arguments)))
+ (loop as pos = (position #\, arguments :from-end t :end last-pos)
+ while pos
+ do
+ (push (find-type arguments (1+ pos) last-pos) argument-types)
+ (setf last-pos pos))
+ (when (> last-pos 0)
+ (push (find-type arguments 0 last-pos) argument-types))))
+
+
+(defun arguments-to-lisp2 (argument types values)
+ (if (null types)
+ values
+ (arguments-to-lisp2 (inc-pointer argument (foreign-type-size :pointer))
+ (rest types)
+ (nconc values
+ (list
+ (typecase (first types)
+ ;(smoke::smoke-standard-object
+ ; (smoke::object-to-lisp
+ ; (mem-ref
+ ; (mem-ref argument
+ ; :pointer) :pointer)
+ ; (first types)))
+ (smoke::smoke-type
+ (smoke::type-to-lisp argument
+ (first types)))
+ (t
+ (translate-cxx-lisp-object
+ (mem-ref argument :pointer)))))))))
+
+(defun arguments-to-lisp (arguments types)
+ (arguments-to-lisp2 (inc-pointer arguments ;; index 0 is for the return value
+ (foreign-type-size :pointer))
+ types ()))
+
+
+(defun get-type (smoke-type)
+ (typecase smoke-type
+ (smoke::smoke-standard-object
+ (if (smoke::pointer-p smoke-type)
+ (error "FOO");;qmetatype.+voidstar+
+ (let ((type (meta-type.type (smoke::name smoke-type))))
+ (assert (/= 0 type)
+ (type)
+ "The type ~S has no QMetaType."
+ (smoke::name smoke-type))
+ type)))
+ (t
+ *cxx-lisp-object-metatype*)))
+
+
+(defun types (smoke-types)
+ ;;FIXME free TYPES on error.
+ (let ((types (cffi:foreign-alloc :int :count (1+ (length smoke-types))))
+ (index 0))
+ (dolist (type smoke-types)
+ (setf (cffi:mem-aref types :int index)
+ (get-type type))
+ (incf index))
+ (setf (cffi:mem-aref types :int index)
+ 0)
+ types))