[elephant-cvs] CVS elephant/src
ieslick
ieslick at common-lisp.net
Thu Jan 26 04:03:45 UTC 2006
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp:/tmp/cvs-serv1023/src
Modified Files:
Tag: ELEPHANT-0-4-1-rc1-IAN
bdb-enable.lisp classes.lisp collections.lisp controller.lisp
metaclasses.lisp sleepycat.lisp
Added Files:
Tag: ELEPHANT-0-4-1-rc1-IAN
IAN-TODO indexing.lisp
Log Message:
First pass implementation of main class indexing system after branching from 0.4.1-rc1
--- /project/elephant/cvsroot/elephant/src/bdb-enable.lisp 2006/01/25 22:18:03 1.4
+++ /project/elephant/cvsroot/elephant/src/bdb-enable.lisp 2006/01/26 04:03:44 1.4.2.1
@@ -66,15 +66,15 @@
(uffi:load-foreign-library "/lib/tls/libpthread.so.0" :module "pthread")
(error "Couldn't load libpthread!"))
- (unless
- (uffi:load-foreign-library
- (if (find-package 'asdf)
+ (unless
+ (uffi:load-foreign-library
+ (if (find-package 'asdf)
(merge-pathnames
- #p"libmemutil.so"
+ (make-pathname :name "libmemutil" :type *c-library-extension*)
(asdf:component-pathname (asdf:find-system 'elephant)))
- "/usr/local/share/common-lisp/elephant-0.3/libmemutil.so")
- :module "libmemutil")
- (error "Couldn't load libmemutil.so!"))
+ (format nil "/usr/local/share/common-lisp/elephant-0.3/libmemutil.~A" *c-library-extension*))
+ :module "libmemutil")
+ (error "Couldn't load libmemutil.~A!" *c-library-extension*))
;; This code has now been moved to the small, asdf-loadable system
@@ -87,9 +87,9 @@
;; "/db/ben/lisp/db43/lib/libdb.so"
"/usr/local/BerkeleyDB.4.3/lib/libdb-4.3.so"
;; this works on FreeBSD
- #+(and (or bsd freebsd) (not darwin))
+ #+(and (or bsd freebsd) (not darwin macosx))
"/usr/local/lib/db43/libdb.so"
- #+darwin
+ #+(or darwin macosx)
;; for Fink (OS X) -- but I will assume Linux more common...
;; "/sw/lib/libdb-4.3.dylib"
;; a possible manual install
@@ -102,10 +102,10 @@
(uffi:load-foreign-library
(if (find-package 'asdf)
(merge-pathnames
- #p"libsleepycat.so"
+ (make-pathname :name "libsleepycat" :type *c-library-extension*)
(asdf:component-pathname (asdf:find-system 'elephant)))
- "/usr/local/share/common-lisp/elephant-0.3/libsleepycat.so")
+ (format nil "/usr/local/share/common-lisp/elephant-0.3/libsleepycat.~A" *c-library-extension*))
:module "libsleepycat")
- (error "Couldn't load libsleepycat!"))
+ (error "Couldn't load libsleepycat.~A!" *c-library-extension*))
)
--- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/25 14:09:46 1.16
+++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/26 04:03:44 1.16.2.1
@@ -138,7 +138,10 @@
(call-next-method)
(if (not (slot-boundp instance '%persistent-slots))
(setf (%persistent-slots instance)
- (cons (persistent-slot-names instance) nil)))))
+ (cons (persistent-slot-names instance) nil)))
+ (if (not (slot-boundp instance '%indexed-slots))
+ (setf (%indexed-slots instance)
+ (cons (indexed-slot-names instance) nil)))))
;; #+(or cmu sbcl)
;; (defmethod finalize-inheritance :around ((instance persistent-metaclass))
@@ -247,6 +250,8 @@
(declare (optimize (speed 3)))
(let ((name (slot-definition-name slot-def)))
(persistent-slot-writer new-value instance name)))
+;; (when (%indexed-p class)
+;; (update-class-index class instance))))
(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."
--- /project/elephant/cvsroot/elephant/src/collections.lisp 2006/01/24 15:42:30 1.13
+++ /project/elephant/cvsroot/elephant/src/collections.lisp 2006/01/26 04:03:44 1.13.2.1
@@ -144,11 +144,9 @@
(defclass bdb-indexed-btree (indexed-btree bdb-btree )
(
- (indices :accessor indices :initform (make-hash-table)
- )
+ (indices :accessor indices :initform (make-hash-table))
(indices-cache :accessor indices-cache :initform (make-hash-table)
- :transient t
-)
+ :transient t)
)
(:metaclass persistent-metaclass)
(:documentation "A BDB-based BTree supports secondary indices."))
@@ -378,7 +376,7 @@
"Puts are not allowed on secondary indices. Try adding to
the primary."
(declare (ignore value key)
- (ignorable bt))
+ (ignorable bt))
(error "Puts are forbidden on secondary indices. Try adding to the primary."))
(defgeneric get-primary-key (key bt)
--- /project/elephant/cvsroot/elephant/src/controller.lisp 2006/01/24 15:42:30 1.14
+++ /project/elephant/cvsroot/elephant/src/controller.lisp 2006/01/26 04:03:44 1.14.2.1
@@ -74,6 +74,7 @@
:accessor controller-path
:initarg :path)
(root :reader controller-root)
+ (class-root :reader controller-class-root)
(db :type (or null pointer-void) :accessor controller-db :initform '())
(environment :type (or null pointer-void)
:accessor controller-environment)
@@ -98,7 +99,7 @@
creation, counters, locks, the root (for garbage collection,)
et cetera."))
-;; Without somemore sophistication, these functions
+;; Without some more sophistication, these functions
;; need to be defined here, so that they will be available for testing
;; even if you do not use the strategy in question...
(defun bdb-store-spec-p (path)
@@ -338,11 +339,16 @@
(let ((root (make-instance 'bdb-btree :from-oid -1 :sc sc)))
(setf (slot-value sc 'root) root))
+
+ (setf (slot-value sc 'class-root)
+ (make-instance 'bdb-btree :from-oid -2 :sc sc))
+
sc)))
(defmethod close-controller ((sc bdb-store-controller))
(when (slot-value sc 'root)
;; no root
+ (setf (slot-value sc 'class-root) nil)
(setf (slot-value sc 'root) nil)
;; clean instance cache
(setf (instance-cache sc) (make-cache-table :test 'eql))
--- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/24 15:42:30 1.10
+++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/26 04:03:44 1.10.2.1
@@ -87,11 +87,14 @@
to user-defined classes and collections.)"))
(defclass persistent-metaclass (standard-class)
- ((%persistent-slots :accessor %persistent-slots))
+ ((%persistent-slots :accessor %persistent-slots)
+ (%indexed-slots :accessor %indexed-slots)
+ (%instance-index :accessor %instance-index))
(:documentation
"Metaclass for persistent classes. Use this metaclass to
define persistent classes. All slots are persistent by
-default; use the :transient flag otherwise."))
+default; use the :transient flag otherwise. Slots can also
+be indexed for by-value retrieval"))
(defmethod persistent-slots ((class persistent-metaclass))
(if (slot-boundp class '%persistent-slots)
@@ -113,6 +116,26 @@
nil)
)))
+(defmethod %indexed-p ((class persistent-metaclass))
+ (and (slot-boundp class '%indexed-slots)
+ (car (%indexed-slots class))))
+
+(defmethod indexed-slots ((class persistent-metaclass))
+ (car (%indexed-slots class)))
+
+(defmethod indexed-slots ((class standard-class))
+ nil)
+
+(defmethod old-indexed-slots ((class persistent-metaclass))
+ (cdr (%indexed-slots class)))
+
+(defmethod update-indexed-slots ((class persistent-metaclass) new-slot-list)
+ (setf (%indexed-slots class) (cons new-slot-list
+ (if (slot-boundp class '%indexed-slots)
+ (car (%indexed-slots class))
+ nil))))
+
+
(defclass persistent-slot-definition (standard-slot-definition)
())
@@ -131,6 +154,16 @@
(defclass transient-effective-slot-definition (standard-effective-slot-definition transient-slot-definition)
())
+
+(defclass indexed-slot-definition (persistent-slot-definition)
+ ((indexed :initform t :initarg :indexed :allocation :class)))
+
+(defclass indexed-direct-slot-definition (persistent-direct-slot-definition indexed-slot-definition)
+ ())
+
+(defclass indexed-effective-slot-definition (persistent-effective-slot-definition indexed-slot-definition)
+ ())
+
(defgeneric transient (slot))
(defmethod transient ((slot standard-direct-slot-definition))
@@ -139,6 +172,14 @@
(defmethod transient ((slot persistent-direct-slot-definition))
nil)
+(defgeneric indexed (slot))
+
+(defmethod indexed ((slot standard-direct-slot-definition))
+ nil)
+
+(defmethod indexed ((slot indexed-direct-slot-definition))
+ t)
+
#+allegro
(defmethod excl::valid-slot-allocation-list ((class persistent-metaclass))
'(:instance :class :database))
@@ -150,12 +191,18 @@
"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)))
+ (transient-p (getf initargs :transient))
+ (indexed-p (getf initargs :indexed)))
(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"))
+ (indexed-p
+ (find-class 'indexed-direct-slot-definition))
(transient-p
(find-class 'transient-direct-slot-definition))
(t
@@ -183,9 +230,15 @@
(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)))
+ (let ((transient-p (getf initargs :transient))
+ (indexed-p (getf initargs :indexed)))
(when (consp transient-p) (setq transient-p (car transient-p)))
- (cond (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"))
+ (indexed-p
+ (find-class 'indexed-effective-slot-definition))
+ (transient-p
(find-class 'transient-effective-slot-definition))
(t
(find-class 'persistent-effective-slot-definition)))))
@@ -235,11 +288,11 @@
(defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) slot-definitions)
(let ((initargs (call-next-method)))
(if (ensure-transient-chain slot-definitions initargs)
- (append initargs '(:transient t))
- (progn
- (setf (getf initargs :allocation) :database)
- initargs))))
-
+ (setf initargs (append initargs '(:transient t)))
+ (setf (getf initargs :allocation) :database))
+ (if (some #'indexed slot-definitions)
+ (append initargs '(:indexed t))
+ initargs)))
(defmacro persistent-slot-reader (instance name)
`(if (not (bdb-store-spec-p (:dbcn-spc-pst ,instance)))
@@ -323,7 +376,7 @@
(defun persistent-slot-names (class)
(let ((slot-definitions (class-slots class)))
(loop for slot-definition in slot-definitions
- when (equalp (class-of slot-definition) (find-class 'persistent-effective-slot-definition))
+ when (subtypep (type-of slot-definition) 'persistent-effective-slot-definition)
collect (slot-definition-name slot-definition))))
(defun transient-slot-names (class)
@@ -331,3 +384,8 @@
(loop for slot-definition in slot-definitions
unless (persistent-p slot-definition)
collect (slot-definition-name slot-definition))))
+
+(defun indexed-slot-names (class)
+ (loop for slot-definition in (class-slots class)
+ when (subtypep (type-of slot-definition) 'indexed-effective-slot-definition)
+ collect (slot-definition-name slot-definition)))
--- /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2005/12/05 15:27:54 1.16
+++ /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/01/26 04:03:44 1.16.2.1
@@ -124,6 +124,10 @@
(eval-when (:compile-toplevel)
(proclaim '(optimize (ext:inhibit-warnings 3))))
+(eval-when (:compile-toplevel :load-toplevel)
+ (defparameter *c-library-extension*
+ #+macosx "dylib"
+ #-macosx "so" ))
(eval-when (:compile-toplevel :load-toplevel)
@@ -131,11 +135,11 @@
(uffi:load-foreign-library
(if (find-package 'asdf)
(merge-pathnames
- #p"libmemutil.so"
+ (make-pathname :name "libmemutil" :type *c-library-extension*)
(asdf:component-pathname (asdf:find-system 'elephant)))
- (format nil "~A/~A" *elephant-lib-path* "libmemutil.so"))
+ (format nil "~A/~A.~A" *elephant-lib-path* "libmemutil" *c-library-extension*))
:module "libmemutil")
- (error "Couldn't load libmemutil.so!"))
+ (error "Couldn't load libmemutil.~A!" *c-library-extension*))
;; fini on user editable part
@@ -509,7 +513,8 @@
"Return the number of bytes of the internal representation
of a string."
#+(and allegro ics)
- `(let ((l (length ,s))) (+ l l))
+ ;; old: `(let ((l (length ,s))) (+ l l))
+ `(excl:native-string-sizeof ,s :external-format :unicode)
#+(or (and sbcl sb-unicode) lispworks)
`(etypecase ,s
(base-string (length ,s))
@@ -521,7 +526,7 @@
;; memcpy is faster than looping! For Lispworks this causes
;; a string to array conversion, but I don't know how to do
;; any better (fli:replace-foreign-array is promising?)
-#-(or cmu sbcl scl openmcl)
+#-(or cmu sbcl scl openmcl allegro)
(def-function ("copy_buf" copy-str-to-buf)
((dest array-or-pointer-char)
(dest-offset :int)
@@ -566,6 +571,18 @@
(ccl::%copy-ivector-to-ptr ivector (+ disp src-offset)
dest dest-offset length)))
+#+allegro
+(defun copy-str-to-buf (dest dest-offset src src-offset length)
+ "Use build-in unicode handling and copying facilities.
+ NOTE: We need to validate the speed of this vs. default."
+ (declare (optimize (speed 3) (safety 0))
+ (type string src)
+ (type array-or-pointer-char dest)
+ (type fixnum length src-offset dest-offset)
+ (dynamic-extent src dest length))
+ (excl:string-to-native (subseq src src-offset) :address (offset-char-pointer dest dest-offset)
+ :external-format :unicode))
+
;; Lisp version, for kicks. this assumes 8-bit chars!
#+(not (or cmu sbcl scl allegro openmcl lispworks))
(defun copy-str-to-buf (dest dest-offset src src-offset length)
@@ -752,7 +769,10 @@
(resize-buffer-stream bs needed))
;; I wonder if the basic problem here is that we are using this
;; routine instead of something like "copy-ub8-from-system-area"?
+ #-allegro
(copy-str-to-buf buf size s 0 str-bytes)
+ #+allegro
+ (excl:string-to-native s :address (offset-char-pointer buf size) :external-format :unicode)
(setf size needed)
nil)))
@@ -880,7 +900,7 @@
;; wide!!!
#+(and allegro ics)
(excl:native-to-string
- (offset-char-pointer (buffer-stream-buffer bs) position)
+ (offset-char-pointer (buffer-stream-buffer bs) position)
:length byte-length
:external-format :unicode)
#+lispworks
More information about the Elephant-cvs
mailing list