darcs - smoke

2 ;;;

3 ;;; This program is free software: you can redistribute it and/or modify

4 ;;; it under the terms of the GNU General Public License as published by

5 ;;; the Free Software Foundation, either version 3 of the License, or

6 ;;; (at your option) any later version.

7 ;;;

8 ;;; This program is distributed in the hope that it will be useful,

9 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

10 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

11 ;;; GNU General Public License for more details.

12 ;;;

13 ;;; You should have received a copy of the GNU General Public License

14 ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.

15 ;;;

16 ;;; As a special exception, the copyright holders of this library give you

17 ;;; permission to link this library with independent modules to produce an

18 ;;; executable, regardless of the license terms of these independent

19 ;;; modules, and to copy and distribute the resulting executable under

20 ;;; terms of your choice, provided that you also meet, for each linked

21 ;;; independent module, the terms and conditions of the license of that

22 ;;; module. An independent module is a module which is not derived from or

23 ;;; based on this library. If you modify this library, you may extend this

24 ;;; exception to your version of the library, but you are not obligated to

25 ;;; do so. If you do not wish to do so, delete this exception statement

26 ;;; from your version.

28 (in-package #:smoke)

30 (declaim (inline call-s-method))

31 (defun call-s-method (method object-pointer stack-pointer)

32 (foreign-funcall-pointer

33 (foreign-slot-value (smoke-class-pointer (get-class method))

34 'smoke-class 'class-function)

35 ()

36 smoke-index (foreign-slot-value (smoke-method-pointer method)

37 'smoke-method 'method)

38 :pointer object-pointer

39 smoke-stack stack-pointer

40 :void))

42 (defun s-call (method object-pointer &optional (args nil))

43 (with-stack (stack args (arguments method) )

44 (call-s-method method object-pointer (call-stack-pointer stack))

45 (type-to-lisp (call-stack-pointer stack) (return-type method))))

47 (defun pointer-call (method object-pointer &optional (args nil))

48 (with-stack (stack args (arguments method) )

49 (call-s-method method object-pointer (call-stack-pointer stack))

50 (foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'class)))

52 (defun smoke-call (class pointer method-name &optional (args nil))

53 (s-call (make-smoke-method-from-name class method-name) pointer args))

55 (defun enum-call (method)

56 "Return the enum value for METHOD."

57 ;; FIXME:

58 ;;

59 ;; we could use static call, but QGraphicsEllipseItem::Type has

60 ;; wrongly QGraphicsGridLayout as return type. Smoke ignores case

61 ;; and confuses it with the member function type() ?? (27.2.09)

62 ;;

63 (assert (enum-p method))

64 (with-stack (stack nil nil)

65 (call-s-method method (null-pointer) (call-stack-pointer stack))

66 (foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'long)))

68 (defun delete-pointer (pointer class)

69 "Destructs the object at POINTER of type CLASS.

70 Calls the destructor and frees the memory."

71 (declare (optimize (speed 3)))

72 (let ((method-name (concatenate 'string "~" (constructor-name class))))

73 (s-call (make-smoke-method-from-name class method-name) pointer)))

75 (defun delete-object (object)

76 (delete-pointer (pointer object) (class-of object))

77 (setf (slot-value object 'pointer) (null-pointer)))

79 (eval-startup (:load-toplevel :execute)

80 (defparameter *binding* (smoke-construct-binding

81 (callback destructed)

82 (callback dispatch-method)))

83 (defparameter *no-dispatch-binding* (smoke-construct-binding

84 (callback destructed)

85 (null-pointer))))

87 (defun set-binding (object)

88 "Sets the Smoke binding for OBJECT, that receives its callbacks."

89 (declare (optimize (speed 3)))

90 (let ((class (class-of object)))

91 (with-foreign-object (stack 'smoke-stack-item 2)

92 (setf (foreign-slot-value (mem-aref stack 'smoke-stack-item 1)

93 'smoke-stack-item 'voidp)

94 (if (typep class 'cxx:class)

95 *binding*

96 *no-dispatch-binding*))

97 (foreign-funcall-pointer

98 (foreign-slot-value (smoke-class-pointer class)

99 'smoke-class 'class-function)

100 ()

101 smoke-index 0 ;; set binding method index

102 :pointer (pointer object)

103 smoke-stack stack

104 :void))))

105

106 (defun init (smoke module)

107 "Returns the a new Smoke binding for the Smoke module SMOKE."

108 (use-foreign-library libclsmoke)

109 (setf (smoke-module-pointer module) smoke)

110 (init-smoke-module module)

111 (setf (gethash (pointer-address smoke) *smoke-modules*) module)

112 module)

113

114 (let ((pointer-symbol-map (make-hash-table)))

115 ;; Used by make-load-form for enums to reference the smoke module.

116 (defun register-smoke-module-var (symbol)

117 "Registers SYMBOL of a variable containing a pointer to a Smoke module."

118 (setf (gethash (pointer-address (smoke-module-pointer (eval symbol)))

119 pointer-symbol-map)

120 symbol))

121 (defun get-smoke-variable-for-pointer (pointer)

122 "Returns the SYMBOL of the variable whose value is POINTER."

123 (gethash (pointer-address pointer) pointer-symbol-map)))

124

125 (defun call (object method-name &rest args)

126 (smoke-call (class-of object) (pointer object)

127 method-name args))

128

129 (defmethod documentation ((class smoke-standard-class) (doc-type (eql 't)))

130 (declare (optimize (speed 3)))

131 (format nil "~@[~A~%~]C++ name: ~A" (call-next-method) (name class)))

132

133 (defmethod documentation ((gf smoke-gf) (doc-type (eql 't)))

134 (declare (optimize (speed 3)))

135 (let ((methods (all-methods (name gf))))

136 (format nil "~@[~A~%~]~{~T~A~%~}"

137 (call-next-method)

138 (sort (mapcar #'method-declaration methods) #'string<=))))

139

140 (declaim (inline cstring=))

141 (defun cstring= (string1 string2)

142 "Returns T when the C strings STRING1 and STRING2 are equal

143 and NIL otherwise."

144 (zerop (strcmp string1 string2)))

145

146 (defun all-methods (name)

147 "Returns a list of all methods named NAME."

148 (declare (optimize (speed 3)))

149 (with-foreign-string (name name)

150 (let ((methods))

151 (maphash

152 #'(lambda (address module)

153 (declare (ignore address))

154 (map-methods #'(lambda (method)

155 (when (and (cstring= name (smoke-method-name method))

156 (not (enum-p method)))

157 (push (make-smoke-method

158 :id (smoke-method-id method)

159 :smoke (smoke-method-smoke method))

160 methods)))

161 module))

162 *smoke-modules*)

163 methods)))

164

165 (defun fgrep-methods (smoke str)

166 (map-methods #'(lambda (method)

167 (when (search str (name method))

168 (princ (method-declaration method))

169 (terpri)))

170 smoke))

171

172 (defmacro define-smoke-module (package library

173 (variable variable-name)

174 (init-function function-name))

175 "Define a Smoke module."

176 (let ((smoke-module (intern "*SMOKE-MODULE*")))

177 `(progn

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

179 (define-foreign-library ,library

180 (:darwin ,(format nil "~(~A~).3.dylib" library))

181 (:unix ,(format nil "~(~A~).so.3" library))

182 (t (:default ,(format nil "~(~A~)" library)))))

183 (eval-startup (:compile-toplevel :execute)

184 (load-foreign-library ',library))

185

186 (eval-startup (:compile-toplevel :execute)

187 (defcvar (,variable ,variable-name :read-only t :library ,library)

188 :pointer)

189 (defcfun (,init-function ,function-name :library ,library)

190 :void))

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

192 (defparameter ,smoke-module (make-smoke-module)))

193 (eval-startup (:compile-toplevel :execute)

194 (,init-function)

195 (init ,variable ,smoke-module)

196 (register-smoke-module-var ',smoke-module))

197 (define-classes-and-gfs ,package ,smoke-module))))

198

199 (defun fgrep-classes (smoke str)

200 (map-classes #'(lambda (class)

201 (when (search str (name class))

202 (format t "~A~%" (name class))))

203 smoke))

204

205 (defmacro define-takes-ownership (method lambda-list object)

206 "Declares METHOD transfers the ownership of OBJECT to the

207 first argument of LAMBDA-LIST."

208 `(defmethod ,method :before ,lambda-list

209 (declare (ignorable ,@(loop for arg in (rest lambda-list) collect

210 (if (consp arg)

211 (first arg)

212 arg))))

213 (transfer-ownership-to ,object ,(if (consp (first lambda-list))

214 (first (first lambda-list))

215 (first lambda-list)))))