elephant-cvs
Threads by month
- ----- 2025 -----
- July
- June
- May
- April
- March
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2007 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2006 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2005 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2004 -----
- December
- November
- October
- September
- August
August 2004
- 1 participants
- 76 discussions

27 Aug '04
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv23860/src
Modified Files:
serializer.lisp
Log Message:
aggregate object support
Date: Thu Aug 26 19:57:36 2004
Author: blee
Index: elephant/src/serializer.lisp
diff -u elephant/src/serializer.lisp:1.1.1.1 elephant/src/serializer.lisp:1.2
--- elephant/src/serializer.lisp:1.1.1.1 Thu Aug 19 10:05:14 2004
+++ elephant/src/serializer.lisp Thu Aug 26 19:57:36 2004
@@ -2,261 +2,555 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package "UFFI"))
-; f: fixnum <-> long
-; i: integer <-> array of long
-; r: rational <-> 2x array of long
-
-; l: long-float <-> double (punt on other floats? check
-; *features* for :ieee-floating-point -- see
-; http://www.common-lisp.net/project/ieeefp-tests/)
-
-; N: nil
-; S: symbol
-; c: character (hopefully a base-char)
-; s: string
-; p: pathname
-
-; o: CL-STORE stream
-
-; O: persistent object
-
-
-(declaim (inline resize-write-buffer int-byte-spec copy-buf
- deserialize-tail-string deserialize-bignum))
-
-(declaim (type array-char *write-buffer* *write-buffer-rest*
- *read-buffer* *read-buffer-rest*)
- (type fixnum *write-buffer-length* *read-buffer-length*))
-
-(defconstant +fixnum+ (char-code #\f))
-(defconstant +positive-bignum+ (char-code #\B))
-(defconstant +negative-bignum+ (char-code #\b))
-(defconstant +rational+ (char-code #\r))
-(defconstant +long-float+ (char-code #\l))
-(defconstant +nil+ (char-code #\N))
-(defconstant +symbol+ (char-code #\S))
-(defconstant +base-char+ (char-code #\c))
-(defconstant +string+ (char-code #\s))
-(defconstant +pathname+ (char-code #\p))
-(defconstant +cl-store+ (char-code #\O))
-(defconstant +persistent-object+ (char-code #\P))
+(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
+ deserialize-bignum))
-(defconstant +fixnum-width+ (integer-length most-positive-fixnum))
+(def-type foreign-char :char)
-#+(or cmu scl sbcl allegro)
-(defvar *resourced-byte-spec* (byte 32 0))
+;; Constants
-(defun int-byte-spec (position)
+(defconstant +fixnum+ (char-code #\f))
+(defconstant +symbol+ (char-code #\S))
+(defconstant +string+ (char-code #\s))
+(defconstant +nil+ (char-code #\N))
+(defconstant +persistent+ (char-code #\P))
+(defconstant +single-float+ (char-code #\F))
+(defconstant +double-float+ (char-code #\D))
+(defconstant +base-char+ (char-code #\c))
+(defconstant +pathname+ (char-code #\p))
+(defconstant +positive-bignum+ (char-code #\B))
+(defconstant +negative-bignum+ (char-code #\b))
+(defconstant +rational+ (char-code #\r))
+(defconstant +cons+ (char-code #\C))
+(defconstant +hash-table+ (char-code #\H))
+(defconstant +object+ (char-code #\O))
+(defconstant +array+ (char-code #\A))
+
+(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)))
+ (setq *lisp-obj-id* 0)
+ (clrhash *circularity-hash*)
+ (labels
+ ((%serialize (frob)
+ (declare (optimize (speed 3) (safety 0)))
+ (etypecase frob
+ (fixnum
+ (buffer-write-byte +fixnum+ bs)
+ (buffer-write-int frob bs))
+ (symbol
+ (let ((s (symbol-name frob)))
+ (declare (type string s) (dynamic-extent s))
+ (buffer-write-byte +symbol+ bs)
+ (buffer-write-int (byte-length s) bs)
+ (buffer-write-string s bs)))
+ (string
+ (buffer-write-byte +string+ bs)
+ (buffer-write-int (byte-length frob) bs)
+ (buffer-write-string frob bs))
+ (null
+ (buffer-write-byte +nil+ bs))
+ (persistent
+ (buffer-write-byte +persistent+ bs)
+ (buffer-write-int (oid frob) bs)
+ (%serialize (type-of frob)))
+ #-(and :lispworks (or :win32 :linux))
+ (single-float
+ (buffer-write-byte +single-float+ bs)
+ (buffer-write-float frob bs))
+ (double-float
+ (buffer-write-byte +double-float+ bs)
+ (buffer-write-double frob bs))
+ (character
+ (buffer-write-byte +base-char+ bs)
+ ;; might be wide!
+ (buffer-write-int (char-code frob) bs))
+ (pathname
+ (let ((s (namestring frob)))
+ (declare (type string s) (dynamic-extent s))
+ (buffer-write-byte +pathname+ bs)
+ (buffer-write-int (byte-length s) bs)
+ (buffer-write-string s bs)))
+ (integer
+ (let* ((num (abs frob))
+ (word-size (ceiling (/ (integer-length num) 32)))
+ (needed (* word-size 4)))
+ (declare (type fixnum word-size needed))
+ (if (< frob 0)
+ (buffer-write-byte +negative-bignum+ bs)
+ (buffer-write-byte +positive-bignum+ bs))
+ (buffer-write-int needed bs)
+ (loop for i fixnum from 0 below word-size
+ ;; shouldn't this be "below"?
+ for byte-spec = (int-byte-spec i)
+ ;; this ldb is consing!
+ ;; there is an OpenMCL function which should work
+ ;; and non-cons
+ for the-uint of-type (unsigned-byte 32) = (ldb byte-spec num)
+ do
+ (buffer-write-uint the-uint bs))))
+ (rational
+ (buffer-write-byte +rational+ bs)
+ (%serialize (numerator frob))
+ (%serialize (denominator frob)))
+ (cons
+ (buffer-write-byte +cons+ bs)
+ (let ((idp (gethash frob *circularity-hash*)))
+ (if idp (buffer-write-int idp bs)
+ (progn
+ (buffer-write-int (incf *lisp-obj-id*) bs)
+ (setf (gethash frob *circularity-hash*) *lisp-obj-id*)
+ (%serialize (car frob))
+ (%serialize (cdr frob))))))
+ (hash-table
+ (buffer-write-byte +hash-table+ bs)
+ (let ((idp (gethash frob *circularity-hash*)))
+ (if idp (buffer-write-int idp bs)
+ (progn
+ (buffer-write-int (incf *lisp-obj-id*) bs)
+ (setf (gethash frob *circularity-hash*) *lisp-obj-id*)
+ (%serialize (hash-table-test frob))
+ (%serialize (hash-table-rehash-size frob))
+ (%serialize (hash-table-rehash-threshold frob))
+ (%serialize (hash-table-count frob))
+ (loop for key being the hash-key of frob
+ using (hash-value value)
+ do
+ (%serialize key)
+ (%serialize value))))))
+ (standard-object
+ (buffer-write-byte +object+ bs)
+ (let ((idp (gethash frob *circularity-hash*)))
+ (if idp (buffer-write-int idp bs)
+ (progn
+ (buffer-write-int (incf *lisp-obj-id*) bs)
+ (setf (gethash frob *circularity-hash*) *lisp-obj-id*)
+ (%serialize (type-of frob))
+ (let ((svs (slots-and-values frob)))
+ (declare (dynamic-extent svs))
+ (%serialize (/ (length svs) 2))
+ (loop for item in svs
+ do (%serialize item)))))))
+ (array
+ (buffer-write-byte +array+ bs)
+ (let ((idp (gethash frob *circularity-hash*)))
+ (if idp (buffer-write-int idp bs)
+ (progn
+ (buffer-write-int (incf *lisp-obj-id*) bs)
+ (setf (gethash frob *circularity-hash*) *lisp-obj-id*)
+ (buffer-write-byte
+ (logior (byte-from-array-type (array-element-type frob))
+ (if (array-has-fill-pointer-p frob)
+ +fill-pointer-p+ 0)
+ (if (adjustable-array-p frob)
+ +adjustable-p+ 0))
+ bs)
+ (let ((rank (array-rank frob)))
+ (buffer-write-int rank bs)
+ (loop for i fixnum from 0 below rank
+ do (buffer-write-int (array-dimension frob i)
+ bs)))
+ (loop for i fixnum from 0 below (array-total-size frob)
+ do
+ (%serialize (row-major-aref frob i)))))))
+ )))
+ (%serialize frob)
+ (finish-buffer bs)))
+
+(defun slots-and-values (o)
+ (loop for sd in (compute-slots (class-of o))
+ for slot-name = (slot-definition-name sd)
+ with ret = ()
+ do
+ (when (slot-boundp o slot-name)
+ (push (slot-value o slot-name) ret)
+ (push slot-name ret))
+ finally (return ret)))
+
+(defun deserialize (buf)
(declare (optimize (speed 3) (safety 0))
- (type fixnum position))
- #+(or cmu scl sbcl allegro)
- (progn (setf (cdr *resourced-byte-spec*) (* 32 position))
- *resourced-byte-spec*)
- #-(or cmu scl sbcl allegro)
- (byte 32 (* 32 position))
- )
+ (type array-or-pointer-char buf))
+ (setf (buffer-stream-buffer *in-buf*) buf)
+ (setf (buffer-stream-position *in-buf*) 0)
+ (setq *lisp-obj-id* 0)
+ (clrhash *circularity-hash*)
+ (labels
+ ((%deserialize (bs)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs))
+ (let ((tag (buffer-read-byte bs)))
+ (declare (type foreign-char tag))
+ (cond
+ ((= tag +fixnum+)
+ (buffer-read-fixnum bs))
+ ((= tag +symbol+)
+ (intern (or (buffer-read-string bs (buffer-read-fixnum bs)) "")))
+ ((= tag +string+)
+ (buffer-read-string bs (buffer-read-fixnum bs)))
+ ((= tag +nil+) nil)
+ ((= tag +persistent+)
+ (get-cached-instance *store-controller*
+ (buffer-read-fixnum bs)
+ (%deserialize bs)))
+ ((= tag +single-float+)
+ (buffer-read-float bs))
+ ((= tag +double-float+)
+ (buffer-read-double bs))
+ ((= tag +base-char+)
+ (code-char (buffer-read-byte bs)))
+ ((= tag +pathname+)
+ (parse-namestring
+ (or (buffer-read-string bs (buffer-read-fixnum bs)) "")))
+ ((= tag +positive-bignum+)
+ (deserialize-bignum bs (buffer-read-fixnum bs) t))
+ ((= tag +negative-bignum+)
+ (deserialize-bignum bs (buffer-read-fixnum bs) nil))
+ ((= tag +rational+)
+ (/ (the integer (%deserialize bs))
+ (the integer (%deserialize bs))))
+ ((= tag +cons+)
+ (let* ((id (buffer-read-fixnum bs))
+ (maybe-cons (gethash id *circularity-hash*)))
+ (if maybe-cons maybe-cons
+ (let ((c (cons nil nil)))
+ (setf (gethash id *circularity-hash*) c)
+ (setf (car c) (%deserialize bs))
+ (setf (cdr c) (%deserialize bs))
+ c))))
+ ((= tag +hash-table+)
+ (let* ((id (buffer-read-fixnum bs))
+ (maybe-hash (gethash id *circularity-hash*)))
+ (if maybe-hash maybe-hash
+ (let ((h (make-hash-table :test (%deserialize bs)
+ :rehash-size (%deserialize bs)
+ :rehash-threshold
+ (%deserialize bs))))
+ (loop for i fixnum from 0 below (%deserialize bs)
+ do
+ (setf (gethash (%deserialize bs) h)
+ (%deserialize bs)))
+ h))))
+ ((= tag +object+)
+ (let* ((id (buffer-read-fixnum bs))
+ (maybe-o (gethash id *circularity-hash*)))
+ (if maybe-o maybe-o
+ (let ((o (make-instance (%deserialize bs))))
+ (loop for i fixnum from 0 below (%deserialize bs)
+ do
+ (setf (slot-value o (%deserialize bs))
+ (%deserialize bs)))
+ o))))
+ ((= tag +array+)
+ (let* ((id (buffer-read-fixnum bs))
+ (maybe-array (gethash id *circularity-hash*)))
+ (if maybe-array maybe-array
+ (let* ((flags (buffer-read-byte bs))
+ (a (make-array
+ (loop for i fixnum from 0 below
+ (buffer-read-int bs)
+ collect (buffer-read-int bs))
+ :element-type (array-type-from-byte
+ (logand #x3f flags))
+ :fill-pointer (/= 0 (logand +fill-pointer-p+
+ flags))
+ :adjustable (/= 0 (logand +adjustable-p+
+ flags)))))
+ (loop for i fixnum from 0 below (array-total-size a)
+ do
+ (setf (row-major-aref a i) (%deserialize bs)))
+ a))))
+ (t (error "deserialize fubar!"))))))
+ (%deserialize *in-buf*)))
+(defun deserialize-bignum (bs length positive)
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs)
+ (type fixnum length)
+ (type boolean positive))
+ (loop for i from 0 upto (/ length 4)
+ for byte-spec = (int-byte-spec i)
+ with num integer = 0
+ do
+ (setq num (dpb (buffer-read-uint bs) byte-spec num))
+ finally (return (if positive num (- num)))))
-(defvar *write-buffer* (allocate-foreign-object :char 2))
-(defvar *write-buffer-rest*
- (make-pointer (+ (pointer-address *write-buffer*) 1) :char))
-(defvar *write-buffer-length* 0)
-(defun resize-write-buffer (length)
+
+;; 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))
- (if (< length *write-buffer-length*)
- (values *write-buffer* *write-buffer-length*)
- (let ((newlen (max length (* *write-buffer-length* 2))))
+ (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))
- (setq *write-buffer-length* newlen)
- (free-foreign-object *write-buffer*)
- (setq *write-buffer* (allocate-foreign-object :char newlen))
- (setq *write-buffer-rest*
- (make-pointer (+ (pointer-address *write-buffer*) 1) :char))
- (values *write-buffer* *write-buffer-length*))))
-
-(defvar *read-buffer* (allocate-foreign-object :char 2))
-(defvar *read-buffer-rest*
- (make-pointer (+ (pointer-address *read-buffer*) 1) :char))
-(defvar *read-buffer-length* 0)
+ (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 resize-read-buffer (buf length)
+(defun finish-buffer (bs)
(declare (optimize (speed 3) (safety 0))
- (ignore buf)
- (type fixnum length))
- (if (< length *read-buffer-length*)
- (values *read-buffer* *read-buffer-length*)
- (let ((newlen (max length (* *read-buffer-length* 2))))
- (declare (type fixnum newlen))
- (setq *read-buffer-length* newlen)
- (free-foreign-object *read-buffer*)
- (setq *read-buffer* (allocate-foreign-object :char newlen))
- (setq *read-buffer-rest*
- (make-pointer (+ (pointer-address *read-buffer*) 1) :char))
- (values *read-buffer* *read-buffer-length*))))
-
-(defun copy-buf (str buf len &key (src-offset 0) (buf-offset 0))
- (declare (optimize (speed 3) (safety 0))
- (type string str)
- (type array-char buf)
- (type fixnum len src-offset buf-offset)
- (dynamic-extent str buf len))
- (typecase str
- (simple-string
- (loop for i fixnum from 0 below len
- do
- (setf (deref-array buf '(:array :char) (+ i buf-offset))
- (char-code (schar str (+ i src-offset))))))
- (string
- (loop for i fixnum from 0 below len
- do
- (setf (deref-array buf '(:array :char) (+ i buf-offset))
- (char-code (char str (+ i src-offset))))))))
+ (type buffer-stream bs))
+ (with-struct-slots ((buf buffer-stream-buffer)
+ (pos buffer-stream-position))
+ bs
+ (let ((length pos))
+ (setf pos 0)
+ length)))
-(def-type foreign-char :char)
+(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))))
-(defmacro write-tag (tag)
- `(setf (deref-pointer *write-buffer* :char) ,tag))
+(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)))
-(defgeneric serialize (frob))
+(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)))
-(defmethod serialize ((frob integer))
- (declare (optimize (speed 3) (safety 0)))
- (if (typep frob 'fixnum)
- (progn
- (write-tag +fixnum+)
- (with-cast-pointer (p *write-buffer-rest* :int)
- (setf (deref-pointer p :int) frob))
- (values *write-buffer* 5))
- (let* ((num (abs frob))
- (word-size (ceiling (/ (integer-length num) 32)))
- (needed (+ (* word-size 4) 1)))
- (declare (type fixnum word-size needed))
- (when (> needed *write-buffer-length*)
- (resize-write-buffer needed))
- (if (> frob 0) (write-tag +positive-bignum+)
- (write-tag +negative-bignum+))
- (with-cast-pointer
- (p *write-buffer-rest* :unsigned-int)
- (loop for i fixnum from 0 to word-size
- for byte-spec = (int-byte-spec i)
- ;; this ldb is consing!
- for the-byte of-type (unsigned-byte 32) = (ldb byte-spec num)
- do
- (setf (deref-array p '(:array :unsigned-int) i) the-byte)
- finally
- (return (values *write-buffer* needed)))))))
+(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)))
-(defmethod serialize ((frob float))
- (declare (optimize (speed 3) (safety 0)))
- (write-tag +long-float+)
- (with-cast-pointer
- (p *write-buffer-rest* :double)
- (setf (deref-pointer p :double) (coerce frob 'long-float)))
- (values *write-buffer* 9))
-
-(defmethod serialize ((frob null))
- (declare (optimize (speed 3) (safety 0)))
- (write-tag +nil+)
- (values *write-buffer* 1))
+(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)))
-(defmethod serialize ((frob character))
- (declare (optimize (speed 3) (safety 0)))
- (write-tag +base-char+)
- (setf (deref-array *write-buffer* '(:array :char) 1) (char-code frob))
- (values *write-buffer* 2))
+(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)))
-(defmethod serialize ((frob symbol))
- (declare (optimize (speed 3) (safety 0)))
- (let* ((s (symbol-name frob))
- (slen (length s))
- (needed (+ slen 1)))
- (declare (type fixnum slen needed)
- (dynamic-extent s))
- (when (> needed *write-buffer-length*) (resize-write-buffer needed))
- (write-tag +symbol+)
- (copy-buf s *write-buffer-rest* slen)
- (values *write-buffer* needed)))
+(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)))
-(defmethod serialize ((frob string))
- (declare (optimize (speed 3) (safety 0)))
- (let* ((slen (length frob))
- (needed (+ slen 1)))
- (declare (type fixnum slen needed))
- (when (> needed *write-buffer-length*) (resize-write-buffer needed))
- (write-tag +string+)
- (copy-buf frob *write-buffer-rest* slen)
- (values *write-buffer* needed)))
+(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))))
-(defmethod serialize ((frob pathname))
- (declare (optimize (speed 3) (safety 0)))
- (let ((s (namestring frob)))
- (declare (type string s) (dynamic-extent s))
- (let* ((slen (length s))
- (needed (+ slen 1)))
- (declare (type fixnum slen needed))
- (when (> needed *write-buffer-length*) (resize-write-buffer needed))
- (write-tag +pathname+)
- (copy-buf s *write-buffer-rest* slen)
- (values *write-buffer* needed))))
-
-;(defmethod serialize ((frob persistent))
-; (declare (optimize (speed 3) (safety 0)))
-; (let ((s (%class-name frob)))
-; (declare (type string s))
-; (let* ((slen (length s))
-; (needed (+ slen 2)))
-; (declare (type fixnum slen needed))
-; (write-tag +persistent-object+)
-; (copy-buf (
-; (concatenate 'string "O" (prin1-to-string (oid frob))
-; ":" (%class-name frob)))
+(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 deserialize (buf buf-rest length)
- (declare (optimize (speed 3) (safety 0))
- (type array-char buf buf-rest)
- (fixnum length))
- (let ((tag (deref-pointer buf :char)))
- (declare (type foreign-char tag))
- (cond
- ((= tag +string+)
- (convert-from-foreign-string buf-rest :length (- length 1)
- :null-terminated-p nil))
- ((= tag +fixnum+)
- (with-cast-pointer (p buf-rest :int)
- (deref-pointer p :int)))
- ((= tag +nil+) nil)
- ((= tag +long-float+)
- (with-cast-pointer
- (p buf-rest :double)
- (deref-pointer p :double)))
- ((= tag +positive-bignum+) (deserialize-bignum buf-rest length t))
- ((= tag +negative-bignum+) (deserialize-bignum buf-rest length nil))
- ((= tag +symbol+)
- (intern
- (convert-from-foreign-string buf-rest :length (- length 1)
- :null-terminated-p nil)))
- ((= tag +base-char+)
- (code-char (deref-array buf '(:array :char) 1)))
- ((= tag +pathname+)
- (parse-namestring
- (convert-from-foreign-string buf-rest :length (- length 1)
- :null-terminated-p nil)))
- (t (error "deserialize fubar!")))))
+(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 deserialize-bignum (buf-rest length positive)
+(defun buffer-read-string (bs length)
(declare (optimize (speed 3) (safety 0))
- (type array-char buf-rest)
- (type fixnum length)
- (type boolean positive))
- (with-cast-pointer (p buf-rest :unsigned-int)
- (loop for i from 0 upto (/ (- length 1) 4)
- for byte-spec = (int-byte-spec i)
- with num integer = 0
- do
- (setq num (dpb (deref-array p '(:array :unsigned-int) i)
- byte-spec num))
- finally (return (if positive num (- num))))))
\ No newline at end of file
+ (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))
+(defvar array-type-to-byte (make-hash-table :test 'equalp))
+(defvar byte-to-array-type (make-hash-table :test 'equalp))
+
+(setf (gethash 'T array-type-to-byte) #x00)
+(setf (gethash 'bit array-type-to-byte) #x01)
+(setf (gethash '(unsigned-byte 2) array-type-to-byte) #x02)
+(setf (gethash '(unsigned-byte 4) array-type-to-byte) #x03)
+(setf (gethash '(unsigned-byte 8) array-type-to-byte) #x04)
+(setf (gethash '(unsigned-byte 16) array-type-to-byte) #x05)
+(setf (gethash '(unsigned-byte 32) array-type-to-byte) #x06)
+(setf (gethash '(unsigned-byte 64) array-type-to-byte) #x07)
+(setf (gethash '(signed-byte 8) array-type-to-byte) #x08)
+(setf (gethash '(signed-byte 16) array-type-to-byte) #x09)
+(setf (gethash '(signed-byte 32) array-type-to-byte) #x0A)
+(setf (gethash '(signed-byte 64) array-type-to-byte) #x0B)
+(setf (gethash 'character array-type-to-byte) #x0C)
+(setf (gethash 'single-float array-type-to-byte) #x0D)
+(setf (gethash 'double-float array-type-to-byte) #x0E)
+(setf (gethash '(complex single-float) array-type-to-byte) #x0F)
+(setf (gethash '(complex double-float) array-type-to-byte) #x10)
+
+(loop for key being the hash-key of array-type-to-byte
+ using (hash-value value)
+ do
+ (setf (gethash value byte-to-array-type) key))
+
+(defun array-type-from-byte (b)
+ (gethash b byte-to-array-type))
+
+(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))
+ (type (unsigned-byte 24) position))
+ #+(or cmu scl sbcl allegro)
+ (progn (setf (cdr *resourced-byte-spec*) (* 32 position))
+ *resourced-byte-spec*)
+ #-(or cmu scl sbcl allegro)
+ (byte 32 (* 32 position))
+ )
1
0

27 Aug '04
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv23659/src
Modified Files:
libsleepycat.c
Log Message:
beginning of lock and cursor support
Date: Thu Aug 26 19:54:43 2004
Author: blee
Index: elephant/src/libsleepycat.c
diff -u elephant/src/libsleepycat.c:1.1.1.1 elephant/src/libsleepycat.c:1.2
--- elephant/src/libsleepycat.c:1.1.1.1 Thu Aug 19 10:05:15 2004
+++ elephant/src/libsleepycat.c Thu Aug 26 19:54:43 2004
@@ -1,6 +1,22 @@
/* Pointer arithmetic utility functions */
+int read_int(char *buf, int offset) {
+ return *(int*)(buf + offset);
+}
+
+unsigned int read_uint(char *buf, int offset) {
+ return *(unsigned int*)(buf + offset);
+}
+
+float read_float(char *buf, int offset) {
+ return *(float*)(buf + offset);
+}
+
+double read_double(char *buf, int offset) {
+ return *(double*)(buf + offset);
+}
+
void write_int(char *buf, int num, int offset) {
*(int*)(buf + offset) = num;
}
@@ -9,20 +25,16 @@
*(unsigned int*)(buf + offset) = num;
}
-void write_double(char *buf, double num, int offset) {
- *(double*)(buf + offset) = num;
+void write_float(char *buf, float num, int offset) {
+ *(float*)(buf + offset) = num;
}
-int read_int(char *buf, int offset) {
- return *(int*)(buf + offset);
-}
-
-unsigned int read_uint(char *buf, int offset) {
- return *(unsigned int*)(buf + offset);
+void write_double(char *buf, double num, int offset) {
+ *(double*)(buf + offset) = num;
}
-double read_double(char *buf, int offset) {
- return *(double*)(buf + offset);
+char *offset_charp(char *p, int offset) {
+ return p + offset;
}
#include <string.h>
@@ -76,6 +88,13 @@
return env->remove(env, home, flags);
}
+int db_env_set_flags(DB_ENV *dbenv, u_int32_t flags, int onoff) {
+ return dbenv->set_flags(dbenv, flags, onoff);
+}
+
+int db_env_get_flags(DB_ENV *dbenv, u_int32_t *flagsp) {
+ return dbenv->get_flags(dbenv, flagsp);
+}
/* Database */
@@ -111,9 +130,16 @@
return db->truncate(db, txnid, countp, flags);
}
+int db_set_pagesize(DB *db, u_int32_t pagesize) {
+ return db->set_pagesize(db, pagesize);
+}
+
+int db_get_pagesize(DB *db, u_int32_t *pagesizep) {
+ return db->get_pagesize(db, pagesizep);
+}
/* Accessors */
-/* Should also make versions which support bulk retrieval */
+/* We manage our own buffers (DB_DBT_USERMEM). */
int db_get_raw(DB *db, DB_TXN *txnid,
char *key, u_int32_t key_length,
@@ -128,7 +154,6 @@
DBTKey.size = key_length;
DBTDatum.data = buffer;
DBTDatum.ulen = buffer_length;
- /* Need this for threaded applications */
DBTDatum.flags |= DB_DBT_USERMEM;
ret = db->get(db, txnid, &DBTKey, &DBTDatum, flags);
@@ -165,10 +190,113 @@
}
+/* Cursors */
+
+DBC * db_cursor(DB *db, DB_TXN *txnid, u_int32_t flags, int *errno) {
+ DBC *cursor;
+ *errno = db->cursor(db, txnid, &cursor, flags);
+ return cursor;
+}
+
+int db_cursor_close(DBC *cursor) {
+ return cursor->c_close(cursor);
+}
+
+int db_cursor_del(DBC *cursor, u_int32_t flags) {
+ return cursor->c_del(cursor, flags);
+}
+
+DBC * db_cursor_dup(DBC *cursor, u_int32_t flags, int *errno) {
+ DBC *dup;
+ *errno = cursor->c_dup(cursor, &dup, flags);
+ return dup;
+}
+
+int db_cursor_get_raw(DBC *cursor,
+ char *keybuf, u_int32_t keybuf_length,
+ char *buffer, u_int32_t buffer_length,
+ u_int32_t flags, u_int32_t *key_length,
+ u_int32_t *result_length) {
+ DBT DBTKey, DBTDatum;
+ int ret;
+
+ memset(&DBTKey, 0, sizeof(DBT));
+ memset(&DBTDatum, 0, sizeof(DBT));
+ DBTKey.data = keybuf;
+ DBTKey.ulen = keybuf_length;
+ DBTKey.flags |= DB_DBT_USERMEM;
+ DBTDatum.data = buffer;
+ DBTDatum.ulen = buffer_length;
+ DBTDatum.flags |= DB_DBT_USERMEM;
+
+ ret = cursor->c_get(cursor, &DBTKey, &DBTDatum, flags);
+ *key_length = DBTKey.size;
+ *result_length = DBTDatum.size;
+
+ return ret;
+}
+
+int db_cursor_put_raw(DBC *cursor,
+ char *key, u_int32_t key_length,
+ char *datum, u_int32_t datum_length,
+ u_int32_t flags) {
+ DBT DBTKey, DBTDatum;
+
+ memset(&DBTKey, 0, sizeof(DBT));
+ memset(&DBTDatum, 0, sizeof(DBT));
+ DBTKey.data = key;
+ DBTKey.size = key_length;
+ DBTDatum.data = datum;
+ DBTDatum.size = datum_length;
+
+ return cursor->c_put(cursor, &DBTKey, &DBTDatum, flags);
+}
+
+
+/* Bulk retrieval */
+
+int db_cursor_get_multiple_key(DBC *cursor,
+ char *keybuf, u_int32_t keybuf_length,
+ char *buffer, u_int32_t buffer_length,
+ u_int32_t flags, u_int32_t *key_length,
+ u_int32_t *result_length,
+ void **pointer, DBT **data) {
+ DBT DBTKey, DBTDatum;
+ int ret;
+
+ memset(&DBTKey, 0, sizeof(DBT));
+ memset(&DBTDatum, 0, sizeof(DBT));
+ DBTKey.data = keybuf;
+ DBTKey.ulen = keybuf_length;
+ DBTKey.flags |= DB_DBT_USERMEM;
+ DBTDatum.data = buffer;
+ DBTDatum.ulen = buffer_length;
+ DBTDatum.flags |= DB_DBT_USERMEM;
+
+ flags |= DB_MULTIPLE_KEY;
+ ret = cursor->c_get(cursor, &DBTKey, &DBTDatum, flags);
+ *key_length = DBTKey.size;
+ *result_length = DBTDatum.size;
+ if ((DBTKey.size <= DBTKey.ulen) && (DBTDatum.size <= DBTDatum.ulen)) {
+ **data = DBTDatum;
+ DB_MULTIPLE_INIT(*pointer, *data);
+ }
+
+ return ret;
+}
+
+void db_multiple_key_next(void *pointer, DBT *data,
+ char **key, u_int32_t *key_length,
+ char **result, u_int32_t *result_length) {
+ DB_MULTIPLE_KEY_NEXT(pointer, data,
+ *key, *key_length,
+ *result, *result_length);
+}
+
/* Transactions */
-DB_TXN * db_env_txn_begin(DB_ENV *env, DB_TXN *parent,
- u_int32_t flags, int *errno) {
+DB_TXN * db_txn_begin(DB_ENV *env, DB_TXN *parent,
+ u_int32_t flags, int *errno) {
DB_TXN * p;
*errno = env->txn_begin(env, parent, &p, flags);
return p;
@@ -182,14 +310,45 @@
return txnid->commit(txnid, flags);
}
-/*
-int db_env_lock_detect(DB_ENV *env, u_int32_t flags, u_int32_t atype,
- int *aborted) {
- return env->lock_detect(env, flags, atype, aborted);
+
+int db_txnp_begin(DB_ENV *env, DB_TXN *parent, DB_TXN **txnp,
+ u_int32_t flags) {
+ return env->txn_begin(env, parent, txnp, flags);
+}
+
+/* Locks and timeouts */
+
+u_int32_t db_txn_id(DB_TXN *tid) {
+ return tid->id(tid);
+}
+
+int db_env_lock_id(DB_ENV *env, u_int32_t *idp) {
+ return env->lock_id(env, idp);
+}
+
+int db_env_lock_id_free(DB_ENV *env, u_int32_t id) {
+ return env->lock_id_free(env, id);
+}
+
+/* db_timeout_t = u_int32_t */
+int db_env_set_timeout(DB_ENV *env, db_timeout_t timeout, u_int32_t flags) {
+ return env->set_timeout(env, timeout, flags);
+}
+
+int db_env_get_timeout(DB_ENV *env, db_timeout_t *timeoutp, u_int32_t flags) {
+ return env->get_timeout(env, timeoutp, flags);
}
int db_env_set_lk_detect(DB_ENV *env, u_int32_t detect) {
return env->set_lk_detect(env, detect);
}
-*/
+int db_env_get_lk_detect(DB_ENV *env, u_int32_t *detectp) {
+ return env->get_lk_detect(env, detectp);
+}
+
+int db_env_lock_detect(DB_ENV *env, u_int32_t flags, u_int32_t atype,
+ int *aborted) {
+ return env->lock_detect(env, flags, atype, aborted);
+}
+
1
0

27 Aug '04
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv23640/src
Modified Files:
sleepycat.lisp
Log Message:
beginning of lock and cursor support
Date: Thu Aug 26 19:54:39 2004
Author: blee
Index: elephant/src/sleepycat.lisp
diff -u elephant/src/sleepycat.lisp:1.1.1.1 elephant/src/sleepycat.lisp:1.2
--- elephant/src/sleepycat.lisp:1.1.1.1 Thu Aug 19 10:05:14 2004
+++ elephant/src/sleepycat.lisp Thu Aug 26 19:54:38 2004
@@ -12,44 +12,83 @@
(defpackage sleepycat
(:use common-lisp uffi)
- (:export write-int write-unsigned-int write-double
- read-int read-unsigned-int read-double copy-str-to-buf
- *current-transaction*
+ (:export read-int read-uint read-float read-double
+ write-int write-uint write-float write-double
+ offset-char-pointer copy-str-to-buf copy-bufs byte-length
pointer-int pointer-void array-or-pointer-char
db-env-create db-env-close db-env-open db-env-dbremove
- db-env-dbrename db-env-remove db-create db-close db-open
+ db-env-dbrename db-env-remove db-env-set-flags
+ db-env-get-flags
+ db-create db-close db-open
db-remove db-rename db-sync db-truncate
db-get-key-buffered db-get-buffered db-get db-put-buffered db-put
db-delete-buffered db-delete
+ *current-transaction*
db-transaction-begin db-transaction-abort db-transaction-commit
with-transaction with-transaction-retry
- db-error
- DBTYPE#BTREE DBTYPE#HASH DBTYPE#QUEUE DBTYPE#RECNO
- DBTYPE#UNKNOWN +NULL-VOID+ +NULL-CHAR+))
+ db-transaction-id db-env-lock-id db-env-lock-id-free
+ db-env-set-timeout db-env-get-timeout
+ db-env-set-lock-detect db-env-get-lock-detect
+ DB-BTREE DB-HASH DB-QUEUE DB-RECNO DB-UNKNOWN
+ +NULL-VOID+ +NULL-CHAR+
+ db-error db-error-errno
+ DB_KEYEMPTY DB_LOCK_DEADLOCK DB_LOCK_NOTGRANTED DB_NOTFOUND
+ ))
(in-package "SLEEPYCAT")
(eval-when (:compile-toplevel :load-toplevel)
(def-type pointer-int (* :int))
(def-type pointer-void :pointer-void)
- (def-foreign-type array-or-pointer-char
+ (def-foreign-type array-or-pointer-char
#+allegro (:array :char)
- #-allegro (* :char))
+ #+(or cmu sbcl scl) (* :char))
(def-type array-or-pointer-char array-or-pointer-char)
+ (def-enum DBTYPE ((:BTREE 1) :HASH :QUEUE :RECNO :UNKNOWN))
)
-(declaim (inline write-int write-unsigned-int write-double
- read-int read-unsigned-int read-double copy-buf
- %db-get-raw db-get-key-buffered db-get-buffered db-get
- %db-put-raw db-put-buffered db-put
+(declaim (inline read-int read-uint read-float read-double
+ write-int write-uint write-float write-double
+ offset-char-pointer copy-str-to-buf copy-bufs
+ %db-get-key-buffered db-get-key-buffered
+ %db-get-buffered db-get-buffered db-get
+ %db-put-buffered db-put-buffered
+ %db-put db-put
%db-delete db-delete-buffered db-delete
- %db-env-txn-begin db-transaction-begin
- %db-env-txn-begin2 db-transaction-begin2
+ %db-txn-begin db-transaction-begin
%db-txn-abort db-transaction-abort
%db-txn-commit db-transaction-commit
flags))
-;; Pointer arithmetic utility functions
+;; Buffer management / pointer arithmetic
+
+;; Notes: on CMUCL and Allegro: with-cast-pointer +
+;; deref-array is faster than FFI + C pointer arithmetic.
+;; however pointer arithmetic is usually consing. OpenMCL
+;; supports non-consing pointer arithmentic though.
+
+
+;; TODO: #+openmcl versions which do macptr arith.
+
+(def-function ("read_int" read-int)
+ ((buf array-or-pointer-char)
+ (offset :int))
+ :returning :int)
+
+(def-function ("read_uint" read-uint)
+ ((buf array-or-pointer-char)
+ (offset :int))
+ :returning :unsigned-int)
+
+(def-function ("read_float" read-float)
+ ((buf array-or-pointer-char)
+ (offset :int))
+ :returning :float)
+
+(def-function ("read_double" read-double)
+ ((buf array-or-pointer-char)
+ (offset :int))
+ :returning :double)
(def-function ("write_int" write-int)
((buf array-or-pointer-char)
@@ -57,33 +96,50 @@
(offset :int))
:returning :void)
-(def-function ("write_uint" write-unsigned-int)
+(def-function ("write_uint" write-uint)
((buf array-or-pointer-char)
(num :unsigned-int)
(offset :int))
:returning :void)
-(def-function ("write_double" write-double)
+(def-function ("write_float" write-float)
((buf array-or-pointer-char)
- (num :double)
+ (num :float)
(offset :int))
:returning :void)
-(def-function ("read_int" read-int)
+(def-function ("write_double" write-double)
((buf array-or-pointer-char)
+ (num :double)
(offset :int))
- :returning :int)
+ :returning :void)
-(def-function ("read_uint" read-uint)
- ((buf array-or-pointer-char)
+(def-function ("offset_charp" offset-char-pointer)
+ ((p array-or-pointer-char)
(offset :int))
- :returning :unsigned-int)
+ :returning array-or-pointer-char)
-(def-function ("read_double" read-double)
- ((buf array-or-pointer-char)
- (offset :int))
- :returning :double)
+;; Allegro and Lispworks use 16-bit unicode characters
+(defmacro byte-length (s)
+ #+(or lispworks (and allegro ics))
+ `(let ((l (length ,s))) (+ l l))
+ #-(or lispworks (and allegro ics))
+ `(length ,s))
+
+;; for copying the bytes of a string to a foreign buffer
+;; memcpy is faster than looping! For Lispworks this causes
+;; a string to array conversion, but I don't know how to do
+;; any better (fli:replace-foreign-array is promising?)
+#-(or cmu sbcl scl openmcl)
+(def-function ("copy_buf" copy-str-to-buf)
+ ((dest array-or-pointer-char)
+ (dest-offset :int)
+ (src array-or-pointer-char)
+ (src-offset :int)
+ (length :int))
+ :returning :void)
+#+(or cmu sbcl scl)
(def-function ("copy_buf" copy-str-to-buf)
((dest array-or-pointer-char)
(dest-offset :int)
@@ -92,6 +148,48 @@
(length :int))
:returning :void)
+;; but OpenMCL can't directly pass string bytes.
+#+openmcl
+(defun copy-str-to-buf (dest dest-offset src src-offset length)
+ (declare (optimize (speed 3) (safety 0))
+ (type string src)
+ (type array-or-pointer-char dest)
+ (type fixnum length src-offset dest-offset)
+ (dynamic-extent src dest length))
+ (multiple-value-bind (ivector disp)
+ (ccl::array-data-and-offset src)
+ (ccl::%copy-ivector-to-ptr src (+ disp src-offset)
+ dest dest-offset length)))
+
+;; Lisp version, for kicks. this assumes 8-bit chars!
+#+(not (or cmu sbcl scl allegro openmcl lispworks))
+(defun copy-str-to-buf (dest dest-offset src src-offset length)
+ (declare (optimize (speed 3) (safety 0))
+ (type string src)
+ (type array-or-pointer-char dest)
+ (type fixnum length src-offset dest-offset)
+ (dynamic-extent src dest length))
+ (typecase src
+ (simple-string
+ (loop for i fixnum from 0 below length
+ do
+ (setf (deref-array dest 'array-or-pointer-char (+ i dest-offset))
+ (char-code (schar src (+ i src-offset))))))
+ (string
+ (loop for i fixnum from 0 below length
+ do
+ (setf (deref-array dest 'array-or-pointer-char (+ i dest-offset))
+ (char-code (char src (+ i src-offset))))))))
+
+;; For copying two foreign buffers
+(def-function ("copy_buf" copy-bufs)
+ ((dest array-or-pointer-char)
+ (dest-offset :int)
+ (src array-or-pointer-char)
+ (src-offset :int)
+ (length :int))
+ :returning :void)
+
;; Thread local storage (special variables)
(defconstant +NULL-VOID+ (make-null-pointer :void))
@@ -101,16 +199,14 @@
(defvar *errno-buffer* (allocate-foreign-object :int 1))
-(declaim (type array-or-pointer-char *get-buffer* *key-buffer*)
- (type fixnum *get-buffer-length* *key-buffer-length*))
+(declaim (type array-or-pointer-char *get-buffer*)
+ (type fixnum *get-buffer-length*))
-(defvar *get-buffer*)
-(setq *get-buffer* (allocate-foreign-object :char 1))
+(defvar *get-buffer* (allocate-foreign-object :char 1))
(defvar *get-buffer-length* 0)
-(defun resize-get-buffer (buf length)
+(defun resize-get-buffer (length)
(declare (optimize (speed 3) (safety 0) (space 0))
- (ignore buf)
(type fixnum length))
(if (< length *get-buffer-length*)
(values *get-buffer* *get-buffer-length*)
@@ -121,32 +217,6 @@
(setq *get-buffer* (allocate-foreign-object :char newlen))
(values *get-buffer* *get-buffer-length*))))
-(defvar *key-buffer*)
-(setq *key-buffer* (allocate-foreign-object :char 1))
-(defvar *key-buffer-length* 0)
-
-(defun resize-key-buffer (buf length)
- (declare (optimize (speed 3) (safety 0) (space 0))
- (ignore buf)
- (type fixnum length))
- (if (< length *key-buffer-length*)
- (values *key-buffer* *key-buffer-length*)
- (let ((newlen (max length (* *key-buffer-length* 2))))
- (declare (type fixnum newlen))
- (setq *key-buffer-length* newlen)
- (free-foreign-object *key-buffer*)
- (setq *key-buffer* (allocate-foreign-object :char newlen))
- (values *key-buffer* *key-buffer-length*))))
-
-(defun fill-key-buffer (key &key (key-length (length key)))
- (declare (optimize (speed 3) (safety 0) (space 0))
- (type string key)
- (type fixnum key-length)
- (dynamic-extent key-length))
- (when (< *key-buffer-length* key-length) (resize-key-buffer nil key-length))
- (with-cstring (k key)
- (copy-str-to-buf *key-buffer* 0 k 0 key-length)))
-
;; Wrapper macro -- handles errno return values
;; makes flags into keywords
;; makes keyword args, cstring wrappers
@@ -245,10 +315,10 @@
:returning :int)
(wrap-errno db-env-open (dbenvp home flags mode)
- :flags (db-joinenv db-init-cdb db-init-lock db-init-log
- db-init-mpool db-init-rep db-init-txn
- db-recover db-recover-fatal db-create
- db-lockdown db-private db-system-mem db-thread)
+ :flags (joinenv init-cdb init-lock init-log
+ init-mpool init-rep init-txn
+ recover recover-fatal create
+ lockdown private system-mem thread)
:keys ((mode #o640))
:cstrings (home))
@@ -287,9 +357,26 @@
(flags :unsigned-int))
:returning :int)
-(wrap-errno db-env-remove (env home flags) :flags (db-force)
+(wrap-errno db-env-remove (env home flags) :flags (force)
:cstrings (home))
+(def-function ("db_env_set_flags" %db-env-set-flags)
+ ((env :pointer-void)
+ (flags :unsigned-int)
+ (onoff :int))
+ :returning :int)
+
+(wrap-errno db-env-set-flags (env flags onoff)
+ :flags (auto-commit nommap txn-nosync))
+
+(def-function ("db_env_get_flags" %db-env-get-flags)
+ ((env :pointer-void)
+ (flags :unsigned-int :out))
+ :returning :int)
+
+(wrap-errno db-env-get-flags (env) :outs 2)
+
+
;; Database
(def-function ("db_cr" %db-create)
@@ -313,8 +400,6 @@
(wrap-errno db-close (db flags))
-(def-enum DBTYPE ((:BTREE 1) :HASH :QUEUE :RECNO :UNKNOWN))
-
(def-function ("db_open" %db-open)
((db :pointer-void)
(txn :pointer-void)
@@ -326,12 +411,12 @@
:returning :int)
(wrap-errno db-open (db transaction file database type flags mode)
- :flags (auto-commit db-create db-dirty-read db-excl db-nommap
- db-rdonly db-thread db-truncate)
+ :flags (auto-commit create dirty-read excl nommap
+ rdonly thread truncate)
:keys ((transaction *current-transaction*)
(file +NULL-CHAR+)
(database +NULL-CHAR+)
- (type DBTYPE#UNKNOWN)
+ (type DB-UNKNOWN)
(mode #o640))
:cstrings (file database))
@@ -388,36 +473,30 @@
(result-length :unsigned-int :out))
:returning :int)
-(defun db-get-key-buffered (db &key
- (key-buffer *key-buffer*)
- (key-length *key-buffer-length*)
- (buffer *get-buffer*)
- (buffer-length *get-buffer-length*)
- (resize-function #'resize-get-buffer)
- (transaction *current-transaction*)
- auto-commit db-get-both db-dirty-read)
+(defun db-get-key-buffered (db key-buffer key-length &key
+ (transaction *current-transaction*)
+ auto-commit get-both dirty-read)
(declare (optimize (speed 3) (safety 0) (space 0))
(type pointer-void db transaction)
- (type array-or-pointer-char key-buffer buffer)
- (type fixnum key-length buffer-length)
- (type boolean auto-commit db-get-both db-dirty-read))
+ (type array-or-pointer-char key-buffer)
+ (type fixnum key-length)
+ (type boolean auto-commit get-both dirty-read))
(loop
do
(multiple-value-bind (errno result-length)
(%db-get-key-buffered db transaction key-buffer key-length
- buffer buffer-length
+ *get-buffer* *get-buffer-length*
(flags :auto-commit auto-commit
- :db-get-both db-get-both
- :db-dirty-read db-dirty-read))
+ :get-both get-both
+ :dirty-read dirty-read))
(declare (type fixnum result-length errno))
- (if (<= result-length buffer-length)
+ (if (<= result-length *get-buffer-length*)
(if (= errno 0)
(return-from db-get-key-buffered
(the (values array-or-pointer-char fixnum)
- (values buffer result-length)))
+ (values *get-buffer* result-length)))
(error 'db-error :errno errno))
- (multiple-value-setq (buffer buffer-length)
- (funcall resize-function buffer result-length))))))
+ (resize-get-buffer result-length)))))
(def-function ("db_get_raw" %db-get-buffered)
((db :pointer-void)
@@ -432,66 +511,57 @@
(defun db-get-buffered (db key &key
(key-length (length key))
- (buffer *get-buffer*)
- (buffer-length *get-buffer-length*)
- (resize-function #'resize-get-buffer)
(transaction *current-transaction*)
- auto-commit db-get-both db-dirty-read)
+ auto-commit get-both dirty-read)
(declare (optimize (speed 3) (safety 0) (space 0))
(type pointer-void db transaction)
(type string key)
- (type array-or-pointer-char buffer)
- (type fixnum key-length buffer-length)
- (type boolean auto-commit db-get-both db-dirty-read))
+ (type fixnum key-length)
+ (type boolean auto-commit get-both dirty-read))
(with-cstring (k key)
(loop
do
(multiple-value-bind (errno result-length)
(%db-get-buffered db transaction k key-length
- buffer buffer-length
+ *get-buffer* *get-buffer-length*
(flags :auto-commit auto-commit
- :db-get-both db-get-both
- :db-dirty-read db-dirty-read))
+ :get-both get-both
+ :dirty-read dirty-read))
(declare (type fixnum result-length errno))
- (if (<= result-length buffer-length)
+ (if (<= result-length *get-buffer-length*)
(if (= errno 0)
(return-from db-get-buffered
(the (values array-or-pointer-char fixnum)
- (values buffer result-length)))
+ (values *get-buffer* result-length)))
(error 'db-error :errno errno))
- (multiple-value-setq (buffer buffer-length)
- (funcall resize-function buffer result-length)))))))
+ (resize-get-buffer result-length))))))
(defun db-get (db key &key (key-length (length key))
- (buffer *get-buffer*)
- (buffer-length *get-buffer-length*)
- (resize-function #'resize-get-buffer)
(transaction *current-transaction*)
- auto-commit db-get-both db-dirty-read)
+ auto-commit get-both dirty-read)
(declare (optimize (speed 3) (safety 0) (space 0))
(type pointer-void db transaction)
(type string key)
- (type array-or-pointer-char buffer)
- (type fixnum key-length buffer-length)
- (type boolean auto-commit db-get-both db-dirty-read))
+ (type fixnum key-length)
+ (type boolean auto-commit get-both dirty-read))
(with-cstring (k key)
(loop
do
(multiple-value-bind (errno result-length)
(%db-get-buffered db transaction k key-length
- buffer buffer-length
+ *get-buffer* *get-buffer-length*
(flags :auto-commit auto-commit
- :db-get-both db-get-both
- :db-dirty-read db-dirty-read))
+ :get-both get-both
+ :dirty-read dirty-read))
(declare (type fixnum result-length errno))
- (if (<= result-length buffer-length)
+ (if (<= result-length *get-buffer-length*)
(if (= errno 0)
(return-from db-get
- (convert-from-foreign-string buffer :length result-length
+ (convert-from-foreign-string *get-buffer*
+ :length result-length
:null-terminated-p nil))
(error 'db-error :errno errno))
- (multiple-value-setq (buffer buffer-length)
- (funcall resize-function buffer result-length)))))))
+ (resize-get-buffer result-length))))))
(def-function ("db_put_raw" %db-put-buffered)
((db :pointer-void)
@@ -573,7 +643,7 @@
;; Transactions
-(def-function ("db_env_txn_begin" %db-env-txn-begin)
+(def-function ("db_txn_begin" %db-txn-begin)
((env :pointer-void)
(parent :pointer-void)
(flags :unsigned-int)
@@ -581,20 +651,20 @@
:returning :pointer-void)
(defun db-transaction-begin (env &key (parent *current-transaction*)
- db-dirty-read db-txn-nosync db-txn-nowait
- db-txn-sync)
+ dirty-read txn-nosync txn-nowait
+ txn-sync)
(declare (optimize (speed 3) (safety 0) (space 0))
(type pointer-void env parent)
- (type boolean db-dirty-read db-txn-nosync db-txn-nowait
- db-txn-sync)
+ (type boolean dirty-read txn-nosync txn-nowait
+ txn-sync)
(type pointer-int *errno-buffer*))
(let* ((txn
- (%db-env-txn-begin env parent
- (flags :db-dirty-read db-dirty-read
- :db-txn-nosync db-txn-nosync
- :db-txn-nowait db-txn-nowait
- :db-txn-sync db-txn-sync)
- *errno-buffer*))
+ (%db-txn-begin env parent
+ (flags :dirty-read dirty-read
+ :txn-nosync txn-nosync
+ :txn-nowait txn-nowait
+ :txn-sync txn-sync)
+ *errno-buffer*))
(errno (deref-array *errno-buffer* '(:array :int) 0)))
(declare (type pointer-void txn)
(type fixnum errno))
@@ -618,51 +688,71 @@
(wrap-errno (db-transaction-commit %db-txn-commit) (transaction flags)
:keys ((transaction *current-transaction*))
- :flags (db-txn-nosync db-txn-sync)
+ :flags (txn-nosync txn-sync)
:declarations (declare (optimize (speed 3) (safety 0) (space 0))
(type pointer-void transaction)
- (type boolean db-txn-nosync db-txn-sync)))
+ (type boolean txn-nosync txn-sync)))
(defmacro with-transaction ((&key transaction environment
(globally t)
(parent *current-transaction*)
- db-dirty-read db-txn-nosync
- db-txn-nowait db-txn-sync)
+ dirty-read txn-nosync
+ txn-nowait txn-sync)
&body body)
- (let ((last-transaction (gensym))
- (txn (if transaction transaction (gensym)))
+ (let ((txn (if transaction transaction (gensym)))
(success (gensym)))
- `(let (,@(if globally `(,last-transaction *current-transaction*)
- (values))
- (,txn (db-transaction-begin ,environment
- :parent ,parent
- :db-dirty-read ,db-dirty-read
- :db-txn-nosync ,db-txn-nosync
- :db-txn-nowait ,db-txn-nowait
- :db-txn-sync ,db-txn-sync))
- (,success nil))
+ `(let* ((,txn (db-transaction-begin ,environment
+ :parent ,parent
+ :dirty-read ,dirty-read
+ :txn-nosync ,txn-nosync
+ :txn-nowait ,txn-nowait
+ :txn-sync ,txn-sync))
+ (,success nil)
+ ,@(if globally `((*current-transaction* ,txn))
+ (values)))
+ (declare (dynamic-extent ,txn ,success)
+ (type pointer-void ,txn)
+ (type boolean ,success))
(unwind-protect
- (progn
- ,@(if globally `((setq *current-transaction* ,txn))
- (values))
- (prog1
- (progn ,@body)
- (setq ,success t)
- (db-transaction-commit :transaction ,txn
- :db-txn-nosync ,db-txn-nosync
- :db-txn-sync ,db-txn-sync)))
- (progn
- ,@(if globally
- `((setq *current-transaction* ,last-transaction))
- (values))
- (unless ,success (db-transaction-abort :transaction ,txn)))))))
+ (prog1
+ (progn ,@body)
+ (setq ,success t)
+ (db-transaction-commit :transaction ,txn
+ :txn-nosync ,txn-nosync
+ :txn-sync ,txn-sync))
+ (unless ,success (db-transaction-abort :transaction ,txn))))))
+
+;; this is code for a non-consing with-transaction. which
+;; doesn't work in the (globally t) case (e.g. setting
+;; *current-transaction*.)
+
+; #+cmu
+; `(alien:with-alien ((,txn (* t)
+; (%db-txn-begin
+; ,environment ,parent
+; (flags :dirty-read ,dirty-read
+; :txn-nosync ,txn-nosync
+; :txn-nowait ,txn-nowait
+; :txn-sync ,txn-sync)
+; *errno-buffer*)))
+; (let ((,success nil)
+; ,@(if globally `((*current-transaction* ,txn)) (values)))
+; (declare (type pointer-void *current-transaction*)
+; (dynamic-extent *current-transaction*))
+; (unwind-protect
+; (prog1 (progn ,@body)
+; (setq ,success t)
+; (%db-txn-commit ,txn
+; (flags :txn-nosync ,txn-nosync
+; :txn-sync ,txn-sync)))
+; (unless ,success (%db-txn-abort ,txn)))))))
(defmacro with-transaction-retry ((&key transaction environment
(globally t)
(parent *current-transaction*)
(retries 100)
- db-dirty-read db-txn-nosync
- db-txn-nowait db-txn-sync)
+ dirty-read txn-nosync
+ txn-nowait txn-sync)
&body body)
(let ((ret-tag (gensym))
(retry-count (gensym)))
@@ -673,17 +763,112 @@
:environment ,environment
:globally ,globally
:parent ,parent
- :db-dirty-read ,db-dirty-read
- :db-txn-nosync ,db-txn-nosync
- :db-txn-nowait ,db-txn-nowait
- :db-txn-sync ,db-txn-sync)
+ :dirty-read ,dirty-read
+ :txn-nosync ,txn-nosync
+ :txn-nowait ,txn-nowait
+ :txn-sync ,txn-sync)
,body)
(db-error (err)
(if (< (incf ,retry-count) ,retries)
(go ,ret-tag)
(error err))))))))
+;; Locks and timeouts
+
+(def-enum lockop ((:DUMP 0) :GET :GET-TIMEOUT :INHERIT
+ :PUT :PUT-ALL :PUT-OBJ :PUT-READ
+ :TIMEOUT :TRADE :UPGRADE-WRITE))
+
+(def-enum lockmode ((:NG 0) :READ :WRITE :WAIT
+ :IWRITE :IREAD :IWR :DIRTY :WWRITE))
+
+(def-struct db-lockreq
+ (op lockop)
+ (mode lockmode)
+ (timeout :unsigned-int)
+ (obj (:array :char))
+ (lock :pointer-void))
+
+
+(def-function ("db_txn_id" db-transaction-id)
+ ((transaction :pointer-void))
+ :returning :unsigned-int)
+
+
+(def-function ("db_env_lock_id" %db-env-lock-id)
+ ((env :pointer-void)
+ (id :unsigned-int :out))
+ :returning :int)
+
+(wrap-errno db-env-lock-id (env) :outs 2)
+
+
+(def-function ("db_env_lock_id_free" %db-env-lock-id-free)
+ ((env :pointer-void)
+ (id :unsigned-int))
+ :returning :int)
+
+(wrap-errno db-env-lock-id-free (env id))
+
+(def-function ("db_env_set_timeout" %db-env-set-timeout)
+ ((env :pointer-void)
+ (timeout :unsigned-int)
+ (flags :unsigned-int))
+ :returning :int)
+
+(wrap-errno db-env-set-timeout (env timeout flags)
+ :flags (set-lock-timeout set-transaction-timeout))
+
+(def-function ("db_env_get_timeout" %db-env-get-timeout)
+ ((env :pointer-void)
+ (timeout :unsigned-int :out)
+ (flags :unsigned-int))
+ :returning :int)
+
+(wrap-errno db-env-get-timeout (env flags) :outs 2
+ :flags (set-lock-timeout set-transaction-timeout))
+
+(defconstant DB_LOCK_DEFAULT 1)
+(defconstant DB_LOCK_EXPIRE 2)
+(defconstant DB_LOCK_MAXLOCKS 3)
+(defconstant DB_LOCK_MINLOCKS 4)
+(defconstant DB_LOCK_MINWRITE 5)
+(defconstant DB_LOCK_OLDEST 6)
+(defconstant DB_LOCK_RANDOM 7)
+(defconstant DB_LOCK_YOUNGEST 8)
+
+(def-function ("db_env_set_lk_detect" %db-env-set-lock-detect)
+ ((env :pointer-void)
+ (detect :unsigned-int))
+ :returning :int)
+
+(wrap-errno db-env-set-lock-detect (env detect))
+
+(def-function ("db_env_get_lk_detect" %db-env-get-lock-detect)
+ ((env :pointer-void)
+ (detect :unsigned-int :out))
+ :returning :int)
+
+(wrap-errno db-env-get-lock-detect (env) :outs 2)
+
+(def-function ("db_env_lock_detect" %db-env-lock-detect)
+ ((env :pointer-void)
+ (flags :unsigned-int)
+ (atype :unsigned-int)
+ (aborted :int :out))
+ :returning :int)
+
+(wrap-errno db-env-lock-detect (env flags atype) :outs 2)
+
;; Constants and Flags
+;; eventually write a macro which generates a custom flag function.
+
+;I don't like the UFFI syntax for enumerations
+(defconstant DB-BTREE 1)
+(defconstant DB-HASH 2)
+(defconstant DB-QUEUE 3)
+(defconstant DB-RECNO 4)
+(defconstant DB-UNKNOWN 5)
(defconstant DB_AUTO_COMMIT #x1000000)
(defconstant DB_JOINENV #x0040000)
@@ -700,7 +885,6 @@
(defconstant DB_SYSTEM_MEM #x0400000)
(defconstant DB_THREAD #x0000040)
(defconstant DB_FORCE #x0000004)
-(defconstant DB_GET_BOTH 10)
(defconstant DB_DIRTY_READ #x2000000)
(defconstant DB_CREATE #x0000001)
(defconstant DB_EXCL #x0001000)
@@ -711,69 +895,84 @@
(defconstant DB_TXN_NOWAIT #x0001000)
(defconstant DB_TXN_SYNC #x0002000)
+(defconstant DB_GET_BOTH 10)
+(defconstant DB_SET_LOCK_TIMEOUT 29)
+(defconstant DB_SET_TXN_TIMEOUT 33)
+
(defun flags (&key
auto-commit
- db-joinenv
- db-init-cdb
- db-init-lock
- db-init-log
- db-init-mpool
- db-init-rep
- db-init-txn
- db-recover
- db-recover-fatal
- db-lockdown
- db-private
- db-system-mem
- db-thread
- db-force
- db-get-both
- db-dirty-read
- db-create
- db-excl
- db-nommap
- db-rdonly
- db-truncate
- db-txn-nosync
- db-txn-nowait
- db-txn-sync)
+ joinenv
+ init-cdb
+ init-lock
+ init-log
+ init-mpool
+ init-rep
+ init-txn
+ recover
+ recover-fatal
+ lockdown
+ private
+ system-mem
+ thread
+ force
+ get-both
+ dirty-read
+ create
+ excl
+ nommap
+ rdonly
+ truncate
+ txn-nosync
+ txn-nowait
+ txn-sync
+ set-lock-timeout
+ set-transaction-timeout)
(let ((flags 0))
(declare (optimize (speed 3) (safety 0) (space 0))
(type (unsigned-byte 32) flags)
- (type boolean auto-commit db-joinenv db-init-cdb db-init-lock
- db-init-log db-init-mpool db-init-rep db-init-txn
- db-recover db-recover-fatal db-lockdown db-private
- db-system-mem db-thread db-force db-get-both
- db-dirty-read db-create db-excl db-nommap db-rdonly
- db-truncate db-txn-nosync db-txn-nowait))
+ (type boolean auto-commit joinenv init-cdb init-lock
+ init-log init-mpool init-rep init-txn
+ recover recover-fatal lockdown private
+ system-mem thread force get-both
+ dirty-read create excl nommap rdonly
+ truncate txn-nosync txn-nowait
+ set-lock-timeout set-transaction-timeout))
(when auto-commit (setq flags (logior flags DB_AUTO_COMMIT)))
- (when db-joinenv (setq flags (logior flags DB_JOINENV)))
- (when db-init-cdb (setq flags (logior flags DB_INIT_CDB)))
- (when db-init-lock (setq flags (logior flags DB_INIT_LOCK)))
- (when db-init-log (setq flags (logior flags DB_INIT_LOG)))
- (when db-init-mpool (setq flags (logior flags DB_INIT_MPOOL)))
- (when db-init-rep (setq flags (logior flags DB_INIT_REP)))
- (when db-init-txn (setq flags (logior flags DB_INIT_TXN)))
- (when db-recover (setq flags (logior flags DB_RECOVER)))
- (when db-recover-fatal (setq flags (logior flags DB_RECOVER_FATAL)))
- (when db-lockdown (setq flags (logior flags DB_LOCKDOWN)))
- (when db-private (setq flags (logior flags DB_PRIVATE)))
- (when db-system-mem (setq flags (logior flags DB_SYSTEM_MEM)))
- (when db-thread (setq flags (logior flags DB_THREAD)))
- (when db-force (setq flags (logior flags DB_FORCE)))
- (when db-get-both (setq flags (logior flags DB_GET_BOTH)))
- (when db-dirty-read (setq flags (logior flags DB_DIRTY_READ)))
- (when db-create (setq flags (logior flags DB_CREATE)))
- (when db-excl (setq flags (logior flags DB_EXCL)))
- (when db-nommap (setq flags (logior flags DB_NOMMAP)))
- (when db-rdonly (setq flags (logior flags DB_RDONLY)))
- (when db-truncate (setq flags (logior flags DB_TRUNCATE)))
- (when db-txn-nosync (setq flags (logior flags DB_TXN_NOSYNC)))
- (when db-txn-nowait (setq flags (logior flags DB_TXN_NOWAIT)))
- (when db-txn-sync (setq flags (logior flags DB_TXN_SYNC)))
+ (when joinenv (setq flags (logior flags DB_JOINENV)))
+ (when init-cdb (setq flags (logior flags DB_INIT_CDB)))
+ (when init-lock (setq flags (logior flags DB_INIT_LOCK)))
+ (when init-log (setq flags (logior flags DB_INIT_LOG)))
+ (when init-mpool (setq flags (logior flags DB_INIT_MPOOL)))
+ (when init-rep (setq flags (logior flags DB_INIT_REP)))
+ (when init-txn (setq flags (logior flags DB_INIT_TXN)))
+ (when recover (setq flags (logior flags DB_RECOVER)))
+ (when recover-fatal (setq flags (logior flags DB_RECOVER_FATAL)))
+ (when lockdown (setq flags (logior flags DB_LOCKDOWN)))
+ (when private (setq flags (logior flags DB_PRIVATE)))
+ (when system-mem (setq flags (logior flags DB_SYSTEM_MEM)))
+ (when thread (setq flags (logior flags DB_THREAD)))
+ (when force (setq flags (logior flags DB_FORCE)))
+ (when get-both (setq flags (logior flags DB_GET_BOTH)))
+ (when dirty-read (setq flags (logior flags DB_DIRTY_READ)))
+ (when create (setq flags (logior flags DB_CREATE)))
+ (when excl (setq flags (logior flags DB_EXCL)))
+ (when nommap (setq flags (logior flags DB_NOMMAP)))
+ (when rdonly (setq flags (logior flags DB_RDONLY)))
+ (when truncate (setq flags (logior flags DB_TRUNCATE)))
+ (when txn-nosync (setq flags (logior flags DB_TXN_NOSYNC)))
+ (when txn-nowait (setq flags (logior flags DB_TXN_NOWAIT)))
+ (when txn-sync (setq flags (logior flags DB_TXN_SYNC)))
+ (when set-lock-timeout (setq flags (logior flags DB_SET_LOCK_TIMEOUT)))
+ (when set-transaction-timeout (setq flags (logior flags DB_SET_TXN_TIMEOUT)))
flags))
;; Errors
+
+(defconstant DB_KEYEMPTY -30997)
+(defconstant DB_LOCK_DEADLOCK -30995)
+(defconstant DB_LOCK_NOTGRANTED -30994)
+(defconstant DB_NOTFOUND -30990)
+
(def-function ("db_strerr" %db-strerror)
((error :int))
:returning :cstring)
@@ -788,11 +987,3 @@
(declare (type db-error condition) (type stream stream))
(format stream "Berkeley DB error: ~A"
(db-strerror (db-error-errno condition))))))
-
-(define-condition buffer-too-small-error (error)
- ((length-needed :initarg :length :reader length-needed))
- (:report
- (lambda (condition stream)
- (declare (type buffer-too-small-error condition) (type stream stream))
- (format stream "buffer-too-small-error: needed ~D bytes!"
- (length-needed condition)))))
\ No newline at end of file
1
0
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv23599/src
Modified Files:
classes.lisp
Log Message:
new MOP stuff
Date: Thu Aug 26 19:53:52 2004
Author: blee
Index: elephant/src/classes.lisp
diff -u elephant/src/classes.lisp:1.1.1.1 elephant/src/classes.lisp:1.2
--- elephant/src/classes.lisp:1.1.1.1 Thu Aug 19 10:05:14 2004
+++ elephant/src/classes.lisp Thu Aug 26 19:53:52 2004
@@ -1,35 +1,26 @@
+;; TODO: slot-bound-p (check the database)
+
(in-package "ELEPHANT")
(defclass persistent ()
((%oid :accessor oid
- :initarg :from-oid)
- (%oid-string :accessor oid-string)
- (%store-controller :allocation :class
- :accessor get-store-controller
- :initform *store-controller*
- :initarg :store-controller)
- (%class-name :type string :accessor %class-name
- :allocation :class)
- (%persistent-slots))
+ :initarg :from-oid))
(:documentation
"Abstract superclass for all persistent classes (common
-to user-defined classes and collections.)" ))
+to user-defined classes and collections.)"))
(defmethod initialize-instance :before ((instance persistent)
&rest initargs
&key from-oid)
(declare (ignore initargs))
- "Sets the OID, OID-STRING and registers with the store controller."
- (let ((sc (get-store-controller instance)))
- (setf (%class-name instance) (string (class-name (class-of instance))))
- (if (not from-oid)
- (setf (oid instance) (next-oid sc))
+ "Sets the OID."
+ (if (not from-oid)
+ (setf (oid instance) (next-oid *store-controller*))
(setf (oid instance) from-oid))
- (setf (oid-string instance)
- (prin1-to-string (oid instance)))
- (register-instance sc instance)))
+ (cache-instance *store-controller* instance))
-(defclass persistent-class (persistent) ()
+(defclass persistent-object (persistent)
+ ((%persistent-slots))
(:documentation "Superclass of all user-defined persistent
classes"))
@@ -46,7 +37,7 @@
())
(defmethod pcl::slot-definition-allocation ((slot-definition persistent-slot-definition))
- :class)
+ :instance)
(defmethod (setf pcl::slot-definition-allocation) (value (slot-definition persistent-slot-definition))
(declare (ignore value))
@@ -55,10 +46,9 @@
(defmethod pcl::initialize-internal-slot-functions ((slot persistent-slot-definition))
nil)
-(defmethod pcl::direct-slot-definition-class ((class persistent-metaclass) initargs)
+(defmethod pcl::direct-slot-definition-class ((class persistent-metaclass) &rest initargs)
(let ((allocation-key (getf initargs :allocation)))
- (cond ((or (eq allocation-key :transient)
- (eq allocation-key :class))
+ (cond ((eq allocation-key :class)
(call-next-method))
(t
(find-class 'persistent-direct-slot-definition)))))
@@ -66,12 +56,68 @@
(defmethod pcl:validate-superclass ((class elephant::persistent-metaclass) (super pcl::standard-class))
t)
-(defmethod pcl::effective-slot-definition-class ((class persistent-metaclass) initargs)
- (let ((allocation (getf initargs :allocation)))
- (if (eq allocation :persistent)
- (find-class 'persistent-effective-slot-definition)
- (call-next-method))))
+(defmethod persistent-p ((class t))
+ nil)
+
+(defmethod persistent-p ((class persistent-metaclass))
+ t)
+
+(defmethod pcl::effective-slot-definition-class ((class persistent-metaclass) &rest initargs)
+ (let ((allocation-key (getf initargs :allocation))
+ (allocation-class (getf initargs :allocation-class)))
+ (cond ((eq allocation-key :class)
+ (call-next-method))
+ ((not (persistent-p allocation-class))
+ (call-next-method))
+ (t
+ (find-class 'persistent-effective-slot-definition)))))
+(defmacro make-persistent-reader (name)
+ `(lambda (instance)
+ (declare (type persistent instance))
+ (buffer-write-int (oid instance) *key-buf*)
+ (let ((key-length (serialize ,name *key-buf*)))
+ (handler-case
+ (deserialize (db-get-key-buffered (db *store-controller*)
+ (buffer-stream-buffer *key-buf*)
+ key-length))
+ (db-error (err)
+ (if (= (db-error-errno err) DB_NOTFOUND)
+ (error 'unbound-slot :instance instance :slot ,name)
+ (error err)))))))
+
+(defmacro make-persistent-writer (name)
+ `(lambda (new-value instance)
+ (declare (type persistent instance))
+ (buffer-write-int (oid instance) *key-buf*)
+ (let ((key-length (serialize ,name *key-buf*))
+ (val-length (serialize new-value *out-buf*)))
+ (db-put-buffered (db *store-controller*)
+ (buffer-stream-buffer *key-buf*) key-length
+ (buffer-stream-buffer *out-buf*) val-length
+ :transaction *current-transaction*
+ :auto-commit *auto-commit*))))
+
+#|
+(defmethod pcl::compute-slots :around ((class persistent-metaclass))
+ (call-next-method))
+|#
+
+(defmethod handle-optimized-accessors ((slot-def t))
+ slot-def)
+
+(defmethod handle-optimized-accessors ((slot-def persistent-slot-definition))
+ (let ((name (pcl::slot-definition-name slot-def)))
+ (setf (pcl::slot-definition-reader-function slot-def)
+ (make-persistent-reader name))
+ (setf (pcl::slot-definition-writer-function slot-def)
+ (make-persistent-writer name)))
+ slot-def)
+
+(defmethod pcl::compute-effective-slot-definition ((class persistent-metaclass) name direct-slot-definitions)
+ (let ((object (call-next-method)))
+ (handle-optimized-accessors object)))
+
(defun persistent-slot-names (class)
(let ((slot-definitions (pcl::class-slots class)))
(loop for slot-definition in slot-definitions
@@ -82,63 +128,16 @@
(let* ((persistent-metaclass (find-class 'persistent-metaclass))
(not-already-persistent (loop for superclass in direct-superclasses
never (eq (class-of superclass) persistent-metaclass))))
- (prog1
- (if not-already-persistent
- (apply #'call-next-method class :direct-superclasses (cons (find-class 'persistent-class) direct-superclasses) args)
- (call-next-method))
- (register-class-slots *store-controller* (class-name class) (persistent-slot-names class)))))
+ (if not-already-persistent
+ (apply #'call-next-method class :direct-superclasses (cons (find-class 'persistent-object) direct-superclasses) args)
+ (call-next-method))))
-(defmethod pcl::slot-value-using-class :around (class (instance persistent-class) (slot-def persistent-slot-definition))
+(defmethod pcl::slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition))
(let ((slot-name (pcl::slot-definition-name slot-def)))
- (let ((db-slot-name (call-next-method)))
- (if db-slot-name
- (deserialize (db-get db-slot-name
- (oid-string instance))
- *store-controller*)
- nil))))
+ (format *standard-output* "Deserializing ~A ~%" slot-name)))
-(defmethod (setf pcl::slot-value-using-class) :around (new-value class (instance persistent-class) (slot-def persistent-slot-definition))
+(defmethod (setf pcl::slot-value-using-class) :around (new-value class (instance persistent-object) (slot-def persistent-slot-definition))
(let ((slot-name (pcl::slot-definition-name slot-def)))
- (let ((db-slot-name (slot-value-using-class class instance slot-def)))
- (if db-slot-name
- (%db-put db-slot-name
- (oid-string instance) (serialize new-value)
- :transaction *transaction*)
- (call-next-method)))))
-
-;;; Need a delete class method! here's a first cut.
-;;; however this method begs the question as to what the
-;;; right transaction API is! (this can't be right!)
+ (format *standard-output* "Serializing ~A into ~A ~%" new-value slot-name)))
-#|
-(defmethod delete ((obj persistent-class) &key transaction parent)
- "Remove object from the database. Transaction protected."
- (if transaction
- (use-transaction (transaction)
- (loop for slot in (%persistent-slots obj)
- with slot-name = (if (listp slot) (first slot)
- slot)
- do (%db-remove (db-slot slot-name obj) (oid-string obj))))
- (with-transaction (parent :environment ???)
- delete-stuff)))
-
-(defun db-slot (slotname obj)
- (funcall (symbol-function (db-slot-from-slot slotname)) obj))
-
-|#
-;;; These need to be fixed, macro-fied?
-;;; meant to check for a transaction, do auto-commit otherwise
-;;; this is necessary for transaction protected DB handles
-
-(defun %db-put (db key value &rest args &key (transaction *transaction*)
- &allow-other-keys)
- (if transaction
- (apply #'db-put db key value :transaction transaction args)
- (apply #'db-put db key value :auto-commit t args)))
-
-(defun %db-remove (db key &rest args &key (transaction *transaction*)
- &allow-other-keys)
- (if transaction
- (apply #'db-delete db key :transaction transaction args)
- (apply #'db-delete db key :auto-commit t args)))
\ No newline at end of file
1
0
Update of /project/elephant/cvsroot//elephant
In directory common-lisp.net:/home/blee/test
Log Message:
Start
Status:
Vendor Tag: elephant
Release Tags: start
N elephant/src/classes.lisp
N elephant/src/collections.lisp
N elephant/src/controller.lisp
N elephant/src/elephant.lisp
N elephant/src/serializer.lisp
N elephant/src/sleepycat.lisp
N elephant/src/libsleepycat.c
No conflicts created by this import
Date: Thu Aug 19 10:05:15 2004
Author: blee
New module elephant added
1
0
Update of /project/elephant/cvsroot//src
In directory common-lisp.net:/home/blee/elephant/src
Log Message:
Start
Status:
Vendor Tag: elephant
Release Tags: start
N src/classes.lisp
N src/collections.lisp
N src/controller.lisp
N src/elephant.lisp
N src/serializer.lisp
N src/sleepycat.lisp
N src/libsleepycat.c
No conflicts created by this import
Date: Thu Aug 19 10:01:22 2004
Author: blee
New module src added
1
0