darcs - qt.core

1 ;; see: "Inside the Qt 4 Containers"

2 ;; http://doc.trolltech.com/qq/qq19-containers.html#sequentialcontainers

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

6 (defcfun cl-smoke-make-qvector :pointer)

7 (defcfun cl-smoke-delete-qvector :void

8 (vector :pointer))

10 (defbitfield qvector-data-flags

11 :sharable

12 :capacity)

14 (defcstruct qvector-data

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

16 (alloc :int)

17 (size :int)

18 (flags qvector-data-flags))

20 (defcstruct qvector-type-data

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

22 (alloc :int)

23 (size :int)

24 (flags qvector-data-flags)

25 (array :pointer))

27 ;; FIXME We assume QVector to be a POD struct, which is not

28 ;; neccesarily the case.

29 (defcstruct qvector

30 (data (:pointer qvector-data)))

32 (defun qvector-size (qvector)

33 (foreign-slot-value (foreign-slot-value qvector 'qvector 'data)

34 'qvector-data 'size))

36 (defun qvector-elt (qvector index element-type)

37 (pointer-to-lisp

38 (cffi:inc-pointer

39 (foreign-slot-pointer (foreign-slot-value qvector 'qvector 'data)

40 'qvector-type-data 'array)

41 (* index (type-size element-type)))

42 element-type))

44 (defun from-qvector (qvector element-type)

45 (let ((result (make-array (qvector-size qvector))))

46 (dotimes (i (length result) result)

47 (setf (elt result i)

48 (qvector-elt qvector i element-type)))))

50 (defcfun memcpy :pointer

51 (destination :pointer)

52 (source :pointer)

53 (size :unsigned-int))

55 (defun make-qvector (element-type elements)

56 (let* ((length (length elements))

57 (element-size (type-size element-type))

58 (data (foreign-alloc :char :count (+ (foreign-type-size 'qvector-data)

59 (* length element-size))))

60 (darray (foreign-slot-pointer data 'qvector-type-data 'array))

61 (vector (cl-smoke-make-qvector)))

62 (unless (stack-p element-type)

63 (error "FIXME: TODO"))

64 (if (class-p element-type)

65 (dotimes (i length)

66 (memcpy (inc-pointer darray (* i element-size))

67 (pointer (elt elements i))

68 element-size))

69 (dotimes (i length)

70 (setf (mem-aref darray (type-foreign-keyword element-type) i)

71 (elt elements i))))

72 (setf (mem-ref data :int) 1) ;; ref count

73 (with-foreign-slots ((ref alloc size flags)

74 data qvector-data)

75 (setf alloc length ;; allocated size

76 size length

77 flags :sharable)

78 (setf (foreign-slot-value vector 'qvector 'data)

79 data))

80 vector))

82 (defun deref (basic-atomic-int-pointer)

83 ;; decrement and return true when the new value is non-zero

84 (cxx:deref

85 (make-instance 'qt:basic-atomic-int :pointer basic-atomic-int-pointer)))

87 (defun free-qvector (vector)

88 (unless (null-pointer-p (foreign-slot-value vector 'qvector 'data))

89 (let ((data (foreign-slot-value vector 'qvector 'data)))

90 (unless (deref (foreign-slot-pointer data 'qvector-type-data 'ref))

91 (foreign-free data)))

92 (setf (foreign-slot-value vector 'qvector 'data)

93 (null-pointer)))

94 (cl-smoke-delete-qvector vector))

96 (defmacro define-qvector-translations (element-type lisp-type)

97 `(progn

98 (defun ,(symbolicate 'from-vector- element-type) (elements)

99 (make-cleanup-pointer

100 (make-qvector (make-smoke-type *smoke-module* ,element-type)

101 elements)

102 #'free-qvector))

103 (defun ,(symbolicate 'vector- element-type '-p) (sequence)

104 (every #'(lambda (element)

105 (typep element ',lisp-type))

106 sequence))

107 (defun ,(symbolicate 'to-vector- element-type) (pointer)

108 (from-qvector pointer (make-smoke-type *smoke-module* ,element-type)))

109 (define-from-lisp-translation (,(format nil "QVector<~A>" element-type)

110 ;; FIXME QImage::setColorTable

111 ;; has an "const QVector<QRgb>"

112 ;; argument!

113 ,(format nil "const QVector<~A>" element-type)

114 ,(format nil "const QVector<~A>&" element-type))

115 (and vector

116 (satisfies ,(symbolicate 'vector- element-type '-p)))

117 ,(symbolicate 'from-vector- element-type))

118 (define-to-lisp-translation (,(format nil "QVector<~A>" element-type)

119 ,(format nil "const QVector<~A>&" element-type))

120 ,(symbolicate 'to-vector- element-type)

121 free-qvector)))

122

123 (define-qvector-translations "double" double-float)