560af5c5 |
1 | ;; Common Lisp bindings for GTK+ v1.2.x |
2 | ;; Copyright (C) 1999 Espen S. Johnsen <espejohn@online.no> |
3 | ;; |
4 | ;; This library is free software; you can redistribute it and/or |
5 | ;; modify it under the terms of the GNU Lesser General Public |
6 | ;; License as published by the Free Software Foundation; either |
7 | ;; version 2 of the License, or (at your option) any later version. |
8 | ;; |
9 | ;; This library is distributed in the hope that it will be useful, |
10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | ;; Lesser General Public License for more details. |
13 | ;; |
14 | ;; You should have received a copy of the GNU Lesser General Public |
15 | ;; License along with this library; if not, write to the Free Software |
16 | ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
17 | |
545712f4 |
18 | ;; $Id: glib.lisp,v 1.27 2005-02-14 00:44:26 espen Exp $ |
560af5c5 |
19 | |
20 | |
21 | (in-package "GLIB") |
c4e9d221 |
22 | |
560af5c5 |
23 | (use-prefix "g") |
24 | |
25 | |
26 | ;;;; Memory management |
27 | |
dba0c446 |
28 | (defbinding (allocate-memory "g_malloc0") () pointer |
560af5c5 |
29 | (size unsigned-long)) |
30 | |
dba0c446 |
31 | (defbinding (reallocate-memory "g_realloc") () pointer |
560af5c5 |
32 | (address pointer) |
33 | (size unsigned-long)) |
34 | |
3c657c71 |
35 | (defbinding (deallocate-memory "g_free") () nil |
36 | (address pointer)) |
9adccb27 |
37 | ;; (defun deallocate-memory (address) |
38 | ;; (declare (ignore address))) |
560af5c5 |
39 | |
40 | (defun copy-memory (from length &optional (to (allocate-memory length))) |
73572c12 |
41 | (;#+cmu kernel:system-area-copy |
42 | ;#+sbcl sb-impl::system-area-copy |
43 | system-area-copy from 0 to 0 (* 8 length)) |
560af5c5 |
44 | to) |
45 | |
46 | |
c4e9d221 |
47 | ;;;; User data mechanism |
48 | |
49 | (internal *user-data* *user-data-count*) |
50 | |
c4e9d221 |
51 | (defvar *user-data* (make-hash-table)) |
52 | (defvar *user-data-count* 0) |
53 | |
54 | (defun register-user-data (object &optional destroy-function) |
55 | (check-type destroy-function (or null symbol function)) |
56 | (incf *user-data-count*) |
57 | (setf |
58 | (gethash *user-data-count* *user-data*) |
59 | (cons object destroy-function)) |
60 | *user-data-count*) |
61 | |
62 | (defun find-user-data (id) |
63 | (check-type id fixnum) |
64 | (multiple-value-bind (user-data p) (gethash id *user-data*) |
65 | (values (car user-data) p))) |
66 | |
7e531ed5 |
67 | (defun user-data-exists-p (id) |
68 | (nth-value 1 (find-user-data id))) |
69 | |
c9219df2 |
70 | (defun update-user-data (id object) |
71 | (check-type id fixnum) |
72 | (multiple-value-bind (user-data exists-p) (gethash id *user-data*) |
73 | (cond |
74 | ((not exists-p) (error "User data id ~A does not exist" id)) |
75 | (t |
76 | (when (cdr user-data) |
77 | (funcall (cdr user-data) (car user-data))) |
78 | (setf (car user-data) object))))) |
79 | |
c4e9d221 |
80 | (defun destroy-user-data (id) |
81 | (check-type id fixnum) |
82 | (let ((user-data (gethash id *user-data*))) |
83 | (when (cdr user-data) |
84 | (funcall (cdr user-data) (car user-data)))) |
85 | (remhash id *user-data*)) |
86 | |
560af5c5 |
87 | |
0aef1da8 |
88 | ;;;; Quarks |
89 | |
90 | (deftype quark () 'unsigned) |
91 | |
5cae32e1 |
92 | (defbinding %quark-from-string () quark |
415444ae |
93 | (string string)) |
94 | |
7e531ed5 |
95 | (defun quark-intern (object) |
96 | (etypecase object |
97 | (quark object) |
98 | (string (%quark-from-string object)) |
99 | (symbol (%quark-from-string (format nil "clg-~A:~A" |
100 | (package-name (symbol-package object)) |
101 | object))))) |
0aef1da8 |
102 | |
7e531ed5 |
103 | (defbinding quark-to-string () (copy-of string) |
104 | (quark quark)) |
0aef1da8 |
105 | |
106 | |
3846c0b6 |
107 | ;;;; Linked list (GList) |
560af5c5 |
108 | |
72e5ffec |
109 | (deftype glist (type) |
9adccb27 |
110 | `(or (null (cons ,type list)))) |
560af5c5 |
111 | |
72e5ffec |
112 | (defbinding (%glist-append "g_list_append") () pointer |
3846c0b6 |
113 | (glist pointer) |
72e5ffec |
114 | (nil null)) |
3846c0b6 |
115 | |
9adccb27 |
116 | (defun make-glist (type list) |
72e5ffec |
117 | (loop |
118 | with writer = (writer-function type) |
119 | for element in list |
120 | as glist = (%glist-append (or glist (make-pointer 0))) |
121 | do (funcall writer element glist) |
122 | finally (return glist))) |
560af5c5 |
123 | |
560af5c5 |
124 | (defun glist-next (glist) |
125 | (unless (null-pointer-p glist) |
9adccb27 |
126 | (sap-ref-sap glist +size-of-pointer+))) |
560af5c5 |
127 | |
9adccb27 |
128 | ;; Also used for gslists |
129 | (defun map-glist (seqtype function glist element-type) |
130 | (let ((reader (reader-function element-type))) |
131 | (case seqtype |
132 | ((nil) |
133 | (loop |
134 | as tmp = glist then (glist-next tmp) |
135 | until (null-pointer-p tmp) |
136 | do (funcall function (funcall reader tmp)))) |
137 | (list |
138 | (loop |
139 | as tmp = glist then (glist-next tmp) |
140 | until (null-pointer-p tmp) |
141 | collect (funcall function (funcall reader tmp)))) |
142 | (t |
143 | (coerce |
144 | (loop |
145 | as tmp = glist then (glist-next tmp) |
146 | until (null-pointer-p tmp) |
147 | collect (funcall function (funcall reader tmp))) |
148 | seqtype))))) |
149 | |
dba0c446 |
150 | (defbinding (glist-free "g_list_free") () nil |
560af5c5 |
151 | (glist pointer)) |
152 | |
72e5ffec |
153 | (defun destroy-glist (glist element-type) |
154 | (loop |
155 | with destroy = (destroy-function element-type) |
156 | as tmp = glist then (glist-next tmp) |
157 | until (null-pointer-p tmp) |
158 | do (funcall destroy tmp 0)) |
159 | (glist-free glist)) |
415444ae |
160 | |
9adccb27 |
161 | (defmethod alien-type ((type (eql 'glist)) &rest args) |
162 | (declare (ignore type args)) |
163 | (alien-type 'pointer)) |
164 | |
165 | (defmethod size-of ((type (eql 'glist)) &rest args) |
166 | (declare (ignore type args)) |
415444ae |
167 | (size-of 'pointer)) |
560af5c5 |
168 | |
9adccb27 |
169 | (defmethod to-alien-form (list (type (eql 'glist)) &rest args) |
170 | (declare (ignore type)) |
171 | (destructuring-bind (element-type) args |
172 | `(make-glist ',element-type ,list))) |
173 | |
174 | (defmethod to-alien-function ((type (eql 'glist)) &rest args) |
8755b1a5 |
175 | (declare (ignore type)) |
9adccb27 |
176 | (destructuring-bind (element-type) args |
177 | #'(lambda (list) |
178 | (make-glist element-type list)))) |
179 | |
180 | (defmethod from-alien-form (glist (type (eql 'glist)) &rest args) |
181 | (declare (ignore type)) |
182 | (destructuring-bind (element-type) args |
560af5c5 |
183 | `(let ((glist ,glist)) |
9adccb27 |
184 | (unwind-protect |
185 | (map-glist 'list #'identity glist ',element-type) |
72e5ffec |
186 | (destroy-glist glist ',element-type))))) |
9adccb27 |
187 | |
188 | (defmethod from-alien-function ((type (eql 'glist)) &rest args) |
189 | (declare (ignore type)) |
190 | (destructuring-bind (element-type) args |
191 | #'(lambda (glist) |
192 | (unwind-protect |
193 | (map-glist 'list #'identity glist element-type) |
72e5ffec |
194 | (destroy-glist glist element-type))))) |
195 | |
196 | (defmethod copy-from-alien-form (glist (type (eql 'glist)) &rest args) |
197 | (declare (ignore type)) |
198 | (destructuring-bind (element-type) args |
199 | `(map-glist 'list #'identity ,glist ',element-type))) |
200 | |
201 | (defmethod copy-from-alien-function ((type (eql 'glist)) &rest args) |
202 | (declare (ignore type)) |
203 | (destructuring-bind (element-type) args |
204 | #'(lambda (glist) |
205 | (map-glist 'list #'identity glist element-type)))) |
9adccb27 |
206 | |
207 | (defmethod cleanup-form (glist (type (eql 'glist)) &rest args) |
72e5ffec |
208 | (declare (ignore type)) |
209 | (destructuring-bind (element-type) args |
210 | `(destroy-glist ,glist ',element-type))) |
9adccb27 |
211 | |
212 | (defmethod cleanup-function ((type (eql 'glist)) &rest args) |
e8caa25a |
213 | (declare (ignore type)) |
72e5ffec |
214 | (destructuring-bind (element-type) args |
215 | #'(lambda (glist) |
216 | (destroy-glist glist element-type)))) |
560af5c5 |
217 | |
e8caa25a |
218 | (defmethod writer-function ((type (eql 'glist)) &rest args) |
219 | (declare (ignore type)) |
220 | (destructuring-bind (element-type) args |
221 | #'(lambda (list location &optional (offset 0)) |
222 | (setf |
223 | (sap-ref-sap location offset) |
224 | (make-glist element-type list))))) |
225 | |
226 | (defmethod reader-function ((type (eql 'glist)) &rest args) |
227 | (declare (ignore type)) |
228 | (destructuring-bind (element-type) args |
229 | #'(lambda (location &optional (offset 0)) |
230 | (unless (null-pointer-p (sap-ref-sap location offset)) |
231 | (map-glist 'list #'identity (sap-ref-sap location offset) element-type))))) |
232 | |
233 | (defmethod destroy-function ((type (eql 'glist)) &rest args) |
234 | (declare (ignore type)) |
235 | (destructuring-bind (element-type) args |
236 | #'(lambda (location &optional (offset 0)) |
237 | (unless (null-pointer-p (sap-ref-sap location offset)) |
238 | (destroy-glist (sap-ref-sap location offset) element-type) |
239 | (setf (sap-ref-sap location offset) (make-pointer 0)))))) |
240 | |
241 | |
560af5c5 |
242 | |
3846c0b6 |
243 | ;;;; Single linked list (GSList) |
244 | |
245 | (deftype gslist (type) `(or (null (cons ,type list)))) |
246 | |
72e5ffec |
247 | (defbinding (%gslist-prepend "g_slist_prepend") () pointer |
3846c0b6 |
248 | (gslist pointer) |
72e5ffec |
249 | (nil null)) |
3846c0b6 |
250 | |
9adccb27 |
251 | (defun make-gslist (type list) |
72e5ffec |
252 | (loop |
253 | with writer = (writer-function type) |
254 | for element in (reverse list) |
255 | as gslist = (%gslist-prepend (or gslist (make-pointer 0))) |
256 | do (funcall writer element gslist) |
257 | finally (return gslist))) |
9adccb27 |
258 | |
dba0c446 |
259 | (defbinding (gslist-free "g_slist_free") () nil |
3846c0b6 |
260 | (gslist pointer)) |
261 | |
72e5ffec |
262 | (defun destroy-gslist (gslist element-type) |
263 | (loop |
264 | with destroy = (destroy-function element-type) |
265 | as tmp = gslist then (glist-next tmp) |
266 | until (null-pointer-p tmp) |
267 | do (funcall destroy tmp 0)) |
268 | (gslist-free gslist)) |
3846c0b6 |
269 | |
9adccb27 |
270 | (defmethod alien-type ((type (eql 'gslist)) &rest args) |
271 | (declare (ignore type args)) |
272 | (alien-type 'pointer)) |
273 | |
274 | (defmethod size-of ((type (eql 'gslist)) &rest args) |
275 | (declare (ignore type args)) |
3846c0b6 |
276 | (size-of 'pointer)) |
277 | |
9adccb27 |
278 | (defmethod to-alien-form (list (type (eql 'gslist)) &rest args) |
279 | (declare (ignore type)) |
280 | (destructuring-bind (element-type) args |
281 | `(make-sglist ',element-type ,list))) |
282 | |
283 | (defmethod to-alien-function ((type (eql 'gslist)) &rest args) |
8755b1a5 |
284 | (declare (ignore type)) |
9adccb27 |
285 | (destructuring-bind (element-type) args |
286 | #'(lambda (list) |
287 | (make-gslist element-type list)))) |
288 | |
289 | (defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args) |
290 | (declare (ignore type)) |
291 | (destructuring-bind (element-type) args |
3846c0b6 |
292 | `(let ((gslist ,gslist)) |
9adccb27 |
293 | (unwind-protect |
294 | (map-glist 'list #'identity gslist ',element-type) |
72e5ffec |
295 | (destroy-gslist gslist ',element-type))))) |
3846c0b6 |
296 | |
9adccb27 |
297 | (defmethod from-alien-function ((type (eql 'gslist)) &rest args) |
298 | (declare (ignore type)) |
299 | (destructuring-bind (element-type) args |
300 | #'(lambda (gslist) |
301 | (unwind-protect |
302 | (map-glist 'list #'identity gslist element-type) |
72e5ffec |
303 | (destroy-gslist gslist element-type))))) |
304 | |
305 | (defmethod copy-from-alien-form (gslist (type (eql 'gslist)) &rest args) |
306 | (declare (ignore type)) |
307 | (destructuring-bind (element-type) args |
308 | `(map-glist 'list #'identity ,gslist ',element-type))) |
309 | |
73572c12 |
310 | (defmethod copy-from-alien-function ((type (eql 'gslist)) &rest args) |
72e5ffec |
311 | (declare (ignore type)) |
312 | (destructuring-bind (element-type) args |
313 | #'(lambda (gslist) |
314 | (map-glist 'list #'identity gslist element-type)))) |
3846c0b6 |
315 | |
72e5ffec |
316 | (defmethod cleanup-form (gslist (type (eql 'gslist)) &rest args) |
e8caa25a |
317 | (declare (ignore type)) |
72e5ffec |
318 | (destructuring-bind (element-type) args |
319 | `(destroy-gslist ,gslist ',element-type))) |
3846c0b6 |
320 | |
9adccb27 |
321 | (defmethod cleanup-function ((type (eql 'gslist)) &rest args) |
e8caa25a |
322 | (declare (ignore type)) |
72e5ffec |
323 | (destructuring-bind (element-type) args |
324 | #'(lambda (gslist) |
325 | (destroy-gslist gslist element-type)))) |
415444ae |
326 | |
e8caa25a |
327 | (defmethod writer-function ((type (eql 'gslist)) &rest args) |
328 | (declare (ignore type)) |
329 | (destructuring-bind (element-type) args |
330 | #'(lambda (list location &optional (offset 0)) |
331 | (setf |
332 | (sap-ref-sap location offset) |
333 | (make-gslist element-type list))))) |
334 | |
335 | (defmethod reader-function ((type (eql 'gslist)) &rest args) |
336 | (declare (ignore type)) |
337 | (destructuring-bind (element-type) args |
338 | #'(lambda (location &optional (offset 0)) |
339 | (unless (null-pointer-p (sap-ref-sap location offset)) |
340 | (map-glist 'list #'identity (sap-ref-sap location offset) element-type))))) |
341 | |
342 | (defmethod destroy-function ((type (eql 'gslist)) &rest args) |
343 | (declare (ignore type)) |
344 | (destructuring-bind (element-type) args |
345 | #'(lambda (location &optional (offset 0)) |
346 | (unless (null-pointer-p (sap-ref-sap location offset)) |
347 | (destroy-gslist (sap-ref-sap location offset) element-type) |
348 | (setf (sap-ref-sap location offset) (make-pointer 0)))))) |
5cae32e1 |
349 | |
415444ae |
350 | |
9adccb27 |
351 | ;;; Vector |
415444ae |
352 | |
9adccb27 |
353 | (defun make-c-vector (type length &optional content location) |
354 | (let* ((size-of-type (size-of type)) |
355 | (location (or location (allocate-memory (* size-of-type length)))) |
356 | (writer (writer-function type))) |
814ccf77 |
357 | (etypecase content |
358 | (vector |
359 | (loop |
360 | for element across content |
361 | for i from 0 below length |
362 | as offset = 0 then (+ offset size-of-type) |
363 | do (funcall writer element location offset))) |
364 | (list |
365 | (loop |
366 | for element in content |
367 | for i from 0 below length |
368 | as offset = 0 then (+ offset size-of-type) |
369 | do (funcall writer element location offset)))) |
9adccb27 |
370 | location)) |
371 | |
372 | |
373 | (defun map-c-vector (seqtype function location element-type length) |
374 | (let ((reader (reader-function element-type)) |
375 | (size-of-element (size-of element-type))) |
dba0c446 |
376 | (case seqtype |
377 | ((nil) |
9adccb27 |
378 | (loop |
379 | for i from 0 below length |
380 | as offset = 0 then (+ offset size-of-element) |
381 | do (funcall function (funcall reader location offset)))) |
dba0c446 |
382 | (list |
9adccb27 |
383 | (loop |
384 | for i from 0 below length |
385 | as offset = 0 then (+ offset size-of-element) |
386 | collect (funcall function (funcall reader location offset)))) |
dba0c446 |
387 | (t |
9adccb27 |
388 | (loop |
389 | with sequence = (make-sequence seqtype length) |
390 | for i from 0 below length |
391 | as offset = 0 then (+ offset size-of-element) |
392 | do (setf |
dba0c446 |
393 | (elt sequence i) |
9adccb27 |
394 | (funcall function (funcall reader location offset))) |
395 | finally (return sequence)))))) |
396 | |
397 | |
72e5ffec |
398 | (defun destroy-c-vector (location element-type length) |
399 | (loop |
400 | with destroy = (destroy-function element-type) |
401 | with element-size = (size-of element-type) |
402 | for i from 0 below length |
403 | as offset = 0 then (+ offset element-size) |
404 | do (funcall destroy location offset)) |
405 | (deallocate-memory location)) |
406 | |
407 | |
9adccb27 |
408 | (defmethod alien-type ((type (eql 'vector)) &rest args) |
409 | (declare (ignore type args)) |
410 | (alien-type 'pointer)) |
411 | |
412 | (defmethod size-of ((type (eql 'vector)) &rest args) |
413 | (declare (ignore type args)) |
414 | (size-of 'pointer)) |
415 | |
416 | (defmethod to-alien-form (vector (type (eql 'vector)) &rest args) |
417 | (declare (ignore type)) |
418 | (destructuring-bind (element-type &optional (length '*)) args |
419 | (if (eq length '*) |
420 | `(let* ((vector ,vector) |
421 | (location (sap+ |
422 | (allocate-memory (+ ,+size-of-int+ |
423 | (* ,(size-of element-type) |
424 | (length vector)))) |
425 | ,+size-of-int+))) |
426 | (make-c-vector ',element-type (length vector) vector location) |
427 | (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector)) |
428 | location) |
429 | `(make-c-vector ',element-type ,length ,vector)))) |
430 | |
72e5ffec |
431 | (defmethod from-alien-form (c-vector (type (eql 'vector)) &rest args) |
432 | (declare (ignore type)) |
433 | (destructuring-bind (element-type &optional (length '*)) args |
434 | (if (eq length '*) |
435 | (error "Can't use vector of variable size as return type") |
436 | `(let ((c-vector ,c-vector)) |
437 | (prog1 |
c9219df2 |
438 | (map-c-vector 'vector #'identity c-vector ',element-type ,length) |
72e5ffec |
439 | (destroy-c-vector c-vector ',element-type ,length)))))) |
440 | |
441 | (defmethod copy-from-alien-form (c-vector (type (eql 'vector)) &rest args) |
9adccb27 |
442 | (declare (ignore type)) |
443 | (destructuring-bind (element-type &optional (length '*)) args |
444 | (if (eq length '*) |
445 | (error "Can't use vector of variable size as return type") |
c9219df2 |
446 | `(map-c-vector 'vector #'identity ,c-vector ',element-type ',length)))) |
9adccb27 |
447 | |
448 | (defmethod cleanup-form (location (type (eql 'vector)) &rest args) |
449 | (declare (ignore type)) |
450 | (destructuring-bind (element-type &optional (length '*)) args |
451 | `(let* ((location ,location) |
452 | (length ,(if (eq length '*) |
453 | `(sap-ref-32 location ,(- +size-of-int+)) |
454 | length))) |
455 | (loop |
456 | with destroy = (destroy-function ',element-type) |
457 | for i from 0 below length |
458 | as offset = 0 then (+ offset ,(size-of element-type)) |
459 | do (funcall destroy location offset)) |
460 | (deallocate-memory ,(if (eq length '*) |
461 | `(sap+ location ,(- +size-of-int+)) |
462 | 'location))))) |
16bf1149 |
463 | |
464 | (defmethod writer-function ((type (eql 'vector)) &rest args) |
465 | (declare (ignore type)) |
466 | (destructuring-bind (element-type &optional (length '*)) args |
467 | #'(lambda (vector location &optional (offset 0)) |
468 | (setf |
469 | (sap-ref-sap location offset) |
470 | (make-c-vector element-type length vector))))) |
471 | |
472 | (defmethod reader-function ((type (eql 'vector)) &rest args) |
473 | (declare (ignore type)) |
474 | (destructuring-bind (element-type &optional (length '*)) args |
475 | (if (eq length '*) |
476 | (error "Can't create reader function for vector of variable size") |
477 | #'(lambda (location &optional (offset 0)) |
478 | (unless (null-pointer-p (sap-ref-sap location offset)) |
479 | (map-c-vector 'vector #'identity (sap-ref-sap location offset) |
480 | element-type length)))))) |
481 | |
482 | (defmethod destroy-function ((type (eql 'vector)) &rest args) |
483 | (declare (ignore type)) |
484 | (destructuring-bind (element-type &optional (length '*)) args |
485 | (if (eq length '*) |
486 | (error "Can't create destroy function for vector of variable size") |
487 | #'(lambda (location &optional (offset 0)) |
488 | (unless (null-pointer-p (sap-ref-sap location offset)) |
489 | (destroy-c-vector |
490 | (sap-ref-sap location offset) element-type length) |
491 | (setf (sap-ref-sap location offset) (make-pointer 0))))))) |
463fe62f |
492 | |
493 | |
494 | ;;;; Null terminated vector |
495 | |
496 | (defun make-0-vector (type content &optional location) |
497 | (let* ((size-of-type (size-of type)) |
498 | (location (or |
499 | location |
500 | (allocate-memory (* size-of-type (1+ (length content)))))) |
501 | (writer (writer-function type))) |
502 | (etypecase content |
503 | (vector |
504 | (loop |
505 | for element across content |
506 | as offset = 0 then (+ offset size-of-type) |
507 | do (funcall writer element location offset) |
508 | finally (setf (sap-ref-sap location offset) (make-pointer 0)))) |
509 | (list |
510 | (loop |
511 | for element in content |
512 | as offset = 0 then (+ offset size-of-type) |
513 | do (funcall writer element location offset) |
514 | finally (setf (sap-ref-sap location (+ offset size-of-type)) (make-pointer 0))))) |
515 | location)) |
516 | |
517 | |
518 | (defun map-0-vector (seqtype function location element-type) |
519 | (let ((reader (reader-function element-type)) |
520 | (size-of-element (size-of element-type))) |
521 | (case seqtype |
522 | ((nil) |
523 | (loop |
524 | as offset = 0 then (+ offset size-of-element) |
525 | until (null-pointer-p (sap-ref-sap location offset)) |
526 | do (funcall function (funcall reader location offset)))) |
527 | (list |
528 | (loop |
529 | as offset = 0 then (+ offset size-of-element) |
530 | until (null-pointer-p (sap-ref-sap location offset)) |
531 | collect (funcall function (funcall reader location offset)))) |
532 | (t |
533 | (coerce |
534 | (loop |
535 | as offset = 0 then (+ offset size-of-element) |
536 | until (null-pointer-p (sap-ref-sap location offset)) |
537 | collect (funcall function (funcall reader location offset))) |
538 | seqtype))))) |
539 | |
540 | |
541 | (defun destroy-0-vector (location element-type) |
542 | (loop |
543 | with destroy = (destroy-function element-type) |
544 | with element-size = (size-of element-type) |
545 | as offset = 0 then (+ offset element-size) |
546 | until (null-pointer-p (sap-ref-sap location offset)) |
547 | do (funcall destroy location offset)) |
548 | (deallocate-memory location)) |
549 | |
550 | |
545712f4 |
551 | (defmethod alien-type ((type (eql 'null-terminated-vector)) &rest args) |
463fe62f |
552 | (declare (ignore type args)) |
553 | (alien-type 'pointer)) |
554 | |
545712f4 |
555 | (defmethod size-of ((type (eql 'null-terminated-vector)) &rest args) |
463fe62f |
556 | (declare (ignore type args)) |
557 | (alien-type 'pointer)) |
558 | |
545712f4 |
559 | (defmethod writer-function ((type (eql 'null-terminated-vector)) &rest args) |
463fe62f |
560 | (declare (ignore type)) |
545712f4 |
561 | (destructuring-bind (element-type) args |
463fe62f |
562 | (unless (eq (alien-type element-type) (alien-type 'pointer)) |
563 | (error "Elements in null-terminated vectors need to be of pointer types")) |
564 | #'(lambda (vector location &optional (offset 0)) |
565 | (setf |
566 | (sap-ref-sap location offset) |
567 | (make-0-vector element-type vector))))) |
568 | |
545712f4 |
569 | (defmethod reader-function ((type (eql 'null-terminated-vector)) &rest args) |
463fe62f |
570 | (declare (ignore type)) |
545712f4 |
571 | (destructuring-bind (element-type) args |
463fe62f |
572 | (unless (eq (alien-type element-type) (alien-type 'pointer)) |
573 | (error "Elements in null-terminated vectors need to be of pointer types")) |
574 | #'(lambda (location &optional (offset 0)) |
575 | (unless (null-pointer-p (sap-ref-sap location offset)) |
576 | (map-0-vector 'vector #'identity (sap-ref-sap location offset) |
577 | element-type))))) |
578 | |
545712f4 |
579 | (defmethod destroy-function ((type (eql 'null-terminated-vector)) &rest args) |
463fe62f |
580 | (declare (ignore type)) |
545712f4 |
581 | (destructuring-bind (element-type) args |
463fe62f |
582 | (unless (eq (alien-type element-type) (alien-type 'pointer)) |
583 | (error "Elements in null-terminated vectors need to be of pointer types")) |
584 | #'(lambda (location &optional (offset 0)) |
585 | (unless (null-pointer-p (sap-ref-sap location offset)) |
545712f4 |
586 | (destroy-0-vector |
463fe62f |
587 | (sap-ref-sap location offset) element-type) |
588 | (setf (sap-ref-sap location offset) (make-pointer 0)))))) |
589 | |
545712f4 |
590 | (defmethod unbound-value ((type (eql 'null-terminated-vector)) &rest args) |
591 | (declare (ignore type args)) |
463fe62f |
592 | (values t nil)) |