Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv23879/src
Modified Files: elephant.lisp Log Message: weak hashes
Date: Thu Aug 26 19:57:52 2004 Author: blee
Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.1.1.1 elephant/src/elephant.lisp:1.2 --- elephant/src/elephant.lisp:1.1.1.1 Thu Aug 19 10:05:14 2004 +++ elephant/src/elephant.lisp Thu Aug 26 19:57:52 2004 @@ -1,10 +1,80 @@ (defpackage elephant (:nicknames ele :ele) (:use common-lisp sleepycat) - #+cmu - (:shadowing-import-from PCL find-class class-name built-in-class class-of) - (:export *store-controller* store-controller - open-controller close-controller with-open-controller - persistent persistent-class def-persistent-class - serialize deserialize add-deserializer - *current-transaction* with-transaction with-transaction-retries)) + (:export *store-controller* *current-transaction* *auto-commit* + store-controller open-controller close-controller + with-open-controller + persistent persistent-object persistent-metaclass + with-transaction with-transaction-retry) + #+cmu + (:import-from :pcl + slot-definition-name + compute-slots) + ;; Hopefully SBCL = CMUCL except for package names (both using Gerd's PCL) + #+sbcl + (:import-from :sb-mop + slot-definition-name + compute-slots) + #+openmcl + (:import-from :openmcl-mop + slot-definition-name + compute-slots) + #+allegro + (:import-from :clos + slot-definition-name + compute-slots) + #+lispworks + (:import-from :clos + slot-definition-name + compute-slots) + + ) + +(in-package "ELEPHANT") + +;; Thread-local specials which control Elephant + +(defparameter *store-controller* nil + "The store controller which persistent objects talk to.") +(defvar *auto-commit* nil) + + +;; Portable value-weak hash-tables for the cache: when the +;; values are collected, the entries (keys) should be +;; flushed from the table too + +(defun make-cache-table (&rest args) + #+(or cmu sbcl scl) + (apply #'make-hash-table args) + #+allegro + (apply #'make-hash-table :values :weak args) + #+lispworks + (apply #'make-hash-table :weak-kind :value args) + #-(or cmu sbcl scl allegro lispworks) + (apply #'make-hash-table args) + ) + +(defun get-cache (key cache) + #+(or cmu sbcl scl) + (let ((val (gethash key cache))) + (if val (values (weak-pointer-value val) t) + (values nil nil))) + #-(or cmu sbcl scl) + (gethash key cache) + ) + +(defun setf-cache (key cache value) + #+(or cmu sbcl scl) + (let ((w (make-weak-pointer value))) + (finalize value #'(lambda () (remhash key cache))) + (setf (gethash key cache) w) + value) + #+allegro + (progn + (excl:schedule-finalization value #'(lambda () (remhash key cache))) + (setf (gethash key cache) value)) + #-(or cmu sbcl scl allegro) + (setf (gethash key cache) value) + ) + +(defsetf get-cache setf-cache)