From 868ae7fad94b80592524dea37eae1000075605c6 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Thu, 20 May 2004 17:15:29 +0000 Subject: [PATCH] r9418: rework cmucl/sbcl arrays in deref-array, allocate-foreign-object, and with-foreight-object --- ChangeLog | 6 ++++++ debian/changelog | 6 ++++++ src/aggregates.lisp | 10 ++++++++-- src/objects.lisp | 29 +++++++++++++++++++++++------ src/primitives.lisp | 37 +++++++++++++++++++------------------ tests/arrays.lisp | 18 +++++++++--------- tests/pointers.lisp | 9 +++++++++ tests/uffi-c-test-lib.lisp | 2 +- 8 files changed, 81 insertions(+), 36 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4c0ea2e..13f8e7d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2004-05-20 Kevin Rosenberg (kevin@rosenberg.net) + * Version 1.5.0 released + * Reworked array allocation and dereferencing for cmu/sbcl for greater + consistancy/robustness. Hopefully, this won't break any packages that use + UFFI, but the change does slightly change the alien types of foreign variables. + 2004-04-15 Kevin Rosenberg (kevin@rosenberg.net) * src/objects.lisp: Add new functions: MAKE-POINTER and POINTER-ADDRESS diff --git a/debian/changelog b/debian/changelog index bdca5c6..18363c5 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-uffi (1.5.0-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Thu, 20 May 2004 09:59:07 -0600 + cl-uffi (1.4.19-1) unstable; urgency=low * New upstream diff --git a/src/aggregates.lisp b/src/aggregates.lisp index 255e226..5c5b511 100644 --- a/src/aggregates.lisp +++ b/src/aggregates.lisp @@ -160,8 +160,14 @@ of the enum-name name, separator-string, and field-name" (defmacro deref-array (obj type i) "Returns a field from a row" #+(or lispworks scl) (declare (ignore type)) - #+(or cmu scl) `(alien:deref (the (alien:alien ,(convert-from-uffi-type type :declare)) ,obj) ,i) - #+sbcl `(sb-alien:deref (the (sb-alien:alien ,(convert-from-uffi-type type :declare)) ,obj) ,i) + #+(or cmu scl) `(alien:deref + (alien:cast + ,obj + ,(convert-from-uffi-type type :declare)) ,i) + #+sbcl `(sb-alien:deref + (sb-alien:cast + ,obj + ,(convert-from-uffi-type type :declare)) ,i) #+lispworks `(fli:dereference ,obj :index ,i :copy-foreign-object nil) #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i) #+openmcl diff --git a/src/objects.lisp b/src/objects.lisp index 940c941..6ec3223 100644 --- a/src/objects.lisp +++ b/src/objects.lisp @@ -51,9 +51,21 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." ) (progn #+(or cmu scl) - `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) + (if (integerp size) + `(alien:cast + (alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) + (array ,(convert-from-uffi-type (eval type) :allocation) ,size)) + `(alien:cast + (alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) + (array ,(convert-from-uffi-type (eval type) :allocation) nil))) #+sbcl - `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) + (if (integerp size) + `(sb-alien:cast + (sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) + (array ,(convert-from-uffi-type (eval type) :allocation) ,size)) + `(sb-alien:cast + (sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size) + (array ,(convert-from-uffi-type (eval type) :allocation) nil))) #+lispworks `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate) :nelems ,size) #+allegro @@ -171,10 +183,15 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." (let ((,var (alien:addr ,obj))) ,@body))) #+sbcl - (let ((obj (gensym))) - `(sb-alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate))) - (let ((,var (sb-alien:addr ,obj))) - ,@body))) + (let ((obj (gensym)) + (ctype (convert-from-uffi-type (eval type) :allocate))) + (if (and (consp ctype) (eq 'array (car ctype))) + `(sb-alien:with-alien ((,obj ,ctype)) + (let* ((,var ,obj)) + ,@body)) + `(sb-alien:with-alien ((,obj ,ctype)) + (let* ((,var (sb-alien:addr ,obj))) + ,@body)))) #+lispworks `(fli:with-dynamic-foreign-objects ((,var ,(convert-from-uffi-type (eval type) :allocate))) diff --git a/src/primitives.lisp b/src/primitives.lisp index fbfc120..f107ac0 100644 --- a/src/primitives.lisp +++ b/src/primitives.lisp @@ -258,16 +258,26 @@ supports takes advantage of this optimization." (t (basic-convert-from-uffi-type type))) (let ((sub-type (car type))) - (case sub-type - (cl:quote - (convert-from-uffi-type (cadr type) context)) - (:struct-pointer - #+mcl `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct))) - #-mcl (%convert-from-uffi-type (list '* (cadr type)) :struct) - ) - (:struct + (cond + ((eq sub-type 'cl:quote) + (convert-from-uffi-type (cadr type) context)) + #+sbcl + ((and (eq sub-type :array) + (or (eq context :declare) (eq context :routine)) + (= 2 (length type))) + `(sb-alien:array ,(%convert-from-uffi-type (second type) context) nil)) + #+cmu + ((and (eq sub-type :array) + (or (eq context :declare) (eq context :routine)) + (= 2 (length type))) + `(alien:array ,(%convert-from-uffi-type (second type) context) nil)) + ((eq sub-type :struct-pointer) + #+mcl `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct))) + #-mcl (%convert-from-uffi-type (list '* (second type)) :struct) + ) + ((eq sub-type :struct) #+mcl `(:struct ,(%convert-from-uffi-type (cadr type) :struct)) - #-mcl (%convert-from-uffi-type (cadr type) :struct) + #-mcl (%convert-from-uffi-type (second type) :struct) ) (t (cons (%convert-from-uffi-type (first type) context) @@ -277,15 +287,6 @@ supports takes advantage of this optimization." (let ((result (%convert-from-uffi-type type context))) (cond ((atom result) result) - ;; Arrays without size are really pointers to type on SBCL/CMUCL - #+sbcl - ((and (consp type) (= 2 (length type)) (eq :array (car type))) - (setf (car result) 'sb-alien:*) - result) - #+cmu - ((and (consp type) (= 2 (length type)) (eq :array (car type))) - (setf (car result) 'alien:*) - result) #+openmcl ((eq (car result) :address) (if (eq context :struct) diff --git a/tests/arrays.lisp b/tests/arrays.lisp index e018083..4d6afb4 100644 --- a/tests/arrays.lisp +++ b/tests/arrays.lisp @@ -15,7 +15,8 @@ (in-package #:uffi-tests) -(uffi:def-constant +column-length+ 10) +(eval-when (:compile-toplevel :load-toplevel :execute) + (uffi:def-constant +column-length+ 10)) (uffi:def-constant +row-length+ 10) (uffi:def-foreign-type long-ptr '(* :long)) @@ -31,25 +32,24 @@ (nreverse results)) (0 1 4 9 16 25 36 49 64 81)) - (deftest array.2 - (let ((a (uffi:allocate-foreign-object 'long-ptr +row-length+)) + (let ((a (uffi:allocate-foreign-object '(:array :long #.+column-length+) +row-length+)) (results nil)) (dotimes (r +row-length+) (declare (fixnum r)) - (setf (uffi:deref-array a '(:array (* :long)) r) - (uffi:allocate-foreign-object :long +column-length+)) - (let ((col (uffi:deref-array a '(:array (* :long)) r))) + (setf (uffi:deref-array a '(:array (:array :long #.+column-length+)) r) + (uffi:allocate-foreign-object :long #.+column-length+)) + (let ((col (uffi:deref-array a '(:array (:array :long #.+column-length+)) r))) (dotimes (c +column-length+) (declare (fixnum c)) - (setf (uffi:deref-array col '(:array :long) c) (+ (* r +column-length+) c))))) + (setf (uffi:deref-array col '(:array :long #.+column-length+) c) (+ (* r +column-length+) c))))) (dotimes (r +row-length+) (declare (fixnum r)) - (let ((col (uffi:deref-array a '(:array (* :long)) r))) + (let ((col (uffi:deref-array a '(:array (:array :long #.+column-length+)) r))) (dotimes (c +column-length+) (declare (fixnum c)) - (push (uffi:deref-array col '(:array :long) c) results)))) + (push (uffi:deref-array col '(:array :long #.+column-length+) c) results)))) (uffi:free-foreign-object a) (nreverse results)) (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99)) diff --git a/tests/pointers.lisp b/tests/pointers.lisp index 495fdcd..886ea51 100644 --- a/tests/pointers.lisp +++ b/tests/pointers.lisp @@ -52,5 +52,14 @@ (uffi:convert-from-foreign-string fs)) "a") +(deftest chptr.6 + (uffi:with-foreign-object (fs '(:array :unsigned-char 128)) + (setf (uffi:deref-array fs '(:array :unsigned-char) 0) + (uffi:ensure-char-storable #\a)) + (setf (uffi:deref-array fs '(:array :unsigned-char) 1) + (uffi:ensure-char-storable (code-char 0))) + (uffi:convert-from-foreign-string fs)) + "a") + diff --git a/tests/uffi-c-test-lib.lisp b/tests/uffi-c-test-lib.lisp index 95b411e..1fd6d16 100644 --- a/tests/uffi-c-test-lib.lisp +++ b/tests/uffi-c-test-lib.lisp @@ -36,7 +36,7 @@ (uffi:def-function ("half_double_vector" half-double-vector) ((size :int) - (vec (* :double))) + (vec (:array :double))) :returning :void) (uffi:def-function ("return_long_negative_one" return-long-negative-one) -- 2.34.1