[elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp/archive
ieslick
ieslick at common-lisp.net
Mon Feb 12 20:36:45 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive
In directory clnet:/tmp/cvs-serv5382/src/contrib/eslick/db-lisp/archive
Added Files:
binary-data.lisp binary-types.lisp lisp-types.lisp
octet-stream.lisp serializer3.lisp
Log Message:
Henrik's fixes and latest db-lisp updates
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/binary-data.lisp 2007/02/12 20:36:45 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/binary-data.lisp 2007/02/12 20:36:45 1.1
(in-package :db-lisp)
;;
;; Macros
;;
(defmacro with-gensyms ((&rest names) &body body)
`(let ,(loop for n in names collect `(,n (make-symbol ,(string n))))
, at body))
;;
;; Binary types
;;
;; NOTE: Needs to be made MP safe
(defvar *in-progress-objects* nil)
(defconstant +null+ (code-char 0))
(defgeneric read-value (type stream &key)
(:documentation "Read a value of the given type from the stream."))
(defgeneric write-value (type stream value &key)
(:documentation "Write a value as the given type to the stream."))
(defgeneric read-object (object stream)
(:method-combination progn :most-specific-last)
(:documentation "Fill in the slots of object from stream."))
(defgeneric write-object (object stream)
(:method-combination progn :most-specific-last)
(:documentation "Write out the slots of object to the stream."))
;; These may not be needed; design your compound objects so that
;; you can read offsets and parse compound objects
;;(defgeneric read-field-value (type stream &optional base-pos)
;; (:documentation "Index directly to a subfield of a complex type to read
;; from a random underlying stream"))
;;
;;(defgeneric write-field-value (type stream value &optional base-pos)
;; (:documentation "Write an object directly to the subfield of a complex
;; type in the provided field"))
;;
;; Defaults for read-value of binary-object types
(defmethod read-value ((type symbol) stream &key)
(let ((object (make-instance type)))
(read-object object stream)
object))
(defmethod write-value ((type symbol) stream value &key)
(assert (typep value type))
(write-object value stream))
(defun read-value-at (type stream pos)
"Ensure a stream is at a particular offset before reading"
(file-position stream pos)
(read-value type stream))
(defun write-value-at (type stream pos value)
"Ensure a stream is at a particular offset before writing"
(file-position stream pos)
(write-value type stream value))
;;; Binary types
(defmacro define-binary-type (name (&rest args) &body spec)
(with-gensyms (type stream value)
`(progn
(defmethod read-value ((,type (eql ',name)) ,stream &key , at args)
(declare (ignorable , at args))
,(type-reader-body spec stream))
(defmethod write-value ((,type (eql ',name)) ,stream ,value &key , at args)
(declare (ignorable , at args))
,(type-writer-body spec stream value)))))
(defun type-reader-body (spec stream)
(ecase (length spec)
(1 (destructuring-bind (type &rest args) (mklist (first spec))
`(read-value ',type ,stream , at args)))
(2 (destructuring-bind ((in) &body body) (cdr (assoc :reader spec))
`(let ((,in ,stream)) , at body)))))
(defun type-writer-body (spec stream value)
(ecase (length spec)
(1 (destructuring-bind (type &rest args) (mklist (first spec))
`(write-value ',type ,stream ,value , at args)))
(2 (destructuring-bind ((out v) &body body) (cdr (assoc :writer spec))
`(let ((,out ,stream) (,v ,value)) , at body)))))
;;; Binary classes
(defmacro define-generic-binary-class (name (&rest superclasses) slots read-method)
(with-gensyms (objectvar streamvar)
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get ',name 'slots) ',(mapcar #'first slots))
(setf (get ',name 'superclasses) ',superclasses))
(defclass ,name ,superclasses
,(mapcar #'slot->defclass-slot slots))
,read-method
(defmethod write-object progn ((,objectvar ,name) ,streamvar)
(declare (ignorable ,streamvar))
(with-slots ,(new-class-all-slots slots superclasses) ,objectvar
,@(mapcar #'(lambda (x) (slot->write-value x streamvar)) slots))))))
(defmacro define-binary-class (name (&rest superclasses) slots)
(with-gensyms (objectvar streamvar)
`(define-generic-binary-class ,name ,superclasses ,slots
(defmethod read-object progn ((,objectvar ,name) ,streamvar)
(declare (ignorable ,streamvar))
(with-slots ,(new-class-all-slots slots superclasses) ,objectvar
,@(mapcar #'(lambda (x) (slot->read-value x streamvar)) slots))))))
(defmacro define-tagged-binary-class (name (&rest superclasses) slots &rest options)
(with-gensyms (typevar objectvar streamvar)
`(define-generic-binary-class ,name ,superclasses ,slots
(defmethod read-value ((,typevar (eql ',name)) ,streamvar &key)
(let* ,(mapcar #'(lambda (x) (slot->binding x streamvar)) slots)
(let ((,objectvar
(make-instance
,@(or (cdr (assoc :dispatch options))
(error "Must supply :disptach form."))
,@(mapcan #'slot->keyword-arg slots))))
(read-object ,objectvar ,streamvar)
,objectvar))))))
(defun as-keyword (sym) (intern (string sym) :keyword))
(defun normalize-slot-spec (spec)
(list (first spec) (mklist (second spec))))
(defun mklist (x) (if (listp x) x (list x)))
(defun slot->defclass-slot (spec)
(let ((name (first spec)))
`(,name :initarg ,(as-keyword name) :accessor ,name)))
(defun slot->read-value (spec stream)
(destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
`(setf ,name (read-value ',type ,stream , at args))))
(defun slot->write-value (spec stream)
(destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
`(write-value ',type ,stream ,name , at args)))
(defun slot->binding (spec stream)
(destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
`(,name (read-value ',type ,stream , at args))))
(defun slot->keyword-arg (spec)
(let ((name (first spec)))
`(,(as-keyword name) ,name)))
;;; Keeping track of inherited slots
(defun direct-slots (name)
(copy-list (get name 'slots)))
(defun inherited-slots (name)
(loop for super in (get name 'superclasses)
nconc (direct-slots super)
nconc (inherited-slots super)))
(defun all-slots (name)
(nconc (direct-slots name) (inherited-slots name)))
(defun new-class-all-slots (slots superclasses)
"Like all slots but works while compiling a new class before slots
and superclasses have been saved."
(nconc (mapcan #'all-slots superclasses) (mapcar #'first slots)))
;;; In progress Object stack
(defun current-binary-object ()
(first *in-progress-objects*))
(defun parent-of-type (type)
(find-if #'(lambda (x) (typep x type)) *in-progress-objects*))
(defmethod read-object :around (object stream)
(declare (ignore stream))
(let ((*in-progress-objects* (cons object *in-progress-objects*)))
(call-next-method)))
(defmethod write-object :around (object stream)
(declare (ignore stream))
(let ((*in-progress-objects* (cons object *in-progress-objects*)))
(call-next-method)))
;; Copyright (c) 2005, Peter Seibel All rights reserved.
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;; * Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; * Redistributions in binary form must reproduce the above
;; copyright notice, this list of conditions and the following
;; disclaimer in the documentation and/or other materials provided
;; with the distribution.
;; * Neither the name of the Peter Seibel nor the names of its
;; contributors may be used to endorse or promote products derived
;; from this software without specific prior written permission.
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/binary-types.lisp 2007/02/12 20:36:45 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/binary-types.lisp 2007/02/12 20:36:45 1.1
(in-package :db-lisp)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A few basic types
(define-binary-type unsigned-integer (bytes)
(:reader (in)
(loop with value = 0
for shift downfrom (* bytes 8) to 0 by 8 do
(setf value (logior (ash (read-byte in) shift) value))
finally (return value)))
(:writer (out value)
(loop for shift downfrom (* bytes 8) to 0 by 8 do
(write-byte (logand (ash value (- shift)) #xFF) out))))
(define-binary-type unsigned-integer-cplx (bytes bits-per-byte)
(:reader (in)
(loop with value = 0
for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do
(setf (ldb (byte bits-per-byte low-bit) value) (read-byte in))
finally (return value)))
(:writer (out value)
(loop for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte
do (write-byte (ldb (byte bits-per-byte low-bit) value) out))))
(define-binary-type u8 () (unsigned-integer :bytes 1))
(define-binary-type u16 () (unsigned-integer :bytes 2))
(define-binary-type u24 () (unsigned-integer :bytes 3))
(define-binary-type u32 () (unsigned-integer :bytes 4))
(define-binary-type u64 () (unsigned-integer :bytes 8))
;;; Strings
(define-binary-type generic-string (length character-type)
(:reader (in)
(let ((string (make-string length)))
(dotimes (i length)
(setf (char string i) (read-value character-type in)))
string))
(:writer (out string)
(dotimes (i length)
(write-value character-type out (char string i)))))
(define-binary-type generic-terminated-string (terminator character-type)
(:reader (in)
(with-output-to-string (s)
(loop for char = (read-value character-type in)
until (char= char terminator) do (write-char char s))))
(:writer (out string)
(loop for char across string
do (write-value character-type out char)
finally (write-value character-type out terminator))))
;;; ISO-8859-1 strings
(define-binary-type iso-8859-1-char ()
(:reader (in)
(let ((code (read-byte in)))
(or (code-char code)
(error "Character code ~d not supported" code))))
(:writer (out char)
(let ((code (char-code char)))
(if (<= 0 code #xff)
(write-byte code out)
(error "Illegal character for iso-8859-1 encoding: character: ~c with code: ~d" char code)))))
(define-binary-type iso-8859-1-string (length)
(generic-string :length length :character-type 'iso-8859-1-char))
(define-binary-type iso-8859-1-terminated-string (terminator)
(generic-terminated-string :terminator terminator :character-type 'iso-8859-1-char))
;;; UCS-2 (Unicode) strings (i.e. UTF-16 without surrogate pairs, phew.)
;;; Define a binary type for reading a UCS-2 character relative to a
;;; particular byte ordering as indicated by the BOM value.
;; v2.3 specifies that the BOM should be present. v2.2 is silent
;; though it is arguably inherent in the definition of UCS-2) Length
;; is in bytes. On the write side, since we don't have any way of
;; knowing what BOM was used to read the string we just pick one.
;; This does mean roundtrip transparency could be broken.
(define-binary-type ucs-2-char (swap)
(:reader (in)
(let ((code (read-value 'u2 in)))
(when swap (setf code (swap-bytes code)))
(or (code-char code) (error "Character code ~d not supported" code))))
(:writer (out char)
(let ((code (char-code char)))
(unless (<= 0 code #xffff)
(error "Illegal character for ucs-2 encoding: ~c with char-code: ~d" char code))
(when swap (setf code (swap-bytes code)))
(write-value 'u2 out code))))
(defun swap-bytes (code)
(assert (<= code #xffff))
(rotatef (ldb (byte 8 0) code) (ldb (byte 8 8) code))
code)
(define-binary-type ucs-2-char-big-endian () (ucs-2-char :swap nil))
(define-binary-type ucs-2-char-little-endian () (ucs-2-char :swap t))
(defun ucs-2-char-type (byte-order-mark)
(ecase byte-order-mark
(#xfeff 'ucs-2-char-big-endian)
(#xfffe 'ucs-2-char-little-endian)))
(define-binary-type ucs-2-string (length)
(:reader (in)
(let ((byte-order-mark (read-value 'u2 in))
(characters (1- (/ length 2))))
(read-value
'generic-string in
:length characters
:character-type (ucs-2-char-type byte-order-mark))))
(:writer (out string)
(write-value 'u2 out #xfeff)
(write-value
'generic-string out string
:length (length string)
:character-type (ucs-2-char-type #xfeff))))
(define-binary-type ucs-2-terminated-string (terminator)
(:reader (in)
(let ((byte-order-mark (read-value 'u2 in)))
(read-value
'generic-terminated-string in
:terminator terminator
:character-type (ucs-2-char-type byte-order-mark))))
(:writer (out string)
(write-value 'u2 out #xfeff)
(write-value
'generic-terminated-string out string
:terminator terminator
:character-type (ucs-2-char-type #xfeff))))
;; Copyright (c) 2005, Peter Seibel All rights reserved.
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;; * Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; * Redistributions in binary form must reproduce the above
;; copyright notice, this list of conditions and the following
;; disclaimer in the documentation and/or other materials provided
;; with the distribution.
;; * Neither the name of the Peter Seibel nor the names of its
;; contributors may be used to endorse or promote products derived
;; from this software without specific prior written permission.
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/lisp-types.lisp 2007/02/12 20:36:45 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/lisp-types.lisp 2007/02/12 20:36:45 1.1
(in-package :db-lisp)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Map lisp types to binary types
(defparameter *lisp-binary-typemap*
'((fixnum . u32)
[7 lines skipped]
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/octet-stream.lisp 2007/02/12 20:36:45 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/octet-stream.lisp 2007/02/12 20:36:45 1.1
[248 lines skipped]
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/serializer3.lisp 2007/02/12 20:36:45 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/serializer3.lisp 2007/02/12 20:36:45 1.1
[381 lines skipped]
More information about the Elephant-cvs
mailing list