darcs - smoke

1 (in-package :smoke)

2

3 (defun constant-definition (package method smoke)

4 "Returns an expression that defines a constant for the enum METHOD.

5 The second return value is the expression to export the constant."

6 (let ((symbol

7 (if (or (string= (name (get-class method))

8 "Qt")

9 (string= (name (get-class method))

10 "QGlobalSpace"))

11 (lispify (concatenate 'string "+" (name method)

12 "+")

13 package)

14 (lispify (concatenate 'string

15 (name (get-class method))

16 ".+"

17 (name method) "+")

18 package))))

19 (values

20 (if (= 8 (type-id (return-type method)))

21 `(define-constant ,symbol ;; a long, not really an enum.

22 ,(enum-call method))

23 `(define-constant ,symbol

24 (make-instance 'enum

25 :value ,(enum-call method)

26 :type (make-instance 'smoke-type

27 :id ,(id (return-type method))

28 :smoke ,smoke))

29 :test #'enum=))

30 symbol)))

31

32 (defun static-method-symbol (package method)

33 "Returns the lisp symbol for the static method METHOD."

34 (let ((class (get-class method)))

35 (lispify (concatenate 'string

36 (if (string= (name class)

37 "QGlobalSpace")

38 nil

39 (concatenate 'string

40 (name class)

41 "."))

42 (name method))

43 package)))

44

45 (defun static-method-definition (package method &optional (argument-count -1))

46 "Returns an expression to define a function for the static METHOD.

47 The second return value is the expression to export the function."

48 (let* ((class (get-class method))

49 (method-name (name method))

50 (name (static-method-symbol package method)))

51 (values

52 `(defun ,name ,(if (< argument-count 0)

53 '(&rest args)

54 (make-lambda argument-count))

55 (call-using-args

56 (find-class (quote ,(lispify (name class)

57 (if (string= (name class)

58 "QGlobalSpace")

59 *package* ;; See #'MAKE-SMOKE-CLASSES

60 package))))

61 ,method-name

62 ,(if (< argument-count 0)

63 'args

64 `(list ,@(make-lambda argument-count)))))

65 name)))

66

67 (defun ensure-generic-methods (symbols-names)

68 "Ensures the generic functions for SYMBOLS-NAMES."

69 (declare (list symbols-names)

70 (optimize (speed 3)))

71 (dolist (symbol-name symbols-names)

72 (ensure-generic-function (first symbol-name)

73 :cxx-name (rest symbol-name)

74 :generic-function-class 'smoke-gf

75 :lambda-list '(object &rest args))

76 (export (first symbol-name) :cxx)))

77

78 (defun setf-method-definition (method)

79 `(defun (setf ,(lispify (subseq (name method) 3) :cxx)) (new-value object)

80 (,(lispify (name method) :cxx) object new-value)

81 new-value))

82

83 (defmacro sizes= ((smoke)&rest arrays)

84 `(and ,@(loop for array in arrays collect

85 `(= (smoke-array-length (,array ,smoke))

86 ,(smoke-array-length (funcall (fdefinition array)

87 (eval smoke)))))))

88

89 (defmacro check-recompile (smoke)

90 "Raises an error or tries to recompile when the fasl of the define-classes-and-gfs

91 was not compiled against the current smoke module."

92 (with-unique-names (restart)

93 `(eval-when (:load-toplevel :execute)

94 (unless (sizes= (,smoke)

95 smoke-module-methods

96 smoke-module-method-names

97 smoke-module-method-maps

98 smoke-module-classes

99 smoke-module-types)

100 (let ((,restart (find-restart 'asdf:try-recompiling)))

101 (if ,restart

102 (invoke-restart ,restart)

103 (error "The smoke module ~A changed, you need to recompile the lisp file."

104 (smoke-get-module-name (smoke-module-pointer ,smoke)))))))))

105

106 (defmacro define-classes-and-gfs (package smoke)

107 "Process the C++ methods of the Smoke module SMOKE.

108 Expands to DEFUNs for static methods, DEFINE-CONSTANTs for enum methods

109 and a function do define the generic methods a load-time."

110 ;;; symbol - id pairs are stored in the hash-tables to prevent the

111 ;;; multiple definition of a function with the same name.

112 (let ((generics (make-hash-table))

113 (constants)

114 (functions)

115 (function-symbols (make-hash-table))

116 (setf-function-symbols (make-hash-table))

117 (exports))

118 (map-methods

119 #'(lambda (method)

120 (when (and (enum-p method)

121 ;; qt.network has QIODevice::NotOpen(), but the

122 ;; class is external (workaround).

123 (not (external-p (get-class method))))

124 (multiple-value-bind (def export) (constant-definition package method smoke)

125 (push def

126 constants)

127 (push export exports)))

128 (when (and (not (destructor-p method))

129 (not (constructor-p method))

130 (not (enum-p method))

131 (not (eql nil (name method)))

132 (string/= (name method) "tr")) ;; we have a custom qt:tr function

133 (let ((name (name method)))

134 (when (and (starts-with-subseq "set" name)

135 (> (length name) 3)

136 (upper-case-p (char name 3))

137 (= 1 (get-arguments-length method)))

138 (unless (nth-value 1 (gethash (lispify name :cxx) setf-function-symbols))

139 (setf (gethash (lispify name :cxx) setf-function-symbols) t)

140 (push (setf-method-definition method) functions)))

141 (let ((lisp-name (lispify name "CXX")))

142 (unless (and (gethash lisp-name generics) (attribute-p method))

143 (setf (gethash lisp-name generics) name))))

144 (when (static-p method)

145 (let* ((function-symbol (static-method-symbol package method))

146 (methods (gethash function-symbol function-symbols)))

147 (unless (fboundp function-symbol) ;; do not overwrite

148 ;; existing functions e.g. qInstallMsgHandler of

149 ;; qt.core with that of qt.gui which causes a

150 ;; segfault when loading from an saved image.

151 (setf (gethash function-symbol function-symbols)

152 (if methods (- (id method)) (id method))))))))

153 (eval smoke))

154 (loop for id being the hash-values of function-symbols do

155 (let ((method (make-smoke-method

156 :smoke (eval smoke)

157 :id (abs id))))

158 (multiple-value-bind (definition export)

159 (static-method-definition

160 package

161 method

162 (if (< 0 id)

163 (get-arguments-length method)

164 -1))

165 (push definition functions)

166 (push export exports))))

167 `(progn (check-recompile ,smoke)

168 ,@functions

169 (eval-startup (:compile-toplevel :load-toplevel :execute)

170 ;; FIXME when loading the Lisp image we no longer need

171 ;; to call #'ensure-class, but the class-map needs still

172 ;; to be populated by #'add-id-class-map and #'add-id;

173 ;; For now we ignore the negligible overhead.

174 (make-smoke-classes ,package ,smoke))

175 (eval-when (:load-toplevel :execute)

176 (ensure-generic-methods ',(hash-table-alist generics)))

177 ,@constants

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

179 (export (quote ,exports) ,package)))))

180