chiark / gitweb /
Fix compilation for Gtk with the new, stricter inheritance
[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.9 2008-12-10 02:41:40 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
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)
56        (loop
57         for element in content
58         for i below length
59         for offset by element-size
60         do (funcall writer element location offset)))
61       (t
62        (loop
63         for element across content
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)))
74     (case seqtype
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))))
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))
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
141 (define-type-method argument-type ((type vector))
142   (declare (ignore type))
143   'sequence)
144
145 (define-type-method return-type ((type vector))
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
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
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
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
311
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)
335     (check-unboxed-vector type)
336     (destructuring-bind (element-type &optional (length '*)) 
337         (rest (type-expand-to 'unboxed-vector type))
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))
356     (check-unboxed-vector type)
357     (destructuring-bind (element-type &optional (length '*)) 
358         (rest (type-expand-to 'unboxed-vector type))
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))
367     (check-unboxed-vector type)
368     (destructuring-bind (element-type &optional (length '*))
369         (rest (type-expand-to 'unboxed-vector type))
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))
382     (check-unboxed-vector type)
383     (destructuring-bind (element-type &optional (length '*))
384         (rest (type-expand-to 'unboxed-vector type))
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)
402     (check-unboxed-vector type)
403     (destructuring-bind (element-type &optional (length '*))
404         (rest (type-expand-to 'unboxed-vector type))
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
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
464 (define-type-method destroy-function ((type unboxed-vector) &key temp inlined)
465   (declare (ignore temp))
466   (check-unboxed-vector type)
467   (destructuring-bind (element-type &optional (length '*))
468       (rest (type-expand-to 'unboxed-vector type))
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
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
517    with destroy = (destroy-function element-type :temp temp-p)
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
539 (define-type-method type-alignment ((type vector0) &key inlined)
540   (assert-not-inlined type inlined)
541   (type-alignment 'pointer))
542
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)))
633                    (to-vector 
634                     (setf (ref-pointer to offset)                 
635                      (allocate-memory (* (1+ length) element-size)))))
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
688 (define-type-method type-alignment ((type counted-vector) &key inlined)
689   (assert-not-inlined type inlined)
690   (type-alignment 'pointer))
691
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))))))))
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