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