chiark / gitweb /
Vector arguments declared as SEQUENCE
[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.6 2008-04-11 20:19:09 espen Exp $
24
25
26 (in-package "GFFI")
27
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
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
117 (define-type-method argument-type ((type vector))
118   (declare (ignore type))
119   'sequence)
120
121 (define-type-method return-type ((type vector))
122   (destructuring-bind (element-type &optional (length '*)) 
123       (rest (type-expand-to 'vector type))
124     (if (constantp length)
125         `(vector ,(return-type element-type) ,length)
126       `(vector ,(return-type element-type) *))))
127
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
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
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
287
288 ;;;; Null terminated vector
289
290 (defun make-0-vector (type &key content location temp)
291   (let* ((element-size (size-of type))
292          (length (length content))
293          (location (or location (allocate-memory (* element-size (1+ length))))))
294     (make-c-vector type length :content content :location location :temp temp)))
295
296
297 (defun map-0-vector (seqtype function location element-type &optional (ref :read))
298   (let ((reader (reader-function element-type :ref ref))
299         (element-size (size-of element-type)))
300     (case seqtype 
301      ((nil)
302       (loop
303        for offset by element-size
304        until (memory-clear-p (pointer+ location offset) element-size)
305        do (funcall function (funcall reader location offset))))
306      (list
307       (loop
308        for offset by element-size
309        until (memory-clear-p (pointer+ location offset) element-size)
310        collect (funcall function (funcall reader location offset))))
311      (t
312       (coerce 
313        (loop
314         for offset by element-size
315         until (memory-clear-p (pointer+ location offset) element-size)
316         collect (funcall function (funcall reader location offset)))
317        seqtype)))))
318
319
320 (defun unset-0-vector (location element-type &optional temp-p)
321   (loop
322    with destroy = (destroy-function element-type :temp temp-p)
323    with element-size = (size-of element-type)
324    for offset by element-size
325    until (memory-clear-p (pointer+ location offset) element-size)
326    do (funcall destroy location offset)))
327
328 (defun destroy-0-vector (location element-type &optional temp-p)
329   (unset-0-vector location element-type temp-p)
330   (deallocate-memory location))
331
332
333 (deftype vector0 (element-type) `(vector ,element-type))
334 (deftype null-terminated-vector (element-type) `(vector0 ,element-type))
335
336 (define-type-method alien-type ((type vector0))
337   (declare (ignore type))
338   (alien-type 'pointer))
339
340 (define-type-method size-of ((type vector0) &key inlined)
341   (assert-not-inlined type inlined)
342   (size-of 'pointer))
343
344 (define-type-method type-alignment ((type vector0) &key inlined)
345   (assert-not-inlined type inlined)
346   (type-alignment 'pointer))
347
348 (define-type-method alien-arg-wrapper ((type vector0) var vector style form &optional copy-in-p)
349   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
350     (cond
351       ((and (in-arg-p style) copy-in-p)
352        `(with-pointer (,var (make-0-vector ',element-type :content ,vector))
353           ,form))
354       ((and (in-arg-p style) (not (out-arg-p style)))
355        `(with-memory (,var (* ,(size-of element-type) (1+ (length ,vector))))
356           (make-0-vector ',element-type :content ,vector :location ,var :temp t)
357           (unwind-protect
358               ,form
359             (unset-0-vector ,var ',element-type t))))
360       ((and (in-arg-p style) (out-arg-p style))
361        (let ((c-vector (make-symbol "C-VECTOR")))
362          `(with-memory (,c-vector (* ,(size-of element-type) (1+ (length ,vector))))
363             (make-0-vector ',element-type :content ,vector :location ,c-vector :temp t)
364             (with-pointer (,var ,c-vector)
365               (unwind-protect
366                   ,form
367                 (unset-0-vector ,c-vector ',element-type t))))))
368       ((and (out-arg-p style) (not (in-arg-p style)))
369        `(with-pointer (,var)
370           ,form)))))
371
372
373 (define-type-method to-alien-form ((type vector0) vector &optional copy-p)
374   (declare (ignore copy-p))
375   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
376     `(make-0-vector ',element-type :content ,vector)))
377
378 (define-type-method from-alien-form ((type vector0) form  &key (ref :free))
379   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
380     `(let ((c-vector ,form))
381        (prog1
382            (map-0-vector 'vector #'identity c-vector ',element-type
383             ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
384          ,(when (eq ref :free)  
385             `(deallocate-memory c-vector))))))
386
387
388 (define-type-method writer-function ((type vector0) &key temp inlined)  
389   (assert-not-inlined type inlined)
390   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
391     #'(lambda (vector location &optional (offset 0))
392         (setf 
393          (ref-pointer location offset)
394          (make-0-vector element-type :content vector :temp temp)))))
395
396 (define-type-method reader-function ((type vector0) &key (ref :read) inlined)
397   (assert-not-inlined type inlined)
398   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
399     (ecase ref
400       ((:read :peek)
401        #'(lambda (location &optional (offset 0))
402            (unless (null-pointer-p (ref-pointer location offset))
403              (map-0-vector 'vector #'identity (ref-pointer location offset) 
404               element-type ref))))
405       (:get
406        #'(lambda (location &optional (offset 0))
407            (unless (null-pointer-p (ref-pointer location offset))
408              (prog1
409                  (map-0-vector 'vector #'identity (ref-pointer location offset)
410                   element-type :get)
411                (deallocate-memory (ref-pointer location offset))
412                (setf (ref-pointer location offset) (make-pointer 0)))))))))
413
414
415 (define-type-method destroy-function ((type vector0) &key temp inlined)
416   (assert-not-inlined type inlined)
417   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
418     #'(lambda (location &optional (offset 0))
419           (unless (null-pointer-p (ref-pointer location offset))
420             (destroy-0-vector 
421              (ref-pointer location offset) element-type temp)
422             (setf (ref-pointer location offset) (make-pointer 0))))))
423
424 (define-type-method copy-function ((type vector0) &key inlined)
425   (assert-not-inlined type inlined)
426   (destructuring-bind (element-type) (rest (type-expand-to 'vector0 type))
427     (let ((copy-element (copy-function element-type))
428           (element-size (size-of element-type)))
429       #'(lambda (from to &optional (offset 0))
430           (unless (null-pointer-p (ref-pointer from offset))
431             (let* ((from-vector (ref-pointer from offset))
432                    (length 
433                     (loop
434                      for length from 0
435                      for element by element-size
436                      until (memory-clear-p from-vector element-size element)
437                      finally (return length)))
438                    (to-vector 
439                     (setf (ref-pointer to offset)                 
440                      (allocate-memory (* (1+ length) element-size)))))
441               (loop
442                repeat length
443                for element by element-size
444                do (funcall copy-element from-vector to-vector element))))))))
445
446 (define-type-method unbound-value ((type vector0))
447   (declare (ignore type))
448   nil)
449
450
451
452 ;;;; Counted vector
453
454 (defun make-counted-vector (type &key content location (counter-type 'unsigned-int) temp)
455   (let* ((element-size (size-of type))
456          (length (length content))
457          (location (or 
458                     location
459                     (allocate-memory 
460                      (+ (size-of counter-type) (* element-size length))))))
461     (funcall (writer-function counter-type :temp temp) length location)
462     (make-c-vector type length :content content :location (pointer+ location (size-of counter-type)))
463     location))
464
465 (defun map-counted-vector (seqtype function location element-type &optional (counter-type 'unsigned-int) (ref :read))
466   (let ((length (funcall (reader-function counter-type) location :ref ref)))
467     (map-c-vector 
468      seqtype function (pointer+ location (size-of counter-type))
469      element-type length)))
470
471 (defun unset-counted-vector (location element-type &optional (counter-type 'unsigned-int) temp-p)
472   (let ((length (funcall (reader-function counter-type) location)))
473     (unset-c-vector 
474      (pointer+ location (size-of counter-type)) element-type length temp-p)))
475
476 (defun destroy-counted-vector (location element-type &optional (counter-type 'unsigned-int) temp-p)
477   (unset-counted-vector location element-type counter-type temp-p)
478   (deallocate-memory location))
479
480
481 (deftype counted-vector (element-type &optional counter-type) 
482   (declare (ignore counter-type))
483   `(vector ,element-type))
484
485 (define-type-method alien-type ((type counted-vector))
486   (declare (ignore type))
487   (alien-type 'pointer))
488
489 (define-type-method size-of ((type counted-vector) &key inlined)
490   (assert-not-inlined type inlined)
491   (size-of 'pointer))
492
493 (define-type-method type-alignment ((type counted-vector) &key inlined)
494   (assert-not-inlined type inlined)
495   (type-alignment 'pointer))
496
497 (define-type-method alien-arg-wrapper ((type counted-vector) var vector style form &optional copy-in-p)
498   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
499       (rest (type-expand-to 'counted-vector type))
500     (cond
501       ((and (in-arg-p style) copy-in-p)
502        `(with-pointer (,var (make-counted-vector ',element-type 
503                              :content ,vector :counter-type ',counter-type))
504           ,form))
505       ((and (in-arg-p style) (not (out-arg-p style)))
506        `(with-memory (,var (+ (* ,(size-of element-type) (length ,vector)) ,(size-of counter-type)))
507           (make-counted-vector ',element-type :content ,vector 
508            :location ,var :counter-type ',counter-type :temp t)
509           (unwind-protect
510               ,form
511             (unset-counted-vector ,var ',element-type ',counter-type t))))
512       ((and (in-arg-p style) (out-arg-p style))
513        (let ((c-vector (make-symbol "C-VECTOR")))
514          `(with-memory (,c-vector (+ (* ,(size-of element-type) (length ,vector)) ,(size-of counter-type)))
515             (make-counted-vector ',element-type :content ,vector ,c-vector 
516              :counter-type ',counter-type :temp t)
517             (with-pointer (,var ,c-vector)
518               (unwind-protect
519                   ,form
520                 (unset-counted-vector ,c-vector ',element-type ',counter-type t))))))
521       ((and (out-arg-p style) (not (in-arg-p style)))
522        `(with-pointer (,var)
523           ,form)))))
524
525
526 (define-type-method to-alien-form ((type counted-vector) vector &optional copy-p)
527   (declare (ignore copy-p))
528   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
529       (rest (type-expand-to 'counted-vector type))
530     `(make-counted-vector ',element-type 
531       :content ,vector :counter-type ',counter-type)))
532
533 (define-type-method from-alien-form ((type counted-vector) form  &key (ref :free))
534   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
535       (rest (type-expand-to 'counted-vector type))
536     `(let ((c-vector ,form))
537        (prog1
538            (map-counted-vector 'vector #'identity c-vector ',element-type ',counter-type 
539             ,(ecase ref (:free :get) ((:static :temp) :peek) (:copy :read)))
540          ,(when (eq ref :free)
541             `(deallocate c-vector))))))
542
543 (define-type-method writer-function ((type counted-vector) &key temp inlined)
544   (assert-not-inlined type inlined)
545   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
546       (rest (type-expand-to 'counted-vector type))
547     #'(lambda (vector location &optional (offset 0))
548         (setf 
549          (ref-pointer location offset)
550          (make-counted-vector element-type :content vector 
551           :counter-type counter-type :temp temp)))))
552
553 (define-type-method reader-function ((type counted-vector) &key (ref :read) inlined)
554   (assert-not-inlined type inlined)
555   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
556       (rest (type-expand-to 'counted-vector type))
557     (ecase ref
558       ((:read :peek)
559        #'(lambda (location &optional (offset 0))
560            (unless (null-pointer-p (ref-pointer location offset))
561              (map-counted-vector 'vector #'identity 
562               (ref-pointer location offset) element-type counter-type ref))))
563       (:get
564        #'(lambda (location &optional (offset 0))
565            (unless (null-pointer-p (ref-pointer location offset))
566              (prog1
567                  (map-counted-vector 'vector #'identity 
568                   (ref-pointer location offset) element-type counter-type :get)
569                (deallocate-memory (ref-pointer location offset))
570                (setf (ref-pointer location offset) (make-pointer 0)))))))))
571
572 (define-type-method destroy-function ((type counted-vector) &key temp inlined)
573   (assert-not-inlined type inlined)
574   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
575       (rest (type-expand-to 'counted-vector type))
576     #'(lambda (location &optional (offset 0))
577         (unless (null-pointer-p (ref-pointer location offset))
578           (destroy-counted-vector (ref-pointer location offset) 
579            element-type counter-type temp)
580           (setf (ref-pointer location offset) (make-pointer 0))))))
581
582 (define-type-method copy-function ((type counted-vector) &key inlined)
583   (assert-not-inlined type inlined)
584   (destructuring-bind (element-type &optional (counter-type 'unsigned-int))
585       (rest (type-expand-to 'counted-vector type))
586     (let ((vector-length (reader-function counter-type))
587           (counter-size (size-of counter-type))
588           (copy-element (copy-function element-type))
589           (element-size (size-of element-type)))
590       #'(lambda (from to &optional (offset 0))
591           (unless (null-pointer-p (ref-pointer from offset))
592             (let* ((from-vector (ref-pointer from offset))
593                    (length (funcall vector-length from-vector))
594                    (to-vector  (setf 
595                                 (ref-pointer to offset)           
596                                 (allocate-memory (+ counter-size (* length element-size))))))       
597               (copy-memory from-vector counter-size to-vector)
598               (loop
599                repeat length
600                for element from counter-size by element-size
601                do (funcall copy-element from-vector to-vector element))))))))
602
603
604 ;;;; Accessor functions for raw memory access
605
606 (defun vector-reader-function (type &key (start 0) end)
607   "Returns a function for reading values from raw C vectors"
608   (let ((element-size (size-of type))
609         (reader (reader-function type)))
610     #'(lambda (vector index)
611         (assert (and (>= index start) (or (not end) (< index end))))
612         (funcall reader vector (* index element-size)))))
613
614 (defun vector-writer-function (type &key (start 0) end)
615   "Returns a function for writing values to raw C vectors"
616   (let ((element-size (size-of type))
617         (writer (writer-function type)))
618     #'(lambda (value vector index)
619         (assert (and (>= index start) (or (not end) (< index end))))
620         (funcall writer value vector (* index element-size)))))
621
622
623 (defmacro define-vector-accessor (type)
624   (let ((name (intern (format nil "VECTOR-REF-~A" type)))
625         (ref (intern (format nil "REF-~A" type))))
626     `(progn     
627        (declaim 
628         (ftype (function (pointer fixnum) ,type) ,name)
629         (inline ,name))
630        (defun ,name (vector index)
631          (,ref vector (* ,(size-of type) index)))
632        (declaim 
633         (ftype (function (,type pointer fixnum) ,type) (setf ,name))
634         (inline (setf ,name)))
635        (defun (setf ,name) (value vector index)
636          (setf (,ref vector (* ,(size-of type) index)) value)))))
637
638 (define-vector-accessor int-8)
639 (define-vector-accessor uint-8)
640 (define-vector-accessor int-16)
641 (define-vector-accessor uint-16)
642 (define-vector-accessor int-32)
643 (define-vector-accessor uint-32)
644 (define-vector-accessor int-64)
645 (define-vector-accessor uint-64)
646 (define-vector-accessor double-float)
647 (define-vector-accessor single-float)
648