From 3f02f80ce6909ada82d9791172821756f967a844 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 4 Apr 2005 20:31:17 +0000 Subject: [PATCH] r10380: working on new sbcl --- src/aggregates.lisp | 35 +++++++++------- src/primitives.lisp | 6 ++- src/strings.lisp | 90 +++++++++++++++++++----------------------- tests/gethostname.lisp | 2 +- tests/time.lisp | 24 +++++------ 5 files changed, 80 insertions(+), 77 deletions(-) diff --git a/src/aggregates.lisp b/src/aggregates.lisp index ec1a559..5d0bcf7 100644 --- a/src/aggregates.lisp +++ b/src/aggregates.lisp @@ -228,20 +228,27 @@ of the enum-name name, separator-string, and field-name" #+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")))) - (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)))))) + (defvar *system-copy-fn* (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")) + (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL") + (intern "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL"))) + (defconstant *system-copy-offset* (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")) + (* sb-vm:vector-data-offset sb-vm:n-word-bits) + 0)) + (defconstant *system-copy-multiplier* (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")) + sb-vm:n-byte-bits + 1))) + + +#+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)))) + (funcall *system-copy-fn* sap 0 result *system-copy-offset* + (* len *system-copy-multiplier*)) + result)))) #+cmu (defun convert-from-foreign-usb8 (s len) diff --git a/src/primitives.lisp b/src/primitives.lisp index 0f47eb7..ac4116a 100644 --- a/src/primitives.lisp +++ b/src/primitives.lisp @@ -97,8 +97,10 @@ supports takes advantage of this optimization." (:unsigned-short . (alien:unsigned 16)) (:int . (alien:signed 32)) (:unsigned-int . (alien:unsigned 32)) - (:long . (alien:signed 32)) - (:unsigned-long . (alien:unsigned 32)) + #-x86-64 (:long . (alien:signed 32)) + #-x86-64 (:unsigned-long . (alien:unsigned 32)) + #+x86-64 (:long . (alien:signed 64)) + #+x86-64 (:unsigned-long . (alien:unsigned 64)) (:float . alien:single-float) (:double . alien:double-float) (:void . t) diff --git a/src/strings.lisp b/src/strings.lisp index 7ac5c16..a0ca3fc 100644 --- a/src/strings.lisp +++ b/src/strings.lisp @@ -299,56 +299,48 @@ that LW/CMU automatically converts strings from c-calls." (setf (char result i) (code-char (system:sap-ref-8 sap i)))) 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))) +#+(and sbcl (not sb-unicode)) +(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t)) + (declare (type sb-sys:system-area-pointer sap) + (type (or null fixnum) length)) + (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 *system-copy-fn* sap 0 result *system-copy-offset* + (* length *system-copy-multiplier*)) + 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) +(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t)) + (declare (type sb-sys:system-area-pointer sap) + (type (or null fixnum) length)) + (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 *system-copy-fn* sap 0 result *system-copy-offset* + (* length *system-copy-multiplier*)) + result))))) (eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/tests/gethostname.lisp b/tests/gethostname.lisp index ec019da..8213740 100644 --- a/tests/gethostname.lisp +++ b/tests/gethostname.lisp @@ -46,7 +46,7 @@ (deftest gethostname.2 (stringp (gethostname2)) t) (deftest gethostname.3 (plusp (length (gethostname))) t) (deftest gethostname.4 (plusp (length (gethostname2))) t) -(deftest gethostname.5 (gethostname) #.(gethostname2)) +(deftest gethostname.5 (string= (gethostname) (gethostname2)) t) diff --git a/tests/time.lisp b/tests/time.lisp index 24a3af2..cccd0b4 100644 --- a/tests/time.lisp +++ b/tests/time.lisp @@ -26,7 +26,9 @@ (year :int) (wday :int) (yday :int) - (isdst :int)) + (isdst :int) + ;; gmoffset present on SusE SLES9 + (gmoffset :long)) (uffi:def-function ("time" c-time) ((time (* time-t))) @@ -50,16 +52,16 @@ 7381) (deftest time.2 - (uffi:with-foreign-object (time 'time-t) - (setf (uffi:deref-pointer time :unsigned-long) 7381) - (let ((tm-ptr (the tm-pointer (gmtime time)))) - (values (1+ (uffi:get-slot-value tm-ptr 'tm 'mon)) - (uffi:get-slot-value tm-ptr 'tm 'mday) - (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year)) - (uffi:get-slot-value tm-ptr 'tm 'hour) - (uffi:get-slot-value tm-ptr 'tm 'min) - (uffi:get-slot-value tm-ptr 'tm 'sec) - ))) + (uffi:with-foreign-object (time 'time-t) + (setf (uffi:deref-pointer time :unsigned-long) 7381) + (let ((tm-ptr (the tm-pointer (gmtime time)))) + (values (1+ (uffi:get-slot-value tm-ptr 'tm 'mon)) + (uffi:get-slot-value tm-ptr 'tm 'mday) + (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year)) + (uffi:get-slot-value tm-ptr 'tm 'hour) + (uffi:get-slot-value tm-ptr 'tm 'min) + (uffi:get-slot-value tm-ptr 'tm 'sec) + ))) 1 1 1970 2 3 1) -- 2.34.1