[elephant-cvs] CVS update: elephant/src/serializer.lisp
blee at common-lisp.net
blee at common-lisp.net
Fri Aug 27 02:57:37 UTC 2004
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv23860/src
Modified Files:
serializer.lisp
Log Message:
aggregate object support
Date: Thu Aug 26 19:57:36 2004
Author: blee
Index: elephant/src/serializer.lisp
diff -u elephant/src/serializer.lisp:1.1.1.1 elephant/src/serializer.lisp:1.2
--- elephant/src/serializer.lisp:1.1.1.1 Thu Aug 19 10:05:14 2004
+++ elephant/src/serializer.lisp Thu Aug 26 19:57:36 2004
@@ -2,261 +2,555 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package "UFFI"))
-; f: fixnum <-> long
-; i: integer <-> array of long
-; r: rational <-> 2x array of long
-
-; l: long-float <-> double (punt on other floats? check
-; *features* for :ieee-floating-point -- see
-; http://www.common-lisp.net/project/ieeefp-tests/)
-
-; N: nil
-; S: symbol
-; c: character (hopefully a base-char)
-; s: string
-; p: pathname
-
-; o: CL-STORE stream
-
-; O: persistent object
-
-
-(declaim (inline resize-write-buffer int-byte-spec copy-buf
- deserialize-tail-string deserialize-bignum))
-
-(declaim (type array-char *write-buffer* *write-buffer-rest*
- *read-buffer* *read-buffer-rest*)
- (type fixnum *write-buffer-length* *read-buffer-length*))
-
-(defconstant +fixnum+ (char-code #\f))
-(defconstant +positive-bignum+ (char-code #\B))
-(defconstant +negative-bignum+ (char-code #\b))
-(defconstant +rational+ (char-code #\r))
-(defconstant +long-float+ (char-code #\l))
-(defconstant +nil+ (char-code #\N))
-(defconstant +symbol+ (char-code #\S))
-(defconstant +base-char+ (char-code #\c))
-(defconstant +string+ (char-code #\s))
-(defconstant +pathname+ (char-code #\p))
-(defconstant +cl-store+ (char-code #\O))
-(defconstant +persistent-object+ (char-code #\P))
+(declaim (inline int-byte-spec
+ ;resize-buffer-stream
+ finish-buffer
+ 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
+ buffer-read-string
+ ;serialize deserialize
+ deserialize-bignum))
-(defconstant +fixnum-width+ (integer-length most-positive-fixnum))
+(def-type foreign-char :char)
-#+(or cmu scl sbcl allegro)
-(defvar *resourced-byte-spec* (byte 32 0))
+;; Constants
-(defun int-byte-spec (position)
+(defconstant +fixnum+ (char-code #\f))
+(defconstant +symbol+ (char-code #\S))
+(defconstant +string+ (char-code #\s))
+(defconstant +nil+ (char-code #\N))
+(defconstant +persistent+ (char-code #\P))
+(defconstant +single-float+ (char-code #\F))
+(defconstant +double-float+ (char-code #\D))
+(defconstant +base-char+ (char-code #\c))
+(defconstant +pathname+ (char-code #\p))
+(defconstant +positive-bignum+ (char-code #\B))
+(defconstant +negative-bignum+ (char-code #\b))
+(defconstant +rational+ (char-code #\r))
+(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)
+(defconstant +adjustable-p+ #x80)
+
+; a stream-like interface for our buffers. ultimately we
+; might want a gray / simple -stream for real, for now who
+; cares?
+
+(defstruct buffer-stream
+ (buffer (allocate-foreign-object :char 1) :type array-or-pointer-char)
+ (length 0 :type fixnum)
+ (position 0 :type fixnum))
+
+;; Some thread-local storage
+
+(declaim (type buffer-stream *out-buf* *key-buf* *in-buf*)
+ (type fixnum *lisp-obj-id*)
+ (type hash-table *circularity-hash*))
+
+(defvar *out-buf* (make-buffer-stream))
+(defvar *key-buf* (make-buffer-stream))
+(defvar *in-buf* (make-buffer-stream))
+(defvar *lisp-obj-id* 0)
+(defvar *circularity-hash* (make-hash-table :test 'eq))
+
+(defun serialize (frob bs)
+ (declare (optimize (speed 3) (safety 0)))
+ (setq *lisp-obj-id* 0)
+ (clrhash *circularity-hash*)
+ (labels
+ ((%serialize (frob)
+ (declare (optimize (speed 3) (safety 0)))
+ (etypecase frob
+ (fixnum
+ (buffer-write-byte +fixnum+ bs)
+ (buffer-write-int frob bs))
+ (symbol
+ (let ((s (symbol-name frob)))
+ (declare (type string s) (dynamic-extent s))
+ (buffer-write-byte +symbol+ bs)
+ (buffer-write-int (byte-length s) bs)
+ (buffer-write-string s bs)))
+ (string
+ (buffer-write-byte +string+ bs)
+ (buffer-write-int (byte-length frob) bs)
+ (buffer-write-string frob bs))
+ (null
+ (buffer-write-byte +nil+ bs))
+ (persistent
+ (buffer-write-byte +persistent+ bs)
+ (buffer-write-int (oid frob) bs)
+ (%serialize (type-of frob)))
+ #-(and :lispworks (or :win32 :linux))
+ (single-float
+ (buffer-write-byte +single-float+ bs)
+ (buffer-write-float frob bs))
+ (double-float
+ (buffer-write-byte +double-float+ bs)
+ (buffer-write-double frob bs))
+ (character
+ (buffer-write-byte +base-char+ bs)
+ ;; might be wide!
+ (buffer-write-int (char-code frob) bs))
+ (pathname
+ (let ((s (namestring frob)))
+ (declare (type string s) (dynamic-extent s))
+ (buffer-write-byte +pathname+ bs)
+ (buffer-write-int (byte-length s) bs)
+ (buffer-write-string s bs)))
+ (integer
+ (let* ((num (abs frob))
+ (word-size (ceiling (/ (integer-length num) 32)))
+ (needed (* word-size 4)))
+ (declare (type fixnum word-size needed))
+ (if (< frob 0)
+ (buffer-write-byte +negative-bignum+ bs)
+ (buffer-write-byte +positive-bignum+ bs))
+ (buffer-write-int needed bs)
+ (loop for i fixnum from 0 below word-size
+ ;; shouldn't this be "below"?
+ for byte-spec = (int-byte-spec i)
+ ;; this ldb is consing!
+ ;; 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))))
+ (rational
+ (buffer-write-byte +rational+ bs)
+ (%serialize (numerator frob))
+ (%serialize (denominator frob)))
+ (cons
+ (buffer-write-byte +cons+ bs)
+ (let ((idp (gethash frob *circularity-hash*)))
+ (if idp (buffer-write-int idp bs)
+ (progn
+ (buffer-write-int (incf *lisp-obj-id*) bs)
+ (setf (gethash frob *circularity-hash*) *lisp-obj-id*)
+ (%serialize (car frob))
+ (%serialize (cdr frob))))))
+ (hash-table
+ (buffer-write-byte +hash-table+ bs)
+ (let ((idp (gethash frob *circularity-hash*)))
+ (if idp (buffer-write-int idp bs)
+ (progn
+ (buffer-write-int (incf *lisp-obj-id*) bs)
+ (setf (gethash frob *circularity-hash*) *lisp-obj-id*)
+ (%serialize (hash-table-test frob))
+ (%serialize (hash-table-rehash-size frob))
+ (%serialize (hash-table-rehash-threshold frob))
+ (%serialize (hash-table-count frob))
+ (loop for key being the hash-key of frob
+ using (hash-value value)
+ do
+ (%serialize key)
+ (%serialize value))))))
+ (standard-object
+ (buffer-write-byte +object+ bs)
+ (let ((idp (gethash frob *circularity-hash*)))
+ (if idp (buffer-write-int idp bs)
+ (progn
+ (buffer-write-int (incf *lisp-obj-id*) bs)
+ (setf (gethash frob *circularity-hash*) *lisp-obj-id*)
+ (%serialize (type-of frob))
+ (let ((svs (slots-and-values frob)))
+ (declare (dynamic-extent svs))
+ (%serialize (/ (length svs) 2))
+ (loop for item in svs
+ do (%serialize item)))))))
+ (array
+ (buffer-write-byte +array+ bs)
+ (let ((idp (gethash frob *circularity-hash*)))
+ (if idp (buffer-write-int idp bs)
+ (progn
+ (buffer-write-int (incf *lisp-obj-id*) bs)
+ (setf (gethash frob *circularity-hash*) *lisp-obj-id*)
+ (buffer-write-byte
+ (logior (byte-from-array-type (array-element-type frob))
+ (if (array-has-fill-pointer-p frob)
+ +fill-pointer-p+ 0)
+ (if (adjustable-array-p frob)
+ +adjustable-p+ 0))
+ bs)
+ (let ((rank (array-rank frob)))
+ (buffer-write-int rank bs)
+ (loop for i fixnum from 0 below rank
+ do (buffer-write-int (array-dimension frob i)
+ bs)))
+ (loop for i fixnum from 0 below (array-total-size frob)
+ do
+ (%serialize (row-major-aref frob i)))))))
+ )))
+ (%serialize frob)
+ (finish-buffer bs)))
+
+(defun slots-and-values (o)
+ (loop for sd in (compute-slots (class-of o))
+ for slot-name = (slot-definition-name sd)
+ with ret = ()
+ do
+ (when (slot-boundp o slot-name)
+ (push (slot-value o slot-name) ret)
+ (push slot-name ret))
+ finally (return ret)))
+
+(defun deserialize (buf)
(declare (optimize (speed 3) (safety 0))
- (type fixnum position))
- #+(or cmu scl sbcl allegro)
- (progn (setf (cdr *resourced-byte-spec*) (* 32 position))
- *resourced-byte-spec*)
- #-(or cmu scl sbcl allegro)
- (byte 32 (* 32 position))
- )
+ (type array-or-pointer-char buf))
+ (setf (buffer-stream-buffer *in-buf*) buf)
+ (setf (buffer-stream-position *in-buf*) 0)
+ (setq *lisp-obj-id* 0)
+ (clrhash *circularity-hash*)
+ (labels
+ ((%deserialize (bs)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs))
+ (let ((tag (buffer-read-byte bs)))
+ (declare (type foreign-char tag))
+ (cond
+ ((= tag +fixnum+)
+ (buffer-read-fixnum bs))
+ ((= tag +symbol+)
+ (intern (or (buffer-read-string bs (buffer-read-fixnum bs)) "")))
+ ((= tag +string+)
+ (buffer-read-string bs (buffer-read-fixnum bs)))
+ ((= tag +nil+) nil)
+ ((= tag +persistent+)
+ (get-cached-instance *store-controller*
+ (buffer-read-fixnum bs)
+ (%deserialize bs)))
+ ((= tag +single-float+)
+ (buffer-read-float bs))
+ ((= tag +double-float+)
+ (buffer-read-double bs))
+ ((= tag +base-char+)
+ (code-char (buffer-read-byte bs)))
+ ((= tag +pathname+)
+ (parse-namestring
+ (or (buffer-read-string bs (buffer-read-fixnum bs)) "")))
+ ((= tag +positive-bignum+)
+ (deserialize-bignum bs (buffer-read-fixnum bs) t))
+ ((= tag +negative-bignum+)
+ (deserialize-bignum bs (buffer-read-fixnum bs) nil))
+ ((= tag +rational+)
+ (/ (the integer (%deserialize bs))
+ (the integer (%deserialize bs))))
+ ((= tag +cons+)
+ (let* ((id (buffer-read-fixnum bs))
+ (maybe-cons (gethash id *circularity-hash*)))
+ (if maybe-cons maybe-cons
+ (let ((c (cons nil nil)))
+ (setf (gethash id *circularity-hash*) c)
+ (setf (car c) (%deserialize bs))
+ (setf (cdr c) (%deserialize bs))
+ c))))
+ ((= tag +hash-table+)
+ (let* ((id (buffer-read-fixnum bs))
+ (maybe-hash (gethash id *circularity-hash*)))
+ (if maybe-hash maybe-hash
+ (let ((h (make-hash-table :test (%deserialize bs)
+ :rehash-size (%deserialize bs)
+ :rehash-threshold
+ (%deserialize bs))))
+ (loop for i fixnum from 0 below (%deserialize bs)
+ do
+ (setf (gethash (%deserialize bs) h)
+ (%deserialize bs)))
+ h))))
+ ((= tag +object+)
+ (let* ((id (buffer-read-fixnum bs))
+ (maybe-o (gethash id *circularity-hash*)))
+ (if maybe-o maybe-o
+ (let ((o (make-instance (%deserialize bs))))
+ (loop for i fixnum from 0 below (%deserialize bs)
+ do
+ (setf (slot-value o (%deserialize bs))
+ (%deserialize bs)))
+ o))))
+ ((= tag +array+)
+ (let* ((id (buffer-read-fixnum bs))
+ (maybe-array (gethash id *circularity-hash*)))
+ (if maybe-array maybe-array
+ (let* ((flags (buffer-read-byte bs))
+ (a (make-array
+ (loop for i fixnum from 0 below
+ (buffer-read-int bs)
+ collect (buffer-read-int bs))
+ :element-type (array-type-from-byte
+ (logand #x3f flags))
+ :fill-pointer (/= 0 (logand +fill-pointer-p+
+ flags))
+ :adjustable (/= 0 (logand +adjustable-p+
+ flags)))))
+ (loop for i fixnum from 0 below (array-total-size a)
+ do
+ (setf (row-major-aref a i) (%deserialize bs)))
+ a))))
+ (t (error "deserialize fubar!"))))))
+ (%deserialize *in-buf*)))
+(defun deserialize-bignum (bs length positive)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs)
+ (type fixnum length)
+ (type boolean positive))
+ (loop for i from 0 upto (/ length 4)
+ for byte-spec = (int-byte-spec i)
+ with num integer = 0
+ do
+ (setq num (dpb (buffer-read-uint bs) byte-spec num))
+ finally (return (if positive num (- num)))))
-(defvar *write-buffer* (allocate-foreign-object :char 2))
-(defvar *write-buffer-rest*
- (make-pointer (+ (pointer-address *write-buffer*) 1) :char))
-(defvar *write-buffer-length* 0)
-(defun resize-write-buffer (length)
+
+;; Stream-like buffer interface
+
+(eval-when (:compile-toplevel :load-toplevel)
+ (defun process-struct-slot-defs (slot-defs struct)
+ (loop for def in slot-defs
+ collect (list (first def) (list (second def) struct)))))
+
+(defmacro with-struct-slots (slot-defs struct &body body)
+ `(symbol-macrolet ,(process-struct-slot-defs slot-defs struct)
+ , at body))
+
+(declaim (type array-or-pointer-char *buffer* *key-buffer*)
+ (type fixnum *buffer-length* *buffer-position*
+ *key-buffer-length* *key-buffer-position*))
+
+(defun resize-buffer-stream (bs length)
(declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs)
(type fixnum length))
- (if (< length *write-buffer-length*)
- (values *write-buffer* *write-buffer-length*)
- (let ((newlen (max length (* *write-buffer-length* 2))))
+ (with-struct-slots ((buf buffer-stream-buffer)
+ (pos buffer-stream-position)
+ (len buffer-stream-length))
+ bs
+ (when (> length len)
+ (let ((newlen (max length (* len 2))))
(declare (type fixnum newlen))
- (setq *write-buffer-length* newlen)
- (free-foreign-object *write-buffer*)
- (setq *write-buffer* (allocate-foreign-object :char newlen))
- (setq *write-buffer-rest*
- (make-pointer (+ (pointer-address *write-buffer*) 1) :char))
- (values *write-buffer* *write-buffer-length*))))
-
-(defvar *read-buffer* (allocate-foreign-object :char 2))
-(defvar *read-buffer-rest*
- (make-pointer (+ (pointer-address *read-buffer*) 1) :char))
-(defvar *read-buffer-length* 0)
+ (let ((newbuf (allocate-foreign-object :char newlen)))
+ (copy-bufs newbuf 0 buf 0 len)
+ (free-foreign-object buf)
+ (setf buf newbuf)
+ (setf len newlen)
+ nil)))))
-(defun resize-read-buffer (buf length)
+(defun finish-buffer (bs)
(declare (optimize (speed 3) (safety 0))
- (ignore buf)
- (type fixnum length))
- (if (< length *read-buffer-length*)
- (values *read-buffer* *read-buffer-length*)
- (let ((newlen (max length (* *read-buffer-length* 2))))
- (declare (type fixnum newlen))
- (setq *read-buffer-length* newlen)
- (free-foreign-object *read-buffer*)
- (setq *read-buffer* (allocate-foreign-object :char newlen))
- (setq *read-buffer-rest*
- (make-pointer (+ (pointer-address *read-buffer*) 1) :char))
- (values *read-buffer* *read-buffer-length*))))
-
-(defun copy-buf (str buf len &key (src-offset 0) (buf-offset 0))
- (declare (optimize (speed 3) (safety 0))
- (type string str)
- (type array-char buf)
- (type fixnum len src-offset buf-offset)
- (dynamic-extent str buf len))
- (typecase str
- (simple-string
- (loop for i fixnum from 0 below len
- do
- (setf (deref-array buf '(:array :char) (+ i buf-offset))
- (char-code (schar str (+ i src-offset))))))
- (string
- (loop for i fixnum from 0 below len
- do
- (setf (deref-array buf '(:array :char) (+ i buf-offset))
- (char-code (char str (+ i src-offset))))))))
+ (type buffer-stream bs))
+ (with-struct-slots ((buf buffer-stream-buffer)
+ (pos buffer-stream-position))
+ bs
+ (let ((length pos))
+ (setf pos 0)
+ length)))
-(def-type foreign-char :char)
+(defun buffer-write-byte (b bs)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs)
+ (type (unsigned-byte 8) b))
+ (with-struct-slots ((buf buffer-stream-buffer)
+ (pos buffer-stream-position)
+ (len buffer-stream-length))
+ bs
+ (let ((needed (+ pos 1)))
+ (when (> needed len)
+ (resize-buffer-stream bs needed))
+ (setf (deref-array buf '(:array :char) pos) b)
+ (setf pos needed))))
-(defmacro write-tag (tag)
- `(setf (deref-pointer *write-buffer* :char) ,tag))
+(defun buffer-write-int (i bs)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs)
+ (type (signed-byte 32) i))
+ (with-struct-slots ((buf buffer-stream-buffer)
+ (pos buffer-stream-position)
+ (len buffer-stream-length))
+ bs
+ (let ((needed (+ pos 4)))
+ (when (> needed len)
+ (resize-buffer-stream bs needed))
+ (write-int buf i pos)
+ (setf pos needed)
+ nil)))
-(defgeneric serialize (frob))
+(defun buffer-write-uint (u bs)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs)
+ (type (unsigned-byte 32) u))
+ (with-struct-slots ((buf buffer-stream-buffer)
+ (pos buffer-stream-position)
+ (len buffer-stream-length))
+ bs
+ (let ((needed (+ pos 4)))
+ (when (> needed len)
+ (resize-buffer-stream bs needed))
+ (write-uint buf u pos)
+ (setf pos needed)
+ nil)))
-(defmethod serialize ((frob integer))
- (declare (optimize (speed 3) (safety 0)))
- (if (typep frob 'fixnum)
- (progn
- (write-tag +fixnum+)
- (with-cast-pointer (p *write-buffer-rest* :int)
- (setf (deref-pointer p :int) frob))
- (values *write-buffer* 5))
- (let* ((num (abs frob))
- (word-size (ceiling (/ (integer-length num) 32)))
- (needed (+ (* word-size 4) 1)))
- (declare (type fixnum word-size needed))
- (when (> needed *write-buffer-length*)
- (resize-write-buffer needed))
- (if (> frob 0) (write-tag +positive-bignum+)
- (write-tag +negative-bignum+))
- (with-cast-pointer
- (p *write-buffer-rest* :unsigned-int)
- (loop for i fixnum from 0 to word-size
- for byte-spec = (int-byte-spec i)
- ;; this ldb is consing!
- for the-byte of-type (unsigned-byte 32) = (ldb byte-spec num)
- do
- (setf (deref-array p '(:array :unsigned-int) i) the-byte)
- finally
- (return (values *write-buffer* needed)))))))
+(defun buffer-write-float (d bs)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs)
+ (type single-float d))
+ (with-struct-slots ((buf buffer-stream-buffer)
+ (pos buffer-stream-position)
+ (len buffer-stream-length))
+ bs
+ (let ((needed (+ pos 4)))
+ (when (> needed len)
+ (resize-buffer-stream bs needed))
+ (write-float buf d pos)
+ (setf pos needed)
+ nil)))
-(defmethod serialize ((frob float))
- (declare (optimize (speed 3) (safety 0)))
- (write-tag +long-float+)
- (with-cast-pointer
- (p *write-buffer-rest* :double)
- (setf (deref-pointer p :double) (coerce frob 'long-float)))
- (values *write-buffer* 9))
-
-(defmethod serialize ((frob null))
- (declare (optimize (speed 3) (safety 0)))
- (write-tag +nil+)
- (values *write-buffer* 1))
+(defun buffer-write-double (d bs)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs)
+ (type double-float d))
+ (with-struct-slots ((buf buffer-stream-buffer)
+ (pos buffer-stream-position)
+ (len buffer-stream-length))
+ bs
+ (let ((needed (+ pos 8)))
+ (when (> needed len)
+ (resize-buffer-stream bs needed))
+ (write-double buf d pos)
+ (setf pos needed)
+ nil)))
-(defmethod serialize ((frob character))
- (declare (optimize (speed 3) (safety 0)))
- (write-tag +base-char+)
- (setf (deref-array *write-buffer* '(:array :char) 1) (char-code frob))
- (values *write-buffer* 2))
+(defun buffer-write-string (s bs)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs)
+ (type string s))
+ (with-struct-slots ((buf buffer-stream-buffer)
+ (pos buffer-stream-position)
+ (len buffer-stream-length))
+ bs
+ (let* ((str-bytes (byte-length s))
+ (needed (+ pos str-bytes)))
+ (declare (type fixnum str-bytes needed)
+ (dynamic-extent str-bytes needed))
+ (when (> needed len)
+ (resize-buffer-stream bs needed))
+ (copy-str-to-buf buf pos s 0 str-bytes)
+ (setf pos needed)
+ nil)))
-(defmethod serialize ((frob symbol))
- (declare (optimize (speed 3) (safety 0)))
- (let* ((s (symbol-name frob))
- (slen (length s))
- (needed (+ slen 1)))
- (declare (type fixnum slen needed)
- (dynamic-extent s))
- (when (> needed *write-buffer-length*) (resize-write-buffer needed))
- (write-tag +symbol+)
- (copy-buf s *write-buffer-rest* slen)
- (values *write-buffer* needed)))
+(defun buffer-read-byte (bs)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs))
+ (let ((pos (buffer-stream-position bs)))
+ (incf (buffer-stream-position bs))
+ (deref-array (buffer-stream-buffer bs) '(:array :char) pos)))
-(defmethod serialize ((frob string))
- (declare (optimize (speed 3) (safety 0)))
- (let* ((slen (length frob))
- (needed (+ slen 1)))
- (declare (type fixnum slen needed))
- (when (> needed *write-buffer-length*) (resize-write-buffer needed))
- (write-tag +string+)
- (copy-buf frob *write-buffer-rest* slen)
- (values *write-buffer* needed)))
+(defun buffer-read-fixnum (bs)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs))
+ (let ((pos (buffer-stream-position bs)))
+ (setf (buffer-stream-position bs) (+ pos 4))
+ (the fixnum (read-int (buffer-stream-buffer bs) pos))))
-(defmethod serialize ((frob pathname))
- (declare (optimize (speed 3) (safety 0)))
- (let ((s (namestring frob)))
- (declare (type string s) (dynamic-extent s))
- (let* ((slen (length s))
- (needed (+ slen 1)))
- (declare (type fixnum slen needed))
- (when (> needed *write-buffer-length*) (resize-write-buffer needed))
- (write-tag +pathname+)
- (copy-buf s *write-buffer-rest* slen)
- (values *write-buffer* needed))))
-
-;(defmethod serialize ((frob persistent))
-; (declare (optimize (speed 3) (safety 0)))
-; (let ((s (%class-name frob)))
-; (declare (type string s))
-; (let* ((slen (length s))
-; (needed (+ slen 2)))
-; (declare (type fixnum slen needed))
-; (write-tag +persistent-object+)
-; (copy-buf (
-; (concatenate 'string "O" (prin1-to-string (oid frob))
-; ":" (%class-name frob)))
+(defun buffer-read-int (bs)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs))
+ (let ((pos (buffer-stream-position bs)))
+ (setf (buffer-stream-position bs) (+ pos 4))
+ (the (signed-byte 32) (read-int (buffer-stream-buffer bs) pos))))
+(defun buffer-read-uint (bs)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs))
+ (let ((pos (buffer-stream-position bs)))
+ (setf (buffer-stream-position bs) (+ pos 4))
+ (the (unsigned-byte 32)(read-uint (buffer-stream-buffer bs) pos))))
+(defun buffer-read-float (bs)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs))
+ (let ((pos (buffer-stream-position bs)))
+ (setf (buffer-stream-position bs) (+ pos 4))
+ (read-float (buffer-stream-buffer bs) pos)))
-(defun deserialize (buf buf-rest length)
- (declare (optimize (speed 3) (safety 0))
- (type array-char buf buf-rest)
- (fixnum length))
- (let ((tag (deref-pointer buf :char)))
- (declare (type foreign-char tag))
- (cond
- ((= tag +string+)
- (convert-from-foreign-string buf-rest :length (- length 1)
- :null-terminated-p nil))
- ((= tag +fixnum+)
- (with-cast-pointer (p buf-rest :int)
- (deref-pointer p :int)))
- ((= tag +nil+) nil)
- ((= tag +long-float+)
- (with-cast-pointer
- (p buf-rest :double)
- (deref-pointer p :double)))
- ((= tag +positive-bignum+) (deserialize-bignum buf-rest length t))
- ((= tag +negative-bignum+) (deserialize-bignum buf-rest length nil))
- ((= tag +symbol+)
- (intern
- (convert-from-foreign-string buf-rest :length (- length 1)
- :null-terminated-p nil)))
- ((= tag +base-char+)
- (code-char (deref-array buf '(:array :char) 1)))
- ((= tag +pathname+)
- (parse-namestring
- (convert-from-foreign-string buf-rest :length (- length 1)
- :null-terminated-p nil)))
- (t (error "deserialize fubar!")))))
+(defun buffer-read-double (bs)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs))
+ (let ((pos (buffer-stream-position bs)))
+ (setf (buffer-stream-position bs) (+ pos 8))
+ (read-double (buffer-stream-buffer bs) pos)))
-(defun deserialize-bignum (buf-rest length positive)
+(defun buffer-read-string (bs length)
(declare (optimize (speed 3) (safety 0))
- (type array-char buf-rest)
- (type fixnum length)
- (type boolean positive))
- (with-cast-pointer (p buf-rest :unsigned-int)
- (loop for i from 0 upto (/ (- length 1) 4)
- for byte-spec = (int-byte-spec i)
- with num integer = 0
- do
- (setq num (dpb (deref-array p '(:array :unsigned-int) i)
- byte-spec num))
- finally (return (if positive num (- num))))))
\ No newline at end of file
+ (type buffer-stream bs)
+ (type fixnum length))
+ (let ((pos (buffer-stream-position bs)))
+ (setf (buffer-stream-position bs) (+ pos length))
+ ;; wide!!!
+ #+(and allegro ics)
+ (excl:native-to-string
+ (offset-char-pointer (buffer-stream-buffer bs) pos)
+ :length length
+ :external-format :unicode)
+ #+lispworks
+ (fli:convert-from-foreign-string
+ (offset-char-pointer (buffer-stream-buffer bs) pos)
+ :length length :external-format :unicode :null-terminated-p nil)
+ #-(or lispworks (and allegro ics))
+ (convert-from-foreign-string
+ (offset-char-pointer (buffer-stream-buffer bs) pos)
+ :length length :null-terminated-p nil)))
+
+;; array type tags
+
+(declaim (type hash-table array-type-to-byte byte-to-array-type))
+(defvar array-type-to-byte (make-hash-table :test 'equalp))
+(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)
+
+(loop for key being the hash-key of array-type-to-byte
+ using (hash-value value)
+ do
+ (setf (gethash value byte-to-array-type) key))
+
+(defun array-type-from-byte (b)
+ (gethash b byte-to-array-type))
+
+(defun byte-from-array-type (ty)
+ (the (unsigned-byte 8) (gethash ty array-type-to-byte)))
+
+;(defconstant +cl-store+ (char-code #\o))
+
+#+(or cmu scl sbcl allegro)
+(defvar *resourced-byte-spec* (byte 32 0))
+
+(defun int-byte-spec (position)
+ (declare (optimize (speed 3) (safety 0))
+ (type (unsigned-byte 24) position))
+ #+(or cmu scl sbcl allegro)
+ (progn (setf (cdr *resourced-byte-spec*) (* 32 position))
+ *resourced-byte-spec*)
+ #-(or cmu scl sbcl allegro)
+ (byte 32 (* 32 position))
+ )
More information about the Elephant-cvs
mailing list