[elephant-cvs] CVS update: elephant/src/serializer.lisp elephant/src/sleepycat.lisp

[Robert L. Read]

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))