August 2004 - elephant-cvs@common-lisp.net

[elephant-cvs] CVS update: elephant/src/serializer.lisp
by blee＠common-lisp.net 27 Aug '04

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

[elephant-cvs] CVS update: elephant/src/libsleepycat.c
by blee＠common-lisp.net 27 Aug '04

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

[elephant-cvs] CVS update: elephant/src/sleepycat.lisp
by blee＠common-lisp.net 27 Aug '04

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

[elephant-cvs] CVS update: elephant/src/classes.lisp
by blee＠common-lisp.net 27 Aug '04

27 Aug '04

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

[elephant-cvs] CVS update: Module imported: elephant
by blee＠common-lisp.net 19 Aug '04

19 Aug '04

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

[elephant-cvs] CVS update: Module imported: src
by blee＠common-lisp.net 19 Aug '04

19 Aug '04

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