[elephant-cvs] CVS update: elephant/src/serializer.lisp
blee at common-lisp.net
blee at common-lisp.net
Sun Aug 29 07:54:47 UTC 2004
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)
- , 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))
- (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))
More information about the Elephant-cvs
mailing list