Added automatic function type declarations and accessor functions for raw memory...

[clg] / gffi / vectors.lisp

diff --git a/gffi/vectors.lisp b/gffi/vectors.lisp
index ad9b46127575c688f9bb5a53efa5ba5cc38751b4..2131a2a4903ec830b25329cb9476040e03305f1e 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.5 2007-09-07 07:28:42 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,19 @@ (define-type-method alien-type ((type vector))
   (declare (ignore type))
   (alien-type 'pointer))
 
+(defun vector-type (type)
+  (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 argument-type ((type vector))
+  (vector-type type))
+
+(define-type-method return-type ((type vector))
+  (vector-type type))
+
 (define-type-method size-of ((type vector) &key inlined)
   (if inlined
       (destructuring-bind (element-type &optional (length '*)) 
@@ -295,7 +321,7 @@ (defun map-0-vector (seqtype function location element-type &optional (ref :read
 
 (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 +601,50 @@ (define-type-method copy-function ((type counted-vector) &key inlined)
               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)
+