chiark / gitweb /
Bug fix in SCALE-TO-DEVICE
[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
925b76cc 23;; $Id: vectors.lisp,v 1.4 2007-06-18 10:13:07 espen Exp $
e5426fae 24
25
26(in-package "GFFI")
27
28;;; Vector
29
30(defun make-c-vector (type length &key content location temp)
31 (let* ((element-size (size-of type))
32 (location (or location (allocate-memory (* element-size length))))
33 (writer (writer-function type :temp temp)))
34 (etypecase content
35 (vector
36 (loop
37 for element across content
38 for i below length
39 for offset by element-size
40 do (funcall writer element location offset)))
41 (list
42 (loop
43 for element in content
44 for i below length
45 for offset by element-size
46 do (funcall writer element location offset))))
47 location))
48
49
50(defun map-c-vector (seqtype function location element-type length
51 &optional (ref :read))
52 (let ((reader (reader-function element-type :ref ref))
53 (element-size (size-of element-type)))
54 (case seqtype
55 ((nil)
56 (loop
57 for i below length
58 for offset by element-size
59 do (funcall function (funcall reader location offset))))
60 (list
61 (loop
62 for i below length
63 for offset by element-size
64 collect (funcall function (funcall reader location offset))))
65 (t
66 (loop
67 with sequence = (make-sequence seqtype length)
68 for i below length
69 for offset by element-size
70 do (setf
71 (elt sequence i)
72 (funcall function (funcall reader location offset)))
73 finally (return sequence))))))
74
75
76(defun unset-c-vector (location element-type length &optional temp-p)
77 (loop
78 with destroy = (destroy-function element-type :temp temp-p)
79 with element-size = (size-of element-type)
80 for i below length
81 for offset by element-size
82 do (funcall destroy location offset)))
83
84
85(defun destroy-c-vector (location element-type length &optional temp-p)
86 (unset-c-vector location element-type length temp-p)
87 (deallocate-memory location))
88
89
90(defmacro with-c-vector (var type content &body body)
91 (let ((length (make-symbol "LENGTH")))
92 `(let ((,length (length ,content)))
93 (with-memory (,var (* ,(size-of type) ,length))
94 (make-c-vector ',type ,length :content ,content :location ,var :temp t)
95 (unwind-protect
96 (progn ,@body)
97 (unset-c-vector ,var ',type ,length t))))))
98
99
100(define-type-method alien-type ((type vector))
101 (declare (ignore type))
102 (alien-type 'pointer))
103
104(define-type-method size-of ((type vector) &key inlined)
105 (if inlined
106 (destructuring-bind (element-type &optional (length '*))
107 (rest (type-expand-to 'vector type))
108 (if (eq length '*)
109 (error "Can't inline vector with variable size: ~A" type)
110 (* (size-of element-type) length)))
111 (size-of 'pointer)))
112
90e8bbf6 113(define-type-method type-alignment ((type vector) &key inlined)
114 (if inlined
115 (destructuring-bind (element-type &optional (length '*))
116 (rest (type-expand-to 'vector type))
117 (if (eq length '*)
118 (error "Can't inline vector with variable size: ~A" type)
119 (* (type-alignment element-type) length)))
120 (type-alignment 'pointer)))
121
e5426fae 122(define-type-method alien-arg-wrapper ((type vector) var vector style form &optional copy-in-p)
123 (destructuring-bind (element-type &optional (length '*))
124 (rest (type-expand-to 'vector type))
125 (when (and (eq length '*) (out-arg-p style))
126 (error "Can't use vector with variable size as return type"))
127 (cond
128 ((and (in-arg-p style) copy-in-p)
129 `(with-pointer (,var `(make-c-vector ',element-type
130 ,(if (eq length '*) `(length ,vector) length)
131 :content ,vector))
132 ,form))
133 ((and (in-arg-p style) (not (out-arg-p style)))
134 `(with-memory (,var ,(if (eq length '*)
135 `(* ,(size-of element-type)
136 (length ,vector))
137 `(* ,(size-of element-type) ,length)))
138 (make-c-vector ',element-type
139 ,(if (eq length '*) `(length ,vector) length)
140 :content ,vector :location ,var :temp t)
141 (unwind-protect
142 ,form
143 (unset-c-vector ,var ',element-type
144 ,(if (eq length '*) `(length ,vector) length) t))))
145 ((and (in-arg-p style) (out-arg-p style))
146 (let ((c-vector (make-symbol "C-VECTOR")))
147 `(with-memory (,c-vector (* ,(size-of element-type) length))
148 (make-c-vector ',element-type ,length
149 :content ,vector :location ,c-vector :temp t)
150 (with-pointer (,var ,c-vector)
151 (unwind-protect
152 ,form
153 (unset-c-vector ,c-vector ',element-type ,length t))))))
154 ((and (out-arg-p style) (not (in-arg-p style)))
155 `(with-pointer (,var)
156 ,form)))))
157
158;; This will enable us specify vectors with variable length in C callbacks
159(define-type-method callback-wrapper ((type vector) var vector form)
160 (funcall (find-applicable-type-method 'callback-wrapper t) type var vector form))
161
162(define-type-method to-alien-form ((type vector) vector &optional copy-p)
163 (declare (ignore copy-p))
164 (destructuring-bind (element-type &optional (length '*))
165 (rest (type-expand-to 'vector type))
166 `(make-c-vector ',element-type
167 ,(if (eq length '*) `(length ,vector) length) :content ,vector)))
168
169
170(define-type-method from-alien-form ((type vector) form &key (ref :free))
171 (destructuring-bind (element-type &optional (length '*))
172 (rest (type-expand-to 'vector type))
173 (if (eq length '*)
174 (error "Can't use vector of variable size as return type")
175 `(let ((c-vector ,form))
176 (prog1
177 (map-c-vector 'vector #'identity c-vector ',element-type ,length
178 ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
179 ,(when (eq ref :free)
180 `(deallocate-memory c-vector)))))))
181
182
183(define-type-method writer-function ((type vector) &key temp inlined)
184 (destructuring-bind (element-type &optional (length '*))
185 (rest (type-expand-to 'vector type))
186 (if inlined
187 (if (eq length '*)
188 (error "Can't inline vector with variable size: ~A" type)
189 #'(lambda (vector location &optional (offset 0))
190 (make-c-vector element-type length
191 :location (pointer+ location offset)
192 :content vector :temp temp)))
193 #'(lambda (vector location &optional (offset 0))
194 (setf
195 (ref-pointer location offset)
196 (make-c-vector element-type length :content vector :temp temp))))))
197
198(define-type-method reader-function ((type vector) &key (ref :read) inlined)
199 (destructuring-bind (element-type &optional (length '*))
200 (rest (type-expand-to 'vector type))
201 (cond
202 ((eq length '*)
203 (error "Can't create reader function for vector with variable size"))
204 (inlined
205 #'(lambda (location &optional (offset 0))
206 (map-c-vector 'vector #'identity (pointer+ location offset)
207 element-type length ref)))
208 (t
209 (ecase ref
210 ((:read :peek)
211 #'(lambda (location &optional (offset 0))
212 (unless (null-pointer-p (ref-pointer location offset))
213 (map-c-vector 'vector #'identity (ref-pointer location offset)
214 element-type length ref))))
215 (:get
216 #'(lambda (location &optional (offset 0))
217 (unless (null-pointer-p (ref-pointer location offset))
218 (prog1
219 (map-c-vector 'vector #'identity
220 (ref-pointer location offset) element-type length :get)
221 (deallocate-memory (ref-pointer location offset))
222 (setf (ref-pointer location offset) (make-pointer 0)))))))))))
223
224(define-type-method destroy-function ((type vector) &key temp inlined)
225 (destructuring-bind (element-type &optional (length '*))
226 (rest (type-expand-to 'vector type))
227 (cond
228 ((eq length '*)
229 (error "Can't create destroy function for vector with variable size"))
230 (inlined
231 #'(lambda (location &optional (offset 0))
232 (unset-c-vector (pointer+ location offset)
233 element-type length temp)))
234 (t
235 #'(lambda (location &optional (offset 0))
236 (unless (null-pointer-p (ref-pointer location offset))
237 (destroy-c-vector (ref-pointer location offset)
238 element-type length temp)
239 (setf (ref-pointer location offset) (make-pointer 0))))))))
240
241(define-type-method copy-function ((type vector) &key inlined)
242 (destructuring-bind (element-type &optional (length '*))
243 (rest (type-expand-to 'vector type))
244 (cond
245 ((eq length '*) (error "Can't copy vector with variable size: ~A" type))
246 (inlined
247 (let ((copy-element (copy-function element-type))
248 (element-size (size-of element-type)))
249 #'(lambda (from to &optional (offset 0))
250 (loop
251 repeat length
252 for element from offset by element-size
253 do (funcall copy-element from to element)))))
254 (t
255 (let ((size (* length (size-of element-type)))
256 (copy-content (copy-function type :inlined t)))
257 #'(lambda (from to &optional (offset 0))
258 (unless (null-pointer-p (ref-pointer from offset))
259 (let ((vector (allocate-memory size)))
260 (setf (ref-pointer to offset) vector)
261 (funcall copy-content (ref-pointer from offset) vector)))))))))
262
263
264;;;; Null terminated vector
265
266(defun make-0-vector (type &key content location temp)
267 (let* ((element-size (size-of type))
268 (length (length content))
269 (location (or location (allocate-memory (* element-size (1+ length))))))
270 (make-c-vector type length :content content :location location :temp temp)))
271
272
273(defun map-0-vector (seqtype function location element-type &optional (ref :read))
274 (let ((reader (reader-function element-type :ref ref))
275 (element-size (size-of element-type)))
276 (case seqtype
277 ((nil)
278 (loop
279 for offset by element-size
280 until (memory-clear-p (pointer+ location offset) element-size)
281 do (funcall function (funcall reader location offset))))
282 (list
283 (loop
284 for offset by element-size
285 until (memory-clear-p (pointer+ location offset) element-size)
286 collect (funcall function (funcall reader location offset))))
287 (t
288 (coerce
289 (loop
290 for offset by element-size
291 until (memory-clear-p (pointer+ location offset) element-size)
292 collect (funcall function (funcall reader location offset)))
293 seqtype)))))
294
295
296(defun unset-0-vector (location element-type &optional temp-p)
297 (loop
925b76cc 298 with destroy = (destroy-function element-type :temp temp-p)
e5426fae 299 with element-size = (size-of element-type)
300 for offset by element-size
301 until (memory-clear-p (pointer+ location offset) element-size)
302 do (funcall destroy location offset)))
303
304(defun destroy-0-vector (location element-type &optional temp-p)
305 (unset-0-vector location element-type temp-p)
306 (deallocate-memory location))
307
308
309(deftype vector0 (element-type) `(vector ,element-type))
310(deftype null-terminated-vector (element-type) `(vector0 ,element-type))
311
312(define-type-method alien-type ((type vector0))
313 (declare (ignore type))
314 (alien-type 'pointer))
315
316(define-type-method size-of ((type vector0) &key inlined)
317 (assert-not-inlined type inlined)
318 (size-of 'pointer))
319
90e8bbf6 320(define-type-method type-alignment ((type vector0) &key inlined)
321 (assert-not-inlined type inlined)
322 (type-alignment 'pointer))
323
e5426fae 324(define-type-method alien-arg-wrapper ((type vector0) var vector style form &optional copy-in-p)
325 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
326 (cond
327 ((and (in-arg-p style) copy-in-p)
328 `(with-pointer (,var (make-0-vector ',element-type :content ,vector))
329 ,form))
330 ((and (in-arg-p style) (not (out-arg-p style)))
331 `(with-memory (,var (* ,(size-of element-type) (1+ (length ,vector))))
332 (make-0-vector ',element-type :content ,vector :location ,var :temp t)
333 (unwind-protect
334 ,form
335 (unset-0-vector ,var ',element-type t))))
336 ((and (in-arg-p style) (out-arg-p style))
337 (let ((c-vector (make-symbol "C-VECTOR")))
338 `(with-memory (,c-vector (* ,(size-of element-type) (1+ (length ,vector))))
339 (make-0-vector ',element-type :content ,vector :location ,c-vector :temp t)
340 (with-pointer (,var ,c-vector)
341 (unwind-protect
342 ,form
343 (unset-0-vector ,c-vector ',element-type t))))))
344 ((and (out-arg-p style) (not (in-arg-p style)))
345 `(with-pointer (,var)
346 ,form)))))
347
348
349(define-type-method to-alien-form ((type vector0) vector &optional copy-p)
350 (declare (ignore copy-p))
351 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
352 `(make-0-vector ',element-type :content ,vector)))
353
354(define-type-method from-alien-form ((type vector0) form &key (ref :free))
355 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
356 `(let ((c-vector ,form))
357 (prog1
358 (map-0-vector 'vector #'identity c-vector ',element-type
359 ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
360 ,(when (eq ref :free)
361 `(deallocate-memory c-vector))))))
362
363
364(define-type-method writer-function ((type vector0) &key temp inlined)
365 (assert-not-inlined type inlined)
366 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
367 #'(lambda (vector location &optional (offset 0))
368 (setf
369 (ref-pointer location offset)
370 (make-0-vector element-type :content vector :temp temp)))))
371
372(define-type-method reader-function ((type vector0) &key (ref :read) inlined)
373 (assert-not-inlined type inlined)
374 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
375 (ecase ref
376 ((:read :peek)
377 #'(lambda (location &optional (offset 0))
378 (unless (null-pointer-p (ref-pointer location offset))
379 (map-0-vector 'vector #'identity (ref-pointer location offset)
380 element-type ref))))
381 (:get
382 #'(lambda (location &optional (offset 0))
383 (unless (null-pointer-p (ref-pointer location offset))
384 (prog1
385 (map-0-vector 'vector #'identity (ref-pointer location offset)
386 element-type :get)
387 (deallocate-memory (ref-pointer location offset))
388 (setf (ref-pointer location offset) (make-pointer 0)))))))))
389
390
391(define-type-method destroy-function ((type vector0) &key temp inlined)
392 (assert-not-inlined type inlined)
393 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
394 #'(lambda (location &optional (offset 0))
395 (unless (null-pointer-p (ref-pointer location offset))
396 (destroy-0-vector
397 (ref-pointer location offset) element-type temp)
398 (setf (ref-pointer location offset) (make-pointer 0))))))
399
400(define-type-method copy-function ((type vector0) &key inlined)
401 (assert-not-inlined type inlined)
402 (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
403 (let ((copy-element (copy-function element-type))
404 (element-size (size-of element-type)))
405 #'(lambda (from to &optional (offset 0))
406 (unless (null-pointer-p (ref-pointer from offset))
407 (let* ((from-vector (ref-pointer from offset))
408 (length
409 (loop
410 for length from 0
411 for element by element-size
412 until (memory-clear-p from-vector element-size element)
413 finally (return length)))
110bd96c 414 (to-vector
415 (setf (ref-pointer to offset)
416 (allocate-memory (* (1+ length) element-size)))))
e5426fae 417 (loop
418 repeat length
419 for element by element-size
420 do (funcall copy-element from-vector to-vector element))))))))
421
422(define-type-method unbound-value ((type vector0))
423 (declare (ignore type))
424 nil)
425
426
427
428;;;; Counted vector
429
430(defun make-counted-vector (type &key content location (counter-type 'unsigned-int) temp)
431 (let* ((element-size (size-of type))
432 (length (length content))
433 (location (or
434 location
435 (allocate-memory
436 (+ (size-of counter-type) (* element-size length))))))
437 (funcall (writer-function counter-type :temp temp) length location)
438 (make-c-vector type length :content content :location (pointer+ location (size-of counter-type)))
439 location))
440
441(defun map-counted-vector (seqtype function location element-type &optional (counter-type 'unsigned-int) (ref :read))
442 (let ((length (funcall (reader-function counter-type) location :ref ref)))
443 (map-c-vector
444 seqtype function (pointer+ location (size-of counter-type))
445 element-type length)))
446
447(defun unset-counted-vector (location element-type &optional (counter-type 'unsigned-int) temp-p)
448 (let ((length (funcall (reader-function counter-type) location)))
449 (unset-c-vector
450 (pointer+ location (size-of counter-type)) element-type length temp-p)))
451
452(defun destroy-counted-vector (location element-type &optional (counter-type 'unsigned-int) temp-p)
453 (unset-counted-vector location element-type counter-type temp-p)
454 (deallocate-memory location))
455
456
457(deftype counted-vector (element-type &optional counter-type)
458 (declare (ignore counter-type))
459 `(vector ,element-type))
460
461(define-type-method alien-type ((type counted-vector))
462 (declare (ignore type))
463 (alien-type 'pointer))
464
465(define-type-method size-of ((type counted-vector) &key inlined)
466 (assert-not-inlined type inlined)
467 (size-of 'pointer))
468
90e8bbf6 469(define-type-method type-alignment ((type counted-vector) &key inlined)
470 (assert-not-inlined type inlined)
471 (type-alignment 'pointer))
472
e5426fae 473(define-type-method alien-arg-wrapper ((type counted-vector) var vector style form &optional copy-in-p)
474 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
475 (rest (type-expand-to 'counted-vector type))
476 (cond
477 ((and (in-arg-p style) copy-in-p)
478 `(with-pointer (,var (make-counted-vector ',element-type
479 :content ,vector :counter-type ',counter-type))
480 ,form))
481 ((and (in-arg-p style) (not (out-arg-p style)))
482 `(with-memory (,var (+ (* ,(size-of element-type) (length ,vector)) ,(size-of counter-type)))
483 (make-counted-vector ',element-type :content ,vector
484 :location ,var :counter-type ',counter-type :temp t)
485 (unwind-protect
486 ,form
487 (unset-counted-vector ,var ',element-type ',counter-type t))))
488 ((and (in-arg-p style) (out-arg-p style))
489 (let ((c-vector (make-symbol "C-VECTOR")))
490 `(with-memory (,c-vector (+ (* ,(size-of element-type) (length ,vector)) ,(size-of counter-type)))
491 (make-counted-vector ',element-type :content ,vector ,c-vector
492 :counter-type ',counter-type :temp t)
493 (with-pointer (,var ,c-vector)
494 (unwind-protect
495 ,form
496 (unset-counted-vector ,c-vector ',element-type ',counter-type t))))))
497 ((and (out-arg-p style) (not (in-arg-p style)))
498 `(with-pointer (,var)
499 ,form)))))
500
501
502(define-type-method to-alien-form ((type counted-vector) vector &optional copy-p)
503 (declare (ignore copy-p))
504 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
505 (rest (type-expand-to 'counted-vector type))
506 `(make-counted-vector ',element-type
507 :content ,vector :counter-type ',counter-type)))
508
509(define-type-method from-alien-form ((type counted-vector) form &key (ref :free))
510 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
511 (rest (type-expand-to 'counted-vector type))
512 `(let ((c-vector ,form))
513 (prog1
514 (map-counted-vector 'vector #'identity c-vector ',element-type ',counter-type
515 ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
516 ,(when (eq ref :free)
517 `(deallocate c-vector))))))
518
519(define-type-method writer-function ((type counted-vector) &key temp inlined)
520 (assert-not-inlined type inlined)
521 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
522 (rest (type-expand-to 'counted-vector type))
523 #'(lambda (vector location &optional (offset 0))
524 (setf
525 (ref-pointer location offset)
526 (make-counted-vector element-type :content vector
527 :counter-type counter-type :temp temp)))))
528
529(define-type-method reader-function ((type counted-vector) &key (ref :read) inlined)
530 (assert-not-inlined type inlined)
531 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
532 (rest (type-expand-to 'counted-vector type))
533 (ecase ref
534 ((:read :peek)
535 #'(lambda (location &optional (offset 0))
536 (unless (null-pointer-p (ref-pointer location offset))
537 (map-counted-vector 'vector #'identity
538 (ref-pointer location offset) element-type counter-type ref))))
539 (:get
540 #'(lambda (location &optional (offset 0))
541 (unless (null-pointer-p (ref-pointer location offset))
542 (prog1
543 (map-counted-vector 'vector #'identity
544 (ref-pointer location offset) element-type counter-type :get)
545 (deallocate-memory (ref-pointer location offset))
546 (setf (ref-pointer location offset) (make-pointer 0)))))))))
547
548(define-type-method destroy-function ((type counted-vector) &key temp inlined)
549 (assert-not-inlined type inlined)
550 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
551 (rest (type-expand-to 'counted-vector type))
552 #'(lambda (location &optional (offset 0))
553 (unless (null-pointer-p (ref-pointer location offset))
554 (destroy-counted-vector (ref-pointer location offset)
555 element-type counter-type temp)
556 (setf (ref-pointer location offset) (make-pointer 0))))))
557
558(define-type-method copy-function ((type counted-vector) &key inlined)
559 (assert-not-inlined type inlined)
560 (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
561 (rest (type-expand-to 'counted-vector type))
562 (let ((vector-length (reader-function counter-type))
563 (counter-size (size-of counter-type))
564 (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))
569 (length (funcall vector-length from-vector))
570 (to-vector (setf
571 (ref-pointer to offset)
572 (allocate-memory (+ counter-size (* length element-size))))))
573 (copy-memory from-vector counter-size to-vector)
574 (loop
575 repeat length
576 for element from counter-size by element-size
577 do (funcall copy-element from-vector to-vector element))))))))