[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Wed Apr 26 17:53:45 UTC 2006
Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv12311/src/elephant
Modified Files:
classes.lisp classindex-utils.lisp classindex.lisp
collections.lisp controller.lisp metaclasses.lisp migrate.lisp
serializer.lisp transactions.lisp variables.lisp
Added Files:
package.lisp
Removed Files:
elephant.lisp
Log Message:
Significant additions to the 0.6.0 release on the trunk. Updates to
documentation, 0.5.0 compliance, final on 0.6.0 features. There are
one or two BDB interactions on migration to work out but this should
be a nearly code complete 0.6.0 release. Please start testing and
evaluating this - especially the ability to open and tag 0.5.0 databases.
Features:
- Database version tagging
- Support for 0.5.0 namespaces & databases
- New migration system
- class indexing without slot indexing
- various bug fixes
- reverted fast allegro/sbcl string support to
allow 0.5.0 databases to work correctly. I
couldn't find a good way to work around this
without creating infinite headaches
- validated that running db_deadlock will stop all
lisp freezes that I've encountered. This has to
be run each time a DB environment is opened/created
so eventually should be made part of the open-controller
functionality for the BDB backend
--- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/03/01 18:57:34 1.8
+++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/04/26 17:53:44 1.9
@@ -45,6 +45,28 @@
;; 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))
@@ -58,14 +80,13 @@
(call-next-method))))
(defmethod finalize-inheritance :around ((instance persistent-metaclass))
- "Update the persistent slot records in the 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)))
- (when (not (slot-boundp instance '%indexed-slots))
- (update-indexed-record instance (indexed-slot-names-from-defs instance)))))
+ (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))
@@ -130,7 +151,6 @@
;; 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
--- /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2006/03/01 18:57:34 1.2
+++ /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2006/04/26 17:53:44 1.3
@@ -1,4 +1,14 @@
-
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;
+;;; classindex-untils.lisp -- support for classindex.lisp and
+;;; class re-definition synchronization
+;;;
+;;; Initial version 1/24/2006 Ian Eslick
+;;; eslick at alum mit edu
+;;;
+;;; License: Lisp Limited General Public License
+;;; http://www.franz.com/preamble.html
+;;;
(in-package :elephant)
@@ -46,7 +56,7 @@
;; Differentiate derived indices from slot-based ones
;;
-(defparameter *derived-index-marker* "%%derived%%-")
+(defparameter *derived-index-marker* "%%DERIVED%%-")
(defun make-derived-name (name)
(intern (format nil "~A~A" *derived-index-marker* name)))
@@ -58,7 +68,8 @@
*derived-index-marker*))
(defun get-derived-name-root (dname)
- (when (symbolp dname) (symbol-name dname))
+ (when (symbolp dname)
+ (setf dname (symbol-name dname)))
(intern (subseq dname (length *derived-index-marker*))))
;;
@@ -116,6 +127,180 @@
(error (e)
(warn "Error ~A computing derived index for on instance ~A" e instance)
(values nil nil))))
+
+
+;; =============================
+;; CLASS / DB SYNCHRONIZATION
+;; =============================
+
+;; TO READER: I got really tired of trying to figure out all
+;; the messy conditionals and I figure default behaviors are something
+;; others might want to modify, so here's what determines the rule
+;; behavior..
+;;
+;; Rules match on the following states of the metaclass and current
+;; database class-index for each slotname currently in either of
+;; those sources. Actions are taken, typically when a slot exists
+;; in one but not the other or features like indexed/persistent
+;; differ between the slots
+;;
+;; class state:
+;; class-indexed - the slot is marked as indexed
+;; class-persistent - the slot is marked as persistent (not indexed)
+;; class-transient - the slot is marked transient
+;; class-derived - the slot is in the derived list of the class
+;;
+;; database
+;; db-slot - the database has a slot index
+;; db-derived - the database has a derived index
+;;
+;; The inversions of any of these terms are also available as
+;; (not indexed-slot) for example, to cover more than one feature
+;; combination
+;;
+;; Each rule should apply uniquely to a given feature set.
+;;
+;; Actions taken when rules match can include:
+;;
+;; add-slot-index - add a new index with the slotname to the db
+;; remove-slot-index - remove a slot with the slotname from the db
+;; add-derived-index - xxx this makes no sense! xxx
+;; remove-derived-index - remove a derived index from the db
+;; unregister-indexed-slot - remove an indexed slot from the class metaobject
+;; unregister-derived - remove a derived index from the class metaobject
+;; register-indexed-slot - register a slot with the class metaobject
+;; register-derived-index - register a derived index with the class metaobject
+;;
+
+;; DEFINE THE SYNCHRONIZATION RULES
+(eval-when (:compile-toplevel :load-toplevel)
+
+ (defclass synch-rule ()
+ ((lhs :accessor synch-rule-lhs :initarg :lhs :initform nil)
+ (rhs :accessor synch-rule-rhs :initarg :rhs :initform nil)))
+
+ (defun make-synch-rule (rule-spec)
+ (let ((lhs (subseq rule-spec 0 (position '=> rule-spec)))
+ (rhs (subseq rule-spec (1+ (position '=> rule-spec)))))
+ (make-instance 'synch-rule :lhs lhs :rhs rhs)))
+
+ (defparameter *synchronize-rules*
+ (mapcar #'(lambda (rule-specs)
+ (cons (car rule-specs)
+ (mapcar #'make-synch-rule (cdr rule-specs))))
+ '((:class ;; class changes db
+ ((not db-slot) class-indexed => add-slot-index)
+ (db-slot (not class-indexed) => remove-slot-index)
+ (db-derived (not class-indexed) (not class-persistent)
+ (not class-transient) => register-derived-index))
+ (:union ;; merge both sides
+ (db-slot (not class-indexed) => register-indexed-slot)
+ ((not db-slot) class-indexed => add-slot-index)
+ (db-derived (not class-derived) => register-derived-index)
+ (db-derived class-persistent => remove-derived-index warn))
+ ;; NOTE: What about cases where we need to remove things as below?
+ (:db ;; db changes class
+ ((not db-slot) class-indexed => unregister-indexed-slot)
+ ((not db-derived) class-derived => unregister-derived-index)
+ (db-slot class-persistent => register-indexed-slot)
+ (db-slot class-transient => remove-indexed-slot)
+ (db-derived class-transient => remove-derived-index warn)
+ (db-derived class-persistent => remove-derived-index warn)
+ (db-derived class-indexed => remove-derived-index warn)
+ (db-derived (not class-derived) (not class-indexed)
+ (not class-persistent) (not class-transient)
+ => register-derived-index)))))
+ )
+
+;; TOP LEVEL METHOD
+
+(defun synchronize-class-to-store (class &key (sc *store-controller*)
+ (method *default-indexed-class-synch-policy*))
+ (let ((slot-records (compute-class-and-ele-status class sc))
+ (rule-set (cdr (assoc method *synchronize-rules*))))
+ (apply-synch-rules class slot-records rule-set)))
+
+;; COMPUTING RULE APPLICABILITY AND FIRING
+
+(defun synch-rule-applicable? (rule features)
+ (simple-match-set (synch-rule-lhs rule) features))
+
+(defun simple-match-set (a b)
+ (declare (optimize (speed 3) (safety 1)))
+ (cond ((null a) t)
+ ((and (not (null a)) (null b)) nil)
+ ((member (first a) b :test #'equal)
+ (simple-match-set (cdr a) (remove (first a) b :test #'equal)))
+ (t nil)))
+
+(defparameter *print-synch-messages* nil)
+
+(defun apply-synch-rule (rule class name)
+ (when *print-synch-messages*
+ (format t "Class/DB Synch: converting state ~A using ~A for ~A~%"
+ (synch-rule-lhs rule) (synch-rule-rhs rule) name))
+ (loop for action in (synch-rule-rhs rule) do
+ (case action
+ (add-slot-index (add-class-slot-index class name :update-class nil))
+ (remove-slot-index (remove-class-slot-index class name :update-class nil))
+ (add-derived-index (add-class-derived-index class name :update-class nil))
+ (remove-derived-index (remove-class-derived-index class name :update-class nil))
+ (unregister-indexed-slot (unregister-indexed-slot class name))
+ (unregister-derived-index (unregister-derived-index class name))
+ (register-indexed-slot (register-indexed-slot class name))
+ (register-derived-index (register-derived-index class name))
+ (warn (warn "Performing slot synchronization actions: ~A" (synch-rule-rhs rule))))))
+
+(defun apply-synch-rules (class records rule-set)
+ (declare (optimize (speed 3) (safety 1)))
+ (labels ((slotname (rec) (car rec))
+ (feature-set (rec) (cdr rec)))
+ (loop for record in records do
+ (loop for rule in rule-set
+ when (synch-rule-applicable? rule (feature-set record))
+ do
+ (apply-synch-rule rule class (slotname record))))))
+
+;; COMPUTE CURRENT STATE OF CLASS OBJECT AND DATABASE AFTER CHANGES
+
+(defun compute-class-and-ele-status (class &optional (store-controller *store-controller*))
+ (let* ((*store-controller* store-controller)
+ ;; db info
+ (db-indices (find-inverted-index-names class))
+ (db-derived (mapcar #'get-derived-name-root
+ (remove-if-not #'derived-name? db-indices)))
+ (db-slot (set-difference db-indices db-derived))
+ ;; class info
+ (marked-slots (indexing-record-slots (indexed-record class)))
+ (marked-derived (indexing-record-derived (indexed-record class)))
+ (persistent-slots (set-difference (persistent-slots class) marked-slots))
+ (other-slots (set-difference
+ (set-difference (class-slots class) persistent-slots)
+ marked-slots))
+ (all-names (union (mapcar #'slot-definition-name (class-slots class)) db-indices))
+ ;; [order matters in traversal]
+ (all-sets `((class-indexed . ,marked-slots)
+ (class-derived . ,marked-derived)
+ (class-persistent . ,persistent-slots)
+ (class-transient . ,other-slots)
+ (db-slot . ,db-slot)
+ (db-derived . ,db-derived))))
+ (labels ((compute-features (slotname)
+ (let ((features nil))
+ (loop for set in all-sets do
+ (push (compute-feature slotname (cdr set) (car set))
+ features))
+ (cons slotname features)))
+ (compute-feature (name set label)
+ (if (member name set)
+ label
+ `(not ,label))))
+ (mapcar #'compute-features all-names))))
+
+;; ==================================
+;; TOOLS
+;; ==================================
+
;;
;; This has turned out to be useful for debugging
@@ -139,10 +324,10 @@
(disable-class-indexing name)
(flush-instance-cache *store-controller*)
(setf (find-class name) nil)))
-
-
+
+
;; Rob created this just for some debugging.
-;; It seesm theoretically possible that we could make
+;; It seems theoretically possible that we could make
;; a function that fully checks the consinstency of the index;
;; that is, that the indexed classes indeed exist in the store.
(defun dump-class-index (c)
@@ -150,7 +335,8 @@
(dump-btree
idx)
)
-)
+ )
+
(defun report-indexed-classes (&key (class nil) (sc *store-controller*))
(format t "indexed-classes:~%")
(let ((bt (controller-class-root sc)))
--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/03/27 20:36:27 1.8
+++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/04/26 17:53:44 1.9
@@ -1,7 +1,7 @@
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; classindex.lisp -- use btree collections to track objects by slot values
-;;; via metaclass options or accessor :after methods
+;;; via metaclass options or accessor :after methods
;;;
;;; Initial version 1/24/2006 Ian Eslick
;;; eslick at alum mit edu
@@ -98,7 +98,7 @@
(defmethod find-class-index ((class-name symbol) &key (sc *store-controller*) (errorp t))
(find-class-index (find-class class-name) :sc sc :errorp errorp))
-(defmethod class-indexedp-by-name ((class-name symbol) &key (sc *store-controller*) (errorp t))
+(defmethod class-indexedp-by-name ((class-name symbol) &key (sc *store-controller*))
(get-value class-name (controller-class-root sc)))
(defmethod find-class-index ((class persistent-metaclass) &key (sc *store-controller*) (errorp t))
@@ -145,9 +145,8 @@
(defmethod find-inverted-index ((class persistent-metaclass) slot &key (null-on-fail nil))
(let* ((cidx (find-class-index class))
- (dslot (make-derived-name slot))
(idx (or (get-index cidx slot)
- (get-index cidx dslot))))
+ (get-index cidx (make-derived-name slot)))))
(if idx
idx
(if null-on-fail
@@ -166,26 +165,27 @@
(defmethod close-controller :before ((sc store-controller))
"Ensure the classes don't have stale references to closed stores!"
(when (controller-class-root sc)
- (map-btree (lambda (class-name index)
- (declare (ignore index))
- (let ((class (find-class class-name nil)))
- (when class
- (setf (%index-cache class) nil))))
- (controller-class-root sc))))
+ (with-transaction (:store-controller sc :txn-sync t :retries 2)
+ (map-btree (lambda (class-name index)
+ (declare (ignore index))
+ (let ((class (find-class class-name nil)))
+ (when class
+ (setf (%index-cache class) nil))))
+ (controller-class-root sc)))))
+
;; =============================
;; INDEXING INTERFACE
;; =============================
(defmethod enable-class-indexing ((class persistent-metaclass) indexed-slot-names &key (sc *store-controller*))
- (assert (not (= 0 (length indexed-slot-names))))
(let ((croot (controller-class-root sc)))
(multiple-value-bind (btree found)
(get-value (class-name class) croot)
(declare (ignore btree))
(when found (error "Class is already enabled for indexing! Run disable class indexing to clean up.")))
;; Put class instance index into the class root & cache it in the class object
- (update-indexed-record class indexed-slot-names)
+ (update-indexed-record class indexed-slot-names :class-indexed t)
(with-transaction (:store-controller sc)
(let ((class-idx (build-indexed-btree sc)))
(setf (get-value (class-name class) croot) class-idx)
@@ -283,7 +283,7 @@
(when update-class (register-derived-index class name))
(with-transaction (:store-controller sc)
(add-index class-idx
- :index-name name
+ :index-name (make-derived-name name)
:key-form (make-derived-key-form derived-defun)
:populate populate))))))
@@ -340,6 +340,7 @@
;; =========================
(defgeneric get-instances-by-class (persistent-metaclass))
+(defgeneric get-instance-by-value (persistent-metaclass slot-name value))
(defgeneric get-instances-by-value (persistent-metaclass slot-name value))
(defgeneric get-instances-by-range (persistent-metaclass slot-name start end))
@@ -384,6 +385,16 @@
(push val instances)
(return-from get-instances-by-value instances)))))))))
+(defmethod get-instance-by-value ((class symbol) slot-name value)
+ (let ((list (get-instances-by-value (find-class class) slot-name value)))
+ (when (consp list)
+ (car list))))
+
+(defmethod get-instance-by-value ((class persistent-metaclass) slot-name value)
+ (let ((list (get-instances-by-value class slot-name value)))
+ (when (consp list)
+ (car list))))
+
(defmethod get-instances-by-range ((class symbol) slot-name start end)
(get-instances-by-range (find-class class) slot-name start end))
@@ -417,174 +428,9 @@
(assert (consp instances))
(with-transaction (:store-controller sc)
(mapc (lambda (instance)
- (remove-kv (oid instance) (find-class-index (class-of instance))))
+ (remove-kv (oid instance) (find-class-index (class-of instance)))
+ (drop-pobject instance))
instances))))
-;; =============================
-;; CLASS / DB SYNCHRONIZATION
-;; =============================
-
-;; TO READER: I got really tired of trying to figure out all
-;; the messy conditionals and I figure default behaviors are something
-;; others might want to modify, so here's what determines the rule
-;; behavior.
-;;
-;; Rules match on the following states of the metaclass and current
-;; database class-index for each slotname currently in either of
-;; those sources. Actions are taken, typically when a slot exists
-;; in one but not the other or features like indexed/persistent
-;; differ between the slots
-;;
-;; class state:
-;; class-indexed - the slot is marked as indexed
-;; class-persistent - the slot is marked as persistent (not indexed)
-;; class-transient - the slot is marked transient
-;; class-derived - the slot is in the derived list of the class
-;;
-;; database
-;; db-slot - the database has a slot index
-;; db-derived - the database has a derived index
-;;
-;; The inversions of any of these terms are also available as
-;; (not indexed-slot) for example, to cover more than one feature
-;; combination
-;;
-;; Each rule should apply uniquely to a given feature set.
-;;
-;; Actions taken when rules match can include:
-;;
-;; add-slot-index - add a new index with the slotname to the db
-;; remove-slot-index - remove a slot with the slotname from the db
-;; add-derived-index - xxx this makes no sense! xxx
-;; remove-derived-index - remove a derived index from the db
-;; unregister-indexed-slot - remove an indexed slot from the class metaobject
-;; unregister-derived - remove a derived index from the class metaobject
-;; register-indexed-slot - register a slot with the class metaobject
-;; register-derived-index - register a derived index with the class metaobject
-;;
-
-;; DEFINE THE SYNCHRONIZATION RULES
-(eval-when (:compile-toplevel :load-toplevel)
-
- (defclass synch-rule ()
- ((lhs :accessor synch-rule-lhs :initarg :lhs :initform nil)
- (rhs :accessor synch-rule-rhs :initarg :rhs :initform nil)))
-
- (defun make-synch-rule (rule-spec)
- (let ((lhs (subseq rule-spec 0 (position '=> rule-spec)))
- (rhs (subseq rule-spec (1+ (position '=> rule-spec)))))
- (make-instance 'synch-rule :lhs lhs :rhs rhs)))
-
- (defparameter *synchronize-rules*
- (mapcar #'(lambda (rule-specs)
- (cons (car rule-specs)
- (mapcar #'make-synch-rule (cdr rule-specs))))
- '((:class ;; class changes db
- ((not db-slot) class-indexed => add-slot-index)
- (db-slot (not class-indexed) => remove-slot-index)
- (db-derived (not class-derived) => remove-derived-index))
- (:union ;; merge both sides
- (db-slot (not class-indexed) => register-indexed-slot)
- ((not db-slot) class-indexed => add-slot-index)
- (db-derived (not class-derived) => register-derived-index)
- (db-derived class-persistent => remove-derived-index warn))
- ;; NOTE: What about cases where we need to remove things as below?
- (:db ;; db changes class
- ((not db-slot) class-indexed => unregister-indexed-slot)
- ((not db-derived) class-derived => unregister-derived-index)
- (db-slot class-persistent => register-indexed-slot)
- (db-slot class-transient => remove-indexed-slot)
- (db-derived class-transient => remove-derived-index warn)
- (db-derived class-persistent => remove-derived-index warn)
- (db-derived class-indexed => remove-derived-index warn)
- (db-derived (not class-derived) (not class-indexed)
- (not class-persistent) (not class-transient) =>
- register-derived-slot)))))
- )
-
-;; TOP LEVEL METHOD
-
-(defun synchronize-class-to-store (class &key (sc *store-controller*)
- (method *default-indexed-class-synch-policy*))
- (let ((slot-records (compute-class-and-ele-status class sc))
- (rule-set (cdr (assoc method *synchronize-rules*))))
- (apply-synch-rules class slot-records rule-set)))
-
-;; COMPUTING RULE APPLICABILITY AND FIRING
-
-(defun synch-rule-applicable? (rule features)
- (simple-match-set (synch-rule-lhs rule) features))
-
-(defun simple-match-set (a b)
- (declare (optimize (speed 3) (safety 1)))
- (cond ((null a) t)
- ((and (not (null a)) (null b)) nil)
- ((member (first a) b :test #'equal)
- (simple-match-set (cdr a) (remove (first a) b :test #'equal)))
- (t nil)))
-
-(defparameter *print-synch-messages* nil)
-
-(defun apply-synch-rule (rule class name)
- (when *print-synch-messages*
- (format t "Class/DB Synch: converting state ~A using ~A for ~A~%"
- (synch-rule-lhs rule) (synch-rule-rhs rule) name))
- (loop for action in (synch-rule-rhs rule) do
- (case action
- (add-slot-index (add-class-slot-index class name :update-class nil))
- (remove-slot-index (remove-class-slot-index class name :update-class nil))
- (add-derived-index (add-class-derived-index class name :update-class nil))
- (remove-derived-index (remove-class-derived-index class name :update-class nil))
- (unregister-indexed-slot (unregister-indexed-slot class name))
- (unregister-derived-index (unregister-derived-index class name))
- (register-indexed-slot (register-indexed-slot class name))
- (register-derived-index (register-derived-index class name))
- (warn (warn "Performing slot synchronization actions: ~A" (synch-rule-rhs rule))))))
-
-(defun apply-synch-rules (class records rule-set)
- (declare (optimize (speed 3) (safety 1)))
- (labels ((slotname (rec) (car rec))
- (feature-set (rec) (cdr rec)))
- (loop for record in records do
- (loop for rule in rule-set
- when (synch-rule-applicable? rule (feature-set record))
- do
- (apply-synch-rule rule class (slotname record))))))
-
-;; COMPUTE CURRENT STATE OF CLASS OBJECT AND DATABASE AFTER CHANGES
-
-(defun compute-class-and-ele-status (class &optional (store-controller *store-controller*))
- (let* ((*store-controller* store-controller)
- ;; db info
- (db-indices (find-inverted-index-names class))
- (db-derived (mapcar #'get-derived-name-root
- (remove-if-not #'derived-name? db-indices)))
- (db-slot (set-difference db-indices db-derived))
- ;; class info
- (marked-slots (indexing-record-slots (indexed-record class)))
- (marked-derived (indexing-record-derived (indexed-record class)))
- (persistent-slots (set-difference (persistent-slots class) marked-slots))
- (other-slots (set-difference
- (set-difference (class-slots class) persistent-slots)
- marked-slots))
- (all-names (union (mapcar #'slot-definition-name (class-slots class)) db-indices))
- ;; [order matters in traversal]
- (all-sets `((class-indexed . ,marked-slots)
- (class-derived . ,marked-derived)
- (class-persistent . ,persistent-slots)
- (class-transient . ,other-slots)
- (db-slot . ,db-slot)
- (db-derived . ,db-derived))))
- (labels ((compute-features (slotname)
- (let ((features nil))
- (loop for set in all-sets do
- (push (compute-feature slotname (cdr set) (car set))
- features))
- (cons slotname features)))
- (compute-feature (name set label)
- (if (member name set)
- label
- `(not ,label))))
- (mapcar #'compute-features all-names))))
--- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/02/20 21:21:42 1.3
+++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/04/26 17:53:44 1.4
@@ -332,6 +332,17 @@
(unless more (return nil))
(funcall fn k v)))))
+(defmethod empty-btree-p ((btree btree))
+ (with-transaction (:store-controller (get-con btree))
+ (with-btree-cursor (cur btree)
+ (multiple-value-bind (valid k) (cursor-next cur)
+ (cond ((not valid) ;; truly empty
+ t)
+ ((eq k *elephant-properties-label*) ;; has properties
+ (not (cursor-next cur)))
+ (t nil))))))
+
+
(defun dump-btree (bt)
(format t "DUMP ~A~%" bt)
(map-btree #'(lambda (k v) (format t "k ~A / v ~A~%" k v)) bt)
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/03/27 20:36:28 1.8
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/04/26 17:53:44 1.9
@@ -117,8 +117,9 @@
"Conveniently open a store controller."
(assert (consp spec))
(setq *store-controller* (get-controller spec))
- (open-controller *store-controller* :recover recover
- :recover-fatal recover-fatal :thread thread))
+ (ensure-marked-version
+ (open-controller *store-controller* :recover recover
+ :recover-fatal recover-fatal :thread thread)))
(defun close-store (&optional sc)
"Conveniently close the store controller."
@@ -131,12 +132,12 @@
(defmacro with-open-store ((spec) &body body)
"Executes the body with an open controller,
unconditionally closing the controller on exit."
- `(let ((*store-controller* (get-controller ,spec)))
+ `(let ((*store-controller* nil))
(declare (special *store-controller*))
- (open-controller *store-controller*)
+ (open-store spec)
(unwind-protect
(progn , at body)
- (close-controller *store-controller*))))
+ (close-store *store-controller*))))
;;
;; COMMON STORE CONTROLLER FUNCTIONALITY
@@ -163,6 +164,96 @@
(for garbage collection,) et cetera."))
;;
+;; VERSIONING AND UPGRADES
+;;
+
+;; Need to tag databases
+;; Need to handle untagged db's
+;; Need to provide upgrade hooks
+
+(defvar *restricted-properties* '(:version)
+ "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))))
+
+(defmethod ensure-marked-version ((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)
+
+(defmethod controller-version ((sc store-controller))
+ (let ((alist (controller-properties sc)))
+ (let ((result (assoc :version alist)))
+ (if result
+ (cdr result)
+ nil))))
+
+(defmethod up-to-date-p ((sc store-controller))
+ (equal (controller-version sc) *elephant-code-version*))
+
+(defparameter *elephant-upgrade-table*
+ '( ((0 6 0) (0 5 0))
+ ))
+
+(defun prior-version-p (v1 v2)
+ "Is v1 an equal or earlier version than v2"
+ (cond ((and (null v1) (null v2)) t)
+ ((and (null v1) (not (null v2))) t)
+ ((and (not (null v1)) (null v2)) nil)
+ ((< (car v1) (car v2)) t)
+ ((> (car v1) (car v2)) nil)
+ ((= (car v1) (car v2))
+ (prior-version-p (cdr v1) (cdr v2)))
+ (t (error "Version problem!"))))
+
+(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))
+
+(defmethod upgrade ((sc store-controller))
+ (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 "Upgrade by migrating your old repository to a clean repository created using the current code base. i.e. (migrate new old)"))
+
+
+;;
;; OBJECT CACHE
;;
@@ -178,7 +269,7 @@
(let ((obj (get-cache oid (instance-cache sc))))
(if obj obj
;; Should get cached since make-instance calls cache-instance
- (make-instance (handle-legacy-classes class-name)
+ (make-instance (handle-legacy-classes class-name nil)
:from-oid oid :sc sc))))
(defmethod flush-instance-cache ((sc store-controller))
@@ -188,7 +279,13 @@
(setf (instance-cache sc)
(make-cache-table :test 'eql)))
-(defun handle-legacy-classes (name)
+(defparameter *legacy-conversions-db*
+ '((("elephant" . "bdb-btree") . ("sleepycat" . "bdb-btree"))
+ (("elephant" . "bdb-indexed-btree") . ("sleepycat" . "bdb-indexed-btree"))
+ (("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index"))))
+
+(defun handle-legacy-classes (name version)
+ (declare (ignore version))
(let ((entry (assoc (symbol->string-pair name) *legacy-conversions-db* :test #'equal)))
(if entry
(string-pair->symbol (cdr entry))
@@ -201,10 +298,6 @@
(defun string-pair->symbol (name)
(intern (string-upcase (cdr name)) (car name)))
-(defparameter *legacy-conversions-db*
- '((("elephant" . "bdb-btree") . ("sleepycat" . "bdb-btree"))
- (("elephant" . "bdb-indexed-btree") . ("sleepycat" . "bdb-indexed-btree"))
- (("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index"))))
;;
;; STORE CONTROLLER PROTOCOL
@@ -264,6 +357,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*)))
(setf (get-value key (controller-root store-controller)) value))
(defun get-from-root (key &key (store-controller *store-controller*))
@@ -293,12 +387,9 @@
(defmethod drop-pobject ((inst persistent-object))
"Reclaim persistent object storage by unbinding slot values.
- This also drops references to the instance from any index
- it partipates in. This does not delete the cached object
- instance or any serialized references still in the db.
+ This does not delete the cached object instance or any
+ serialized references still in the db.
Need a migration or GC for that!"
- (when (indexed (class-of inst))
- (drop-instances (list inst)))
(let ((pslots (persistent-slots (class-of inst))))
(dolist (slot pslots)
(slot-makunbound inst slot))))
--- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/25 22:05:08 1.6
+++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/04/26 17:53:44 1.7
@@ -40,16 +40,16 @@
;; Top level defclass form - hide metaclass option
;;
-(defmacro defpclass (cname parents slot-defs &optional class-opts)
+(defmacro defpclass (cname parents slot-defs &rest class-opts)
`(defclass ,cname ,parents
,slot-defs
- ,(add-persistent-metaclass-argument class-opts)))
+ ,@(add-persistent-metaclass-argument class-opts)))
(defun add-persistent-metaclass-argument (class-opts)
(when (assoc :metaclass class-opts)
(error "User metaclass specification not allowed in defpclass"))
- (append (list :metaclass 'persistent-metaclass) class-opts))
-
+ (append class-opts (list (list :metaclass 'persistent-metaclass))))
+
;;
;; Persistent slot maintenance
;;
@@ -105,7 +105,7 @@
;; This just encapsulates record keeping a bit
(defclass indexing-record ()
- ((class :accessor indexing-record-class :initarg :class :initform t)
+ ((class :accessor indexing-record-class :initarg :class :initform nil)
(slots :accessor indexing-record-slots :initarg :slots :initform nil)
(derived-count :accessor indexing-record-derived :initarg :derived :initform 0)))
@@ -125,16 +125,21 @@
(when (slot-boundp class '%indexed-slots)
(cdr (%indexed-slots class))))
-(defmethod update-indexed-record ((class persistent-metaclass) new-slot-list)
+(defmethod update-indexed-record ((class persistent-metaclass) new-slot-list &key class-indexed)
(let ((oldrec (if (slot-boundp class '%indexed-slots)
(indexed-record class)
nil)))
(setf (%indexed-slots class)
- (cons (make-instance 'indexing-record
- :slots new-slot-list
- :derived (when oldrec (indexing-record-derived oldrec)))
+ (cons (make-new-indexed-record new-slot-list oldrec class-indexed)
(if oldrec oldrec nil)))))
+(defmethod make-new-indexed-record (new-slot-list oldrec class-indexed)
+ (make-instance 'indexing-record
+ :class (or class-indexed
+ (when oldrec (indexing-record-class oldrec)))
+ :slots new-slot-list
+ :derived (when oldrec (indexing-record-derived oldrec))))
+
(defmethod removed-indexing? ((class persistent-metaclass))
(and (not (indexed class))
(previously-indexed class)))
@@ -191,9 +196,10 @@
(setf (indexing-record-derived record) (remove name (indexing-record-derived record)))))
(defmethod indexed ((class persistent-metaclass))
- (and (slot-boundp class '%indexed-slots )
+ (and (slot-boundp class '%indexed-slots)
(not (null (%indexed-slots class)))
- (or (indexing-record-slots (indexed-record class))
+ (or (indexing-record-class (indexed-record class))
+ (indexing-record-slots (indexed-record class))
(indexing-record-derived (indexed-record class)))))
(defmethod previously-indexed ((class persistent-metaclass))
@@ -201,7 +207,8 @@
(not (null (%indexed-slots class)))
(let ((old (old-indexed-record class)))
(when (not (null old))
- (or (indexing-record-slots old)
+ (or (indexing-record-class old)
+ (indexing-record-slots old)
(indexing-record-derived old))))))
(defmethod indexed ((slot standard-slot-definition)) nil)
--- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/21 19:40:06 1.3
+++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/04/26 17:53:44 1.4
@@ -28,17 +28,17 @@
;; - Migrate currently will not handle circular list objects
;; - Migrate does not support arrays with nested persistent objects
;;
-;;
;; - Indexed classes only have their class index copied if you use the
;; top level migration. Objects will be copied without slot data if you
;; try to migrate an object outside of a store-to-store migration due to
;; the class object belonging to one store or another
+;;
;; - Migrate assumes that after migration, indexed classes belong to the
;; target store.
;;
;; - In general, migration is a one-time activity and afterwards (or after
;; a validation test) the source store should be closed. Any failures
-;; in migration should then be easy to catch
+;; in migration should then be easy to catch.
;;
;; - Each call to migration will be good about keeping track of already
;; copied objects to avoid duplication. Duplication _shouldn't_ screw
@@ -46,9 +46,16 @@
;; However this information is not saved between calls and there's no
;; other way to do comparisons between objects across stores (different
;; oid namespaces) so user beware of the pitfalls of partial migrations...
+;;
+;; - Migrate keeps a memory-resident hash of all objects; this means
+;; you cannot currently migrate a store that has more data than your
+;; main memory. (This could be fixed by keeping the oid table in
+;; the target store and deleting it on completion)
+;;
;; - Migration does not maintain OID equivalence so any datastructures which
;; index into those will have to have a way to reconstruct themselves (better
-;; to keep the object references themselves rather than oids)
+;; to keep the object references themselves rather than oids in general)
+;; but they can overload the migrate method to accomplish this cleanly
;;
;; CUSTOMIZE MIGRATION:
;; - To customize migration overload a version of migrate to specialize on
@@ -149,8 +156,9 @@
;; Copy all other reachable objects
(map-btree (lambda (key value)
(let ((newval (migrate dst value)))
- (with-transaction (:store-controller dst :txn-nosync t)
- (add-to-root key newval :store-controller dst))))
+ (unless (eq key *elephant-properties-label*)
+ (with-transaction (:store-controller dst :txn-nosync t)
+ (add-to-root key newval :store-controller dst)))))
(controller-root src))
dst)
@@ -302,7 +310,7 @@
(defmethod migrate ((dst store-controller) (src array))
"NOTE: We need to handle arrays that might contain persistent objects!"
- (warn "Arrays with persistent objects will fail migration!")
+ (warn "Arrays containing persistent objects will fail migration!")
src)
--- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/03/01 18:57:34 1.2
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/04/26 17:53:44 1.3
@@ -50,7 +50,7 @@
(defconstant +ucs4-string+ 21)
(defconstant +ucs4-pathname+ 22)
-(defconstant +persistent+ 15)
+(defconstant +persistent+ 15) ;; stored by id+classname
(defconstant +cons+ 16)
(defconstant +hash-table+ 17)
(defconstant +object+ 18)
@@ -59,7 +59,6 @@
(defconstant +fill-pointer-p+ #x40)
(defconstant +adjustable-p+ #x80)
-
(defun serialize (frob bs)
"Serialize a lisp value into a buffer-stream."
(declare (optimize (speed 3) (safety 0))
@@ -81,12 +80,13 @@
(buffer-write-byte
#+(and allegro ics)
(etypecase s
- (base-string +ucs1-symbol+)
+ (base-string +ucs2-symbol+) ;; +ucs1-symbol+
(string +ucs2-symbol+))
#+(or (and sbcl sb-unicode) lispworks)
(etypecase s
- (base-string +ucs1-symbol+)
- (string #+sbcl +ucs4-symbol+ #+lispwoks +ucs2-symbol+))
+ (base-string #+sbcl +ucs4-symbol+ #+lispworks +ucs2-symbol+ )
+ ;; +ucs1-symbol+)
+ (string #+sbcl +ucs4-symbol+ #+lispworks +ucs2-symbol+))
#-(or lispworks (and allegro ics) (and sbcl sb-unicode))
+ucs1-symbol+
bs)
@@ -101,11 +101,12 @@
(buffer-write-byte
#+(and allegro ics)
(etypecase frob
- (base-string +ucs1-string+)
+ (base-string +ucs2-string+) ;; +ucs1-string+
(string +ucs2-string+))
#+(or (and sbcl sb-unicode) lispworks)
(etypecase frob
- (base-string +ucs1-string+)
+ (base-string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+ )
+ ;; +ucs1-string+
(string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+))
#-(or lispworks (and allegro ics) (and sbcl sb-unicode))
+ucs1-string+
@@ -143,11 +144,12 @@
(buffer-write-byte
#+(and allegro ics)
(etypecase s
- (base-string +ucs1-pathname+)
+ (base-string +ucs2-pathname+) ;; +ucs1-pathname+
(string +ucs2-pathname+))
#+(or (and sbcl sb-unicode) lispworks)
(etypecase s
- (base-string +ucs1-pathname+)
+ (base-string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+ )
+ ;; +ucs1-pathname+
(string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+))
#-(or lispworks (and allegro ics) (and sbcl sb-unicode))
+ucs1-pathname+
--- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2006/02/19 04:53:00 1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2006/04/26 17:53:44 1.2
@@ -52,6 +52,7 @@
:txn-nowait ,txn-nowait
:txn-sync ,txn-sync))
+
;;
;; An interface to manage transactions explicitely
;;
--- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/02/19 04:53:00 1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/04/26 17:53:44 1.2
@@ -27,6 +27,22 @@
(defvar *cachesize* 100
"Size of the OID sequence cache.")
+;;;;;;;;;;;;;;;;
+;;;; Versioning Support
+
+(defvar *elephant-code-version* '(0 6 0)
+ "The current database version supported by the code base")
+
+(defvar *elephant-unmarked-code-version* '(0 5 0)
+ "If a database is opened with existing data but no version then
+ we assume it's version 0.5.0")
+
+(defvar *elephant-properties-label* 'elephant::*database-properties*
+ "This is the symbol used to store properties associated with the
+ database in the controller-root through the new properties interface.
+ Users attempting to directly write this variable will run into an
+ error")
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Thread-local specials
--- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2006/04/26 17:53:45 NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2006/04/26 17:53:45 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; package.lisp -- package definition
;;;
;;; 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 :cl-user)
(defpackage elephant
(:use common-lisp elephant-memutil)
(:nicknames ele :ele)
(:documentation
"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*
#:store-controller
#:open-store #:close-store #:with-open-store
#:add-to-root #:get-from-root #:remove-from-root #:root-existsp
#:flush-instance-cache
#:with-transaction
#:start-ele-transaction #:commit-transaction #:abort-transaction
#:persistent #:persistent-object #:persistent-metaclass
#:persistent-collection #:defpclass
#:btree #:make-btree #:get-value #:remove-kv #:existp #:map-btree
#:indexed-btree #:make-indexed-btree
#:add-index #:get-index #:remove-index #:map-indices
#:btree-index #:get-primary-key
#:primary #:key-form #:key-fn
#:btree-differ
#:migrate #:*inhibit-slot-copy*
#:cursor #:secondary-cursor #:make-cursor
#:with-btree-cursor #:cursor-close #:cursor-init
#:cursor-duplicate #:cursor-current #:cursor-first
#:cursor-last #:cursor-next #:cursor-next-dup
#:cursor-next-nodup #:cursor-prev #:cursor-prev-nodup
#:cursor-set #:cursor-set-range #:cursor-get-both
#:cursor-get-both-range #:cursor-delete #:cursor-put
#:cursor-pcurrent #:cursor-pfirst #:cursor-plast
#:cursor-pnext #:cursor-pnext-dup #:cursor-pnext-nodup
#:cursor-pprev #:cursor-pprev-nodup #:cursor-pset
#: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
#:enable-class-indexing #:disable-class-indexing
#:add-class-slot-index #:remove-class-slot-index
#:add-class-derived-index #:remove-class-derived-index
#:describe-db-class-index
#:report-indexed-classes
#:class-indexedp-by-name
;; Low level cursor API
#:make-inverted-cursor #:make-class-cursor
#:with-inverted-cursor #:with-class-cursor
;; Instance query API
#:get-instances-by-class
#:get-instance-by-value
#:get-instances-by-value
#:get-instances-by-range
#:drop-instances
)
#+cmu
(:import-from :pcl
compute-class-precedence-list
validate-superclass
standard-slot-definition
standard-direct-slot-definition
standard-effective-slot-definition
direct-slot-definition-class
effective-slot-definition-class
slot-definition-name
slot-definition-initform
slot-definition-initfunction
compute-effective-slot-definition
class-slots
slot-value-using-class
slot-boundp-using-class
slot-makunbound-using-class
slot-definition-allocation
slot-definition-initargs
class-finalized-p
finalize-inheritance
ensure-class-using-class
compute-slots
initialize-internal-slot-functions
compute-effective-slot-definition-initargs
slot-definition-reader-function
slot-definition-writer-function
slot-definition-boundp-function
slot-definition-allocation-class
class-slot-cells
plist-value
+slot-unbound+)
#+cmu
(:import-from :ext
make-weak-pointer weak-pointer-value finalize)
#+cmu
(:import-from :bignum
%bignum-ref)
#+sbcl
(:import-from :sb-mop
compute-class-precedence-list
validate-superclass
standard-slot-definition
standard-direct-slot-definition
standard-effective-slot-definition
direct-slot-definition-class
effective-slot-definition-class
slot-definition-name
slot-definition-initform
slot-definition-initfunction
compute-effective-slot-definition
class-slots
slot-value-using-class
slot-boundp-using-class
slot-makunbound-using-class
slot-definition-allocation
slot-definition-initargs
class-finalized-p
finalize-inheritance
ensure-class-using-class
compute-slots)
#+sbcl
(:import-from :sb-pcl
initialize-internal-slot-functions
compute-effective-slot-definition-initargs
slot-definition-reader-function
slot-definition-writer-function
slot-definition-boundp-function
slot-definition-allocation-class
class-slot-cells
plist-value
+slot-unbound+)
#+sbcl
(:import-from :sb-ext
make-weak-pointer weak-pointer-value finalize)
#+sbcl
(:import-from :sb-bignum
%bignum-ref)
#+allegro
(:import-from :clos
compute-class-precedence-list
validate-superclass
standard-slot-definition
standard-direct-slot-definition
standard-effective-slot-definition
direct-slot-definition-class
effective-slot-definition-class
slot-definition-name
slot-definition-initform
slot-definition-initfunction
compute-effective-slot-definition
class-slots
slot-value-using-class
slot-boundp-using-class
slot-makunbound-using-class
slot-definition-allocation
slot-definition-initargs
class-finalized-p
finalize-inheritance
ensure-class-using-class
compute-slots
slot-definition-readers
slot-definition-writers
class-direct-slots
)
#+allegro
(:import-from :excl
compute-effective-slot-definition-initargs)
#+openmcl
(:import-from :ccl
class-finalized-p
finalize-inheritance
ensure-class-using-class
compute-class-precedence-list
validate-superclass
standard-slot-definition
standard-direct-slot-definition
standard-effective-slot-definition
direct-slot-definition-class
effective-slot-definition-class
slot-definition-name
slot-definition-initform
slot-definition-initfunction
compute-effective-slot-definition
class-slots
slot-value-using-class
slot-boundp-using-class
slot-makunbound-using-class
slot-definition-allocation
slot-definition-initargs
compute-slots
;; This stuff we need until we resolve the :transient
;; slot specifier stuff
make-effective-slot-definition
slots-class
%slot-definition-initfunction
%slot-definition-documentation
%slot-definition-initargs
%slot-definition-initform
%slot-definition-allocation
%slot-definition-class
%slot-definition-type)
#+lispworks
(:import-from :clos
compute-class-precedence-list
validate-superclass
ensure-class-using-class
standard-slot-definition
standard-direct-slot-definition
standard-effective-slot-definition
direct-slot-definition-class
effective-slot-definition-class
slot-definition-name
slot-definition-initform
slot-definition-initfunction
compute-effective-slot-definition
class-slots
slot-value-using-class
slot-boundp-using-class
slot-makunbound-using-class
slot-definition-allocation
slot-definition-initargs
compute-slots)
)
(in-package "ELE")
#+cmu
(eval-when (:compile-toplevel)
(proclaim '(optimize (ext:inhibit-warnings 3))))
More information about the Elephant-cvs
mailing list