[elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp

Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv8664/src/contrib/eslick/db-lisp

Added Files: TODO binary-data.lisp binary-types.lisp btree.lisp buffers.lisp file.lisp lisp-types.lisp octet-stream.lisp package.lisp Log Message: Cleaning up source directory, moving partial projects to contrib

--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/04 10:17:21 1.1

A lisp backend will need: - read/write binary sequences - move/cache binary pages to/from disk - locking of structures/pages for multi-threaded use - transaction logging (context + primitives) - checkpointing, backup and log removal

Want to build other data structures on this basic substrate: - large sets / persistent arrays - linear records - inverse index

Can we store odd types? - Classes? - Closures? - Functions? (probably only with source access)

Some constraints: - A binary file will allow for multiple internal btrees, will lock the root indices - Want to enable multiple possible allocation, layout and update algorithms; so each file should describe its type? - Would like to allow multiple processes to have open file handles Perhaps have a per-thread file handle? - Mixing types is possible if based on underlying page size, but performance will suffer

;; read/write fields in an array ;; parse/unparse from a stream or array

;; instantiate a lisp version of the binary type ;; associate a type with an array

;; need binary versions of native lisp types

;; (defgeneric parse-binary-value (type in &key) ;; (:documentation "Read a binary value from an array or stream"))

;; (defmethod parse-binary-value ((type (eql 'u8)) (in stream) &key) ;; (read-byte in))

;; (defmethod parse-binary-value ((type (eql 'u8)) (in array) &key (offset 0)) ;; (declare (type fixnum offset)) ;; (assert (subtypep (type-of in) '(array (unsigned 8) *))) ;; (aref in offset))

;; (defmethod unparse-binary-value ((type (eql 'u8)) (out stream) (value (unsigned 8)) &key) ;; (write-byte value out))

;; (defmethod unparse-binary-value ((type (eql 'u8)) (out array) (value (unsigned 8)) &key (offset 0)) ;; (--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/binary-data.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/binary-data.lisp 2007/02/04 10:17:21 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)))) ,@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 ,@args) (declare (ignorable ,@args)) ,(type-reader-body spec stream)) (defmethod write-value ((,type (eql ',name)) ,stream ,value &key ,@args) (declare (ignorable ,@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 ,@args))) (2 (destructuring-bind ((in) &body body) (cdr (assoc :reader spec)) `(let ((,in ,stream)) ,@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 ,@args))) (2 (destructuring-bind ((out v) &body body) (cdr (assoc :writer spec)) `(let ((,out ,stream) (,v ,value)) ,@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 ,@args))))

(defun slot->write-value (spec stream) (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) `(write-value ',type ,stream ,name ,@args)))

(defun slot->binding (spec stream) (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) `(,name (read-value ',type ,stream ,@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/binary-types.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/binary-types.lisp 2007/02/04 10:17:21 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))))

[43 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/04 10:17:21 1.1

[45 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/buffers.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/buffers.lisp 2007/02/04 10:17:21 1.1

[209 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/04 10:17:21 1.1

[227 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/lisp-types.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/lisp-types.lisp 2007/02/04 10:17:21 1.1

[242 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/octet-stream.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/octet-stream.lisp 2007/02/04 10:17:21 1.1

[483 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/04 10:17:21 1.1

[555 lines skipped]