Vector arguments declared as SEQUENCE

[clg] / gffi / vectors.lisp

diff --git a/gffi/vectors.lisp b/gffi/vectors.lisp
index ad9b461..1a9313e 100644 (file)
--- a/gffi/vectors.lisp
+++ b/gffi/vectors.lisp
@@ -20,11 +20,24 @@
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-;; $Id: vectors.lisp,v 1.3 2007-06-01 06:15:37 espen Exp $
+;; $Id: vectors.lisp,v 1.6 2008-04-11 20:19:09 espen Exp $
 
 
 (in-package "GFFI")
 
+
+;;; Accessor functions for raw memory access
+
+(define-memory-accessor int-16)
+(define-memory-accessor int-32)
+(define-memory-accessor int-64)
+(define-memory-accessor uint-16)
+(define-memory-accessor uint-32)
+(define-memory-accessor uint-64)
+(define-memory-accessor single-float)
+(define-memory-accessor double-float)
+
+
 ;;; Vector
 
 (defun make-c-vector (type length &key content location temp)
@@ -101,6 +114,17 @@
   (declare (ignore type))
   (alien-type 'pointer))
 
+(define-type-method argument-type ((type vector))
+  (declare (ignore type))
+  'sequence)
+
+(define-type-method return-type ((type vector))
+  (destructuring-bind (element-type &optional (length '*)) 
+      (rest (type-expand-to 'vector type))
+    (if (constantp length)
+       `(vector ,(return-type element-type) ,length)
+      `(vector ,(return-type element-type) *))))
+
 (define-type-method size-of ((type vector) &key inlined)
   (if inlined
       (destructuring-bind (element-type &optional (length '*)) 
@@ -295,7 +319,7 @@
 
 (defun unset-0-vector (location element-type &optional temp-p)
   (loop
-   with destroy = (destroy-function element-type temp-p)
+   with destroy = (destroy-function element-type :temp temp-p)
    with element-size = (size-of element-type)
    for offset by element-size
    until (memory-clear-p (pointer+ location offset) element-size)
@@ -575,3 +599,50 @@
               repeat length
               for element from counter-size by element-size
               do (funcall copy-element from-vector to-vector element))))))))
+
+
+;;;; Accessor functions for raw memory access
+
+(defun vector-reader-function (type &key (start 0) end)
+  "Returns a function for reading values from raw C vectors"
+  (let ((element-size (size-of type))
+       (reader (reader-function type)))
+    #'(lambda (vector index)
+       (assert (and (>= index start) (or (not end) (< index end))))
+       (funcall reader vector (* index element-size)))))
+
+(defun vector-writer-function (type &key (start 0) end)
+  "Returns a function for writing values to raw C vectors"
+  (let ((element-size (size-of type))
+       (writer (writer-function type)))
+    #'(lambda (value vector index)
+       (assert (and (>= index start) (or (not end) (< index end))))
+       (funcall writer value vector (* index element-size)))))
+
+
+(defmacro define-vector-accessor (type)
+  (let ((name (intern (format nil "VECTOR-REF-~A" type)))
+       (ref (intern (format nil "REF-~A" type))))
+    `(progn     
+       (declaim 
+       (ftype (function (pointer fixnum) ,type) ,name)
+       (inline ,name))
+       (defun ,name (vector index)
+        (,ref vector (* ,(size-of type) index)))
+       (declaim 
+       (ftype (function (,type pointer fixnum) ,type) (setf ,name))
+       (inline (setf ,name)))
+       (defun (setf ,name) (value vector index)
+        (setf (,ref vector (* ,(size-of type) index)) value)))))
+
+(define-vector-accessor int-8)
+(define-vector-accessor uint-8)
+(define-vector-accessor int-16)
+(define-vector-accessor uint-16)
+(define-vector-accessor int-32)
+(define-vector-accessor uint-32)
+(define-vector-accessor int-64)
+(define-vector-accessor uint-64)
+(define-vector-accessor double-float)
+(define-vector-accessor single-float)
+