From ieslick at common-lisp.net  Tue Jan 16 00:51:25 2007
From: ieslick at common-lisp.net (ieslick)
Date: Mon, 15 Jan 2007 19:51:25 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/elephant
Message-ID: <20070116005125.7F57C59084@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv4094

Added Files:
	cross-platform.lisp serializer1.lisp serializer2.lisp 
	unicode2.lisp 
Log Message:



--- /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp	2007/01/16 00:51:25	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp	2007/01/16 00:51:25	1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; cross-platform.lisp -- convert Lisp data to/from byte arrays
;;; 
;;; Initial version 8/26/2004 by Ben Lee
;;; <blee at common-lisp.net>
;;; 
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;

(in-package :elephant)

;; This is a quick portability hack to avoid external dependencies, if we get
;; to many of these do we need to import a standard library? do we need to import 'port' or some
;; other thread layer to the elephant dependency list?

(defmacro ele-without-interrupts (&body body)
  `(elephant-memutil::memutil-without-interrupts , at body))

(defun ele-make-lock ()
  #+allegro (mp::make-process-lock)
  #+cmu (mp:make-lock)
  #+sbcl (sb-thread:make-mutex)
  #+mcl (ccl:make-lock)
  #+lispworks (mp:make-lock)
  #-(or allegro sbcl cmu lispworks mcl) nil )

(defmacro ele-with-lock ((lock &rest ignored) &body body)
  (declare (ignore ignored)
	   (ignorable lock))
  #+allegro `(mp:with-process-lock (,lock) , at body)
  #+cmu `(mp:with-lock-held (,lock) , at body)
  #+sbcl `(sb-thread:with-mutex (,lock) , at body)
  #+lispworks `(mp:with-lock (,lock) , at body)
  #+mcl `(ccl:with-lock-grabbed (,lock) , at body)
  #-(or allegro sbcl cmu lispworks mcl) `(progn , at body) )

--- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp	2007/01/16 00:51:25	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp	2007/01/16 00:51:25	1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; serializer.lisp -- convert Lisp data to/from byte arrays
;;; 
;;; Initial version 8/26/2004 by Ben Lee
;;; <blee at common-lisp.net>
;;; 
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;

(in-package "ELEPHANT")

(defpackage :elephant-serializer1
  (:use :cl :elephant :elephant-memutil)
  (:import-from :elephant 
		*resourced-byte-spec*
		get-cached-instance
		slot-definition-allocation
		slot-definition-name
		compute-slots
		oid))

(in-package :elephant-serializer1)

(declaim (inline int-byte-spec
		 serialize deserialize
		 slots-and-values
		 deserialize-bignum))

(uffi:def-type foreign-char :char)

;; Constants

(defconstant +fixnum+                1)
(defconstant +char+                  2)
(defconstant +single-float+          3)
(defconstant +double-float+          4)
(defconstant +negative-bignum+       5)
(defconstant +positive-bignum+       6)
(defconstant +rational+              7)

(defconstant +nil+                   8)

;; 8-bit
(defconstant +ucs1-symbol+           9)
(defconstant +ucs1-string+          10)
(defconstant +ucs1-pathname+        11)

;; 16-bit
(defconstant +ucs2-symbol+          12)
(defconstant +ucs2-string+          13)
(defconstant +ucs2-pathname+        14)

;; 32-bit
(defconstant +ucs4-symbol+          20)
(defconstant +ucs4-string+          21)
(defconstant +ucs4-pathname+        22)

(defconstant +persistent+           15) ;; stored by id+classname
(defconstant +cons+                 16)
(defconstant +hash-table+           17)
(defconstant +object+               18)
(defconstant +array+                19)

(defconstant +fill-pointer-p+     #x40)
(defconstant +adjustable-p+       #x80)

(defvar *lisp-obj-id* 0 
  "Circularity ids for the serializer.")

(defvar *circularity-hash* (make-hash-table)
  "Circularity hash for the serializer.")

(defun clear-circularity-hash ()
  "This handles the case where we store an object with lots
   of object references.  CLRHASH then starts to dominate
   performance as it has to visit ever spot in the table so
   we're better off GCing the old table than clearing it"
  (declare (optimize (speed 3) (safety 0)))
  (if (> (hash-table-size *circularity-hash*) 100)
      (setf *circularity-hash* (make-hash-table :test 'eq :size 50))
      (clrhash *circularity-hash*)))

(defun serialize (frob bs sc)
  "Serialize a lisp value into a buffer-stream."
  (declare (optimize (speed 3) (safety 0))
	   (type buffer-stream bs))
  (setq *lisp-obj-id* 0)
  (clear-circularity-hash)
  (labels 
      ((%serialize (frob)
	 (declare (optimize (speed 3) (safety 0)))
	 (typecase frob
	   (fixnum
	    (buffer-write-byte +fixnum+ bs)
	    (buffer-write-int frob bs))
	   (null
	    (buffer-write-byte +nil+ bs))
	   (symbol
	    (let ((s (symbol-name frob)))
	      (declare (type string s) (dynamic-extent s))
	      (buffer-write-byte 
	       #+(and allegro ics)
	       (etypecase s
		 (base-string +ucs1-symbol+) ;; +ucs1-symbol+
		 (string +ucs2-symbol+))
	       #+(or (and sbcl sb-unicode) lispworks)
	       (etypecase s 
		 (base-string +ucs1-symbol+)
		 (string #+sbcl +ucs4-symbol+ #+lispworks +ucs2-symbol+))
	       #-(or lispworks (and allegro ics) (and sbcl sb-unicode))
	       +ucs1-symbol+
	       bs)
	      (buffer-write-int (byte-length s) bs)
	      (buffer-write-string s bs)
	      (let ((package (symbol-package frob)))
		(if package
		    (%serialize (package-name package))
		    (%serialize nil)))))
	   (string
	    (progn
	    (buffer-write-byte 
	     #+(and allegro ics)
	     (etypecase frob
	       (base-string +ucs1-string+)  ;; +ucs1-string+
	       (string +ucs2-string+))
	     #+(or (and sbcl sb-unicode) lispworks)
	     (etypecase frob
	       (base-string +ucs1-string+)
	       (string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+))
	     #-(or lispworks (and allegro ics) (and sbcl sb-unicode))
	     +ucs1-string+
	     bs)
	    (buffer-write-int (byte-length frob) bs)
	    (buffer-write-string frob bs)))
	   (persistent
	    (buffer-write-byte +persistent+ bs)
	    (buffer-write-int (oid frob) bs)
	    ;; This circumlocution is necessitated by 
	    ;; an apparent bug in SBCL 9.9 --- type-of sometimes
	    ;; does NOT return the "proper name" of the class as the
	    ;; CLHS says it should, but gives the class object itself,
	    ;; which cannot be directly serialized....
	    (let ((tp (type-of frob)))
	      #+(or sbcl)
	      (if (not (symbolp tp))
		  (setf tp (class-name (class-of frob))))
	      (%serialize tp))
	      )
	   #-(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 +char+ bs)
	    ;; might be wide!
	    (buffer-write-uint (char-code frob) bs))
	   (pathname
	    (let ((s (namestring frob)))
	      (declare (type string s) (dynamic-extent s))
	      (buffer-write-byte 
	       #+(and allegro ics) 
	       (etypecase s
		 (base-string +ucs1-pathname+) ;;  +ucs1-pathname+
		 (string +ucs2-pathname+))
	       #+(or (and sbcl sb-unicode) lispworks)
	       (etypecase s 
		 (base-string +ucs1-pathname+)
		 (string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+))
	       #-(or lispworks (and allegro ics) (and sbcl sb-unicode))
	       +ucs1-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 
		    ;; this ldb is consing on CMUCL!
		    ;; there is an OpenMCL function which should work 
		    ;; and non-cons
		    do
		    #+(or cmu sbcl)
		    (buffer-write-uint (%bignum-ref num i) bs)
		    #+(or allegro lispworks openmcl)
		    (buffer-write-uint (ldb (int-byte-spec i) num) 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)))
		    (when (array-has-fill-pointer-p frob)
		      (buffer-write-int (fill-pointer frob) bs))
		    (loop for i fixnum from 0 below (array-total-size frob)
			  do
			  (%serialize (row-major-aref frob i)))))))
	   )))
    (%serialize frob)
    bs))

(defun slots-and-values (o)
  (declare (optimize (speed 3) (safety 0)))
  (loop for sd in (compute-slots (class-of o))
	for slot-name = (slot-definition-name sd)
	with ret = ()
	do
	(when (and (slot-boundp o slot-name)
		   (eq :instance
		       (slot-definition-allocation sd)))
	  (push (slot-value o slot-name) ret)
	  (push slot-name ret))
	finally (return ret)))

(defun deserialize (buf-str sc)
  "Deserialize a lisp value from a buffer-stream."
  (declare (optimize (speed 3) (safety 0))
	   (type (or null buffer-stream) buf-str))
  (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 +nil+) nil)
	     ((= tag +ucs1-symbol+)
	      (let ((name (buffer-read-ucs1-string bs (buffer-read-fixnum bs)))
		    (maybe-package-name (%deserialize bs)))
		(if maybe-package-name
		    (intern name (find-package maybe-package-name))
		    (make-symbol name))))
	     #+(or lispworks (and allegro ics))
	     ((= tag +ucs2-symbol+)
	      (let ((name (buffer-read-ucs2-string bs (buffer-read-fixnum bs)))
		    (maybe-package-name (%deserialize bs)))
		(if maybe-package-name
		    (intern name (find-package maybe-package-name))
		    (make-symbol name))))
	     #+(and sbcl sb-unicode)
	     ((= tag +ucs4-symbol+)
	      (let ((name (buffer-read-ucs4-string bs (buffer-read-fixnum bs)))
		    (maybe-package-name (%deserialize bs)))
;;		(format t "ouput name = ~A~%" name)
		(if maybe-package-name
		    (intern name (find-package maybe-package-name))
		    (make-symbol name))))
	     ((= tag +ucs1-string+)
	      (buffer-read-ucs1-string bs (buffer-read-fixnum bs)))
	     #+(or lispworks (and allegro ics))
	     ((= tag +ucs2-string+)
	      (buffer-read-ucs2-string bs (buffer-read-fixnum bs)))
	     #+(and sbcl sb-unicode)
	     ((= tag +ucs4-string+)
	      (buffer-read-ucs4-string bs (buffer-read-fixnum bs)))
	     ((= tag +persistent+)
;;	      (get-cached-instance *store-controller*
	      (get-cached-instance sc
				   (buffer-read-fixnum bs)
				   (%deserialize bs)))
	     ((= tag +single-float+)
	      (buffer-read-float bs))
	     ((= tag +double-float+)
	      (buffer-read-double bs))
	     ((= tag +char+)
	      (code-char (buffer-read-uint bs)))
	     ((= tag +ucs1-pathname+)
	      (parse-namestring 
	       (or (buffer-read-ucs1-string bs (buffer-read-fixnum bs)) "")))
	     #+(or lispworks (and allegro ics))
	     ((= tag +ucs2-pathname+)
	      (parse-namestring 
	       (or (buffer-read-ucs2-string bs (buffer-read-fixnum bs)) "")))
	     #+(and sbcl sb-unicode)
	     ((= tag +ucs4-pathname+)
	      (parse-namestring 
	       (or (buffer-read-ucs4-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+)

[151 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/01/16 00:51:25	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/01/16 00:51:25	1.1

[720 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp	2007/01/16 00:51:25	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp	2007/01/16 00:51:25	1.1

[980 lines skipped]


From ieslick at common-lisp.net  Tue Jan 16 00:55:22 2007
From: ieslick at common-lisp.net (ieslick)
Date: Mon, 15 Jan 2007 19:55:22 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/elephant
Message-ID: <20070116005522.147C76011E@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv4243

Added Files:
	classes-new.lisp serializer2-locks.lisp serializer3.lisp 
Log Message:

Adding missing files, some of these will go away later but I want
to keep a record of my work to date.  I really should have put this
on a branch, but it got out of control before I realized how much
rewiring I was doing!

-----------



--- /project/elephant/cvsroot/elephant/src/elephant/classes-new.lisp	2007/01/16 00:55:22	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/classes-new.lisp	2007/01/16 00:55:22	1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; classes.lisp -- persistent objects via metaobjects
;;; 
;;; Initial version 8/26/2004 by Andrew Blumberg
;;; <ablumberg at common-lisp.net>
;;; 
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg at common-lisp.net> <blee at common-lisp.net>
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
(in-package "ELEPHANT")

(defvar *debug-si* nil)

(defmethod initialize-instance :before  ((instance persistent)
					 &rest initargs
					 &key from-oid
					 (sc *store-controller*))
  "Sets the OID and home controller"
  (declare (ignore initargs))
  (if (null sc)
      (error "Initialize instance for type persistent requires valid store controller argument :sc"))
  (if from-oid
      (setf (oid instance) from-oid)
      (setf (oid instance) (next-oid sc)))
  (setf (:dbcn-spc-pst instance) (controller-spec sc))
  (cache-instance sc instance))

(defclass persistent-object (persistent) ()
  (:metaclass persistent-metaclass)
  (:documentation 
   "Superclass of all user-defined persistent classes.  This is
    automatically inherited if you use the persistent-metaclass
    metaclass."))

;; ================================================
;; METACLASS INITIALIZATION AND CHANGES
;; ================================================

(defmethod ensure-class-using-class :around ((class (eql nil)) name &rest args &key index)
  "Support the :index class option"
  (let ((result (apply #'call-next-method class name (remove-index-keyword args))))
    (when (and index (subtypep (type-of result) 'persistent-metaclass))
      (update-indexed-record result nil :class-indexed t))
    result))

(defmethod ensure-class-using-class :around ((class persistent-metaclass) name &rest args &key index)
  "Support the :index class option on redefinition"
  (let ((result (apply #'call-next-method class name (remove-index-keyword args))))
    (when index
      (update-indexed-record result nil :class-indexed t))
    result))
				     
(defun remove-index-keyword (list)
  (cond ((null list) 
	 nil)
	((eq (car list) :index)
	 (cddr list))
	(t 
	 (cons (car list) (remove-index-keyword (cdr list))))))

(defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses)
  "Ensures we inherit from persistent-object."
  (let* ((persistent-metaclass (find-class 'persistent-metaclass))
	 (persistent-object (find-class 'persistent-object))
	 (not-already-persistent (loop for superclass in direct-superclasses
				       never (eq (class-of superclass) persistent-metaclass))))
    (if (and (not (eq class persistent-object)) not-already-persistent)
	(apply #'call-next-method class slot-names
	       :direct-superclasses (cons persistent-object
					  direct-superclasses) args)
	(call-next-method))))

(defmethod finalize-inheritance :around ((instance persistent-metaclass))
  "Update the persistent slot records in the metaclass."
  (prog1
      (call-next-method)
    (when (not (slot-boundp instance '%persistent-slots))
	(setf (%persistent-slots instance) 
	      (cons (persistent-slot-names instance) nil)))
    (update-indexed-record instance (indexed-slot-names-from-defs instance))))

(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys)
  (declare (ignore initargs))
  (prog1
      (call-next-method)
    (when (class-finalized-p instance)
      (update-persistent-slots instance (persistent-slot-names instance))
      (update-indexed-record instance (indexed-slot-names-from-defs instance))
      (if (removed-indexing? instance)
	  (progn 
	    (let ((class-idx (get-value (class-name instance) (controller-class-root *store-controller*))))
	      (when class-idx
		(wipe-class-indexing instance class-idx)))
	    (setf (%index-cache instance) nil))
	  (set-db-synch instance :class))
;;      #+allegro
;;      (loop with persistent-slots = (persistent-slots instance)
;;	    for slot-def in (class-direct-slots instance)
;;	    when (member (slot-definition-name slot-def) persistent-slots)
;;	    do (initialize-accessors slot-def instance))
      (make-instances-obsolete instance))))

;; ================================================
;; PERSISTENT OBJECT MAINTENANCE
;; ================================================

;;
;; CLASS INSTANCE INITIALIZATION
;;

(defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key from-oid &allow-other-keys)
  "Initializes the persistent slots via initargs or forms.
This seems to be necessary because it is typical for
implementations to optimize setting the slots via initforms
and initargs in such a way that slot-value-using-class et al
aren't used.  We also handle writing any indices after the 
class is fully initialized.  Calls the next method for the transient 
slots."
  (let* ((class (find-class (class-name (class-of instance))))
	 (oid (oid instance))
	 (persistent-slot-names (persistent-slot-names class)))
    (flet ((persistent-slot-p (item) 
	     (member item persistent-slot-names :test #'eq)))
      (let ((transient-slot-inits 
	     (if (eq slot-names t)	; t means all slots
		 (transient-slot-names class)
		 (remove-if #'persistent-slot-p slot-names)))
	    (persistent-slot-inits
	     (if (eq slot-names t) 
		 persistent-slot-names
		 (remove-if-not #'persistent-slot-p slot-names))))
	(inhibit-indexing oid)
	(unwind-protect 
	     (progn
	       ;; initialize the persistent slots ourselves
	       (initialize-persistent-slots class instance persistent-slot-inits initargs)
	       ;; let the implementation initialize the transient slots
	       (apply #'call-next-method instance transient-slot-inits initargs))
	  (uninhibit-indexing oid))
	;; Inhibit indexing altogether if the object already was defined (ie being created 
	;;   from an oid) as it should be indexed already.  This hack avoids a deadlock 
	;;   situation where we write the class or index page that we are currently reading 
	;;   via a cursor without going through the cursor abstraction. There has to be a 
	;;   better way to do this.
	(when (and (indexed class) (not from-oid))
	  (let ((class-index (find-class-index class)))
	    (when class-index
	      (setf (get-value oid class-index) instance))))
	))))

(defun initialize-persistent-slots (class instance persistent-slot-inits initargs)
  (flet ((initialize-from-initarg (slot-def)
	   (loop for initarg in initargs
	      with slot-initargs = (slot-definition-initargs slot-def)
	      when (member initarg slot-initargs :test #'eq)
	      do 
		(setf (slot-value-using-class class instance slot-def) 
		      (getf initargs initarg))
		(return t))))
    (with-transaction (:store-controller (get-con instance))
      (loop for slot-def in (class-slots class)
	 unless (initialize-from-initarg slot-def)
	 when (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq)
	 unless (slot-boundp-using-class class instance slot-def)
	 do
	 (let ((initfun (slot-definition-initfunction slot-def)))
	   (when initfun
	     (setf (slot-value-using-class class instance slot-def)
		   (funcall initfun))))))))

;;
;; CLASS REDEFINITION PROTOCOL
;;

(defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys)
  ;; NOTE: probably should delete discarded slots, but we'll worry about that later
  ;;       (also will want to delete discarded indices since we don't have a good GC)
  (declare (ignore property-list discarded-slots added-slots))
  (prog1
      (call-next-method)
    (let* ((class (class-of instance))
	   (new-persistent-slots (set-difference (persistent-slots class)
						 (old-persistent-slots class))))
      ;; Update new persistent slots, the others we get for free (same oid!)
      ;; Isn't this done by the default call-next-method?
      (apply #'shared-initialize instance new-persistent-slots initargs))
    ))

;;
;; CLASS CHANGE PROTOCOL
;;

(defmethod update-instance-for-different-class :around ((previous persistent) (current persistent) &rest initargs &key)
  (let* ((old-class (class-of previous))
	 (new-class (class-of current))
	 (new-persistent-slots (set-difference
				(persistent-slots new-class)
				(persistent-slots old-class)))
	 (raw-retained-persistent-slots (intersection (persistent-slots new-class)
						      (persistent-slots old-class)))
	 (retained-unbound-slots (loop for slot-name in raw-retained-persistent-slots
				       when (not (persistent-slot-boundp (get-con previous) previous slot-name))
				       collect slot-name))
 	 (retained-persistent-slots (set-difference raw-retained-persistent-slots retained-unbound-slots)))
    ;; Apply default values for unbound & new slots (updates class index)
    (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs)
    ;; Copy values from old class (NOTE: should delete discarded slots?) (updates class index)
    (with-transaction (:store-controller (get-con current))
      (loop for slot-def in (class-slots new-class)
	 when (member (slot-definition-name slot-def) retained-persistent-slots)
	 do (setf (slot-value-using-class new-class
					  current
					  slot-def)
		  (slot-value-using-class old-class
					  previous
					  (find-slot-def-by-name old-class (slot-definition-name slot-def))))))
    ;; Delete this instance from its old class index, if exists
    (when (indexed old-class)
      (remove-kv (oid previous) (find-class-index old-class)))
    (call-next-method)))


;;
;; SLOT ACCESS PROTOCOLS
;;

(defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
  "Get the slot value from the database."
  (declare (optimize (speed 3)))
  (let ((name (slot-definition-name slot-def)))
    (persistent-slot-reader (get-con instance) instance name)))

(defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
  "Set the slot value in the database."
  (declare (optimize (speed 3)))
  (if (indexed class)
      (indexed-slot-writer class instance slot-def new-value)
      (let ((name (slot-definition-name slot-def)))
	(persistent-slot-writer (get-con instance) new-value instance name))))

(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
  "Checks if the slot exists in the database."
  (declare (optimize (speed 3)))
  (let ((name (slot-definition-name slot-def)))
    (persistent-slot-boundp (get-con instance) instance name)))

(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol))
  "Checks if the slot exists in the database."
  (declare (optimize (speed 3)))
  (loop for slot in (class-slots class)
	for matches-p = (eq (slot-definition-name slot) slot-name)
	until matches-p
	finally (return (if (and matches-p
				 (subtypep (type-of slot) 'persistent-slot-definition))
			    (persistent-slot-boundp (get-con instance) instance slot-name)
			    (call-next-method)))))

(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
  "Deletes the slot from the database."
  (declare (optimize (speed 3)))
  ;; NOTE: call remove-indexed-slot here instead?
  (when (indexed slot-def)
    (unregister-indexed-slot class (slot-definition-name slot-def)))
  (persistent-slot-makunbound (get-con instance) instance (slot-definition-name slot-def)))
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2-locks.lisp	2007/01/16 00:55:22	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2-locks.lisp	2007/01/16 00:55:22	1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; serializer.lisp -- convert Lisp data to/from byte arrays
;;; 
;;; Initial version 8/26/2004 by Ben Lee
;;; <blee at common-lisp.net>
;;; 
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;

(in-package :elephant)

(defpackage :elephant-serializer2
  (:use :cl :elephant :elephant-memutil)
  (:import-from :elephant 
		*circularity-initial-hash-size*
		*resourced-byte-spec*
		get-cached-instance
		slot-definition-allocation
		slot-definition-name
		compute-slots
		oid))
		

(in-package :elephant-serializer2)

(declaim (inline int-byte-spec
		 serialize deserialize
		 slots-and-values
		 deserialize-bignum))

(uffi:def-type foreign-char :char)

;; Constants

(defconstant +fixnum+                1)
(defconstant +fixnum64+              2)
(defconstant +char+                  3)
(defconstant +single-float+          4)
(defconstant +double-float+          5)
(defconstant +negative-bignum+       6)
(defconstant +positive-bignum+       7)
(defconstant +rational+              8)

;; Save constants by splitting strings and encoding
(defconstant +utf8-string+           9)
(defconstant +utf16-string+         10)
(defconstant +utf32-string+         11)

;; String-based aggregates
(defconstant +pathname+             12)
(defconstant +symbol+               13)

;; Cached symbol references 
(defconstant +symbol-id+            14)

;; stored by id+classname
(defconstant +persistent+           15)

;; Composite objects
(defconstant +cons+                 16)
(defconstant +hash-table+           17)
(defconstant +object+               18)
(defconstant +array+                19)
(defconstant +struct+               20)
(defconstant +class+                21)

(defconstant +nil+                  #x3F)

;; Arrays
(defconstant +fill-pointer-p+     #x40)
(defconstant +adjustable-p+       #x80)

;;
;; The following may be overkill, but is intended to avoid continually
;; allocating hashes each time we serialize an object.  I added some
;; adaptation to keep it from dropping and re-allocating if the user
;; continually saves large collections of objects.  However the
;; defaults should handle most apps just fine.  The queue is useful
;; because a system with 10 threads will need 10 circularity queues if
;; it is storing large objects
;;

;;
;; Circularity Hash for Serializer
;;

(defparameter *circularity-hash-queue* (make-array 20 :fill-pointer 0 :adjustable t)
  "Circularity ids for the serializer.")

(defparameter *circularity-lock* (ele-make-lock)
  "Enable multiprocessor ")

(defun get-circularity-hash ()
  "Get a clean hash for object serialization"
  (declare (optimize (speed 3) (safety 0)))
  (make-hash-table :test 'eq :size *circularity-initial-hash-size*))
;;  (if (= 0 (length *circularity-hash-queue*))
;;      (make-hash-table :test 'eq :size *circularity-initial-hash-size*))
;;      (ele-with-lock (*circularity-lock*)
;;	   (vector-pop *circularity-hash-queue*))))

(defun release-circularity-hash (hash)
  "Return the hash to the queue for reuse"
  (declare (optimize (speed 3) (safety 0))
	   (type hash-table hash)
	   (type array *circularity-hash-queue*))
  nil)
;;  (unless (= (hash-table-count hash) 0)
;;    (clrhash hash))
;;  (ele-with-lock (*circularity-lock*)
;;    (vector-push-extend hash *circularity-hash-queue*)))


;;
;; Circularity Hash for Serializer
;;

(defparameter *circularity-vector-queue* (make-array 20 :fill-pointer 0 :adjustable t)
  "A list of vectors used for linear deserialization.
   This works nicely because all ID's are written

[449 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/serializer3.lisp	2007/01/16 00:55:22	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer3.lisp	2007/01/16 00:55:22	1.1

[582 lines skipped]


From ieslick at common-lisp.net  Tue Jan 16 18:02:27 2007
From: ieslick at common-lisp.net (ieslick)
Date: Tue, 16 Jan 2007 13:02:27 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/db-bdb
Message-ID: <20070116180227.B8516120A7@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/db-bdb
In directory clnet:/tmp/cvs-serv771

Modified Files:
	libberkeley-db.c 
Log Message:

Fixed build errors in db-bdb C interface file.  This file is
not yet complete for serializer2



--- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c	2006/12/16 19:35:10	1.2
+++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c	2007/01/16 18:02:27	1.3
@@ -67,7 +67,7 @@
 /* Pointer arithmetic utility functions */
 /* should these be in network-byte order? probably not..... */
 int read_int(char *buf, int offset) {
-  int int;
+  int i;
   memcpy(&i, buf+offset, sizeof(int));
   return i;
 }
@@ -79,7 +79,7 @@
 }
 
 int32_t read_int32(char *buf, int offset) {
-  int int32_t;
+  int32_t i;
   memcpy(&i, buf+offset, sizeof(int32_t));
   return i;
 }
@@ -119,7 +119,7 @@
   memcpy(buf+offset, &num, sizeof(int));
 }
 
-void write_uint(char *buf, unsighed int num, int offset) {
+void write_uint(char *buf, unsigned int num, int offset) {
   memcpy(buf+offset, &num, sizeof(unsigned int));
 }
 
@@ -277,6 +277,7 @@
 
 double read_num(char *buf);
 int case_cmp(const char *a, int32_t length1, const char *b, int32_t length2);
+int wcs_cmp(const wchar_t *a, int32_t length1, const wchar_t *b, int32_t length2);
 int lex_cmp(const char *a, int32_t length1, const char *b, int32_t length2);
 int utf16_cmp(const char *s1, int32_t length1, 
 	      const char *s2, int32_t length2);
@@ -316,7 +317,7 @@
   }
 
   /* Compare types. */
-  if 
+  /* ISE: need extra conditional here...forget why, so research it */
   difference = at - bt;
   if (difference) return difference;
 
@@ -335,7 +336,7 @@
   case 20:
   case 21:
   case 22:
-    return wcs_cmp(ad+9, read_int(ad, 5), bd+9, read_int(bd, 5)); 
+    return wcs_cmp((wchar_t*)ad+9, read_int(ad, 5), (wchar_t*)bd+9, read_int(bd, 5)); 
   default:
     return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5);
   }
@@ -368,33 +369,37 @@
 
   /* Compare numerics. */
   if (type_numeric2(at) && type_numeric2(bt)) {
-    ddifference = read_num2(ad+4) - read_num2(bd+4);
+    /* ddifference = read_num2(ad+4) - read_num2(bd+4); */
+    ddifference = read_num(ad+4) - read_num(bd+4);
     if (ddifference > 0) return 1;
     else if (ddifference < 0) return -1;
     return 0;
   }
 
   /* Compare types. */
-  if 
+  /* ISE: need extra conditional here...forget why, so research it */
   difference = at - bt;
   if (difference) return difference;
 
-  ;; TODO: compare strings of different sizes?
-  ;; TODO: compare symbol-ids?
+  /* TODO: compare strings of different sizes? */
+  /* TODO: compare symbol-ids? */
   
   /* Same type! */
   switch (at) {
-  case #x3F: /* nil */
+  case 0x3F: /* nil */
     return 0;
   case 9: /* 8-bit string */
+    return case_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5));
+    /* ISE: Why did I do this?
     if( bt == 9 )
       return case_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5));
     else 
       return full_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5))
+    */
   case 10: /* 16-bit string */
     return utf16_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5));
   case 11:
-    return wcs_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); 
+    return wcs_cmp((wchar_t*)ad+9, read_int32(ad, 5), (wchar_t*)bd+9, read_int32(bd, 5)); 
   default:
     return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5);
   }
@@ -866,8 +871,8 @@
 }
 
 void db_multiple_key_next(void *pointer, DBT *data,
-			  char **key, u_int32_t *ret_key_size,
-			  char **result, u_int32_t *result_size) {
+			  unsigned char **key, u_int32_t *ret_key_size,
+			  unsigned char **result, u_int32_t *result_size) {
   DB_MULTIPLE_KEY_NEXT(pointer, data, 
 		       *key, *ret_key_size, 
 		       *result, *result_size);
@@ -875,7 +880,7 @@
 
 /* Transactions */
 
-DB_TXN * db_txn_begin(DB_ENV *env, DB_TXN *parent, 
+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);



From ieslick at common-lisp.net  Fri Jan 19 21:03:29 2007
From: ieslick at common-lisp.net (ieslick)
Date: Fri, 19 Jan 2007 16:03:29 -0500 (EST)
Subject: [elephant-cvs] CVS elephant
Message-ID: <20070119210329.BA9BE2F054@common-lisp.net>

Update of /project/elephant/cvsroot/elephant
In directory clnet:/tmp/cvs-serv4428

Modified Files:
	TODO ele-bdb.asd elephant.asd 
Log Message:
Added missing file; Henrik's fixes to ele-bdb and clsql cursor-pset

--- /project/elephant/cvsroot/elephant/TODO	2006/12/16 19:35:09	1.31
+++ /project/elephant/cvsroot/elephant/TODO	2007/01/19 21:03:29	1.32
@@ -14,7 +14,6 @@
   - flexible handling of 64-bit fixnums
 
 Stability:
-- Remove build gensym warnings in sleepycat.lisp
 - Delete persistent slot values from the slot store with remove-kv to ensure that
   there's no data left lying around if you define then redefine a class and add
   back a persistent slot name that you thought was deleted and it gets the old
@@ -61,6 +60,8 @@
   parameter that determines if this is the default?
 
 Performance:
+- Allow dump of fast-symbol tables for low-level reconstruction in case of 
+  catastrophic errors
 - Metering and understanding locking issues.  Large transactions seem
   to use a lot of locks.  In general understanding how to use Berkeley DB
   efficiently seems like a good thing. (From Ben)
@@ -85,6 +86,7 @@
 
 0.6.1 - Features COMPLETED to date
 ----------------------------------
+January 2006 checkin
 x Improved optimization options to be more user controlled (Pierre Thierry)
 x Implement backend support for symbol-table protocol
 x Speed up symbol storage and reference using symbol id's
@@ -94,7 +96,10 @@
 x New build interface; all-lisp compilation (sans win32)
 x Simplify user-specific configuration parameters using config.sexp and my-config.sexp
 x Make sure to ensure thread safety in buffer-stream allocation!
+x Investigated gensym warnings in berkeley-db.lisp (caused by an FFI macro, no harm in it)
+x Remove warnings in libberkeley-db.c
 
+Prior to December 2006
 x BDB overwrite of values makes DB grow 
   [So far I can only find that it grows on the 2nd write, but not after that...artifact of
    page allocation or caching of memory pools?]
--- /project/elephant/cvsroot/elephant/ele-bdb.asd	2006/12/16 19:35:09	1.13
+++ /project/elephant/cvsroot/elephant/ele-bdb.asd	2007/01/19 21:03:29	1.14
@@ -31,11 +31,16 @@
 
 (defun get-config-option (option component)
   (unless *bdb-config*
-    (with-open-file (config (make-pathname :defaults (asdf:component-pathname  
-						      (asdf:component-system component))
-					   :name "my-config"
-					   :type "sexp"))
-      (setf *bdb-config* (read config))))
+    (let ((filespec (make-pathname :defaults (asdf:component-pathname  
+
+(asdf:component-system component))
+                                           :name "my-config"
+                                           :type "sexp")))
+      (unless (probe-file filespec)
+        (error "Missing file. Copy config.sexp in elephant root
+directory to my-config.sexp and edit it appropriately."))
+      (with-open-file (config filespec)
+        (setf *bdb-config* (read config)))))
   (cdr (assoc option *bdb-config*)))
 
 ;;
--- /project/elephant/cvsroot/elephant/elephant.asd	2006/12/16 19:35:09	1.21
+++ /project/elephant/cvsroot/elephant/elephant.asd	2007/01/19 21:03:29	1.22
@@ -130,8 +130,8 @@
 (defsystem elephant
   :name "elephant"
   :author "Ben Lee <blee at common-lisp.net>"
-  :version "0.6.0"
-  :maintainer "Ben Lee <blee at common-lisp.net>"
+  :version "0.6.1"
+  :maintainer "Robert Read <read at robertlread.net>"
   :licence "LLGPL"
   :description "Object database for Common Lisp"
   :long-description "An object-oriented database based on Berkeley DB, for CMUCL/SBCL, OpenMCL, and Allegro."



From ieslick at common-lisp.net  Fri Jan 19 21:03:30 2007
From: ieslick at common-lisp.net (ieslick)
Date: Fri, 19 Jan 2007 16:03:30 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/db-bdb
Message-ID: <20070119210330.0ECEE38010@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/db-bdb
In directory clnet:/tmp/cvs-serv4428/src/db-bdb

Modified Files:
	bdb-controller.lisp berkeley-db.lisp libberkeley-db.c 
Added Files:
	bdb-symbol-tables.lisp 
Log Message:
Added missing file; Henrik's fixes to ele-bdb and clsql cursor-pset

--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp	2006/12/16 19:35:10	1.14
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp	2007/01/19 21:03:29	1.15
@@ -57,16 +57,6 @@
 	 (string t)
 	 (otherwise nil))))
 
-(defmethod controller-version ((sc store-controller))
-  (let ((version (controller-version sc)))
-    (if version version
-	(let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc)))))
-	  (if (probe-file path)
-	      (with-open-file (stream path :direction :input)
-		(read stream))
-	      (with-open-file (stream path :direction :output)
-		(write *elephant-code-version* :stream stream)))))))
-
 ;;
 ;; Open/close     
 ;;
--- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp	2006/11/11 18:43:31	1.1
+++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp	2007/01/19 21:03:29	1.2
@@ -1673,10 +1673,11 @@
   :returning :int)
 
 (def-function ("db_set_lisp_compare" %db-set-lisp-compare)
-    ((db :pointer-void))
+    ((db :pointer-void)
+     (version :int))
   :returning :int)
 
-(wrap-errno db-set-lisp-compare (db) :documentation 
+(wrap-errno db-set-lisp-compare (db version) :documentation 
 "Sets the Btree comparision function to a hand-cooked
 function for Elephant to compare lisp values.")
 
@@ -1686,10 +1687,11 @@
   :returning :int)
 
 (def-function ("db_set_lisp_dup_compare" %db-set-lisp-dup-compare)
-    ((db :pointer-void))
+    ((db :pointer-void)
+     (version :int))
   :returning :int)
 
-(wrap-errno db-set-lisp-dup-compare (db) :documentation 
+(wrap-errno db-set-lisp-dup-compare (db version) :documentation 
 "Sets the duplicate comparision function to a hand-cooked
 function for Elephant to compare lisp values.")
 
--- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c	2007/01/16 18:02:27	1.3
+++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c	2007/01/19 21:03:29	1.4
@@ -873,8 +873,8 @@
 void db_multiple_key_next(void *pointer, DBT *data,
 			  unsigned char **key, u_int32_t *ret_key_size,
 			  unsigned char **result, u_int32_t *result_size) {
-  DB_MULTIPLE_KEY_NEXT(pointer, data, 
-		       *key, *ret_key_size, 
+  DB_MULTIPLE_KEY_NEXT(pointer, data,
+		       *key, *ret_key_size,
 		       *result, *result_size);
 }
 

--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-symbol-tables.lisp	2007/01/19 21:03:30	NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-symbol-tables.lisp	2007/01/19 21:03:30	1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; controller.lisp -- Lisp interface to a Berkeley DB store
;;; 
;;; Initial version 8/26/2004 by Ben Lee
;;; <blee at common-lisp.net>
;;; 
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg at common-lisp.net> <blee at common-lisp.net>
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;

(in-package :db-bdb)

(defmethod lookup-persistent-symbol-id ((sc bdb-store-controller) symbol)
  "Look up and create id association for symbol"
  (with-buffer-streams (keybuf valbuf)
    (buffer-write-int *symbol-to-id-table-oid* keybuf)
    (serialize-symbol-complete symbol keybuf)
    (let ((buf (db-get-key-buffered (controller-btrees sc)
				    keybuf valbuf)))
      (if buf (values (buffer-read-int buf) T)
	  (values (create-persistent-symbol sc symbol keybuf valbuf) t)))))

(defun create-persistent-symbol (sc symbol keybuf valbuf)
  "Takes an symbol->id table + symbol keybuf, allocates an ID and updates
   the persistent tables."
  (reset-buffer-stream valbuf) ;; Just to avoid any contamination
;;  (with-transaction (:txn-nosync t :dirty-read t) 
  (format t "getting next symid")
  (let ((id (next-symid sc))) ;; allocate a new unique id
    ;; Update symbol->id table
    (format t "Writing sym->id: ~A -> ~A~%" symbol id)
    (buffer-write-int id valbuf)
    (format t "Putting id into table location~%")
    (db-put-buffered (controller-btrees sc) keybuf valbuf
		     :auto-commit *auto-commit*)
    ;; Write id->symbol table
    (reset-buffer-stream keybuf)
    (reset-buffer-stream valbuf)
    (format t "Writing id->sym: ~A -> ~A~%" id symbol)
    (buffer-write-int *id-to-symbol-table-oid* keybuf)
    (buffer-write-int id keybuf)
    (serialize-symbol-complete symbol valbuf)
    (db-put-buffered (controller-btrees sc) keybuf valbuf
		     :auto-commit *auto-commit*)
    id)
;;    )
  )


(defmethod lookup-persistent-symbol ((sc bdb-store-controller) id)
  "Lookup the ID associated with a symbol"
  (with-buffer-streams (keybuf valbuf)
    (format t "Looking up: ~A~%" id)
    (buffer-write-int *id-to-symbol-table-oid* keybuf)
    (buffer-write-int id keybuf)
    (format t "Get for id: ~A~%" id)
    (let ((buf (db-get-key-buffered (controller-btrees sc)
				    keybuf valbuf)))
      (format t "Got buf: ~A~%" buf)
      (if buf (values (deserialize buf sc) T)
	  (error "Invalid ID - no persistent mapping for ID")))))

;;
;; Stress test
;;

(defun stress-test (iters syms)
    (loop for i fixnum from 0 upto iters do
	 (format t "Iteration ~A~%" i)
;;	 (with-transaction ()
;;	   (print *current-transaction*)
	   (loop for i fixnum from 0 upto (length syms) do
		(add-to-root (nth i syms) (nth i syms)))))

(defun make-syms (num &aux list)
  (loop for i fixnum from 0 below num do
       (let* ((str (format nil "test~A" i))
	      (sym (intern str)))
	 (push sym list)))
  (nreverse list))


From ieslick at common-lisp.net  Fri Jan 19 21:03:30 2007
From: ieslick at common-lisp.net (ieslick)
Date: Fri, 19 Jan 2007 16:03:30 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/db-clsql
Message-ID: <20070119210330.43B483801C@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/db-clsql
In directory clnet:/tmp/cvs-serv4428/src/db-clsql

Modified Files:
	sql-collections.lisp 
Log Message:
Added missing file; Henrik's fixes to ele-bdb and clsql cursor-pset

--- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp	2006/11/11 18:41:11	1.6
+++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp	2007/01/19 21:03:30	1.7
@@ -136,7 +136,7 @@
 	 (tup tuples (cdr tup)))
 	((= i len) nil)
       (setf (aref (:sql-crsr-ks cursor) i) 
-	    (deserialize-from-base64-string (caar tup) :sc sc)))
+	    (deserialize-from-base64-string (caar tup) sc)))
     (sort (:sql-crsr-ks cursor) #'my-generic-less-than)
     (setf (:sql-crsr-ck cursor) 0)
     (setf (cursor-initialized-p cursor) t)
@@ -362,14 +362,14 @@
   (declare (optimize (speed 3)))
   (unless (cursor-initialized-p cursor)
     (cursor-init cursor))
-  (let ((idx (position key (:sql-crsr-ks cursor))))
+  (let ((idx (position key (:sql-crsr-ks cursor) :test #'equal)))
     (if idx
-	(progn
-	  (setf (:sql-crsr-ck cursor) idx)
-	  (setf (:dp-nmbr cursor) 0)
-	  (cursor-current-x cursor :returnpk t))
-	(cursor-un-init cursor)
-	)))
+        (progn
+          (setf (:sql-crsr-ck cursor) idx)
+          (setf (:dp-nmbr cursor) 0)
+          (cursor-current-x cursor :returnpk t))
+        (cursor-un-init cursor)
+        )))
 
 (defun array-index-if (p a)
   (do ((i 0 (1+ i)))



From ieslick at common-lisp.net  Fri Jan 19 21:03:30 2007
From: ieslick at common-lisp.net (ieslick)
Date: Fri, 19 Jan 2007 16:03:30 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/elephant
Message-ID: <20070119210330.944B038010@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv4428/src/elephant

Modified Files:
	controller.lisp package.lisp 
Log Message:
Added missing file; Henrik's fixes to ele-bdb and clsql cursor-pset

--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2006/12/16 19:35:10	1.17
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/19 21:03:30	1.18
@@ -198,7 +198,7 @@
    (class-root :reader controller-class-root
 	       :documentation "This should be a persistent indexed btree instantiated by the backend")
    ;; Upgradable serializer strategy
-   (version :accessor controller-version :initform nil)
+   (version :accessor controller-version-cached :initform nil)
    (serializer-version :accessor controller-serializer-version :initform nil)
    (serialize :accessor controller-serialize :initform nil)
    (deserialize :accessor controller-deserialize :initform nil)
@@ -230,11 +230,16 @@
 (defvar *restricted-properties* '(:version)
   "Properties that are not user manipulable")
 
-(defgeneric controller-version ((sc store-controller))
-  (:documentation "Return the elephant version of this controller - should not 
-                   require the serializer to operate as it may be used to determine
-                   the serializer version used to read the DB.  This has to be valid
-                   prior to the DB being opened."))
+(defmethod controller-version ((sc store-controller))
+  (let ((version (controller-version-cached sc)))
+    (if version version
+	(let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc)))))
+	  (if (probe-file path)
+	      (with-open-file (stream path :direction :input)
+		(setf (controller-version-cached sc) (read stream)))
+	      (with-open-file (stream path :direction :output)
+		(setf (controller-version-cached sc) 
+		      (write *elephant-code-version* :stream stream))))))))
 
 (defun prior-version-p (v1 v2)
   "Is v1 an equal or earlier version than v2"
--- /project/elephant/cvsroot/elephant/src/elephant/package.lisp	2006/12/16 19:35:10	1.4
+++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp	2007/01/19 21:03:30	1.5
@@ -29,7 +29,8 @@
 	   #:*elephant-lib-path* #:*elephant-code-version*
 
 	   #:store-controller #:controller-root #:controller-class-root
-	   #:controller-version #:controller-serialize #:controller-deserialize
+	   #:controller-version #:controller-serializer-version 
+	   #:controller-serialize #:controller-deserialize
 	   #:open-store #:close-store #:with-open-store
 	   #:add-to-root #:get-from-root #:remove-from-root #:root-existsp
 	   #:get-cached-instance #:flush-instance-cache



From ieslick at common-lisp.net  Sat Jan 20 22:12:17 2007
From: ieslick at common-lisp.net (ieslick)
Date: Sat, 20 Jan 2007 17:12:17 -0500 (EST)
Subject: [elephant-cvs] CVS elephant
Message-ID: <20070120221217.5986865003@common-lisp.net>

Update of /project/elephant/cvsroot/elephant
In directory clnet:/tmp/cvs-serv5278

Modified Files:
	TODO config.sexp 
Log Message:
Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again.

--- /project/elephant/cvsroot/elephant/TODO	2007/01/19 21:03:29	1.32
+++ /project/elephant/cvsroot/elephant/TODO	2007/01/20 22:12:17	1.33
@@ -114,16 +114,16 @@
 x Remove sleepycat name.  Change sleepycat to db-bdb to reflect oracle ownership and avoid
   confusion for new users
 
-0.6.2 - Advanded work, low-hanging fruit (Fall '06)
+0.6.2 - Advanded work, low-hanging fruit (Summer '07)
 --------------------------------------------------
+  - Persistent variables (abstraction that allows compound lisp objects at the cost of
+    full serialization after each write that indirects through the API).  Can this be done
+    with clean semantics or should we punt it?
   - Class option MOP add-on to support declared persistent baseclass slots for standard base classes
   - Evaluate porting elephant to closer-to-MOP to make it easier to
     support additional lisps and to seriously clean up
     metaclasses.lisp and classes.lisp protocols
   - A wrapper around migration that emulates a stop-and-copy GC
-
-0.6.3 - Documentation & Tools (Winter '06)
---------------------------------------------------
   - Tutorial example rethink: update the blog tutorial using indexed 
     objects to create different views as well as integrating something 
     like logging for admin or version control purposes.
@@ -135,6 +135,7 @@
 
 0.7.0: Fast In-Memory Database (Not backwards compatible)
 --------------------------------------------------
+  - Full support for DCM or integration of DCM functionality
   - Integrate prevalence-like in-memory database system for single image, multiple-thread operation
   - Fast serializer port w/ upgrade strategy and prevalence like storage solution
     - Further improve SQL 64-bit serialization performance (if possible)
@@ -170,16 +171,18 @@
 
 0.9.0 - Supporting Tools Release
 --------------------------------------------------
-  - Document DCM?
-  - Add needed support (if any) for persistent graph structures & queries (Ian on a branch)
-  - Simple object query language (Ian - orthogonal, on main branch)
-  - Repository browser (Ian - orthogonal, on main branch)
-    (a simple REPL tool to see what classes are in a repository and
-     what state they're in...useful for long-lived repositories)
-
-
-
-
+  - Support a simple object query language over the database
+  - Add special support (if any) for persistent graph structures & queries (ala AllegroCache)
+  - Repository browser - a simple REPL tool like the Slime inspector 
+    to see what classes are in a repository and what state they're in...useful 
+    for long-lived repositories or if you've forgotten a variable name
+
+1.0 - Production release (1st fully supported version since 0.7.1)
+--------------------------------------------------
+  - Finalize supported platforms (LispWorks?  OpenMCL?)
+  - Significant work on test cases & testing framework
+  - Final pass of performance enhancements
+  - Invite community review and testing
 
 ========================================================
 ========================================================
--- /project/elephant/cvsroot/elephant/config.sexp	2006/12/16 19:35:09	1.2
+++ /project/elephant/cvsroot/elephant/config.sexp	2007/01/20 22:12:17	1.3
@@ -1,8 +1,9 @@
-((:berkeley-db-root . "/usr/local/BerkeleyDB.4.4/")
+((:berkeley-db-include-dir . "/usr/local/BerkeleyDB.4.4/")
+ (:berkeley-db-lib-dir . "/opt/local/lib/db44/")
  (:berkeley-db-lib . "/usr/local/BerkeleyDB.4.4/lib/libDB-4.4.dylib")
  (:pthread-lib . nil)
  (:clsql-lib . nil)
- (:fast-symbols . t))
+ (:fast-symbols . nil))
 
 ;; Typical pthread settings are: /lib/tls/libpthread.so.0
 ;; nil means that the library in question is not loaded



From ieslick at common-lisp.net  Sat Jan 20 22:12:17 2007
From: ieslick at common-lisp.net (ieslick)
Date: Sat, 20 Jan 2007 17:12:17 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/db-bdb
Message-ID: <20070120221217.C73F37111E@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/db-bdb
In directory clnet:/tmp/cvs-serv5278/src/db-bdb

Modified Files:
	berkeley-db.lisp libberkeley-db.c libberkeley-db.def 
Log Message:
Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again.

--- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp	2007/01/19 21:03:29	1.2
+++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp	2007/01/20 22:12:17	1.3
@@ -466,7 +466,17 @@
 
 (wrap-errno db-env-get-flags (env) :outs 2
 	    :documentation "Get flags of an environment.")
-	   
+
+(def-function ("db_env_txn_checkpoint" %db-env-txn-checkpoint)
+    ((env :pointer-void)
+     (kbyte :unsigned-int)
+     (min :unsigned-int)
+     (flags :unsigned-int))
+  :returning :int)
+
+(wrap-errno db-env-txn-checkpoint (env kbyte min flags)
+	    :flags (force)
+	    :documentation "Make a checkpoint.")
 
 ;; Database
 
--- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c	2007/01/19 21:03:29	1.4
+++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c	2007/01/20 22:12:17	1.5
@@ -210,6 +210,11 @@
   return dbenv->get_flags(dbenv, flagsp);
 }
 
+int db_env_txn_checkpoint(DB_ENV *dbenv, u_int32_t kbyte, u_int32_t min,
+			  u_int32_t flags) {
+  return dbenv->txn_checkpoint(dbenv, kbyte, min, flags);
+}
+
 /* Database */
 
 DB *db_cr(DB_ENV *dbenv, u_int32_t flags, int *errno) {
--- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.def	2006/11/11 18:41:10	1.1
+++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.def	2007/01/20 22:12:17	1.2
@@ -19,6 +19,7 @@
 	db_env_remove
 	db_env_set_flags
 	db_env_get_flags
+	db_env_txn_checkpoint
 	db_cr
 	db_close
 	db_open



From ieslick at common-lisp.net  Sat Jan 20 22:12:18 2007
From: ieslick at common-lisp.net (ieslick)
Date: Sat, 20 Jan 2007 17:12:18 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/elephant
Message-ID: <20070120221218.31C987111E@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv5278/src/elephant

Modified Files:
	controller.lisp cross-platform.lisp package.lisp 
	serializer.lisp serializer2.lisp variables.lisp 
Log Message:
Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again.

--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/19 21:03:30	1.18
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/20 22:12:17	1.19
@@ -26,7 +26,6 @@
 (defparameter *elephant-backends*
   '((:bdb (:ele-bdb))
     (:clsql (:ele-clsql))
-;;    (:acache (:ele-acache))
     )
   "Entries have the form of (backend-type asdf-depends-list")
 
@@ -102,53 +101,6 @@
 ;;   
 ;; ================================================
 
-;;
-;; Callback hooks for persistent variables
-;;
-;; NOTE: Design sketch; not sure I'll include this...
-
-;;(defvar *variable-hooks* nil
-;;  "An alist (specs -> varlist) where varlist is tuple of
-;;   lisp name, store name (auto) and policy")
-
-;;(defun add-hook (name spec)
-;;  (if (assoc spec *variable-hooks* :test #'equal)
-;;      (push name (assoc spec *variable-hooks* :test #'equal))
-;;      (push (cons spec (list name)) *variable-hooks*)))
-
-;;(defun remove-hook (name spec)
-;;  (if (assoc spec *variable-hooks* :test #'equal)
-;;      (setf (assoc spec *variable-hooks* :test #'equal) 
-;;	    (remove name (assoc spec *variable-hooks* :test #'equal)))
-;;      (error "No hooks declared on ~A" spec)))
-
-;; (defmacro defpvar (name spec (policy &rest accessors) initial-value &optional (documentation nil))
-;;   `(progn
-;;      (defvar ,name ,initial-value ,documentation)
-;;      (add-hook ,name ,spec)
-;;      ,(case policy
-;; 	(:wrap-mutators
-;; 	 `(progn
-;; 	    ,(loop for accessor in accessors do
-;; 		  (let ((gf (ensure-generic-function 
-;; 		  `(defmethod ,accessor :after (
-
-;; (defpvar *agencies* (:wrap-mutators
-;; 		     'add-agent
-;; 		     'remove-agent
-;; 		     'clear-agents)
-;;   nil
-;;   "test")
-
-;; (defmethod add-agent (agent)
-;;   (push agent *agencies*))
-
-;; (defmethod remove-agent (agent)
-;;   (setf *agencies* (remove agent *agencies*)))
-
-;; (defmethod clear-agents (agent)
-;;   (setf *agencies* nil))
-   
 
 ;;
 ;; Open a Store
@@ -157,10 +109,11 @@
 (defun open-store (spec &rest args)
   "Conveniently open a store controller."
   (assert (consp spec))
+  ;; setup system config parameters (if necessary)
+  ;; GF iface to overload by backend
   (setq *store-controller* (get-controller spec))
   (initialize-serializer *store-controller*)
-  (ensure-properties
-   (apply #'open-controller *store-controller* args)))
+  (apply #'open-controller *store-controller* args))
 
 (defun close-store (&optional sc)
   "Conveniently close the store controller."
@@ -205,6 +158,7 @@
    ;; Symbol ID caches
    (symbol-cache :accessor controller-symbol-cache :initform (make-hash-table :size 2000))
    (symbol-id-cache :accessor controller-symbol-id-cache :initform (make-hash-table :size 2000))
+   (fast-symbols :accessor controller-fast-symbols-p :initform nil)
    )
   (:documentation 
    "Class of objects responsible for the book-keeping of holding DB 
@@ -213,24 +167,24 @@
 
 (defun initialize-serializer (sc)
   "Establish serializer version on controller startup"
-  (cond ((equal (controller-version sc) '(0 6 1))
-	 (setf (controller-serializer-version sc) 2)
-	 (setf (controller-serialize sc) 'elephant-serializer2::serialize)
-	 (setf (controller-deserialize sc) 'elephant-serializer2::deserialize))
-	((prior-version-p (controller-version sc) '(0 6 0))
+  (cond ((prior-version-p (controller-version sc) '(0 6 0))
 	 (setf (controller-serializer-version sc) 1)
 	 (setf (controller-serialize sc) 'elephant-serializer1::serialize)
 	 (setf (controller-deserialize sc) 'elephant-serializer1::deserialize))
-	(t (error "Unsupported Elephant database version"))))
+	(t 
+	 (setf (controller-serializer-version sc) 2)
+	 (setf (controller-serialize sc) 'elephant-serializer2::serialize)
+	 (setf (controller-deserialize sc) 'elephant-serializer2::deserialize))))
 
 ;;
 ;; VERSIONING
 ;;
 
-(defvar *restricted-properties* '(:version)
-  "Properties that are not user manipulable")
-
-(defmethod controller-version ((sc store-controller))
+(defmethod database-version ((sc store-controller))
+  (:documentation "A version determination for a given store
+   controller that is independant of the serializer as the
+   serializer is dispatched based on the code version which is a
+   list of the form '(0 6 0)"))
   (let ((version (controller-version-cached sc)))
     (if version version
 	(let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc)))))
@@ -252,82 +206,6 @@
 	 (prior-version-p (cdr v1) (cdr v2)))
 	(t (error "Version problem!"))))
 
-(defmethod ensure-properties ((sc store-controller))
-  "Not sure this test is right (empty root)"
-  (let ((props (controller-properties sc))
-	(empty? (and (empty-btree-p (controller-root sc))
-		     (empty-btree-p (controller-class-root sc)))))
-    ;; marked - continue
-    (unless (assoc :version props)
-      (if empty?
-	  ;; empty so new database - mark with current code version
-	  (setf (get-value *elephant-properties-label* (controller-root sc))
-		(acons :version *elephant-code-version* props))
-	  ;; has stuff in it but not marked - mark as prior
-	  (setf (get-value *elephant-properties-label* (controller-root sc))
-		(acons :version *elephant-unmarked-code-version* props)))))
-  sc)
-
-
-;;
-;; Upgrade paths
-;;
-
-(defmethod up-to-date-p ((sc store-controller))
-  (equal (controller-version sc) *elephant-code-version*))
-
-(defmethod upgrade ((sc store-controller) target-spec)
-  (unless (upgradable-p sc)
-    (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A" 
-	   (controller-spec sc)
-	   (controller-version sc)
-	   *elephant-code-version*
-	   *elephant-upgrade-table*))
-  (warn "Please read the current limitations on migrate-based upgrade in migrate.lisp to ensure your 
-         data does not require any unsupported features")
-  (let ((source sc)
-	(target (open-store target-spec)))
-    (migrate target source)
-    (close-store target)))
-
-(defparameter *elephant-upgrade-table*
-  '( ((0 6 0) (0 5 0))
-     ((0 6 1) (0 6 0))
-   ))
-
-(defmethod upgradable-p ((sc store-controller))
-  "Determine if this store can be brought up to date using the upgrade function"
-  (unwind-protect
-       (let ((row (assoc *elephant-code-version* *elephant-upgrade-table* :test #'equal))
-	     (ver (controller-version sc)))
-	 (when (member ver (rest row) :test #'equal)) t)
-    nil))
-
-
-;;
-;; PROPERTIES
-;;
-
-(defmethod controller-properties ((sc store-controller))
-  (get-from-root *elephant-properties-label* :store-controller sc))
-
-(defmethod set-ele-property (property value &key (sc *store-controller*))
-  (assert (and (symbolp property) (not (member property *restricted-properties*))))
-  (let ((props (get-from-root *elephant-properties-label* :store-controller sc)))
-    (setf (get-value *elephant-properties-label* (controller-root sc))
-	  (if (assoc property props)
-	      (progn (setf (cdr (assoc property props)) value)
-		     props)
-	      (acons property value props)))))
-
-(defmethod get-ele-property (property &key (sc *store-controller*))
-  (assert (symbolp property))
-  (let ((entry (assoc property 
-		      (get-from-root *elephant-properties-label* 
-				     :store-controller sc))))
-    (when entry
-      (cdr entry))))
-
 ;;
 ;; OBJECT CACHE 
 ;;
@@ -392,12 +270,6 @@
    "Close the db handles and environment.  Tries to wipe out
 references to the db handles."))
 
-(defgeneric database-version ((sc store-controller))
-  (:documentation "A version determination for a given store
-   controller that is independant of the serializer as the
-   serializer is dispatched based on the code version which is a
-   list of the form '(0 6 0)"))
-
 (defgeneric connection-is-indeed-open (controller)
   (:documentation "Validate the controller and the db that it is connected to")
   (:method ((controller t)) t))
@@ -411,6 +283,7 @@
    "Tell the backend to reclaim any storage caused by key deletion, if possible.
     This should default to return space to the filesystem rather than just to the free list."))
 
+
 ;;
 ;; Object Root Operations
 ;;
@@ -420,7 +293,7 @@
 retrieve it in a later session.  N.B. this means it (and
 everything it points to) won't get gc'd."
   (declare (type store-controller store-controller))
-  (assert (not (eq key *elephant-properties-label*)))
+;;  (assert (not (eq key *elephant-properties-label*)))
   (setf (get-value key (controller-root store-controller)) value))
 
 (defun get-from-root (key &key (store-controller *store-controller*))
@@ -453,6 +326,118 @@
   (remhash (controller-spec sc) *dbconnection-spec*))
 
 ;;
+;; DATABASE PROPERTY INTERFACE (Not used by system as of 0.6.1)
+;;
+
+(defvar *restricted-properties* '()
+  "Properties that are not user manipulable")
+
+(defmethod controller-properties ((sc store-controller))
+  (get-from-root *elephant-properties-label* :store-controller sc))
+
+(defmethod set-ele-property (property value &key (sc *store-controller*))
+  (assert (and (symbolp property) (not (member property *restricted-properties*))))
+  (let ((props (get-from-root *elephant-properties-label* :store-controller sc)))
+    (setf (get-value *elephant-properties-label* (controller-root sc))
+	  (if (assoc property props)
+	      (progn (setf (cdr (assoc property props)) value)
+		     props)
+	      (acons property value props)))))
+
+(defmethod get-ele-property (property &key (sc *store-controller*))
+  (assert (symbolp property))
+  (let ((entry (assoc property 
+		      (get-from-root *elephant-properties-label* 
+				     :store-controller sc))))
+    (when entry
+      (cdr entry))))
+
+
+;;
+;; Upgrade paths
+;;
+
+(defmethod up-to-date-p ((sc store-controller))
+  (equal (controller-version sc) *elephant-code-version*))
+
+(defmethod upgrade ((sc store-controller) target-spec)
+  (unless (upgradable-p sc)
+    (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A" 
+	   (controller-spec sc)
+	   (controller-version sc)
+	   *elephant-code-version*
+	   *elephant-upgrade-table*))
+  (warn "Please read the current limitations on migrate-based upgrade in migrate.lisp to ensure your 
+         data does not require any unsupported features")
+  (let ((source sc)
+	(target (open-store target-spec)))
+    (migrate target source)
+    (close-store target)))
+
+(defparameter *elephant-upgrade-table*
+  '( ((0 6 0) (0 5 0))
+     ((0 6 1) (0 6 0))
+   ))
+
+(defmethod upgradable-p ((sc store-controller))
+  "Determine if this store can be brought up to date using the upgrade function"
+  (unwind-protect
+       (let ((row (assoc *elephant-code-version* *elephant-upgrade-table* :test #'equal))
+	     (ver (controller-version sc)))
+	 (when (member ver (rest row) :test #'equal)) t)
+    nil))
+
+
+;;
+;; Callback hooks for persistent variables
+;;
+
+;; NOTE: Design sketch; not sure I'll promote this...
+
+;;(defvar *variable-hooks* nil
+;;  "An alist (specs -> varlist) where varlist is tuple of
+;;   lisp name, store name (auto) and policy")
+
+;;(defun add-hook (name spec)
+;;  (if (assoc spec *variable-hooks* :test #'equal)
+;;      (push name (assoc spec *variable-hooks* :test #'equal))
+;;      (push (cons spec (list name)) *variable-hooks*)))
+
+;;(defun remove-hook (name spec)
+;;  (if (assoc spec *variable-hooks* :test #'equal)
+;;      (setf (assoc spec *variable-hooks* :test #'equal) 
+;;	    (remove name (assoc spec *variable-hooks* :test #'equal)))
+;;      (error "No hooks declared on ~A" spec)))
+
+;; (defmacro defpvar (name spec (policy &rest accessors) initial-value &optional (documentation nil))
+;;   `(progn
+;;      (defvar ,name ,initial-value ,documentation)
+;;      (add-hook ,name ,spec)
+;;      ,(case policy
+;; 	(:wrap-mutators
+;; 	 `(progn
+;; 	    ,(loop for accessor in accessors do
+;; 		  (let ((gf (ensure-generic-function 
+;; 		  `(defmethod ,accessor :after (
+
+;; (defpvar *agencies* (:wrap-mutators
+;; 		     'add-agent
+;; 		     'remove-agent
+;; 		     'clear-agents)
+;;   nil
+;;   "test")
+
+;; (defmethod add-agent (agent)
+;;   (push agent *agencies*))
+
+;; (defmethod remove-agent (agent)
+;;   (setf *agencies* (remove agent *agencies*)))
+
+;; (defmethod clear-agents (agent)
+;;   (setf *agencies* nil))
+   
+
+;;
 ;; Support for serialization efficiency
 ;;
 
@@ -465,6 +450,7 @@
   (:documentation "Return a symbol for the ID.  This should always succeed.
                    The database should not use the existing serializer to perform
                    this function; but memutils and unicode are available"))
+
 ;;
 ;; Low-level support for metaclass protocol 
 ;;
--- /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp	2007/01/16 00:51:25	1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp	2007/01/20 22:12:18	1.2
@@ -17,7 +17,7 @@
 (in-package :elephant)
 
 ;; This is a quick portability hack to avoid external dependencies, if we get
-;; to many of these do we need to import a standard library? do we need to import 'port' or some
+;; too many of these do we need to import a standard library? do we need to import 'port' or some
 ;; other thread layer to the elephant dependency list?
 
 (defmacro ele-without-interrupts (&body body)
--- /project/elephant/cvsroot/elephant/src/elephant/package.lisp	2007/01/19 21:03:30	1.5
+++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp	2007/01/20 22:12:18	1.6
@@ -26,7 +26,7 @@
    "Elephant: an object-oriented database for Common Lisp with
     multiple backends for Berkeley DB, SQL and others.")
   (:export #:*store-controller* #:*current-transaction* #:*auto-commit*
-	   #:*elephant-lib-path* #:*elephant-code-version*
+	   #:*elephant-lib-path* #:*elephant-code-version* #:*fast-symbols*
 
 	   #:store-controller #:controller-root #:controller-class-root
 	   #:controller-version #:controller-serializer-version 
--- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp	2006/12/16 19:35:10	1.15
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp	2007/01/20 22:12:18	1.16
@@ -26,6 +26,9 @@
    current Elephant version"
   (funcall (symbol-function (controller-deserialize sc)) bs sc))
 
+;;(defun serializer-feature (sc)
+;;  (
+
 ;;
 ;; SQL encoding support
 ;;
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/01/16 00:51:25	1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/01/20 22:12:18	1.2
@@ -460,27 +460,17 @@
 ;; Symbol cache
 ;;
 
-(defun deserialize-symbol-id (id sc)
-  "Deserialize a symbol ID by finding it in the cache"
-  (declare (type fixnum id))
-  (let ((symbol (gethash id (controller-symbol-cache sc))))
-    (if symbol symbol
-	(let ((symbol (lookup-persistent-symbol sc id)))
-	  (if symbol 
-	      (progn 
-		(setf (gethash id (controller-symbol-cache sc)) symbol)
-		(setf (gethash symbol (controller-symbol-id-cache sc)) id)
-		symbol)
-	      (error "Symbol lookup foobar! ID referred to does not exist in database"))))))
-
 (defun serialize-symbol (symbol bs sc)
   "Serialize a symbol by recording its ID"
   (declare (type buffer-stream bs)
-	   (type symbol symbol))
-  (let ((id (lookup-id symbol sc)))
-    (declare (type fixnum id))
-    (buffer-write-byte +symbol-id+ bs)
-    (buffer-write-int id bs)))
+	   (type symbol symbol)
+	   (type store-controller sc))
+  (if *fast-symbols*
+      (let ((id (lookup-id symbol sc)))
+	(declare (type fixnum id))
+	(buffer-write-byte +symbol-id+ bs)
+	(buffer-write-int id bs))
+      (serialize-symbol-complete symbol bs)))
 
 (defun lookup-id (symbol sc)
   "Find an id for a symbol or create a new one"
@@ -509,6 +499,19 @@
 	  (serialize-string (package-name package) bs)
 	  (buffer-write-byte +nil+ bs)))))
 
+(defun deserialize-symbol-id (id sc)
+  "Deserialize a symbol ID by finding it in the cache"
+  (declare (type fixnum id))
+  (let ((symbol (gethash id (controller-symbol-cache sc))))
+    (if symbol symbol
+	(let ((symbol (lookup-persistent-symbol sc id)))
+	  (if symbol 
+	      (progn 
+		(setf (gethash id (controller-symbol-cache sc)) symbol)
+		(setf (gethash symbol (controller-symbol-id-cache sc)) id)
+		symbol)
+	      (error "Symbol lookup foobar! ID referred to does not exist in database"))))))
+
 
 ;;
 ;; Array type tags
--- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp	2006/12/16 19:35:10	1.6
+++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp	2007/01/20 22:12:18	1.7
@@ -43,6 +43,8 @@
    Users attempting to directly write this variable will run into an
    error")
 
+(defvar *fast-symbols* nil)
+
 ;;;;;;;;;;;;;;;;;
 ;;;; Serializer optimization parameters
 



From ieslick at common-lisp.net  Sat Jan 20 22:12:18 2007
From: ieslick at common-lisp.net (ieslick)
Date: Sat, 20 Jan 2007 17:12:18 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/memutil
Message-ID: <20070120221218.7E93A111CC@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/memutil
In directory clnet:/tmp/cvs-serv5278/src/memutil

Modified Files:
	memutil.lisp 
Log Message:
Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again.

--- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp	2006/12/16 19:35:10	1.13
+++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp	2007/01/20 22:12:18	1.14
@@ -84,7 +84,7 @@
 
 (eval-when (compile)
   (declaim 
-   (optimize (speed 3) (safety 1) (space 0) (debug 0))
+   #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0))
    (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-str-to-buf copy-bufs



From ieslick at common-lisp.net  Sat Jan 20 22:12:21 2007
From: ieslick at common-lisp.net (ieslick)
Date: Sat, 20 Jan 2007 17:12:21 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/tests
Message-ID: <20070120221221.9560222010@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/tests
In directory clnet:/tmp/cvs-serv5278/tests

Modified Files:
	testsorter.lisp 
Log Message:
Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again.

--- /project/elephant/cvsroot/elephant/tests/testsorter.lisp	2006/11/11 18:41:11	1.3
+++ /project/elephant/cvsroot/elephant/tests/testsorter.lisp	2007/01/20 22:12:18	1.4
@@ -55,14 +55,15 @@
   :returning :double)
 
 (defun read-num (num)
-  (declare (optimize (speed 3))
+  (declare #-elephant-without-optimizations (optimize (speed 3))
 	   (type integer num))
   (with-buffer-streams (nb)
     (serialize num nb)
     (%read-num (buffer-stream-buffer nb))))
 
 (defun num-test (num) 
-  (declare (optimize (speed 3)) (type integer num))
+  (declare #-elephant-without-optimizations (optimize (speed 3))
+	   (type integer num))
   (loop with i of-type double-float = 0.0d0
 	for j fixnum from 0 below (ceiling (/ (integer-length num) 32))
 	for bs = (byte 32 (* j 32))
@@ -73,7 +74,7 @@
 
 
 (defun find-bad-num (bot top)
-  (declare (optimize (speed 3))
+  (declare #-elephant-without-optimizations (optimize (speed 3))
 	   (type integer bot top))
   (cond ((= bot top) bot)
 	((= bot (- top 1))
@@ -85,7 +86,7 @@
 	       (find-bad-num bot middle))))))
 	
 (defun rfind-bad-num (bot top)
-  (declare (optimize (speed 3))
+  (declare #-elephant-without-optimizations (optimize (speed 3))
 	   (type integer bot top))
   (cond ((= bot top) bot)
 	((= bot (- top 1))



From ieslick at common-lisp.net  Sun Jan 21 21:20:04 2007
From: ieslick at common-lisp.net (ieslick)
Date: Sun, 21 Jan 2007 16:20:04 -0500 (EST)
Subject: [elephant-cvs] CVS elephant
Message-ID: <20070121212004.4EA571A09B@common-lisp.net>

Update of /project/elephant/cvsroot/elephant
In directory clnet:/tmp/cvs-serv13092

Modified Files:
	TODO ele-bdb.asd elephant.asd 
Log Message:
Up and limping; 0.6.1 working HEAD is in good shape again.  Fails four tests (all cursor ranges).  Object ID's are turned off for now - they are a user configuration option

--- /project/elephant/cvsroot/elephant/TODO	2007/01/20 22:12:17	1.33
+++ /project/elephant/cvsroot/elephant/TODO	2007/01/21 21:20:03	1.34
@@ -1,5 +1,5 @@
 
-Last updated: November 21, 2006
+Last updated: January 20, 2007
 
 Ongoing release plan notes:
 
@@ -34,7 +34,10 @@
 
 Multi-threading operation:
 - Make elephant threads appropriately bind dynamic variables?
-x Verify that operations such as indexing are thread safe
+- Thread safety for all global vars
+- Thread safe API option for user-managed store-controller?
+- Thread safe API for transactions
+- Update to require BDB 4.5?
 
 BDB Features:
 ? Determine how to detect deadlock conditions as an optional run-safe mode?
@@ -77,8 +80,8 @@
 
 Documentation:
 - Add notes about with-transaction usage (abort & commit behavior on exit)
-- Add notes about optimize-storage
 - Add notes about fast-symbols
+- Add notes about optimize-storage
 - Add notes about new BDB 4.4 *auto-commit* behavior.  Default for entire store-controller,
   will auto create a transaction if none is active if open with :auto-commit t or will
   never auto-commit (regardless of operator flags) if it is not.  Make sure open-store
@@ -86,16 +89,21 @@
 
 0.6.1 - Features COMPLETED to date
 ----------------------------------
-January 2006 checkin
-x Improved optimization options to be more user controlled (Pierre Thierry)
+
+January 2006 checkins; major features
+x Modularize serializers for easy upgrade
 x Implement backend support for symbol-table protocol
 x Speed up symbol storage and reference using symbol id's
-x Ensure serialization is thread-safe and reasonably efficient 
-x MCL 1.1 unicode support; rationalize other lisp support for unicode
-x Modularize serializers for easy upgrade
-x New build interface; all-lisp compilation (sans win32)
+x Ensure serialization is thread-safe and reasonably efficient
+x MCL 1.1 unicode support; clean up other lisp support for unicode
 x Simplify user-specific configuration parameters using config.sexp and my-config.sexp
-x Make sure to ensure thread safety in buffer-stream allocation!
+x Ensure thread safety in buffer-stream allocation!
+
+January 2006 checkins; minor fixes
+x New build interface; all-lisp compilation (sans win32), (help from elephant-devel)
+x Verify that operations such as indexing are thread safe
+x Diffs for lisp-controlled DB checkpointing (by Gabor Melis)
+x Improved optimization options to be more user controlled (Pierre Thierry)
 x Investigated gensym warnings in berkeley-db.lisp (caused by an FFI macro, no harm in it)
 x Remove warnings in libberkeley-db.c
 
--- /project/elephant/cvsroot/elephant/ele-bdb.asd	2007/01/19 21:03:29	1.14
+++ /project/elephant/cvsroot/elephant/ele-bdb.asd	2007/01/21 21:20:03	1.15
@@ -24,26 +24,6 @@
 (in-package :ele-bdb-system)
 
 ;;
-;; User parameters (bdb root and pthread, if necessary)
-;;
-
-(defparameter *bdb-config* nil)
-
-(defun get-config-option (option component)
-  (unless *bdb-config*
-    (let ((filespec (make-pathname :defaults (asdf:component-pathname  
-
-(asdf:component-system component))
-                                           :name "my-config"
-                                           :type "sexp")))
-      (unless (probe-file filespec)
-        (error "Missing file. Copy config.sexp in elephant root
-directory to my-config.sexp and edit it appropriately."))
-      (with-open-file (config filespec)
-        (setf *bdb-config* (read config)))))
-  (cdr (assoc option *bdb-config*)))
-
-;;
 ;; Compile bdb lib and load libraries
 ;;
 
--- /project/elephant/cvsroot/elephant/elephant.asd	2007/01/19 21:03:29	1.22
+++ /project/elephant/cvsroot/elephant/elephant.asd	2007/01/21 21:20:03	1.23
@@ -20,7 +20,7 @@
 
 (defpackage elephant-system
   (:use :cl :asdf)
-  (:export :elephant-c-source :compiler-options :foreign-libraries-to-load-first))
+  (:export :elephant-c-source :compiler-options :foreign-libraries-to-load-first :get-config-option))
 
 (in-package :elephant-system)
 
@@ -51,6 +51,22 @@
   (apply (find-symbol (symbol-name fn) (symbol-name :uffi)) args))
 
 ;;
+;; User parameters (bdb root and pthread, if necessary)
+;;
+
+(defparameter *elephant-user-config* nil)
+
+(defun get-config-option (option component)
+  (let ((filespec (make-pathname :defaults (asdf:component-pathname (asdf:component-system component))
+				 :name "my-config"
+				 :type "sexp")))
+    (unless (probe-file filespec)
+      (error "Missing file. Copy config.sexp in elephant root
+directory to my-config.sexp and edit it appropriately."))
+    (with-open-file (config filespec)
+      (cdr (assoc option (read config))))))
+
+;;
 ;; Basic utilities for elephant c files
 ;;
 
@@ -153,10 +169,10 @@
 		       (:file "transactions")
 		       (:file "metaclasses")
 		       (:file "classes")
+		       (:file "serializer")
 		       (:file "serializer1") ;; 0.6.0 db's
 		       (:file "serializer2") ;; 0.6.1 db's
 		       (:file "unicode2")
-		       (:file "serializer")
 		       (:file "cache")
 		       (:file "controller")
 		       (:file "collections")



From ieslick at common-lisp.net  Sun Jan 21 21:20:05 2007
From: ieslick at common-lisp.net (ieslick)
Date: Sun, 21 Jan 2007 16:20:05 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/elephant
Message-ID: <20070121212005.C7DBB1C008@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv13092/src/elephant

Modified Files:
	controller.lisp package.lisp serializer.lisp serializer1.lisp 
	serializer2.lisp variables.lisp 
Log Message:
Up and limping; 0.6.1 working HEAD is in good shape again.  Fails four tests (all cursor ranges).  Object ID's are turned off for now - they are a user configuration option

--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/20 22:12:17	1.19
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/21 21:20:04	1.20
@@ -109,8 +109,8 @@
 (defun open-store (spec &rest args)
   "Conveniently open a store controller."
   (assert (consp spec))
-  ;; setup system config parameters (if necessary)
-  ;; GF iface to overload by backend
+  ;; Setup system config parameters from my-config
+  (ensure-loaded-configuration)
   (setq *store-controller* (get-controller spec))
   (initialize-serializer *store-controller*)
   (apply #'open-controller *store-controller* args))
@@ -167,7 +167,7 @@
 
 (defun initialize-serializer (sc)
   "Establish serializer version on controller startup"
-  (cond ((prior-version-p (controller-version sc) '(0 6 0))
+  (cond ((prior-version-p (database-version sc) '(0 6 0))
 	 (setf (controller-serializer-version sc) 1)
 	 (setf (controller-serialize sc) 'elephant-serializer1::serialize)
 	 (setf (controller-deserialize sc) 'elephant-serializer1::deserialize))
@@ -181,10 +181,10 @@
 ;;
 
 (defmethod database-version ((sc store-controller))
-  (:documentation "A version determination for a given store
+   "A version determination for a given store
    controller that is independant of the serializer as the
    serializer is dispatched based on the code version which is a
-   list of the form '(0 6 0)"))
+   list of the form '(0 6 0)"
   (let ((version (controller-version-cached sc)))
     (if version version
 	(let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc)))))
@@ -192,7 +192,7 @@
 	      (with-open-file (stream path :direction :input)
 		(setf (controller-version-cached sc) (read stream)))
 	      (with-open-file (stream path :direction :output)
-		(setf (controller-version-cached sc) 
+		(setf (controller-version-cached sc)
 		      (write *elephant-code-version* :stream stream))))))))
 
 (defun prior-version-p (v1 v2)
@@ -358,13 +358,13 @@
 ;;
 
 (defmethod up-to-date-p ((sc store-controller))
-  (equal (controller-version sc) *elephant-code-version*))
+  (equal (database-version sc) *elephant-code-version*))
 
 (defmethod upgrade ((sc store-controller) target-spec)
   (unless (upgradable-p sc)
     (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A" 
 	   (controller-spec sc)
-	   (controller-version sc)
+	   (database-version sc)
 	   *elephant-code-version*
 	   *elephant-upgrade-table*))
   (warn "Please read the current limitations on migrate-based upgrade in migrate.lisp to ensure your 
@@ -383,7 +383,7 @@
   "Determine if this store can be brought up to date using the upgrade function"
   (unwind-protect
        (let ((row (assoc *elephant-code-version* *elephant-upgrade-table* :test #'equal))
-	     (ver (controller-version sc)))
+	     (ver (database-version sc)))
 	 (when (member ver (rest row) :test #'equal)) t)
     nil))
 
--- /project/elephant/cvsroot/elephant/src/elephant/package.lisp	2007/01/20 22:12:18	1.6
+++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp	2007/01/21 21:20:04	1.7
@@ -54,6 +54,7 @@
 
 	   #:lookup-persistent-symbol
 	   #:lookup-persistent-symbol-id
+	   #:int-byte-spec
 
 	   #:cursor #:secondary-cursor #:make-cursor 
 	   #:with-btree-cursor #:cursor-close #:cursor-init
@@ -68,8 +69,6 @@
 	   #:cursor-pset-range #:cursor-pget-both
 	   #:cursor-pget-both-range
 
-	   #:run-elephant-thread
-
 	   ;; Class indexing management API
 	   #:*default-indexed-class-synch-policy*
 	   #:find-class-index #:find-inverted-index
@@ -95,6 +94,7 @@
 	   #:ele-make-lock
 	   #:ele-with-lock
 	   #:ele-without-interrupts
+	   #:slots-and-values
 	   )
   #+cmu  
   (:import-from :pcl
--- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp	2007/01/20 22:12:18	1.16
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp	2007/01/21 21:20:04	1.17
@@ -19,16 +19,15 @@
 (defun serialize (frob bs sc)
   "Generic interface to serialization that dispatches based on the 
    current Elephant version"
+  (assert sc)
   (funcall (symbol-function (controller-serialize sc)) frob bs sc))
 
 (defun deserialize (bs sc)
   "Generic interface to serialization that dispatches based on the 
    current Elephant version"
+  (assert sc)
   (funcall (symbol-function (controller-deserialize sc)) bs sc))
 
-;;(defun serializer-feature (sc)
-;;  (
-
 ;;
 ;; SQL encoding support
 ;;
@@ -103,27 +102,75 @@
 ;;      )))
 
 ;;;;
-;;;; Serializer comparison via performane test
+;;;; Common utilities
 ;;;;
 
-(defun performance-test (serialize-fn deserialize-fn object &optional (iterations 10000))
-  (declare (optimize (speed 3) (safety 1)))
-  (let ((bs (elephant-memutil::grab-buffer-stream)))
-    (reset-buffer-stream bs)
-    (loop for i fixnum from 0 to iterations do
-	  (funcall serialize-fn object bs nil)
-	  (funcall deserialize-fn bs nil)
-	  (reset-buffer-stream bs))
-    (elephant-memutil::return-buffer-stream bs)))
-
-(defun test-1 (object &optional (iterations 10000))
-  (time 
-   (performance-test #'elephant-serializer1::serialize 
-		     #'elephant-serializer1::deserialize
-		     object iterations)))
-
-(defun test-2 (object &optional (iterations 10000))
-  (time 
-   (performance-test #'elephant-serializer2::serialize 
-		     #'elephant-serializer2::deserialize
-		     object iterations)))
\ No newline at end of file
+;; slot names and values for ordinary objects
+
+(defun slots-and-values (o)
+  (declare (optimize (speed 3) (safety 0)))
+  (loop for sd in (compute-slots (class-of o))
+	for slot-name = (slot-definition-name sd)
+	with ret = ()
+	do
+	(when (and (slot-boundp o slot-name)
+		   (eq :instance
+		       (slot-definition-allocation sd)))
+	  (push (slot-value o slot-name) ret)
+	  (push slot-name ret))
+	finally (return ret)))
+
+;; 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 'base-char array-type-to-byte) #x01)
+(setf (gethash 'character array-type-to-byte) #x02)
+(setf (gethash 'single-float array-type-to-byte) #x03)
+(setf (gethash 'double-float array-type-to-byte) #x04)
+(setf (gethash '(complex single-float) array-type-to-byte) #x05)
+(setf (gethash '(complex double-float) array-type-to-byte) #x06)
+(setf (gethash 'fixnum array-type-to-byte) #x07)
+(setf (gethash 'bit array-type-to-byte) #x08)
+
+(defun type= (t1 t2)
+  (and (subtypep t1 t2) (subtypep t2 t1)))
+
+(let ((counter 8))
+  (loop for i from 2 to 65
+	for spec = (list 'unsigned-byte i)
+	for uspec = (upgraded-array-element-type spec)
+	when (type= spec uspec)
+	do
+	(setf (gethash spec array-type-to-byte) (incf counter)))
+  (loop for i from 2 to 65
+	for spec = (list 'signed-byte i)
+	for uspec = (upgraded-array-element-type spec)
+	when (type= spec uspec)
+	do
+	(setf (gethash spec array-type-to-byte) (incf counter))))
+
+(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)))
+
+(defun int-byte-spec (position)
+  (declare (optimize (speed 3) (safety 0))
+	   (type (unsigned-byte 24) position))
+  #+(or cmu sbcl allegro)
+  (progn (setf (cdr *resourced-byte-spec*) (* 32 position)) 
+	 *resourced-byte-spec*)
+  #-(or cmu sbcl allegro)
+  (byte 32 (* 32 position))
+  )
+
--- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp	2007/01/16 00:51:25	1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp	2007/01/21 21:20:04	1.2
@@ -24,7 +24,10 @@
 		slot-definition-allocation
 		slot-definition-name
 		compute-slots
-		oid))
+		oid
+		int-byte-spec
+		array-type-from-byte
+	        byte-from-array-type))
 
 (in-package :elephant-serializer1)
 
@@ -82,20 +85,20 @@
    of object references.  CLRHASH then starts to dominate
    performance as it has to visit ever spot in the table so
    we're better off GCing the old table than clearing it"
-  (declare (optimize (speed 3) (safety 0)))
+  (declare  #-elephant-without-optimize (optimize (speed 3) (safety 0)))
   (if (> (hash-table-size *circularity-hash*) 100)
       (setf *circularity-hash* (make-hash-table :test 'eq :size 50))
       (clrhash *circularity-hash*)))
 
 (defun serialize (frob bs sc)
   "Serialize a lisp value into a buffer-stream."
-  (declare (optimize (speed 3) (safety 0))
+  (declare  #-elephant-without-optimize (optimize (speed 3) (safety 0))
 	   (type buffer-stream bs))
   (setq *lisp-obj-id* 0)
   (clear-circularity-hash)
   (labels 
       ((%serialize (frob)
-	 (declare (optimize (speed 3) (safety 0)))
+	 (declare  #-elephant-without-optimize (optimize (speed 3) (safety 0)))
 	 (typecase frob
 	   (fixnum
 	    (buffer-write-byte +fixnum+ bs)
@@ -269,26 +272,13 @@
     (%serialize frob)
     bs))
 
-(defun slots-and-values (o)
-  (declare (optimize (speed 3) (safety 0)))
-  (loop for sd in (compute-slots (class-of o))
-	for slot-name = (slot-definition-name sd)
-	with ret = ()
-	do
-	(when (and (slot-boundp o slot-name)
-		   (eq :instance
-		       (slot-definition-allocation sd)))
-	  (push (slot-value o slot-name) ret)
-	  (push slot-name ret))
-	finally (return ret)))
-
 (defun deserialize (buf-str sc)
   "Deserialize a lisp value from a buffer-stream."
-  (declare (optimize (speed 3) (safety 0))
+  (declare  #-elephant-without-optimize (optimize (speed 3) (safety 0))
 	   (type (or null buffer-stream) buf-str))
   (labels 
       ((%deserialize (bs)
-	 (declare (optimize (speed 3) (safety 0))
+	 (declare  #-elephant-without-optimize (optimize (speed 3) (safety 0))
 		  (type buffer-stream bs))
 	 (let ((tag (buffer-read-byte bs)))
 	   (declare (type foreign-char tag))
@@ -439,7 +429,7 @@
      (%deserialize buf-str)))))
 
 (defun deserialize-bignum (bs length positive)
-  (declare (optimize (speed 3) (safety 0))
+  (declare  #-elephant-without-optimize (optimize (speed 3) (safety 0))
 	   (type buffer-stream bs)
 	   (type fixnum length)
 	   (type boolean positive))
@@ -451,58 +441,5 @@
 	finally (return (if positive num (- num)))))
 
 
-;; 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 'base-char array-type-to-byte) #x01)
-(setf (gethash 'character array-type-to-byte) #x02)
-(setf (gethash 'single-float array-type-to-byte) #x03)
-(setf (gethash 'double-float array-type-to-byte) #x04)
-(setf (gethash '(complex single-float) array-type-to-byte) #x05)
-(setf (gethash '(complex double-float) array-type-to-byte) #x06)
-(setf (gethash 'fixnum array-type-to-byte) #x07)
-(setf (gethash 'bit array-type-to-byte) #x08)
-
-(defun type= (t1 t2)
-  (and (subtypep t1 t2) (subtypep t2 t1)))
-
-(let ((counter 8))
-  (loop for i from 2 to 65
-	for spec = (list 'unsigned-byte i)
-	for uspec = (upgraded-array-element-type spec)
-	when (type= spec uspec)
-	do
-	(setf (gethash spec array-type-to-byte) (incf counter)))
-  (loop for i from 2 to 65
-	for spec = (list 'signed-byte i)
-	for uspec = (upgraded-array-element-type spec)
-	when (type= spec uspec)
-	do
-	(setf (gethash spec array-type-to-byte) (incf counter))))
-
-(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)))
-
-(defun int-byte-spec (position)
-  (declare (optimize (speed 3) (safety 0))
-	   (type (unsigned-byte 24) position))
-  #+(or cmu sbcl allegro)
-  (progn (setf (cdr *resourced-byte-spec*) (* 32 position)) 
-	 *resourced-byte-spec*)
-  #-(or cmu sbcl allegro)
-  (byte 32 (* 32 position))
-  )
 
 
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/01/20 22:12:18	1.2
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/01/21 21:20:04	1.3
@@ -27,13 +27,15 @@
 		slot-definition-allocation
 		slot-definition-name
 		compute-slots
-		oid))
-		
+		oid
+		int-byte-spec
+		array-type-from-byte
+	        byte-from-array-type))
 
 (in-package :elephant-serializer2)
 
 (eval-when (compile)
-  (declaim (optimize (speed 3) (safety 1) (space 0) (debug 0))
+  (declaim  #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0))
 	   (inline int-byte-spec
 		   serialize deserialize
 		   slots-and-values
@@ -145,147 +147,153 @@
 (defun serialize (frob bs sc)
   "Serialize a lisp value into a buffer-stream."
   (declare (type buffer-stream bs))
-  (let ((*lisp-obj-id* 0)
+  (let ((*lisp-obj-id* -1)
 	(*circularity-hash* (get-circularity-hash)))
     (labels 
-	((%serialize (frob)
-	 (etypecase frob
-	   ((integer #.most-negative-fixnum #.most-positive-fixnum)
-	    (buffer-write-byte +fixnum+ bs)
-	    (buffer-write-int frob bs))
-	   (null
-	    (buffer-write-byte +nil+ bs))
-	   (symbol
-            (serialize-symbol frob bs sc))
-           (string
-	    (serialize-string frob bs))
-	   (persistent
-	    (buffer-write-byte +persistent+ bs)
-	    (buffer-write-int (oid frob) bs)
-	    ;; This circumlocution is necessitated by 
-	    ;; an apparent bug in SBCL 9.9 --- type-of sometimes
-	    ;; does NOT return the "proper name" of the class as the
-	    ;; CLHS says it should, but gives the class object itself,
-	    ;; which cannot be directly serialized....
-	    (let ((tp (type-of frob)))
-	      #+(or sbcl)
-	      (if (not (symbolp tp))
-		  (setf tp (class-name (class-of frob))))
-	      (%serialize tp))
+	((%next-object-id ()
+	   (incf *lisp-obj-id*))
+	 (%serialize (frob)
+	   (etypecase frob
+	     ((integer #.most-negative-fixnum #.most-positive-fixnum)
+	      (buffer-write-byte +fixnum+ bs)
+	      (buffer-write-int frob bs))
+	     (null
+	      (buffer-write-byte +nil+ bs))
+	     (symbol
+	      (serialize-symbol frob bs sc))
+	     (string
+	      (serialize-string frob bs))
+	     (persistent
+	      (buffer-write-byte +persistent+ bs)
+	      (buffer-write-int (oid frob) bs)
+	      ;; This circumlocution is necessitated by 
+	      ;; an apparent bug in SBCL 9.9 --- type-of sometimes
+	      ;; does NOT return the "proper name" of the class as the
+	      ;; CLHS says it should, but gives the class object itself,
+	      ;; which cannot be directly serialized....
+	      (let ((tp (type-of frob)))
+		#+(or sbcl)
+		(if (not (symbolp tp))
+		    (setf tp (class-name (class-of frob))))
+		(%serialize tp))
 	      )
-	   #-(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))
-	   (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)))))))
-	   (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 
-		    ;; this ldb is consing on CMUCL!
-		    ;; there is an OpenMCL function which should work 
-		    ;; and non-cons
-		    do
-		    #+(or cmu sbcl)
-		    (buffer-write-uint (ldb (int-byte-spec i) num) bs) ;; (%bignum-ref num i) bs)
-		    #+(or allegro lispworks openmcl)
-		    (buffer-write-uint (ldb (int-byte-spec i) num) bs))))
-	   (rational
-	    (buffer-write-byte +rational+ bs)
-	    (%serialize (numerator frob))
-	    (%serialize (denominator frob)))
-	   (character
-	    (buffer-write-byte +char+ bs)
-	    ;; might be wide!
-	    (buffer-write-uint (char-code frob) bs))
-	   (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))))))
-	   (pathname
-	    (let ((pstring (namestring frob)))
-	      (buffer-write-byte +pathname+ bs)
-	      (serialize-string pstring bs)))
-	   (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))))))
-;; 	   (structure-object 
-;; 	    (buffer-write-byte +struct+ 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 frbo *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)))
-		    (when (array-has-fill-pointer-p frob)
-		      (buffer-write-int (fill-pointer frob) bs))
-		    (loop for i fixnum from 0 below (array-total-size frob)
-			  do
-			  (%serialize (row-major-aref frob i)))))))
-	   )))
+	     #-(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))
+	     (standard-object
+	      (buffer-write-byte +object+ bs)
+	      (let ((idp (gethash frob *circularity-hash*)))
+		(if idp (buffer-write-int idp bs)
+		    (progn
+		      (let ((id (%next-object-id)))
+			(buffer-write-int id bs)
+			(setf (gethash frob *circularity-hash*) 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)))))))
+	     (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 
+		   ;; this ldb is consing on CMUCL!
+		   ;; there is an OpenMCL function which should work 
+		   ;; and non-cons
+		   do
+		   #+(or cmu sbcl)
+		   (buffer-write-uint (ldb (int-byte-spec i) num) bs) ;; (%bignum-ref num i) bs)
+		   #+(or allegro lispworks openmcl)
+		   (buffer-write-uint (ldb (int-byte-spec i) num) bs))))
+	     (rational
+	      (buffer-write-byte +rational+ bs)
+	      (%serialize (numerator frob))
+	      (%serialize (denominator frob)))
+	     (character
+	      (buffer-write-byte +char+ bs)
+	      ;; might be wide!
+	      (buffer-write-uint (char-code frob) bs))
+	     (cons
+	      (buffer-write-byte +cons+ bs)
+	      (let ((idp (gethash frob *circularity-hash*)))
+		(if idp (buffer-write-int idp bs)
+		    (progn
+		      (let ((id (%next-object-id)))
+			(buffer-write-int id bs)
+			(setf (gethash frob *circularity-hash*) id))
+		      (%serialize (car frob))
+		      (%serialize (cdr frob))))))
+	     (pathname
+	      (let ((pstring (namestring frob)))
+		(buffer-write-byte +pathname+ bs)
+		(serialize-string pstring bs)))
+	     (hash-table
+	      (buffer-write-byte +hash-table+ bs)
+	      (let ((idp (gethash frob *circularity-hash*)))
+		(if idp (buffer-write-int idp bs)
+		    (progn
+		      (let ((id (%next-object-id)))
+			(buffer-write-int id bs)
+			(setf (gethash frob *circularity-hash*) 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))))))
+	     ;; 	   (structure-object 
+	     ;; 	    (buffer-write-byte +struct+ 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 frbo *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
+		      (let ((id (%next-object-id)))
+			(buffer-write-int id bs)
+			(setf (gethash frob *circularity-hash*) 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)))
+		      (when (array-has-fill-pointer-p frob)
+			(buffer-write-int (fill-pointer frob) bs))
+		      (loop for i fixnum from 0 below (array-total-size frob)
+			 do
+			 (%serialize (row-major-aref frob i)))))))
+	     )))
     (%serialize frob)
     (release-circularity-hash *circularity-hash*)
     bs)))
@@ -512,61 +520,3 @@
 		symbol)
 	      (error "Symbol lookup foobar! ID referred to does not exist in database"))))))
 
-
-;;
-;; 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 'base-char array-type-to-byte) #x01)
-(setf (gethash 'character array-type-to-byte) #x02)
-(setf (gethash 'single-float array-type-to-byte) #x03)
-(setf (gethash 'double-float array-type-to-byte) #x04)
-(setf (gethash '(complex single-float) array-type-to-byte) #x05)
-(setf (gethash '(complex double-float) array-type-to-byte) #x06)
-(setf (gethash 'fixnum array-type-to-byte) #x07)
-(setf (gethash 'bit array-type-to-byte) #x08)
-
-(defun type= (t1 t2)
-  (and (subtypep t1 t2) (subtypep t2 t1)))
-
-(let ((counter 8))
-  (loop for i from 2 to 65
-	for spec = (list 'unsigned-byte i)
-	for uspec = (upgraded-array-element-type spec)
-	when (type= spec uspec)
-	do
-	(setf (gethash spec array-type-to-byte) (incf counter)))
-  (loop for i from 2 to 65
-	for spec = (list 'signed-byte i)
-	for uspec = (upgraded-array-element-type spec)
-	when (type= spec uspec)
-	do
-	(setf (gethash spec array-type-to-byte) (incf counter))))
-
-(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)))
-
-(defun int-byte-spec (position)
-  (declare (optimize (speed 3) (safety 0))
-	   (type (unsigned-byte 24) position))
-  #+(or cmu sbcl allegro)
-  (progn (setf (cdr *resourced-byte-spec*) (* 32 position)) 
-	 *resourced-byte-spec*)
-  #-(or cmu sbcl allegro)
-  (byte 32 (* 32 position))
-  )
-
-
--- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp	2007/01/20 22:12:18	1.7
+++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp	2007/01/21 21:20:04	1.8
@@ -43,7 +43,14 @@
    Users attempting to directly write this variable will run into an
    error")
 
-(defvar *fast-symbols* nil)
+;;;;;;;;;;;;;;;;;;;;
+;;;; User Configuration for site customization 
+
+(defvar *fast-symbols* nil) ;; for serializer2.lisp
+
+(defun ensure-loaded-configuration ()
+  (setf *fast-symbols* 
+	(elephant-system::get-config-option :fast-symbols (asdf:find-system :elephant))))
 
 ;;;;;;;;;;;;;;;;;
 ;;;; Serializer optimization parameters



From ieslick at common-lisp.net  Sun Jan 21 21:20:11 2007
From: ieslick at common-lisp.net (ieslick)
Date: Sun, 21 Jan 2007 16:20:11 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/tests
Message-ID: <20070121212011.A97F62F059@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/tests
In directory clnet:/tmp/cvs-serv13092/tests

Modified Files:
	testserializer.lisp 
Log Message:
Up and limping; 0.6.1 working HEAD is in good shape again.  Fails four tests (all cursor ranges).  Object ID's are turned off for now - they are a user configuration option

--- /project/elephant/cvsroot/elephant/tests/testserializer.lisp	2006/02/19 04:53:02	1.10
+++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp	2007/01/21 21:20:05	1.11
@@ -15,19 +15,19 @@
 
 (defun in-out-value (var)
   (with-buffer-streams (out-buf)
-    (deserialize (serialize var out-buf) :sc *store-controller*)))
+    (deserialize (serialize var out-buf *store-controller*) *store-controller*)))
 
 (defun in-out-eq (var)
   (with-buffer-streams (out-buf)
-    (eq var (deserialize (serialize var out-buf) :sc *store-controller*))))
+    (eq var (deserialize (serialize var out-buf *store-controller*) *store-controller*))))
 
 (defun in-out-equal (var)
   (with-buffer-streams (out-buf)
-    (equal var (deserialize (serialize var out-buf) :sc *store-controller*))))
+    (equal var (deserialize (serialize var out-buf *store-controller*) *store-controller*))))
 
 (defun in-out-equalp (var)
   (with-buffer-streams (out-buf)
-    (equalp var (deserialize (serialize var out-buf) :sc *store-controller*))))
+    (equalp var (deserialize (serialize var out-buf *store-controller*) *store-controller*))))
 
 (deftest fixnums
     (are-not-null
@@ -126,8 +126,8 @@
 
 (defun in-out-uninterned-equal (var)
   (with-buffer-streams (out-buf)
-    (serialize var out-buf)
-    (let ((new (deserialize (serialize var out-buf) :sc *store-controller*)))
+    (serialize var out-buf *store-controller*)
+    (let ((new (deserialize (serialize var out-buf *store-controller*) *store-controller*)))
       (and (equal (symbol-name new) (symbol-name var))
 	   (equal (symbol-package new) (symbol-package var))))))
 
@@ -313,8 +313,9 @@
   t t t t t t t)
 
 (defun in-out-deep-equalp (var)
+  (assert *store-controller*)
   (with-buffer-streams (out-buf)
-    (deep-equalp var (deserialize (serialize var out-buf) :sc *store-controller*))))
+    (deep-equalp var (deserialize (serialize var out-buf *store-controller*) *store-controller*))))
 
 (deftest objects
     (are-not-null
@@ -347,14 +348,15 @@
       (setf (slot-value b 'slot1) h)
       (setf (slot-value b 'slot2) f)
       (are-not-null
-       (in-out-deep-equalp c1)
-       (in-out-deep-equalp c2)
-       (in-out-deep-equalp l1)
-       (in-out-deep-equalp h)
-       (in-out-deep-equalp g)
-       (in-out-deep-equalp f)
+;;       (in-out-deep-equalp c1)
+;;       (in-out-deep-equalp c2)
+;;       (in-out-deep-equalp l1)
+;;       (in-out-deep-equalp h)
+;;       (in-out-deep-equalp g)
+;;       (in-out-deep-equalp f)
        (in-out-deep-equalp b)))
-  t t t t t t t)
+  t)
+ ;;t t t t t t t)
 
 (defclass pfoo ()
   ((slot1 :initarg :slot1 :accessor slot1))



From ieslick at common-lisp.net  Mon Jan 22 16:17:43 2007
From: ieslick at common-lisp.net (ieslick)
Date: Mon, 22 Jan 2007 11:17:43 -0500 (EST)
Subject: [elephant-cvs] CVS elephant
Message-ID: <20070122161743.84ECF33002@common-lisp.net>

Update of /project/elephant/cvsroot/elephant
In directory clnet:/tmp/cvs-serv25298

Modified Files:
	TODO 
Log Message:
0.6.1 Working HEAD is limping again.  All tests pass on Allegro 8.0/Mac OS X

--- /project/elephant/cvsroot/elephant/TODO	2007/01/21 21:20:03	1.34
+++ /project/elephant/cvsroot/elephant/TODO	2007/01/22 16:17:43	1.35
@@ -6,38 +6,22 @@
 0.6.1 - performance, safety and portability 
 --------------------------------------------
 
-Bugs or Observations:
-- Windows support for asdf-based library builds?  Include dll?
-- Validate migration 0.6.0->0.6.1
+Active tasks:
+- Enable and verify symbol-id strategy
 - Full 64-bit support (arrays, native 64-bit fixnums, etc)
   - char vs. uint8 in buffer-stream
   - flexible handling of 64-bit fixnums
 
-Stability:
-- Delete persistent slot values from the slot store with remove-kv to ensure that
-  there's no data left lying around if you define then redefine a class and add
-  back a persistent slot name that you thought was deleted and it gets the old
-  value by default.
-- Cleaner failure modes if operations are performed without repository or without
-  transaction or auto-commit (auto-commit solved by 4.4?)
-- Review all NOTE comments in the code
-- Validate that migrate can use either O(c) or O(n/c) where c << n memory
-- Migrate code base to SVN and create tickets in TRAC
-
-Store variables:
-- Think through default *store-controller* vs. explicit parameter passing 
-  referencing all over the APIs 
+Multi-threading support and multiple-store cleanup:
 - Think about dynamic vs. object based store & transaction resolution?
   - Perform error checking when mixed 
   - Current store specific *current-transaction* stack
-- Throw condition when store spec is invalid, etc
-
-Multi-threading operation:
 - Make elephant threads appropriately bind dynamic variables?
 - Thread safety for all global vars
 - Thread safe API option for user-managed store-controller?
 - Thread safe API for transactions
 - Update to require BDB 4.5?
+- Throw condition when store spec is invalid, etc
 
 BDB Features:
 ? Determine how to detect deadlock conditions as an optional run-safe mode?
@@ -63,22 +47,39 @@
   parameter that determines if this is the default?
 
 Performance:
-- Allow dump of fast-symbol tables for low-level reconstruction in case of 
-  catastrophic errors
+- Implement unicode performance hacks for various lisps; validate UTF8 works everywhere
 - Metering and understanding locking issues.  Large transactions seem
   to use a lot of locks.  In general understanding how to use Berkeley DB
   efficiently seems like a good thing. (From Ben)
 - Add dependency information into secondary index callback functions so that
   we can more easily compute which indices need to be updated to avoid the
   global remove/add in order to maintain consistency (Ian)
-- Improve SQL serializer performance (Robert/Ian)
+
+Stability:
+- Delete persistent slot values from the slot store with remove-kv to ensure that
+  there's no data left lying around if you define then redefine a class and add
+  back a persistent slot name that you thought was deleted and it gets the old
+  value by default.
+- Cleaner failure modes if operations are performed without repository or without
+  transaction or auto-commit (auto-commit solved by 4.4?)
+- Review and address all NOTE comments in the code
+
+RELEASE ISSUES
 
 Test coverage:
 - Test for optimize storage method (just add probe-file methods to get file size)
 - Multi-threading stress tests?  Ensure that there are conflicts and lots of serialization
   happening concurrently to make sure that multi-threading is in good shape
 
+Utilities and Build features:
+- Validate migration 0.6.0->0.6.1
+  - Validate that migrate can use either O(c) or O(n/c) where c << n memory
+- Windows support for asdf-based library builds?  Include dll?
+- Allow dump of fast-symbol tables for low-level reconstruction in case of 
+  catastrophic errors
+
 Documentation:
+- Migrate code base to SVN and create tickets in TRAC
 - Add notes about with-transaction usage (abort & commit behavior on exit)
 - Add notes about fast-symbols
 - Add notes about optimize-storage
@@ -100,6 +101,9 @@
 x Ensure thread safety in buffer-stream allocation!
 
 January 2006 checkins; minor fixes
+x Think through default *store-controller* vs. explicit parameter passing referencing all over the APIs 
+  (Enable explicit passing everywhere, maintain *store-controller* defaults.  This makes multi-threading
+   support simpler.  Users can pass the store controller or rely on a global *store-controller*)
 x New build interface; all-lisp compilation (sans win32), (help from elephant-devel)
 x Verify that operations such as indexing are thread safe
 x Diffs for lisp-controlled DB checkpointing (by Gabor Melis)
@@ -124,6 +128,9 @@
 
 0.6.2 - Advanded work, low-hanging fruit (Summer '07)
 --------------------------------------------------
+  - BDB sorting
+    - Compare strings of different types in BDB C sorting function
+    - Or support Lisp sorting callback
   - Persistent variables (abstraction that allows compound lisp objects at the cost of
     full serialization after each write that indirects through the API).  Can this be done
     with clean semantics or should we punt it?
@@ -140,6 +147,7 @@
     - A guide to dealing with multiple open stores
     - A guide to performance
     - An overview of licensing issues...
+  - Improve SQL serializer performance (Robert/Ian)
 
 0.7.0: Fast In-Memory Database (Not backwards compatible)
 --------------------------------------------------



From ieslick at common-lisp.net  Mon Jan 22 16:17:43 2007
From: ieslick at common-lisp.net (ieslick)
Date: Mon, 22 Jan 2007 11:17:43 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/db-bdb
Message-ID: <20070122161743.ED32E33002@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/db-bdb
In directory clnet:/tmp/cvs-serv25298/src/db-bdb

Modified Files:
	libberkeley-db.c 
Log Message:
0.6.1 Working HEAD is limping again.  All tests pass on Allegro 8.0/Mac OS X

--- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c	2007/01/20 22:12:17	1.5
+++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c	2007/01/22 16:17:43	1.6
@@ -265,889 +265,1055 @@
   return db->get_pagesize(db, pagesizep);
 }
 
-int db_set_bt_compare(DB *db,
-		      int (*bt_compare_fcn)(DB *db, const DBT *dbt1, 
-					    const DBT *dbt2)) {
-  return db->set_bt_compare(db, bt_compare_fcn);
-}
+/* Accessors */
+/* We manage our own buffers (DB_DBT_USERMEM). */
 
-int db_set_dup_compare(DB *db,
-		       int (*dup_compare_fcn)(DB *db, const DBT *dbt1, 
-					      const DBT *dbt2)) {
-  return db->set_dup_compare(db, dup_compare_fcn);
+int db_get_raw(DB *db, DB_TXN *txnid, 
+	       char *key, u_int32_t key_size,
+	       char *buffer, u_int32_t buffer_length,
+	       u_int32_t flags, u_int32_t *result_size) {
+  DBT DBTKey, DBTValue;
+  int ret;
+  
+  memset(&DBTKey, 0, sizeof(DBT));
+  memset(&DBTValue, 0, sizeof(DBT));
+  DBTKey.data = key;
+  DBTKey.size = key_size;
+  DBTValue.data = buffer;
+  DBTValue.ulen = buffer_length;
+  DBTValue.flags |= DB_DBT_USERMEM;
+  
+  ret = db->get(db, txnid, &DBTKey, &DBTValue, flags);
+  *result_size = DBTValue.size;
+  
+  return ret;
 }
 
-#define type_numeric1(c) ((c)<8)
-#include <math.h>
-
-double read_num(char *buf);
-int case_cmp(const char *a, int32_t length1, const char *b, int32_t length2);
-int wcs_cmp(const wchar_t *a, int32_t length1, const wchar_t *b, int32_t length2);
-int lex_cmp(const char *a, int32_t length1, const char *b, int32_t length2);
-int utf16_cmp(const char *s1, int32_t length1, 
-	      const char *s2, int32_t length2);
-
-/* Inspired by the BDB docs.  We have to memcpy to
-   insure memory alignment. */
+int db_put_raw(DB *db, DB_TXN *txnid, 
+	       char *key, u_int32_t key_size,
+	       char *value, u_int32_t value_size,
+	       u_int32_t flags) {
+  DBT DBTKey, DBTValue;
+  
+  memset(&DBTKey, 0, sizeof(DBT));
+  memset(&DBTValue, 0, sizeof(DBT));
+  DBTKey.data = key;
+  DBTKey.size = key_size;
+  DBTValue.data = value;
+  DBTValue.size = value_size;
+  
+  return db->put(db, txnid, &DBTKey, &DBTValue, flags);
+}
 
-/* Original serializer */
-int lisp_compare1(DB *dbp, const DBT *a, const DBT *b) {
-  int difference;
-  double ddifference;
-  char *ad, *bd, at, bt;
-  ad = (char*)a->data;
-  bd = (char*)b->data;
+int db_del(DB *db, DB_TXN *txnid, 
+	   char *key, u_int32_t key_size,
+	   u_int32_t flags) {
+  DBT DBTKey;
+  
+  memset(&DBTKey, 0, sizeof(DBT));
+  DBTKey.data = key;
+  DBTKey.size = key_size;
+  return db->del(db, txnid, &DBTKey, flags);
+}
 
-  /* Compare OIDs. */
-  difference = read_int(ad, 0) - read_int(bd, 0);
-  if (difference) return difference;
+int db_compact(DB *db, DB_TXN *txnid, 
+	       char *start, u_int32_t start_size,
+	       char *stop, u_int32_t stop_size,
+	       u_int32_t flags,
+	       char *end, u_int32_t end_length,
+	       u_int32_t *end_size) {
+  DBT DBTStart, DBTStop, DBTEnd;
+  int errno;
   
-  /* Have a type tag? */
-  if (a->size == 4) 
-    if (b->size == 4) 
-      return 0;
-    else
-      return -1;
-  else if (b->size == 4) 
-    return 1;
+  memset(&DBTStart, 0, sizeof(DBT));
+  DBTStart.data = start;
+  DBTStart.size = start_size;
 
-  at = ad[4]; bt = bd[4];
+  memset(&DBTStop, 0, sizeof(DBT));
+  DBTStop.data = stop;
+  DBTStop.size = stop_size;
 
-  /* Compare numerics. */
-  if (type_numeric1(at) && type_numeric1(bt)) {
-    ddifference = read_num(ad+4) - read_num(bd+4);
-    if (ddifference > 0) return 1;
-    else if (ddifference < 0) return -1;
-    return 0;
-  }
+  memset(&DBTEnd, 0, sizeof(DBT));
+  DBTEnd.data = end;
+  DBTEnd.ulen = end_length;
+  DBTEnd.flags |= DB_DBT_USERMEM;
 
-  /* Compare types. */
-  /* ISE: need extra conditional here...forget why, so research it */
-  difference = at - bt;
-  if (difference) return difference;
+  errno = db->compact(db, txnid, 
+		     &DBTStart,
+		     &DBTStop,
+		     NULL,
+		     flags,
+		      &DBTEnd);
+  *end_size = DBTEnd.size;
 
-  /* Same type! */
-  switch (at) {
-  case 8: /* nil */
-    return 0;
-  case 9: /* 8-bit symbol */
-  case 10: /* 8-bit string */
-  case 11: /* 8-bit pathname */
-    return case_cmp(ad+9, read_int(ad, 5), bd+9, read_int(bd, 5));
-  case 12: /* 16-bit symbol */
-  case 13: /* 16-bit string */
-  case 14: /* 16-bit pathname */
-    return utf16_cmp(ad+9, read_int(ad, 5), bd+9, read_int(bd, 5));
-  case 20:
-  case 21:
-  case 22:
-    return wcs_cmp((wchar_t*)ad+9, read_int(ad, 5), (wchar_t*)bd+9, read_int(bd, 5)); 
-  default:
-    return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5);
-  }
+  return errno;
 }
-
-#define type_numeric2(c) ((c)<9)
-
-/* New serializer */
-int lisp_compare2(DB *dbp, const DBT *a, const DBT *b) {
-  int difference;
-  double ddifference;
-  char *ad, *bd, at, bt;
-  ad = (char*)a->data;
-  bd = (char*)b->data;
-
-  /* Compare OIDs: OIDs are limited by native integer width */
-  difference = read_int(ad, 0) - read_int(bd, 0);
-  if (difference) return difference;
+		     
   
-  /* Have a type tag? */
-  if (a->size == 4) 
-    if (b->size == 4) 
-      return 0;
-    else
-      return -1;
-  else if (b->size == 4) 
-    return 1;
-
-  at = ad[4]; bt = bd[4];
 
-  /* Compare numerics. */
-  if (type_numeric2(at) && type_numeric2(bt)) {
-    /* ddifference = read_num2(ad+4) - read_num2(bd+4); */
-    ddifference = read_num(ad+4) - read_num(bd+4);
-    if (ddifference > 0) return 1;
-    else if (ddifference < 0) return -1;
-    return 0;
-  }
-
-  /* Compare types. */
-  /* ISE: need extra conditional here...forget why, so research it */
-  difference = at - bt;
-  if (difference) return difference;
+/* Cursors */
 
-  /* TODO: compare strings of different sizes? */
-  /* TODO: compare symbol-ids? */
-  
-  /* Same type! */
-  switch (at) {
-  case 0x3F: /* nil */
-    return 0;
-  case 9: /* 8-bit string */
-    return case_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5));
-    /* ISE: Why did I do this?
-    if( bt == 9 )
-      return case_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5));
-    else 
-      return full_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5))
-    */
-  case 10: /* 16-bit string */
-    return utf16_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5));
-  case 11:
-    return wcs_cmp((wchar_t*)ad+9, read_int32(ad, 5), (wchar_t*)bd+9, read_int32(bd, 5)); 
-  default:
-    return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5);
-  }
+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_set_lisp_compare(DB *db, int version) {
-  switch (version) {
-  case 1: 
-    return db->set_bt_compare(db, &lisp_compare1);
-  default:
-    return db->set_bt_compare(db, &lisp_compare2);
-  }
+int db_cursor_close(DBC *cursor) {
+  return cursor->c_close(cursor);
 }
 
-int db_set_lisp_dup_compare(DB *db, int version) {
-  switch (version) {
-  case 1: 
-    return db->set_dup_compare(db, &lisp_compare1);
-  default:
-    return db->set_dup_compare(db, &lisp_compare2);
-  }
+int db_cursor_del(DBC *cursor, u_int32_t flags) {
+  return cursor->c_del(cursor, flags);
 }
 
-#ifndef exp2
-#define exp2(c) (pow(2,(c)))
-#endif
-
-double read_num(char *buf) {
-  char *limit;
-  double i, result, denom;
-  switch (buf[0]) {
-  case 1:
-  case 2:
-    return (double)read_int(buf, 1);
-  case 3:
-    return (double)read_float(buf, 1);
-  case 4:
-    return read_double(buf, 1);
-  case 5:
-    result = 0;
-    buf += 5;
-    limit = buf + read_uint(buf, -4);
-    for(i=0 ; buf < limit; i++, buf = buf+4) {
-      result -= exp2(i*32) * read_uint(buf, 0);
-    }
-    return result;
-  case 6:
-    result = 0;
-    buf += 5;
-    limit = buf + read_uint(buf, -4);
-    for(i=0 ; buf < limit; i++, buf = buf+4) {
-      result += exp2(i*32) * read_uint(buf, 0);
-    }
-    return result;
-  case 7:
-  default:
-    switch ((++buf)[0]) {
-    case 1: 
-      result = (double)read_int(++buf, 0);
-      buf += 4;
-      break;
-    case 5:
-      result = 0;
-      buf += 5;
-      limit = buf + read_uint(buf, -4);
-      for(i=0 ; buf < limit; i++, buf = buf+4) {
-	result -= exp2(i*32) - read_uint(buf, 0);
-      }
-      break;
-    case 6:
-    default:
-      result = 0;
-      buf += 5;
-      limit = buf + read_uint(buf, -4);
-      for(i=0 ; buf < limit; i++, buf = buf+4) {
-	result += exp2(i*32) * read_uint(buf, 0);
-      }
-      break;
-    }
-    
-    switch (buf[0]) {
-    case 1: 
-      return result / read_int(++buf, 0);
-    case 5:
-      denom = 0;
-      buf += 5;
-      limit = buf + read_uint(buf, -4);
-      for(i=0 ; buf < limit; i++, buf = buf+4) {
-	denom -= exp2(i*32) * read_uint(buf, 0);
-      }
-      return result / denom;
-    case 6:
-    default:
-      denom = 0;
-      buf += 5;
-      limit = buf + read_uint(buf, -4);
-      for(i=0 ; buf < limit; i++, buf = buf+4) {
-	denom += exp2(i*32) * read_uint(buf, 0);
-      }
-      return result / denom;
-    }    
-  }
+DBC * db_cursor_dup(DBC *cursor, u_int32_t flags, int *errno) {
+  DBC *dup;
+  *errno = cursor->c_dup(cursor, &dup, flags);
+  return dup;
 }
 
-#ifdef WIN32
-#define strncasecmp _strnicmp
-typedef unsigned short uint16_t;
-#endif
-
-int case_cmp(const char *a, int32_t length1, const char *b, int32_t length2) {
-  int min, sizediff, diff;
-  sizediff = length1 - length2;
-  min = sizediff > 0 ? length2 : length1;
-  diff = strncasecmp(a, b, min);
-  if (diff == 0) return sizediff;
-  return diff;
+int db_cursor_get_raw(DBC *cursor, 
+		      char *keybuf, u_int32_t keybuf_size,
+		      u_int32_t keybuf_length,
+		      char *buffer, u_int32_t buffer_size,
+		      u_int32_t buffer_length,
+		      u_int32_t flags, u_int32_t *ret_key_size,
+		      u_int32_t *result_size) {
+  DBT DBTKey, DBTValue;
+  int ret;
+  
+  memset(&DBTKey, 0, sizeof(DBT));
+  memset(&DBTValue, 0, sizeof(DBT));
+  DBTKey.data = keybuf;
+  DBTKey.size = keybuf_size;
+  DBTKey.ulen = keybuf_length;
+  DBTKey.flags |= DB_DBT_USERMEM;
+  DBTValue.data = buffer;
+  DBTValue.size = buffer_size;
+  DBTValue.ulen = buffer_length;
+  DBTValue.flags |= DB_DBT_USERMEM;
+  
+  ret = cursor->c_get(cursor, &DBTKey, &DBTValue, flags);
+  *ret_key_size = DBTKey.size;
+  *result_size = DBTValue.size;
+  
+  return ret;
 }
 
-int wcs_cmp(const wchar_t *a, int32_t length1, 
-	    const wchar_t *b, int32_t length2) {
-  int min, sizediff, diff;
-  sizediff = length1 - length2;
-  min = sizediff > 0 ? length2 : length1;
-  diff = wcsncmp(a, b, min /4);
-  if (diff == 0) return sizediff;
-  return diff;
+int db_cursor_pget_raw(DBC *cursor, 
+		       char *keybuf, u_int32_t keybuf_size,
+		       u_int32_t keybuf_length,
+		       char *pkeybuf, u_int32_t pkeybuf_size,
+		       u_int32_t pkeybuf_length,
+		       char *buffer, u_int32_t buffer_size,
+		       u_int32_t buffer_length,
+		       u_int32_t flags, 
+		       u_int32_t *ret_key_size,
+		       u_int32_t *ret_pkey_size,
+		       u_int32_t *result_size) {
+  DBT DBTKey, DBTPKey, DBTValue;
+  int ret;
+  
+  memset(&DBTKey, 0, sizeof(DBT));
+  memset(&DBTPKey, 0, sizeof(DBT));

[1387 lines skipped]



From ieslick at common-lisp.net  Mon Jan 22 16:17:44 2007
From: ieslick at common-lisp.net (ieslick)
Date: Mon, 22 Jan 2007 11:17:44 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/elephant
Message-ID: <20070122161744.33F0B34052@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv25298/src/elephant

Modified Files:
	controller.lisp serializer2.lisp 
Log Message:
0.6.1 Working HEAD is limping again.  All tests pass on Allegro 8.0/Mac OS X

--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/21 21:20:04	1.20
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/22 16:17:43	1.21
@@ -137,7 +137,7 @@
 ;; COMMON STORE CONTROLLER FUNCTIONALITY
 ;;
 
-(defclass store-controller ()  
+(defclass store-controller ()
   ((spec :type (or pathname string (simple-array character))
 	 :accessor controller-spec
 	 :initarg :spec
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/01/21 21:20:04	1.3
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/01/22 16:17:44	1.4
@@ -45,7 +45,7 @@
 
 ;; Constants
 
-(defconstant +fixnum+                1)
+(defconstant +fixnum32+              1)
 (defconstant +fixnum64+              2)
 (defconstant +char+                  3)
 (defconstant +single-float+          4)
@@ -154,15 +154,15 @@
 	   (incf *lisp-obj-id*))
 	 (%serialize (frob)
 	   (etypecase frob
-	     ((integer #.most-negative-fixnum #.most-positive-fixnum)
-	      (buffer-write-byte +fixnum+ bs)
-	      (buffer-write-int frob bs))
-	     (null
-	      (buffer-write-byte +nil+ bs))
 	     (symbol
 	      (serialize-symbol frob bs sc))
 	     (string
 	      (serialize-string frob bs))
+	     ((integer #.most-negative-fixnum #.most-positive-fixnum)
+	      (buffer-write-byte +fixnum32+ bs)
+	      (buffer-write-int frob bs))
+	     (null
+	      (buffer-write-byte +nil+ bs))
 	     (persistent
 	      (buffer-write-byte +persistent+ bs)
 	      (buffer-write-int (oid frob) bs)
@@ -327,7 +327,7 @@
 	   (declare (type foreign-char tag)
 		    (dynamic-extent tag))
 	   (cond
-	     ((= tag +fixnum+) 
+	     ((= tag +fixnum32+) 
 	      (buffer-read-fixnum bs))
 	     ((= tag +nil+) nil)
 	     ((= tag +utf8-string+)



From ieslick at common-lisp.net  Mon Jan 22 16:17:44 2007
From: ieslick at common-lisp.net (ieslick)
Date: Mon, 22 Jan 2007 11:17:44 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/tests
Message-ID: <20070122161744.8032F38010@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/tests
In directory clnet:/tmp/cvs-serv25298/tests

Modified Files:
	delscript.sh testindexing.lisp testserializer.lisp 
Log Message:
0.6.1 Working HEAD is limping again.  All tests pass on Allegro 8.0/Mac OS X

--- /project/elephant/cvsroot/elephant/tests/delscript.sh	2006/11/11 18:41:11	1.2
+++ /project/elephant/cvsroot/elephant/tests/delscript.sh	2007/01/22 16:17:44	1.3
@@ -1,9 +1,12 @@
 rm testdb/__*
 rm testdb/%*
 rm testdb/log*
+rm testdb/VERSION
 rm testdb2/__*
 rm testdb2/%*
 rm testdb2/log*
+rm testdb2/VERSION
 rm testbdb/testsbdb
 rm testbdb/__*
-rm testbdb/log*
\ No newline at end of file
+rm testbdb/log*
+rm testbdb/VERSION
\ No newline at end of file
--- /project/elephant/cvsroot/elephant/tests/testindexing.lisp	2006/09/04 05:42:43	1.19
+++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp	2007/01/22 16:17:44	1.20
@@ -417,8 +417,8 @@
 	 (end (1- (+ start size))))
     (get-instances-by-range class 'stress1 start end)))
 
-(defparameter *stress-count* 500)
-(defparameter *range-size* 40)
+(defparameter *stress-count* 700)
+(defparameter *range-size* 80)
 
 (deftest indexing-timing
     (progn
--- /project/elephant/cvsroot/elephant/tests/testserializer.lisp	2007/01/21 21:20:05	1.11
+++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp	2007/01/22 16:17:44	1.12
@@ -348,15 +348,14 @@
       (setf (slot-value b 'slot1) h)
       (setf (slot-value b 'slot2) f)
       (are-not-null
-;;       (in-out-deep-equalp c1)
-;;       (in-out-deep-equalp c2)
-;;       (in-out-deep-equalp l1)
-;;       (in-out-deep-equalp h)
-;;       (in-out-deep-equalp g)
-;;       (in-out-deep-equalp f)
+       (in-out-deep-equalp c1)
+       (in-out-deep-equalp c2)
+       (in-out-deep-equalp l1)
+       (in-out-deep-equalp h)
+       (in-out-deep-equalp g)
+       (in-out-deep-equalp f)
        (in-out-deep-equalp b)))
-  t)
- ;;t t t t t t t)
+  t t t t t t t)
 
 (defclass pfoo ()
   ((slot1 :initarg :slot1 :accessor slot1))



From ieslick at common-lisp.net  Mon Jan 22 22:22:35 2007
From: ieslick at common-lisp.net (ieslick)
Date: Mon, 22 Jan 2007 17:22:35 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/db-bdb
Message-ID: <20070122222235.729C02E1BD@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/db-bdb
In directory clnet:/tmp/cvs-serv32683

Modified Files:
	bdb-symbol-tables.lisp berkeley-db.lisp 
Added Files:
	bdb-slots.lisp 
Log Message:
Added missing file

--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-symbol-tables.lisp	2007/01/19 21:03:29	1.1
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-symbol-tables.lisp	2007/01/22 22:22:35	1.2
@@ -34,18 +34,18 @@
    the persistent tables."
   (reset-buffer-stream valbuf) ;; Just to avoid any contamination
 ;;  (with-transaction (:txn-nosync t :dirty-read t) 
-  (format t "getting next symid")
+;;  (format t "getting next symid")
   (let ((id (next-symid sc))) ;; allocate a new unique id
     ;; Update symbol->id table
-    (format t "Writing sym->id: ~A -> ~A~%" symbol id)
+;;    (format t "Writing sym->id: ~A -> ~A~%" symbol id)
     (buffer-write-int id valbuf)
-    (format t "Putting id into table location~%")
+;;    (format t "Putting id into table location~%")
     (db-put-buffered (controller-btrees sc) keybuf valbuf
 		     :auto-commit *auto-commit*)
     ;; Write id->symbol table
     (reset-buffer-stream keybuf)
     (reset-buffer-stream valbuf)
-    (format t "Writing id->sym: ~A -> ~A~%" id symbol)
+;;    (format t "Writing id->sym: ~A -> ~A~%" id symbol)
     (buffer-write-int *id-to-symbol-table-oid* keybuf)
     (buffer-write-int id keybuf)
     (serialize-symbol-complete symbol valbuf)
@@ -59,13 +59,13 @@
 (defmethod lookup-persistent-symbol ((sc bdb-store-controller) id)
   "Lookup the ID associated with a symbol"
   (with-buffer-streams (keybuf valbuf)
-    (format t "Looking up: ~A~%" id)
+;;    (format t "Looking up: ~A~%" id)
     (buffer-write-int *id-to-symbol-table-oid* keybuf)
     (buffer-write-int id keybuf)
-    (format t "Get for id: ~A~%" id)
+;;    (format t "Get for id: ~A~%" id)
     (let ((buf (db-get-key-buffered (controller-btrees sc)
 				    keybuf valbuf)))
-      (format t "Got buf: ~A~%" buf)
+;;      (format t "Got buf: ~A~%" buf)
       (if buf (values (deserialize buf sc) T)
 	  (error "Invalid ID - no persistent mapping for ID")))))
 
--- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp	2007/01/20 22:12:17	1.3
+++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp	2007/01/22 22:22:35	1.4
@@ -19,7 +19,9 @@
 
 (in-package :db-bdb)
 
-(declaim (inline %db-get-key-buffered db-get-key-buffered 
+(declaim 
+ #-elephant-without-optimize (optimize (speed 3) (safety 0))
+ (inline %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 
@@ -617,8 +619,7 @@
 a buffer-stream.  Space for the value is passed in as a
 buffer-stream.  On success the buffer-stream is returned for
 decoding, or NIL if nothing was found."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void db transaction)
+  (declare (type pointer-void db transaction)
 	   (type buffer-stream key-buffer-stream value-buffer-stream)
 	   (type boolean auto-commit get-both degree-2 read-committed dirty-read read-uncommitted))
   (loop 
@@ -668,8 +669,7 @@
 string.  Space for the value is passed in as a
 buffer-stream.  On success the buffer-stream is returned for
 decoding, or NIL if nothing was found."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void db transaction)
+  (declare (type pointer-void db transaction)
 	   (type string key)
 	   (type buffer-stream value-buffer-stream)
 	   (type fixnum key-size)
@@ -708,8 +708,7 @@
   "Get a key / value pair from a DB.  The key is passed as a
 string, and the value is returned as a string.  If nothing
 is found, NIL is returned."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void db transaction)
+  (declare (type pointer-void db transaction)
 	   (type string key)
 	   (type fixnum key-size)
 	   (type boolean auto-commit get-both degree-2 read-committed
@@ -759,8 +758,7 @@
   "Put a key / value pair into a DB.  The pair are encoded
 in buffer-streams.  T on success, or nil if the key already
 exists and EXISTS-ERROR-P is NIL."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void db transaction)
+  (declare (type pointer-void db transaction)
 	   (type buffer-stream key-buffer-stream value-buffer-stream)
 	   (type boolean auto-commit exists-error-p))
   (let ((errno 
@@ -794,8 +792,7 @@
 		   (value-size (length value))
 		   (transaction *current-transaction*))
 	    :cstrings (key value)
-	    :declarations (declare (optimize (speed 3) (safety 0))
-				   (type pointer-void db transaction)
+	    :declarations (declare (type pointer-void db transaction)
 				   (type string key value)
 				   (type fixnum key-size value-size)
 				   (type boolean auto-commit))
@@ -816,8 +813,7 @@
   "Delete a key / value pair from a DB.  The key is encoded
 in a buffer-stream.  T on success, NIL if the key wasn't
 found."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void db transaction) 
+  (declare (type pointer-void db transaction) 
 	   (type buffer-stream key-buffer-stream)
 	   (type boolean auto-commit))
   (let ((errno (%db-delete-buffered db transaction
@@ -846,8 +842,7 @@
 		  (transaction *current-transaction*))
   "Delete a key / value pair from a DB.  The key is a
 string.  T on success, NIL if the key wasn't found."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void db transaction) (type string key)
+  (declare (type pointer-void db transaction) (type string key)
 	   (type fixnum key-size) (type boolean auto-commit))
   (with-cstrings ((key key))
     (let ((errno
@@ -878,8 +873,7 @@
 duplicates.  The key and value are encoded as
 buffer-streams.  T on success, NIL if the key / value pair
 wasn't found."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void db transaction) 
+  (declare (type pointer-void db transaction) 
 	   (type buffer-stream key-buffer-stream value-buffer-stream))
   (let ((errno (%db-delete-kv db transaction
 			      (buffer-stream-buffer key-buffer-stream)
@@ -913,8 +907,7 @@
 
 (defun db-compact (db start stop end &key (transaction *current-transaction*)
 		   freelist-only free-space)
-  (declare (optimize (speed 3) (safety 2))
-	   (type pointer-void db transaction)
+  (declare (type pointer-void db transaction)
 	   (type buffer-stream start stop)
 	   (type boolean freelist-only free-space))
   (loop
@@ -953,8 +946,7 @@
 (defun db-cursor (db &key (transaction *current-transaction*)
 		  degree-2 read-committed dirty-read read-uncommitted)
   "Create a cursor."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void db)
+  (declare (type pointer-void db)
 	   (type boolean degree-2 read-committed dirty-read read-uncommitted)
 	   (type pointer-int *errno-buffer*))
   (let* ((curs (%db-cursor db transaction (flags :degree-2 (or degree-2 read-committed)
@@ -979,8 +971,7 @@
 
 (defun db-cursor-delete (cursor)
   "Delete by cursor."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void cursor))
+  (declare (type pointer-void cursor))
   (let ((errno (%db-cursor-delete cursor 0)))
     (declare (type fixnum errno))
     (cond ((= errno 0) t)
@@ -1000,8 +991,7 @@
 
 (defun db-cursor-duplicate (cursor &key (position t)) 
   "Duplicate a cursor."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void cursor))
+  (declare (type pointer-void cursor))
   (let* ((newc (%db-cursor-dup cursor (flags :position position) 
 			       *errno-buffer*))
 	 (errno (deref-array *errno-buffer* '(:array :int) 0)))
@@ -1031,8 +1021,7 @@
   "Move a cursor, returning the key / value pair found.
 Supports current, first, last, next, next-dup, next-nodup,
 prev, prev-nodup."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void cursor)
+  (declare (type pointer-void cursor)
 	   (type buffer-stream key-buffer-stream value-buffer-stream)
 	   (type boolean current first last next next-dup next-nodup prev 
 		 prev-nodup dirty-read read-uncommitted))
@@ -1077,8 +1066,7 @@
 			       &key set set-range dirty-read read-uncommitted)
   "Move a cursor to a key, returning the key / value pair
 found.  Supports set and set-range."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void cursor)
+  (declare (type pointer-void cursor)
 	   (type buffer-stream key-buffer-stream value-buffer-stream)
 	   (type boolean set set-range dirty-read read-uncommitted))
   (loop 
@@ -1118,8 +1106,7 @@
 				    &key get-both get-both-range dirty-read read-uncommitted)
   "Move a cursor to a key / value pair, returning the key /
 value pair found.  Supports get-both and get-both-range."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void cursor)
+  (declare (type pointer-void cursor)
 	   (type buffer-stream key-buffer-stream value-buffer-stream)
 	   (type boolean get-both get-both-range dirty-read read-uncommitted))
   (loop 
@@ -1180,8 +1167,7 @@
   "Move a secondary cursor, returning the key / value /
 primary triple found.  Supports current, first, last, next,
 next-dup, next-nodup, prev, prev-nodup."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void cursor)
+  (declare (type pointer-void cursor)
 	   (type buffer-stream key-buffer-stream pkey-buffer-stream 
 		 value-buffer-stream)
 	   (type boolean current first last next next-dup next-nodup prev 
@@ -1236,8 +1222,7 @@
 				&key set set-range dirty-read)
   "Move a secondary cursor tp a key, returning the key / value /
 primary triple found.  Supports set, set-range."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void cursor)
+  (declare (type pointer-void cursor)
 	   (type buffer-stream key-buffer-stream pkey-buffer-stream 
 		 value-buffer-stream)
 	   (type boolean set set-range dirty-read))
@@ -1288,8 +1273,7 @@
   "Move a secondary cursor tp a key / primary pair,
 returning the key / value / primary triple found.  Supports
 get, get-range."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void cursor)
+  (declare (type pointer-void cursor)
 	   (type buffer-stream key-buffer-stream pkey-buffer-stream 
 		 value-buffer-stream)
 	   (type boolean get-both get-both-range dirty-read))
@@ -1346,8 +1330,7 @@
 			       &key after before current keyfirst keylast
 			       no-dup-data exists-error-p)
   "Put by cursor.  The key and value are encoded as buffer-streams."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void cursor)
+  (declare (type pointer-void cursor)
 	   (type buffer-stream key-buffer-stream value-buffer-stream)
 	   (type boolean after before current keyfirst keylast no-dup-data
 		 exists-error-p))
@@ -1385,8 +1368,7 @@
 			     degree-2 read-committed dirty-read read-uncommitted
 			     txn-nosync txn-nowait txn-sync)
   "Start a transaction.  Transactions may be nested."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void env parent)
+  (declare (type pointer-void env parent)
 	   (type boolean degree-2 read-committed dirty-read read-uncommitted 
 		 txn-nosync txn-nowait txn-sync)
 	   (type pointer-int *errno-buffer*))
@@ -1411,8 +1393,7 @@
 
 (wrap-errno (db-transaction-abort %db-txn-abort) (transaction)
 	    :keys ((transaction *current-transaction*))
-	    :declarations (declare (optimize (speed 3) (safety 0))
-				   (type pointer-void transaction))
+	    :declarations (declare (type pointer-void transaction))
 	    :documentation "Abort a transaction.")
 
 (def-function ("db_txn_commit" %db-txn-commit)
@@ -1423,8 +1404,7 @@
 (wrap-errno (db-transaction-commit %db-txn-commit) (transaction flags)
 	    :keys ((transaction *current-transaction*))
 	    :flags (txn-nosync txn-sync)
-	    :declarations (declare (optimize (speed 3) (safety 0))
-				   (type pointer-void transaction)
+	    :declarations (declare (type pointer-void transaction)
 				   (type boolean txn-nosync txn-sync))
 	    :documentation "Commit a transaction.")
 
@@ -1523,7 +1503,6 @@
 
 (defun db-transaction-id (&optional (transaction *current-transaction*))
   "Returns the ID of the transaction (for locking purposes.)"
-  (declare (optimize (speed 3)))
   (%db-transaction-id transaction))
 
 (def-function ("db_env_lock_id" %db-env-lock-id)
@@ -1715,8 +1694,7 @@
 
 (defun db-sequence-create (db)
   "Create a new sequence."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void db)
+  (declare (type pointer-void db)
 	   (type pointer-int *errno-buffer*))
   (let* ((seq
 	  (%db-sequence-create db 0 *errno-buffer*))
@@ -1763,8 +1741,7 @@
 (defun db-sequence-get (sequence delta &key auto-commit txn-nosync 
 			(transaction *current-transaction*))
   "Get the next element."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void sequence transaction)
+  (declare (type pointer-void sequence transaction)
 	   (type fixnum delta)
 	   (type boolean auto-commit txn-nosync))
   (multiple-value-bind
@@ -1792,8 +1769,7 @@
 (defun db-sequence-get-fixnum (sequence delta &key auto-commit txn-nosync 
 			       (transaction *current-transaction*))
   "Get the next element as a fixnum."
-  (declare (optimize (speed 3) (safety 0))
-	   (type pointer-void sequence transaction)
+  (declare (type pointer-void sequence transaction)
 	   (type fixnum delta)
 	   (type boolean auto-commit txn-nosync))
   (multiple-value-bind

--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-slots.lisp	2007/01/22 22:22:35	NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-slots.lisp	2007/01/22 22:22:35	1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; bdb-slots.lisp -- Implement the slot protocol
;;; 
;;; Initial version 8/26/2004 by Ben Lee
;;; <blee at common-lisp.net>
;;; 
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg at common-lisp.net> <blee at common-lisp.net>
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;

(in-package :db-bdb)

;;
;; Persistent slot protocol implementation
;;

(defmethod persistent-slot-reader ((sc bdb-store-controller) instance name)
;;  (declare (optimize (speed 3) (safety 1) (space 1)))
  (with-buffer-streams (key-buf value-buf)
    (buffer-write-int (oid instance) key-buf)
    (serialize name key-buf sc)
    (let ((buf (db-get-key-buffered (controller-db sc)
				    key-buf value-buf)))
      (if buf (deserialize buf sc)
	  #+cmu
	  (error 'unbound-slot :instance instance :slot name)
	  #-cmu
	  (error 'unbound-slot :instance instance :name name)))))

(defmethod persistent-slot-writer ((sc bdb-store-controller) new-value instance name)
;;  (declare (optimize (speed 3) (safety 1) (space 1)))
;;  (format t "psw -- sc: ~A  ct: ~A ac: ~A~%" *store-controller* *current-transaction* *auto-commit*)
  (with-buffer-streams (key-buf value-buf)
    (buffer-write-int (oid instance) key-buf)
    (serialize name key-buf sc)
    (serialize new-value value-buf sc)
    (db-put-buffered (controller-db sc)
		     key-buf value-buf
		     :transaction *current-transaction*
		     :auto-commit *auto-commit*)
    new-value))

(defmethod persistent-slot-boundp ((sc bdb-store-controller) instance name)
;;  (declare (optimize (speed 3) (safety 1) (space 1)))
  (with-buffer-streams (key-buf value-buf)
    (buffer-write-int (oid instance) key-buf)
    (serialize name key-buf sc)
    (let ((buf (db-get-key-buffered (controller-db sc)
				    key-buf value-buf)))
      (if buf t nil))))

(defmethod persistent-slot-makunbound ((sc bdb-store-controller) instance name)
;;  (declare (optimize (speed 3) (safety 1) (space 1)))
  (with-buffer-streams (key-buf)
    (buffer-write-int (oid instance) key-buf)
    (serialize name key-buf sc)
    (db-delete-buffered (controller-db sc) key-buf
			:transaction *current-transaction*
			:auto-commit *auto-commit*)))


From ieslick at common-lisp.net  Mon Jan 22 23:11:08 2007
From: ieslick at common-lisp.net (ieslick)
Date: Mon, 22 Jan 2007 18:11:08 -0500 (EST)
Subject: [elephant-cvs] CVS elephant
Message-ID: <20070122231108.760D124053@common-lisp.net>

Update of /project/elephant/cvsroot/elephant
In directory clnet:/tmp/cvs-serv9131

Modified Files:
	TODO 
Log Message:
Where did bdb-slots go?

--- /project/elephant/cvsroot/elephant/TODO	2007/01/22 16:17:43	1.35
+++ /project/elephant/cvsroot/elephant/TODO	2007/01/22 23:11:08	1.36
@@ -7,12 +7,12 @@
 --------------------------------------------
 
 Active tasks:
-- Enable and verify symbol-id strategy
+- Speed up symbol storage and reference using symbol id's
 - Full 64-bit support (arrays, native 64-bit fixnums, etc)
   - char vs. uint8 in buffer-stream
   - flexible handling of 64-bit fixnums
-
-Multi-threading support and multiple-store cleanup:
+- Ensure serialization is thread-safe and reasonably efficient
+  - Fast and slow critical sections by lisp
 - Think about dynamic vs. object based store & transaction resolution?
   - Perform error checking when mixed 
   - Current store specific *current-transaction* stack
@@ -91,11 +91,9 @@
 0.6.1 - Features COMPLETED to date
 ----------------------------------
 
-January 2006 checkins; major features
+January 22, 2006 checkins:
 x Modularize serializers for easy upgrade
 x Implement backend support for symbol-table protocol
-x Speed up symbol storage and reference using symbol id's
-x Ensure serialization is thread-safe and reasonably efficient
 x MCL 1.1 unicode support; clean up other lisp support for unicode
 x Simplify user-specific configuration parameters using config.sexp and my-config.sexp
 x Ensure thread safety in buffer-stream allocation!



From ieslick at common-lisp.net  Mon Jan 22 23:11:08 2007
From: ieslick at common-lisp.net (ieslick)
Date: Mon, 22 Jan 2007 18:11:08 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/elephant
Message-ID: <20070122231108.BDBCC7B01B@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv9131/src/elephant

Modified Files:
	controller.lisp package.lisp serializer2.lisp variables.lisp 
Log Message:
Where did bdb-slots go?

--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/22 16:17:43	1.21
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/22 23:11:08	1.22
@@ -80,6 +80,7 @@
 	(setf (gethash spec *dbconnection-spec*) sc)
 	sc)))
 
+
 ;; NOTE: Check for asdf loaded rather than rely on asdf to?
 (defun load-backend (type)
   (let ((record (assoc type *elephant-backends*)))
@@ -109,9 +110,8 @@
 (defun open-store (spec &rest args)
   "Conveniently open a store controller."
   (assert (consp spec))
-  ;; Setup system config parameters from my-config
-  (ensure-loaded-configuration)
   (setq *store-controller* (get-controller spec))
+  (load-user-configuration *store-controller*)
   (initialize-serializer *store-controller*)
   (apply #'open-controller *store-controller* args))
 
@@ -165,6 +165,13 @@
     handles, the cache, table creation, counters, locks, the root 
     (for garbage collection,) et cetera."))
 
+;; User configuration parameters for the controller
+
+(defun load-user-configuration (controller)
+  ;; Fast symbols
+  (setf (controller-fast-symbols-p controller)
+	(elephant-system::get-config-option :fast-symbols (asdf:find-system :elephant))))
+
 (defun initialize-serializer (sc)
   "Establish serializer version on controller startup"
   (cond ((prior-version-p (database-version sc) '(0 6 0))
--- /project/elephant/cvsroot/elephant/src/elephant/package.lisp	2007/01/21 21:20:04	1.7
+++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp	2007/01/22 23:11:08	1.8
@@ -35,6 +35,7 @@
 	   #:add-to-root #:get-from-root #:remove-from-root #:root-existsp
 	   #:get-cached-instance #:flush-instance-cache
 	   #:controller-symbol-cache #:controller-symbol-id-cache
+	   #:controller-fast-symbols-p
 	   #:optimize-storage
 
 	   #:with-transaction
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/01/22 16:17:44	1.4
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/01/22 23:11:08	1.5
@@ -473,7 +473,7 @@
   (declare (type buffer-stream bs)
 	   (type symbol symbol)
 	   (type store-controller sc))
-  (if *fast-symbols*
+  (if (controller-fast-symbols-p sc)
       (let ((id (lookup-id symbol sc)))
 	(declare (type fixnum id))
 	(buffer-write-byte +symbol-id+ bs)
--- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp	2007/01/21 21:20:04	1.8
+++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp	2007/01/22 23:11:08	1.9
@@ -43,15 +43,6 @@
    Users attempting to directly write this variable will run into an
    error")
 
-;;;;;;;;;;;;;;;;;;;;
-;;;; User Configuration for site customization 
-
-(defvar *fast-symbols* nil) ;; for serializer2.lisp
-
-(defun ensure-loaded-configuration ()
-  (setf *fast-symbols* 
-	(elephant-system::get-config-option :fast-symbols (asdf:find-system :elephant))))
-
 ;;;;;;;;;;;;;;;;;
 ;;;; Serializer optimization parameters
 



From ieslick at common-lisp.net  Thu Jan 25 18:18:00 2007
From: ieslick at common-lisp.net (ieslick)
Date: Thu, 25 Jan 2007 13:18:00 -0500 (EST)
Subject: [elephant-cvs] CVS elephant
Message-ID: <20070125181800.1A9E434053@common-lisp.net>

Update of /project/elephant/cvsroot/elephant
In directory clnet:/tmp/cvs-serv27212

Modified Files:
	INSTALL TODO config.sexp elephant.asd 
Log Message:
Symbol ID hack removed from BDB; Allegro/MacOS/x86 passes

--- /project/elephant/cvsroot/elephant/INSTALL	2006/11/11 18:41:10	1.19
+++ /project/elephant/cvsroot/elephant/INSTALL	2007/01/25 18:17:59	1.20
@@ -3,10 +3,10 @@
 Requirements
 ------------
 
-Support Lisps:
+Supported Lisps:
 CMUCL 19a Linux
-SBCL 0.9.6/0.9.9 Linux / Mac OSX
-Allegro CL 6.2/7.0/8.0 Linux / Mac OSX
+SBCL 0.9.17/1.0+ Linux / Mac OSX
+Allegro CL 7.0/8.0 Linux / Mac OSX
 OpenMCL 0.14.2
 LispWorks (port in-progress)
 
@@ -14,14 +14,12 @@
 ASDF        - http://www.cliki.net/asdf
 UFFI 1.5.4+ - http://uffi.b9.com/
 
-Backends:
-1) Sleepycat Berkeley DB 4.3 - http://www.sleepycat.com
-2) CLSQL - http://clsql.b9.com/
-   And an appropriate SQL installation.  
+A Backend Database:
+1) Oracle Berkeley DB 4.4 or 4.5 - http://www.oracle.com/database/berkeley-db.html
+2) CLSQL - http://clsql.b9.com/ with an appropriate SQL installation.  
    Tested with SQlite3 and Postgresql so far
 
-A C compiler, probably gcc or Visual Studio.  Presumably you
-have this if you installed Sleepycat.
+A C compiler, probably gcc or Visual Studio.  Presumably you have this if you installed
 
 ------------------
 Short Instructions
@@ -35,10 +33,10 @@
 Then: (open-store '(<backend> <spec>))
 
 Where <backend> = { :bdb | :clsql }
-      <spec>    = { '(:sqlite3 "db path") | '(:postgresql "db path") | "bdb directory" }
+      <spec>    = { "fresh directory for BDB files" | '(:sqlite3 "db path") | '(:postgresql "db path")
 
-This should load all files, including compiling libraries, on
-most systems.  For Win32, see the instructions below.  
+This should load all files, including compiling libraries, on most
+systems.  For Win32, see the instructions below.
 
 (We'll improve the build process for Win32 if there is demand)
 
@@ -46,18 +44,18 @@
 Long Instructions
 -----------------
 
-For SBCL, CMUCL, Allegro 7.0+, MCL and CLISP:
+For SBCL, CMUCL, Allegro 8.0+, MCL and CLISP:
 
 0) Unpack Elephant.  I put mine in the directory
 
-/usr/local/share/common-lisp/elephant-0.6/
+/usr/local/share/common-lisp/elephant-0.6.x/
 
 1) Install ASDF. 
 
 Ensure that you have a recent version of ASDF installed as 
 the load process now depends upon it.
 
-2) Install UFFI.
+2) Install UFFI
 
 3) Install a backend: Either Berkeley DB 4.4, PostGresql, or SQLite 3.
 
@@ -78,11 +76,11 @@
 Under Un*x, you may actually already have this installed, though 
 it may be compiled with funny options, so if things don't work 
 you may want to try to start from scratch.  FreeBSD has a port 
-for this, as I'm sure do other BSDs (including Darwin/Fink.)  
+for this, as I'm sure do other BSDs (including DarwinPorts/Fink.)  
 Take note of where libdb.so and db.h are installed, usually:
 
-  /usr/local/BerekleyDB.4.4/lib/libdb.so and
-  /usr/local/BerekleyDB.4.4/include/db.h, or
+  /usr/local/BerkeleyDB.4.4/lib/libdb.so and
+  /usr/local/BerkeleyDB.4.4/include/db.h, or
 
   /usr/local/lib/db44/libdb.so and
   /usr/local/include/db44/db.h.)
@@ -95,6 +93,7 @@
 of the Berkeley DB distribution :berkeley-db-root, the library to load
 :berkeley-db-lib and the pthreads library if you're running linux :pthread-lib.
 
+
 For Win32 (directions courtesy of Bill Clementson): 
 ---------------------------------------------------
 Create an MSVC dll project and add src/db-bdb/libberkeley-db.c,
@@ -176,6 +175,11 @@
 
 This should take less than 5 minutes on decent hardware.  
 
+The tests are not idempotent, so if you run the tests a second time,
+they are likely to fail.  To avoid this, for example if you are
+debugging tests, just run the script delscript.sh (or do the
+equivalent on Win32) in the elephant/tests directory.
+
 Elephant allows migration between repositories.  To test this:
 
 (do-migration-tests *default-spec* <backend>)
--- /project/elephant/cvsroot/elephant/TODO	2007/01/22 23:11:08	1.36
+++ /project/elephant/cvsroot/elephant/TODO	2007/01/25 18:17:59	1.37
@@ -8,20 +8,26 @@
 
 Active tasks:
 - Speed up symbol storage and reference using symbol id's
+  - Fast symbols are property tag in DB (so code doesn't corrupt DB)
 - Full 64-bit support (arrays, native 64-bit fixnums, etc)
-  - char vs. uint8 in buffer-stream
-  - flexible handling of 64-bit fixnums
+  - Set parameter at startup based on *features*
+  - Mark fixnums appropriately: 32-bit lisps can decode 64-bit fixnums as bignums (two 32-bit entities)
+    - propogate assumptions to bignum byte specs
+    - are there other fixed assumptions?
+  - char vs. uint8 in buffer-stream to read-out (See Marco e-mail)
 - Ensure serialization is thread-safe and reasonably efficient
-  - Fast and slow critical sections by lisp
-- Think about dynamic vs. object based store & transaction resolution?
+  - Provide support for fast and slow critical sections by lisps: buffer-streams, 
+    circularity-arrays/hashes, shared controller side-effects... (see email)
+  - Resourced-byte-spec should be per-thread (or removed - ok to cons during bignum serialization)
+- Think about dynamic vs. object-based store & transaction variables
   - Perform error checking when mixed 
   - Current store specific *current-transaction* stack
-- Make elephant threads appropriately bind dynamic variables?
+- Allow elephant threads to appropriately bind dynamic variables?
 - Thread safety for all global vars
 - Thread safe API option for user-managed store-controller?
 - Thread safe API for transactions
-- Update to require BDB 4.5?
 - Throw condition when store spec is invalid, etc
+- Test with BDB 4.5?
 
 BDB Features:
 ? Determine how to detect deadlock conditions as an optional run-safe mode?
--- /project/elephant/cvsroot/elephant/config.sexp	2007/01/20 22:12:17	1.3
+++ /project/elephant/cvsroot/elephant/config.sexp	2007/01/25 18:17:59	1.4
@@ -2,8 +2,7 @@
  (:berkeley-db-lib-dir . "/opt/local/lib/db44/")
  (:berkeley-db-lib . "/usr/local/BerkeleyDB.4.4/lib/libDB-4.4.dylib")
  (:pthread-lib . nil)
- (:clsql-lib . nil)
- (:fast-symbols . nil))
+ (:clsql-lib . nil))
 
 ;; Typical pthread settings are: /lib/tls/libpthread.so.0
 ;; nil means that the library in question is not loaded
--- /project/elephant/cvsroot/elephant/elephant.asd	2007/01/21 21:20:03	1.23
+++ /project/elephant/cvsroot/elephant/elephant.asd	2007/01/25 18:17:59	1.24
@@ -107,8 +107,8 @@
   (unless (and input-file output-file)
     (error "Must specify both input and output files"))
   (list 
-   #-(or darwin macosx) "-shared"
-   #+(or darwin macosx) "-bundle"
+   #-(or darwin macosx darwin-host) "-shared"
+   #+(or darwin macosx darwin-host) "-bundle"
    "-Wall"
    "-fPIC"
    "-O3"



From ieslick at common-lisp.net  Thu Jan 25 18:18:00 2007
From: ieslick at common-lisp.net (ieslick)
Date: Thu, 25 Jan 2007 13:18:00 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/db-bdb
Message-ID: <20070125181800.4E5953A018@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/db-bdb
In directory clnet:/tmp/cvs-serv27212/src/db-bdb

Modified Files:
	bdb-symbol-tables.lisp 
Log Message:
Symbol ID hack removed from BDB; Allegro/MacOS/x86 passes

--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-symbol-tables.lisp	2007/01/22 22:22:35	1.2
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-symbol-tables.lisp	2007/01/25 18:18:00	1.3
@@ -26,38 +26,37 @@
     (serialize-symbol-complete symbol keybuf)
     (let ((buf (db-get-key-buffered (controller-btrees sc)
 				    keybuf valbuf)))
-      (if buf (values (buffer-read-int buf) T)
-	  (values (create-persistent-symbol sc symbol keybuf valbuf) t)))))
-
-(defun create-persistent-symbol (sc symbol keybuf valbuf)
-  "Takes an symbol->id table + symbol keybuf, allocates an ID and updates
-   the persistent tables."
-  (reset-buffer-stream valbuf) ;; Just to avoid any contamination
-;;  (with-transaction (:txn-nosync t :dirty-read t) 
-;;  (format t "getting next symid")
-  (let ((id (next-symid sc))) ;; allocate a new unique id
+      (if buf 
+	  (values (buffer-read-int buf) t)
+	  (values (create-persistent-symbol-id sc symbol) t)))))
+
+(defun create-persistent-symbol-id (sc symbol)
+  "Allocates an ID and updates persistent tables"
+  (let ((id (next-symid sc))) 
     ;; Update symbol->id table
-;;    (format t "Writing sym->id: ~A -> ~A~%" symbol id)
-    (buffer-write-int id valbuf)
-;;    (format t "Putting id into table location~%")
-    (db-put-buffered (controller-btrees sc) keybuf valbuf
-		     :auto-commit *auto-commit*)
+    (with-buffer-streams (keybuf valbuf)
+;;      (format t "Writing sym->id: ~A -> ~A~%" symbol id)
+      (buffer-write-int *symbol-to-id-table-oid* keybuf)
+      (serialize-symbol-complete symbol keybuf)
+      (buffer-write-int id valbuf)
+;;      (format t "Putting it into table location~%")
+      (db-put-buffered (controller-btrees sc) keybuf valbuf))
     ;; Write id->symbol table
-    (reset-buffer-stream keybuf)
-    (reset-buffer-stream valbuf)
-;;    (format t "Writing id->sym: ~A -> ~A~%" id symbol)
-    (buffer-write-int *id-to-symbol-table-oid* keybuf)
-    (buffer-write-int id keybuf)
-    (serialize-symbol-complete symbol valbuf)
-    (db-put-buffered (controller-btrees sc) keybuf valbuf
-		     :auto-commit *auto-commit*)
-    id)
-;;    )
-  )
+    (with-buffer-streams (keybuf valbuf)
+;;      (format t "Writing id->sym: ~A -> ~A~%" id symbol)
+      (buffer-write-int *id-to-symbol-table-oid* keybuf)
+;;      (buffer-write-byte elephant-serializer2::+fixnum32+ keybuf)
+;;      (buffer-write-int id keybuf)
+      (serialize id keybuf sc)
+      (serialize-symbol-complete symbol valbuf)
+;;      (format t "Putting it into table location~%")
+      (db-put-buffered (controller-btrees sc) keybuf valbuf))
+;;    (format t "Done")
+    id))
 
 
 (defmethod lookup-persistent-symbol ((sc bdb-store-controller) id)
-  "Lookup the ID associated with a symbol"
+  "Lookup the symbol associated with this id"
   (with-buffer-streams (keybuf valbuf)
 ;;    (format t "Looking up: ~A~%" id)
     (buffer-write-int *id-to-symbol-table-oid* keybuf)



From ieslick at common-lisp.net  Thu Jan 25 18:18:00 2007
From: ieslick at common-lisp.net (ieslick)
Date: Thu, 25 Jan 2007 13:18:00 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/elephant
Message-ID: <20070125181800.87BA77D00D@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv27212/src/elephant

Modified Files:
	controller.lisp serializer2.lisp unicode2.lisp 
Log Message:
Symbol ID hack removed from BDB; Allegro/MacOS/x86 passes

--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/22 23:11:08	1.22
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/25 18:18:00	1.23
@@ -151,14 +151,10 @@
    (class-root :reader controller-class-root
 	       :documentation "This should be a persistent indexed btree instantiated by the backend")
    ;; Upgradable serializer strategy
-   (version :accessor controller-version-cached :initform nil)
+   (database-version :accessor controller-version-cached :initform nil)
    (serializer-version :accessor controller-serializer-version :initform nil)
    (serialize :accessor controller-serialize :initform nil)
    (deserialize :accessor controller-deserialize :initform nil)
-   ;; Symbol ID caches
-   (symbol-cache :accessor controller-symbol-cache :initform (make-hash-table :size 2000))
-   (symbol-id-cache :accessor controller-symbol-id-cache :initform (make-hash-table :size 2000))
-   (fast-symbols :accessor controller-fast-symbols-p :initform nil)
    )
   (:documentation 
    "Class of objects responsible for the book-keeping of holding DB 
@@ -443,21 +439,6 @@
 ;; (defmethod clear-agents (agent)
 ;;   (setf *agencies* nil))
    
-
-;;
-;; Support for serialization efficiency
-;;
-
-(defgeneric lookup-persistent-symbol-id (sc symbol)
-  (:documentation "Return an ID for the provided symbol.  This function is
-                   a callback for the serializer that the backends share in
-                   most cases."))
-
-(defgeneric lookup-persistent-symbol (sc id)
-  (:documentation "Return a symbol for the ID.  This should always succeed.
-                   The database should not use the existing serializer to perform
-                   this function; but memutils and unicode are available"))
-
 ;;
 ;; Low-level support for metaclass protocol 
 ;;
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/01/22 23:11:08	1.5
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/01/25 18:18:00	1.6
@@ -64,7 +64,7 @@
 (defconstant +symbol+               13)
 
 ;; Cached symbol references 
-(defconstant +symbol-id+            14)
+;; (defconstant +reserved+            14)
 
 ;; stored by id+classname
 (defconstant +persistent+           15)
@@ -115,7 +115,7 @@
     (vector-push-extend hash *circularity-hash-queue*)))
 
 ;;
-;; Circularity Hash for Serializer
+;; Circularity Hash for Deserializer
 ;;
 
 (defparameter *circularity-vector-queue* (make-array 20 :fill-pointer 0 :adjustable t)
@@ -146,7 +146,8 @@
 
 (defun serialize (frob bs sc)
   "Serialize a lisp value into a buffer-stream."
-  (declare (type buffer-stream bs))
+  (declare (type buffer-stream bs)
+	   (ignorable sc))
   (let ((*lisp-obj-id* -1)
 	(*circularity-hash* (get-circularity-hash)))
     (labels 
@@ -154,15 +155,23 @@
 	   (incf *lisp-obj-id*))
 	 (%serialize (frob)
 	   (etypecase frob
-	     (symbol
-	      (serialize-symbol frob bs sc))
-	     (string
-	      (serialize-string frob bs))
 	     ((integer #.most-negative-fixnum #.most-positive-fixnum)
 	      (buffer-write-byte +fixnum32+ bs)
 	      (buffer-write-int frob bs))
 	     (null
 	      (buffer-write-byte +nil+ bs))
+	     (symbol
+	      (let ((sym-name (symbol-name frob)))
+		(declare (type string sym-name)
+			 (dynamic-extent sym-name))
+		(buffer-write-byte +symbol+ bs)
+		(serialize-string sym-name bs)
+		(let ((package (symbol-package frob)))
+		  (if package
+		      (serialize-string (package-name package) bs)
+		      (buffer-write-byte +nil+ bs)))))
+	     (string
+	      (serialize-string frob bs))
 	     (persistent
 	      (buffer-write-byte +persistent+ bs)
 	      (buffer-write-int (oid frob) bs)
@@ -199,23 +208,7 @@
 			(loop for item in svs
 			   do (%serialize item)))))))
 	     (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 
-		   ;; this ldb is consing on CMUCL!
-		   ;; there is an OpenMCL function which should work 
-		   ;; and non-cons
-		   do
-		   #+(or cmu sbcl)
-		   (buffer-write-uint (ldb (int-byte-spec i) num) bs) ;; (%bignum-ref num i) bs)
-		   #+(or allegro lispworks openmcl)
-		   (buffer-write-uint (ldb (int-byte-spec i) num) bs))))
+	      (serialize-bignum frob bs))
 	     (rational
 	      (buffer-write-byte +rational+ bs)
 	      (%serialize (numerator frob))
@@ -298,17 +291,31 @@
     (release-circularity-hash *circularity-hash*)
     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 (and (slot-boundp o slot-name)
-		   (eq :instance
-		       (slot-definition-allocation sd)))
-	  (push (slot-value o slot-name) ret)
-	  (push slot-name ret))
-	finally (return ret)))
+(defun serialize-bignum (frob bs)
+  "Serialize bignum to buffer stream"
+  (declare (type integer frob)
+	   (type buffer-stream bs))
+  (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 
+       ;; this ldb is consing on CMUCL!
+       ;; there is an OpenMCL function which should work 
+       ;; and non-cons
+       do
+	 #+(or cmu sbcl)
+	 (buffer-write-uint (ldb (int-byte-spec i) num) bs) ;; (%bignum-ref num i) bs)
+	 #+(or allegro lispworks openmcl)
+	 (buffer-write-uint (ldb (int-byte-spec i) num) bs))))
+
+;;;
+;;; DESERIALIZER
+;;;
 
 (defun deserialize (buf-str sc)
   "Deserialize a lisp value from a buffer-stream."
@@ -343,8 +350,6 @@
 		(if package
 		    (intern name (find-package package))
 		    (make-symbol name))))
-	     ((= tag +symbol-id+)
-	      (deserialize-symbol-id (buffer-read-int bs) sc))
 	     ((= tag +persistent+)
 	      (get-cached-instance sc
 				   (buffer-read-fixnum bs)
@@ -462,61 +467,4 @@
 	with num integer = 0 
 	do
 	(setq num (dpb (buffer-read-uint bs) byte-spec num))
-	finally (return (if positive num (- num)))))
-
-;;
-;; Symbol cache
-;;
-
-(defun serialize-symbol (symbol bs sc)
-  "Serialize a symbol by recording its ID"
-  (declare (type buffer-stream bs)
-	   (type symbol symbol)
-	   (type store-controller sc))
-  (if (controller-fast-symbols-p sc)
-      (let ((id (lookup-id symbol sc)))
-	(declare (type fixnum id))
-	(buffer-write-byte +symbol-id+ bs)
-	(buffer-write-int id bs))
-      (serialize-symbol-complete symbol bs)))
-
-(defun lookup-id (symbol sc)
-  "Find an id for a symbol or create a new one"
-  (declare (type symbol symbol))
-  (let ((id (gethash symbol (controller-symbol-id-cache sc))))
-    (declare (type fixnum id))
-    (if id id
-	(let ((pid (lookup-persistent-symbol-id sc symbol)))
-	  (setf (gethash symbol (controller-symbol-id-cache sc)) pid)
-	  (setf (gethash pid (controller-symbol-cache sc)) symbol)
-	  pid))))
-
-(defun serialize-symbol-complete (symbol bs)
-  "To be called by backends to serialize the string
-   instead of the ID as they implement the
-   persistent symbol table"
-  (declare (type symbol symbol)
-	   (type buffer-stream bs))
-  (let ((sym-name (symbol-name symbol)))
-    (declare (type string sym-name) 
-	     (dynamic-extent sym-name))
-    (buffer-write-byte +symbol+ bs)
-    (serialize-string sym-name bs)
-    (let ((package (symbol-package symbol)))
-      (if package
-	  (serialize-string (package-name package) bs)
-	  (buffer-write-byte +nil+ bs)))))
-
-(defun deserialize-symbol-id (id sc)
-  "Deserialize a symbol ID by finding it in the cache"
-  (declare (type fixnum id))
-  (let ((symbol (gethash id (controller-symbol-cache sc))))
-    (if symbol symbol
-	(let ((symbol (lookup-persistent-symbol sc id)))
-	  (if symbol 
-	      (progn 
-		(setf (gethash id (controller-symbol-cache sc)) symbol)
-		(setf (gethash symbol (controller-symbol-id-cache sc)) id)
-		symbol)
-	      (error "Symbol lookup foobar! ID referred to does not exist in database"))))))
-
+	finally (return (if positive num (- num)))))
\ No newline at end of file
--- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp	2007/01/16 00:51:25	1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp	2007/01/25 18:18:00	1.2
@@ -39,7 +39,7 @@
 	;; Accelerate the common case where a character set is not Latin-1
 	((and (not (equal "" string)) (< (char-code (char string 0)) #xFFFF))
 	 (serialize-to-utf16le string bstream))
-	;; Actualy code pages > 0 are rare; so we can pay an extra cost
+	;; Actually code pages > 0 are rare; so we can pay an extra cost
 	(t (or (serialize-to-utf8 string bstream)
 	       (serialize-to-utf16le string bstream)
 	       (serialize-to-utf32le string bstream)))))



From ieslick at common-lisp.net  Thu Jan 25 18:18:00 2007
From: ieslick at common-lisp.net (ieslick)
Date: Thu, 25 Jan 2007 13:18:00 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/tests
Message-ID: <20070125181800.B755E7D002@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/tests
In directory clnet:/tmp/cvs-serv27212/tests

Modified Files:
	elephant-tests.lisp 
Log Message:
Symbol ID hack removed from BDB; Allegro/MacOS/x86 passes

--- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp	2006/11/11 18:41:11	1.21
+++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp	2007/01/25 18:18:00	1.22
@@ -216,3 +216,71 @@
   `(values
     ,@(loop for form in forms
 	    collect `(is-not-null ,form))))
+
+
+(defpclass performance-test ()
+  ((slot1-is-a-test-slot :accessor perfslot1 :initarg :s1 :initform 1)
+   (slot2-is-a-really-long-symbol :accessor perfslot2 :initarg :s2 :initform 2)
+   (slot3-is-so-long-we-shouldnt-even-talk-about-it-lest-we-die :accessor perfslot3 :initarg :s3 :initform 3)))
+
+(defun performance-test ()
+  (let ((a (make-array 500))
+	(b (make-array 500 :element-type 'fixnum)))
+
+    (loop for j from 0 to 20 do
+	 (with-transaction ()
+	   (loop for i from 0 below 500 do
+		(setf (aref a i) (make-instance 'performance-test :s1 10 :s2 20 :s3 30))))
+	 (with-transaction ()
+	   (loop for i from 0 below 500 do
+		(setf (perfslot2 (aref a i)) 30)
+		(setf (aref b i) (+ (* (perfslot2 (aref a i)) 
+				       (perfslot3 (aref a i)))
+				    (perfslot1 (aref a i))))))
+	 (every (lambda (elt) (= elt 910)) b))))
+	   
+
+(defun serializer-performance-test ()
+  (elephant-memutil::with-buffer-streams (key val)
+    (loop for i from 0 upto 1000000 do
+	 (serialize 'persistent-symbol-test key *store-controller*)
+	 (deserialize key *store-controller*)
+	 (elephant-memutil::reset-buffer-stream key))))
+
+(defun slot-access-test ()
+  (let ((pt (make-instance 'performance-test))
+	(var 0))
+    (loop for i from 0 upto 1000000 do
+	 (setq var (perfslot1 pt)))))
+
+(defclass simple-class ()
+  ((slot1 :accessor slot1 :initform 20)
+   (slot-number-two :accessor slot2 :initform "This is a test")
+   (slot3 :accessor slot3 :initform 'state-is-idle)
+   (slot4 :accessor slot4 :initform 'test)))
+
+(defun regular-class-test (sc)
+  (let ((src (make-array 500))
+	(targ (make-array 500))
+	(bt (make-btree sc)))
+    (loop for i from 0 below 500 do
+	 (setf (aref src i) 
+	       (make-instance 'simple-class)))
+    (time
+     (loop for j from 0 upto 20 do
+	  (with-transaction (:store-controller sc)
+	    (loop for elt across src 
+	       for i from 0 do
+		 (setf (get-value i bt) elt)))
+	  (with-transaction (:store-controller sc)
+	    (loop for elt across src
+	       for i from 0 do
+		 (setf (aref targ i) (get-value i bt))))))))
+
+(defun serializer-stdclass-test ()
+  (let ((inst (make-instance 'simple-class)))
+    (elephant-memutil::with-buffer-streams (key val)
+      (loop for i from 0 upto 100000 do
+	   (serialize inst key *store-controller*)
+	   (deserialize key *store-controller*)
+	   (elephant-memutil::reset-buffer-stream key)))))



From ieslick at common-lisp.net  Thu Jan 25 19:37:55 2007
From: ieslick at common-lisp.net (ieslick)
Date: Thu, 25 Jan 2007 14:37:55 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/elephant
Message-ID: <20070125193755.65F5F15145@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv11335/src/elephant

Modified Files:
	backend.lisp controller.lisp 
Log Message:
Minor fixes for symbol id removal checkin

--- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp	2006/12/16 19:35:10	1.5
+++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp	2007/01/25 19:37:53	1.6
@@ -79,9 +79,6 @@
 		#:register-backend-con-init
 		#:lookup-backend-con-init
 		)
-  (:import-from :elephant-serializer2
-		#:serialize-symbol-complete
-		)
   (:export 
 		;; Variables
 		#:*cachesize*
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/25 18:18:00	1.23
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/25 19:37:53	1.24
@@ -164,9 +164,8 @@
 ;; User configuration parameters for the controller
 
 (defun load-user-configuration (controller)
-  ;; Fast symbols
-  (setf (controller-fast-symbols-p controller)
-	(elephant-system::get-config-option :fast-symbols (asdf:find-system :elephant))))
+  ;; Placeholder
+  nil)
 
 (defun initialize-serializer (sc)
   "Establish serializer version on controller startup"



From ieslick at common-lisp.net  Thu Jan 25 19:37:55 2007
From: ieslick at common-lisp.net (ieslick)
Date: Thu, 25 Jan 2007 14:37:55 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/tests
Message-ID: <20070125193755.CB7561C008@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/tests
In directory clnet:/tmp/cvs-serv11335/tests

Modified Files:
	testindexing.lisp 
Log Message:
Minor fixes for symbol id removal checkin

--- /project/elephant/cvsroot/elephant/tests/testindexing.lisp	2007/01/22 16:17:44	1.20
+++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp	2007/01/25 19:37:55	1.21
@@ -371,6 +371,8 @@
 
 (defvar normal-index nil)
 
+(defgeneric stress1 (obj))
+
 (defun make-stress-classes ()
   (defclass stress-normal ()
     ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index nil)



From rread at common-lisp.net  Fri Jan 26 14:41:08 2007
From: rread at common-lisp.net (rread)
Date: Fri, 26 Jan 2007 09:41:08 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/db-bdb
Message-ID: <20070126144108.DF0DB3144@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/db-bdb
In directory clnet:/tmp/cvs-serv22773/src/db-bdb

Modified Files:
	bdb-controller.lisp 
Log Message:
Repairing the use of the serializer for the SQL side


--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp	2007/01/19 21:03:29	1.15
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp	2007/01/26 14:41:08	1.16
@@ -271,4 +271,20 @@
 		      :free-space free-space)))
     (values (deserialize end ctrl))))
 
+;; Store the serializer version.  For BDB this can be in a file; different backends 
+;; may require a different approach.
+(defmethod database-version ((sc bdb-store-controller))
+   "A version determination for a given store
+   controller that is independant of the serializer as the
+   serializer is dispatched based on the code version which is a
+   list of the form '(0 6 0)"
+  (let ((version (elephant::controller-version-cached sc)))
+    (if version version
+	(let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc)))))
+	  (if (probe-file path)
+	      (with-open-file (stream path :direction :input)
+		(setf (elephant::controller-version-cached sc) (read stream)))
+	      (with-open-file (stream path :direction :output)
+		(setf (elephant::controller-version-cached sc)
+		      (write *elephant-code-version* :stream stream))))))))
 



From rread at common-lisp.net  Fri Jan 26 14:41:09 2007
From: rread at common-lisp.net (rread)
Date: Fri, 26 Jan 2007 09:41:09 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/db-clsql
Message-ID: <20070126144109.4DA3C1603B@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/db-clsql
In directory clnet:/tmp/cvs-serv22773/src/db-clsql

Modified Files:
	sql-collections.lisp sql-controller.lisp 
Log Message:
Repairing the use of the serializer for the SQL side


--- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp	2007/01/19 21:03:30	1.7
+++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp	2007/01/26 14:41:08	1.8
@@ -27,19 +27,17 @@
 
       ;; Somehow I suspect that what I am getting back here 
       ;; is actually the main key...
-  (let* ((sc (get-con bt))
-	 (con (controller-db sc)))
-      (let ((pk (sql-get-from-clcn (oid bt) key  sc con)))
+  (let* ((sc (get-con bt)))
+      (let ((pk (sql-get-from-clcn (oid bt) key  sc)))
 	(if pk 
-	    (sql-get-from-clcn (oid (primary bt)) pk sc con))
+	    (sql-get-from-clcn (oid (primary bt)) pk sc))
 	)))
 
 (defmethod get-primary-key (key (bt sql-btree-index))
   (declare (optimize (speed 3)))
       (let* ((sc (get-con bt))
-	     (con (controller-db sc))
 	     )
-	(sql-get-from-clcn (oid bt) key sc con)))
+	(sql-get-from-clcn (oid bt) key sc)))
 
 
 ;; My basic strategy is to keep track of a current key
@@ -321,9 +319,8 @@
 	(let* ((cur-pk (aref (:sql-crsr-ks cursor)
 			     (:sql-crsr-ck cursor)))
 	       (sc (get-con (cursor-btree cursor)))
-	       (con (controller-db sc)) 
 	       (indexed-pk (sql-get-from-clcn-nth (cursor-oid cursor) cur-pk 
-						  sc con
+						  sc
 						  (:dp-nmbr cursor))))
 	  (if indexed-pk
 	      (let ((v (get-value indexed-pk (primary (cursor-btree cursor)))))
@@ -533,8 +530,7 @@
 	      (setf (:dp-nmbr cursor) 
 		    (sql-get-from-clcn-cnt (cursor-oid cursor)
 					   (get-current-key cursor)
-					   (controller-db (get-con (cursor-btree cursor)))
-
+					   (get-con (cursor-btree cursor))
 		    ))))
 	(has-key-value-scnd cursor :returnpk returnpk))
       (cursor-last-x cursor :returnpk returnpk)))
@@ -600,7 +596,7 @@
 	(- (sql-get-from-clcn-cnt 
 	    (cursor-oid cursor)
 	    (get-current-key cursor)
-	    (controller-db (get-con (cursor-btree cursor)))
+	    (get-con (cursor-btree cursor))
 	    )
 	   1))
   (assert (>= (:dp-nmbr cursor) 0))
@@ -621,7 +617,7 @@
 	(setf (:dp-nmbr cursor) 
 	      (- (sql-get-from-clcn-cnt (cursor-oid cursor)
 					(get-current-key cursor)
-					(controller-db (get-con (cursor-btree cursor)))
+					(get-con (cursor-btree cursor))
 ) 1))
 	(has-key-value-scnd cursor :returnpk returnpk))
       (cursor-last-x cursor :returnpk returnpk)))
--- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp	2006/11/11 18:41:11	1.12
+++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp	2007/01/26 14:41:08	1.13
@@ -59,33 +59,29 @@
   )
 
 (defmethod get-value (key (bt sql-btree))
-  (let* ((sc (get-con bt))
-	 (con (controller-db sc)))
-    (sql-get-from-clcn (oid bt) key sc con)
+  (let* ((sc (get-con bt)))
+    (sql-get-from-clcn (oid bt) key sc)
     )
   )
 
 (defmethod (setf get-value) (value key (bt sql-btree))
-  (let* ((sc (get-con bt))
-	 (con (controller-db sc)))
-    (sql-add-to-clcn (oid bt) key value sc con)
+  (let* ((sc (get-con bt)))
+    (sql-add-to-clcn (oid bt) key value sc)
     )
   )
 
 (defmethod existsp (key (bt sql-btree))
-  (let* ((sc (get-con bt))
-	 (con (controller-db sc)))
-    (sql-from-clcn-existsp (oid bt) key  con)
+  (let* ((sc (get-con bt)))
+    (sql-from-clcn-existsp (oid bt) key sc)
     )
   )
 
 (defmethod remove-kv (key (bt sql-btree))
-  (let* ((sc (get-con bt))
-	 (con (controller-db sc)))
+  (let* ((sc (get-con bt)))
     (sql-remove-one-from-clcn (oid bt)
 			      key
 			      sc
-			      con))
+			      ))
   )
 
 
@@ -129,8 +125,7 @@
   )
 
 (defmethod add-index ((bt sql-indexed-btree) &key index-name key-form populate)
-  (let* ((sc (get-con bt))
-	 (con (controller-db sc)))
+  (let* ((sc (get-con bt)))
     (if (and (not (null index-name))
 	     (symbolp index-name) (or (symbolp key-form) (listp key-form)))
 	(let ((indices (indices bt))
@@ -146,15 +141,15 @@
 		 #'(lambda (k v)
 		     (multiple-value-bind (index? secondary-key)
 			 (funcall key-fn index k v)
-;; This is a slow, DB cycle intensive operation.  It could chunked somehow,
-;; I think, probably making it 10 times faster.
+		       ;; This is a slow, DB cycle intensive operation.  It could chunked somehow,
+		       ;; I think, probably making it 10 times faster.
 		       (when index?
 			 (unless (sql-from-clcn-key-and-value-existsp 
-				  (oid index) secondary-key k con)
+				  (oid index) secondary-key k sc)
 			   (sql-add-to-clcn (oid index)
 					    secondary-key
 					    k
-					    sc con :insert-only t))
+					    sc :insert-only t))
 			 )))
 		 bt))))
 	  index)
@@ -163,7 +158,6 @@
 (defmethod (setf get-value) (value key (bt sql-indexed-btree))
   "Set a key / value pair, and update secondary indices."
   (let* ((sc (get-con bt))
-	 (con (controller-db sc))
 	 (indices (indices-cache bt)))
     (with-transaction (:store-controller sc)
       (maphash 
@@ -174,15 +168,15 @@
 	     (when index?
 	       ;; This duplicates values that are already there...
 	       (unless (sql-from-clcn-key-and-value-existsp 
-			(oid index) secondary-key key con)
+			(oid index) secondary-key key sc)
 		 (sql-add-to-clcn (oid index)
 				  secondary-key
 				  key
-				  sc con :insert-only t))
+				  sc :insert-only t))
 	       )))
        indices)
       ;; Now we place the actual value
-      (sql-add-to-clcn (oid bt) key value sc con)
+      (sql-add-to-clcn (oid bt) key value sc)
       )
     value))
 
@@ -191,7 +185,7 @@
   (declare (optimize (speed 3)))
   (let* (
 	 (sc (get-con bt))
-	 (con (controller-db sc)))
+	 )
     (with-transaction (:store-controller sc)
       (let ((value (get-value key bt)))
 	(when value
@@ -209,13 +203,13 @@
 		     (sql-remove-key-and-value-from-clcn (oid index)
 							 secondary-key
 							 key
-							 con)
+							 sc)
 		     ;; And furthermore, we have to remove the index entry
 		     ;;		     (remove-kv secondary-key index)
 		     )))
 	     indices)
 	    ;; Now we place the actual value
-	    (sql-remove-from-clcn (oid bt) key sc con))
+	    (sql-remove-from-clcn (oid bt) key sc))
 	  )
 	value))))
 
@@ -233,6 +227,22 @@
 ;; way to recover from that automatically.  If it 
 ;; does not exist, return nil so we can create it later!
 
+
+(defun version-table-exists (con)
+  ;; we want to use ":owner :all" because we don't really care who created
+  ;; the table, as long as we have the rights we need!
+  (clsql:table-exists-p [version] :database con :owner :all)
+  )
+
+(defun create-version-table (con)
+  ;; ALL OF THIS needs to be inside a transaction.
+  (clsql::create-table [version]
+		       '(
+			 ([serializerversion] text :not-null)
+			 ) :database con
+		       )
+  )
+
 ;; These functions are probably not cross-database portable...
 (defun keyvalue-table-exists (con)
   ;; we want to use ":owner :all" because we don't really care who created
@@ -240,6 +250,7 @@
   (clsql:table-exists-p [keyvalue] :database con :owner :all)
   )
 
+
 ;; This is just an initial version; it is possible that 
 ;; we might someday wish to use blobs instead; certainly, I am
 ;; storing blobs now in the Berkeley-db and we meed to make sure 
@@ -260,12 +271,15 @@
 
   ;; ALL OF THIS needs to be inside a transaction.
   (clsql::create-table [keyvalue]
-		'(
-		  ([clctn_id] integer :not-null)
-		  ([key] text :not-null)
-		  ([value] text)
-		  ) :database con
-		)
+
+		       ;; This is most likely to work with any database system..
+		       '(
+			 ([clctn_id] integer :not-null)
+			 ([key] text :not-null)
+			 ([value] text)
+			 ) 
+		       :database con)
+
   ;; 	      :constraints '("PRIMARY KEY (clctn_id key)"
   ;;				     "UNIQUE (clctn_id,key)")
 
@@ -278,22 +292,46 @@
   ;;)
   ;;    (unless (index-exists-p [idx_clctn_id])
   (clsql::create-index [idx_clctn_id] :on [keyvalue]
-		:attributes '([clctn_id])
-		:database con)
+		       :attributes '([clctn_id])
+		       :database con)
   ;; )
   ;;    (unless (index-exists-p [idx_key])
   (clsql::create-index [idx_key] :on [keyvalue]
-		:attributes '([key])
-		:database con)
+		       :attributes '([key])
+		       :database con)
   ;;)
   ;; This is actually unique
   ;;    (unless (index-exists-p [idx_both])
   (clsql:create-index [idx_both] :on [keyvalue]
-		:attributes '([clctn_id] [key])
-		:database con)
+		      :attributes '([clctn_id] [key])
+		      :database con)
   ;;)
   )
 
+(defmethod database-version ((sc sql-store-controller))
+  "A version determination for a given store
+   controller that is independant of the serializer as the
+   serializer is dispatched based on the code version which is a
+   list of the form '(0 6 0)"
+  (let* ((con (controller-db sc))
+	 (version (elephant::controller-version-cached sc)))
+    (if version version
+	(let ((tuples
+	       (clsql::select [serializerversion] 
+			      :from [version]
+			      :database con)))
+	  ;; The table should exists, but there may or may not be a record there...
+	  (setf (elephant::controller-version-cached sc)
+		(if tuples 
+		    (read-from-string (caar tuples))
+		    (clsql::insert-records :into [version]
+					   :attributes '(serializerversion)
+					   :values (list (format nil "~A" *elephant-code-version*))
+					   :database con)
+		    )
+		)))))
+
+
 (defmethod open-controller ((sc sql-store-controller)
 			    ;; At present these three have no meaning
 			    &key 
@@ -304,14 +342,18 @@
   (the sql-store-controller
     (let* ((dbtype (car (second (controller-spec sc))))
 	   (con (clsql:connect (cdr (second (controller-spec sc)))
-			      :database-type dbtype
-			      :if-exists :old)))
+			       :database-type dbtype
+			       :if-exists :old)))
       (setf (slot-value sc 'db) con)
       ;; Now we should make sure that the KEYVALUE table exists, and, if 
       ;; it does not, we need to create it..
       (unless (keyvalue-table-exists con)
 	(with-transaction (:store-controller sc)
 	  (create-keyvalue-table con)))
+      (unless (version-table-exists con)
+	(with-transaction (:store-controller sc)
+	  (create-version-table con)))
+      (elephant::initialize-serializer sc)
       ;; These should get oid 0 and 1 respectively 
       (setf (slot-value sc 'root) (make-instance 'sql-btree :sc sc :from-oid 0))
       (setf (slot-value sc 'class-root) (make-instance 'sql-indexed-btree :sc sc :from-oid 1))
@@ -322,7 +364,7 @@
 (defmethod reconnect-controller ((sc sql-store-controller))
   (setf (controller-db sc)
 	(clsql:reconnect :database (controller-db sc)))
-)
+  )
 (defmethod close-controller ((sc sql-store-controller))
   (when (slot-value sc 'db)
     ;; close the connection
@@ -337,7 +379,7 @@
 (defmethod next-oid ((sc sql-store-controller ))
   (let ((con (controller-db sc)))
     (clsql:sequence-next [persistent_seq]
-		   :database con))
+			 :database con))
   )
 
 ;; if add-to-root is a method, then we can make it class dependent...
@@ -348,39 +390,39 @@
 ;; a proper method myself, but I will give it a name so it doesn't 
 ;; conflict with 'add-to-root.  'add-to-root can remain a convenience symbol,
 ;; that will end up calling this routine!
-(defun sql-add-to-root (key value pgsc con)
-  (sql-add-to-clcn 0 key value pgsc con)
+(defun sql-add-to-root (key value sc)
+  (sql-add-to-clcn 0 key value sc)
   )
 
-(defun sql-add-to-clcn (clcn key value sc con
-			    &key (insert-only nil))
+(defun sql-add-to-clcn (clcn key value sc
+			&key (insert-only nil))
   (declare (ignore sc))
   (assert (integerp clcn))
-  (let (
+  (let ((con (controller-db sc))
 	(vbs 
-	 (serialize-to-base64-string value))
+	 (serialize-to-base64-string value sc))
 	(kbs
-	 (serialize-to-base64-string key))
+	 (serialize-to-base64-string key sc))
 	)
-    (if (and (not insert-only) (sql-from-clcn-existsp clcn key con))
+    (if (and (not insert-only) (sql-from-clcn-existsp clcn key sc))
 	(clsql::update-records [keyvalue]
-			:av-pairs `((key ,kbs)
-				    (clctn_id ,clcn)
-				    (value ,vbs))
-			:where [and [= [clctn_id] clcn] [= [key] kbs]]
-			:database con)
+			       :av-pairs `((key ,kbs)
+					   (clctn_id ,clcn)
+					   (value ,vbs))
+			       :where [and [= [clctn_id] clcn] [= [key] kbs]]
+			       :database con)
 	(clsql::insert-records :into [keyvalue]
-			:attributes '(key clctn_id value)
-			:values (list kbs clcn vbs)
-			:database con
-			))
+			       :attributes '(key clctn_id value)
+			       :values (list kbs clcn vbs)
+			       :database con
+			       ))
     )
   value
   )
 
 
-(defun sql-get-from-root (key sc con)
-  (sql-get-from-clcn 0 key sc con)
+(defun sql-get-from-root (key sc)
+  (sql-get-from-clcn 0 key sc)
   )
 
 ;; This is a major difference betwen SQL and BDB:
@@ -399,22 +441,29 @@
 ;; To do that I have to read in all of the values and deserialized them
 ;; This could be a good reason to keep the oids out, and separte, in 
 ;; a separate column.
-(defun sql-get-from-clcn (clcn key sc con)
+(defun sql-get-from-clcn (clcn key sc)
   (assert (integerp clcn))
-  (sql-get-from-clcn-nth clcn key sc con 0)
+  (sql-get-from-clcn-nth clcn key sc 0)
   )
 
-(defun sql-get-from-clcn-nth (clcn key sc con n)
+(defun sql-get-from-clcn-nth (clcn key sc n)
   (assert (and (integerp clcn) (integerp n)))
-  (let* (
+  (let* ((con (controller-db sc))
 	 (kbs 
-	  (serialize-to-base64-string key))
+	  (serialize-to-base64-string key sc))
+	 (offsetquery (format nil "select value from keyvalue where clctn_id = ~A and key = '~A' order by value offset ~A limit 1 "
+			      clcn
+			      kbs
+			      n))
 	 (tuples
-	  (clsql::select [value] 
-		  :from [keyvalue]
-		  :where [and [= [clctn_id] clcn] [= [key] kbs]]
-		  :database con
-		  )))
+;;	  (clsql::query offsetquery :database con)
+	     	  (clsql::select [value] 
+	     			 :from [keyvalue]
+	     			 :where [and [= [clctn_id] clcn] [= [key] kbs]]
+	     			 :database con
+	     			 )
+	   )
+	 )
     ;; Get the lowest value by sorting and taking the first value;
     ;; this isn't a very good way to do things...
     ;; Note also that this will be extremely inefficient if 
@@ -424,95 +473,101 @@
     ;; that efficiently without changing the database structure;
     ;; but that's OK, I could add a column to support that 
     ;; relatively easily later on.
+;;    (if (and (> (length tuples) 1))
+;;	(format t "l = ~A~%" (length tuples))
+;;	)
     (if (< n (length tuples))
+;;	(values (deserialize-from-base64-string (car (nth n tuples)) sc)
+;;		t)
 	(values (nth n (sort 
 			(mapcar 
 			 #'(lambda (x)
-			     (deserialize-from-base64-string (car x) :sc sc))
+			     (deserialize-from-base64-string (car x) sc))
 			 tuples)
 			#'my-generic-less-than))
 		t)
 	(values nil nil))))
 
-(defun sql-get-from-clcn-cnt (clcn key con)
+(defun sql-get-from-clcn-cnt (clcn key sc)
   (assert (integerp clcn))
-  (let* (
-	 (kbs (serialize-to-base64-string key))
+  (let* ((con (controller-db sc))
+	 (kbs (serialize-to-base64-string key sc))
 	 (tuples
 	  (clsql::select [count [value]]
-		  :from [keyvalue]

[244 lines skipped]



From rread at common-lisp.net  Fri Jan 26 14:41:14 2007
From: rread at common-lisp.net (rread)
Date: Fri, 26 Jan 2007 09:41:14 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/elephant
Message-ID: <20070126144114.127311603B@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv22773/src/elephant

Modified Files:
	backend.lisp controller.lisp serializer.lisp 
Log Message:
Repairing the use of the serializer for the SQL side


--- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp	2007/01/25 19:37:53	1.6
+++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp	2007/01/26 14:41:13	1.7
@@ -39,6 +39,7 @@
 		#:*elephant-code-version*
 		#:store-controller
 		#:open-controller
+		#:database-version
 		#:close-controller
 		#:controller-serialize
 		#:controller-deserialize
@@ -95,6 +96,7 @@
 		#:*elephant-code-version*
 		#:store-controller
 		#:open-controller
+		#:database-version
 		#:close-controller
 		#:controller-serialize
 		#:controller-deserialize
@@ -136,4 +138,4 @@
 		#:register-backend-con-init
 		#:lookup-backend-con-init
 		))
-		
\ No newline at end of file
+		
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/25 19:37:53	1.24
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/26 14:41:13	1.25
@@ -112,8 +112,9 @@
   (assert (consp spec))
   (setq *store-controller* (get-controller spec))
   (load-user-configuration *store-controller*)
+  (apply #'open-controller *store-controller* args)
   (initialize-serializer *store-controller*)
-  (apply #'open-controller *store-controller* args))
+  )
 
 (defun close-store (&optional sc)
   "Conveniently close the store controller."
@@ -178,24 +179,7 @@
 	 (setf (controller-serialize sc) 'elephant-serializer2::serialize)
 	 (setf (controller-deserialize sc) 'elephant-serializer2::deserialize))))
 
-;;
-;; VERSIONING
-;;
 
-(defmethod database-version ((sc store-controller))
-   "A version determination for a given store
-   controller that is independant of the serializer as the
-   serializer is dispatched based on the code version which is a
-   list of the form '(0 6 0)"
-  (let ((version (controller-version-cached sc)))
-    (if version version
-	(let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc)))))
-	  (if (probe-file path)
-	      (with-open-file (stream path :direction :input)
-		(setf (controller-version-cached sc) (read stream)))
-	      (with-open-file (stream path :direction :output)
-		(setf (controller-version-cached sc)
-		      (write *elephant-code-version* :stream stream))))))))
 
 (defun prior-version-p (v1 v2)
   "Is v1 an equal or earlier version than v2"
@@ -258,6 +242,15 @@
   (intern (string-upcase (cdr name)) (car name)))
 
 
+
+;;
+;; VERSIONING
+;;
+
+(defgeneric database-version (sc)
+  (:documentation "Backends implement this to store the serializer version")
+  )
+
 ;;
 ;; STORE CONTROLLER PROTOCOL
 ;; 
--- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp	2007/01/21 21:20:04	1.17
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp	2007/01/26 14:41:13	1.18
@@ -36,19 +36,24 @@
   (with-buffer-streams (out-buf)
   (cl-base64::usb8-array-to-base64-string
    (elephant-memutil::buffer-read-byte-vector 
-    (serialize x out-buf sc)))))
+    (serialize x out-buf sc)))
+ )
+)
 
 (defun convert-buffer-to-base64-string (bs sc)
   (declare (ignore sc))
   (cl-base64::usb8-array-to-base64-string
-   (elephant-memutil::buffer-read-byte-vector bs)))
+   (elephant-memutil::buffer-read-byte-vector bs)
+)
+)
 
 (defun deserialize-from-base64-string (x sc)
   (with-buffer-streams (other)
     (deserialize 
      (elephant-memutil::buffer-write-byte-vector 
       other 
-      (cl-base64::base64-string-to-usb8-array x))
+      (cl-base64::base64-string-to-usb8-array x)
+      )
      sc)
     ))
 



From ieslick at common-lisp.net  Mon Jan 29 15:15:04 2007
From: ieslick at common-lisp.net (ieslick)
Date: Mon, 29 Jan 2007 10:15:04 -0500 (EST)
Subject: [elephant-cvs] CVS elephant
Message-ID: <20070129151504.9A0F92D160@common-lisp.net>

Update of /project/elephant/cvsroot/elephant
In directory clnet:/tmp/cvs-serv26676

Modified Files:
	elephant.asd 
Log Message:
Build support for 64-bit compilation or OpenMCL 1.1 on OS X

--- /project/elephant/cvsroot/elephant/elephant.asd	2007/01/25 18:17:59	1.24
+++ /project/elephant/cvsroot/elephant/elephant.asd	2007/01/29 15:15:04	1.25
@@ -109,6 +109,7 @@
   (list 
    #-(or darwin macosx darwin-host) "-shared"
    #+(or darwin macosx darwin-host) "-bundle"
+   #+(or x8664-target) "-arch x86_64"
    "-Wall"
    "-fPIC"
    "-O3"



From ieslick at common-lisp.net  Wed Jan 31 20:05:37 2007
From: ieslick at common-lisp.net (ieslick)
Date: Wed, 31 Jan 2007 15:05:37 -0500 (EST)
Subject: [elephant-cvs] CVS elephant
Message-ID: <20070131200537.B618E5B005@common-lisp.net>

Update of /project/elephant/cvsroot/elephant
In directory clnet:/tmp/cvs-serv24260

Modified Files:
	TODO ele-bdb.asd 
Log Message:
Upgrade to BDB 4.5; green on Allegro 8.0/Mac OS X

--- /project/elephant/cvsroot/elephant/TODO	2007/01/25 18:17:59	1.37
+++ /project/elephant/cvsroot/elephant/TODO	2007/01/31 20:05:37	1.38
@@ -7,14 +7,13 @@
 --------------------------------------------
 
 Active tasks:
-- Speed up symbol storage and reference using symbol id's
-  - Fast symbols are property tag in DB (so code doesn't corrupt DB)
 - Full 64-bit support (arrays, native 64-bit fixnums, etc)
   - Set parameter at startup based on *features*
   - Mark fixnums appropriately: 32-bit lisps can decode 64-bit fixnums as bignums (two 32-bit entities)
     - propogate assumptions to bignum byte specs
     - are there other fixed assumptions?
   - char vs. uint8 in buffer-stream to read-out (See Marco e-mail)
+
 - Ensure serialization is thread-safe and reasonably efficient
   - Provide support for fast and slow critical sections by lisps: buffer-streams, 
     circularity-arrays/hashes, shared controller side-effects... (see email)
@@ -69,6 +68,7 @@
 - Cleaner failure modes if operations are performed without repository or without
   transaction or auto-commit (auto-commit solved by 4.4?)
 - Review and address all NOTE comments in the code
+- Use SWIG and CFFI to better track changes in defconstant?
 
 RELEASE ISSUES
 
@@ -81,8 +81,6 @@
 - Validate migration 0.6.0->0.6.1
   - Validate that migrate can use either O(c) or O(n/c) where c << n memory
 - Windows support for asdf-based library builds?  Include dll?
-- Allow dump of fast-symbol tables for low-level reconstruction in case of 
-  catastrophic errors
 
 Documentation:
 - Migrate code base to SVN and create tickets in TRAC
@@ -99,7 +97,6 @@
 
 January 22, 2006 checkins:
 x Modularize serializers for easy upgrade
-x Implement backend support for symbol-table protocol
 x MCL 1.1 unicode support; clean up other lisp support for unicode
 x Simplify user-specific configuration parameters using config.sexp and my-config.sexp
 x Ensure thread safety in buffer-stream allocation!
--- /project/elephant/cvsroot/elephant/ele-bdb.asd	2007/01/21 21:20:03	1.15
+++ /project/elephant/cvsroot/elephant/ele-bdb.asd	2007/01/31 20:05:37	1.16
@@ -63,7 +63,6 @@
 		       (:bdb-c-source "libberkeley-db")
 		       (:file "berkeley-db")
 		       (:file "bdb-controller")
-		       (:file "bdb-symbol-tables")
 		       (:file "bdb-slots")
 		       (:file "bdb-collections")
 		       (:file "bdb-transactions"))



From ieslick at common-lisp.net  Wed Jan 31 20:05:38 2007
From: ieslick at common-lisp.net (ieslick)
Date: Wed, 31 Jan 2007 15:05:38 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/db-bdb
Message-ID: <20070131200538.0EFD05B005@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/db-bdb
In directory clnet:/tmp/cvs-serv24260/src/db-bdb

Modified Files:
	bdb-collections.lisp bdb-controller.lisp berkeley-db.lisp 
	libberkeley-db.c 
Removed Files:
	bdb-symbol-tables.lisp 
Log Message:
Upgrade to BDB 4.5; green on Allegro 8.0/Mac OS X

--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp	2006/12/16 19:35:10	1.11
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp	2007/01/31 20:05:37	1.12
@@ -19,6 +19,8 @@
 
 (in-package :db-bdb)
 
+(declaim  #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0)))
+
 (defclass bdb-btree (btree) ()
   (:documentation "A BerkleyDB implementation of a BTree"))
 
@@ -32,7 +34,6 @@
   (make-instance 'bdb-btree :sc sc))
 
 (defmethod get-value (key (bt bdb-btree))
-  (declare (optimize (speed 3) (space 0) (safety 0)))
   (let ((sc (get-con bt)))
     (with-buffer-streams (key-buf value-buf)
       (buffer-write-int (oid bt) key-buf)
@@ -43,7 +44,6 @@
 	    (values nil nil))))))
 
 (defmethod existsp (key (bt bdb-btree))
-  (declare (optimize (speed 3) (safety 0) (space 0)))
   (with-buffer-streams (key-buf value-buf)
     (buffer-write-int (oid bt) key-buf)
     (serialize key key-buf (get-con bt))
@@ -55,8 +55,6 @@
 
 
 (defmethod (setf get-value) (value key (bt bdb-btree))
-  (declare (optimize (speed 3) (safety 0) (space 0)))
-  (assert (or *auto-commit* (not (eq *current-transaction* 0))))
 ;;  (with-transaction ()
     (let ((sc (get-con bt)))
       (with-buffer-streams (key-buf value-buf)
@@ -64,8 +62,7 @@
 	(serialize key key-buf sc)
 	(serialize value value-buf sc)
 	(db-put-buffered (controller-btrees sc)
-			 key-buf value-buf
-			 :auto-commit *auto-commit*)))
+			 key-buf value-buf)))
 ;;    )
   value)
 
@@ -85,15 +82,13 @@
 ;; 	(write-value))))
 
 (defmethod remove-kv (key (bt bdb-btree))
-  (declare (optimize (speed 3) (space 0) (safety 0)))
-  (assert (or *auto-commit* (not (eq *current-transaction* 0))))
 ;;  (with-transaction (:store-controller (get-con bt))
   (let ((sc (get-con bt)) )
     (with-buffer-streams (key-buf)
       (buffer-write-int (oid bt) key-buf)
       (serialize key key-buf sc)
       (db-delete-buffered (controller-btrees sc)
-			  key-buf :auto-commit *auto-commit*))))
+			  key-buf))))
 
 ;; Secondary indices
 
@@ -216,7 +211,6 @@
 
 (defmethod remove-kv (key (bt bdb-indexed-btree))
   "Remove a key / value pair, and update secondary indices."
-  (declare (optimize (speed 3)))
   (let ((sc (get-con bt)))
       (with-buffer-streams (key-buf secondary-buf)
 	(buffer-write-int (oid bt) key-buf)
@@ -252,7 +246,6 @@
 
 (defmethod get-value (key (bt bdb-btree-index))
   "Get the value in the primary DB from a secondary key."
-  (declare (optimize (speed 3)))
   (with-buffer-streams (key-buf value-buf)
     (buffer-write-int (oid bt) key-buf)
     (serialize key key-buf (get-con bt))
@@ -263,7 +256,6 @@
 	  (values nil nil)))))
 
 (defmethod get-primary-key (key (bt btree-index))
-  (declare (optimize (speed 3)))
   (let ((sc (get-con bt)))
     (with-buffer-streams (key-buf value-buf)
       (buffer-write-int (oid bt) key-buf)
@@ -282,19 +274,16 @@
 
 (defmethod make-cursor ((bt bdb-btree))
   "Make a cursor from a btree."
-  (declare (optimize (speed 3)))
   (make-instance 'bdb-cursor 
 		 :btree bt
 		 :handle (db-cursor (controller-btrees (get-con bt)))
 		 :oid (oid bt)))
 
 (defmethod cursor-close ((cursor bdb-cursor))
-  (declare (optimize (speed 3)))
   (db-cursor-close (cursor-handle cursor))
   (setf (cursor-initialized-p cursor) nil))
 
 (defmethod cursor-duplicate ((cursor bdb-cursor))
-  (declare (optimize (speed 3)))
   (make-instance (type-of cursor)
 		 :initialized-p (cursor-initialized-p cursor)
 		 :oid (cursor-oid cursor)
@@ -303,7 +292,6 @@
 			  :position (cursor-initialized-p cursor))))
 
 (defmethod cursor-current ((cursor bdb-cursor))
-  (declare (optimize (speed 3)))
   (when (cursor-initialized-p cursor)
     (let ((sc (get-con (cursor-btree cursor))))
       (with-buffer-streams (key-buf value-buf)
@@ -317,7 +305,6 @@
 	      (setf (cursor-initialized-p cursor) nil)))))))
 
 (defmethod cursor-first ((cursor bdb-cursor))
-  (declare (optimize (speed 3)))
   (let ((sc (get-con (cursor-btree cursor))))
   (with-buffer-streams (key-buf value-buf)
     (buffer-write-int (cursor-oid cursor) key-buf)
@@ -333,7 +320,6 @@
 		 
 ;;A bit of a hack.....
 (defmethod cursor-last ((cursor bdb-cursor))
-  (declare (optimize (speed 3)))
   (let ((sc (get-con (cursor-btree cursor))))
   (with-buffer-streams (key-buf value-buf)
     (buffer-write-int (+ (cursor-oid cursor) 1) key-buf)
@@ -361,7 +347,6 @@
 	      (setf (cursor-initialized-p cursor) nil)))))))
 
 (defmethod cursor-next ((cursor bdb-cursor))
-  (declare (optimize (speed 3)))
   (if (cursor-initialized-p cursor)
       (let ((sc (get-con (cursor-btree cursor))))
 	(with-buffer-streams (key-buf value-buf)
@@ -375,7 +360,6 @@
       (cursor-first cursor)))
 	  
 (defmethod cursor-prev ((cursor bdb-cursor))
-  (declare (optimize (speed 3)))
   (if (cursor-initialized-p cursor)
       (let ((sc (get-con (cursor-btree cursor))))
 	(with-buffer-streams (key-buf value-buf)
@@ -389,7 +373,6 @@
 	(cursor-last cursor))))
 	  
 (defmethod cursor-set ((cursor bdb-cursor) key)
-  (declare (optimize (speed 3)))
   (let ((sc (get-con (cursor-btree cursor))))
   (with-buffer-streams (key-buf value-buf)
     (buffer-write-int (cursor-oid cursor) key-buf)
@@ -404,7 +387,6 @@
 	  (setf (cursor-initialized-p cursor) nil))))))
 
 (defmethod cursor-set-range ((cursor bdb-cursor) key)
-  (declare (optimize (speed 3)))
   (let ((sc (get-con (cursor-btree cursor))))
   (with-buffer-streams (key-buf value-buf)
     (buffer-write-int (cursor-oid cursor) key-buf)
@@ -419,7 +401,6 @@
 	  (setf (cursor-initialized-p cursor) nil))))))
 
 (defmethod cursor-get-both ((cursor bdb-cursor) key value)
-  (declare (optimize (speed 3)))
   (let ((sc (get-con (cursor-btree cursor))))
   (with-buffer-streams (key-buf value-buf)
     (buffer-write-int (cursor-oid cursor) key-buf)
@@ -435,7 +416,6 @@
 	  (setf (cursor-initialized-p cursor) nil))))))
 
 (defmethod cursor-get-both-range ((cursor bdb-cursor) key value)
-  (declare (optimize (speed 3)))
   (let ((sc (get-con (cursor-btree cursor))))
   (with-buffer-streams (key-buf value-buf)
     (buffer-write-int (cursor-oid cursor) key-buf)
@@ -450,7 +430,6 @@
 	  (setf (cursor-initialized-p cursor) nil))))))
 
 (defmethod cursor-delete ((cursor bdb-cursor))
-  (declare (optimize (speed 3)))
   (if (cursor-initialized-p cursor)
       (with-buffer-streams (key-buf value-buf)
 	(multiple-value-bind (key val)
@@ -469,7 +448,6 @@
   "Put by cursor.  Not particularly useful since primaries
 don't support duplicates.  Currently doesn't properly move
 the cursor."
-  (declare (optimize (speed 3)))
   (if key-specified-p
       (setf (get-value key (cursor-btree cursor)) value)
       (if (cursor-initialized-p cursor)
@@ -493,7 +471,6 @@
 
 (defmethod make-cursor ((bt bdb-btree-index))
   "Make a secondary-cursor from a secondary index."
-  (declare (optimize (speed 3)))
   (make-instance 'bdb-secondary-cursor 
 		 :btree bt
 		 :handle (db-cursor 
@@ -502,7 +479,6 @@
 
 
 (defmethod cursor-pcurrent ((cursor bdb-secondary-cursor))
-  (declare (optimize (speed 3)))
   (when (cursor-initialized-p cursor)
     (with-buffer-streams (key-buf pkey-buf value-buf)
       (multiple-value-bind (key pkey val)
@@ -519,7 +495,6 @@
 	    (setf (cursor-initialized-p cursor) nil))))))
 
 (defmethod cursor-pfirst ((cursor bdb-secondary-cursor))
-  (declare (optimize (speed 3)))
   (with-buffer-streams (key-buf pkey-buf value-buf)
     (buffer-write-int (cursor-oid cursor) key-buf)
     (multiple-value-bind (key pkey val)
@@ -536,7 +511,6 @@
 		 
 ;;A bit of a hack.....
 (defmethod cursor-plast ((cursor bdb-secondary-cursor))
-  (declare (optimize (speed 3)))
   (let ((sc (get-con (cursor-btree cursor))))
   (with-buffer-streams (key-buf pkey-buf value-buf)
     (buffer-write-int (+ (cursor-oid cursor) 1) key-buf)
@@ -568,7 +542,6 @@
 	      (setf (cursor-initialized-p cursor) nil)))))))
 
 (defmethod cursor-pnext ((cursor bdb-secondary-cursor))
-  (declare (optimize (speed 3)))
   (if (cursor-initialized-p cursor)
       (with-buffer-streams (key-buf pkey-buf value-buf)
 	(multiple-value-bind (key pkey val)
@@ -583,7 +556,6 @@
       (cursor-pfirst cursor)))
 	  
 (defmethod cursor-pprev ((cursor bdb-secondary-cursor))
-  (declare (optimize (speed 3)))
   (if (cursor-initialized-p cursor)
       (with-buffer-streams (key-buf pkey-buf value-buf)
 	(multiple-value-bind (key pkey val)
@@ -598,7 +570,6 @@
       (cursor-plast cursor)))
 
 (defmethod cursor-pset ((cursor bdb-secondary-cursor) key)
-  (declare (optimize (speed 3)))
   (let ((sc (get-con (cursor-btree cursor))))
     (with-buffer-streams (key-buf pkey-buf value-buf)
       (buffer-write-int (cursor-oid cursor) key-buf)
@@ -615,7 +586,6 @@
 	    (setf (cursor-initialized-p cursor) nil))))))
 
 (defmethod cursor-pset-range ((cursor bdb-secondary-cursor) key)
-  (declare (optimize (speed 3)))
   (let ((sc (get-con (cursor-btree cursor))))
     (with-buffer-streams (key-buf pkey-buf value-buf)
       (buffer-write-int (cursor-oid cursor) key-buf)
@@ -631,7 +601,6 @@
 	    (setf (cursor-initialized-p cursor) nil))))))
 
 (defmethod cursor-pget-both ((cursor bdb-secondary-cursor) key pkey)
-  (declare (optimize (speed 3)))
   (with-buffer-streams (key-buf pkey-buf value-buf)
     (let ((primary-oid (oid (primary (cursor-btree cursor))))
 	  (sc (get-con (cursor-btree cursor))))
@@ -649,7 +618,6 @@
 	    (setf (cursor-initialized-p cursor) nil))))))
 
 (defmethod cursor-pget-both-range ((cursor bdb-secondary-cursor) key pkey)
-  (declare (optimize (speed 3)))
   (with-buffer-streams (key-buf pkey-buf value-buf)
     (let ((primary-oid (oid (primary (cursor-btree cursor))))
 	  (sc (get-con (cursor-btree cursor))))
@@ -668,7 +636,6 @@
 
 (defmethod cursor-delete ((cursor bdb-secondary-cursor))
   "Delete by cursor: deletes ALL secondary indices."
-  (declare (optimize (speed 3)))
   (if (cursor-initialized-p cursor)
       (with-buffer-streams (key-buf pkey-buf value-buf)
 	(multiple-value-bind (key pkey val)
@@ -706,7 +673,6 @@
   (error "Puts are forbidden on secondary indices.  Try adding to the primary."))
 
 (defmethod cursor-next-dup ((cursor bdb-secondary-cursor))
-  (declare (optimize (speed 3)))
   (when (cursor-initialized-p cursor)
     (with-buffer-streams (key-buf value-buf)
       (multiple-value-bind (key val)
@@ -718,7 +684,6 @@
 	    (setf (cursor-initialized-p cursor) nil))))))
 	  
 (defmethod cursor-next-nodup ((cursor bdb-secondary-cursor))
-  (declare (optimize (speed 3)))
   (if (cursor-initialized-p cursor)
       (with-buffer-streams (key-buf value-buf)
 	(multiple-value-bind (key val)
@@ -731,7 +696,6 @@
       (cursor-first cursor)))	  
 
 (defmethod cursor-prev-nodup ((cursor bdb-secondary-cursor))
-  (declare (optimize (speed 3)))
   (if (cursor-initialized-p cursor)
       (with-buffer-streams (key-buf value-buf)
 	(multiple-value-bind (key val)
@@ -744,7 +708,6 @@
       (cursor-last cursor)))
 
 (defmethod cursor-pnext-dup ((cursor bdb-secondary-cursor))
-  (declare (optimize (speed 3)))
   (when (cursor-initialized-p cursor)
     (with-buffer-streams (key-buf pkey-buf value-buf)
       (multiple-value-bind (key pkey val)
@@ -757,7 +720,6 @@
 	    (setf (cursor-initialized-p cursor) nil))))))
 	  
 (defmethod cursor-pnext-nodup ((cursor bdb-secondary-cursor))
-  (declare (optimize (speed 3)))
   (if (cursor-initialized-p cursor)
       (with-buffer-streams (key-buf pkey-buf value-buf)
 	(multiple-value-bind (key pkey val)
@@ -771,16 +733,15 @@
       (cursor-pfirst cursor)))
 
 (defmethod cursor-pprev-nodup ((cursor bdb-secondary-cursor))
-  (declare (optimize (speed 3)))
   (if (cursor-initialized-p cursor)
       (with-buffer-streams (key-buf pkey-buf value-buf)
 	(multiple-value-bind (key pkey val)
 	    (db-cursor-pmove-buffered (cursor-handle cursor) key-buf
 				      pkey-buf value-buf :prev-nodup t)
 	  (if (and key (= (buffer-read-int key) (cursor-oid cursor)))
-	      (values t (deserialize key (get-con (cursor-btree cursor))) 
+	      (values t (deserialize key (get-con (cursor-btree cursor)))
 		      (deserialize val (get-con (cursor-btree cursor)))
-		      (progn (buffer-read-int pkey) 
+		      (progn (buffer-read-int pkey)
 			     (deserialize pkey (get-con (cursor-btree cursor)))))
 	      (setf (cursor-initialized-p cursor) nil))))
       (cursor-plast cursor)))
--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp	2007/01/26 14:41:08	1.16
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp	2007/01/31 20:05:37	1.17
@@ -19,6 +19,8 @@
 
 (in-package :db-bdb)
 
+(declaim  #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0)))
+
 (defclass bdb-store-controller (store-controller)
   ((db :type (or null pointer-void) :accessor controller-db :initform '())
    (environment :type (or null pointer-void) 
@@ -61,15 +63,15 @@
 ;; Open/close     
 ;;
 
-(defmethod open-controller ((sc bdb-store-controller) &key (recover t)
-			    (recover-fatal nil) (thread t)
+(defmethod open-controller ((sc bdb-store-controller) &key (recover nil)
+			    (recover-fatal nil) (thread t) (errfile nil)
 			    (deadlock-detect nil))
   (let ((env (db-env-create)))
-    ;; thread stuff?
     (setf (controller-environment sc) env)
+    (db-env-set-flags env 0 :auto-commit t)
     (db-env-open env (namestring (second (controller-spec sc)))
-		 :create t :init-txn t :init-lock t 
-		 :init-mpool t :init-log t :thread thread
+		 :create t :init-rep nil :init-mpool t :thread thread
+		 :init-lock t :init-log t :init-txn t 
 		 :recover recover :recover-fatal recover-fatal
 		 )
     (db-env-set-timeout env 100000 :set-transaction-timeout t)
@@ -99,7 +101,7 @@
       (db-bdb::db-set-lisp-dup-compare indices-assoc (controller-serializer-version sc))
       (db-set-flags indices-assoc :dup-sort t)
       (db-open indices-assoc :file "%ELEPHANT" :database "%ELEPHANTINDICES" 
-	       :auto-commit t :type DB-UNKNOWN :thread thread :rdonly t)
+	       :auto-commit t :type DB-UNKNOWN :thread thread) ;; :rdonly t)
       (db-bdb::db-fake-associate btrees indices-assoc :auto-commit t)
       
       (let ((db (db-create env)))
@@ -134,18 +136,14 @@
       (setf (slot-value sc 'class-root)
 	    (make-instance 'bdb-btree :from-oid -2 :sc sc))
 
+      (when errfile
+	(db-set-error-file (controller-db sc) errfile))
+
       (when deadlock-detect
 	(start-deadlock-detector sc))
 
       sc)))
 
-;; NOTE: This was the easist way to do this.  A BDB hash table would be better
-;; and perhaps generally a better thing to export; however I don't want to
-;; go through the effort at this time.
-
-(defparameter *symbol-to-id-table-oid* -3)
-(defparameter *id-to-symbol-table-oid* -4)
-
 (defmethod close-controller ((sc bdb-store-controller))
   (when (slot-value sc 'root)
     (stop-deadlock-detector sc)
--- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp	2007/01/22 22:22:35	1.4
+++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp	2007/01/31 20:05:37	1.5
@@ -77,80 +77,85 @@
 ;; eventually write a macro which generates a custom flag function.
 ;;
 
-;I don't like the UFFI syntax for enumerations
+;; Current header file version required: Berkeley DB 4.5
+
+;; I don't like the UFFI syntax for enumerations
 (defconstant DB-BTREE                 1)
 (defconstant DB-HASH                  2)
 (defconstant DB-RECNO                 3)
 (defconstant DB-QUEUE                 4)
 (defconstant DB-UNKNOWN               5)
 
-(defconstant DB_CREATE        #x00000001)
 (defconstant DB_LOCK_NOWAIT   #x00000002)
+
+(defconstant DB_CREATE        #x00000001)
 (defconstant DB_FORCE         #x00000004)
-(defconstant DB_NOMMAP        #x00000008)
-(defconstant DB_RDONLY        #x00000010)
-(defconstant DB_RECOVER       #x00000020)
-(defconstant DB_THREAD        #x00000040)
-(defconstant DB_TRUNCATE      #x00000080)
-(defconstant DB_TXN_NOSYNC    #x00000100)
-(defconstant DB_EXCL          #x00002000)
+(defconstant DB_MULTIVERSION  #x00000008)
+(defconstant DB_NOMMAP        #x00000010)
+(defconstant DB_RDONLY        #x00000020)
+(defconstant DB_RECOVER       #x00000040)
+(defconstant DB_THREAD        #x00000080)
+(defconstant DB_TRUNCATE      #x00000100)
+(defconstant DB_TXN_NOSYNC    #x00000200)
+(defconstant DB_TXN_NOT_DURABLE #x00000400)
+(defconstant DB_TXN_WRITE_NOSYNC #x00000800)
+
+(defconstant DB_EXCL          #x00004000)
 
-(defconstant DB_TXN_NOWAIT    #x00002000)
-(defconstant DB_TXN_SYNC      #x00004000)
+(defconstant DB_TXN_NOWAIT    #x00004000)
+(defconstant DB_TXN_SYNC      #x00008000)
 
-(defconstant DB_DUP           #x00004000)
-(defconstant DB_DUPSORT       #x00008000)
+(defconstant DB_DUP           #x00008000)
+(defconstant DB_DUPSORT       #x00010000)
 
 (defconstant DB_JOINENV          #x00000000)
-(defconstant DB_INIT_CDB         #x00002000)
-(defconstant DB_INIT_LOCK        #x00004000)
-(defconstant DB_INIT_LOG         #x00008000)
-(defconstant DB_INIT_MPOOL       #x00010000)
-(defconstant DB_INIT_REP         #x00020000)
-(defconstant DB_INIT_TXN         #x00040000)
-(defconstant DB_LOCKDOWN         #x00080000)
-(defconstant DB_PRIVATE          #x00100000)
-(defconstant DB_RECOVER_FATAL    #x00200000)
-(defconstant DB_SYSTEM_MEM       #x00800000)
-(defconstant DB_AUTO_COMMIT      #x01000000)
-(defconstant DB_READ_COMMITTED   #x02000000)
-(defconstant DB_DEGREE_2         #x02000000) ;; DEPRECATED, now called DB_READ_COMMITTED
-(defconstant DB_READ_UNCOMMITTED #x04000000)
-(defconstant DB_DIRTY_READ       #x04000000) ;; DEPRECATED, now called DB_READ_UNCOMMITTED
-
-(defconstant DB_CURRENT		      7)
-(defconstant DB_FIRST		      9)
-(defconstant DB_GET_BOTH	     10)
-(defconstant DB_GET_BOTH_RANGE	     12)
-(defconstant DB_LAST		     17)
-(defconstant DB_NEXT		     18)
-(defconstant DB_NEXT_DUP	     19)
-(defconstant DB_NEXT_NODUP	     20)
-(defconstant DB_PREV		     25)
-(defconstant DB_PREV_NODUP	     26)
-(defconstant DB_SET		     28)
-(defconstant DB_SET_RANGE	     30)
+(defconstant DB_INIT_CDB         #x00004000)
+(defconstant DB_INIT_LOCK        #x00008000)
+(defconstant DB_INIT_LOG         #x00010000)
+(defconstant DB_INIT_MPOOL       #x00020000)
+(defconstant DB_INIT_REP         #x00040000)
+(defconstant DB_INIT_TXN         #x00080000)
+(defconstant DB_LOCKDOWN         #x00100000)
+(defconstant DB_PRIVATE          #x00200000)
+(defconstant DB_RECOVER_FATAL    #x00400000)
+(defconstant DB_REGISTER         #x00800000)
+(defconstant DB_SYSTEM_MEM       #x01000000)
+(defconstant DB_AUTO_COMMIT      #x02000000)
+(defconstant DB_READ_COMMITTED   #x04000000)
+(defconstant DB_DEGREE_2         #x04000000) ;; DEPRECATED, now called DB_READ_COMMITTED
+(defconstant DB_READ_UNCOMMITTED #x08000000)
+(defconstant DB_DIRTY_READ       #x08000000) ;; DEPRECATED, now called DB_READ_UNCOMMITTED
 
 (defconstant DB_AFTER		      1)
 (defconstant DB_BEFORE		      3)
-(defconstant DB_KEYFIRST	     15)
-(defconstant DB_KEYLAST		     16)
+(defconstant DB_CURRENT		      6)
+(defconstant DB_FIRST		      7)
+(defconstant DB_GET_BOTH	      8)
+(defconstant DB_GET_BOTH_RANGE	     10)
+(defconstant DB_LAST		     15)
+(defconstant DB_NEXT		     16)
+(defconstant DB_NEXT_DUP	     17)
+(defconstant DB_NEXT_NODUP	     18)
+(defconstant DB_PREV		     23)
+(defconstant DB_PREV_NODUP	     24)
+(defconstant DB_SET		     25)
+(defconstant DB_SET_RANGE	     27)
+
+(defconstant DB_NODUPDATA	     19)
+(defconstant DB_NOOVERWRITE	     20)
+(defconstant DB_NOSYNC		     21)
 
-(defconstant DB_NODUPDATA	     21)
-(defconstant DB_NOOVERWRITE	     22)
-(defconstant DB_NOSYNC		     23)
-
-(defconstant DB_POSITION	     24)
+(defconstant DB_POSITION	     22)
 
 (defconstant DB_SEQ_DEC	     #x00000001)
 (defconstant DB_SEQ_INC	     #x00000002)
 (defconstant DB_SEQ_WRAP     #x00000008)
 
-(defconstant DB_SET_LOCK_TIMEOUT     29)
-(defconstant DB_SET_TXN_TIMEOUT      33)
+(defconstant DB_SET_LOCK_TIMEOUT     26)
+(defconstant DB_SET_TXN_TIMEOUT      30)
 
-(defconstant DB_FREELIST_ONLY  #x00002000)
-(defconstant DB_FREE_SPACE     #x00004000)
+(defconstant DB_FREELIST_ONLY  #x00004000)
+(defconstant DB_FREE_SPACE     #x00008000)
 
 (defconstant DB_KEYEMPTY         -30997)
 (defconstant DB_KEYEXIST	 -30996)
@@ -256,7 +261,7 @@
 		      (documentation nil)
 		      (transaction nil))
   (let ((wname (if (listp names) (first names) names))
-	(fname (if (listp names) (second names) 
+	(fname (if (listp names) (second names)
 		   (intern (concatenate 'string "%" (symbol-name names)))))
 	(wrapper-args (make-wrapper-args args flags keys))
 	(fun-args (make-fun-args args flags))
@@ -480,6 +485,14 @@
 	    :flags (force)
 	    :documentation "Make a checkpoint.")
 
+(def-function ("db_set_error_file" %db-set-error-file)
+    ((db :pointer-void)
+     (file :cstring)))
+
+(defun db-set-error-file (db filename)
+  (with-cstrings ((fname filename))
+    (%db-set-error-file db fname)))
+
 ;; Database
 
 (eval-when (:compile-toplevel :load-toplevel)
@@ -1882,8 +1895,7 @@
   :returning :int)
 
 (defun next-counter (env db parent key key-size lockid lockid-size)
-  "Get the next element in the counter.  To be deprecated
-when 4.3 is released."
+  "Get the next element in the counter.  To be deprecated when 4.3 is released."
   (let ((ret (%next-counter env db parent key key-size lockid lockid-size)))
     (if (< ret 0)
 	(error 'db-error :errno ret)
--- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c	2007/01/22 16:17:43	1.6
+++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c	2007/01/31 20:05:37	1.7
@@ -56,6 +56,7 @@
 */
 
 #include <stdint.h>
+#include <stdio.h>
 #include <string.h>
 #include <wchar.h>
 
@@ -173,7 +174,7 @@
 DB_ENV *db_env_cr(u_int32_t flags, int *errno) {
   DB_ENV *envp;
   *errno = db_env_create(&envp, flags);
-  return envp; 
+  return envp;
 }
 
 char * db_strerr(int error) {
@@ -215,6 +216,7 @@
   return dbenv->txn_checkpoint(dbenv, kbyte, min, flags);
 }
 
+
 /* Database */
 
 DB *db_cr(DB_ENV *dbenv, u_int32_t flags, int *errno) {
@@ -265,6 +267,10 @@
   return db->get_pagesize(db, pagesizep);
 }
 
+void db_set_error_file(DB *db, char *filename) {
+  return db->set_errfile(db, fopen(filename, "w+"));
+}
+
 /* Accessors */
 /* We manage our own buffers (DB_DBT_USERMEM). */
 



From ieslick at common-lisp.net  Wed Jan 31 20:05:38 2007
From: ieslick at common-lisp.net (ieslick)
Date: Wed, 31 Jan 2007 15:05:38 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/elephant
Message-ID: <20070131200538.845EE5B059@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv24260/src/elephant

Modified Files:
	collections.lisp controller.lisp serializer2.lisp 
Log Message:
Upgrade to BDB 4.5; green on Allegro 8.0/Mac OS X

--- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp	2006/06/19 01:03:30	1.5
+++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp	2007/01/31 20:05:38	1.6
@@ -135,7 +135,6 @@
 (defmethod remove-kv (key (bt btree-index))
   "Remove a key / value from the PRIMARY by a secondary
 lookup, updating ALL other secondary indices."
-  (declare (optimize (speed 3)))
   (remove-kv (get-primary-key key bt) (primary bt)))
 
 
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/26 14:41:13	1.25
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2007/01/31 20:05:38	1.26
@@ -139,7 +139,7 @@
 ;;
 
 (defclass store-controller ()
-  ((spec :type (or pathname string (simple-array character))
+  ((spec :type list
 	 :accessor controller-spec
 	 :initarg :spec
 	 :documentation "Backend create functions should pass in :spec during make-instance")
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/01/25 18:18:00	1.6
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/01/31 20:05:38	1.7
@@ -20,7 +20,7 @@
   (:use :cl :elephant :elephant-memutil)
   (:import-from :elephant 
 		*circularity-initial-hash-size*
-		*resourced-byte-spec*
+		#+(or cmu sbcl allegro)
 		get-cached-instance
 		controller-symbol-cache 
 		controller-symbol-id-cache



From ieslick at common-lisp.net  Wed Jan 31 20:05:38 2007
From: ieslick at common-lisp.net (ieslick)
Date: Wed, 31 Jan 2007 15:05:38 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/memutil
Message-ID: <20070131200538.CA2FD5B075@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/memutil
In directory clnet:/tmp/cvs-serv24260/src/memutil

Modified Files:
	memutil.lisp 
Log Message:
Upgrade to BDB 4.5; green on Allegro 8.0/Mac OS X

--- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp	2007/01/20 22:12:18	1.14
+++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp	2007/01/31 20:05:38	1.15
@@ -82,7 +82,7 @@
        (length :int))
     :returning :void))
 
-(eval-when (compile)
+(eval-when (:compile-toplevel)
   (declaim 
    #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0))
    (inline read-int read-uint read-float read-double 



From ieslick at common-lisp.net  Wed Jan 31 22:24:16 2007
From: ieslick at common-lisp.net (ieslick)
Date: Wed, 31 Jan 2007 17:24:16 -0500 (EST)
Subject: [elephant-cvs] CVS elephant/src/db-bdb
Message-ID: <20070131222416.56CC01E06F@common-lisp.net>

Update of /project/elephant/cvsroot/elephant/src/db-bdb
In directory clnet:/tmp/cvs-serv9434/src/db-bdb

Modified Files:
	bdb-controller.lisp berkeley-db.lisp 
Log Message:
Unsure why this doesn't compile, probably due to strings, but I'll comment it out for now

--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp	2007/01/31 20:05:37	1.17
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp	2007/01/31 22:24:16	1.18
@@ -136,8 +136,8 @@
       (setf (slot-value sc 'class-root)
 	    (make-instance 'bdb-btree :from-oid -2 :sc sc))
 
-      (when errfile
-	(db-set-error-file (controller-db sc) errfile))
+;;      (when errfile
+;;	(db-set-error-file (controller-db sc) errfile))
 
       (when deadlock-detect
 	(start-deadlock-detector sc))
--- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp	2007/01/31 20:05:37	1.5
+++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp	2007/01/31 22:24:16	1.6
@@ -485,13 +485,13 @@
 	    :flags (force)
 	    :documentation "Make a checkpoint.")
 
-(def-function ("db_set_error_file" %db-set-error-file)
-    ((db :pointer-void)
-     (file :cstring)))
-
-(defun db-set-error-file (db filename)
-  (with-cstrings ((fname filename))
-    (%db-set-error-file db fname)))
+;;(def-function ("db_set_error_file" %db-set-error-file)
+;;    ((db :pointer-void)
+;;     (file :cstring)))
+
+;;(defun db-set-error-file (db filename)
+;;  (with-cstrings ((fname filename))
+;;    (%db-set-error-file db fname)))
 
 ;; Database