Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv19163/src
Modified Files:
serializer.lisp sleepycat.lisp
Log Message:
Bug fix for unicode SBCL
Date: Mon Dec 5 16:08:36 2005
Author: rread
Index: elephant/src/serializer.lisp
diff -u elephant/src/serializer.lisp:1.11 elephant/src/serializer.lisp:1.12
--- elephant/src/serializer.lisp:1.11 Wed Nov 23 18:51:37 2005
+++ elephant/src/serializer.lisp Mon Dec 5 16:08:35 2005
@@ -120,6 +120,7 @@
(%serialize (package-name package))
(%serialize nil)))))
(string
+ (progn
(buffer-write-byte
#+(and allegro ics) +ucs2-string+
#+(or (and sbcl sb-unicode) lispworks)
@@ -130,7 +131,7 @@
+ucs1-string+
bs)
(buffer-write-int (byte-length frob) bs)
- (buffer-write-string frob bs))
+ (buffer-write-string frob bs)))
(persistent
(buffer-write-byte +persistent+ bs)
(buffer-write-int (oid frob) bs)
@@ -293,6 +294,7 @@
((= tag +ucs4-symbol+)
(let ((name (buffer-read-ucs4-string bs (buffer-read-fixnum bs)))
(maybe-package-name (%deserialize bs)))
+;; (format t "ouput name = ~A~%" name)
(if maybe-package-name
(intern name (find-package maybe-package-name))
(make-symbol name))))
Index: elephant/src/sleepycat.lisp
diff -u elephant/src/sleepycat.lisp:1.14 elephant/src/sleepycat.lisp:1.15
--- elephant/src/sleepycat.lisp:1.14 Wed Nov 23 18:51:37 2005
+++ elephant/src/sleepycat.lisp Mon Dec 5 16:08:35 2005
@@ -149,19 +149,19 @@
)
(declaim (inline read-int read-uint read-float read-double
- write-int write-uint write-float write-double
- offset-char-pointer copy-str-to-buf %copy-str-to-buf copy-bufs
- ;;resize-buffer-stream
- ;;buffer-stream-buffer buffer-stream-size buffer-stream-position
- ;;buffer-stream-length
- reset-buffer-stream
- buffer-write-byte buffer-write-int buffer-write-uint
- buffer-write-float buffer-write-double buffer-write-string
- buffer-read-byte buffer-read-fixnum buffer-read-int
- buffer-read-uint buffer-read-float buffer-read-double
- #-(and allegreo ics) buffer-read-ucs1-string
- #+(or lispworks (and allegro ics)) buffer-read-ucs2-string
- #+(and sbcl sb-unicode) buffer-read-ucs4-string))
+ write-int write-uint write-float write-double
+ offset-char-pointer copy-str-to-buf %copy-str-to-buf copy-bufs
+ ;;resize-buffer-stream
+ ;;buffer-stream-buffer buffer-stream-size buffer-stream-position
+ ;;buffer-stream-length
+ reset-buffer-stream
+ buffer-write-byte buffer-write-int buffer-write-uint
+ buffer-write-float buffer-write-double buffer-write-string
+ buffer-read-byte buffer-read-fixnum buffer-read-int
+ buffer-read-uint buffer-read-float buffer-read-double
+ #-(and allegreo ics) buffer-read-ucs1-string
+ #+(or lispworks (and allegro ics)) buffer-read-ucs2-string
+ #+(and sbcl sb-unicode) buffer-read-ucs4-string))
;; Constants and Flags
;; eventually write a macro which generates a custom flag function.
@@ -541,10 +541,11 @@
#+(or cmu sbcl scl)
(defun copy-str-to-buf (d do s so l)
- (declare (optimize (speed 3) (safety 0))
- (type array-or-pointer-char d)
- (type fixnum do so l)
- (type string s))
+ (declare (optimize (speed 3) (safety 0))
+ (type array-or-pointer-char d)
+ (type fixnum do so l)
+ (type string s))
+;; (format t "copy-str-to-buf s = ~A do =~a so=~A len=~A~%" s do so l)
(%copy-str-to-buf d do
#+sbcl
(sb-sys:vector-sap s)
@@ -660,6 +661,7 @@
(declare (optimize (speed 3) (safety 0))
(type buffer-stream bs)
(type (unsigned-byte 8) b))
+;; (format t "BW-byte ~A~%" b)
(with-struct-slots ((buf buffer-stream-buffer)
(size buffer-stream-size)
(len buffer-stream-length))
@@ -737,9 +739,9 @@
(defun buffer-write-string (s bs)
"Write the underlying bytes of a string. On Unicode
Lisps, this is a 16-bit operation."
- (declare (optimize (speed 3) (safety 0))
- (type buffer-stream bs)
- (type string s))
+;; (declare (optimize (speed 3) (safety 0))
+;; (type buffer-stream bs)
+;; (type string s))
(with-struct-slots ((buf buffer-stream-buffer)
(size buffer-stream-size)
(len buffer-stream-length))
@@ -750,6 +752,8 @@
(dynamic-extent str-bytes needed))
(when (> needed len)
(resize-buffer-stream bs needed))
+;; I wonder if the basic problem here is that we are using this
+;; routine instead of something like "copy-ub8-from-system-area"?
(copy-str-to-buf buf size s 0 str-bytes)
(setf size needed)
nil)))
@@ -853,11 +857,11 @@
(let ((res (make-string byte-length :element-type 'base-char)))
#+#.(sleepycat::new-style-copy-p)
(sb-kernel:copy-ub8-from-system-area
- (sb-alien:alien-sap (buffer-stream-buffer bs))
- (* position sb-vm:n-byte-bits)
- res
- (* sb-vm:vector-data-offset sb-vm:n-word-bits)
- (* byte-length sb-vm:n-byte-bits))
+ (sb-alien:alien-sap (buffer-stream-buffer bs))
+ position
+ res
+ 0
+ byte-length)
#-#.(sleepycat::new-style-copy-p)
(sb-kernel:copy-from-system-area
(sb-alien:alien-sap (buffer-stream-buffer bs))
@@ -896,12 +900,12 @@
(setf (buffer-stream-position bs) (+ position byte-length))
(let ((res (make-string (/ byte-length 4) :element-type 'character)))
#+#.(sleepycat::new-style-copy-p)
- (sb-kernel:copy-ub8-from-system-area
- (sb-alien:alien-sap (buffer-stream-buffer bs))
- (* position sb-vm:n-byte-bits)
- res
- (* sb-vm:vector-data-offset sb-vm:n-word-bits)
- (* byte-length sb-vm:n-byte-bits))
+ (sb-kernel:copy-ub8-from-system-area
+ (sb-alien:alien-sap (buffer-stream-buffer bs))
+ position
+ res
+ 0
+ byte-length)
#-#.(sleepycat::new-style-copy-p)
(sb-kernel:copy-from-system-area
(sb-alien:alien-sap (buffer-stream-buffer bs))
