1 ;; Common Lisp bindings for GTK+ 2.x
2 ;; Copyright 1999-2006 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: vectors.lisp,v 1.7 2008-04-29 22:16:28 espen Exp $
29 ;;; Accessor functions for raw memory access
31 (define-memory-accessor int-16)
32 (define-memory-accessor int-32)
33 (define-memory-accessor int-64)
34 (define-memory-accessor uint-16)
35 (define-memory-accessor uint-32)
36 (define-memory-accessor uint-64)
37 (define-memory-accessor single-float)
38 (define-memory-accessor double-float)
43 (defun make-c-vector (type length &key content location temp)
44 (let* ((element-size (size-of type))
45 (location (or location (allocate-memory (* element-size length))))
46 (writer (writer-function type :temp temp)))
50 for element across content
52 for offset by element-size
53 do (funcall writer element location offset)))
56 for element in content
58 for offset by element-size
59 do (funcall writer element location offset))))
63 (defun map-c-vector (seqtype function location element-type length
64 &optional (ref :read))
65 (let ((reader (reader-function element-type :ref ref))
66 (element-size (size-of element-type)))
71 for offset by element-size
72 do (funcall function (funcall reader location offset))))
76 for offset by element-size
77 collect (funcall function (funcall reader location offset))))
80 with sequence = (make-sequence seqtype length)
82 for offset by element-size
85 (funcall function (funcall reader location offset)))
86 finally (return sequence))))))
89 (defun unset-c-vector (location element-type length &optional temp-p)
91 with destroy = (destroy-function element-type :temp temp-p)
92 with element-size = (size-of element-type)
94 for offset by element-size
95 do (funcall destroy location offset)))
98 (defun destroy-c-vector (location element-type length &optional temp-p)
99 (unset-c-vector location element-type length temp-p)
100 (deallocate-memory location))
103 (defmacro with-c-vector (var type content &body body)
104 (let ((length (make-symbol "LENGTH")))
105 `(let ((,length (length ,content)))
106 (with-memory (,var (* ,(size-of type) ,length))
107 (make-c-vector ',type ,length :content ,content :location ,var :temp t)
110 (unset-c-vector ,var ',type ,length t))))))
113 (define-type-method alien-type ((type vector))
114 (declare (ignore type))
115 (alien-type 'pointer))
117 (define-type-method argument-type ((type vector))
118 (declare (ignore type))
121 (define-type-method return-type ((type vector))
122 (destructuring-bind (element-type &optional (length '*))
123 (rest (type-expand-to 'vector type))
124 (if (constantp length)
125 `(vector ,(return-type element-type) ,length)
126 `(vector ,(return-type element-type) *))))
128 (define-type-method size-of ((type vector) &key inlined)
130 (destructuring-bind (element-type &optional (length '*))
131 (rest (type-expand-to 'vector type))
133 (error "Can't inline vector with variable size: ~A" type)
134 (* (size-of element-type) length)))
137 (define-type-method type-alignment ((type vector) &key inlined)
139 (destructuring-bind (element-type &optional (length '*))
140 (rest (type-expand-to 'vector type))
142 (error "Can't inline vector with variable size: ~A" type)
143 (* (type-alignment element-type) length)))
144 (type-alignment 'pointer)))
146 (define-type-method alien-arg-wrapper ((type vector) var vector style form &optional copy-in-p)
147 (destructuring-bind (element-type &optional (length '*))
148 (rest (type-expand-to 'vector type))
149 (when (and (eq length '*) (out-arg-p style))
150 (error "Can't use vector with variable size as return type"))
152 ((and (in-arg-p style) copy-in-p)
153 `(with-pointer (,var `(make-c-vector ',element-type
154 ,(if (eq length '*) `(length ,vector) length)
157 ((and (in-arg-p style) (not (out-arg-p style)))
158 `(with-memory (,var ,(if (eq length '*)
159 `(* ,(size-of element-type)
161 `(* ,(size-of element-type) ,length)))
162 (make-c-vector ',element-type
163 ,(if (eq length '*) `(length ,vector) length)
164 :content ,vector :location ,var :temp t)
167 (unset-c-vector ,var ',element-type
168 ,(if (eq length '*) `(length ,vector) length) t))))
169 ((and (in-arg-p style) (out-arg-p style))
170 (let ((c-vector (make-symbol "C-VECTOR")))
171 `(with-memory (,c-vector (* ,(size-of element-type) length))
172 (make-c-vector ',element-type ,length
173 :content ,vector :location ,c-vector :temp t)
174 (with-pointer (,var ,c-vector)
177 (unset-c-vector ,c-vector ',element-type ,length t))))))
178 ((and (out-arg-p style) (not (in-arg-p style)))
179 `(with-pointer (,var)
182 ;; This will enable us specify vectors with variable length in C callbacks
183 (define-type-method callback-wrapper ((type vector) var vector form)
184 (funcall (find-applicable-type-method 'callback-wrapper t) type var vector form))
186 (define-type-method to-alien-form ((type vector) vector &optional copy-p)
187 (declare (ignore copy-p))
188 (destructuring-bind (element-type &optional (length '*))
189 (rest (type-expand-to 'vector type))
190 `(make-c-vector ',element-type
191 ,(if (eq length '*) `(length ,vector) length) :content ,vector)))
194 (define-type-method from-alien-form ((type vector) form &key (ref :free))
195 (destructuring-bind (element-type &optional (length '*))
196 (rest (type-expand-to 'vector type))
198 (error "Can't use vector of variable size as return type")
199 `(let ((c-vector ,form))
201 (map-c-vector 'vector #'identity c-vector ',element-type ,length
202 ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
203 ,(when (eq ref :free)
204 `(deallocate-memory c-vector)))))))
207 (define-type-method writer-function ((type vector) &key temp inlined)
208 (destructuring-bind (element-type &optional (length '*))
209 (rest (type-expand-to 'vector type))
212 (error "Can't inline vector with variable size: ~A" type)
213 #'(lambda (vector location &optional (offset 0))
214 (make-c-vector element-type length
215 :location (pointer+ location offset)
216 :content vector :temp temp)))
217 #'(lambda (vector location &optional (offset 0))
219 (ref-pointer location offset)
220 (make-c-vector element-type length :content vector :temp temp))))))
222 (define-type-method reader-function ((type vector) &key (ref :read) inlined)
223 (destructuring-bind (element-type &optional (length '*))
224 (rest (type-expand-to 'vector type))
227 (error "Can't create reader function for vector with variable size"))
229 #'(lambda (location &optional (offset 0))
230 (map-c-vector 'vector #'identity (pointer+ location offset)
231 element-type length ref)))
235 #'(lambda (location &optional (offset 0))
236 (unless (null-pointer-p (ref-pointer location offset))
237 (map-c-vector 'vector #'identity (ref-pointer location offset)
238 element-type length ref))))
240 #'(lambda (location &optional (offset 0))
241 (unless (null-pointer-p (ref-pointer location offset))
243 (map-c-vector 'vector #'identity
244 (ref-pointer location offset) element-type length :get)
245 (deallocate-memory (ref-pointer location offset))
246 (setf (ref-pointer location offset) (make-pointer 0)))))))))))
248 (define-type-method destroy-function ((type vector) &key temp inlined)
249 (destructuring-bind (element-type &optional (length '*))
250 (rest (type-expand-to 'vector type))
253 (error "Can't create destroy function for vector with variable size"))
255 #'(lambda (location &optional (offset 0))
256 (unset-c-vector (pointer+ location offset)
257 element-type length temp)))
259 #'(lambda (location &optional (offset 0))
260 (unless (null-pointer-p (ref-pointer location offset))
261 (destroy-c-vector (ref-pointer location offset)
262 element-type length temp)
263 (setf (ref-pointer location offset) (make-pointer 0))))))))
265 (define-type-method copy-function ((type vector) &key inlined)
266 (destructuring-bind (element-type &optional (length '*))
267 (rest (type-expand-to 'vector type))
269 ((eq length '*) (error "Can't copy vector with variable size: ~A" type))
271 (let ((copy-element (copy-function element-type))
272 (element-size (size-of element-type)))
273 #'(lambda (from to &optional (offset 0))
276 for element from offset by element-size
277 do (funcall copy-element from to element)))))
279 (let ((size (* length (size-of element-type)))
280 (copy-content (copy-function type :inlined t)))
281 #'(lambda (from to &optional (offset 0))
282 (unless (null-pointer-p (ref-pointer from offset))
283 (let ((vector (allocate-memory size)))
284 (setf (ref-pointer to offset) vector)
285 (funcall copy-content (ref-pointer from offset) vector)))))))))
289 (deftype unboxed-vector (element-type &optional (length '*))
290 `(simple-array ,element-type (,length)))
292 (define-type-method argument-type ((type unboxed-vector))
295 (define-type-method return-type ((type unboxed-vector))
296 (destructuring-bind (element-type &optional (length '*))
297 (rest (type-expand-to 'unboxed-vector type))
298 (if (constantp length)
299 `(unboxed-vector ,(return-type element-type) ,length)
300 `(unboxed-vector ,(return-type element-type) *))))
302 (defun check-unboxed-vector (type)
304 (unless (subtypep type 'simple-unboxed-array)
305 (error "~A is not a subtype of ~A" type 'simple-unboxed-array)))
309 (define-type-method alien-arg-wrapper ((type unboxed-vector) var vector style form &optional copy-in-p)
310 (destructuring-bind (element-type &optional (length '*))
311 (rest (type-expand-to 'unboxed-vector type))
312 (check-unboxed-vector type)
313 (when (and (eq length '*) (out-arg-p style))
314 (error "Can't use vector with variable size as return type"))
316 ((and (in-arg-p style) copy-in-p)
317 `(with-pointer (,var (with-pinned-objects (,vector)
318 (copy-memory (vector-sap ,vector)
319 (* (length ,vector) ,(size-of element-type)))))
322 `(with-pinned-objects (,vector)
323 (let ((,var (vector-sap ,vector)))
326 `(with-pointer (,var)
329 (define-type-method to-alien-form ((type unboxed-vector) vector &optional copy-p)
330 (declare (ignore copy-p))
331 (destructuring-bind (element-type &optional (length '*))
332 (rest (type-expand-to 'unboxed-vector type))
333 (check-unboxed-vector type)
334 `(with-pinned-objects (,vector)
337 (* ,(if (eq length '*) `(length ,vector) length)
338 ,(size-of element-type))))))
341 (define-type-method from-alien-form ((type unboxed-vector) form &key (ref :free))
342 (destructuring-bind (element-type &optional (length '*))
343 (rest (type-expand-to 'unboxed-vector type))
344 (check-unboxed-vector type)
346 (error "Can't use vector of variable size as return type"))
347 `(let ((c-vector ,form)
348 (vector (make-array ,length :element-type ',element-type)))
349 (with-pinned-objects (vector)
350 (copy-memory c-vector (* ,length ,(size-of element-type)) (vector-sap vector))
351 ,(when (eq ref :free)
352 `(deallocate-memory c-vector))
355 (define-type-method writer-function ((type unboxed-vector) &key temp inlined)
356 (declare (ignore temp))
357 (destructuring-bind (element-type &optional (length '*))
358 (rest (type-expand-to 'unboxed-vector type))
359 (check-unboxed-vector type)
362 (error "Can't inline vector with variable size: ~A" type)
363 #'(lambda (vector location &optional (offset 0))
364 (with-pinned-objects (vector)
367 (* length (size-of element-type))
368 (pointer+ location offset)))))
369 #'(lambda (vector location &optional (offset 0))
371 (ref-pointer location offset)
372 (with-pinned-objects (vector)
373 (copy-memory (vector-sap vector)
374 (* (length vector) (size-of element-type)))))))))
376 (define-type-method reader-function ((type unboxed-vector) &key (ref :read) inlined)
377 (destructuring-bind (element-type &optional (length '*))
378 (rest (type-expand-to 'unboxed-vector type))
379 (check-unboxed-vector type)
382 (error "Can't create reader function for vector with variable size"))
384 #'(lambda (location &optional (offset 0))
385 (let ((vector (make-array length :element-type element-type)))
386 (with-pinned-objects (vector)
388 (pointer+ location offset)
389 (* length (size-of element-type))
393 #'(lambda (location &optional (offset 0))
394 (let ((vector (make-array length :element-type element-type)))
395 (unless (null-pointer-p (ref-pointer location offset))
396 (with-pinned-objects (vector)
398 (ref-pointer location offset)
399 (* (length vector) (size-of element-type))
400 (vector-sap vector)))
402 (deallocate-memory (ref-pointer location offset))
403 (setf (ref-pointer location offset) (make-pointer 0)))
406 (define-type-method destroy-function ((type unboxed-vector) &key temp inlined)
407 (declare (ignore temp))
408 (destructuring-bind (element-type &optional (length '*))
409 (rest (type-expand-to 'unboxed-vector type))
410 (check-unboxed-vector type)
414 (error "Can't create destroy function for vector with variable size"))
416 #'(lambda (location &optional (offset 0))
417 (clear-memory location (* length (size-of element-type)) offset)))
419 #'(lambda (location &optional (offset 0))
420 (unless (null-pointer-p (ref-pointer location offset))
421 (deallocate-memory (ref-pointer location offset))
422 (setf (ref-pointer location offset) (make-pointer 0))))))))
425 ;;;; Null terminated vector
427 (defun make-0-vector (type &key content location temp)
428 (let* ((element-size (size-of type))
429 (length (length content))
430 (location (or location (allocate-memory (* element-size (1+ length))))))
431 (make-c-vector type length :content content :location location :temp temp)))
434 (defun map-0-vector (seqtype function location element-type &optional (ref :read))
435 (let ((reader (reader-function element-type :ref ref))
436 (element-size (size-of element-type)))
440 for offset by element-size
441 until (memory-clear-p (pointer+ location offset) element-size)
442 do (funcall function (funcall reader location offset))))
445 for offset by element-size
446 until (memory-clear-p (pointer+ location offset) element-size)
447 collect (funcall function (funcall reader location offset))))
451 for offset by element-size
452 until (memory-clear-p (pointer+ location offset) element-size)
453 collect (funcall function (funcall reader location offset)))
457 (defun unset-0-vector (location element-type &optional temp-p)
459 with destroy = (destroy-function element-type :temp temp-p)
460 with element-size = (size-of element-type)
461 for offset by element-size
462 until (memory-clear-p (pointer+ location offset) element-size)
463 do (funcall destroy location offset)))
465 (defun destroy-0-vector (location element-type &optional temp-p)
466 (unset-0-vector location element-type temp-p)
467 (deallocate-memory location))
470 (deftype vector0 (element-type) `(vector ,element-type))
471 (deftype null-terminated-vector (element-type) `(vector0 ,element-type))
473 (define-type-method alien-type ((type vector0))
474 (declare (ignore type))
475 (alien-type 'pointer))
477 (define-type-method size-of ((type vector0) &key inlined)
478 (assert-not-inlined type inlined)
481 (define-type-method type-alignment ((type vector0) &key inlined)
482 (assert-not-inlined type inlined)
483 (type-alignment 'pointer))
485 (define-type-method alien-arg-wrapper ((type vector0) var vector style form &optional copy-in-p)
486 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
488 ((and (in-arg-p style) copy-in-p)
489 `(with-pointer (,var (make-0-vector ',element-type :content ,vector))
491 ((and (in-arg-p style) (not (out-arg-p style)))
492 `(with-memory (,var (* ,(size-of element-type) (1+ (length ,vector))))
493 (make-0-vector ',element-type :content ,vector :location ,var :temp t)
496 (unset-0-vector ,var ',element-type t))))
497 ((and (in-arg-p style) (out-arg-p style))
498 (let ((c-vector (make-symbol "C-VECTOR")))
499 `(with-memory (,c-vector (* ,(size-of element-type) (1+ (length ,vector))))
500 (make-0-vector ',element-type :content ,vector :location ,c-vector :temp t)
501 (with-pointer (,var ,c-vector)
504 (unset-0-vector ,c-vector ',element-type t))))))
505 ((and (out-arg-p style) (not (in-arg-p style)))
506 `(with-pointer (,var)
510 (define-type-method to-alien-form ((type vector0) vector &optional copy-p)
511 (declare (ignore copy-p))
512 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
513 `(make-0-vector ',element-type :content ,vector)))
515 (define-type-method from-alien-form ((type vector0) form &key (ref :free))
516 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
517 `(let ((c-vector ,form))
519 (map-0-vector 'vector #'identity c-vector ',element-type
520 ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
521 ,(when (eq ref :free)
522 `(deallocate-memory c-vector))))))
525 (define-type-method writer-function ((type vector0) &key temp inlined)
526 (assert-not-inlined type inlined)
527 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
528 #'(lambda (vector location &optional (offset 0))
530 (ref-pointer location offset)
531 (make-0-vector element-type :content vector :temp temp)))))
533 (define-type-method reader-function ((type vector0) &key (ref :read) inlined)
534 (assert-not-inlined type inlined)
535 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
538 #'(lambda (location &optional (offset 0))
539 (unless (null-pointer-p (ref-pointer location offset))
540 (map-0-vector 'vector #'identity (ref-pointer location offset)
543 #'(lambda (location &optional (offset 0))
544 (unless (null-pointer-p (ref-pointer location offset))
546 (map-0-vector 'vector #'identity (ref-pointer location offset)
548 (deallocate-memory (ref-pointer location offset))
549 (setf (ref-pointer location offset) (make-pointer 0)))))))))
552 (define-type-method destroy-function ((type vector0) &key temp inlined)
553 (assert-not-inlined type inlined)
554 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
555 #'(lambda (location &optional (offset 0))
556 (unless (null-pointer-p (ref-pointer location offset))
558 (ref-pointer location offset) element-type temp)
559 (setf (ref-pointer location offset) (make-pointer 0))))))
561 (define-type-method copy-function ((type vector0) &key inlined)
562 (assert-not-inlined type inlined)
563 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
564 (let ((copy-element (copy-function element-type))
565 (element-size (size-of element-type)))
566 #'(lambda (from to &optional (offset 0))
567 (unless (null-pointer-p (ref-pointer from offset))
568 (let* ((from-vector (ref-pointer from offset))
572 for element by element-size
573 until (memory-clear-p from-vector element-size element)
574 finally (return length)))
576 (setf (ref-pointer to offset)
577 (allocate-memory (* (1+ length) element-size)))))
580 for element by element-size
581 do (funcall copy-element from-vector to-vector element))))))))
583 (define-type-method unbound-value ((type vector0))
584 (declare (ignore type))
591 (defun make-counted-vector (type &key content location (counter-type 'unsigned-int) temp)
592 (let* ((element-size (size-of type))
593 (length (length content))
597 (+ (size-of counter-type) (* element-size length))))))
598 (funcall (writer-function counter-type :temp temp) length location)
599 (make-c-vector type length :content content :location (pointer+ location (size-of counter-type)))
602 (defun map-counted-vector (seqtype function location element-type &optional (counter-type 'unsigned-int) (ref :read))
603 (let ((length (funcall (reader-function counter-type) location :ref ref)))
605 seqtype function (pointer+ location (size-of counter-type))
606 element-type length)))
608 (defun unset-counted-vector (location element-type &optional (counter-type 'unsigned-int) temp-p)
609 (let ((length (funcall (reader-function counter-type) location)))
611 (pointer+ location (size-of counter-type)) element-type length temp-p)))
613 (defun destroy-counted-vector (location element-type &optional (counter-type 'unsigned-int) temp-p)
614 (unset-counted-vector location element-type counter-type temp-p)
615 (deallocate-memory location))
618 (deftype counted-vector (element-type &optional counter-type)
619 (declare (ignore counter-type))
620 `(vector ,element-type))
622 (define-type-method alien-type ((type counted-vector))
623 (declare (ignore type))
624 (alien-type 'pointer))
626 (define-type-method size-of ((type counted-vector) &key inlined)
627 (assert-not-inlined type inlined)
630 (define-type-method type-alignment ((type counted-vector) &key inlined)
631 (assert-not-inlined type inlined)
632 (type-alignment 'pointer))
634 (define-type-method alien-arg-wrapper ((type counted-vector) var vector style form &optional copy-in-p)
635 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
636 (rest (type-expand-to 'counted-vector type))
638 ((and (in-arg-p style) copy-in-p)
639 `(with-pointer (,var (make-counted-vector ',element-type
640 :content ,vector :counter-type ',counter-type))
642 ((and (in-arg-p style) (not (out-arg-p style)))
643 `(with-memory (,var (+ (* ,(size-of element-type) (length ,vector)) ,(size-of counter-type)))
644 (make-counted-vector ',element-type :content ,vector
645 :location ,var :counter-type ',counter-type :temp t)
648 (unset-counted-vector ,var ',element-type ',counter-type t))))
649 ((and (in-arg-p style) (out-arg-p style))
650 (let ((c-vector (make-symbol "C-VECTOR")))
651 `(with-memory (,c-vector (+ (* ,(size-of element-type) (length ,vector)) ,(size-of counter-type)))
652 (make-counted-vector ',element-type :content ,vector ,c-vector
653 :counter-type ',counter-type :temp t)
654 (with-pointer (,var ,c-vector)
657 (unset-counted-vector ,c-vector ',element-type ',counter-type t))))))
658 ((and (out-arg-p style) (not (in-arg-p style)))
659 `(with-pointer (,var)
663 (define-type-method to-alien-form ((type counted-vector) vector &optional copy-p)
664 (declare (ignore copy-p))
665 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
666 (rest (type-expand-to 'counted-vector type))
667 `(make-counted-vector ',element-type
668 :content ,vector :counter-type ',counter-type)))
670 (define-type-method from-alien-form ((type counted-vector) form &key (ref :free))
671 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
672 (rest (type-expand-to 'counted-vector type))
673 `(let ((c-vector ,form))
675 (map-counted-vector 'vector #'identity c-vector ',element-type ',counter-type
676 ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
677 ,(when (eq ref :free)
678 `(deallocate c-vector))))))
680 (define-type-method writer-function ((type counted-vector) &key temp inlined)
681 (assert-not-inlined type inlined)
682 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
683 (rest (type-expand-to 'counted-vector type))
684 #'(lambda (vector location &optional (offset 0))
686 (ref-pointer location offset)
687 (make-counted-vector element-type :content vector
688 :counter-type counter-type :temp temp)))))
690 (define-type-method reader-function ((type counted-vector) &key (ref :read) inlined)
691 (assert-not-inlined type inlined)
692 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
693 (rest (type-expand-to 'counted-vector type))
696 #'(lambda (location &optional (offset 0))
697 (unless (null-pointer-p (ref-pointer location offset))
698 (map-counted-vector 'vector #'identity
699 (ref-pointer location offset) element-type counter-type ref))))
701 #'(lambda (location &optional (offset 0))
702 (unless (null-pointer-p (ref-pointer location offset))
704 (map-counted-vector 'vector #'identity
705 (ref-pointer location offset) element-type counter-type :get)
706 (deallocate-memory (ref-pointer location offset))
707 (setf (ref-pointer location offset) (make-pointer 0)))))))))
709 (define-type-method destroy-function ((type counted-vector) &key temp inlined)
710 (assert-not-inlined type inlined)
711 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
712 (rest (type-expand-to 'counted-vector type))
713 #'(lambda (location &optional (offset 0))
714 (unless (null-pointer-p (ref-pointer location offset))
715 (destroy-counted-vector (ref-pointer location offset)
716 element-type counter-type temp)
717 (setf (ref-pointer location offset) (make-pointer 0))))))
719 (define-type-method copy-function ((type counted-vector) &key inlined)
720 (assert-not-inlined type inlined)
721 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
722 (rest (type-expand-to 'counted-vector type))
723 (let ((vector-length (reader-function counter-type))
724 (counter-size (size-of counter-type))
725 (copy-element (copy-function element-type))
726 (element-size (size-of element-type)))
727 #'(lambda (from to &optional (offset 0))
728 (unless (null-pointer-p (ref-pointer from offset))
729 (let* ((from-vector (ref-pointer from offset))
730 (length (funcall vector-length from-vector))
732 (ref-pointer to offset)
733 (allocate-memory (+ counter-size (* length element-size))))))
734 (copy-memory from-vector counter-size to-vector)
737 for element from counter-size by element-size
738 do (funcall copy-element from-vector to-vector element))))))))
741 ;;;; Accessor functions for raw memory access
743 (defun vector-reader-function (type &key (start 0) end)
744 "Returns a function for reading values from raw C vectors"
745 (let ((element-size (size-of type))
746 (reader (reader-function type)))
747 #'(lambda (vector index)
748 (assert (and (>= index start) (or (not end) (< index end))))
749 (funcall reader vector (* index element-size)))))
751 (defun vector-writer-function (type &key (start 0) end)
752 "Returns a function for writing values to raw C vectors"
753 (let ((element-size (size-of type))
754 (writer (writer-function type)))
755 #'(lambda (value vector index)
756 (assert (and (>= index start) (or (not end) (< index end))))
757 (funcall writer value vector (* index element-size)))))
760 (defmacro define-vector-accessor (type)
761 (let ((name (intern (format nil "VECTOR-REF-~A" type)))
762 (ref (intern (format nil "REF-~A" type))))
765 (ftype (function (pointer fixnum) ,type) ,name)
767 (defun ,name (vector index)
768 (,ref vector (* ,(size-of type) index)))
770 (ftype (function (,type pointer fixnum) ,type) (setf ,name))
771 (inline (setf ,name)))
772 (defun (setf ,name) (value vector index)
773 (setf (,ref vector (* ,(size-of type) index)) value)))))
775 (define-vector-accessor int-8)
776 (define-vector-accessor uint-8)
777 (define-vector-accessor int-16)
778 (define-vector-accessor uint-16)
779 (define-vector-accessor int-32)
780 (define-vector-accessor uint-32)
781 (define-vector-accessor int-64)
782 (define-vector-accessor uint-64)
783 (define-vector-accessor double-float)
784 (define-vector-accessor single-float)