r9418: rework cmucl/sbcl arrays in deref-array, allocate-foreign-object, and with...

diff --git a/ChangeLog b/ChangeLog
index 4c0ea2e0e54dc8981f4c5c617eefd1afa9f8c4b1..13f8e7d86bb498ea6a0b352baf572fbaf20152d8 100644 (file)
--- 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 bdca5c689d1147c0d2e9aa62dac9e1d042b53acc..18363c5e9c372792eb809bafe83d7d2f027f6cec 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-uffi (1.5.0-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  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 255e226ea70e86574daab2166954577499a1d6af..5c5b5118a88950ea607a21a9f322c6a8c0768adc 100644 (file)
--- 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 940c941cc42f6d09338c22f90b8bc0d9e45949e0..6ec32234aaa87792332dc39ebc2bb0a4c65784ed 100644 (file)
--- 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 fbfc120c2d732625e8f7e820ed14ea3d0652628f..f107ac01d7521076dc3c743b9a93d48127d50acc 100644 (file)
--- 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 e018083d43f00ec7be45d2eb4af1e4d3e62c86b4..4d6afb478f002cf0dccd2a8b2652a1a579db2f02 100644 (file)
--- 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 495fdcd392f9b480f06c3fc4fb623e26b8243ddf..886ea517816b30f03046b659940143b1d48f2b10 100644 (file)
--- 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 95b411e53a05aec48be467d9bc3b4dd56132d1ad..1fd6d16d45ec71c7c59d54956c471dd6dcf3e356 100644 (file)
--- 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)