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

[uffi.git] / src / primitives.lisp

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)