repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Make integer constants return an integer instead of an enum (e,g.: qt:graphics-item.+user-type+).
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 (string= (name (get-class method))
13:22:32 '
8
"Qt")
2009-04-05 tobias
9
(lispify (concatenate 'string "+" (name method)
2009-06-11 tobias
10
"+")
2009-08-30 tobias
11
package)
2009-04-05 tobias
12
(lispify (concatenate 'string
15:36:29 '
13
(name (get-class method))
'
14
".+"
2009-06-11 tobias
15
(name method) "+")
2009-08-30 tobias
16
package))))
2009-04-05 tobias
17
(values
2009-08-30 tobias
18
(if (= 8 (type-id (return-type method)))
13:51:40 '
19
`(define-constant ,symbol ;; a long not really an enum.
'
20
,(enum-call method))
'
21
`(define-constant ,symbol
'
22
(make-instance 'enum
'
23
:value ,(enum-call method)
'
24
:type (make-instance 'smoke-type
'
25
:id ,(id (return-type method))
'
26
:smoke ,smoke))
'
27
:test #'enum=))
2009-05-14 tobias
28
symbol)))
2009-04-05 tobias
29
2009-06-11 tobias
30
(defun static-method-symbol (package method)
2009-04-05 tobias
31
"Returns the lisp symbol for the static method METHOD."
15:36:29 '
32
(let ((class (get-class method)))
'
33
(lispify (concatenate 'string
'
34
(if (string= (name class)
'
35
"QGlobalSpace")
'
36
nil
'
37
(concatenate 'string
'
38
(name class)
'
39
"."))
2009-06-11 tobias
40
(name method))
14:35:40 '
41
package)))
2009-04-05 tobias
42
2009-06-11 tobias
43
(defun static-method-definition (package method &optional (argument-count -1))
2009-04-05 tobias
44
"Returns an expression to define a function for the static METHOD.
15:36:29 '
45
The second return value is the expression to export the function."
'
46
(let* ((class (get-class method))
'
47
(method-name (name method))
2009-06-11 tobias
48
(name (static-method-symbol package method)))
2009-04-05 tobias
49
(values
2009-05-11 tobias
50
`(defun ,name ,(if (< argument-count 0)
20:18:23 '
51
'(&rest args)
'
52
(make-lambda argument-count))
2010-01-10 tobias
53
(call-using-args (find-class (quote ,(lispify (name class) package)))
08:49:36 '
54
,method-name
'
55
,(if (< argument-count 0)
'
56
'args
'
57
`(list ,@(make-lambda argument-count)))))
2009-05-14 tobias
58
name)))
2009-04-05 tobias
59
2009-05-19 tobias
60
(defun ensure-generic-methods (symbols-names)
11:09:12 '
61
"Ensures the generic functions for SYMBOLS-NAMES."
'
62
(declare (list symbols-names)
'
63
(optimize (speed 3)))
'
64
(dolist (symbol-name symbols-names)
'
65
(ensure-generic-function (first symbol-name)
'
66
:cxx-name (rest symbol-name)
2009-04-12 tobias
67
:generic-function-class 'smoke-gf
14:43:33 '
68
:lambda-list '(object &rest args))
2009-05-19 tobias
69
(export (first symbol-name) :cxx)))
11:09:12 '
70
2009-05-11 tobias
71
(defun setf-method-definition (method)
17:55:42 '
72
`(defun (setf ,(lispify (subseq (name method) 3) :cxx)) (new-value object)
'
73
(,(lispify (name method) :cxx) object new-value)
'
74
new-value))
'
75
2009-06-22 tobias
76
(defmacro sizes= ((smoke)&rest arrays)
12:18:08 '
77
`(and ,@(loop for array in arrays collect
'
78
`(= (smoke-array-length (,array ,smoke))
'
79
,(smoke-array-length (funcall (fdefinition array)
'
80
(eval smoke)))))))
'
81
2009-04-05 tobias
82
(defmacro check-recompile (smoke)
2010-01-10 tobias
83
"Raises an error when the fasl of the DEFINE-METHOS was not compiled against
17:30:48 '
84
the current smoke module."
'
85
`(eval-when (:load-toplevel :execute)
'
86
(unless (sizes= (,smoke)
'
87
smoke-module-methods
'
88
smoke-module-method-names
'
89
smoke-module-method-maps
'
90
smoke-module-classes
'
91
smoke-module-types)
'
92
(error "The smoke module ~A changed, you need to recompile the lisp file."
'
93
(smoke-get-module-name (smoke-module-pointer ,smoke))))))
2009-04-05 tobias
94
2009-06-11 tobias
95
(defmacro define-classes-and-gfs (package smoke)
2009-04-05 tobias
96
"Process the C++ methods of the Smoke module SMOKE.
15:36:29 '
97
Expands to DEFUNs for static methods, DEFINE-CONSTANTs for enum methods
'
98
and a function do define the generic methods a load-time."
'
99
;;; symbol - id pairs are stored in the hash-tables to prevent the
2009-07-01 tobias
100
;;; multiple definition of a function with the same name.
2009-04-05 tobias
101
(let ((generics (make-hash-table))
15:36:29 '
102
(constants)
'
103
(functions)
'
104
(function-symbols (make-hash-table))
2009-05-11 tobias
105
(setf-function-symbols (make-hash-table))
2009-04-05 tobias
106
(exports))
15:36:29 '
107
(map-methods
'
108
#'(lambda (method)
2010-01-10 tobias
109
(when (enum-p method)
2009-06-11 tobias
110
(multiple-value-bind (def export) (constant-definition package method smoke)
2009-04-05 tobias
111
(push def
15:36:29 '
112
constants)
'
113
(push export exports)))
'
114
(when (and (not (destructor-p method))
'
115
(not (constructor-p method))
'
116
(not (enum-p method))
'
117
(not (eql nil (name method)))
2009-07-01 tobias
118
(string/= (name method) "tr")) ;; we have a custom qt:tr function
2009-05-11 tobias
119
(let ((name (name method)))
17:55:42 '
120
(when (and (starts-with-subseq "set" name)
'
121
(> (length name) 3)
'
122
(upper-case-p (char name 3))
'
123
(= 1 (get-arguments-length method)))
'
124
(unless (nth-value 1 (gethash (lispify name :cxx) setf-function-symbols))
'
125
(setf (gethash (lispify name :cxx) setf-function-symbols) t)
'
126
(push (setf-method-definition method) functions)))
2010-04-03 tobias
127
(setf (gethash (lispify name "CXX") generics)
12:03:07 '
128
name))
2009-04-05 tobias
129
(when (static-p method)
2009-06-11 tobias
130
(let* ((function-symbol (static-method-symbol package method))
2009-05-11 tobias
131
(methods (gethash function-symbol function-symbols)))
2010-01-10 tobias
132
(setf (gethash function-symbol function-symbols)
08:49:36 '
133
(if methods (- (id method)) (id method)))))))
2009-04-05 tobias
134
(eval smoke))
2009-05-11 tobias
135
(loop for id being the hash-values of function-symbols do
2009-06-22 tobias
136
(let ((method (make-smoke-method
12:18:08 '
137
:smoke (eval smoke)
'
138
:id (abs id))))
2009-05-11 tobias
139
(multiple-value-bind (definition export)
20:18:23 '
140
(static-method-definition
2009-06-11 tobias
141
package
2009-05-11 tobias
142
method
20:18:23 '
143
(if (< 0 id)
'
144
(get-arguments-length method)
'
145
-1))
'
146
(push definition functions)
'
147
(push export exports))))
2009-04-05 tobias
148
`(progn (check-recompile ,smoke)
15:36:29 '
149
,@functions
2010-01-10 tobias
150
(eval-startup (:load-toplevel :execute)
08:49:36 '
151
;; eval on startup for class map.
'
152
(make-smoke-classes ,package ,smoke))
2009-07-08 tobias
153
(eval-when (:load-toplevel :execute)
2009-05-19 tobias
154
(ensure-generic-methods ',(hash-table-alist generics)))
2009-04-05 tobias
155
,@constants
2009-05-19 tobias
156
(eval-when (:load-toplevel :execute)
2009-06-11 tobias
157
(export (quote ,exports) ,package)))))
2009-04-05 tobias
158