[elephant-cvs] CVS elephant/src/contrib/rread/dcm
rread
rread at common-lisp.net
Tue Feb 20 15:54:21 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/contrib/rread/dcm
In directory clnet:/tmp/cvs-serv2139
Modified Files:
dcm-macros.lisp dcm-package.lisp dcm-tests.lisp dcm.asd
dcm.lisp gdcm.lisp
Log Message:
Latest version of DCM
--- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-macros.lisp 2006/04/27 02:00:02 1.1
+++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-macros.lisp 2007/02/20 15:54:21 1.2
@@ -1,22 +1,7 @@
-;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;
-;;; dcm-macros
-;;;
-;;; Initial version by Robert L. Read
-;;;
-;;; 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.
-;;;
-;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net>
-
(in-package "DCM")
+(use-package "SB-THREAD")
+
(defmacro init-director (cls dirclass &rest x)
`(let ((dir (make-instance ,cls , at x)))
(initialize dir ,cls ,dirclass)
@@ -31,3 +16,30 @@
;; (load-all dir)
dir))
+(defvar *dcm-mutexes* (make-hash-table :test 'equal))
+
+(defvar *a-mutex* (sb-thread::make-mutex :name "my lock"))
+
+(defun insure-mutex (name)
+ (let ((mtx (gethash name *dcm-mutexes*))
+ )
+ (or mtx (setf (gethash name *dcm-mutexes*) (sb-thread:make-mutex :name name)))
+ )
+ )
+
+;; This assumes that the the variable "dir" is being defined and that we can can
+;; create
+(defmacro defmethodex (mname dir args &body body)
+ `(defmethod ,mname ,(cons dir args)
+;; (format t "Thread ~A running ~%" sb-thread::*current-thread*)
+ (sb-thread:with-mutex ((insure-mutex (format nil "mutex-~A" ,(car dir))))
+;; (format t "Thread ~A got the lock~%" sb-thread::*current-thread*)
+ (let ((ret
+ , at body))
+;; (format t "Thread ~A dropping lock~%" sb-thread::*current-thread*)
+ ret
+ )
+ )
+ )
+ )
+
--- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-package.lisp 2006/04/27 02:00:02 1.1
+++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-package.lisp 2007/02/20 15:54:21 1.2
@@ -1,19 +1,9 @@
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
-;;; dcm-package.lisp
+;;; dcm-package.asd -- package definition for DCM
;;;
-;;; Initial version by Robert L. Read
-;;;
-;;; 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.
-;;;
-;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net>
+;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net>
+;;; All rights reserverd.
(defpackage dcm
(:documentation
@@ -31,6 +21,7 @@
#:*DEF-STORE-NAME*
#:key
+ #:mtype
#:key-equal
#:dcm-equal
#:max-key-value
@@ -98,6 +89,7 @@
#:get-all-cur-objects
#:get-all-objects-gen
#:retire
+ #:promote
#:find-generation
#:GenDir
)
--- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-tests.lisp 2006/04/27 02:00:02 1.1
+++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-tests.lisp 2007/02/20 15:54:21 1.2
@@ -1,23 +1,23 @@
-;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;
-;;; dcm-tests.lisp
-;;;
-;;; Initial version by Robert L. Read
-;;;
-;;; 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.
-;;;
-;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net>
-
(in-package "DCM")
-
+(defclass UserObject (managed-object)
+ ((username :type 'string :initform "" :initarg :uname :accessor :username)
+ (password :type 'string :initform "" :initarg :pword :accessor :password)
+ (email :type 'string :initform "" :initarg :email :accessor :eml)
+ (fullname :type 'string :initform "" :initarg :fullname :accessor :fllnm)
+ (profile :type 'string :initform "" :initarg :profile :accessor :prfl)
+ (motto :type 'string :initform "" :initarg :motto :accessor :mtt)
+ (privileges :type 'list :initform '() :initarg :privileges :accessor :prvlgs)
+ (preflang :type 'string :initform "en" :initarg :preflang :accessor :prflng)
+;; For now, this will just be a nice big association list, and
+;; the only prefs I have right now are gridconfigurations
+ (prefs :type 'list :initform '() :initarg :prefs :accessor :prfs)
+;; These controls the markets that a user is a allowed to read or create an offer in
+;; (keys identifying markets are stored here.)
+;; We DO NOT give privilege to the public market; We don't want to
+;; store more than necessary. If a market is public, it is not represented here
+;; (in the read list!)
+))
(defclass ExObjectDirector (hash-ele-director)
((mtype :initform 'ExObject
@@ -99,6 +99,15 @@
((null dirs))
(setf s (+ s (length (get-all-objects (car dirs))))))
(assert (= s 1))))
+
+(defun many-threads ()
+ (let (
+ (ed (init-director 'ExObjectDirector 'ExObjectDirector))
+ )
+ (dotimes (x 100)
+ (sb-thread:make-thread
+ #'(lambda () (format t "YYY~A~%" (get-unused-key-value ed)))))
+))
;; This command should test everything so far....
@@ -108,4 +117,5 @@
(tm-register-then-lookup dt)
(tm-get-all-objects dt)
(tm-test-elephant dt)
+ (many-threads)
))
--- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.asd 2006/04/27 15:27:36 1.2
+++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.asd 2007/02/20 15:54:21 1.3
@@ -2,25 +2,14 @@
;;;
;;; dcm.asd -- ASDF system definition for DCM
;;;
-;;; Initial version by Robert L. Read
-;;;
-;;; 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.
-;;;
-;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net>
-
+;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net>
+;;; All rights reserverd.
(defsystem dcm
:name "dcm"
:author "Robert L. Read <read at robertlread.net>"
:version "0.1"
:maintainer "Robert L. Read <read at robertlread.net"
- :licence "LLGPL; part of Elephant"
+ :licence "All Rights Reserverd"
:description "A simple object prevalence system with strategies"
:long-description "An object prevalence system with strategies built on Elephant"
:depends-on (:elephant)
--- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.lisp 2006/04/27 02:00:02 1.1
+++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.lisp 2007/02/20 15:54:21 1.2
@@ -1,19 +1,26 @@
-;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;; Copyright 2004, Robert L. Read. All rights reserved.
;;;
-;;; dcm-tests.lisp
-;;;
-;;; Initial version by Robert L. Read
-;;;
-;;; 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.
-;;;
-;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net>
+
+;; It seems silly to have to do this, but I suspect it
+;; will make the inheritance work better.
+;; An open question is do we want to have to subclass keys
+;; or not; certainly a common error is to pass in the
+;; wrong key.
+
+;; I'm currently not sure how to load this file properly
+;; and how to run ALL the test with a single command.
+
+;; Note: as of Jun. 12, 2006, I am trying to make this thread safe.
+;; according to my understanding and experiments there are two
+;; problems: SBCL itself is not threadsafe (hash tables are mentioned
+;; in particular) although it is probably improving with every release.
+;; By my experiments, I have specifically duplicated a terrible, unrecoverable
+;; hang in the CLSQL connection both through elephant and with direct queries.
+;;
+;; Therefore, since everything I personally do is built on top
+;; of DCM, I am imposing thread-safety at the DCM level (even though in
+;; the best case this probably does not allow as much concurrency as one might like.)
+;;
(in-package "DCM")
@@ -23,10 +30,12 @@
(defparameter *ELEPHANT-CAT* "elephant director")
(defparameter *DEF-STORE-NAME* "DefaultStoreX")
+
(asdf:operate 'asdf:load-op :elephant)
(use-package "ELEPHANT")
;; (asdf:operate 'asdf:load-op :ele-bdb)
(asdf:operate 'asdf:load-op :ele-clsql)
+(use-package "SB-THREAD")
(defclass key ()
((id :type 'integer
@@ -80,13 +89,17 @@
(k (mid a))
(if (typep a 'key)
(k a)
- a)))
+ (if (typep a 'string)
+ (parse-integer a)
+ a))))
(kb
(if (typep b 'managed-object)
(k (mid b))
(if (typep b 'key)
(k b)
- b))))
+ (if (typep a 'string)
+ (parse-integer a)
+ b)))))
(and ka kb
(= ka kb))
)
@@ -188,7 +201,10 @@
(defgeneric register-obj (director managed-object)
)
-(defgeneric lookup-obj (director key)
+(defgeneric lookup-obj (director obj)
+
+ )
+(defgeneric lookup-obj-key (director key)
)
(defgeneric delete-obj (director key)
@@ -197,6 +213,18 @@
(defgeneric get-all-objects (director)
)
+(defmethod lookup-obj ((dir director) (id key))
+ (lookup-obj-key dir id)
+)
+
+(defmethod lookup-obj ((dir director) (id integer))
+ (lookup-obj-key dir (make-instance 'key :id id))
+)
+
+(defmethod lookup-obj ((dir director) (id string))
+ (lookup-obj-key dir (make-instance 'key :id (parse-integer id)))
+)
+
(defmethod get-all-cur-objects ((dir director))
(get-all-objects dir))
@@ -213,6 +241,14 @@
(delete-obj dir (mid mo)))
(get-all-objects dir)))
+
+;; (defmethodex delete-all-objects-from-director (dir director) (tp)
+;; (mapc
+;; #'(lambda (mo)
+;; (delete-obj dir (mid mo)))
+;; (get-all-objects dir)))
+
+
;; Create a hash-based subclass
(defparameter *HASH-CAT* "hash director")
@@ -227,7 +263,9 @@
(defmethod get-all-objects ((dir hash-director))
(get-all-objects-type dir 'managed-object))
-(defmethod get-all-objects-type ((dir hash-director) tp)
+
+(defmethodex get-all-objects-type (dir hash-director) (tp)
+ ;; (defmethod get-all-objects-type ((dir hash-director) tp)
(let ((objs '()))
(maphash #'(lambda (k v)
(if (typep v tp)
@@ -235,7 +273,8 @@
(slot-value dir 'key-to-mo))
objs))
-(defmethod get-all-objects-owned-by ((dir hash-director) (o key))
+(defmethodex get-all-objects-owned-by (dir hash-director) ((o key))
+ ;; (defmethod get-all-objects-owned-by ((dir hash-director) (o key))
(let ((objs '()))
(maphash #'(lambda (key v)
(if (equal (k (:ownr v)) (k o))
@@ -248,7 +287,10 @@
;; There does not appear to be a "hash-reduce".
;; That would be an elegant function to have for
;; this and other purposes.
-(defmethod get-unused-key-value ((dir hash-director))
+(defmethodex get-unused-key-value (dir hash-director) ()
+ (get-unused-key-value-naked dir))
+
+(defmethod get-unused-key-value-naked ((dir hash-director))
(the integer
(+ 1
(hash-keys-reduce #'max (slot-value dir 'key-to-mo)
@@ -280,14 +322,17 @@
(setf r (funcall fun r key)))))
r))
-(defmethod register-obj ((dir hash-director) (mo managed-object))
- (unless (mid mo)
- (setf (mid mo) (make-instance 'key :id (get-unused-key-value dir))))
+
+(defmethodex register-obj (dir hash-director) ((mo managed-object))
+ (progn
+ (unless (mid mo)
+ (setf (mid mo) (make-instance 'key :id (get-unused-key-value-naked dir))))
(with-slots (key-to-mo) dir
- (setf (gethash (k (mid mo)) key-to-mo) mo)))
+ (setf (gethash (k (mid mo)) key-to-mo) mo))))
-(defmethod lookup-obj ((dir hash-director) (id key))
+;; (defmethodex lookup-obj-key (dir hash-director) ((id key))
+(defmethod lookup-obj-key ((dir hash-director) (id key))
(with-slots (key-to-mo) dir
(gethash (k id) key-to-mo)))
@@ -295,7 +340,8 @@
;; I would really like to insist on create-read-update-delete functions
;; for the abstract class of director.
-(defmethod delete-obj ((dir hash-director) (id key))
+(defmethodex delete-obj (dir hash-director) ((id key))
+ ;; (defmethod delete-obj ((dir hash-director) (id key))
(with-slots (key-to-mo) dir
(remhash (k id) key-to-mo)))
@@ -310,14 +356,16 @@
;; These functions will have to be expanded later to include
;; multiple controllers. It would be really nice if I could tie
;; this to garabase collection instead.
-(defvar *basic-store-controller* (open-store *DCM-DEFAULT*))
+;; (defvar *basic-store-controller* (open-store *DCM-DEFAULT*))
+(defvar *basic-store-controller* nil)
(defun reconnect-db ()
(reconnect-controller *basic-store-controller*))
(defun init-elephant-controllers (dcm-default)
- (setq *basic-store-controller* (open-store dcm-default)))
+ (setq *basic-store-controller* (open-store dcm-default))
+ (setq elephant::*store-controller* *basic-store-controller*))
(defun release-elephant-controllers ()
(close-controller *basic-store-controller*))
@@ -346,6 +394,7 @@
(let* ((name (format nil "DCM-SPECIAL-~A" c))
(sc (slot-value dir 'root))
(bt (get-from-root name :store-controller sc)))
+ (format t "bt of name ~A is: ~A~%" name bt)
(unless bt
(setf bt (add-to-root name (make-btree sc) :store-controller sc)))
(setf (slot-value dir 'dcm-btree) bt))
@@ -359,11 +408,13 @@
;; and in fact, pushing this into Elephant), would be an
;; excellent idea.
;; (defun empty-out-corrupted-btree (c sc)
-;; (let* ((name (format nil "DCM-SPECIAL-~A" (class-name c)))
-;; (bt (get-from-root name :store-controller sc)))
-;; ; "delete from keyvalue where clct_id = ")
-;; ))
-(defmethod register-many-random ((dir director) n)
+;; (let* ((name (format nil "DCM-SPECIAL-~A" (class-name c)))
+;; (bt (get-from-root name :store-controller sc)))
+;; "delete from keyvalue where clct_id = ")
+;; )
+
+(defmethodex register-many-random (dir director) (n)
+ ;; (defmethod register-many-random ((dir director) n)
(with-slots
(mtype)
dir
@@ -374,15 +425,30 @@
(make-instance mtype))))))
;; I'm goint to try using the ele::next-oid fuction here:
-(defmethod get-unused-key-value ((dir elephant-director))
+(defmethodex get-unused-key-value (dir elephant-director) ()
+ (get-unused-key-value-naked dir))
+
+(defmethod get-unused-key-value-naked ((dir elephant-director))
(the integer
(with-slots (root) dir
(ELEPHANT::next-oid root))))
+;; (defmethodex get-all-objects (dir elephant-director) ()
(defmethod get-all-objects ((dir elephant-director))
(get-all-objects-type dir 'managed-object))
-(defmethod get-all-objects-type ((dir elephant-director) tp)
+(defmethodex get-all-objects-type (dir elephant-director) (tp)
+ ;; (defmethod get-all-objects-type ((dir elephant-director) tp)
+ (with-slots (dcm-btree) dir
+ (let ((objs '()))
+ (map-btree #'(lambda (k x)
+ (declare (ignore k))
+ (if (typep x (:mtype dir))
+ (push x objs)))
+ dcm-btree)
+ objs)))
+
+(defmethod get-all-objects-type-xxxx ((dir elephant-director) tp)
(with-slots (dcm-btree) dir
(let ((objs '()))
(map-btree #'(lambda (k x)
@@ -392,7 +458,8 @@
dcm-btree)
objs)))
-(defmethod get-all-objects-owned-by ((dir elephant-director) (o key))
+(defmethodex get-all-objects-owned-by (dir elephant-director) ((o key))
+ ;; (defmethod get-all-objects-owned-by ((dir elephant-director) (o key))
(with-slots (dcm-btree) dir
(let ((objs '()))
(map-btree #'(lambda (k x)
@@ -414,18 +481,23 @@
x)
:accessor :elefdir)))
-(defmethod register-obj ((dir elephant-director) (mo managed-object))
+(defmethodex register-obj (dir elephant-director) ((mo managed-object))
+ ;; (defmethod register-obj ((dir elephant-director) (mo managed-object))
+ (progn
(unless (mid mo)
- (setf (mid mo) (make-instance 'key :id (get-unused-key-value dir))))
+ (setf (mid mo) (make-instance 'key :id (get-unused-key-value-naked dir))))
+ ;; (sb-thread:with-mutex ((insure-mutex (format nil "mutex-~A" dir)))
(with-slots (dcm-btree) dir
(progn
- (setf (get-value (mid mo) dcm-btree) mo))))
+ (setf (get-value (mid mo) dcm-btree) mo)))))
-(defmethod lookup-obj ((dir elephant-director) (id key))
+(defmethodex lookup-obj-key (dir elephant-director) ((id key))
+ ;; (defmethod lookup-obj-key ((dir elephant-director) (id key))
(with-slots (dcm-btree) dir
(get-value id dcm-btree)))
-(defmethod delete-obj ((dir elephant-director) (id key))
+(defmethodex delete-obj (dir elephant-director) ((id key))
+ ;; (defmethod delete-obj ((dir elephant-director) (id key))
(with-slots (dcm-btree) dir
(remove-kv id dcm-btree)))
@@ -449,11 +521,11 @@
((hed :initform (make-instance 'hash-ele-director)
:accessor :hed)))
-(defmethod load-all ((dir hash-ele-director))
- (let ((obs (get-all-objects (:ed dir))))
- (mapc #'(lambda (x) (register-obj (:hd dir) x))
- obs)
- ))
+(defmethodex load-all (dir hash-ele-director) ()
+ (let ((obs (get-all-objects (:ed dir))))
+ (mapc #'(lambda (x) (register-obj (:hd dir) x))
+ obs)
+ ))
(defmethod register-obj ((dir hash-ele-director) (mo managed-object))
(register-obj (:ed dir) mo)
@@ -465,8 +537,8 @@
(get-unused-key-value (:ed dir))))
-(defmethod lookup-obj ((dir hash-ele-director) (id key))
- (lookup-obj (:hd dir) id))
+(defmethod lookup-obj-key ((dir hash-ele-director) (id key))
+ (lookup-obj-key (:hd dir) id))
(defmethod delete-obj ((dir hash-ele-director) (id key))
(delete-obj (:hd dir) id)
@@ -487,7 +559,7 @@
(defparameter *DIR-STRATEGIES* '(hash hash-ele elephant simple))
-o ;; I might have to rehabilitate this function...
+;; I might have to rehabilitate this function...
(defun directory-factory (strategy btreeclassname type repos)
(case strategy
(hash (init-director 'hash-director btreeclassname :managed-type type))
@@ -538,7 +610,7 @@
(let ((mo (make-instance 'managed-object)))
(register-obj dir mo)
(assert (key-equal (mid mo)
- (mid (lookup-obj dir (mid mo))))))))
+ (mid (lookup-obj-key dir (mid mo))))))))
dirs))
)
@@ -580,7 +652,7 @@
(time
(and (mapcar
#'(lambda (k)
- (not (lookup-obj dir (make-instance 'key :id k))))
+ (not (lookup-obj-key dir (make-instance 'key :id k))))
key-values)))))
)
dirs))
@@ -624,7 +696,7 @@
(time
(and (mapcar
#'(lambda (k)
- (not (lookup-obj dir (make-instance 'key :id k))))
+ (not (lookup-obj-key dir (make-instance 'key :id k))))
key-values)))))
))))
dirs))
--- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/gdcm.lisp 2006/04/27 02:00:02 1.1
+++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/gdcm.lisp 2007/02/20 15:54:21 1.2
@@ -1,35 +1,20 @@
-;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;
-;;; gdcm.lisp -- This file implements generational data collection management
-;;; based on the basic data collection management functionality.
-;;; The basic idea is that every object in the collection exists
-;;; within a generation. Each generation can have a different storage
-;;; strategy --- in general, the lower the generation number, the
-;;; faster and smaller the storage strategy.
-;;; Increasing the generation is a fundamental operation.
-
-;;; One fundamental feature of a GenDir is that the
-;;; objects managed retain their identities across these issue.
-
-;;; A GenDir is a kind of director, but it offers generational
-;;; aware operations that it's superclass does not.
-
-;;; Given an object with it's id, how do you efficiently find
-;;; its generation? --- you always have an index, so in theory
-;;; it can't take that long to find what generation it's in.
-
-;;; Initial version by Robert L. Read
-;;;
-;;; 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.
-;;;
-;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net>
+;; gdcm.lisp -- This file implements generational data collection management
+;; based on the basic data collection management functionality.
+;; The basic idea is that every object in the collection exists
+;; within a generation. Each generation can have a different storage
+;; strategy --- in general, the lower the generation number, the
+;; faster and smaller the storage strategy.
+;; Increasing the generation is a fundamental operation.
+
+;; One fundamental feature of a GenDir is that the
+;; objects managed retain their identities across these issue.
+
+;; A GenDir is a kind of director, but it offers generational
+;; aware operations that it's superclass does not.
+
+;; Given an object with it's id, how do you efficiently find
+;; its generation? --- you always have an index, so in theory
+;; it can't take that long to find what generation it's in.
(in-package "DCM")
@@ -40,7 +25,7 @@
(defclass GenDir (director)
((strategy
- :initform '((0 . hash-ele)) ;; This means that 0 and anything less is hash-ele
+ :initform '((0 . hash-ele) (1 . elephant)) ;; This means that 0 and anything less is hash-ele
:accessor strategy)
(final-strategy :initform 'elephant
:accessor final-strategy)
@@ -58,6 +43,11 @@
"Increment the generation number of a object, making number is properly stored there.")
)
+(defgeneric promote (GenDir key)
+ (:documentation
+ "Decrement the generation number of a object, making number is properly stored there.")
+)
+
(defgeneric find-generation (GenDir key)
)
@@ -77,6 +67,20 @@
)
)
+(defmethod promote ((gdcm GenDir) (mid key))
+ (multiple-value-bind (obj gen)
+ (lookup-obj-aux gdcm mid)
+ (unless (= gen 0)
+ (let ((ndir (nth (- gen 1) (subdirs gdcm)))
+ (odir (nth gen (subdirs gdcm)))
+ )
+ (register-obj ndir obj)
+ (delete-obj odir mid)
+ )
+ )
+ )
+ )
+
(defmethod load-all ((dir GenDir))
(do ((i 0 (1+ i))
(dirs (subdirs dir) (rest dirs)))
@@ -124,7 +128,7 @@
(delete-obj (nth gen (subdirs dir)) id))
)
)
-(defmethod lookup-obj ((dir GenDir) (mid key))
+(defmethod lookup-obj-key ((dir GenDir) (mid key))
(multiple-value-bind (obj gen)
(lookup-obj-aux dir mid)
obj)
More information about the Elephant-cvs
mailing list