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

ieslick ieslick at common-lisp.net
Sun Feb 4 10:17:21 UTC 2007


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))))
     , 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/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]



More information about the Elephant-cvs mailing list