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 | |
e7765a40 |
23 | ;; $Id: glib.lisp,v 1.31 2005-04-24 13:27:20 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 | |
50 | |
c4e9d221 |
51 | ;;;; User data mechanism |
52 | |
53 | (internal *user-data* *user-data-count*) |
54 | |
c4e9d221 |
55 | (defvar *user-data* (make-hash-table)) |
56 | (defvar *user-data-count* 0) |
57 | |
58 | (defun register-user-data (object &optional destroy-function) |
59 | (check-type destroy-function (or null symbol function)) |
60 | (incf *user-data-count*) |
61 | (setf |
62 | (gethash *user-data-count* *user-data*) |
63 | (cons object destroy-function)) |
64 | *user-data-count*) |
65 | |
66 | (defun find-user-data (id) |
67 | (check-type id fixnum) |
68 | (multiple-value-bind (user-data p) (gethash id *user-data*) |
69 | (values (car user-data) p))) |
70 | |
7e531ed5 |
71 | (defun user-data-exists-p (id) |
72 | (nth-value 1 (find-user-data id))) |
73 | |
c9219df2 |
74 | (defun update-user-data (id object) |
75 | (check-type id fixnum) |
76 | (multiple-value-bind (user-data exists-p) (gethash id *user-data*) |
77 | (cond |
78 | ((not exists-p) (error "User data id ~A does not exist" id)) |
79 | (t |
80 | (when (cdr user-data) |
81 | (funcall (cdr user-data) (car user-data))) |
82 | (setf (car user-data) object))))) |
83 | |
c4e9d221 |
84 | (defun destroy-user-data (id) |
85 | (check-type id fixnum) |
86 | (let ((user-data (gethash id *user-data*))) |
87 | (when (cdr user-data) |
88 | (funcall (cdr user-data) (car user-data)))) |
89 | (remhash id *user-data*)) |
90 | |
560af5c5 |
91 | |
0aef1da8 |
92 | ;;;; Quarks |
93 | |
94 | (deftype quark () 'unsigned) |
95 | |
5cae32e1 |
96 | (defbinding %quark-from-string () quark |
415444ae |
97 | (string string)) |
98 | |
7e531ed5 |
99 | (defun quark-intern (object) |
100 | (etypecase object |
101 | (quark object) |
102 | (string (%quark-from-string object)) |
103 | (symbol (%quark-from-string (format nil "clg-~A:~A" |
104 | (package-name (symbol-package object)) |
105 | object))))) |
0aef1da8 |
106 | |
7e531ed5 |
107 | (defbinding quark-to-string () (copy-of string) |
108 | (quark quark)) |
0aef1da8 |
109 | |
110 | |
3846c0b6 |
111 | ;;;; Linked list (GList) |
560af5c5 |
112 | |
72e5ffec |
113 | (deftype glist (type) |
9adccb27 |
114 | `(or (null (cons ,type list)))) |
560af5c5 |
115 | |
72e5ffec |
116 | (defbinding (%glist-append "g_list_append") () pointer |
3846c0b6 |
117 | (glist pointer) |
72e5ffec |
118 | (nil null)) |
3846c0b6 |
119 | |
9adccb27 |
120 | (defun make-glist (type list) |
72e5ffec |
121 | (loop |
122 | with writer = (writer-function type) |
123 | for element in list |
124 | as glist = (%glist-append (or glist (make-pointer 0))) |
125 | do (funcall writer element glist) |
126 | finally (return glist))) |
560af5c5 |
127 | |
560af5c5 |
128 | (defun glist-next (glist) |
129 | (unless (null-pointer-p glist) |
9adccb27 |
130 | (sap-ref-sap glist +size-of-pointer+))) |
560af5c5 |
131 | |
9adccb27 |
132 | ;; Also used for gslists |
133 | (defun map-glist (seqtype function glist element-type) |
134 | (let ((reader (reader-function element-type))) |
135 | (case seqtype |
136 | ((nil) |
137 | (loop |
138 | as tmp = glist then (glist-next tmp) |
139 | until (null-pointer-p tmp) |
140 | do (funcall function (funcall reader tmp)))) |
141 | (list |
142 | (loop |
143 | as tmp = glist then (glist-next tmp) |
144 | until (null-pointer-p tmp) |
145 | collect (funcall function (funcall reader tmp)))) |
146 | (t |
147 | (coerce |
148 | (loop |
149 | as tmp = glist then (glist-next tmp) |
150 | until (null-pointer-p tmp) |
151 | collect (funcall function (funcall reader tmp))) |
152 | seqtype))))) |
153 | |
dba0c446 |
154 | (defbinding (glist-free "g_list_free") () nil |
560af5c5 |
155 | (glist pointer)) |
156 | |
72e5ffec |
157 | (defun destroy-glist (glist element-type) |
158 | (loop |
159 | with destroy = (destroy-function element-type) |
160 | as tmp = glist then (glist-next tmp) |
161 | until (null-pointer-p tmp) |
162 | do (funcall destroy tmp 0)) |
163 | (glist-free glist)) |
415444ae |
164 | |
9adccb27 |
165 | (defmethod alien-type ((type (eql 'glist)) &rest args) |
166 | (declare (ignore type args)) |
167 | (alien-type 'pointer)) |
168 | |
169 | (defmethod size-of ((type (eql 'glist)) &rest args) |
170 | (declare (ignore type args)) |
415444ae |
171 | (size-of 'pointer)) |
560af5c5 |
172 | |
9adccb27 |
173 | (defmethod to-alien-form (list (type (eql 'glist)) &rest args) |
174 | (declare (ignore type)) |
175 | (destructuring-bind (element-type) args |
176 | `(make-glist ',element-type ,list))) |
177 | |
178 | (defmethod to-alien-function ((type (eql 'glist)) &rest args) |
8755b1a5 |
179 | (declare (ignore type)) |
9adccb27 |
180 | (destructuring-bind (element-type) args |
181 | #'(lambda (list) |
182 | (make-glist element-type list)))) |
183 | |
184 | (defmethod from-alien-form (glist (type (eql 'glist)) &rest args) |
185 | (declare (ignore type)) |
186 | (destructuring-bind (element-type) args |
560af5c5 |
187 | `(let ((glist ,glist)) |
9adccb27 |
188 | (unwind-protect |
189 | (map-glist 'list #'identity glist ',element-type) |
72e5ffec |
190 | (destroy-glist glist ',element-type))))) |
9adccb27 |
191 | |
192 | (defmethod from-alien-function ((type (eql 'glist)) &rest args) |
193 | (declare (ignore type)) |
194 | (destructuring-bind (element-type) args |
195 | #'(lambda (glist) |
196 | (unwind-protect |
197 | (map-glist 'list #'identity glist element-type) |
72e5ffec |
198 | (destroy-glist glist element-type))))) |
199 | |
200 | (defmethod copy-from-alien-form (glist (type (eql 'glist)) &rest args) |
201 | (declare (ignore type)) |
202 | (destructuring-bind (element-type) args |
203 | `(map-glist 'list #'identity ,glist ',element-type))) |
204 | |
205 | (defmethod copy-from-alien-function ((type (eql 'glist)) &rest args) |
206 | (declare (ignore type)) |
207 | (destructuring-bind (element-type) args |
208 | #'(lambda (glist) |
209 | (map-glist 'list #'identity glist element-type)))) |
9adccb27 |
210 | |
211 | (defmethod cleanup-form (glist (type (eql 'glist)) &rest args) |
72e5ffec |
212 | (declare (ignore type)) |
213 | (destructuring-bind (element-type) args |
214 | `(destroy-glist ,glist ',element-type))) |
9adccb27 |
215 | |
216 | (defmethod cleanup-function ((type (eql 'glist)) &rest args) |
e8caa25a |
217 | (declare (ignore type)) |
72e5ffec |
218 | (destructuring-bind (element-type) args |
219 | #'(lambda (glist) |
220 | (destroy-glist glist element-type)))) |
560af5c5 |
221 | |
e8caa25a |
222 | (defmethod writer-function ((type (eql 'glist)) &rest args) |
223 | (declare (ignore type)) |
224 | (destructuring-bind (element-type) args |
225 | #'(lambda (list location &optional (offset 0)) |
226 | (setf |
227 | (sap-ref-sap location offset) |
228 | (make-glist element-type list))))) |
229 | |
230 | (defmethod reader-function ((type (eql 'glist)) &rest args) |
231 | (declare (ignore type)) |
232 | (destructuring-bind (element-type) args |
233 | #'(lambda (location &optional (offset 0)) |
234 | (unless (null-pointer-p (sap-ref-sap location offset)) |
235 | (map-glist 'list #'identity (sap-ref-sap location offset) element-type))))) |
236 | |
237 | (defmethod destroy-function ((type (eql 'glist)) &rest args) |
238 | (declare (ignore type)) |
239 | (destructuring-bind (element-type) args |
240 | #'(lambda (location &optional (offset 0)) |
241 | (unless (null-pointer-p (sap-ref-sap location offset)) |
242 | (destroy-glist (sap-ref-sap location offset) element-type) |
243 | (setf (sap-ref-sap location offset) (make-pointer 0)))))) |
244 | |
245 | |
560af5c5 |
246 | |
3846c0b6 |
247 | ;;;; Single linked list (GSList) |
248 | |
249 | (deftype gslist (type) `(or (null (cons ,type list)))) |
250 | |
72e5ffec |
251 | (defbinding (%gslist-prepend "g_slist_prepend") () pointer |
3846c0b6 |
252 | (gslist pointer) |
72e5ffec |
253 | (nil null)) |
3846c0b6 |
254 | |
9adccb27 |
255 | (defun make-gslist (type list) |
72e5ffec |
256 | (loop |
257 | with writer = (writer-function type) |
258 | for element in (reverse list) |
259 | as gslist = (%gslist-prepend (or gslist (make-pointer 0))) |
260 | do (funcall writer element gslist) |
261 | finally (return gslist))) |
9adccb27 |
262 | |
dba0c446 |
263 | (defbinding (gslist-free "g_slist_free") () nil |
3846c0b6 |
264 | (gslist pointer)) |
265 | |
72e5ffec |
266 | (defun destroy-gslist (gslist element-type) |
267 | (loop |
268 | with destroy = (destroy-function element-type) |
269 | as tmp = gslist then (glist-next tmp) |
270 | until (null-pointer-p tmp) |
271 | do (funcall destroy tmp 0)) |
272 | (gslist-free gslist)) |
3846c0b6 |
273 | |
9adccb27 |
274 | (defmethod alien-type ((type (eql 'gslist)) &rest args) |
275 | (declare (ignore type args)) |
276 | (alien-type 'pointer)) |
277 | |
278 | (defmethod size-of ((type (eql 'gslist)) &rest args) |
279 | (declare (ignore type args)) |
3846c0b6 |
280 | (size-of 'pointer)) |
281 | |
9adccb27 |
282 | (defmethod to-alien-form (list (type (eql 'gslist)) &rest args) |
283 | (declare (ignore type)) |
284 | (destructuring-bind (element-type) args |
285 | `(make-sglist ',element-type ,list))) |
286 | |
287 | (defmethod to-alien-function ((type (eql 'gslist)) &rest args) |
8755b1a5 |
288 | (declare (ignore type)) |
9adccb27 |
289 | (destructuring-bind (element-type) args |
290 | #'(lambda (list) |
291 | (make-gslist element-type list)))) |
292 | |
293 | (defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args) |
294 | (declare (ignore type)) |
295 | (destructuring-bind (element-type) args |
3846c0b6 |
296 | `(let ((gslist ,gslist)) |
9adccb27 |
297 | (unwind-protect |
298 | (map-glist 'list #'identity gslist ',element-type) |
72e5ffec |
299 | (destroy-gslist gslist ',element-type))))) |
3846c0b6 |
300 | |
9adccb27 |
301 | (defmethod from-alien-function ((type (eql 'gslist)) &rest args) |
302 | (declare (ignore type)) |
303 | (destructuring-bind (element-type) args |
304 | #'(lambda (gslist) |
305 | (unwind-protect |
306 | (map-glist 'list #'identity gslist element-type) |
72e5ffec |
307 | (destroy-gslist gslist element-type))))) |
308 | |
309 | (defmethod copy-from-alien-form (gslist (type (eql 'gslist)) &rest args) |
310 | (declare (ignore type)) |
311 | (destructuring-bind (element-type) args |
312 | `(map-glist 'list #'identity ,gslist ',element-type))) |
313 | |
73572c12 |
314 | (defmethod copy-from-alien-function ((type (eql 'gslist)) &rest args) |
72e5ffec |
315 | (declare (ignore type)) |
316 | (destructuring-bind (element-type) args |
317 | #'(lambda (gslist) |
318 | (map-glist 'list #'identity gslist element-type)))) |
3846c0b6 |
319 | |
72e5ffec |
320 | (defmethod cleanup-form (gslist (type (eql 'gslist)) &rest args) |
e8caa25a |
321 | (declare (ignore type)) |
72e5ffec |
322 | (destructuring-bind (element-type) args |
323 | `(destroy-gslist ,gslist ',element-type))) |
3846c0b6 |
324 | |
9adccb27 |
325 | (defmethod cleanup-function ((type (eql 'gslist)) &rest args) |
e8caa25a |
326 | (declare (ignore type)) |
72e5ffec |
327 | (destructuring-bind (element-type) args |
328 | #'(lambda (gslist) |
329 | (destroy-gslist gslist element-type)))) |
415444ae |
330 | |
e8caa25a |
331 | (defmethod writer-function ((type (eql 'gslist)) &rest args) |
332 | (declare (ignore type)) |
333 | (destructuring-bind (element-type) args |
334 | #'(lambda (list location &optional (offset 0)) |
335 | (setf |
336 | (sap-ref-sap location offset) |
337 | (make-gslist element-type list))))) |
338 | |
339 | (defmethod reader-function ((type (eql 'gslist)) &rest args) |
340 | (declare (ignore type)) |
341 | (destructuring-bind (element-type) args |
342 | #'(lambda (location &optional (offset 0)) |
343 | (unless (null-pointer-p (sap-ref-sap location offset)) |
344 | (map-glist 'list #'identity (sap-ref-sap location offset) element-type))))) |
345 | |
346 | (defmethod destroy-function ((type (eql 'gslist)) &rest args) |
347 | (declare (ignore type)) |
348 | (destructuring-bind (element-type) args |
349 | #'(lambda (location &optional (offset 0)) |
350 | (unless (null-pointer-p (sap-ref-sap location offset)) |
351 | (destroy-gslist (sap-ref-sap location offset) element-type) |
352 | (setf (sap-ref-sap location offset) (make-pointer 0)))))) |
5cae32e1 |
353 | |
415444ae |
354 | |
9adccb27 |
355 | ;;; Vector |
415444ae |
356 | |
9adccb27 |
357 | (defun make-c-vector (type length &optional content location) |
358 | (let* ((size-of-type (size-of type)) |
359 | (location (or location (allocate-memory (* size-of-type length)))) |
360 | (writer (writer-function type))) |
814ccf77 |
361 | (etypecase content |
362 | (vector |
363 | (loop |
364 | for element across content |
365 | for i from 0 below length |
366 | as offset = 0 then (+ offset size-of-type) |
367 | do (funcall writer element location offset))) |
368 | (list |
369 | (loop |
370 | for element in content |
371 | for i from 0 below length |
372 | as offset = 0 then (+ offset size-of-type) |
373 | do (funcall writer element location offset)))) |
9adccb27 |
374 | location)) |
375 | |
376 | |
377 | (defun map-c-vector (seqtype function location element-type length) |
378 | (let ((reader (reader-function element-type)) |
379 | (size-of-element (size-of element-type))) |
dba0c446 |
380 | (case seqtype |
381 | ((nil) |
9adccb27 |
382 | (loop |
383 | for i from 0 below length |
384 | as offset = 0 then (+ offset size-of-element) |
385 | do (funcall function (funcall reader location offset)))) |
dba0c446 |
386 | (list |
9adccb27 |
387 | (loop |
388 | for i from 0 below length |
389 | as offset = 0 then (+ offset size-of-element) |
390 | collect (funcall function (funcall reader location offset)))) |
dba0c446 |
391 | (t |
9adccb27 |
392 | (loop |
393 | with sequence = (make-sequence seqtype length) |
394 | for i from 0 below length |
395 | as offset = 0 then (+ offset size-of-element) |
396 | do (setf |
dba0c446 |
397 | (elt sequence i) |
9adccb27 |
398 | (funcall function (funcall reader location offset))) |
399 | finally (return sequence)))))) |
400 | |
401 | |
72e5ffec |
402 | (defun destroy-c-vector (location element-type length) |
403 | (loop |
404 | with destroy = (destroy-function element-type) |
405 | with element-size = (size-of element-type) |
406 | for i from 0 below length |
407 | as offset = 0 then (+ offset element-size) |
408 | do (funcall destroy location offset)) |
409 | (deallocate-memory location)) |
410 | |
411 | |
9adccb27 |
412 | (defmethod alien-type ((type (eql 'vector)) &rest args) |
413 | (declare (ignore type args)) |
414 | (alien-type 'pointer)) |
415 | |
416 | (defmethod size-of ((type (eql 'vector)) &rest args) |
417 | (declare (ignore type args)) |
418 | (size-of 'pointer)) |
419 | |
420 | (defmethod to-alien-form (vector (type (eql 'vector)) &rest args) |
421 | (declare (ignore type)) |
422 | (destructuring-bind (element-type &optional (length '*)) args |
423 | (if (eq length '*) |
424 | `(let* ((vector ,vector) |
425 | (location (sap+ |
426 | (allocate-memory (+ ,+size-of-int+ |
427 | (* ,(size-of element-type) |
428 | (length vector)))) |
429 | ,+size-of-int+))) |
430 | (make-c-vector ',element-type (length vector) vector location) |
431 | (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector)) |
432 | location) |
433 | `(make-c-vector ',element-type ,length ,vector)))) |
434 | |
72e5ffec |
435 | (defmethod from-alien-form (c-vector (type (eql 'vector)) &rest args) |
436 | (declare (ignore type)) |
437 | (destructuring-bind (element-type &optional (length '*)) args |
438 | (if (eq length '*) |
439 | (error "Can't use vector of variable size as return type") |
440 | `(let ((c-vector ,c-vector)) |
441 | (prog1 |
c9219df2 |
442 | (map-c-vector 'vector #'identity c-vector ',element-type ,length) |
72e5ffec |
443 | (destroy-c-vector c-vector ',element-type ,length)))))) |
444 | |
445 | (defmethod copy-from-alien-form (c-vector (type (eql 'vector)) &rest args) |
9adccb27 |
446 | (declare (ignore type)) |
447 | (destructuring-bind (element-type &optional (length '*)) args |
448 | (if (eq length '*) |
449 | (error "Can't use vector of variable size as return type") |
e7765a40 |
450 | `(map-c-vector 'vector #'identity ,c-vector ',element-type ,length)))) |
9adccb27 |
451 | |
5e8ceafa |
452 | (defmethod copy-from-alien-function ((type (eql 'vector)) &rest args) |
453 | (declare (ignore type)) |
454 | (destructuring-bind (element-type &optional (length '*)) args |
455 | (if (eq length '*) |
456 | (error "Can't use vector of variable size as return type") |
457 | #'(lambda (c-vector) |
458 | (map-c-vector 'vector #'identity c-vector element-type length))))) |
459 | |
9adccb27 |
460 | (defmethod cleanup-form (location (type (eql 'vector)) &rest args) |
461 | (declare (ignore type)) |
462 | (destructuring-bind (element-type &optional (length '*)) args |
463 | `(let* ((location ,location) |
464 | (length ,(if (eq length '*) |
465 | `(sap-ref-32 location ,(- +size-of-int+)) |
466 | length))) |
467 | (loop |
468 | with destroy = (destroy-function ',element-type) |
469 | for i from 0 below length |
470 | as offset = 0 then (+ offset ,(size-of element-type)) |
471 | do (funcall destroy location offset)) |
472 | (deallocate-memory ,(if (eq length '*) |
473 | `(sap+ location ,(- +size-of-int+)) |
474 | 'location))))) |
16bf1149 |
475 | |
476 | (defmethod writer-function ((type (eql 'vector)) &rest args) |
477 | (declare (ignore type)) |
478 | (destructuring-bind (element-type &optional (length '*)) args |
479 | #'(lambda (vector location &optional (offset 0)) |
480 | (setf |
481 | (sap-ref-sap location offset) |
482 | (make-c-vector element-type length vector))))) |
483 | |
484 | (defmethod reader-function ((type (eql 'vector)) &rest args) |
485 | (declare (ignore type)) |
486 | (destructuring-bind (element-type &optional (length '*)) args |
487 | (if (eq length '*) |
488 | (error "Can't create reader function for vector of variable size") |
489 | #'(lambda (location &optional (offset 0)) |
490 | (unless (null-pointer-p (sap-ref-sap location offset)) |
491 | (map-c-vector 'vector #'identity (sap-ref-sap location offset) |
492 | element-type length)))))) |
493 | |
494 | (defmethod destroy-function ((type (eql 'vector)) &rest args) |
495 | (declare (ignore type)) |
496 | (destructuring-bind (element-type &optional (length '*)) args |
497 | (if (eq length '*) |
498 | (error "Can't create destroy function for vector of variable size") |
499 | #'(lambda (location &optional (offset 0)) |
500 | (unless (null-pointer-p (sap-ref-sap location offset)) |
501 | (destroy-c-vector |
502 | (sap-ref-sap location offset) element-type length) |
503 | (setf (sap-ref-sap location offset) (make-pointer 0))))))) |
463fe62f |
504 | |
505 | |
506 | ;;;; Null terminated vector |
507 | |
508 | (defun make-0-vector (type content &optional location) |
509 | (let* ((size-of-type (size-of type)) |
510 | (location (or |
511 | location |
512 | (allocate-memory (* size-of-type (1+ (length content)))))) |
513 | (writer (writer-function type))) |
514 | (etypecase content |
515 | (vector |
516 | (loop |
517 | for element across content |
518 | as offset = 0 then (+ offset size-of-type) |
519 | do (funcall writer element location offset) |
520 | finally (setf (sap-ref-sap location offset) (make-pointer 0)))) |
521 | (list |
522 | (loop |
523 | for element in content |
524 | as offset = 0 then (+ offset size-of-type) |
525 | do (funcall writer element location offset) |
526 | finally (setf (sap-ref-sap location (+ offset size-of-type)) (make-pointer 0))))) |
527 | location)) |
528 | |
529 | |
530 | (defun map-0-vector (seqtype function location element-type) |
531 | (let ((reader (reader-function element-type)) |
532 | (size-of-element (size-of element-type))) |
533 | (case seqtype |
534 | ((nil) |
535 | (loop |
536 | as offset = 0 then (+ offset size-of-element) |
537 | until (null-pointer-p (sap-ref-sap location offset)) |
538 | do (funcall function (funcall reader location offset)))) |
539 | (list |
540 | (loop |
541 | as offset = 0 then (+ offset size-of-element) |
542 | until (null-pointer-p (sap-ref-sap location offset)) |
543 | collect (funcall function (funcall reader location offset)))) |
544 | (t |
545 | (coerce |
546 | (loop |
547 | as offset = 0 then (+ offset size-of-element) |
548 | until (null-pointer-p (sap-ref-sap location offset)) |
549 | collect (funcall function (funcall reader location offset))) |
550 | seqtype))))) |
551 | |
552 | |
553 | (defun destroy-0-vector (location element-type) |
554 | (loop |
555 | with destroy = (destroy-function element-type) |
556 | with element-size = (size-of element-type) |
557 | as offset = 0 then (+ offset element-size) |
558 | until (null-pointer-p (sap-ref-sap location offset)) |
559 | do (funcall destroy location offset)) |
560 | (deallocate-memory location)) |
561 | |
5e8ceafa |
562 | (deftype null-terminated-vector (element-type) `(vector ,element-type)) |
463fe62f |
563 | |
545712f4 |
564 | (defmethod alien-type ((type (eql 'null-terminated-vector)) &rest args) |
463fe62f |
565 | (declare (ignore type args)) |
566 | (alien-type 'pointer)) |
567 | |
545712f4 |
568 | (defmethod size-of ((type (eql 'null-terminated-vector)) &rest args) |
463fe62f |
569 | (declare (ignore type args)) |
5e8ceafa |
570 | (size-of 'pointer)) |
571 | |
572 | (defmethod to-alien-form (vector (type (eql 'null-terminated-vector)) &rest args) |
573 | (declare (ignore type)) |
574 | (destructuring-bind (element-type) args |
575 | `(make-0-vector ',element-type ,vector))) |
576 | |
577 | (defmethod from-alien-form (c-vector (type (eql 'null-terminated-vector)) &rest args) |
578 | (declare (ignore type)) |
579 | (destructuring-bind (element-type) args |
580 | `(let ((c-vector ,c-vector)) |
581 | (prog1 |
582 | (map-0-vector 'vector #'identity c-vector ',element-type) |
583 | (destroy-0-vector c-vector ',element-type))))) |
584 | |
585 | (defmethod copy-from-alien-form (c-vector (type (eql 'null-terminated-vector)) &rest args) |
586 | (declare (ignore type)) |
587 | (destructuring-bind (element-type) args |
588 | `(map-0-vector 'vector #'identity ,c-vector ',element-type))) |
589 | |
590 | (defmethod cleanup-form (location (type (eql 'null-terminated-vector)) &rest args) |
591 | (declare (ignore type)) |
592 | (destructuring-bind (element-type) args |
593 | `(destroy-0-vector ,location ',element-type))) |
463fe62f |
594 | |
545712f4 |
595 | (defmethod writer-function ((type (eql 'null-terminated-vector)) &rest args) |
463fe62f |
596 | (declare (ignore type)) |
545712f4 |
597 | (destructuring-bind (element-type) args |
463fe62f |
598 | (unless (eq (alien-type element-type) (alien-type 'pointer)) |
599 | (error "Elements in null-terminated vectors need to be of pointer types")) |
600 | #'(lambda (vector location &optional (offset 0)) |
601 | (setf |
602 | (sap-ref-sap location offset) |
603 | (make-0-vector element-type vector))))) |
604 | |
545712f4 |
605 | (defmethod reader-function ((type (eql 'null-terminated-vector)) &rest args) |
463fe62f |
606 | (declare (ignore type)) |
545712f4 |
607 | (destructuring-bind (element-type) args |
463fe62f |
608 | (unless (eq (alien-type element-type) (alien-type 'pointer)) |
609 | (error "Elements in null-terminated vectors need to be of pointer types")) |
610 | #'(lambda (location &optional (offset 0)) |
611 | (unless (null-pointer-p (sap-ref-sap location offset)) |
612 | (map-0-vector 'vector #'identity (sap-ref-sap location offset) |
613 | element-type))))) |
614 | |
545712f4 |
615 | (defmethod destroy-function ((type (eql 'null-terminated-vector)) &rest args) |
463fe62f |
616 | (declare (ignore type)) |
545712f4 |
617 | (destructuring-bind (element-type) args |
463fe62f |
618 | (unless (eq (alien-type element-type) (alien-type 'pointer)) |
619 | (error "Elements in null-terminated vectors need to be of pointer types")) |
620 | #'(lambda (location &optional (offset 0)) |
621 | (unless (null-pointer-p (sap-ref-sap location offset)) |
545712f4 |
622 | (destroy-0-vector |
463fe62f |
623 | (sap-ref-sap location offset) element-type) |
624 | (setf (sap-ref-sap location offset) (make-pointer 0)))))) |
625 | |
545712f4 |
626 | (defmethod unbound-value ((type (eql 'null-terminated-vector)) &rest args) |
627 | (declare (ignore type args)) |
463fe62f |
628 | (values t nil)) |
5e8ceafa |
629 | |
630 | |
631 | ;;; Counted vector |
632 | |
633 | (defun make-counted-vector (type content) |
634 | (let* ((size-of-type (size-of type)) |
635 | (length (length content)) |
636 | (location |
637 | (allocate-memory (+ +size-of-int+ (* size-of-type length))))) |
638 | (setf (sap-ref-32 location 0) length) |
639 | (make-c-vector type length content (sap+ location +size-of-int+)))) |
640 | |
641 | (defun map-counted-vector (seqtype function location element-type) |
642 | (let ((length (sap-ref-32 location 0))) |
643 | (map-c-vector |
644 | seqtype function (sap+ location +size-of-int+) |
645 | element-type length))) |
646 | |
647 | (defun destroy-counted-vector (location element-type) |
648 | (loop |
649 | with destroy = (destroy-function element-type) |
650 | with element-size = (size-of element-type) |
651 | for i from 0 below (sap-ref-32 location 0) |
652 | as offset = +size-of-int+ then (+ offset element-size) |
653 | do (funcall destroy location offset)) |
654 | (deallocate-memory location)) |
655 | |
656 | |
657 | (deftype counted-vector (element-type) `(vector ,element-type)) |
658 | |
659 | (defmethod alien-type ((type (eql 'counted-vector)) &rest args) |
660 | (declare (ignore type args)) |
661 | (alien-type 'pointer)) |
662 | |
663 | (defmethod size-of ((type (eql 'counted-vector)) &rest args) |
664 | (declare (ignore type args)) |
665 | (size-of 'pointer)) |
666 | |
667 | (defmethod to-alien-form (vector (type (eql 'counted-vector)) &rest args) |
668 | (declare (ignore type)) |
669 | (destructuring-bind (element-type) args |
670 | `(make-counted-vector ',element-type ,vector))) |
671 | |
672 | (defmethod from-alien-form (c-vector (type (eql 'counted-vector)) &rest args) |
673 | (declare (ignore type)) |
674 | (destructuring-bind (element-type) args |
675 | `(let ((c-vector ,c-vector)) |
676 | (prog1 |
677 | (map-counted-vector 'vector #'identity c-vector ',element-type) |
678 | (destroy-counted-vector c-vector ',element-type))))) |
679 | |
680 | (defmethod copy-from-alien-form (c-vector (type (eql 'counted-vector)) &rest args) |
681 | (declare (ignore type)) |
682 | (destructuring-bind (element-type) args |
683 | `(map-counted-vector 'vector #'identity ,c-vector ',element-type))) |
684 | |
685 | (defmethod copy-from-alien-function ((type (eql 'counted-vector)) &rest args) |
686 | (declare (ignore type)) |
687 | (destructuring-bind (element-type) args |
688 | #'(lambda (c-vector) |
689 | (map-counted-vector 'vector #'identity c-vector element-type)))) |
690 | |
691 | (defmethod cleanup-form (location (type (eql 'counted-vector)) &rest args) |
692 | (declare (ignore type)) |
693 | (destructuring-bind (element-type) args |
694 | `(destroy-counted-vector ,location ',element-type))) |
695 | |
696 | (defmethod writer-function ((type (eql 'counted-vector)) &rest args) |
697 | (declare (ignore type)) |
698 | (destructuring-bind (element-type) args |
699 | #'(lambda (vector location &optional (offset 0)) |
700 | (setf |
701 | (sap-ref-sap location offset) |
702 | (make-counted-vector element-type vector))))) |
703 | |
704 | (defmethod reader-function ((type (eql 'counted-vector)) &rest args) |
705 | (declare (ignore type)) |
706 | (destructuring-bind (element-type) args |
707 | #'(lambda (location &optional (offset 0)) |
708 | (unless (null-pointer-p (sap-ref-sap location offset)) |
709 | (map-counted-vector 'vector #'identity |
710 | (sap-ref-sap location offset) element-type))))) |
711 | |
712 | (defmethod destroy-function ((type (eql 'counted-vector)) &rest args) |
713 | (declare (ignore type)) |
714 | (destructuring-bind (element-type) args |
715 | #'(lambda (location &optional (offset 0)) |
716 | (unless (null-pointer-p (sap-ref-sap location offset)) |
717 | (destroy-counted-vector |
718 | (sap-ref-sap location offset) element-type) |
719 | (setf (sap-ref-sap location offset) (make-pointer 0)))))) |