;; 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.7 2008-04-29 22:16:28 espen Exp $
+;; $Id: vectors.lisp,v 1.9 2008-12-10 02:41:40 espen Exp $
(in-package "GFFI")
(let* ((element-size (size-of type))
(location (or location (allocate-memory (* element-size length))))
(writer (writer-function type :temp temp)))
- (etypecase content
- (vector
+
+ (cond
+ #+(or cmu sbcl)
+ ((and
+ (typep content 'simple-unboxed-array)
+ (type-equal-p type (array-element-type content)))
+ (with-pinned-objects (content)
+ (copy-memory (vector-sap content) (* length element-size) location)))
+ ((listp content)
(loop
- for element across content
+ for element in content
for i below length
for offset by element-size
do (funcall writer element location offset)))
- (list
+ (t
(loop
- for element in content
+ for element across content
for i below length
for offset by element-size
do (funcall writer element location offset))))
&optional (ref :read))
(let ((reader (reader-function element-type :ref ref))
(element-size (size-of element-type)))
- (case seqtype
+ (case seqtype
((nil)
(loop
for i below length
for i below length
for offset by element-size
collect (funcall function (funcall reader location offset))))
+ (vector
+ (let ((vector (make-array length :element-type element-type)))
+ (cond
+ #+(or cmu sbcl)
+ ((and
+ (typep vector 'simple-unboxed-array)
+ (or (eq function 'identity) (eq function #'identity)))
+ (with-pinned-objects (vector)
+ (copy-memory location (* length element-size) (vector-sap vector))))
+ (t
+ (loop
+ for i below length
+ for offset by element-size
+ do (setf
+ (aref vector i)
+ (funcall function (funcall reader location offset))))))
+ vector))
(t
(loop
with sequence = (make-sequence seqtype length)
(setf (ref-pointer to offset) vector)
(funcall copy-content (ref-pointer from offset) vector)))))))))
+
;;;; Unboxed vector
(deftype unboxed-vector (element-type &optional (length '*))
#+(or sbcl cmu)
(progn
(define-type-method alien-arg-wrapper ((type unboxed-vector) var vector style form &optional copy-in-p)
+ (check-unboxed-vector type)
(destructuring-bind (element-type &optional (length '*))
(rest (type-expand-to 'unboxed-vector type))
- (check-unboxed-vector type)
(when (and (eq length '*) (out-arg-p style))
(error "Can't use vector with variable size as return type"))
(cond
(define-type-method to-alien-form ((type unboxed-vector) vector &optional copy-p)
(declare (ignore copy-p))
+ (check-unboxed-vector type)
(destructuring-bind (element-type &optional (length '*))
(rest (type-expand-to 'unboxed-vector type))
- (check-unboxed-vector type)
`(with-pinned-objects (,vector)
(copy-memory
(vector-sap ,vector)
(define-type-method from-alien-form ((type unboxed-vector) form &key (ref :free))
+ (check-unboxed-vector type)
(destructuring-bind (element-type &optional (length '*))
(rest (type-expand-to 'unboxed-vector type))
- (check-unboxed-vector type)
(when (eq length '*)
(error "Can't use vector of variable size as return type"))
`(let ((c-vector ,form)
(define-type-method writer-function ((type unboxed-vector) &key temp inlined)
(declare (ignore temp))
+ (check-unboxed-vector type)
(destructuring-bind (element-type &optional (length '*))
(rest (type-expand-to 'unboxed-vector type))
- (check-unboxed-vector type)
(if inlined
(if (eq length '*)
(error "Can't inline vector with variable size: ~A" type)
(* (length vector) (size-of element-type)))))))))
(define-type-method reader-function ((type unboxed-vector) &key (ref :read) inlined)
+ (check-unboxed-vector type)
(destructuring-bind (element-type &optional (length '*))
(rest (type-expand-to 'unboxed-vector type))
- (check-unboxed-vector type)
(cond
((eq length '*)
(error "Can't create reader function for vector with variable size"))
(setf (ref-pointer location offset) (make-pointer 0)))
vector))))))))
+
+#-(or sbcl cmu)
+(progn
+ (define-type-method alien-arg-wrapper ((type unboxed-vector) var vector style form &optional copy-in-p)
+ (check-unboxed-vector type)
+ (destructuring-bind (element-type &optional (length '*))
+ (rest (type-expand-to 'unboxed-vector type))
+ (alien-arg-wrapper `(vector ,element-type ,length) var vector style form copy-in-p)))
+
+ (define-type-method to-alien-form ((type unboxed-vector) vector &optional copy-p)
+ (check-unboxed-vector type)
+ (destructuring-bind (element-type &optional (length '*))
+ (rest (type-expand-to 'unboxed-vector type))
+ (to-alien-form `(vector ,element-type ,length) vector copy-p)))
+
+ (define-type-method from-alien-form ((type unboxed-vector) form &key (ref :free))
+ (check-unboxed-vector type)
+ (destructuring-bind (element-type &optional (length '*))
+ (rest (type-expand-to 'unboxed-vector type))
+ (from-alien-form `(vector ,element-type ,length) form :ref ref)))
+
+ (define-type-method writer-function ((type unboxed-vector) &key temp inlined)
+ (check-unboxed-vector type)
+ (destructuring-bind (element-type &optional (length '*))
+ (rest (type-expand-to 'unboxed-vector type))
+ (writer-function `(vector ,element-type ,length) :temp temp :inlined inlined)))
+
+ (define-type-method reader-function ((type unboxed-vector) &key (ref :read) inlined)
+ (check-unboxed-vector type)
+ (destructuring-bind (element-type &optional (length '*))
+ (rest (type-expand-to 'unboxed-vector type))
+ (reader-function `(vector ,element-type ,length) :ref ref :inlined inlined))))
+
(define-type-method destroy-function ((type unboxed-vector) &key temp inlined)
(declare (ignore temp))
+ (check-unboxed-vector type)
(destructuring-bind (element-type &optional (length '*))
(rest (type-expand-to 'unboxed-vector type))
- (check-unboxed-vector type)
(cond
#+sbcl
((eq length '*)