From 218088774006bd9df58df318a6b3981065dfc71f Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 4 Apr 2005 20:04:49 +0000 Subject: [PATCH] r10379: more sbcl fixes --- src/aggregates.lisp | 29 ++++++------- src/strings.lisp | 99 +++++++++++++++++++++++---------------------- 2 files changed, 65 insertions(+), 63 deletions(-) diff --git a/src/aggregates.lisp b/src/aggregates.lisp index 6be523d..ec1a559 100644 --- a/src/aggregates.lisp +++ b/src/aggregates.lisp @@ -227,20 +227,21 @@ of the enum-name name, separator-string, and field-name" (setf (aref a i) (uffi:deref-array s '(:array :unsigned-byte) i))))) #+sbcl -(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))))) +(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")))) + (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 4a1e6a5..7ac5c16 100644 --- a/src/strings.lisp +++ b/src/strings.lisp @@ -299,56 +299,57 @@ that LW/CMU automatically converts strings from c-calls." (setf (char result i) (code-char (system:sap-ref-8 sap i)))) result))) -#+(and sbcl (not sb-unicode)) -(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)))) +#+sbcl +(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))))))) -#+(and sbcl sb-unicode) -(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 - (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" -- 2.34.1