112ac1d3 |
1 | ;; Common Lisp bindings for GTK+ 2.x |
2 | ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net> |
560af5c5 |
3 | ;; |
112ac1d3 |
4 | ;; Permission is hereby granted, free of charge, to any person obtaining |
5 | ;; a copy of this software and associated documentation files (the |
6 | ;; "Software"), to deal in the Software without restriction, including |
7 | ;; without limitation the rights to use, copy, modify, merge, publish, |
8 | ;; distribute, sublicense, and/or sell copies of the Software, and to |
9 | ;; permit persons to whom the Software is furnished to do so, subject to |
10 | ;; the following conditions: |
560af5c5 |
11 | ;; |
112ac1d3 |
12 | ;; The above copyright notice and this permission notice shall be |
13 | ;; included in all copies or substantial portions of the Software. |
560af5c5 |
14 | ;; |
112ac1d3 |
15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, |
16 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF |
17 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. |
18 | ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY |
19 | ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, |
20 | ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE |
21 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |
22 | |
75689fea |
23 | ;; $Id: glib.lisp,v 1.36 2006-02-26 15:30:01 espen Exp $ |
560af5c5 |
24 | |
25 | |
26 | (in-package "GLIB") |
c4e9d221 |
27 | |
560af5c5 |
28 | (use-prefix "g") |
29 | |
30 | |
31 | ;;;; Memory management |
32 | |
dba0c446 |
33 | (defbinding (allocate-memory "g_malloc0") () pointer |
560af5c5 |
34 | (size unsigned-long)) |
35 | |
dba0c446 |
36 | (defbinding (reallocate-memory "g_realloc") () pointer |
560af5c5 |
37 | (address pointer) |
38 | (size unsigned-long)) |
39 | |
3c657c71 |
40 | (defbinding (deallocate-memory "g_free") () nil |
41 | (address pointer)) |
9adccb27 |
42 | ;; (defun deallocate-memory (address) |
43 | ;; (declare (ignore address))) |
560af5c5 |
44 | |
45 | (defun copy-memory (from length &optional (to (allocate-memory length))) |
4f805161 |
46 | #+cmu(system-area-copy from 0 to 0 (* 8 length)) |
47 | #+sbcl(system-area-ub8-copy from 0 to 0 length) |
560af5c5 |
48 | to) |
49 | |
b238749d |
50 | (defun clear-memory (from length) |
75689fea |
51 | #+cmu(vm::system-area-fill 0 from 0 (* 8 length)) |
b238749d |
52 | #+sbcl(system-area-ub8-fill 0 from 0 length)) |
53 | |
7cda9325 |
54 | (defmacro with-allocated-memory ((var size) &body body) |
9a47e267 |
55 | (if (constantp size) |
b238749d |
56 | (let ((alien (make-symbol "ALIEN")) |
57 | (size (eval size))) |
58 | `(with-alien ((,alien (array #+sbcl(sb-alien:unsigned 8) #+cmu(alien:unsigned 8) ,size))) |
9a47e267 |
59 | (let ((,var (alien-sap ,alien))) |
b238749d |
60 | (clear-memory ,var ,size) |
9a47e267 |
61 | ,@body))) |
62 | `(let ((,var (allocate-memory ,size))) |
63 | (unwind-protect |
64 | (progn ,@body) |
65 | (deallocate-memory ,var))))) |
7cda9325 |
66 | |
560af5c5 |
67 | |
c4e9d221 |
68 | ;;;; User data mechanism |
69 | |
70 | (internal *user-data* *user-data-count*) |
71 | |
c4e9d221 |
72 | (defvar *user-data* (make-hash-table)) |
73 | (defvar *user-data-count* 0) |
74 | |
75 | (defun register-user-data (object &optional destroy-function) |
76 | (check-type destroy-function (or null symbol function)) |
77 | (incf *user-data-count*) |
78 | (setf |
79 | (gethash *user-data-count* *user-data*) |
80 | (cons object destroy-function)) |
81 | *user-data-count*) |
82 | |
83 | (defun find-user-data (id) |
84 | (check-type id fixnum) |
85 | (multiple-value-bind (user-data p) (gethash id *user-data*) |
86 | (values (car user-data) p))) |
87 | |
7e531ed5 |
88 | (defun user-data-exists-p (id) |
89 | (nth-value 1 (find-user-data id))) |
90 | |
c9219df2 |
91 | (defun update-user-data (id object) |
92 | (check-type id fixnum) |
93 | (multiple-value-bind (user-data exists-p) (gethash id *user-data*) |
94 | (cond |
95 | ((not exists-p) (error "User data id ~A does not exist" id)) |
96 | (t |
97 | (when (cdr user-data) |
98 | (funcall (cdr user-data) (car user-data))) |
99 | (setf (car user-data) object))))) |
100 | |
c4e9d221 |
101 | (defun destroy-user-data (id) |
102 | (check-type id fixnum) |
103 | (let ((user-data (gethash id *user-data*))) |
104 | (when (cdr user-data) |
105 | (funcall (cdr user-data) (car user-data)))) |
106 | (remhash id *user-data*)) |
107 | |
560af5c5 |
108 | |
0aef1da8 |
109 | ;;;; Quarks |
110 | |
111 | (deftype quark () 'unsigned) |
112 | |
5cae32e1 |
113 | (defbinding %quark-from-string () quark |
415444ae |
114 | (string string)) |
115 | |
7e531ed5 |
116 | (defun quark-intern (object) |
117 | (etypecase object |
118 | (quark object) |
119 | (string (%quark-from-string object)) |
120 | (symbol (%quark-from-string (format nil "clg-~A:~A" |
121 | (package-name (symbol-package object)) |
122 | object))))) |
0aef1da8 |
123 | |
7e531ed5 |
124 | (defbinding quark-to-string () (copy-of string) |
125 | (quark quark)) |
0aef1da8 |
126 | |
127 | |
3846c0b6 |
128 | ;;;; Linked list (GList) |
560af5c5 |
129 | |
72e5ffec |
130 | (deftype glist (type) |
75689fea |
131 | `(or null (cons ,type list))) |
560af5c5 |
132 | |
72e5ffec |
133 | (defbinding (%glist-append "g_list_append") () pointer |
3846c0b6 |
134 | (glist pointer) |
72e5ffec |
135 | (nil null)) |
3846c0b6 |
136 | |
9adccb27 |
137 | (defun make-glist (type list) |
72e5ffec |
138 | (loop |
139 | with writer = (writer-function type) |
140 | for element in list |
141 | as glist = (%glist-append (or glist (make-pointer 0))) |
142 | do (funcall writer element glist) |
143 | finally (return glist))) |
560af5c5 |
144 | |
560af5c5 |
145 | (defun glist-next (glist) |
146 | (unless (null-pointer-p glist) |
9adccb27 |
147 | (sap-ref-sap glist +size-of-pointer+))) |
560af5c5 |
148 | |
9adccb27 |
149 | ;; Also used for gslists |
150 | (defun map-glist (seqtype function glist element-type) |
151 | (let ((reader (reader-function element-type))) |
152 | (case seqtype |
153 | ((nil) |
154 | (loop |
155 | as tmp = glist then (glist-next tmp) |
156 | until (null-pointer-p tmp) |
157 | do (funcall function (funcall reader tmp)))) |
158 | (list |
159 | (loop |
160 | as tmp = glist then (glist-next tmp) |
161 | until (null-pointer-p tmp) |
162 | collect (funcall function (funcall reader tmp)))) |
163 | (t |
164 | (coerce |
165 | (loop |
166 | as tmp = glist then (glist-next tmp) |
167 | until (null-pointer-p tmp) |
168 | collect (funcall function (funcall reader tmp))) |
169 | seqtype))))) |
170 | |
dba0c446 |
171 | (defbinding (glist-free "g_list_free") () nil |
560af5c5 |
172 | (glist pointer)) |
173 | |
72e5ffec |
174 | (defun destroy-glist (glist element-type) |
175 | (loop |
176 | with destroy = (destroy-function element-type) |
177 | as tmp = glist then (glist-next tmp) |
178 | until (null-pointer-p tmp) |
179 | do (funcall destroy tmp 0)) |
180 | (glist-free glist)) |
415444ae |
181 | |
75689fea |
182 | (define-type-method alien-type ((type glist)) |
183 | (declare (ignore type)) |
9adccb27 |
184 | (alien-type 'pointer)) |
185 | |
75689fea |
186 | (define-type-method size-of ((type glist)) |
187 | (declare (ignore type)) |
415444ae |
188 | (size-of 'pointer)) |
560af5c5 |
189 | |
75689fea |
190 | (define-type-method to-alien-form ((type glist) list) |
191 | (let ((element-type (second (type-expand-to 'glist type)))) |
9adccb27 |
192 | `(make-glist ',element-type ,list))) |
193 | |
75689fea |
194 | (define-type-method to-alien-function ((type glist)) |
195 | (let ((element-type (second (type-expand-to 'glist type)))) |
9adccb27 |
196 | #'(lambda (list) |
197 | (make-glist element-type list)))) |
198 | |
75689fea |
199 | (define-type-method from-alien-form ((type glist) glist) |
200 | (let ((element-type (second (type-expand-to 'glist type)))) |
560af5c5 |
201 | `(let ((glist ,glist)) |
9adccb27 |
202 | (unwind-protect |
203 | (map-glist 'list #'identity glist ',element-type) |
72e5ffec |
204 | (destroy-glist glist ',element-type))))) |
9adccb27 |
205 | |
75689fea |
206 | (define-type-method from-alien-function ((type glist)) |
207 | (let ((element-type (second (type-expand-to 'glist type)))) |
9adccb27 |
208 | #'(lambda (glist) |
209 | (unwind-protect |
210 | (map-glist 'list #'identity glist element-type) |
72e5ffec |
211 | (destroy-glist glist element-type))))) |
212 | |
75689fea |
213 | (define-type-method copy-from-alien-form ((type glist) glist) |
214 | (let ((element-type (second (type-expand-to 'glist type)))) |
72e5ffec |
215 | `(map-glist 'list #'identity ,glist ',element-type))) |
216 | |
75689fea |
217 | (define-type-method copy-from-alien-function ((type glist)) |
218 | (let ((element-type (second (type-expand-to 'glist type)))) |
72e5ffec |
219 | #'(lambda (glist) |
220 | (map-glist 'list #'identity glist element-type)))) |
9adccb27 |
221 | |
75689fea |
222 | (define-type-method cleanup-form ((type glist) glist) |
223 | (let ((element-type (second (type-expand-to 'glist type)))) |
72e5ffec |
224 | `(destroy-glist ,glist ',element-type))) |
9adccb27 |
225 | |
75689fea |
226 | (define-type-method cleanup-function ((type glist)) |
227 | (let ((element-type (second (type-expand-to 'glist type)))) |
72e5ffec |
228 | #'(lambda (glist) |
229 | (destroy-glist glist element-type)))) |
560af5c5 |
230 | |
75689fea |
231 | (define-type-method writer-function ((type glist)) |
232 | (let ((element-type (second (type-expand-to 'glist type)))) |
e8caa25a |
233 | #'(lambda (list location &optional (offset 0)) |
234 | (setf |
235 | (sap-ref-sap location offset) |
236 | (make-glist element-type list))))) |
237 | |
75689fea |
238 | (define-type-method reader-function ((type glist)) |
239 | (let ((element-type (second (type-expand-to 'glist type)))) |
3005806e |
240 | #'(lambda (location &optional (offset 0) weak-p) |
241 | (declare (ignore weak-p)) |
e8caa25a |
242 | (unless (null-pointer-p (sap-ref-sap location offset)) |
243 | (map-glist 'list #'identity (sap-ref-sap location offset) element-type))))) |
244 | |
75689fea |
245 | (define-type-method destroy-function ((type glist)) |
246 | (let ((element-type (second (type-expand-to 'glist type)))) |
e8caa25a |
247 | #'(lambda (location &optional (offset 0)) |
248 | (unless (null-pointer-p (sap-ref-sap location offset)) |
249 | (destroy-glist (sap-ref-sap location offset) element-type) |
250 | (setf (sap-ref-sap location offset) (make-pointer 0)))))) |
251 | |
252 | |
560af5c5 |
253 | |
3846c0b6 |
254 | ;;;; Single linked list (GSList) |
255 | |
75689fea |
256 | (deftype gslist (type) `(or null (cons ,type list))) |
3846c0b6 |
257 | |
72e5ffec |
258 | (defbinding (%gslist-prepend "g_slist_prepend") () pointer |
3846c0b6 |
259 | (gslist pointer) |
72e5ffec |
260 | (nil null)) |
3846c0b6 |
261 | |
9adccb27 |
262 | (defun make-gslist (type list) |
72e5ffec |
263 | (loop |
264 | with writer = (writer-function type) |
265 | for element in (reverse list) |
266 | as gslist = (%gslist-prepend (or gslist (make-pointer 0))) |
267 | do (funcall writer element gslist) |
268 | finally (return gslist))) |
9adccb27 |
269 | |
dba0c446 |
270 | (defbinding (gslist-free "g_slist_free") () nil |
3846c0b6 |
271 | (gslist pointer)) |
272 | |
72e5ffec |
273 | (defun destroy-gslist (gslist element-type) |
274 | (loop |
275 | with destroy = (destroy-function element-type) |
276 | as tmp = gslist then (glist-next tmp) |
277 | until (null-pointer-p tmp) |
278 | do (funcall destroy tmp 0)) |
279 | (gslist-free gslist)) |
3846c0b6 |
280 | |
75689fea |
281 | (define-type-method alien-type ((type gslist)) |
282 | (declare (ignore type)) |
9adccb27 |
283 | (alien-type 'pointer)) |
284 | |
75689fea |
285 | (define-type-method size-of ((type gslist)) |
286 | (declare (ignore type)) |
3846c0b6 |
287 | (size-of 'pointer)) |
288 | |
75689fea |
289 | (define-type-method to-alien-form ((type gslist) list) |
290 | (let ((element-type (second (type-expand-to 'gslist type)))) |
9adccb27 |
291 | `(make-sglist ',element-type ,list))) |
292 | |
75689fea |
293 | (define-type-method to-alien-function ((type gslist)) |
294 | (let ((element-type (second (type-expand-to 'gslist type)))) |
9adccb27 |
295 | #'(lambda (list) |
296 | (make-gslist element-type list)))) |
297 | |
75689fea |
298 | (define-type-method from-alien-form ((type gslist) gslist) |
299 | (let ((element-type (second (type-expand-to 'gslist type)))) |
3846c0b6 |
300 | `(let ((gslist ,gslist)) |
9adccb27 |
301 | (unwind-protect |
302 | (map-glist 'list #'identity gslist ',element-type) |
72e5ffec |
303 | (destroy-gslist gslist ',element-type))))) |
3846c0b6 |
304 | |
75689fea |
305 | (define-type-method from-alien-function ((type gslist)) |
306 | (let ((element-type (second (type-expand-to 'gslist type)))) |
9adccb27 |
307 | #'(lambda (gslist) |
308 | (unwind-protect |
309 | (map-glist 'list #'identity gslist element-type) |
72e5ffec |
310 | (destroy-gslist gslist element-type))))) |
311 | |
75689fea |
312 | (define-type-method copy-from-alien-form ((type gslist) gslist) |
313 | (let ((element-type (second (type-expand-to 'gslist type)))) |
72e5ffec |
314 | `(map-glist 'list #'identity ,gslist ',element-type))) |
315 | |
75689fea |
316 | (define-type-method copy-from-alien-function ((type gslist)) |
317 | (let ((element-type (second (type-expand-to 'gslist type)))) |
72e5ffec |
318 | #'(lambda (gslist) |
319 | (map-glist 'list #'identity gslist element-type)))) |
3846c0b6 |
320 | |
75689fea |
321 | (define-type-method cleanup-form ((type gslist) gslist) |
322 | (let ((element-type (second (type-expand-to 'gslist type)))) |
72e5ffec |
323 | `(destroy-gslist ,gslist ',element-type))) |
3846c0b6 |
324 | |
75689fea |
325 | (define-type-method cleanup-function ((type gslist)) |
326 | (let ((element-type (second (type-expand-to 'gslist type)))) |
72e5ffec |
327 | #'(lambda (gslist) |
328 | (destroy-gslist gslist element-type)))) |
415444ae |
329 | |
75689fea |
330 | (define-type-method writer-function ((type gslist)) |
331 | (let ((element-type (second (type-expand-to 'gslist type)))) |
e8caa25a |
332 | #'(lambda (list location &optional (offset 0)) |
333 | (setf |
334 | (sap-ref-sap location offset) |
335 | (make-gslist element-type list))))) |
336 | |
75689fea |
337 | (define-type-method reader-function ((type gslist)) |
338 | (let ((element-type (second (type-expand-to 'gslist type)))) |
3005806e |
339 | #'(lambda (location &optional (offset 0) weak-p) |
340 | (declare (ignore weak-p)) |
e8caa25a |
341 | (unless (null-pointer-p (sap-ref-sap location offset)) |
342 | (map-glist 'list #'identity (sap-ref-sap location offset) element-type))))) |
343 | |
75689fea |
344 | (define-type-method destroy-function ((type gslist)) |
345 | (let ((element-type (second (type-expand-to 'gslist type)))) |
e8caa25a |
346 | #'(lambda (location &optional (offset 0)) |
347 | (unless (null-pointer-p (sap-ref-sap location offset)) |
348 | (destroy-gslist (sap-ref-sap location offset) element-type) |
349 | (setf (sap-ref-sap location offset) (make-pointer 0)))))) |
5cae32e1 |
350 | |
415444ae |
351 | |
9adccb27 |
352 | ;;; Vector |
415444ae |
353 | |
9adccb27 |
354 | (defun make-c-vector (type length &optional content location) |
355 | (let* ((size-of-type (size-of type)) |
356 | (location (or location (allocate-memory (* size-of-type length)))) |
357 | (writer (writer-function type))) |
814ccf77 |
358 | (etypecase content |
359 | (vector |
360 | (loop |
361 | for element across content |
362 | for i from 0 below length |
363 | as offset = 0 then (+ offset size-of-type) |
364 | do (funcall writer element location offset))) |
365 | (list |
366 | (loop |
367 | for element in content |
368 | for i from 0 below length |
369 | as offset = 0 then (+ offset size-of-type) |
370 | do (funcall writer element location offset)))) |
9adccb27 |
371 | location)) |
372 | |
373 | |
374 | (defun map-c-vector (seqtype function location element-type length) |
375 | (let ((reader (reader-function element-type)) |
376 | (size-of-element (size-of element-type))) |
dba0c446 |
377 | (case seqtype |
378 | ((nil) |
9adccb27 |
379 | (loop |
380 | for i from 0 below length |
381 | as offset = 0 then (+ offset size-of-element) |
382 | do (funcall function (funcall reader location offset)))) |
dba0c446 |
383 | (list |
9adccb27 |
384 | (loop |
385 | for i from 0 below length |
386 | as offset = 0 then (+ offset size-of-element) |
387 | collect (funcall function (funcall reader location offset)))) |
dba0c446 |
388 | (t |
9adccb27 |
389 | (loop |
390 | with sequence = (make-sequence seqtype length) |
391 | for i from 0 below length |
392 | as offset = 0 then (+ offset size-of-element) |
393 | do (setf |
dba0c446 |
394 | (elt sequence i) |
9adccb27 |
395 | (funcall function (funcall reader location offset))) |
396 | finally (return sequence)))))) |
397 | |
398 | |
72e5ffec |
399 | (defun destroy-c-vector (location element-type length) |
400 | (loop |
401 | with destroy = (destroy-function element-type) |
402 | with element-size = (size-of element-type) |
403 | for i from 0 below length |
404 | as offset = 0 then (+ offset element-size) |
405 | do (funcall destroy location offset)) |
406 | (deallocate-memory location)) |
407 | |
408 | |
75689fea |
409 | (define-type-method alien-type ((type vector)) |
410 | (declare (ignore type)) |
9adccb27 |
411 | (alien-type 'pointer)) |
412 | |
75689fea |
413 | (define-type-method size-of ((type vector)) |
414 | (declare (ignore type)) |
9adccb27 |
415 | (size-of 'pointer)) |
416 | |
75689fea |
417 | (define-type-method to-alien-form ((type vector) vector) |
418 | (destructuring-bind (element-type &optional (length '*)) |
419 | (rest (type-expand-to 'vector type)) |
9adccb27 |
420 | (if (eq length '*) |
421 | `(let* ((vector ,vector) |
422 | (location (sap+ |
423 | (allocate-memory (+ ,+size-of-int+ |
424 | (* ,(size-of element-type) |
425 | (length vector)))) |
426 | ,+size-of-int+))) |
427 | (make-c-vector ',element-type (length vector) vector location) |
428 | (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector)) |
429 | location) |
430 | `(make-c-vector ',element-type ,length ,vector)))) |
431 | |
75689fea |
432 | (define-type-method from-alien-form ((type vector) c-vector) |
433 | (destructuring-bind (element-type &optional (length '*)) |
434 | (rest (type-expand-to 'vector type)) |
72e5ffec |
435 | (if (eq length '*) |
436 | (error "Can't use vector of variable size as return type") |
437 | `(let ((c-vector ,c-vector)) |
438 | (prog1 |
c9219df2 |
439 | (map-c-vector 'vector #'identity c-vector ',element-type ,length) |
72e5ffec |
440 | (destroy-c-vector c-vector ',element-type ,length)))))) |
441 | |
75689fea |
442 | (define-type-method copy-from-alien-form ((type vector) c-vector) |
443 | (destructuring-bind (element-type &optional (length '*)) |
444 | (rest (type-expand-to 'vector type)) |
9adccb27 |
445 | (if (eq length '*) |
446 | (error "Can't use vector of variable size as return type") |
e7765a40 |
447 | `(map-c-vector 'vector #'identity ,c-vector ',element-type ,length)))) |
9adccb27 |
448 | |
75689fea |
449 | (define-type-method copy-from-alien-function ((type vector)) |
450 | (destructuring-bind (element-type &optional (length '*)) |
451 | (rest (type-expand-to 'vector type)) |
5e8ceafa |
452 | (if (eq length '*) |
453 | (error "Can't use vector of variable size as return type") |
454 | #'(lambda (c-vector) |
455 | (map-c-vector 'vector #'identity c-vector element-type length))))) |
456 | |
75689fea |
457 | (define-type-method cleanup-form ((type vector) location) |
458 | (destructuring-bind (element-type &optional (length '*)) |
459 | (rest (type-expand-to 'vector type)) |
9adccb27 |
460 | `(let* ((location ,location) |
461 | (length ,(if (eq length '*) |
462 | `(sap-ref-32 location ,(- +size-of-int+)) |
463 | length))) |
464 | (loop |
465 | with destroy = (destroy-function ',element-type) |
466 | for i from 0 below length |
467 | as offset = 0 then (+ offset ,(size-of element-type)) |
468 | do (funcall destroy location offset)) |
469 | (deallocate-memory ,(if (eq length '*) |
470 | `(sap+ location ,(- +size-of-int+)) |
471 | 'location))))) |
16bf1149 |
472 | |
75689fea |
473 | ;; We need these so that we can specify vectors with length given as |
474 | ;; a non constant in callbacks |
475 | (define-type-method callback-from-alien-form ((type vector) form) |
476 | (copy-from-alien-form type form)) |
477 | (define-type-method callback-cleanup-form ((type vector) form) |
478 | (declare (ignore type form)) |
479 | nil) |
480 | |
481 | |
482 | (define-type-method writer-function ((type vector)) |
483 | (destructuring-bind (element-type &optional (length '*)) |
484 | (rest (type-expand-to 'vector type)) |
16bf1149 |
485 | #'(lambda (vector location &optional (offset 0)) |
486 | (setf |
487 | (sap-ref-sap location offset) |
488 | (make-c-vector element-type length vector))))) |
489 | |
75689fea |
490 | (define-type-method reader-function ((type vector)) |
491 | (destructuring-bind (element-type &optional (length '*)) |
492 | (rest (type-expand-to 'vector type)) |
16bf1149 |
493 | (if (eq length '*) |
494 | (error "Can't create reader function for vector of variable size") |
3005806e |
495 | #'(lambda (location &optional (offset 0) weak-p) |
496 | (declare (ignore weak-p)) |
16bf1149 |
497 | (unless (null-pointer-p (sap-ref-sap location offset)) |
498 | (map-c-vector 'vector #'identity (sap-ref-sap location offset) |
499 | element-type length)))))) |
500 | |
75689fea |
501 | (define-type-method destroy-function ((type vector)) |
502 | (destructuring-bind (element-type &optional (length '*)) |
503 | (rest (type-expand-to 'vector type)) |
16bf1149 |
504 | (if (eq length '*) |
505 | (error "Can't create destroy function for vector of variable size") |
506 | #'(lambda (location &optional (offset 0)) |
507 | (unless (null-pointer-p (sap-ref-sap location offset)) |
508 | (destroy-c-vector |
509 | (sap-ref-sap location offset) element-type length) |
510 | (setf (sap-ref-sap location offset) (make-pointer 0))))))) |
463fe62f |
511 | |
512 | |
513 | ;;;; Null terminated vector |
514 | |
515 | (defun make-0-vector (type content &optional location) |
516 | (let* ((size-of-type (size-of type)) |
517 | (location (or |
518 | location |
519 | (allocate-memory (* size-of-type (1+ (length content)))))) |
520 | (writer (writer-function type))) |
521 | (etypecase content |
522 | (vector |
523 | (loop |
524 | for element across content |
525 | as offset = 0 then (+ offset size-of-type) |
526 | do (funcall writer element location offset) |
527 | finally (setf (sap-ref-sap location offset) (make-pointer 0)))) |
528 | (list |
529 | (loop |
530 | for element in content |
531 | as offset = 0 then (+ offset size-of-type) |
532 | do (funcall writer element location offset) |
533 | finally (setf (sap-ref-sap location (+ offset size-of-type)) (make-pointer 0))))) |
534 | location)) |
535 | |
536 | |
537 | (defun map-0-vector (seqtype function location element-type) |
538 | (let ((reader (reader-function element-type)) |
539 | (size-of-element (size-of element-type))) |
540 | (case seqtype |
541 | ((nil) |
542 | (loop |
543 | as offset = 0 then (+ offset size-of-element) |
544 | until (null-pointer-p (sap-ref-sap location offset)) |
545 | do (funcall function (funcall reader location offset)))) |
546 | (list |
547 | (loop |
548 | as offset = 0 then (+ offset size-of-element) |
549 | until (null-pointer-p (sap-ref-sap location offset)) |
550 | collect (funcall function (funcall reader location offset)))) |
551 | (t |
552 | (coerce |
553 | (loop |
554 | as offset = 0 then (+ offset size-of-element) |
555 | until (null-pointer-p (sap-ref-sap location offset)) |
556 | collect (funcall function (funcall reader location offset))) |
557 | seqtype))))) |
558 | |
559 | |
560 | (defun destroy-0-vector (location element-type) |
561 | (loop |
562 | with destroy = (destroy-function element-type) |
563 | with element-size = (size-of element-type) |
564 | as offset = 0 then (+ offset element-size) |
565 | until (null-pointer-p (sap-ref-sap location offset)) |
566 | do (funcall destroy location offset)) |
567 | (deallocate-memory location)) |
568 | |
5e8ceafa |
569 | (deftype null-terminated-vector (element-type) `(vector ,element-type)) |
463fe62f |
570 | |
75689fea |
571 | (define-type-method alien-type ((type null-terminated-vector)) |
572 | (declare (ignore type)) |
463fe62f |
573 | (alien-type 'pointer)) |
574 | |
75689fea |
575 | (define-type-method size-of ((type null-terminated-vector)) |
576 | (declare (ignore type)) |
5e8ceafa |
577 | (size-of 'pointer)) |
578 | |
75689fea |
579 | (define-type-method to-alien-form ((type null-terminated-vector) vector) |
580 | (destructuring-bind (element-type) |
581 | (rest (type-expand-to 'null-terminated-vector type)) |
5e8ceafa |
582 | `(make-0-vector ',element-type ,vector))) |
583 | |
75689fea |
584 | (define-type-method from-alien-form ((type null-terminated-vector) c-vector) |
585 | (destructuring-bind (element-type) |
586 | (rest (type-expand-to 'null-terminated-vector type)) |
5e8ceafa |
587 | `(let ((c-vector ,c-vector)) |
588 | (prog1 |
589 | (map-0-vector 'vector #'identity c-vector ',element-type) |
590 | (destroy-0-vector c-vector ',element-type))))) |
591 | |
75689fea |
592 | (define-type-method copy-from-alien-form ((type null-terminated-vector) c-vector) |
593 | (destructuring-bind (element-type) |
594 | (rest (type-expand-to 'null-terminated-vector type)) |
5e8ceafa |
595 | `(map-0-vector 'vector #'identity ,c-vector ',element-type))) |
596 | |
75689fea |
597 | (define-type-method cleanup-form ((type null-terminated-vector) location) |
598 | (destructuring-bind (element-type) |
599 | (rest (type-expand-to 'null-terminated-vector type)) |
5e8ceafa |
600 | `(destroy-0-vector ,location ',element-type))) |
463fe62f |
601 | |
75689fea |
602 | (define-type-method writer-function ((type null-terminated-vector)) |
603 | (destructuring-bind (element-type) |
604 | (rest (type-expand-to 'null-terminated-vector type)) |
463fe62f |
605 | (unless (eq (alien-type element-type) (alien-type 'pointer)) |
606 | (error "Elements in null-terminated vectors need to be of pointer types")) |
607 | #'(lambda (vector location &optional (offset 0)) |
608 | (setf |
609 | (sap-ref-sap location offset) |
610 | (make-0-vector element-type vector))))) |
611 | |
75689fea |
612 | (define-type-method reader-function ((type null-terminated-vector)) |
613 | (destructuring-bind (element-type) |
614 | (rest (type-expand-to 'null-terminated-vector type)) |
463fe62f |
615 | (unless (eq (alien-type element-type) (alien-type 'pointer)) |
616 | (error "Elements in null-terminated vectors need to be of pointer types")) |
3005806e |
617 | #'(lambda (location &optional (offset 0) weak-p) |
618 | (declare (ignore weak-p)) |
463fe62f |
619 | (unless (null-pointer-p (sap-ref-sap location offset)) |
620 | (map-0-vector 'vector #'identity (sap-ref-sap location offset) |
621 | element-type))))) |
622 | |
75689fea |
623 | (define-type-method destroy-function ((type null-terminated-vector)) |
624 | (destructuring-bind (element-type) |
625 | (rest (type-expand-to 'null-terminated-vector type)) |
463fe62f |
626 | (unless (eq (alien-type element-type) (alien-type 'pointer)) |
627 | (error "Elements in null-terminated vectors need to be of pointer types")) |
628 | #'(lambda (location &optional (offset 0)) |
629 | (unless (null-pointer-p (sap-ref-sap location offset)) |
545712f4 |
630 | (destroy-0-vector |
463fe62f |
631 | (sap-ref-sap location offset) element-type) |
632 | (setf (sap-ref-sap location offset) (make-pointer 0)))))) |
633 | |
75689fea |
634 | (define-type-method unbound-value ((type null-terminated-vector)) |
635 | (declare (ignore type)) |
636 | nil) |
637 | |
638 | |
5e8ceafa |
639 | |
640 | |
641 | ;;; Counted vector |
642 | |
643 | (defun make-counted-vector (type content) |
644 | (let* ((size-of-type (size-of type)) |
645 | (length (length content)) |
646 | (location |
647 | (allocate-memory (+ +size-of-int+ (* size-of-type length))))) |
648 | (setf (sap-ref-32 location 0) length) |
649 | (make-c-vector type length content (sap+ location +size-of-int+)))) |
650 | |
651 | (defun map-counted-vector (seqtype function location element-type) |
652 | (let ((length (sap-ref-32 location 0))) |
653 | (map-c-vector |
654 | seqtype function (sap+ location +size-of-int+) |
655 | element-type length))) |
656 | |
657 | (defun destroy-counted-vector (location element-type) |
658 | (loop |
659 | with destroy = (destroy-function element-type) |
660 | with element-size = (size-of element-type) |
661 | for i from 0 below (sap-ref-32 location 0) |
662 | as offset = +size-of-int+ then (+ offset element-size) |
663 | do (funcall destroy location offset)) |
664 | (deallocate-memory location)) |
665 | |
666 | |
667 | (deftype counted-vector (element-type) `(vector ,element-type)) |
668 | |
75689fea |
669 | (define-type-method alien-type ((type counted-vector)) |
670 | (declare (ignore type)) |
5e8ceafa |
671 | (alien-type 'pointer)) |
672 | |
75689fea |
673 | (define-type-method size-of ((type counted-vector)) |
674 | (declare (ignore type)) |
5e8ceafa |
675 | (size-of 'pointer)) |
676 | |
75689fea |
677 | (define-type-method to-alien-form ((type counted-vector) vector) |
678 | (destructuring-bind (element-type) |
679 | (rest (type-expand-to 'counted-vector type)) |
5e8ceafa |
680 | `(make-counted-vector ',element-type ,vector))) |
681 | |
75689fea |
682 | (define-type-method from-alien-form ((type counted-vector) c-vector) |
683 | (destructuring-bind (element-type) |
684 | (rest (type-expand-to 'counted-vector type)) |
5e8ceafa |
685 | `(let ((c-vector ,c-vector)) |
686 | (prog1 |
687 | (map-counted-vector 'vector #'identity c-vector ',element-type) |
688 | (destroy-counted-vector c-vector ',element-type))))) |
689 | |
75689fea |
690 | (define-type-method copy-from-alien-form ((type counted-vector) c-vector) |
691 | (destructuring-bind (element-type) |
692 | (rest (type-expand-to 'counted-vector type)) |
5e8ceafa |
693 | `(map-counted-vector 'vector #'identity ,c-vector ',element-type))) |
694 | |
75689fea |
695 | (define-type-method copy-from-alien-function ((type counted-vector)) |
696 | (destructuring-bind (element-type) |
697 | (rest (type-expand-to 'counted-vector type)) |
5e8ceafa |
698 | #'(lambda (c-vector) |
699 | (map-counted-vector 'vector #'identity c-vector element-type)))) |
700 | |
75689fea |
701 | (define-type-method cleanup-form ((type counted-vector) location) |
702 | (destructuring-bind (element-type) |
703 | (rest (type-expand-to 'counted-vector type)) |
5e8ceafa |
704 | `(destroy-counted-vector ,location ',element-type))) |
705 | |
75689fea |
706 | (define-type-method writer-function ((type counted-vector)) |
707 | (destructuring-bind (element-type) |
708 | (rest (type-expand-to 'counted-vector type)) |
5e8ceafa |
709 | #'(lambda (vector location &optional (offset 0)) |
710 | (setf |
711 | (sap-ref-sap location offset) |
712 | (make-counted-vector element-type vector))))) |
713 | |
75689fea |
714 | (define-type-method reader-function ((type counted-vector)) |
715 | (destructuring-bind (element-type) |
716 | (rest (type-expand-to 'counted-vector type)) |
3005806e |
717 | #'(lambda (location &optional (offset 0) weak-p) |
718 | (declare (ignore weak-p)) |
5e8ceafa |
719 | (unless (null-pointer-p (sap-ref-sap location offset)) |
720 | (map-counted-vector 'vector #'identity |
721 | (sap-ref-sap location offset) element-type))))) |
722 | |
75689fea |
723 | (define-type-method destroy-function ((type counted-vector)) |
724 | (destructuring-bind (element-type) |
725 | (rest (type-expand-to 'counted-vector type)) |
5e8ceafa |
726 | #'(lambda (location &optional (offset 0)) |
727 | (unless (null-pointer-p (sap-ref-sap location offset)) |
728 | (destroy-counted-vector |
729 | (sap-ref-sap location offset) element-type) |
730 | (setf (sap-ref-sap location offset) (make-pointer 0)))))) |