1 ;; Common Lisp bindings for GTK+ 2.x
2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
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:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
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.
23 ;; $Id: glib.lisp,v 1.35 2006-02-19 22:34:28 espen Exp $
31 ;;;; Memory management
33 (defbinding (allocate-memory "g_malloc0") () pointer
36 (defbinding (reallocate-memory "g_realloc") () pointer
40 (defbinding (deallocate-memory "g_free") () nil
42 ;; (defun deallocate-memory (address)
43 ;; (declare (ignore address)))
45 (defun copy-memory (from length &optional (to (allocate-memory length)))
46 #+cmu(system-area-copy from 0 to 0 (* 8 length))
47 #+sbcl(system-area-ub8-copy from 0 to 0 length)
50 (defun clear-memory (from length)
51 #+cmu(system-area-fill 0 0 from 0 (* 8 length))
52 #+sbcl(system-area-ub8-fill 0 from 0 length))
54 (defmacro with-allocated-memory ((var size) &body body)
56 (let ((alien (make-symbol "ALIEN"))
58 `(with-alien ((,alien (array #+sbcl(sb-alien:unsigned 8) #+cmu(alien:unsigned 8) ,size)))
59 (let ((,var (alien-sap ,alien)))
60 (clear-memory ,var ,size)
62 `(let ((,var (allocate-memory ,size)))
65 (deallocate-memory ,var)))))
68 ;;;; User data mechanism
70 (internal *user-data* *user-data-count*)
72 (defvar *user-data* (make-hash-table))
73 (defvar *user-data-count* 0)
75 (defun register-user-data (object &optional destroy-function)
76 (check-type destroy-function (or null symbol function))
77 (incf *user-data-count*)
79 (gethash *user-data-count* *user-data*)
80 (cons object destroy-function))
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)))
88 (defun user-data-exists-p (id)
89 (nth-value 1 (find-user-data id)))
91 (defun update-user-data (id object)
92 (check-type id fixnum)
93 (multiple-value-bind (user-data exists-p) (gethash id *user-data*)
95 ((not exists-p) (error "User data id ~A does not exist" id))
98 (funcall (cdr user-data) (car user-data)))
99 (setf (car user-data) object)))))
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*))
111 (deftype quark () 'unsigned)
113 (defbinding %quark-from-string () quark
116 (defun quark-intern (object)
119 (string (%quark-from-string object))
120 (symbol (%quark-from-string (format nil "clg-~A:~A"
121 (package-name (symbol-package object))
124 (defbinding quark-to-string () (copy-of string)
128 ;;;; Linked list (GList)
130 (deftype glist (type)
131 `(or (null (cons ,type list))))
133 (defbinding (%glist-append "g_list_append") () pointer
137 (defun make-glist (type list)
139 with writer = (writer-function type)
141 as glist = (%glist-append (or glist (make-pointer 0)))
142 do (funcall writer element glist)
143 finally (return glist)))
145 (defun glist-next (glist)
146 (unless (null-pointer-p glist)
147 (sap-ref-sap glist +size-of-pointer+)))
149 ;; Also used for gslists
150 (defun map-glist (seqtype function glist element-type)
151 (let ((reader (reader-function element-type)))
155 as tmp = glist then (glist-next tmp)
156 until (null-pointer-p tmp)
157 do (funcall function (funcall reader tmp))))
160 as tmp = glist then (glist-next tmp)
161 until (null-pointer-p tmp)
162 collect (funcall function (funcall reader tmp))))
166 as tmp = glist then (glist-next tmp)
167 until (null-pointer-p tmp)
168 collect (funcall function (funcall reader tmp)))
171 (defbinding (glist-free "g_list_free") () nil
174 (defun destroy-glist (glist element-type)
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))
182 (defmethod alien-type ((type (eql 'glist)) &rest args)
183 (declare (ignore type args))
184 (alien-type 'pointer))
186 (defmethod size-of ((type (eql 'glist)) &rest args)
187 (declare (ignore type args))
190 (defmethod to-alien-form (list (type (eql 'glist)) &rest args)
191 (declare (ignore type))
192 (destructuring-bind (element-type) args
193 `(make-glist ',element-type ,list)))
195 (defmethod to-alien-function ((type (eql 'glist)) &rest args)
196 (declare (ignore type))
197 (destructuring-bind (element-type) args
199 (make-glist element-type list))))
201 (defmethod from-alien-form (glist (type (eql 'glist)) &rest args)
202 (declare (ignore type))
203 (destructuring-bind (element-type) args
204 `(let ((glist ,glist))
206 (map-glist 'list #'identity glist ',element-type)
207 (destroy-glist glist ',element-type)))))
209 (defmethod from-alien-function ((type (eql 'glist)) &rest args)
210 (declare (ignore type))
211 (destructuring-bind (element-type) args
214 (map-glist 'list #'identity glist element-type)
215 (destroy-glist glist element-type)))))
217 (defmethod copy-from-alien-form (glist (type (eql 'glist)) &rest args)
218 (declare (ignore type))
219 (destructuring-bind (element-type) args
220 `(map-glist 'list #'identity ,glist ',element-type)))
222 (defmethod copy-from-alien-function ((type (eql 'glist)) &rest args)
223 (declare (ignore type))
224 (destructuring-bind (element-type) args
226 (map-glist 'list #'identity glist element-type))))
228 (defmethod cleanup-form (glist (type (eql 'glist)) &rest args)
229 (declare (ignore type))
230 (destructuring-bind (element-type) args
231 `(destroy-glist ,glist ',element-type)))
233 (defmethod cleanup-function ((type (eql 'glist)) &rest args)
234 (declare (ignore type))
235 (destructuring-bind (element-type) args
237 (destroy-glist glist element-type))))
239 (defmethod writer-function ((type (eql 'glist)) &rest args)
240 (declare (ignore type))
241 (destructuring-bind (element-type) args
242 #'(lambda (list location &optional (offset 0))
244 (sap-ref-sap location offset)
245 (make-glist element-type list)))))
247 (defmethod reader-function ((type (eql 'glist)) &rest args)
248 (declare (ignore type))
249 (destructuring-bind (element-type) args
250 #'(lambda (location &optional (offset 0) weak-p)
251 (declare (ignore weak-p))
252 (unless (null-pointer-p (sap-ref-sap location offset))
253 (map-glist 'list #'identity (sap-ref-sap location offset) element-type)))))
255 (defmethod destroy-function ((type (eql 'glist)) &rest args)
256 (declare (ignore type))
257 (destructuring-bind (element-type) args
258 #'(lambda (location &optional (offset 0))
259 (unless (null-pointer-p (sap-ref-sap location offset))
260 (destroy-glist (sap-ref-sap location offset) element-type)
261 (setf (sap-ref-sap location offset) (make-pointer 0))))))
265 ;;;; Single linked list (GSList)
267 (deftype gslist (type) `(or (null (cons ,type list))))
269 (defbinding (%gslist-prepend "g_slist_prepend") () pointer
273 (defun make-gslist (type list)
275 with writer = (writer-function type)
276 for element in (reverse list)
277 as gslist = (%gslist-prepend (or gslist (make-pointer 0)))
278 do (funcall writer element gslist)
279 finally (return gslist)))
281 (defbinding (gslist-free "g_slist_free") () nil
284 (defun destroy-gslist (gslist element-type)
286 with destroy = (destroy-function element-type)
287 as tmp = gslist then (glist-next tmp)
288 until (null-pointer-p tmp)
289 do (funcall destroy tmp 0))
290 (gslist-free gslist))
292 (defmethod alien-type ((type (eql 'gslist)) &rest args)
293 (declare (ignore type args))
294 (alien-type 'pointer))
296 (defmethod size-of ((type (eql 'gslist)) &rest args)
297 (declare (ignore type args))
300 (defmethod to-alien-form (list (type (eql 'gslist)) &rest args)
301 (declare (ignore type))
302 (destructuring-bind (element-type) args
303 `(make-sglist ',element-type ,list)))
305 (defmethod to-alien-function ((type (eql 'gslist)) &rest args)
306 (declare (ignore type))
307 (destructuring-bind (element-type) args
309 (make-gslist element-type list))))
311 (defmethod from-alien-form (gslist (type (eql 'gslist)) &rest args)
312 (declare (ignore type))
313 (destructuring-bind (element-type) args
314 `(let ((gslist ,gslist))
316 (map-glist 'list #'identity gslist ',element-type)
317 (destroy-gslist gslist ',element-type)))))
319 (defmethod from-alien-function ((type (eql 'gslist)) &rest args)
320 (declare (ignore type))
321 (destructuring-bind (element-type) args
324 (map-glist 'list #'identity gslist element-type)
325 (destroy-gslist gslist element-type)))))
327 (defmethod copy-from-alien-form (gslist (type (eql 'gslist)) &rest args)
328 (declare (ignore type))
329 (destructuring-bind (element-type) args
330 `(map-glist 'list #'identity ,gslist ',element-type)))
332 (defmethod copy-from-alien-function ((type (eql 'gslist)) &rest args)
333 (declare (ignore type))
334 (destructuring-bind (element-type) args
336 (map-glist 'list #'identity gslist element-type))))
338 (defmethod cleanup-form (gslist (type (eql 'gslist)) &rest args)
339 (declare (ignore type))
340 (destructuring-bind (element-type) args
341 `(destroy-gslist ,gslist ',element-type)))
343 (defmethod cleanup-function ((type (eql 'gslist)) &rest args)
344 (declare (ignore type))
345 (destructuring-bind (element-type) args
347 (destroy-gslist gslist element-type))))
349 (defmethod writer-function ((type (eql 'gslist)) &rest args)
350 (declare (ignore type))
351 (destructuring-bind (element-type) args
352 #'(lambda (list location &optional (offset 0))
354 (sap-ref-sap location offset)
355 (make-gslist element-type list)))))
357 (defmethod reader-function ((type (eql 'gslist)) &rest args)
358 (declare (ignore type))
359 (destructuring-bind (element-type) args
360 #'(lambda (location &optional (offset 0) weak-p)
361 (declare (ignore weak-p))
362 (unless (null-pointer-p (sap-ref-sap location offset))
363 (map-glist 'list #'identity (sap-ref-sap location offset) element-type)))))
365 (defmethod destroy-function ((type (eql 'gslist)) &rest args)
366 (declare (ignore type))
367 (destructuring-bind (element-type) args
368 #'(lambda (location &optional (offset 0))
369 (unless (null-pointer-p (sap-ref-sap location offset))
370 (destroy-gslist (sap-ref-sap location offset) element-type)
371 (setf (sap-ref-sap location offset) (make-pointer 0))))))
376 (defun make-c-vector (type length &optional content location)
377 (let* ((size-of-type (size-of type))
378 (location (or location (allocate-memory (* size-of-type length))))
379 (writer (writer-function type)))
383 for element across content
384 for i from 0 below length
385 as offset = 0 then (+ offset size-of-type)
386 do (funcall writer element location offset)))
389 for element in content
390 for i from 0 below length
391 as offset = 0 then (+ offset size-of-type)
392 do (funcall writer element location offset))))
396 (defun map-c-vector (seqtype function location element-type length)
397 (let ((reader (reader-function element-type))
398 (size-of-element (size-of element-type)))
402 for i from 0 below length
403 as offset = 0 then (+ offset size-of-element)
404 do (funcall function (funcall reader location offset))))
407 for i from 0 below length
408 as offset = 0 then (+ offset size-of-element)
409 collect (funcall function (funcall reader location offset))))
412 with sequence = (make-sequence seqtype length)
413 for i from 0 below length
414 as offset = 0 then (+ offset size-of-element)
417 (funcall function (funcall reader location offset)))
418 finally (return sequence))))))
421 (defun destroy-c-vector (location element-type length)
423 with destroy = (destroy-function element-type)
424 with element-size = (size-of element-type)
425 for i from 0 below length
426 as offset = 0 then (+ offset element-size)
427 do (funcall destroy location offset))
428 (deallocate-memory location))
431 (defmethod alien-type ((type (eql 'vector)) &rest args)
432 (declare (ignore type args))
433 (alien-type 'pointer))
435 (defmethod size-of ((type (eql 'vector)) &rest args)
436 (declare (ignore type args))
439 (defmethod to-alien-form (vector (type (eql 'vector)) &rest args)
440 (declare (ignore type))
441 (destructuring-bind (element-type &optional (length '*)) args
443 `(let* ((vector ,vector)
445 (allocate-memory (+ ,+size-of-int+
446 (* ,(size-of element-type)
449 (make-c-vector ',element-type (length vector) vector location)
450 (setf (sap-ref-32 location ,(- +size-of-int+)) (length vector))
452 `(make-c-vector ',element-type ,length ,vector))))
454 (defmethod from-alien-form (c-vector (type (eql 'vector)) &rest args)
455 (declare (ignore type))
456 (destructuring-bind (element-type &optional (length '*)) args
458 (error "Can't use vector of variable size as return type")
459 `(let ((c-vector ,c-vector))
461 (map-c-vector 'vector #'identity c-vector ',element-type ,length)
462 (destroy-c-vector c-vector ',element-type ,length))))))
464 (defmethod copy-from-alien-form (c-vector (type (eql 'vector)) &rest args)
465 (declare (ignore type))
466 (destructuring-bind (element-type &optional (length '*)) args
468 (error "Can't use vector of variable size as return type")
469 `(map-c-vector 'vector #'identity ,c-vector ',element-type ,length))))
471 (defmethod copy-from-alien-function ((type (eql 'vector)) &rest args)
472 (declare (ignore type))
473 (destructuring-bind (element-type &optional (length '*)) args
475 (error "Can't use vector of variable size as return type")
477 (map-c-vector 'vector #'identity c-vector element-type length)))))
479 (defmethod cleanup-form (location (type (eql 'vector)) &rest args)
480 (declare (ignore type))
481 (destructuring-bind (element-type &optional (length '*)) args
482 `(let* ((location ,location)
483 (length ,(if (eq length '*)
484 `(sap-ref-32 location ,(- +size-of-int+))
487 with destroy = (destroy-function ',element-type)
488 for i from 0 below length
489 as offset = 0 then (+ offset ,(size-of element-type))
490 do (funcall destroy location offset))
491 (deallocate-memory ,(if (eq length '*)
492 `(sap+ location ,(- +size-of-int+))
495 (defmethod writer-function ((type (eql 'vector)) &rest args)
496 (declare (ignore type))
497 (destructuring-bind (element-type &optional (length '*)) args
498 #'(lambda (vector location &optional (offset 0))
500 (sap-ref-sap location offset)
501 (make-c-vector element-type length vector)))))
503 (defmethod reader-function ((type (eql 'vector)) &rest args)
504 (declare (ignore type))
505 (destructuring-bind (element-type &optional (length '*)) args
507 (error "Can't create reader function for vector of variable size")
508 #'(lambda (location &optional (offset 0) weak-p)
509 (declare (ignore weak-p))
510 (unless (null-pointer-p (sap-ref-sap location offset))
511 (map-c-vector 'vector #'identity (sap-ref-sap location offset)
512 element-type length))))))
514 (defmethod destroy-function ((type (eql 'vector)) &rest args)
515 (declare (ignore type))
516 (destructuring-bind (element-type &optional (length '*)) args
518 (error "Can't create destroy function for vector of variable size")
519 #'(lambda (location &optional (offset 0))
520 (unless (null-pointer-p (sap-ref-sap location offset))
522 (sap-ref-sap location offset) element-type length)
523 (setf (sap-ref-sap location offset) (make-pointer 0)))))))
526 ;;;; Null terminated vector
528 (defun make-0-vector (type content &optional location)
529 (let* ((size-of-type (size-of type))
532 (allocate-memory (* size-of-type (1+ (length content))))))
533 (writer (writer-function type)))
537 for element across content
538 as offset = 0 then (+ offset size-of-type)
539 do (funcall writer element location offset)
540 finally (setf (sap-ref-sap location offset) (make-pointer 0))))
543 for element in content
544 as offset = 0 then (+ offset size-of-type)
545 do (funcall writer element location offset)
546 finally (setf (sap-ref-sap location (+ offset size-of-type)) (make-pointer 0)))))
550 (defun map-0-vector (seqtype function location element-type)
551 (let ((reader (reader-function element-type))
552 (size-of-element (size-of element-type)))
556 as offset = 0 then (+ offset size-of-element)
557 until (null-pointer-p (sap-ref-sap location offset))
558 do (funcall function (funcall reader location offset))))
561 as offset = 0 then (+ offset size-of-element)
562 until (null-pointer-p (sap-ref-sap location offset))
563 collect (funcall function (funcall reader location offset))))
567 as offset = 0 then (+ offset size-of-element)
568 until (null-pointer-p (sap-ref-sap location offset))
569 collect (funcall function (funcall reader location offset)))
573 (defun destroy-0-vector (location element-type)
575 with destroy = (destroy-function element-type)
576 with element-size = (size-of element-type)
577 as offset = 0 then (+ offset element-size)
578 until (null-pointer-p (sap-ref-sap location offset))
579 do (funcall destroy location offset))
580 (deallocate-memory location))
582 (deftype null-terminated-vector (element-type) `(vector ,element-type))
584 (defmethod alien-type ((type (eql 'null-terminated-vector)) &rest args)
585 (declare (ignore type args))
586 (alien-type 'pointer))
588 (defmethod size-of ((type (eql 'null-terminated-vector)) &rest args)
589 (declare (ignore type args))
592 (defmethod to-alien-form (vector (type (eql 'null-terminated-vector)) &rest args)
593 (declare (ignore type))
594 (destructuring-bind (element-type) args
595 `(make-0-vector ',element-type ,vector)))
597 (defmethod from-alien-form (c-vector (type (eql 'null-terminated-vector)) &rest args)
598 (declare (ignore type))
599 (destructuring-bind (element-type) args
600 `(let ((c-vector ,c-vector))
602 (map-0-vector 'vector #'identity c-vector ',element-type)
603 (destroy-0-vector c-vector ',element-type)))))
605 (defmethod copy-from-alien-form (c-vector (type (eql 'null-terminated-vector)) &rest args)
606 (declare (ignore type))
607 (destructuring-bind (element-type) args
608 `(map-0-vector 'vector #'identity ,c-vector ',element-type)))
610 (defmethod cleanup-form (location (type (eql 'null-terminated-vector)) &rest args)
611 (declare (ignore type))
612 (destructuring-bind (element-type) args
613 `(destroy-0-vector ,location ',element-type)))
615 (defmethod writer-function ((type (eql 'null-terminated-vector)) &rest args)
616 (declare (ignore type))
617 (destructuring-bind (element-type) args
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 (vector location &optional (offset 0))
622 (sap-ref-sap location offset)
623 (make-0-vector element-type vector)))))
625 (defmethod reader-function ((type (eql 'null-terminated-vector)) &rest args)
626 (declare (ignore type))
627 (destructuring-bind (element-type) args
628 (unless (eq (alien-type element-type) (alien-type 'pointer))
629 (error "Elements in null-terminated vectors need to be of pointer types"))
630 #'(lambda (location &optional (offset 0) weak-p)
631 (declare (ignore weak-p))
632 (unless (null-pointer-p (sap-ref-sap location offset))
633 (map-0-vector 'vector #'identity (sap-ref-sap location offset)
636 (defmethod destroy-function ((type (eql 'null-terminated-vector)) &rest args)
637 (declare (ignore type))
638 (destructuring-bind (element-type) args
639 (unless (eq (alien-type element-type) (alien-type 'pointer))
640 (error "Elements in null-terminated vectors need to be of pointer types"))
641 #'(lambda (location &optional (offset 0))
642 (unless (null-pointer-p (sap-ref-sap location offset))
644 (sap-ref-sap location offset) element-type)
645 (setf (sap-ref-sap location offset) (make-pointer 0))))))
647 (defmethod unbound-value ((type (eql 'null-terminated-vector)) &rest args)
648 (declare (ignore type args))
654 (defun make-counted-vector (type content)
655 (let* ((size-of-type (size-of type))
656 (length (length content))
658 (allocate-memory (+ +size-of-int+ (* size-of-type length)))))
659 (setf (sap-ref-32 location 0) length)
660 (make-c-vector type length content (sap+ location +size-of-int+))))
662 (defun map-counted-vector (seqtype function location element-type)
663 (let ((length (sap-ref-32 location 0)))
665 seqtype function (sap+ location +size-of-int+)
666 element-type length)))
668 (defun destroy-counted-vector (location element-type)
670 with destroy = (destroy-function element-type)
671 with element-size = (size-of element-type)
672 for i from 0 below (sap-ref-32 location 0)
673 as offset = +size-of-int+ then (+ offset element-size)
674 do (funcall destroy location offset))
675 (deallocate-memory location))
678 (deftype counted-vector (element-type) `(vector ,element-type))
680 (defmethod alien-type ((type (eql 'counted-vector)) &rest args)
681 (declare (ignore type args))
682 (alien-type 'pointer))
684 (defmethod size-of ((type (eql 'counted-vector)) &rest args)
685 (declare (ignore type args))
688 (defmethod to-alien-form (vector (type (eql 'counted-vector)) &rest args)
689 (declare (ignore type))
690 (destructuring-bind (element-type) args
691 `(make-counted-vector ',element-type ,vector)))
693 (defmethod from-alien-form (c-vector (type (eql 'counted-vector)) &rest args)
694 (declare (ignore type))
695 (destructuring-bind (element-type) args
696 `(let ((c-vector ,c-vector))
698 (map-counted-vector 'vector #'identity c-vector ',element-type)
699 (destroy-counted-vector c-vector ',element-type)))))
701 (defmethod copy-from-alien-form (c-vector (type (eql 'counted-vector)) &rest args)
702 (declare (ignore type))
703 (destructuring-bind (element-type) args
704 `(map-counted-vector 'vector #'identity ,c-vector ',element-type)))
706 (defmethod copy-from-alien-function ((type (eql 'counted-vector)) &rest args)
707 (declare (ignore type))
708 (destructuring-bind (element-type) args
710 (map-counted-vector 'vector #'identity c-vector element-type))))
712 (defmethod cleanup-form (location (type (eql 'counted-vector)) &rest args)
713 (declare (ignore type))
714 (destructuring-bind (element-type) args
715 `(destroy-counted-vector ,location ',element-type)))
717 (defmethod writer-function ((type (eql 'counted-vector)) &rest args)
718 (declare (ignore type))
719 (destructuring-bind (element-type) args
720 #'(lambda (vector location &optional (offset 0))
722 (sap-ref-sap location offset)
723 (make-counted-vector element-type vector)))))
725 (defmethod reader-function ((type (eql 'counted-vector)) &rest args)
726 (declare (ignore type))
727 (destructuring-bind (element-type) args
728 #'(lambda (location &optional (offset 0) weak-p)
729 (declare (ignore weak-p))
730 (unless (null-pointer-p (sap-ref-sap location offset))
731 (map-counted-vector 'vector #'identity
732 (sap-ref-sap location offset) element-type)))))
734 (defmethod destroy-function ((type (eql 'counted-vector)) &rest args)
735 (declare (ignore type))
736 (destructuring-bind (element-type) args
737 #'(lambda (location &optional (offset 0))
738 (unless (null-pointer-p (sap-ref-sap location offset))
739 (destroy-counted-vector
740 (sap-ref-sap location offset) element-type)
741 (setf (sap-ref-sap location offset) (make-pointer 0))))))