r10380: working on new sbcl

diff --git a/src/aggregates.lisp b/src/aggregates.lisp
index ec1a559b2612ec5386223bed35ac0c7585654f32..5d0bcf75bfd07b0f7896efdc1d11091d7e0ce261 100644 (file)
--- 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
 
 #+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)
 
 #+cmu
 (defun convert-from-foreign-usb8 (s len)

diff --git a/src/primitives.lisp b/src/primitives.lisp
index 0f47eb70b2d104134d9d354d4ee193481f5fc0d8..ac4116ae8fd0ad9f0556d3ed4beb6db2f408cea4 100644 (file)
--- 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))
       (: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)
       (:float . alien:single-float)
       (:double . alien:double-float)
       (:void . t)

diff --git a/src/strings.lisp b/src/strings.lisp
index 7ac5c16c14b9d7ab5c423c82e1ffcf09199e0106..a0ca3fc31bdb26ad3e9d099c5caed63c552e0bf1 100644 (file)
--- 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)))
 
        (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)
 
 
 (eval-when (:compile-toplevel :load-toplevel :execute)

diff --git a/tests/gethostname.lisp b/tests/gethostname.lisp
index ec019daed3de518c632bca87fd34e7cbf661ab61..82137401e87b1b42abf82a670687167d67bf47eb 100644 (file)
--- 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.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 24a3af205c0d9483497a687a106db3049d37d3f1..cccd0b40f80421aa319a6ae294099a470906e0cc 100644 (file)
--- a/tests/time.lisp
+++ b/tests/time.lisp
@@ -26,7 +26,9 @@
   (year :int)
   (wday :int)
   (yday :int)
   (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)))
 
 (uffi:def-function ("time" c-time) 
     ((time (* time-t)))


@@ -50,16 +52,16 @@
   7381)
 
 (deftest time.2
   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)
 
 
   1 1 1970 2 3 1)