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