r10379: more sbcl fixes

[uffi.git] / src / strings.lisp

diff --git a/src/strings.lisp b/src/strings.lisp
index 89c41b2ec03a8ca4d240d449a134c33c92c2a2ef..7ac5c16c14b9d7ab5c423c82e1ffcf09199e0106 100644 (file)
--- a/src/strings.lisp
+++ b/src/strings.lisp
@@ -190,8 +190,9 @@ that LW/CMU automatically converts strings from c-calls."
   `(if (ccl:%null-ptr-p ,obj)
      nil
     #+(and mcl (not openmcl)) (ccl:%get-cstring ,obj 0 ,@(if length (list length) nil))
-    #+openmcl (let ((str (ccl:%get-cstring ,obj)))
-               ,(if length '(subseq str 0 length) 'str)))
+    #+openmcl ,@(if length
+                   `((ccl:%str-from-ptr ,obj ,length))
+                   `((ccl:%get-cstring ,obj))))
   )
 
 
@@ -299,27 +300,56 @@ that LW/CMU automatically converts strings from c-calls."
       result)))
 
 #+sbcl
-(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
-  (declare (type sb-sys:system-area-pointer sap))
-  (locally
-      (declare (optimize (speed 3) (safety 0)))
-    (let ((null-terminated-length
-          (when null-terminated-p
-            (loop
-                for offset of-type fixnum upfrom 0
-                until (zerop (sb-sys:sap-ref-8 sap offset))
-                finally (return offset)))))
-      (if length
-         (if (and null-terminated-length
-                  (> (the fixnum length) (the fixnum null-terminated-length)))
-             (setq length null-terminated-length))
-       (setq length null-terminated-length)))
-    (let ((result (make-string length)))
-      (sb-kernel:copy-from-system-area sap 0
-                                   result (* sb-vm:vector-data-offset
-                                             sb-vm:n-word-bits)
-                                   (* length sb-vm:n-byte-bits))
-      result)))
+(sb-ext:without-package-locks
+    (let ((copy-fn (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+                      (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")
+                      (intern "COPY-UB8-FROM-SYSTEM" "SB-KERNEL"))))
+
+      #-sb-unicode
+      (defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
+       (declare (type sb-sys:system-area-pointer sap))
+       (locally
+           (declare (optimize (speed 3) (safety 0)))
+         (let ((null-terminated-length
+                (when null-terminated-p
+                  (loop
+                     for offset of-type fixnum upfrom 0
+                     until (zerop (sb-sys:sap-ref-8 sap offset))
+                     finally (return offset)))))
+           (if length
+               (if (and null-terminated-length
+                        (> (the fixnum length) (the fixnum null-terminated-length)))
+                   (setq length null-terminated-length))
+               (setq length null-terminated-length)))
+         (let ((result (make-string length)))
+           (funcall copy-fn sap 0
+                    result (* sb-vm:vector-data-offset
+                              sb-vm:n-word-bits)
+                    (* length sb-vm:n-byte-bits))
+           result)))
+
+      #+sb-unicode
+      (defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
+       (declare (type sb-sys:system-area-pointer sap))
+       (locally
+           (declare (optimize (speed 3) (safety 0)))
+         (cond
+           (null-terminated-p
+            (let ((casted (sb-alien:cast (sb-alien:sap-alien sap (* char))
+                                         #+sb-unicode sb-alien:utf8-string
+                                         #-sb-unicode sb-alien:c-string)))
+              (if length
+                  (copy-seq (subseq casted 0 length))
+                  (copy-seq casted))))
+           (t
+            (let ((result (make-string length)))
+              ;; this will not work in sb-unicode
+              (funcall copy-fn sap 0
+                       result (* sb-vm:vector-data-offset
+                                 sb-vm:n-word-bits)
+                       (* length sb-vm:n-byte-bits))
+              result)))))))
+
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
    (def-function "strlen"
@@ -347,4 +377,4 @@ that LW/CMU automatically converts strings from c-calls."
   (let* ((len (or len (strlen s)))
          (str (make-string len)))
       (dotimes (i len str)
-        (setf (schar str i) (code-char (uffi:deref-array s '(:array :byte) i))))))
+        (setf (schar str i) (code-char (uffi:deref-array s '(:array :unsigned-byte) i))))))