[elephant-cvs] CVS update: elephant/src/serializer.lisp
blee at common-lisp.net
blee at common-lisp.net
Sat Sep 4 08:20:38 UTC 2004
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv12752/src
Modified Files:
serializer.lisp
Log Message:
+base-char+ => +char+
handle uninterned symbols / symbols in another package
optimizations / fixes for bignums
fill-pointers
circularity fixes (big typo!)
automatic numeric array definition types
Date: Sat Sep 4 10:20:37 2004
Author: blee
Index: elephant/src/serializer.lisp
diff -u elephant/src/serializer.lisp:1.6 elephant/src/serializer.lisp:1.7
--- elephant/src/serializer.lisp:1.6 Sun Aug 29 22:40:49 2004
+++ elephant/src/serializer.lisp Sat Sep 4 10:20:37 2004
@@ -58,7 +58,7 @@
(defconstant +persistent+ (char-code #\P))
(defconstant +single-float+ (char-code #\F))
(defconstant +double-float+ (char-code #\D))
-(defconstant +base-char+ (char-code #\c))
+(defconstant +char+ (char-code #\c))
(defconstant +pathname+ (char-code #\p))
(defconstant +positive-bignum+ (char-code #\B))
(defconstant +negative-bignum+ (char-code #\b))
@@ -66,6 +66,7 @@
(defconstant +cons+ (char-code #\C))
(defconstant +hash-table+ (char-code #\H))
(defconstant +object+ (char-code #\O))
+
(defconstant +array+ (char-code #\A))
(defconstant +fill-pointer-p+ #x40)
@@ -90,7 +91,11 @@
(declare (type string s) (dynamic-extent s))
(buffer-write-byte +symbol+ bs)
(buffer-write-int (byte-length s) bs)
- (buffer-write-string s bs)))
+ (buffer-write-string s bs)
+ (let ((package (symbol-package frob)))
+ (if package
+ (%serialize (package-name package))
+ (%serialize nil)))))
(string
(buffer-write-byte +string+ bs)
(buffer-write-int (byte-length frob) bs)
@@ -107,9 +112,9 @@
(buffer-write-byte +double-float+ bs)
(buffer-write-double frob bs))
(character
- (buffer-write-byte +base-char+ bs)
+ (buffer-write-byte +char+ bs)
;; might be wide!
- (buffer-write-int (char-code frob) bs))
+ (buffer-write-uint (char-code frob) bs))
(pathname
(let ((s (namestring frob)))
(declare (type string s) (dynamic-extent s))
@@ -125,14 +130,15 @@
(buffer-write-byte +negative-bignum+ bs)
(buffer-write-byte +positive-bignum+ bs))
(buffer-write-int needed bs)
- (loop for i fixnum from 0 to word-size
- for byte-spec = (int-byte-spec i)
+ (loop for i fixnum from 0 below word-size
;; this ldb is consing on CMUCL!
;; there is an OpenMCL function which should work
;; and non-cons
- for the-uint of-type (unsigned-byte 32) = (ldb byte-spec num)
- do
- (buffer-write-uint the-uint bs))))
+ do
+ #+(or cmu sbcl)
+ (buffer-write-uint (%bignum-ref num i) bs)
+ #+(or allegro lispworks openmcl)
+ (buffer-write-uint (ldb (int-byte-spec i) num) bs))))
(rational
(buffer-write-byte +rational+ bs)
(%serialize (numerator frob))
@@ -194,6 +200,8 @@
(loop for i fixnum from 0 below rank
do (buffer-write-int (array-dimension frob i)
bs)))
+ (when (array-has-fill-pointer-p frob)
+ (buffer-write-int (fill-pointer frob) bs))
(loop for i fixnum from 0 below (array-total-size frob)
do
(%serialize (row-major-aref frob i)))))))
@@ -233,7 +241,11 @@
(buffer-read-fixnum bs))
((= tag +nil+) nil)
((= tag +symbol+)
- (intern (or (buffer-read-string bs (buffer-read-fixnum bs)) "")))
+ (let ((name (buffer-read-string bs (buffer-read-fixnum bs)))
+ (maybe-package-name (%deserialize bs)))
+ (if maybe-package-name
+ (intern name (find-package maybe-package-name))
+ (make-symbol name))))
((= tag +string+)
(buffer-read-string bs (buffer-read-fixnum bs)))
((= tag +persistent+)
@@ -244,8 +256,8 @@
(buffer-read-float bs))
((= tag +double-float+)
(buffer-read-double bs))
- ((= tag +base-char+)
- (code-char (buffer-read-byte bs)))
+ ((= tag +char+)
+ (code-char (buffer-read-uint bs)))
((= tag +pathname+)
(parse-namestring
(or (buffer-read-string bs (buffer-read-fixnum bs)) "")))
@@ -273,6 +285,7 @@
:rehash-size (%deserialize bs)
:rehash-threshold
(%deserialize bs))))
+ (setf (gethash id *circularity-hash*) h)
(loop for i fixnum from 0 below (%deserialize bs)
do
(setf (gethash (%deserialize bs) h)
@@ -283,6 +296,7 @@
(maybe-o (gethash id *circularity-hash*)))
(if maybe-o maybe-o
(let ((o (make-instance (%deserialize bs))))
+ (setf (gethash id *circularity-hash*) o)
(loop for i fixnum from 0 below (%deserialize bs)
do
(setf (slot-value o (%deserialize bs))
@@ -303,6 +317,9 @@
flags))
:adjustable (/= 0 (logand +adjustable-p+
flags)))))
+ (when (array-has-fill-pointer-p a)
+ (setf (fill-pointer a) (buffer-read-int bs)))
+ (setf (gethash id *circularity-hash*) a)
(loop for i fixnum from 0 below (array-total-size a)
do
(setf (row-major-aref a i) (%deserialize bs)))
@@ -315,7 +332,7 @@
(type buffer-stream bs)
(type fixnum length)
(type boolean positive))
- (loop for i from 0 upto (/ length 4)
+ (loop for i from 0 below (/ length 4)
for byte-spec = (int-byte-spec i)
with num integer = 0
do
@@ -330,22 +347,27 @@
(defvar byte-to-array-type (make-hash-table :test 'equalp))
(setf (gethash 'T array-type-to-byte) #x00)
-(setf (gethash 'bit array-type-to-byte) #x01)
-(setf (gethash '(unsigned-byte 2) array-type-to-byte) #x02)
-(setf (gethash '(unsigned-byte 4) array-type-to-byte) #x03)
-(setf (gethash '(unsigned-byte 8) array-type-to-byte) #x04)
-(setf (gethash '(unsigned-byte 16) array-type-to-byte) #x05)
-(setf (gethash '(unsigned-byte 32) array-type-to-byte) #x06)
-(setf (gethash '(unsigned-byte 64) array-type-to-byte) #x07)
-(setf (gethash '(signed-byte 8) array-type-to-byte) #x08)
-(setf (gethash '(signed-byte 16) array-type-to-byte) #x09)
-(setf (gethash '(signed-byte 32) array-type-to-byte) #x0A)
-(setf (gethash '(signed-byte 64) array-type-to-byte) #x0B)
-(setf (gethash 'character array-type-to-byte) #x0C)
-(setf (gethash 'single-float array-type-to-byte) #x0D)
-(setf (gethash 'double-float array-type-to-byte) #x0E)
-(setf (gethash '(complex single-float) array-type-to-byte) #x0F)
-(setf (gethash '(complex double-float) array-type-to-byte) #x10)
+(setf (gethash 'base-char array-type-to-byte) #x01)
+(setf (gethash 'character array-type-to-byte) #x02)
+(setf (gethash 'single-float array-type-to-byte) #x03)
+(setf (gethash 'double-float array-type-to-byte) #x04)
+(setf (gethash '(complex single-float) array-type-to-byte) #x05)
+(setf (gethash '(complex double-float) array-type-to-byte) #x06)
+(setf (gethash 'fixnum array-type-to-byte) #x07)
+(setf (gethash 'bit array-type-to-byte) #x08)
+(let ((counter 8))
+ (loop for i from 2 to 65
+ for spec = (list 'unsigned-byte i)
+ for uspec = (upgraded-array-element-type spec)
+ unless (gethash uspec array-type-to-byte)
+ do
+ (setf (gethash uspec array-type-to-byte) (incf counter)))
+ (loop for i from 2 to 65
+ for spec = (list 'signed-byte i)
+ for uspec = (upgraded-array-element-type spec)
+ unless (gethash uspec array-type-to-byte)
+ do
+ (setf (gethash uspec array-type-to-byte) (incf counter))))
(loop for key being the hash-key of array-type-to-byte
using (hash-value value)
More information about the Elephant-cvs
mailing list