darcs - smoke

1 (in-package #:smoke)

3 (declaim (inline %make-call-stack))

4 (defstruct (call-stack (:constructor %make-call-stack))

5 (pointer (null-pointer) :type foreign-pointer)

6 (top (null-pointer) :type foreign-pointer))

8 (defgeneric size (object))

9 (defmethod size ((stack call-stack))

10 "Returns the size (number of arguments) of STACK."

11 (/ (- (pointer-address (call-stack-top stack))

12 (pointer-address (call-stack-pointer stack)))

13 (foreign-type-size 'smoke-stack-item)))

15 (defun make-call-stack (smoke-stack)

16 (declare (type foreign-pointer smoke-stack)

17 (optimize (speed 3)))

18 (%make-call-stack

19 :pointer smoke-stack

20 :top (inc-pointer smoke-stack #.(foreign-type-size 'smoke-stack-item))))

22 (defun push-stack (stack value type)

23 (setf (foreign-slot-value (call-stack-top stack) 'smoke-stack-item type)

24 value)

25 (incf-pointer (call-stack-top stack) #.(foreign-type-size 'smoke-stack-item)))

27 (define-compiler-macro push-stack (&whole form stack value type)

28 (if (constantp type)

29 `(progn

30 (setf (foreign-slot-value (call-stack-top ,stack)

31 'smoke-stack-item ,type)

32 ,value)

33 (incf-pointer (call-stack-top ,stack)

34 ,(foreign-type-size 'smoke-stack-item)))

35 form))

37 (defclass smoke-standard-object ()

38 ((pointer :reader pointer

39 :type foreign-pointer

40 :initarg :pointer

41 :documentation "Pointer to the C++ object.")

42 (const-p :reader const-p

43 :initarg :const-p

44 :initform nil

45 :documentation "Returns true when the object is const and nil otherwise.")

46 #+clisp (finalizer :type list :initform (list nil))

47 ;; We can not have a global table of objects owned by C++,

48 ;; since then they would be always reachable from Lisp and thus

49 ;; cycles would never be garbage collected.

50 (owned-objects :accessor owned-objects

51 :initform nil

52 :type list

53 :documentation "Objects owned by the C++ instance."))

54 (:documentation "The standard superclass for Smoke classes."))

56 (defun push-smoke-stack (stack value type-id)

57 (declare (type (smoke-index 0) type-id)

58 (type call-stack stack)

59 (optimize (speed 3)))

60 (ecase type-id

61 (0 (push-stack stack value 'voidp))

62 (1 (push-stack stack value 'bool))

63 (2 (push-stack stack (char-code value) 'char))

64 (3 (push-stack stack value 'uchar))

65 (4 (push-stack stack value 'short))

66 (5 (push-stack stack value 'ushort))

67 (6 (push-stack stack value 'int))

68 (7 (push-stack stack value 'uint))

69 (8 (push-stack stack value 'long))

70 (9 (push-stack stack value 'ulong))

71 (10 (push-stack stack value 'float))

72 (11 (push-stack stack value 'double))

73 (12 (push-stack stack (value value) 'enum-value))

74 (13 (if (typep value 'smoke-standard-object)

75 ;; FIXME call pointer in overload resolution

76 (push-stack stack (pointer value) 'class)

77 (push-stack stack value 'class)))))

79 (defun set-smoke-stack (stack args arguments)

80 "Pushes the arguments ARGS onto the Smoke stack STACK."

81 (when (null args)

82 (assert (null arguments)

83 ()

84 "To few arguments supplied. Missing: ~A" arguments))

85 (unless (null args)

86 (assert (not (null arguments))

87 ()

88 "To many arguments supplied (Arguments ~A)." args)

89 (if (typep (first arguments) 'smoke-type)

90 (push-smoke-stack stack (first args) (type-id (first arguments)))

91 (push-stack stack (first args) 'class)) ;; Used for :qt lisp-object

92 (set-smoke-stack stack (rest args) (rest arguments))))

94 (defmacro with-stack ((stack args types) &body body)

95 (let ((smoke-stack (gensym "STACK")))

96 `(with-foreign-object (,smoke-stack 'smoke-stack-item (1+ (length ,args)))

97 (let ((,stack (make-call-stack ,smoke-stack)))

98 (set-smoke-stack ,stack ,args

99 ,types)

100 ,@body))))

101

102 (defvar *to-lisp-translations* (make-hash-table :test 'equal))

103

104 (defun enum-to-lisp (stack-item type)

105 "Returns the Lisp representation for STACK-ITEM of the basic C type TYPE."

106 (declare (optimize (speed 3)))

107 (ecase (type-id type)

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

109 (let ((pointer (foreign-slot-value stack-item 'smoke-stack-item

110 'voidp)))

111 (prog1 (funcall (car translation) pointer)

112 (when (stack-p type)

113 (funcall (cdr translation) pointer))))

114 (prog1 (foreign-slot-value stack-item 'smoke-stack-item 'voidp)

115 (cerror "Return the pointer"

116 "Missing type translator to convert the type ~A to Lisp."

117 type))))

118 (1 (foreign-slot-value stack-item 'smoke-stack-item 'bool))

119 (2 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'char)))

120 (3 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'uchar)))

121 (4 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'short)))

122 (5 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'ushort)))

123 (6 (foreign-slot-value stack-item 'smoke-stack-item 'int))

124 (7 (foreign-slot-value stack-item 'smoke-stack-item 'uint))

125 (8 (foreign-slot-value stack-item 'smoke-stack-item 'long))

126 (9 (foreign-slot-value stack-item 'smoke-stack-item 'ulong))

127 (10 (foreign-slot-value stack-item 'smoke-stack-item 'float))

128 (11 (foreign-slot-value stack-item 'smoke-stack-item 'double))

129 (12 (make-instance 'enum

130 :value (foreign-slot-value stack-item 'smoke-stack-item

131 'enum-value)

132 :type type))))

133

134 (defgeneric instance-to-lisp (pointer class type)

135 (declare (optimize (speed 3)))

136 (:documentation "Returns a CLOS instance for POINTER."))

137

138 (defun object-to-lisp (object type)

139 (declare (optimize (speed 3)))

140 (let ((class (get-class type)))

141 (if (has-pointer-p object)

142 (if (derived-p (class-of (get-object object))

143 (get-class type))

144 (get-object object)

145 (progn

146 (when (stack-p type)

147 ;; The first member varible of a class can have the

148 ;; same address as its object.

149 ;; e.g.: QSharedData::ref

150 (cerror "Remove the old object."

151 "The object at pointer ~A is ~A but should be a ~A."

152 object (get-object object) type)

153 (remove-object object))

154 (instance-to-lisp object (find-smoke-class class) type)))

155 (instance-to-lisp object (find-smoke-class class) type))))

156

157

158

159 (defun class-to-lisp (stack-item type)

160 "Returns the Lisp representation for STACK-ITEM of type C++ class."

161 (object-to-lisp (foreign-slot-value stack-item 'smoke-stack-item

162 'class)

163 type))

164

165 (defun type-to-lisp (stack-item type)

166 "Returns the Lisp representation of STACK-ITEM"

167 (declare (optimize (speed 3)))

168 (cond

169 ((void-p type) (values))

170 ((class-p type) (class-to-lisp stack-item type))

171 (t (enum-to-lisp stack-item type))))

172

173

174 (defun error-no-free (object)

175 (error "Can not free object at ~A." object))

176

177 (defmacro define-to-lisp-translation (type-names &optional

178 (conversion-function-name 'identity)

179 (free-function-name 'error-no-free))

180 `(progn ,@(loop for type-name in (ensure-list type-names)

181 collect `(setf (gethash ,type-name *to-lisp-translations*)

182 (cons ',conversion-function-name

183 ',free-function-name)))))

184

185 (defmacro define-pointer-typedef (type-names lisp-type)

186 (declare (ignore lisp-type))

187 `(progn

188 (define-to-lisp-translation ,type-names identity identity)))

189 ;; not needed

190 ;;(define-from-lisp-translation ,type-names ,lisp-type)))

191

192 (define-to-lisp-translation ("void*" "const void*" "void**"))

193

194 (define-to-lisp-translation ("char*" "const char*") foreign-string-to-lisp)