Sun Jan 10 09:52:49 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Split up in qt.gui & cleanup name prefix.

--- old-qt.gui/src/signal-slot/translate.lisp 2014-10-30 07:42:44.000000000 +0100

+++ new-qt.gui/src/signal-slot/translate.lisp 1970-01-01 01:00:00.000000000 +0100

@@ -1,111 +0,0 @@

-(in-package :cl-smoke.qt-impl)

-

-(defun find-type (name &optional start end)

- (smoke::make-smoke-type *smoke-module* (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-type

- (pointer-to-lisp (mem-ref argument :pointer)

- (first types)))

-

- (t

- (translate-cxx-lisp-object

- (mem-ref argument :pointer)))))))))

-

-(defun disown-object (object)

- (tg:cancel-finalization object)

- (unless (smoke::virtual-destructor-p (class-of object))

- (smoke::remove-object (pointer object)))

- object)

-

-(defun pointer-to-lisp (pointer type)

- "Returns the lisp value or object at POINTER of type TYPE."

- (if (smoke::class-p type)

- (if (smoke::pointer-p type)

- (smoke::object-to-lisp (mem-ref pointer :pointer) type)

- ;; By-value means that the object at POINTER is allocated by

- ;; the C++ signal code and has dynamic extend in the

- ;; slot. The C++ signal code frees the object when the slot

- ;; returns.

- (disown-object (smoke::object-to-lisp pointer type)))

- (ecase (smoke::type-id type)

- (0 (if-let ((translation (gethash (name type) smoke::*to-lisp-translations*)))

- ;; Do not free stack allocated stuff (e.g.: QString); that is the callers

- ;; responisbility.

- (funcall (car translation) pointer)

- (error "Do not know how to convert the type ~A to Lisp." type)))

- (1 (mem-ref pointer 'cxx-bool))

- (2 (code-char (mem-ref pointer :char)))

- (3 (code-char (mem-ref pointer :unsigned-char)))

- (4 (code-char (mem-ref pointer :short)))

- (5 (code-char (mem-ref pointer :unsigned-short)))

- (6 (mem-ref pointer :int))

- (7 (mem-ref pointer :unsigned-int))

- (8 (mem-ref pointer :long))

- (9 (mem-ref pointer :unsigned-long))

- (10 (mem-ref pointer :float))

- (11 (mem-ref pointer :double))

- (12 (make-instance 'enum

- :value (mem-ref pointer :long)

- :type type)))))

-

-

-(defun arguments-to-lisp (arguments types)

- "Returns ARGUMENTS for a slot invocation as lisp objects."

- (arguments-to-lisp2

- (inc-pointer arguments ;; index 0 is for the return value

- (foreign-type-size :pointer))

- types ()))

-

-

-(defun get-type (smoke-type)

- "Returns the QMetaType ID for SMOKE-TYPE."

- (typecase smoke-type

- (smoke::smoke-standard-object

- (if (smoke::pointer-p smoke-type)

- (error "Not implemented: pointer type.") ;;qmetatype.+voidstar+

- (let ((type (qt: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)

- "Returns a newly allocated array of QMetaType IDs of 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))