From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Mon, 4 Apr 2005 19:59:21 +0000 (+0000)
Subject: r10378: preliminary new sbcl support
X-Git-Tag: v1.6.1~68
X-Git-Url: http://git.kpe.io/?p=uffi.git;a=commitdiff_plain;h=6229dcb7d816d344069abee0d103ef09c8e52c0e

r10378: preliminary new sbcl support
---

diff --git a/src/aggregates.lisp b/src/aggregates.lisp
index c662407..6be523d 100644
--- a/src/aggregates.lisp
+++ b/src/aggregates.lisp
@@ -227,17 +227,20 @@ of the enum-name name, separator-string, and field-name"
       (setf (aref a i) (uffi:deref-array s '(:array :unsigned-byte) i)))))
 
 #+sbcl
-(defun convert-from-foreign-usb8 (s len)
-  (let ((sap (sb-alien:alien-sap s)))
-    (declare (type sb-sys:system-area-pointer sap))
-    (locally
-	(declare (optimize (speed 3) (safety 0)))
-      (let ((result (make-array len :element-type '(unsigned-byte 8))))
-	(sb-kernel:copy-from-system-area sap 0
-					 result (* sb-vm:vector-data-offset
-						   sb-vm:n-word-bits)
-					 (* len sb-vm:n-byte-bits))
-	result))))
+(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"))))
+  (defun convert-from-foreign-usb8 (s len)
+    (let ((sap (sb-alien:alien-sap s)))
+      (declare (type sb-sys:system-area-pointer sap))
+      (locally
+	  (declare (optimize (speed 3) (safety 0)))
+	(let ((result (make-array len :element-type '(unsigned-byte 8))))
+	  (funcall copy-fn sap 0
+		   result (* sb-vm:vector-data-offset
+			     sb-vm:n-word-bits)
+		   (* len sb-vm:n-byte-bits))
+	  result)))))
 
 #+cmu
 (defun convert-from-foreign-usb8 (s len)
diff --git a/src/strings.lisp b/src/strings.lisp
index d911427..4a1e6a5 100644
--- a/src/strings.lisp
+++ b/src/strings.lisp
@@ -300,35 +300,41 @@ that LW/CMU automatically converts strings from c-calls."
       result)))
 
 #+(and sbcl (not 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)))
-      (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)))
+(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"))))
+  (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))))
 
 #+(and sbcl 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 ((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"))))
+  (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
+	(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)))
@@ -338,11 +344,11 @@ that LW/CMU automatically converts strings from c-calls."
         (t
          (let ((result (make-string length)))
 	   ;; this will not work in sb-unicode
-           (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)))))
+           (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"