r10378: preliminary new sbcl support

diff --git a/src/aggregates.lisp b/src/aggregates.lisp
index c6624074dd2a07baeaa46bbad95da468bd32ef89..6be523ddd2b1760c6aca585b8f3fc44d242aed9c 100644 (file)
--- 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 d91142747219aee42d7a6abda37e7a64e621e0e5..4a1e6a59dae950b820e4cf7bae7f91e213736a25 100644 (file)
--- 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"