repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Use strcmp, fix constructor & destrucor calling for classes witn namespace (phonon::MediaPlayer) and add :arg0 to :arg2 initargs
Annotate for file src/objects/stack.lisp
2009-04-05 tobias
1
(in-package #:smoke)
15:36:29 '
2
2009-07-08 tobias
3
(declaim (inline %make-call-stack))
20:41:19 '
4
(defstruct (call-stack (:constructor %make-call-stack))
'
5
(pointer (null-pointer) :type foreign-pointer)
'
6
(top (null-pointer) :type foreign-pointer))
2009-04-05 tobias
7
2009-05-27 tobias
8
(defgeneric size (object))
2009-04-05 tobias
9
(defmethod size ((stack call-stack))
15:36:29 '
10
"Returns the size (number of arguments) of STACK."
2009-07-22 tobias
11
(/ (- (pointer-address (call-stack-top stack))
22:26:05 '
12
(pointer-address (call-stack-pointer stack)))
'
13
(foreign-type-size 'smoke-stack-item)))
2009-04-05 tobias
14
15:36:29 '
15
(defun make-call-stack (smoke-stack)
2009-07-08 tobias
16
(declare (type foreign-pointer smoke-stack)
20:41:19 '
17
(optimize (speed 3)))
'
18
(%make-call-stack
'
19
:pointer smoke-stack
2009-08-02 tobias
20
:top (inc-pointer smoke-stack
10:12:41 '
21
#.(foreign-type-size 'smoke-stack-item))))
2009-04-05 tobias
22
15:36:29 '
23
(defun push-stack (stack value type)
2009-08-02 tobias
24
(setf (foreign-slot-value (call-stack-top stack)
10:12:41 '
25
'smoke-stack-item type) value)
2009-07-08 tobias
26
(incf-pointer (call-stack-top stack) #.(foreign-type-size 'smoke-stack-item)))
2009-06-22 tobias
27
12:18:08 '
28
(define-compiler-macro push-stack (&whole form stack value type)
'
29
(if (constantp type)
'
30
`(progn
2009-07-08 tobias
31
(setf (foreign-slot-value (call-stack-top ,stack)
2009-08-02 tobias
32
'smoke-stack-item ,type) ,value)
2009-07-08 tobias
33
(incf-pointer (call-stack-top ,stack)
20:41:19 '
34
,(foreign-type-size 'smoke-stack-item)))
2009-06-22 tobias
35
form))
2009-08-27 tobias
36
2009-06-12 tobias
37
12:21:44 '
38
(defclass smoke-standard-object ()
'
39
((pointer :reader pointer
2009-07-08 tobias
40
:type foreign-pointer
2009-06-12 tobias
41
:initarg :pointer
12:21:44 '
42
:documentation "Pointer to the C++ object.")
2009-06-30 tobias
43
#+clisp (finalizer :type list :initform (list nil))
2009-06-12 tobias
44
;; We can not have a global table of objects owned by C++,
2009-07-01 tobias
45
;; since then they would be always reachable from Lisp and thus
2009-06-12 tobias
46
;; cycles would never be garbage collected.
12:21:44 '
47
(owned-objects :accessor owned-objects
'
48
:initform nil
'
49
:type list
2009-07-01 tobias
50
:documentation "Objects owned by the C++ instance."))
2009-06-12 tobias
51
(:documentation "The standard superclass for Smoke classes."))
2009-04-05 tobias
52
2009-05-26 tobias
53
(defun push-smoke-stack (stack value type-id)
2009-06-22 tobias
54
(declare (type (smoke-index 0) type-id)
12:18:08 '
55
(type call-stack stack)
'
56
(optimize (speed 3)))
2009-04-05 tobias
57
(ecase type-id
15:36:29 '
58
(0 (push-stack stack value 'voidp))
'
59
(1 (push-stack stack value 'bool))
2009-04-12 tobias
60
(2 (push-stack stack (char-code value) 'char))
2009-04-05 tobias
61
(3 (push-stack stack value 'uchar))
15:36:29 '
62
(4 (push-stack stack value 'short))
'
63
(5 (push-stack stack value 'ushort))
'
64
(6 (push-stack stack value 'int))
'
65
(7 (push-stack stack value 'uint))
'
66
(8 (push-stack stack value 'long))
'
67
(9 (push-stack stack value 'ulong))
'
68
(10 (push-stack stack value 'float))
'
69
(11 (push-stack stack value 'double))
'
70
(12 (push-stack stack (value value) 'enum-value))
2009-05-26 tobias
71
(13 (if (typep value 'smoke-standard-object)
09:54:47 '
72
;; FIXME call pointer in overload resolution
'
73
(push-stack stack (pointer value) 'class)
'
74
(push-stack stack value 'class)))))
2009-04-05 tobias
75
15:36:29 '
76
(defun set-smoke-stack (stack args arguments)
'
77
"Pushes the arguments ARGS onto the Smoke stack STACK."
'
78
(when (null args)
'
79
(assert (null arguments)
'
80
()
'
81
"To few arguments supplied. Missing: ~A" arguments))
'
82
(unless (null args)
'
83
(assert (not (null arguments))
'
84
()
2009-07-01 tobias
85
"To many arguments supplied (Arguments ~A)." args)
2009-05-26 tobias
86
(if (typep (first arguments) 'smoke-type)
09:54:47 '
87
(push-smoke-stack stack (first args) (type-id (first arguments)))
'
88
(push-stack stack (first args) 'class)) ;; Used for :qt lisp-object
'
89
(set-smoke-stack stack (rest args) (rest arguments))))
2009-04-05 tobias
90
15:36:29 '
91
(defmacro with-stack ((stack args types) &body body)
'
92
(let ((smoke-stack (gensym "STACK")))
'
93
`(with-foreign-object (,smoke-stack 'smoke-stack-item (1+ (length ,args)))
'
94
(let ((,stack (make-call-stack ,smoke-stack)))
'
95
(set-smoke-stack ,stack ,args
'
96
,types)
2009-05-26 tobias
97
,@body))))
2009-04-05 tobias
98
15:36:29 '
99
(defun enum-to-lisp (stack-item type)
'
100
"Returns the Lisp representation for STACK-ITEM of the basic C type TYPE."
2009-06-22 tobias
101
(declare (optimize (speed 3)))
2009-04-05 tobias
102
(ecase (type-id type)
2009-08-02 tobias
103
(0 (let ((cffi-type (get-type (name type))))
10:12:41 '
104
(if (null cffi-type)
'
105
(progn
'
106
;; FIXME warn but not on void**
'
107
;;(warn "Unknown translation from ~A to lisp." (name type))
'
108
(foreign-slot-value stack-item 'smoke-stack-item 'voidp))
'
109
(let* ((pointer (foreign-slot-value stack-item
'
110
'smoke-stack-item
'
111
'voidp))
'
112
(value (convert-from-foreign pointer cffi-type)))
'
113
(when (stack-p type)
'
114
;; FIXME free-translated-object is not intended for this;
'
115
;; param is NIL for now.
'
116
(cffi:free-translated-object pointer cffi-type nil))
'
117
value
'
118
))))
2009-04-05 tobias
119
(1 (foreign-slot-value stack-item 'smoke-stack-item 'bool))
15:36:29 '
120
(2 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'char)))
'
121
(3 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'uchar)))
'
122
(4 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'short)))
'
123
(5 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'ushort)))
'
124
(6 (foreign-slot-value stack-item 'smoke-stack-item 'int))
'
125
(7 (foreign-slot-value stack-item 'smoke-stack-item 'uint))
'
126
(8 (foreign-slot-value stack-item 'smoke-stack-item 'long))
'
127
(9 (foreign-slot-value stack-item 'smoke-stack-item 'ulong))
'
128
(10 (foreign-slot-value stack-item 'smoke-stack-item 'float))
'
129
(11 (foreign-slot-value stack-item 'smoke-stack-item 'double))
'
130
(12 (make-instance 'enum
2009-08-02 tobias
131
:value (foreign-slot-value stack-item 'smoke-stack-item 'enum-value)
2009-04-05 tobias
132
:type type))))
15:36:29 '
133
'
134
(defgeneric instance-to-lisp (pointer class type)
2009-06-22 tobias
135
(declare (optimize (speed 3)))
2009-07-01 tobias
136
(:documentation "Returns a CLOS instance for POINTER."))
2009-04-05 tobias
137
15:36:29 '
138
(defun object-to-lisp (object type)
2009-06-22 tobias
139
(declare (optimize (speed 3)))
2009-08-02 tobias
140
(if (class-p type)
10:12:41 '
141
(let ((class (get-class type)))
'
142
(if (has-pointer-p object)
2009-04-05 tobias
143
(get-object object)
2009-08-02 tobias
144
(instance-to-lisp object (find-smoke-class class) type)))
10:12:41 '
145
nil))
2009-04-05 tobias
146
15:36:29 '
147
'
148
'
149
(defun class-to-lisp (stack-item type)
'
150
"Returns the Lisp representation for STACK-ITEM of type C++ class."
2009-08-02 tobias
151
(object-to-lisp (foreign-slot-value stack-item
10:12:41 '
152
'smoke-stack-item
2009-06-22 tobias
153
'class)
12:18:08 '
154
type))
2009-04-05 tobias
155
15:36:29 '
156
(defun type-to-lisp (stack-item type)
'
157
"Returns the Lisp representation of STACK-ITEM"
2009-06-22 tobias
158
(declare (optimize (speed 3)))
2009-04-05 tobias
159
(cond
2009-08-02 tobias
160
((void-p type)
10:12:41 '
161
(values))
'
162
((class-p type)
'
163
(class-to-lisp stack-item type))
'
164
(t
'
165
(enum-to-lisp stack-item type))))