[elephant-cvs] CVS elephant/src/contrib/eslick
ieslick
ieslick at common-lisp.net
Sun Feb 4 10:23:22 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/contrib/eslick
In directory clnet:/tmp/cvs-serv10743/eslick
Added Files:
metaclasses-new.lisp package-new.lisp
Log Message:
Some working files for a lisp backend and a port to close-to-mop to cleanup the MOP implementation
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/metaclasses-new.lisp 2007/02/04 10:23:22 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/metaclasses-new.lisp 2007/02/04 10:23:22 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; metaclasses.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>
;;; (Some changes by Robert L. Read, 2006)
;;;
;;; 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")
(defclass persistent ()
((%oid :accessor oid :initarg :from-oid)
(dbonnection-spec-pst :type (or list string) :accessor :dbcn-spc-pst :initarg :dbconnection-spec-pst))
(:documentation "Abstract superclass for all persistent classes (common
to user-defined classes and collections.)"))
(defclass persistent-metaclass (standard-class)
((%persistent-slots :accessor %persistent-slots)
(%indexed-slots :accessor %indexed-slots)
(%index-cache :accessor %index-cache))
(:documentation
"Metaclass for persistent classes. Use this metaclass to
define persistent classes. All slots are persistent by
default; use the :transient flag otherwise. Slots can also
be indexed for by-value retrieval."))
;;
;; Top level defclass form - hide metaclass option
;;
(defmacro defpclass (cname parents slot-defs &rest class-opts)
`(defclass ,cname ,parents
,slot-defs
,@(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 class-opts (list (list :metaclass 'persistent-metaclass))))
;;
;; Persistent slot maintenance
;;
(defmethod persistent-slots ((class persistent-metaclass))
(if (slot-boundp class '%persistent-slots)
(car (%persistent-slots class))
nil))
(defmethod persistent-slots ((class standard-class))
nil)
(defmethod old-persistent-slots ((class persistent-metaclass))
(cdr (%persistent-slots class)))
(defmethod update-persistent-slots ((class persistent-metaclass) new-slot-list)
;; (setf (%persistent-slots class) (cons new-slot-list (car (%persistent-slots class)))))
(setf (%persistent-slots class) (cons new-slot-list
(if (slot-boundp class '%persistent-slots)
(car (%persistent-slots class))
nil)
)))
(defclass persistent-slot-definition (standard-slot-definition)
((indexed :accessor indexed :initarg :index :initform nil :allocation :instance)))
(defclass persistent-direct-slot-definition (standard-direct-slot-definition persistent-slot-definition)
())
(defclass persistent-effective-slot-definition (standard-effective-slot-definition persistent-slot-definition)
())
(defclass transient-slot-definition (standard-slot-definition)
((transient :initform t :initarg :transient :allocation :class)))
(defclass transient-direct-slot-definition (standard-direct-slot-definition transient-slot-definition)
())
(defclass transient-effective-slot-definition (standard-effective-slot-definition transient-slot-definition)
())
(defgeneric transient (slot))
(defmethod transient ((slot standard-direct-slot-definition))
t)
(defmethod transient ((slot persistent-direct-slot-definition))
nil)
;;
;; Indexed slots maintenance
;;
;; This just encapsulates record keeping a bit
(defclass indexing-record ()
((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)))
(defmethod print-object ((obj indexing-record) stream)
(format stream "#INDEXING-RECORD<islt: ~A dslt: ~A>"
(length (indexing-record-slots obj))
(length (indexing-record-derived obj))))
(defmethod indexed-record ((class standard-class))
nil)
(defmethod indexed-record ((class persistent-metaclass))
(when (slot-boundp class '%indexed-slots)
(car (%indexed-slots class))))
(defmethod old-indexed-record ((class persistent-metaclass))
(when (slot-boundp class '%indexed-slots)
(cdr (%indexed-slots class))))
(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-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)))
(defun indexed-slot-names-from-defs (class)
(let ((slot-definitions (class-slots class)))
(loop for slot-definition in slot-definitions
when (and (subtypep (type-of slot-definition) 'persistent-slot-definition)
(indexed slot-definition))
collect (slot-definition-name slot-definition))))
(defmethod register-indexed-slot ((class persistent-metaclass) slot)
"This method allows for post-definition update of indexed status of
class slots. It changes the effective method so we can rely on
generic function dispatch for differentated behavior"
;; update record
(let ((record (indexed-record class)))
(unless (member slot (car (%persistent-slots class)))
(error "Tried to register slot ~A as index which isn't a persistent slot" slot))
(unless (member slot (indexing-record-slots record))
;; This is a normal startup case, but during other cases we'd like
;; the duplicate warning
;; (warn "Tried to index slot ~A which is already indexed" slot))
(push slot (indexing-record-slots record))))
;; change effective slot def
(let ((slot-def (find-slot-def-by-name class slot)))
(unless slot-def
(error "Slot definition for slot ~A not found, inconsistent state in
class ~A" slot (class-name class)))
(setf (slot-value slot-def 'indexed) t)))
(defmethod unregister-indexed-slot (class slot)
"Revert an indexed slot to it's original state"
;; update record
(let ((record (indexed-record class)))
(unless (member slot (indexing-record-slots record))
(error "Tried to unregister slot ~A which is not indexed" slot))
(setf (indexing-record-slots record) (remove slot (indexing-record-slots record))))
;; change effective slot def status
(let ((slot-def (find-slot-def-by-name class slot)))
(unless slot-def
(error "Slot definition for slot ~A not found, inconsistent state in
class ~A" slot (class-name class)))
(setf (slot-value slot-def 'indexed) nil)))
(defmethod register-derived-index (class name)
"Tell the class that it has derived indices defined against it
and keep a reference count"
(let ((record (indexed-record class)))
(push name (indexing-record-derived record))))
(defmethod unregister-derived-index (class name)
(let ((record (indexed-record class)))
(setf (indexing-record-derived record) (remove name (indexing-record-derived record)))))
(defmethod indexed ((class persistent-metaclass))
(and (slot-boundp class '%indexed-slots)
(not (null (%indexed-slots 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))
(and (slot-boundp class '%indexed-slots)
(not (null (%indexed-slots class)))
(let ((old (old-indexed-record class)))
(when (not (null old))
(or (indexing-record-class old)
(indexing-record-slots old)
(indexing-record-derived old))))))
(defmethod indexed ((slot standard-slot-definition)) nil)
(defmethod indexed ((class standard-class)) nil)
(defvar *inhibit-indexing-list* nil
"Use this to avoid updating an index inside
low-level functions that update groups of
slots at once. We may need to rethink this
if we go to a cheaper form of update that
doesn't batch update all indices")
(defun inhibit-indexing (uid)
(pushnew uid *inhibit-indexing-list*))
(defun uninhibit-indexing (uid)
(setf *inhibit-indexing-list*
(delete uid *inhibit-indexing-list*)))
;;
;; Original support for persistent slot protocol
;;
(defmethod slot-definition-allocation ((slot-definition persistent-slot-definition))
:database)
(defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs)
"Checks for the transient tag (and the allocation type)
and chooses persistent or transient slot definitions."
(let ((allocation-key (getf initargs :allocation))
(transient-p (getf initargs :transient))
(indexed-p (getf initargs :index)))
(when (consp transient-p) (setq transient-p (car transient-p)))
(when (consp indexed-p) (setq indexed-p (car indexed-p)))
(cond ((and (eq allocation-key :class) transient-p)
(find-class 'transient-direct-slot-definition))
((and (eq allocation-key :class) (not transient-p))
(error "Persistent class slots are not supported, try :transient t."))
((and indexed-p transient-p)
(error "Cannot declare slots to be both transient and indexed"))
(transient-p
(find-class 'transient-direct-slot-definition))
(t
(find-class 'persistent-direct-slot-definition)))))
(defmethod validate-superclass ((class persistent-metaclass) (super standard-class))
"Persistent classes may inherit from ordinary classes."
t)
(defmethod validate-superclass ((class standard-class) (super persistent-metaclass))
"Ordinary classes may NOT inherit from persistent classes."
nil)
(defgeneric persistent-p (class))
(defmethod persistent-p ((class t))
nil)
(defmethod persistent-p ((class persistent-metaclass))
t)
(defmethod persistent-p ((class persistent-slot-definition))
t)
(defmethod effective-slot-definition-class ((class persistent-metaclass) &rest initargs)
"Chooses the persistent or transient effective slot
definition class depending on the keyword."
(let ((transient-p (getf initargs :transient))
(indexed-p (getf initargs :index)))
(when (consp transient-p) (setq transient-p (car transient-p)))
(when (consp indexed-p) (setq indexed-p (car indexed-p)))
(cond ((and indexed-p transient-p)
(error "Cannot declare a slot to be both indexed and transient"))
(transient-p
(find-class 'transient-effective-slot-definition))
(t
(find-class 'persistent-effective-slot-definition)))))
(defun ensure-transient-chain (slot-definitions initargs)
(declare (ignore initargs))
(loop for slot-definition in slot-definitions
always (transient slot-definition)))
(defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) slot-definitions)
(let ((initargs (call-next-method)))
(if (ensure-transient-chain slot-definitions initargs)
(setf initargs (append initargs '(:transient t)))
(setf (getf initargs :allocation) :database))
;; Effective slots are indexed only if the most recent slot definition
;; is indexed. NOTE: Need to think more about inherited indexed slots
(if (indexed (first slot-definitions))
(append initargs '(:index t))
initargs)))
(defun find-slot-def-by-name (class slot-name)
(loop for slot-def in (class-slots class)
when (eq (slot-definition-name slot-def) slot-name)
do (return slot-def)))
(defun persistent-slot-defs (class)
(let ((slot-definitions (class-slots class)))
(loop for slot-def in slot-definitions
when (subtypep (type-of slot-def) 'persistent-effective-slot-definition)
collect slot-def)))
(defun transient-slot-defs (class)
(let ((slot-definitions (class-slots class)))
(loop for slot-def in slot-definitions
unless (persistent-p slot-def)
collect slot-def)))
(defun persistent-slot-names (class)
(mapcar #'slot-definition-name (persistent-slot-defs class)))
(defun transient-slot-names (class)
(mapcar #'slot-definition-name (transient-slot-defs class)))
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/package-new.lisp 2007/02/04 10:23:22 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/package-new.lisp 2007/02/04 10:23:22 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-btrees
(:use :closer-common-lisp)
(:export
#: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))
(defpackage elephant
(:use :closer-common-lisp :elephant-memutil :elephant-btrees)
(: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 #:optimize-storage
#: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*
#:run-elephant-thread
;; Class indexing management API
[28 lines skipped]
More information about the Elephant-cvs
mailing list