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