repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
class & type size (and some more exports)
Annotate for file src/smoke-to-clos.lisp
2009-04-05 tobias
1
(in-package :smoke)
15:36:29 '
2
2009-06-11 tobias
3
(defun constant-definition (package method smoke)
2009-04-05 tobias
4
"Returns an expression that defines a constant for the enum METHOD.
15:36:29 '
5
The second return value is the expression to export the constant."
'
6
(let ((symbol
2009-09-09 tobias
7
(if (or (string= (name (get-class method))
13:22:32 '
8
"Qt")
'
9
(string= (name (get-class method))
'
10
"QGlobalSpace"))
2009-04-05 tobias
11
(lispify (concatenate 'string "+" (name method)
2009-06-11 tobias
12
"+")
2009-08-30 tobias
13
package)
2009-04-05 tobias
14
(lispify (concatenate 'string
15:36:29 '
15
(name (get-class method))
'
16
".+"
2009-06-11 tobias
17
(name method) "+")
2009-08-30 tobias
18
package))))
2009-04-05 tobias
19
(values
2009-08-30 tobias
20
(if (= 8 (type-id (return-type method)))
2010-01-10 tobias
21
`(define-constant ,symbol ;; a long, not really an enum.
2009-08-30 tobias
22
,(enum-call method))
13:51:40 '
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=))
2009-05-14 tobias
30
symbol)))
2009-04-05 tobias
31
2009-06-11 tobias
32
(defun static-method-symbol (package method)
2009-04-05 tobias
33
"Returns the lisp symbol for the static method METHOD."
15:36:29 '
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
"."))
2009-06-11 tobias
42
(name method))
14:35:40 '
43
package)))
2009-04-05 tobias
44
2009-06-11 tobias
45
(defun static-method-definition (package method &optional (argument-count -1))
2009-04-05 tobias
46
"Returns an expression to define a function for the static METHOD.
15:36:29 '
47
The second return value is the expression to export the function."
'
48
(let* ((class (get-class method))
'
49
(method-name (name method))
2009-06-11 tobias
50
(name (static-method-symbol package method)))
2009-04-05 tobias
51
(values
2009-05-11 tobias
52
`(defun ,name ,(if (< argument-count 0)
20:18:23 '
53
'(&rest args)
'
54
(make-lambda argument-count))
2010-01-10 tobias
55
(call-using-args
08:49:36 '
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)))))
2009-05-14 tobias
65
name)))
2009-04-05 tobias
66
2009-05-19 tobias
67
(defun ensure-generic-methods (symbols-names)
11:09:12 '
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)
2009-04-12 tobias
74
:generic-function-class 'smoke-gf
14:43:33 '
75
:lambda-list '(object &rest args))
2009-05-19 tobias
76
(export (first symbol-name) :cxx)))
11:09:12 '
77
2009-05-11 tobias
78
(defun setf-method-definition (method)
17:55:42 '
79
`(defun (setf ,(lispify (subseq (name method) 3) :cxx)) (new-value object)
'
80
(,(lispify (name method) :cxx) object new-value)
'
81
new-value))
'
82
2009-06-22 tobias
83
(defmacro sizes= ((smoke)&rest arrays)
12:18:08 '
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
2009-04-05 tobias
89
(defmacro check-recompile (smoke)
2010-01-10 tobias
90
"Raises an error or tries to recompile when the fasl of the define-classes-and-gfs
17:30:48 '
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)))))))))
2009-04-05 tobias
105
2009-06-11 tobias
106
(defmacro define-classes-and-gfs (package smoke)
2009-04-05 tobias
107
"Process the C++ methods of the Smoke module SMOKE.
15:36:29 '
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
2009-07-01 tobias
111
;;; multiple definition of a function with the same name.
2009-04-05 tobias
112
(let ((generics (make-hash-table))
15:36:29 '
113
(constants)
'
114
(functions)
'
115
(function-symbols (make-hash-table))
2009-05-11 tobias
116
(setf-function-symbols (make-hash-table))
2009-04-05 tobias
117
(exports))
15:36:29 '
118
(map-methods
'
119
#'(lambda (method)
2010-01-10 tobias
120
(when (and (enum-p method)
08:49:36 '
121
;; qt.network has QIODevice::NotOpen(), but the
'
122
;; class is external (workaround).
'
123
(not (external-p (get-class method))))
2009-06-11 tobias
124
(multiple-value-bind (def export) (constant-definition package method smoke)
2009-04-05 tobias
125
(push def
15:36:29 '
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)))
2009-07-01 tobias
132
(string/= (name method) "tr")) ;; we have a custom qt:tr function
2009-05-11 tobias
133
(let ((name (name method)))
17:55:42 '
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)))
2010-04-03 tobias
141
(setf (gethash (lispify name "CXX") generics)
12:03:07 '
142
name))
2009-04-05 tobias
143
(when (static-p method)
2009-06-11 tobias
144
(let* ((function-symbol (static-method-symbol package method))
2009-05-11 tobias
145
(methods (gethash function-symbol function-symbols)))
2010-01-10 tobias
146
(unless (fboundp function-symbol) ;; do not overwrite
08:49:36 '
147
;; existing functions e.g. qInstallMsgHandler of
'
148
;; qt.core with that of qt.gui which causes a
'
149
;; segfault when loading from an saved image.
'
150
(setf (gethash function-symbol function-symbols)
'
151
(if methods (- (id method)) (id method))))))))
2009-04-05 tobias
152
(eval smoke))
2009-05-11 tobias
153
(loop for id being the hash-values of function-symbols do
2009-06-22 tobias
154
(let ((method (make-smoke-method
12:18:08 '
155
:smoke (eval smoke)
'
156
:id (abs id))))
2009-05-11 tobias
157
(multiple-value-bind (definition export)
20:18:23 '
158
(static-method-definition
2009-06-11 tobias
159
package
2009-05-11 tobias
160
method
20:18:23 '
161
(if (< 0 id)
'
162
(get-arguments-length method)
'
163
-1))
'
164
(push definition functions)
'
165
(push export exports))))
2009-04-05 tobias
166
`(progn (check-recompile ,smoke)
15:36:29 '
167
,@functions
2010-01-17 tobias
168
(eval-startup (:compile-toplevel :load-toplevel :execute)
2010-01-23 tobias
169
;; FIXME when loading the Lisp image we no longer need
19:45:41 '
170
;; to call #'ensure-class, but the class-map needs still
2010-01-17 tobias
171
;; to be populated by #'add-id-class-map and #'add-id;
21:04:08 '
172
;; For now we ignore the negligible overhead.
'
173
(make-smoke-classes ,package ,smoke))
2009-07-08 tobias
174
(eval-when (:load-toplevel :execute)
2009-05-19 tobias
175
(ensure-generic-methods ',(hash-table-alist generics)))
2009-04-05 tobias
176
,@constants
2009-05-19 tobias
177
(eval-when (:load-toplevel :execute)
2009-06-11 tobias
178
(export (quote ,exports) ,package)))))
2009-04-05 tobias
179