chiark / gitweb /
New function TYPE-EQUAL-P
[clg] / gffi / vectors.lisp
CommitLineData
e5426fae 1;; Common Lisp bindings for GTK+ 2.x
2;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net>
3;;
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:
11;;
12;; The above copyright notice and this permission notice shall be
13;; included in all copies or substantial portions of the Software.
14;;
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
f37a05bb 23;; $Id: vectors.lisp,v 1.8 2008-04-30 17:35:48 espen Exp $
e5426fae 24
25
26(in-package "GFFI")
27
2c708568 28
29;;; Accessor functions for raw memory access
30
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)
39
40
e5426fae 41;;; Vector
42
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)))
47 (etypecase content
48 (vector
49 (loop
50 for element across content
51 for i below length
52 for offset by element-size
53 do (funcall writer element location offset)))
54 (list
55 (loop
56 for element in content
57 for i below length
58 for offset by element-size
59 do (funcall writer element location offset))))
60 location))
61
62
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)))
67 (case seqtype
68 ((nil)
69 (loop
70 for i below length
71 for offset by element-size
72 do (funcall function (funcall reader location offset))))
73 (list
74 (loop
75 for i below length
76 for offset by element-size
77 collect (funcall function (funcall reader location offset))))
78 (t
79 (loop
80 with sequence = (make-sequence seqtype length)
81 for i below length
82 for offset by element-size
83 do (setf
84 (elt sequence i)
85 (funcall function (funcall reader location offset)))
86 finally (return sequence))))))
87
88
89(defun unset-c-vector (location element-type length &optional temp-p)
90 (loop
91 with destroy = (destroy-function element-type :temp temp-p)
92 with element-size = (size-of element-type)
93 for i below length
94 for offset by element-size
95 do (funcall destroy location offset)))
96
97
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))
101
102
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)
108 (unwind-protect
109 (progn ,@body)
110 (unset-c-vector ,var ',type ,length t))))))
111
112
113(define-type-method alien-type ((type vector))
114 (declare (ignore type))
115 (alien-type 'pointer))
116
f9a67e67 117(define-type-method argument-type ((type vector))
118 (declare (ignore type))
119 'sequence)
120
121(define-type-method return-type ((type vector))
2c708568 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) *))))
127
e5426fae 128(define-type-method size-of ((type vector) &key inlined)
129 (if inlined
130 (destructuring-bind (element-type &optional (length '*))
131 (rest (type-expand-to 'vector type))
132 (if (eq length '*)
133 (error "Can't inline vector with variable size: ~A" type)
134 (* (size-of element-type) length)))
135 (size-of 'pointer)))
136
90e8bbf6 137(define-type-method type-alignment ((type vector) &key inlined)
138 (if inlined
139 (destructuring-bind (element-type &optional (length '*))
140 (rest (type-expand-to 'vector type))
141 (if (eq length '*)
142 (error "Can't inline vector with variable size: ~A" type)
143 (* (type-alignment element-type) length)))
144 (type-alignment 'pointer)))
145
e5426fae 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"))
151 (cond
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)
155 :content ,vector))
156 ,form))
157 ((and (in-arg-p style) (not (out-arg-p style)))
158 `(with-memory (,var ,(if (eq length '*)
159 `(* ,(size-of element-type)
160 (length ,vector))
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)
165 (unwind-protect
166 ,form
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)
175 (unwind-protect
176 ,form
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)
180 ,form)))))
181
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))
185
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)))
192
193
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))
197 (if (eq length '*)
198 (error "Can't use vector of variable size as return type")
199 `(let ((c-vector ,form))
200 (prog1
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)))))))
205
206
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))
210 (if inlined
211 (if (eq length '*)
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))
218 (setf
219 (ref-pointer location offset)
220 (make-c-vector element-type length :content vector :temp temp))))))
221
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))
225 (cond
226 ((eq length '*)
227 (error "Can't create reader function for vector with variable size"))
228 (inlined
229 #'(lambda (location &optional (offset 0))
230 (map-c-vector 'vector #'identity (pointer+ location offset)
231 element-type length ref)))
232 (t
233 (ecase ref
234 ((:read :peek)
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))))
239 (:get
240 #'(lambda (location &optional (offset 0))
241 (unless (null-pointer-p (ref-pointer location offset))
242 (prog1
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)))))))))))
247
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))
251 (cond
252 ((eq length '*)
253 (error "Can't create destroy function for vector with variable size"))
254 (inlined
255 #'(lambda (location &optional (offset 0))
256 (unset-c-vector (pointer+ location offset)
257 element-type length temp)))
258 (t
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))))))))
264
265(define-type-method copy-function ((type vector) &key inlined)
266 (destructuring-bind (element-type &optional (length '*))
267 (rest (type-expand-to 'vector type))
268 (cond
269 ((eq length '*) (error "Can't copy vector with variable size: ~A" type))
270 (inlined
271 (let ((copy-element (copy-function element-type))
272 (element-size (size-of element-type)))
273 #'(lambda (from to &optional (offset 0))
274 (loop
275 repeat length
276 for element from offset by element-size
277 do (funcall copy-element from to element)))))
278 (t
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)))))))))
286
f37a05bb 287
9cbf3858 288;;;; Unboxed vector
289
290(deftype unboxed-vector (element-type &optional (length '*))
291 `(simple-array ,element-type (,length)))
292
293(define-type-method argument-type ((type unboxed-vector))
294 type)
295
296(define-type-method return-type ((type unboxed-vector))
297 (destructuring-bind (element-type &optional (length '*))
298 (rest (type-expand-to 'unboxed-vector type))
299 (if (constantp length)
300 `(unboxed-vector ,(return-type element-type) ,length)
301 `(unboxed-vector ,(return-type element-type) *))))
302
303(defun check-unboxed-vector (type)
304 #+(or sbcl cmu)
305 (unless (subtypep type 'simple-unboxed-array)
306 (error "~A is not a subtype of ~A" type 'simple-unboxed-array)))
307
308#+(or sbcl cmu)
309(progn
310 (define-type-method alien-arg-wrapper ((type unboxed-vector) var vector style form &optional copy-in-p)
f37a05bb 311 (check-unboxed-vector type)
9cbf3858 312 (destructuring-bind (element-type &optional (length '*))
313 (rest (type-expand-to 'unboxed-vector type))
9cbf3858 314 (when (and (eq length '*) (out-arg-p style))
315 (error "Can't use vector with variable size as return type"))
316 (cond
317 ((and (in-arg-p style) copy-in-p)
318 `(with-pointer (,var (with-pinned-objects (,vector)
319 (copy-memory (vector-sap ,vector)
320 (* (length ,vector) ,(size-of element-type)))))
321 ,form))
322 ((in-arg-p style)
323 `(with-pinned-objects (,vector)
324 (let ((,var (vector-sap ,vector)))
325 ,form)))
326 ((out-arg-p style)
327 `(with-pointer (,var)
328 ,form)))))
329
330 (define-type-method to-alien-form ((type unboxed-vector) vector &optional copy-p)
331 (declare (ignore copy-p))
f37a05bb 332 (check-unboxed-vector type)
9cbf3858 333 (destructuring-bind (element-type &optional (length '*))
334 (rest (type-expand-to 'unboxed-vector type))
9cbf3858 335 `(with-pinned-objects (,vector)
336 (copy-memory
337 (vector-sap ,vector)
338 (* ,(if (eq length '*) `(length ,vector) length)
339 ,(size-of element-type))))))
340
341
342 (define-type-method from-alien-form ((type unboxed-vector) form &key (ref :free))
f37a05bb 343 (check-unboxed-vector type)
9cbf3858 344 (destructuring-bind (element-type &optional (length '*))
345 (rest (type-expand-to 'unboxed-vector type))
9cbf3858 346 (when (eq length '*)
347 (error "Can't use vector of variable size as return type"))
348 `(let ((c-vector ,form)
349 (vector (make-array ,length :element-type ',element-type)))
350 (with-pinned-objects (vector)
351 (copy-memory c-vector (* ,length ,(size-of element-type)) (vector-sap vector))
352 ,(when (eq ref :free)
353 `(deallocate-memory c-vector))
354 vector))))
355
356 (define-type-method writer-function ((type unboxed-vector) &key temp inlined)
357 (declare (ignore temp))
f37a05bb 358 (check-unboxed-vector type)
9cbf3858 359 (destructuring-bind (element-type &optional (length '*))
360 (rest (type-expand-to 'unboxed-vector type))
9cbf3858 361 (if inlined
362 (if (eq length '*)
363 (error "Can't inline vector with variable size: ~A" type)
364 #'(lambda (vector location &optional (offset 0))
365 (with-pinned-objects (vector)
366 (copy-memory
367 (vector-sap vector)
368 (* length (size-of element-type))
369 (pointer+ location offset)))))
370 #'(lambda (vector location &optional (offset 0))
371 (setf
372 (ref-pointer location offset)
373 (with-pinned-objects (vector)
374 (copy-memory (vector-sap vector)
375 (* (length vector) (size-of element-type)))))))))
376
377 (define-type-method reader-function ((type unboxed-vector) &key (ref :read) inlined)
f37a05bb 378 (check-unboxed-vector type)
9cbf3858 379 (destructuring-bind (element-type &optional (length '*))
380 (rest (type-expand-to 'unboxed-vector type))
9cbf3858 381 (cond
382 ((eq length '*)
383 (error "Can't create reader function for vector with variable size"))
384 (inlined
385 #'(lambda (location &optional (offset 0))
386 (let ((vector (make-array length :element-type element-type)))
387 (with-pinned-objects (vector)
388 (copy-memory
389 (pointer+ location offset)
390 (* length (size-of element-type))
391 (vector-sap vector))
392 vector))))
393 (t
394 #'(lambda (location &optional (offset 0))
395 (let ((vector (make-array length :element-type element-type)))
396 (unless (null-pointer-p (ref-pointer location offset))
397 (with-pinned-objects (vector)
398 (copy-memory
399 (ref-pointer location offset)
400 (* (length vector) (size-of element-type))
401 (vector-sap vector)))
402 (when (eq ref :get)
403 (deallocate-memory (ref-pointer location offset))
404 (setf (ref-pointer location offset) (make-pointer 0)))
405 vector))))))))
406
f37a05bb 407
408#-(or sbcl cmu)
409(progn
410 (define-type-method alien-arg-wrapper ((type unboxed-vector) var vector style form &optional copy-in-p)
411 (check-unboxed-vector type)
412 (destructuring-bind (element-type &optional (length '*))
413 (rest (type-expand-to 'unboxed-vector type))
414 (alien-arg-wrapper `(vector ,element-type ,length) var vector style form copy-in-p)))
415
416 (define-type-method to-alien-form ((type unboxed-vector) vector &optional copy-p)
417 (check-unboxed-vector type)
418 (destructuring-bind (element-type &optional (length '*))
419 (rest (type-expand-to 'unboxed-vector type))
420 (to-alien-form `(vector ,element-type ,length) vector copy-p)))
421
422 (define-type-method from-alien-form ((type unboxed-vector) form &key (ref :free))
423 (check-unboxed-vector type)
424 (destructuring-bind (element-type &optional (length '*))
425 (rest (type-expand-to 'unboxed-vector type))
426 (from-alien-form `(vector ,element-type ,length) form :ref ref)))
427
428 (define-type-method writer-function ((type unboxed-vector) &key temp inlined)
429 (check-unboxed-vector type)
430 (destructuring-bind (element-type &optional (length '*))
431 (rest (type-expand-to 'unboxed-vector type))
432 (writer-function `(vector ,element-type ,length) :temp temp :inlined inlined)))
433
434 (define-type-method reader-function ((type unboxed-vector) &key (ref :read) inlined)
435 (check-unboxed-vector type)
436 (destructuring-bind (element-type &optional (length '*))
437 (rest (type-expand-to 'unboxed-vector type))
438 (reader-function `(vector ,element-type ,length) :ref ref :inlined inlined))))
439
9cbf3858 440(define-type-method destroy-function ((type unboxed-vector) &key temp inlined)
441 (declare (ignore temp))
f37a05bb 442 (check-unboxed-vector type)
9cbf3858 443 (destructuring-bind (element-type &optional (length '*))
444 (rest (type-expand-to 'unboxed-vector type))
9cbf3858 445 (cond
446 #+sbcl
447 ((eq length '*)
448 (error "Can't create destroy function for vector with variable size"))
449 (inlined
450 #'(lambda (location &optional (offset 0))
451 (clear-memory location (* length (size-of element-type)) offset)))
452 (t
453 #'(lambda (location &optional (offset 0))
454 (unless (null-pointer-p (ref-pointer location offset))
455 (deallocate-memory (ref-pointer location offset))
456 (setf (ref-pointer location offset) (make-pointer 0))))))))
457
e5426fae 458
459;;;; Null terminated vector
460
461(defun make-0-vector (type &key content location temp)
462 (let* ((element-size (size-of type))
463 (length (length content))
464 (location (or location (allocate-memory (* element-size (1+ length))))))
465 (make-c-vector type length :content content :location location :temp temp)))
466
467
468(defun map-0-vector (seqtype function location element-type &optional (ref :read))
469 (let ((reader (reader-function element-type :ref ref))
470 (element-size (size-of element-type)))
471 (case seqtype
472 ((nil)
473 (loop
474 for offset by element-size
475 until (memory-clear-p (pointer+ location offset) element-size)
476 do (funcall function (funcall reader location offset))))
477 (list
478 (loop
479 for offset by element-size
480 until (memory-clear-p (pointer+ location offset) element-size)
481 collect (funcall function (funcall reader location offset))))
482 (t
483 (coerce
484 (loop
485 for offset by element-size
486 until (memory-clear-p (pointer+ location offset) element-size)
487 collect (funcall function (funcall reader location offset)))
488 seqtype)))))
489
490
491(defun unset-0-vector (location element-type &optional temp-p)
492 (loop
925b76cc 493 with destroy = (destroy-function element-type :temp temp-p)
e5426fae 494 with element-size = (size-of element-type)
495 for offset by element-size
496 until (memory-clear-p (pointer+ location offset) element-size)
497 do (funcall destroy location offset)))
498
499(defun destroy-0-vector (location element-type &optional temp-p)
500 (unset-0-vector location element-type temp-p)
501 (deallocate-memory location))
502
503
504(deftype vector0 (element-type) `(vector ,element-type))
505(deftype null-terminated-vector (element-type) `(vector0 ,element-type))
506
507(define-type-method alien-type ((type vector0))
508 (declare (ignore type))
509 (alien-type 'pointer))
510
511(define-type-method size-of ((type vector0) &key inlined)
512 (assert-not-inlined type inlined)
513 (size-of 'pointer))
514
90e8bbf6 515(define-type-method type-alignment ((type vector0) &key inlined)
516 (assert-not-inlined type inlined)
517 (type-alignment 'pointer))
518
e5426fae 519(define-type-method alien-arg-wrapper ((type vector0) var vector style form &optional copy-in-p)
520 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
521 (cond
522 ((and (in-arg-p style) copy-in-p)
523 `(with-pointer (,var (make-0-vector ',element-type :content ,vector))
524 ,form))
525 ((and (in-arg-p style) (not (out-arg-p style)))
526 `(with-memory (,var (* ,(size-of element-type) (1+ (length ,vector))))
527 (make-0-vector ',element-type :content ,vector :location ,var :temp t)
528 (unwind-protect
529 ,form
530 (unset-0-vector ,var ',element-type t))))
531 ((and (in-arg-p style) (out-arg-p style))
532 (let ((c-vector (make-symbol "C-VECTOR")))
533 `(with-memory (,c-vector (* ,(size-of element-type) (1+ (length ,vector))))
534 (make-0-vector ',element-type :content ,vector :location ,c-vector :temp t)
535 (with-pointer (,var ,c-vector)
536 (unwind-protect
537 ,form
538 (unset-0-vector ,c-vector ',element-type t))))))
539 ((and (out-arg-p style) (not (in-arg-p style)))
540 `(with-pointer (,var)
541 ,form)))))
542
543
544(define-type-method to-alien-form ((type vector0) vector &optional copy-p)
545 (declare (ignore copy-p))
546 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
547 `(make-0-vector ',element-type :content ,vector)))
548
549(define-type-method from-alien-form ((type vector0) form &key (ref :free))
550 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
551 `(let ((c-vector ,form))
552 (prog1
553 (map-0-vector 'vector #'identity c-vector ',element-type
554 ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
555 ,(when (eq ref :free)
556 `(deallocate-memory c-vector))))))
557
558
559(define-type-method writer-function ((type vector0) &key temp inlined)
560 (assert-not-inlined type inlined)
561 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
562 #'(lambda (vector location &optional (offset 0))
563 (setf
564 (ref-pointer location offset)
565 (make-0-vector element-type :content vector :temp temp)))))
566
567(define-type-method reader-function ((type vector0) &key (ref :read) inlined)
568 (assert-not-inlined type inlined)
569 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
570 (ecase ref
571 ((:read :peek)
572 #'(lambda (location &optional (offset 0))
573 (unless (null-pointer-p (ref-pointer location offset))
574 (map-0-vector 'vector #'identity (ref-pointer location offset)
575 element-type ref))))
576 (:get
577 #'(lambda (location &optional (offset 0))
578 (unless (null-pointer-p (ref-pointer location offset))
579 (prog1
580 (map-0-vector 'vector #'identity (ref-pointer location offset)
581 element-type :get)
582 (deallocate-memory (ref-pointer location offset))
583 (setf (ref-pointer location offset) (make-pointer 0)))))))))
584
585
586(define-type-method destroy-function ((type vector0) &key temp inlined)
587 (assert-not-inlined type inlined)
588 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
589 #'(lambda (location &optional (offset 0))
590 (unless (null-pointer-p (ref-pointer location offset))
591 (destroy-0-vector
592 (ref-pointer location offset) element-type temp)
593 (setf (ref-pointer location offset) (make-pointer 0))))))
594
595(define-type-method copy-function ((type vector0) &key inlined)
596 (assert-not-inlined type inlined)
597 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
598 (let ((copy-element (copy-function element-type))
599 (element-size (size-of element-type)))
600 #'(lambda (from to &optional (offset 0))
601 (unless (null-pointer-p (ref-pointer from offset))
602 (let* ((from-vector (ref-pointer from offset))
603 (length
604 (loop
605 for length from 0
606 for element by element-size
607 until (memory-clear-p from-vector element-size element)
608 finally (return length)))
110bd96c 609 (to-vector
610 (setf (ref-pointer to offset)
611 (allocate-memory (* (1+ length) element-size)))))
e5426fae 612 (loop
613 repeat length
614 for element by element-size
615 do (funcall copy-element from-vector to-vector element))))))))
616
617(define-type-method unbound-value ((type vector0))
618 (declare (ignore type))
619 nil)
620
621
622
623;;;; Counted vector
624
625(defun make-counted-vector (type &key content location (counter-type 'unsigned-int) temp)
626 (let* ((element-size (size-of type))
627 (length (length content))
628 (location (or
629 location
630 (allocate-memory
631 (+ (size-of counter-type) (* element-size length))))))
632 (funcall (writer-function counter-type :temp temp) length location)
633 (make-c-vector type length :content content :location (pointer+ location (size-of counter-type)))
634 location))
635
636(defun map-counted-vector (seqtype function location element-type &optional (counter-type 'unsigned-int) (ref :read))
637 (let ((length (funcall (reader-function counter-type) location :ref ref)))
638 (map-c-vector
639 seqtype function (pointer+ location (size-of counter-type))
640 element-type length)))
641
642(defun unset-counted-vector (location element-type &optional (counter-type 'unsigned-int) temp-p)
643 (let ((length (funcall (reader-function counter-type) location)))
644 (unset-c-vector
645 (pointer+ location (size-of counter-type)) element-type length temp-p)))
646
647(defun destroy-counted-vector (location element-type &optional (counter-type 'unsigned-int) temp-p)
648 (unset-counted-vector location element-type counter-type temp-p)
649 (deallocate-memory location))
650
651
652(deftype counted-vector (element-type &optional counter-type)
653 (declare (ignore counter-type))
654 `(vector ,element-type))
655
656(define-type-method alien-type ((type counted-vector))
657 (declare (ignore type))
658 (alien-type 'pointer))
659
660(define-type-method size-of ((type counted-vector) &key inlined)
661 (assert-not-inlined type inlined)
662 (size-of 'pointer))
663
90e8bbf6 664(define-type-method type-alignment ((type counted-vector) &key inlined)
665 (assert-not-inlined type inlined)
666 (type-alignment 'pointer))
667
e5426fae 668(define-type-method alien-arg-wrapper ((type counted-vector) var vector style form &optional copy-in-p)
669 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
670 (rest (type-expand-to 'counted-vector type))
671 (cond
672 ((and (in-arg-p style) copy-in-p)
673 `(with-pointer (,var (make-counted-vector ',element-type
674 :content ,vector :counter-type ',counter-type))
675 ,form))
676 ((and (in-arg-p style) (not (out-arg-p style)))
677 `(with-memory (,var (+ (* ,(size-of element-type) (length ,vector)) ,(size-of counter-type)))
678 (make-counted-vector ',element-type :content ,vector
679 :location ,var :counter-type ',counter-type :temp t)
680 (unwind-protect
681 ,form
682 (unset-counted-vector ,var ',element-type ',counter-type t))))
683 ((and (in-arg-p style) (out-arg-p style))
684 (let ((c-vector (make-symbol "C-VECTOR")))
685 `(with-memory (,c-vector (+ (* ,(size-of element-type) (length ,vector)) ,(size-of counter-type)))
686 (make-counted-vector ',element-type :content ,vector ,c-vector
687 :counter-type ',counter-type :temp t)
688 (with-pointer (,var ,c-vector)
689 (unwind-protect
690 ,form
691 (unset-counted-vector ,c-vector ',element-type ',counter-type t))))))
692 ((and (out-arg-p style) (not (in-arg-p style)))
693 `(with-pointer (,var)
694 ,form)))))
695
696
697(define-type-method to-alien-form ((type counted-vector) vector &optional copy-p)
698 (declare (ignore copy-p))
699 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
700 (rest (type-expand-to 'counted-vector type))
701 `(make-counted-vector ',element-type
702 :content ,vector :counter-type ',counter-type)))
703
704(define-type-method from-alien-form ((type counted-vector) form &key (ref :free))
705 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
706 (rest (type-expand-to 'counted-vector type))
707 `(let ((c-vector ,form))
708 (prog1
709 (map-counted-vector 'vector #'identity c-vector ',element-type ',counter-type
710 ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
711 ,(when (eq ref :free)
712 `(deallocate c-vector))))))
713
714(define-type-method writer-function ((type counted-vector) &key temp inlined)
715 (assert-not-inlined type inlined)
716 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
717 (rest (type-expand-to 'counted-vector type))
718 #'(lambda (vector location &optional (offset 0))
719 (setf
720 (ref-pointer location offset)
721 (make-counted-vector element-type :content vector
722 :counter-type counter-type :temp temp)))))
723
724(define-type-method reader-function ((type counted-vector) &key (ref :read) inlined)
725 (assert-not-inlined type inlined)
726 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
727 (rest (type-expand-to 'counted-vector type))
728 (ecase ref
729 ((:read :peek)
730 #'(lambda (location &optional (offset 0))
731 (unless (null-pointer-p (ref-pointer location offset))
732 (map-counted-vector 'vector #'identity
733 (ref-pointer location offset) element-type counter-type ref))))
734 (:get
735 #'(lambda (location &optional (offset 0))
736 (unless (null-pointer-p (ref-pointer location offset))
737 (prog1
738 (map-counted-vector 'vector #'identity
739 (ref-pointer location offset) element-type counter-type :get)
740 (deallocate-memory (ref-pointer location offset))
741 (setf (ref-pointer location offset) (make-pointer 0)))))))))
742
743(define-type-method destroy-function ((type counted-vector) &key temp inlined)
744 (assert-not-inlined type inlined)
745 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
746 (rest (type-expand-to 'counted-vector type))
747 #'(lambda (location &optional (offset 0))
748 (unless (null-pointer-p (ref-pointer location offset))
749 (destroy-counted-vector (ref-pointer location offset)
750 element-type counter-type temp)
751 (setf (ref-pointer location offset) (make-pointer 0))))))
752
753(define-type-method copy-function ((type counted-vector) &key inlined)
754 (assert-not-inlined type inlined)
755 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
756 (rest (type-expand-to 'counted-vector type))
757 (let ((vector-length (reader-function counter-type))
758 (counter-size (size-of counter-type))
759 (copy-element (copy-function element-type))
760 (element-size (size-of element-type)))
761 #'(lambda (from to &optional (offset 0))
762 (unless (null-pointer-p (ref-pointer from offset))
763 (let* ((from-vector (ref-pointer from offset))
764 (length (funcall vector-length from-vector))
765 (to-vector (setf
766 (ref-pointer to offset)
767 (allocate-memory (+ counter-size (* length element-size))))))
768 (copy-memory from-vector counter-size to-vector)
769 (loop
770 repeat length
771 for element from counter-size by element-size
772 do (funcall copy-element from-vector to-vector element))))))))
2c708568 773
774
775;;;; Accessor functions for raw memory access
776
777(defun vector-reader-function (type &key (start 0) end)
778 "Returns a function for reading values from raw C vectors"
779 (let ((element-size (size-of type))
780 (reader (reader-function type)))
781 #'(lambda (vector index)
782 (assert (and (>= index start) (or (not end) (< index end))))
783 (funcall reader vector (* index element-size)))))
784
785(defun vector-writer-function (type &key (start 0) end)
786 "Returns a function for writing values to raw C vectors"
787 (let ((element-size (size-of type))
788 (writer (writer-function type)))
789 #'(lambda (value vector index)
790 (assert (and (>= index start) (or (not end) (< index end))))
791 (funcall writer value vector (* index element-size)))))
792
793
794(defmacro define-vector-accessor (type)
795 (let ((name (intern (format nil "VECTOR-REF-~A" type)))
796 (ref (intern (format nil "REF-~A" type))))
797 `(progn
798 (declaim
799 (ftype (function (pointer fixnum) ,type) ,name)
800 (inline ,name))
801 (defun ,name (vector index)
802 (,ref vector (* ,(size-of type) index)))
803 (declaim
804 (ftype (function (,type pointer fixnum) ,type) (setf ,name))
805 (inline (setf ,name)))
806 (defun (setf ,name) (value vector index)
807 (setf (,ref vector (* ,(size-of type) index)) value)))))
808
809(define-vector-accessor int-8)
810(define-vector-accessor uint-8)
811(define-vector-accessor int-16)
812(define-vector-accessor uint-16)
813(define-vector-accessor int-32)
814(define-vector-accessor uint-32)
815(define-vector-accessor int-64)
816(define-vector-accessor uint-64)
817(define-vector-accessor double-float)
818(define-vector-accessor single-float)
819