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