Mon Jan 25 19:45:04 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Allow other modules to define QList<Foo*> conversions.
diff -rN -u old-qt.core/src/list.lisp new-qt.core/src/list.lisp
--- old-qt.core/src/list.lisp 2014-10-30 06:58:12.000000000 +0100
+++ new-qt.core/src/list.lisp 2014-10-30 06:58:12.000000000 +0100
@@ -1,72 +1,101 @@
(in-package :cl-smoke.qt.core)
-(defmacro define-qlist-wrapper (type-name element-type &optional c-name)
- (let* ((c-name (or c-name type-name))
- (type (string-upcase c-name))
- (list-type (symbolicate 'qlist- type)))
- `(progn
- (defcfun ,(concatenate 'string "cl_smoke_list_" c-name "_size") :int
- "Returns the size of LIST."
- (list :pointer))
- (defcfun ,(concatenate 'string "cl_smoke_free_list_" c-name) :void
- "Frees LIST."
- (list :pointer))
- (defcfun ,(concatenate 'string "cl_smoke_make_list_" c-name) :pointer
- "Makes a list.")
- (defcfun ,(concatenate 'string "cl_smoke_list_" c-name "_at") :pointer
- "Returns the a newly constructed copy of the element at position AT of LIST."
- (list :pointer)
- (index :int))
- (defcfun ,(concatenate 'string "cl_smoke_list_" c-name "_append") :pointer
- "Appends NEW-ELEMENT to LIST."
- (list :pointer)
- (new-element :pointer))
- ;; To Lisp
- ,@(loop for type-name in (ensure-list type-name) collect
- `(defun ,(symbolicate 'from- type-name) (list-pointer)
- (let ((vector (make-array (,(symbolicate 'cl-smoke-list-
- type '-size)
- list-pointer))))
- (dotimes (index (length vector) vector)
- (setf (aref vector index)
- ;; FIXME the returned object is not wrapped by Smoke
- ;; -> change this?
- (smoke::object-to-lisp
- (,(symbolicate 'cl-smoke-list-
- type '-at)
- list-pointer index)
- (smoke::make-smoke-type *smoke-module*
- ,type-name)))))))
- ,@(loop for type-name in (ensure-list type-name) collect
- `(define-to-lisp-translation
- (,(format nil "const QList<~A>&" type-name)
- ,(format nil "QList<~A>" type-name))
- ,(symbolicate 'from- type-name)
- ,(symbolicate 'cl-smoke-free-list- type)))
- ;; From Lisp
- (defun ,(symbolicate 'coerce- list-type) (list)
- (let ((qlist (,(symbolicate 'cl-smoke-make-list- type))))
- (loop for element across list do
- (,(symbolicate 'cl-smoke-list- type '-append)
- qlist (pointer (make-instance ',element-type :args (list element)))))
- (make-cleanup-pointer
- qlist
- (function ,(symbolicate 'cl-smoke-free-list- type)))))
- (defun ,(symbolicate list-type '-p) (list)
- (every #'(lambda (element)
- (typep element ',element-type))
- list))
- ,@(loop for type-name in (ensure-list type-name) collect
- `(define-from-lisp-translation (,(format nil "const QList<~A>&" type-name)
- ,(format nil "QList<~A>" type-name))
- ;; FIXME allow sequence
- (and (vector ,element-type)
- (satisfies ,(symbolicate list-type '-p)))
- ,(symbolicate 'coerce- list-type))))))
+(eval-when (:compile-toplevel :execute)
+ (macrolet ((c-name (name)
+ `(nth-value 1 ,name))
+ (fun-names-let (name-pre-post-fixes &body body)
+ `(flet (,@(mapcar
+ #'(lambda (npp)
+ `(,(first npp) (type)
+ (values
+ (intern (string-upcase
+ (concatenate 'string
+ ,(second npp)
+ type
+ ,(third npp)))
+ ,*package*)
+ (concatenate 'string
+ (substitute #\_ #\-
+ ,(second npp))
+ type
+ (substitute #\_ #\-
+ ,(third npp))))))
+ name-pre-post-fixes))
+ ,@body)))
+ (fun-names-let ((list-size "cl-smoke-list-" "-size")
+ (list-free "cl-smoke-free-list-")
+ (list-make "cl-smoke-make-list-")
+ (list-at "cl-smoke-list-" "-at")
+ (list-append "cl-smoke-list-" "-append"))
+ (defmacro define-qlist-wrapper (type-name element-type &optional (c-name nil c-name-p)
+ &key def-cfuns)
+ (let* ((c-name (or c-name type-name))
+ (type c-name)
+ (lisp-type (symbolicate 'qlist- element-type)))
+ `(progn
+ ,(when (or (not c-name-p) def-cfuns)
+ `(progn
+ (defcfun ,(c-name (list-size type)) :int
+ "Returns the size of LIST."
+ (list :pointer))
+ (defcfun ,(c-name (list-free type)) :void
+ "Frees LIST."
+ (list :pointer))
+ (defcfun ,(c-name (list-make type)) :pointer
+ "Makes a list.")
+ (defcfun ,(c-name (list-at type)) :pointer
+ "Returns the a newly constructed copy of the element at
+ position AT of LIST."
+ (list :pointer)
+ (index :int))
+ (defcfun ,(c-name (list-append type)) :pointer
+ "Appends NEW-ELEMENT to LIST."
+ (list :pointer)
+ (new-element :pointer))))
+ ;; To Lisp
+ ,@(loop for type-name in (ensure-list type-name) collect
+ `(defun ,(symbolicate 'from-list- type-name) (list-pointer)
+ (let ((vector (make-array (,(list-size type)
+ list-pointer))))
+ (dotimes (index (length vector) vector)
+ (setf (elt vector index)
+ ;; FIXME the returned object is not wrapped by Smoke
+ ;; -> change this?
+ (smoke:object-to-lisp
+ (,(list-at type)
+ list-pointer index)
+ (smoke:make-smoke-type ,(symbolicate '*smoke-module*)
+ ,type-name)))))))
+ ,@(loop for type-name in (ensure-list type-name) collect
+ `(define-to-lisp-translation
+ (,(format nil "const QList<~A>&" type-name)
+ ,(format nil "QList<~A>" type-name))
+ ,(symbolicate 'from-list- type-name)
+ ,(list-free type)))
+ ;; From Lisp
+ (defun ,(symbolicate 'coerce- lisp-type) (list)
+ (let ((qlist (,(list-make type))))
+ (loop for element across list do
+ (,(list-append type)
+ qlist (pointer (make-instance ',element-type :args (list element)))))
+ (make-cleanup-pointer
+ qlist
+ (function ,(list-free type)))))
+ (defun ,(symbolicate lisp-type '-p) (list)
+ (every #'(lambda (element)
+ ;(typep element ',element-type))
+ (typep element (find-class ',element-type)))
+ list))
+ ,@(loop for type-name in (ensure-list type-name) collect
+ `(define-from-lisp-translation (,(format nil "const QList<~A>&" type-name)
+ ,(format nil "QList<~A>" type-name))
+ ;; FIXME allow sequence
+ (and (vector );,element-type)
+ (satisfies ,(symbolicate lisp-type '-p)))
+ ,(symbolicate 'coerce- lisp-type)))))))))
-;; FIXME it would be nice to have QList<QVariant> as fallback for any
-;; list we can not convert otherwise. e.g.: '("a" 1)
(define-qlist-wrapper "QVariant" qt:variant)
-(define-qlist-wrapper ("QObject*" "QWidget*") qt:object "void")
(define-qlist-wrapper "QByteArray" qt:byte-array)
+
+(define-qlist-wrapper "QObject*" qt:object "void" :def-cfuns t)