[elephant-cvs] CVS elephant/src

[ieslick]

Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp:/tmp/cvs-serv22917/src

Modified Files:
	serializer.lisp sleepycat.lisp 
Log Message:
Snapshot prior to transaction fix and backend reorg

--- /project/elephant/cvsroot/elephant/src/serializer.lisp	2006/02/14 15:25:10	1.14
+++ /project/elephant/cvsroot/elephant/src/serializer.lisp	2006/02/17 22:45:21	1.15
@@ -79,7 +79,10 @@
 	    (let ((s (symbol-name frob)))
 	      (declare (type string s) (dynamic-extent s))
 	      (buffer-write-byte 
-	       #+(and allegro ics) +ucs2-symbol+
+	       #+(and allegro ics)
+	       (etypecase s
+		 (base-string +ucs1-symbol+)
+		 (string +ucs2-symbol+))
 	       #+(or (and sbcl sb-unicode) lispworks)
 	       (etypecase s 
 		 (base-string +ucs1-symbol+) 
@@ -96,11 +99,14 @@
 	   (string
 	    (progn
 	    (buffer-write-byte 
-	     #+(and allegro ics) +ucs2-string+
+	     #+(and allegro ics)
+	     (etypecase frob
+	       (base-string +ucs1-string+)
+	       (string +ucs2-string+))
 	     #+(or (and sbcl sb-unicode) lispworks)
 	     (etypecase frob
-	       (base-string +ucs1-string+) 
-	       (string #+sbcl +ucs4-string+ #+lispwoks +ucs2-string+))
+	       (base-string +ucs1-string+)
+	       (string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+))
 	     #-(or lispworks (and allegro ics) (and sbcl sb-unicode))
 	     +ucs1-string+
 	     bs)
@@ -125,7 +131,10 @@
 	    (let ((s (namestring frob)))
 	      (declare (type string s) (dynamic-extent s))
 	      (buffer-write-byte 
-	       #+(and allegro ics) +ucs2-pathname+
+	       #+(and allegro ics) 
+	       (etypecase s
+		 (base-string +ucs1-pathname+)
+		 (string +ucs2-pathname+))
 	       #+(or (and sbcl sb-unicode) lispworks)
 	       (etypecase s 
 		 (base-string +ucs1-pathname+) 
@@ -250,7 +259,6 @@
 	     ((= tag +fixnum+) 
 	      (buffer-read-fixnum bs))
 	     ((= tag +nil+) nil)
-	     #-(and allegro ics)
 	     ((= tag +ucs1-symbol+)
 	      (let ((name (buffer-read-ucs1-string bs (buffer-read-fixnum bs)))
 		    (maybe-package-name (%deserialize bs)))
@@ -272,7 +280,7 @@
 		(if maybe-package-name
 		    (intern name (find-package maybe-package-name))
 		    (make-symbol name))))
-	     #-(and allegro ics)
+	     #+(and allegro ics)
 	     ((= tag +ucs1-string+)
 	      (buffer-read-ucs1-string bs (buffer-read-fixnum bs)))
 	     #+(or lispworks (and allegro ics))
@@ -292,7 +300,7 @@
 	      (buffer-read-double bs))
 	     ((= tag +char+)
 	      (code-char (buffer-read-uint bs)))
-	     #-(and allegro ics)
+	     #+(and allegro ics)
 	     ((= tag +ucs1-pathname+)
 	      (parse-namestring 
 	       (or (buffer-read-ucs1-string bs (buffer-read-fixnum bs)) "")))
--- /project/elephant/cvsroot/elephant/src/sleepycat.lisp	2006/02/07 23:23:51	1.19
+++ /project/elephant/cvsroot/elephant/src/sleepycat.lisp	2006/02/17 22:45:21	1.20
@@ -48,7 +48,7 @@
 	   #:buffer-write-string #:buffer-read-byte #:buffer-read-fixnum 
 	   #:buffer-read-int #:buffer-read-uint #:buffer-read-float 
 	   #:buffer-read-double 
-	   #-(and allegro ics) #:buffer-read-ucs1-string 
+	   #+(and allegro ics) #:buffer-read-ucs1-string 
 	   #+(or lispworks (and allegro ics)) #:buffer-read-ucs2-string 
 	   #+(and sbcl sb-unicode) #:buffer-read-ucs4-string 
 	   #:byte-length
@@ -490,7 +490,9 @@
 of a string."
   #+(and allegro ics)
   ;; old: `(let ((l (length ,s))) (+ l l))
-  `(excl:native-string-sizeof ,s :external-format :unicode)
+  `(etypecase ,s
+     (base-string (length ,s))
+     (string (excl:native-string-sizeof ,s :external-format :unicode)))
   #+(or (and sbcl sb-unicode) lispworks)
   `(etypecase ,s 
     (base-string (length ,s)) 
@@ -547,20 +549,20 @@
     (ccl::%copy-ivector-to-ptr ivector (+ disp src-offset)
 			       dest dest-offset length)))
 
-#+allegro
-(defun copy-str-to-buf (dest dest-offset src src-offset length)
-  "Use build-in unicode handling and copying facilities.
-   NOTE: We need to validate the speed of this vs. default."
-  (declare (optimize (speed 3) (safety 0))
-	   (type string src)
-	   (type array-or-pointer-char dest)
-	   (type fixnum length src-offset dest-offset)
-	   (dynamic-extent src dest length))
-  (excl:string-to-native (subseq src src-offset) :address (offset-char-pointer dest dest-offset)
-			     :external-format :unicode))
+;; #+allegro
+;; (defun copy-str-to-buf (dest dest-offset src src-offset length)
+;;   "Use build-in unicode handling and copying facilities.
+;;    NOTE: We need to validate the speed of this vs. default."
+;;   (declare (optimize (speed 3) (safety 0))
+;; 	   (type string src)
+;; 	   (type array-or-pointer-char dest)
+;; 	   (type fixnum length src-offset dest-offset)
+;; 	   (dynamic-extent src dest length))
+;;   (excl:string-to-native (subseq src src-offset) :address (offset-char-pointer dest dest-offset)
+;; 			     :external-format :unicode))
 
 ;; Lisp version, for kicks.  this assumes 8-bit chars!
-#+(not (or cmu sbcl scl allegro openmcl lispworks))
+#+(not (or cmu sbcl scl openmcl lispworks))
 (defun copy-str-to-buf (dest dest-offset src src-offset length)
   "Copy a string to a foreign buffer."
   (declare (optimize (speed 3) (safety 0))
@@ -730,9 +732,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))
@@ -745,10 +747,10 @@
 	(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"?
-      #-allegro
+;;      #-allegro
       (copy-str-to-buf buf size s 0 str-bytes)
-      #+allegro
-      (excl:string-to-native s :address (offset-char-pointer buf size) :external-format :unicode)
+;;      #+allegro
+;;      (excl:string-to-native s :address (offset-char-pointer buf size) :external-format :unicode)
       (setf size needed)
       nil)))