darcs - qt.core

1 (in-package :cl-smoke.qt.core)

2

3 (defbitfield qlist-data-flags

4 :sharable)

5

6 (defcstruct qlist-data

7 (ref :char :count #.(class-size (find-class 'qt:basic-atomic-int)))

8 (alloc :int)

9 (begin :int)

10 (end :int)

11 (flags qlist-data-flags)

12 (array :pointer))

13

14 (defcstruct qlist

15 (data (:pointer qlist-data)))

16

17 (defun qlist-size (qlist)

18 (let ((data (foreign-slot-value qlist 'qlist 'data)))

19 (- (foreign-slot-value data 'qlist-data 'end)

20 (foreign-slot-value data 'qlist-data 'begin))))

21

22 (eval-when (:compile-toplevel :load-toplevel :execute)

23 (macrolet ((c-name (name)

24 `(nth-value 1 ,name))

25 (fun-names-let (name-pre-post-fixes &body body)

26 `(flet (,@(mapcar

27 #'(lambda (npp)

28 `(,(first npp) (type)

29 (values

30 (intern (string-upcase

31 (concatenate 'string

32 ,(second npp)

33 type

34 ,(third npp)))

35 ,*package*)

36 (concatenate 'string

37 (substitute #\_ #\-

38 ,(second npp))

39 type

40 (substitute #\_ #\-

41 ,(third npp))))))

42 name-pre-post-fixes))

43 ,@body)))

44 (fun-names-let ((list-free "cl-smoke-free-list-")

45 (list-make "cl-smoke-make-list-")

46 (list-at "cl-smoke-list-" "-at")

47 (list-append "cl-smoke-list-" "-append"))

48 (defmacro define-qlist-wrapper (type-name element-type &optional (c-name nil c-name-p)

49 &key def-cfuns)

50 (let* ((c-name (or c-name type-name))

51 (type c-name)

52 (lisp-type (symbolicate 'qlist- element-type)))

53 `(progn

54 ,(when (or (not c-name-p) def-cfuns)

55 `(progn

56 (defcfun ,(c-name (list-free type)) :void

57 "Frees LIST."

58 (list :pointer))

59 (defcfun ,(c-name (list-make type)) :pointer

60 "Makes a list.")

61 (defcfun ,(c-name (list-at type)) :pointer

62 "Returns the a newly constructed copy of the element at

63 position AT of LIST."

64 (list :pointer)

65 (index :int))

66 (defcfun ,(c-name (list-append type)) :pointer

67 "Appends NEW-ELEMENT to LIST."

68 (list :pointer)

69 (new-element :pointer))))

70 ;; To Lisp

71 ,@(loop for type-name in (ensure-list type-name) collect

72 `(defun ,(symbolicate 'from-list- type-name) (list-pointer)

73 (declare (optimize (speed 3)))

74 (let ((vector (make-array (qlist-size

75 list-pointer))))

76 (dotimes (index (length vector) vector)

77 (setf (elt vector index)

78 ;; FIXME the returned object is not wrapped by Smoke

79 ;; -> change this?

80 (object-to-lisp

81 (,(list-at type)

82 list-pointer index)

83 (make-smoke-type ,(symbolicate '*smoke-module*)

84 ,type-name)))))))

85 ,@(loop for type-name in (ensure-list type-name) collect

86 `(define-to-lisp-translation

87 (,(format nil "const QList<~A>&" type-name)

88 ,(format nil "QList<~A>" type-name))

89 ,(symbolicate 'from-list- type-name)

90 ,(list-free type)))

91 ;; From Lisp

92 (defun ,(symbolicate 'coerce- lisp-type) (list)

93 (let ((qlist (,(list-make type))))

94 (loop for element across list do

95 (,(list-append type)

96 qlist (pointer (make-instance ',element-type :args (list element)))))

97 (make-cleanup-pointer

98 qlist

99 (function ,(list-free type)))))

100 (defun ,(symbolicate lisp-type '-p) (list)

101 (every #'(lambda (element)

102 ;(typep element ',element-type))

103 (typep element (find-class ',element-type)))

104 list))

105 ,@(loop for type-name in (ensure-list type-name) collect

106 `(define-from-lisp-translation (,(format nil "const QList<~A>&" type-name)

107 ,(format nil "QList<~A>" type-name))

108 ;; FIXME allow sequence

109 (and (vector );,element-type)

110 (satisfies ,(symbolicate lisp-type '-p)))

111 ,(symbolicate 'coerce- lisp-type)))))))))

112

113 (define-qlist-wrapper "QVariant" qt:variant)

114

115 (define-qlist-wrapper "QByteArray" qt:byte-array)

116

117 (define-qlist-wrapper "QObject*" qt:object "void" :def-cfuns t)