Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv32420/src

Modified Files: serializer.lisp Log Message: split off utils.lisp, cleanup

Date: Sun Aug 29 09:54:46 2004 Author: blee

Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.4 elephant/src/serializer.lisp:1.5 --- elephant/src/serializer.lisp:1.4 Sat Aug 28 08:41:00 2004 +++ elephant/src/serializer.lisp Sun Aug 29 09:54:46 2004 @@ -37,18 +37,10 @@ ;;;

(in-package "ELEPHANT") -(eval-when (:compile-toplevel :load-toplevel :execute) - (use-package "UFFI"))

(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 + slots-and-values deserialize-bignum))

(def-type foreign-char :char) @@ -75,26 +67,6 @@ (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))) @@ -227,6 +199,7 @@ (finish-buffer bs)))

(defun slots-and-values (o) + (declare (optimize (speed 3) (safety 0))) (loop for sd in (compute-slots (class-of o)) for slot-name = (slot-definition-name sd) with ret = () @@ -345,205 +318,6 @@ finally (return (if positive num (- num)))))

- -;; 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)) - (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)) - (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 finish-buffer (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position)) - bs - (let ((length pos)) - (setf pos 0) - length))) - -(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)))) - -(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))) - -(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))) - -(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))) - -(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))) - -(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))) - -(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))) - -(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)))) - -(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 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 buffer-read-string (bs length) - (declare (optimize (speed 3) (safety 0)) - (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)) @@ -578,11 +352,6 @@

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