X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fstrings.lisp;h=7ac5c16c14b9d7ab5c423c82e1ffcf09199e0106;hb=218088774006bd9df58df318a6b3981065dfc71f;hp=89c41b2ec03a8ca4d240d449a134c33c92c2a2ef;hpb=3e1ab6ebfcf56e76edffaff284aca937e8152408;p=uffi.git

diff --git a/src/strings.lisp b/src/strings.lisp
index 89c41b2..7ac5c16 100644
--- 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))))))