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) + ,@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)) + )