r9396: add ensure-char-storage function, new tests

[uffi.git] / src / primitives.lisp

diff --git a/src/primitives.lisp b/src/primitives.lisp
index 007355c316209082abc7d6d22886cfe297b3403a..fbfc120c2d732625e8f7e820ed14ea3d0652628f 100644 (file)
--- a/src/primitives.lisp
+++ b/src/primitives.lisp
@@ -87,9 +87,6 @@ supports takes advantage of this optimization."
                        (make-hash-table :size 20 :test #'eq))
   )
 
-#+(or cmu sbcl scl)
-(defvar *cmu-sbcl-def-type-list* nil)
-
 #+(or cmu scl)
 (defvar *cmu-sbcl-def-type-list*
     '((:char . (alien:signed 8))
@@ -104,8 +101,10 @@ supports takes advantage of this optimization."
       (:unsigned-long . (alien:unsigned 32))
       (:float . alien:single-float)
       (:double . alien:double-float)
+      (:void . t)
       )
   "Conversions in CMUCL for def-foreign-type are different than in def-function")
+
 #+sbcl
 (defvar *cmu-sbcl-def-type-list*
     '((:char . (sb-alien:signed 8))
@@ -120,6 +119,7 @@ supports takes advantage of this optimization."
       (:unsigned-long . (sb-alien:unsigned 32))
       (:float . sb-alien:single-float)
       (:double . sb-alien:double-float)
+      (:void . t)
       )
   "Conversions in SBCL for def-foreign-type are different than in def-function")
 
@@ -277,6 +277,15 @@ 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)
@@ -286,3 +295,20 @@ supports takes advantage of this optimization."
      ((and (eq (car result) :pointer) (eq context :allocation) :pointer))
      (t result))))
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (char= #\a (schar (symbol-name '#:a) 0))
+    (pushnew :uffi-lowercase-reader *features*))
+  (when (not (string= (symbol-name '#:a)
+                     (symbol-name '#:A)))
+    (pushnew :uffi-case-sensitive *features*)))
+
+(defun make-lisp-name (name)
+  (let ((converted (substitute #\- #\_ name)))
+     (intern 
+      #+uffi-case-sensitive converted
+      #+(and (not uffi-lowercase-reader) (not uffi-case-sensitive)) (string-upcase converted)
+      #+(and uffi-lowercase-reader (not uffi-case-sensitive)) (string-downcase converted))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setq cl:*features* (delete :uffi-lowercase-reader *features*))
+  (setq cl:*features* (delete :uffi-case-sensitive *features*)))