- elephant-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[elephant-cvs] CVS update: elephant/src/controller.lisp
by blee＠common-lisp.net 04 Sep '04

04 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv14824/src Modified Files: controller.lisp Log Message: incorporated Rafal Strzalinski's fix (don't close environments / db's twice) Date: Sat Sep 4 10:28:45 2004 Author: blee Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.8 elephant/src/controller.lisp:1.9 --- elephant/src/controller.lisp:1.8 Sat Sep 4 10:16:55 2004 +++ elephant/src/controller.lisp Sat Sep 4 10:28:44 2004 @@ -146,16 +146,17 @@ (defmethod close-controller ((sc store-controller)) "Close the db handles and environment. Tries to wipe out references to the db handles." - ; no root - (setf (slot-value sc 'root) nil) - ; clean instance cache - (setf (instance-cache sc) (make-cache-table :test 'eql)) - ; close environment - (db-close (controller-db sc)) - (setf (controller-db sc) nil) - (db-env-close (controller-environment sc)) - (setf (controller-environment sc) nil) - nil) + (when (slot-value sc 'root) + ;; no root + (setf (slot-value sc 'root) nil) + ;; clean instance cache + (setf (instance-cache sc) (make-cache-table :test 'eql)) + ;; close environment + (db-close (controller-db sc)) + (setf (controller-db sc) nil) + (db-env-close (controller-environment sc)) + (setf (controller-environment sc) nil) + nil)) (defmacro with-open-controller ((&optional (sc '*store-controller*)) &body body)

1 0

[elephant-cvs] CVS update: Directory change: elephant/tests/testdb
by blee＠common-lisp.net 04 Sep '04

04 Sep '04

Update of /project/elephant/cvsroot/elephant/tests/testdb In directory common-lisp.net:/tmp/cvs-serv13030/tests/testdb Log Message: Directory /project/elephant/cvsroot/elephant/tests/testdb added to the repository Date: Sat Sep 4 10:25:18 2004 Author: blee New directory elephant/tests/testdb added

1 0

[elephant-cvs] CVS update: elephant/tests/testserializer.lisp
by blee＠common-lisp.net 04 Sep '04

04 Sep '04

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv12983/tests Modified Files: testserializer.lisp Log Message: made into RT tests, added a bunch Date: Sat Sep 4 10:25:08 2004 Author: blee Index: elephant/tests/testserializer.lisp diff -u elephant/tests/testserializer.lisp:1.2 elephant/tests/testserializer.lisp:1.3 --- elephant/tests/testserializer.lisp:1.2 Thu Sep 2 09:32:16 2004 +++ elephant/tests/testserializer.lisp Sat Sep 4 10:25:07 2004 @@ -1,27 +1,367 @@ -(in-package "ELE") +(in-package :ele-tests) +(import 'ele::*out-buf*) +(import 'ele::serialize) +(import 'ele::deserialize) +(import 'ele::buffer-stream-buffer) -(defun test (var) +(defun in-out-value (var) (serialize var *out-buf*) (deserialize (buffer-stream-buffer *out-buf*))) -(= 10000000000 (test 10000000000)) +(defun in-out-eq (var) + (serialize var *out-buf*) + (eq var (deserialize (buffer-stream-buffer *out-buf*)))) + +(defun in-out-equal (var) + (serialize var *out-buf*) + (equal var (deserialize (buffer-stream-buffer *out-buf*)))) + +(defun in-out-equalp (var) + (serialize var *out-buf*) + (equalp var (deserialize (buffer-stream-buffer *out-buf*)))) + +(deftest fixnums + (values + (in-out-equal 0) + (in-out-equal -1) + (in-out-equal 1) + (in-out-equal most-positive-fixnum) + (in-out-equal most-negative-fixnum)) + t t t t t) + +(deftest fixnum-type-1 + (values + (typep (in-out-value 0) 'fixnum) + (typep (in-out-value 1) 'fixnum) + (typep (in-out-value -1) 'fixnum) + (typep (in-out-value most-positive-fixnum) 'fixnum) + (typep (in-out-value most-negative-fixnum) 'fixnum)) + t t t t t) + +(deftest bignums + (values + (in-out-equal 10000000000) + (in-out-equal -10000000000) + (loop for i from 0 to 2000 + always (in-out-equal (expt 2 i))) + (loop for i from 0 to 2000 + always (in-out-equal (- (expt 2 i)))) + (loop for i from 0 to 2000 + always (in-out-equal (- (expt 2 i) 1))) + (loop for i from 0 to 2000 + always (in-out-equal (- 1 (expt 2 i)))) + (loop for i from 0 to 2000 + always (in-out-equal (expt 3 i))) + (loop for i from 0 to 2000 + always (in-out-equal (- (expt 3 i))))) + t t t t t t t t) + +(deftest floats + (values + (in-out-equal 0.0) + (in-out-equal -0.0) + (in-out-equal 0.0d0) + (in-out-equal -0.0d0) + (in-out-equal -0.0d0) + (in-out-equal double-float-epsilon) + (in-out-equal long-float-epsilon) + (in-out-equal short-float-epsilon) + (in-out-equal single-float-epsilon) + (in-out-equal double-float-negative-epsilon) + (in-out-equal long-float-negative-epsilon) + (in-out-equal short-float-negative-epsilon) + (in-out-equal single-float-negative-epsilon) + (in-out-equal least-negative-double-float) + (in-out-equal least-negative-long-float) + (in-out-equal least-negative-short-float) + (in-out-equal least-negative-single-float) + (in-out-equal least-positive-double-float) + (in-out-equal least-positive-long-float) + (in-out-equal least-positive-short-float) + (in-out-equal least-positive-single-float) + (in-out-equal most-negative-double-float) + (in-out-equal most-negative-long-float) + (in-out-equal most-negative-short-float) + (in-out-equal most-negative-single-float) + (in-out-equal most-positive-double-float) + (in-out-equal most-positive-long-float) + (in-out-equal most-positive-short-float) + (in-out-equal most-positive-single-float)) + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t) + +(deftest rationals + (values + (in-out-equal 1/2) + (in-out-equal -1/2) + (in-out-equal (/ 1 most-positive-fixnum)) + (in-out-equal (/ 1 most-negative-fixnum)) + (in-out-equal (/ most-positive-fixnum most-negative-fixnum)) + (in-out-equal (/ (expt 2 200) (expt 3 300))) + (in-out-equal (/ (expt 2 200) (- (expt 3 300))))) + t t t t t t t) + +(deftest strings + (values + (in-out-equal "") + (in-out-equal "this is a test") + (in-out-equal (make-string 400 :initial-element (code-char 254)))) + t t t) + +(defun in-out-uninterned-equal (var) + (serialize var *out-buf*) + (let ((new (deserialize (buffer-stream-buffer *out-buf*)))) + (and (equal (symbol-name new) (symbol-name var)) + (equal (symbol-package new) (symbol-package var))))) + +(deftest symbols + (values + (in-out-equal nil) + (in-out-equal T) + (in-out-equal 'foobarbazquux) + (in-out-equal 'ele::next-oid) + (in-out-equal :a-keyword-symbol) + (in-out-uninterned-equal '#:foozle) + (in-out-uninterned-equal (make-symbol "a wha wah ba ba")) + (in-out-uninterned-equal (make-symbol ""))) + t t t t t t t t) + +(deftest chars + (loop for i from 0 below char-code-limit + unless (in-out-equal (code-char i)) + do (return i) + finally (return T)) + t) + +(deftest pathnames + ;;; Given how implementation-specific make-pathname is, + ;;; i don't know how to put more portable tests here! + (values + (in-out-equal #p"/usr/local/share/common-lisp/elephant")) + t) + +(deftest conses + (values + (in-out-equal (cons t 100000)) + (in-out-equal (list 1 'a "this is a test" 'c 10000 nil 1000 nil)) + (in-out-equal (cons (cons (cons t nil) (cons nil t)) (cons 1 (cons t nil)))) + ) + t t t) + +(deftest hash-tables-1 + (let* ((ht (make-hash-table :test 'equalp :size 333 :rehash-size 1.2 + :rehash-threshold 0.8)) + (size (hash-table-size ht)) + (rehash-size (hash-table-rehash-size ht)) + (rehash-threshold (hash-table-rehash-threshold ht)) + (out (in-out-value ht))) + (values + (eq (hash-table-test out) 'equalp) + (= (hash-table-size ht) size) + (= (hash-table-rehash-size ht) rehash-size) + (= (hash-table-rehash-threshold ht) rehash-threshold) + (eq (hash-table-test (in-out-value (make-hash-table :test 'eq))) 'eq) + (eq (hash-table-test (in-out-value (make-hash-table :test 'eql))) 'eql) + (eq (hash-table-test + (in-out-value (make-hash-table :test 'equal))) 'equal) + (eq (hash-table-test + (in-out-value (make-hash-table :test 'equalp))) 'equalp))) + t t t t t t t t) + +(deftest hash-tables-2 + (let ((ht (make-hash-table :test 'equalp))) + (setf (gethash (cons nil nil) ht) "one") + (setf (gethash 2 ht) 2.0d0) + (setf (gethash 'symbolsymbol ht) "three") + (let ((out (in-out-value ht))) + (values + (string= (gethash (cons nil nil) ht) "one") + (= (gethash 2 ht) 2.0d0) + (string= (gethash 'symbolsymbol ht) "three")))) + t t t) + +(defun type= (t1 t2) + (and (subtypep t1 t2) (subtypep t2 t1))) + +(deftest arrays-1 + (values + (array-has-fill-pointer-p + (in-out-value (make-array 200 :fill-pointer t))) + (not (array-has-fill-pointer-p + (in-out-value (make-array 200 :fill-pointer nil)))) + (type= (upgraded-array-element-type '(unsigned-byte 20)) + (array-element-type + (in-out-value (make-array '(3 4 5) + :element-type + '(unsigned-byte 20))))) + (type= (upgraded-array-element-type 'fixnum) + (array-element-type + (in-out-value (make-array '(3 4 5) + :element-type + 'fixnum)))) + ) + t t t t) + +(deftest arrays-2 + (let ((arr (make-array '(3 4 5))) + (vec (make-array 100 :adjustable t :fill-pointer t)) + (svec (make-array 100 :adjustable nil :fill-pointer nil))) + (setf (aref arr 0 0 0) 'symb) + (setf (aref arr 1 2 3) 123132) + (setf (aref arr 2 3 4) "this is a longish string") + (vector-push-extend 123456789101112 vec) + (vector-push-extend "mr t" vec) + (vector-push-extend 'symbolic vec) + (loop for i from 0 to 99 + do + (setf (svref svec i) (expt 2 i))) + (values + (in-out-equalp arr) + (in-out-equalp vec) + (in-out-equalp svec) + (typep (in-out-value svec) 'simple-vector))) + t t t t) + + +;; depends on ele::slots-and-values +(defun deep-equalp (thing another) + (let ((seen (make-hash-table :test 'eq))) + (labels + ((%deep-equalp (s1 s2) + (when (type= (type-of s1) (type-of s2)) + (if (gethash s1 seen) t + (progn + (setf (gethash s1 seen) t) + (typecase s1 + (cons + (and (%deep-equalp (car s1) (car s2)) + (%deep-equalp (cdr s1) (cdr s2)))) + (array + (loop for i from 0 below (array-total-size s1) + always (%deep-equalp + (row-major-aref s1 i) + (row-major-aref s2 i)))) + (hash-table + (when (= (hash-table-count s1) + (hash-table-count s2)) + (loop for key being the hash-key of s1 + using (hash-value value) + always (%deep-equalp value + (gethash key s2))))) + (standard-object + (%deep-equalp (ele::slots-and-values s1) + (ele::slots-and-values s2))) + (t (equalp s1 s2)))))))) + (%deep-equalp thing another)))) + +(defclass foo () + ((slot1 :initarg :slot1) + (slot2 :initarg :slot2))) + +(defclass bar () + ((slot1 :initarg :slot1) + (slot2 :initarg :slot2))) + +(deftest test-deep-equalp + (let ((c1 (cons nil nil)) + (c2 (cons nil nil)) + (l1 (make-list 100)) + (h (make-hash-table :test 'equal)) + (g (make-array '(2 3 4))) + (f (make-instance 'foo)) + (b (make-instance 'bar))) + (setf (car c1) c1) + (setf (cdr c1) c1) + (setf (car c2) c1) + (setf (cdr c2) c2) + (setf (cdr (last l1)) l1) + (setf (gethash "quux" h) l1) + (setf (gethash "bar" h) c2) + (setf (aref g 1 1 1) g) + (setf (aref g 0 0 1) h) + (setf (gethash "foo" h) g) + (setf (slot-value f 'slot1) b) + (setf (slot-value f 'slot2) f) + (setf (slot-value b 'slot1) h) + (setf (slot-value b 'slot2) f) + (values + (deep-equalp c1 c1) + (deep-equalp c2 c2) + (deep-equalp l1 l1) + (deep-equalp h h) + (deep-equalp g g) + (deep-equalp f f) + (deep-equalp b b))) + t t t t t t t) + +(defun in-out-deep-equalp (var) + (serialize var *out-buf*) + (deep-equalp var (deserialize (buffer-stream-buffer *out-buf*)))) + +(deftest objects + (values + (in-out-deep-equalp (make-instance 'foo)) + (in-out-deep-equalp (make-instance 'bar :slot1 + (make-instance 'foo + :slot2 "foo bar")))) + t t) + +(deftest circular + (let ((c1 (cons nil nil)) + (c2 (cons nil nil)) + (l1 (make-list 100)) + (h (make-hash-table :test 'equal)) + (g (make-array '(2 3 4))) + (f (make-instance 'foo)) + (b (make-instance 'bar))) + (setf (car c1) c1) + (setf (cdr c1) c1) + (setf (car c2) c1) + (setf (cdr c2) c2) + (setf (cdr (last l1)) l1) + (setf (gethash "quux" h) l1) + (setf (gethash "bar" h) c2) + (setf (aref g 1 1 1) g) + (setf (aref g 0 0 1) h) + (setf (gethash "foo" h) g) + (setf (slot-value f 'slot1) b) + (setf (slot-value f 'slot2) f) + (setf (slot-value b 'slot1) h) + (setf (slot-value b 'slot2) f) + (values + (in-out-deep-equalp c1) + (in-out-deep-equalp c2) + (in-out-deep-equalp l1) + (in-out-deep-equalp h) + (in-out-deep-equalp g) + (in-out-deep-equalp f) + (in-out-deep-equalp b))) + t t t t t t t) -(equalp (cons 10000000000 10000000000) - (test (cons 10000000000 10000000000))) +(defclass pfoo () + ((slot1 :initarg :slot1 :accessor slot1)) + (:metaclass persistent-metaclass)) -(setq f (cons nil nil)) -(prog1 t (setf (car f) f)) -(prog1 t (setq g (test f))) -(eq g (car g)) -(eq nil (cdr g)) - -(setq h (make-hash-table :test 'eql)) -(prog1 t (setf (gethash 10000000000 h) f)) -(setq h2 (test h)) -(= 1 (hash-table-count h2)) -(prog1 t (setq g (gethash 10000000000 h2))) -(eq g (car g)) -(eq nil (cdr g)) +(defclass pbar (pfoo) + ((slot2 :initarg :slot2 :accessor slot2)) + (:metaclass persistent-metaclass)) -;(defclass foo () -; ((slot1 :type \ No newline at end of file +(deftest persistent + (let ((f1 (make-instance 'pfoo)) + (f2 (make-instance 'pfoo :slot1 "this is a string")) + (b1 (make-instance 'pbar :slot2 "another string")) + (b2 (make-instance 'pbar)) + (h (make-instance 'btree))) + (values + (in-out-eq f1) + (in-out-eq f2) + (in-out-eq b1) + (in-out-eq b2) + (in-out-eq h) + (signals-condition + (slot1 f1)) + (progn (setf (slot1 f1) f1) + (eq f1 (slot1 f1))) + (progn (setf (get-value f2 h) f2) + (eq (get-value f2 h) f2)))) + t t t t t t t t) + \ No newline at end of file

1 0

[elephant-cvs] CVS update: elephant/tests/elephant-tests.lisp
by blee＠common-lisp.net 04 Sep '04

04 Sep '04

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv12903/tests Added Files: elephant-tests.lisp Log Message: initial version Date: Sat Sep 4 10:24:30 2004 Author: blee

1 0

[elephant-cvs] CVS update: elephant/tests/mop-tests.lisp
by blee＠common-lisp.net 04 Sep '04

04 Sep '04

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv12882/tests Modified Files: mop-tests.lisp Log Message: made into RT tests, added a bunch Date: Sat Sep 4 10:24:23 2004 Author: blee Index: elephant/tests/mop-tests.lisp diff -u elephant/tests/mop-tests.lisp:1.2 elephant/tests/mop-tests.lisp:1.3 --- elephant/tests/mop-tests.lisp:1.2 Thu Sep 2 09:30:12 2004 +++ elephant/tests/mop-tests.lisp Sat Sep 4 10:24:23 2004 @@ -1,93 +1,175 @@ -(use-package "ELE") +(in-package :ele-tests) +#+cmu +(import 'pcl::finalize-inheritance) +#+sbcl +(import 'sb-mop::finalize-inheritance) +#+allegro +(import 'clos::finalize-inheritance) +#+openmcl +(import 'ccl::finalize-inheritance) + +(deftest non-transient-class-slot-1 + (signals-condition + ;; This should fail (principle of least surprise) + (defclass non-transient-class-slot-1 () + ((slot3 :accessor slot3 :allocation :class)) + (:metaclass persistent-metaclass))) + t) + +(deftest non-transient-class-slot-2 + (signals-condition + ;; as should this + (defclass non-transient-class-slot-2 () + ((slot3 :accessor slot3 :allocation :class :transient nil)) + (:metaclass persistent-metaclass))) + t) + +(deftest transient-class-slot + (finishes + ;; but this should be fine + (defclass transient-class-slot () + ((slot3 :accessor slot3 :allocation :class :transient t)) + (:metaclass persistent-metaclass))) + t) + +(deftest class-definers + (finishes + (defclass p-class () + ((slot1 :accessor slot1) + (slot2 :accessor slot2 :transient t) + (slot3 :accessor slot3 :allocation :class :transient t)) + (:metaclass persistent-metaclass)) + (defclass nonp-class () + ((slot1 :accessor slot1) + (slot2 :accessor slot2) + (slot3 :accessor slot3 :allocation :class))) + (defclass minus-p-class () + ((slot1 :accessor slot1 :transient t) + (slot2 :accessor slot2) + (slot3 :accessor slot3)) + (:metaclass persistent-metaclass)) + (defclass switch-transient () + ((slot1 :accessor slot1 :transient t) + (slot2 :accessor slot2)) + (:metaclass persistent-metaclass)) + (defclass make-persistent () + ((slot2 :accessor slot2)) + (:metaclass persistent-metaclass))) + t) + +(deftest bad-inheritence + (signals-condition + ;; This should fail + (defclass bad-inheritence (p-class) ())) + t) + +(deftest mixes + (finishes + ;; but this should be fine + (defclass mix-1 (p-class nonp-class) () + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'mix-1)) + ;; This should be ok + (defclass mix-2 (p-class minus-p-class) () + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'mix-2)) + ;; This should be ok + (defclass mix-3 (minus-p-class p-class) () + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'mix-3)) + ;; This should be ok + (defclass mix-4 (switch-transient p-class) () + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'mix-4)) + ;; This should be ok + (defclass mix-5 (p-class switch-transient) () + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'mix-5)) + ;; should work + (defclass mix-6 (make-persistent p-class) () + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'mix-6))) + t) + +(deftest mixes-right-slots + (values + (typep (find-slot-def 'mix-1 'slot1) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-1 'slot2) 'ele::transient-slot-definition) + (typep (find-slot-def 'mix-1 'slot3) 'ele::transient-slot-definition) + (typep (find-slot-def 'mix-2 'slot1) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-2 'slot2) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-2 'slot3) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-3 'slot1) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-3 'slot2) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-3 'slot3) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-4 'slot1) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-4 'slot2) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-4 'slot3) 'ele::transient-slot-definition) + (typep (find-slot-def 'mix-5 'slot1) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-5 'slot2) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-5 'slot3) 'ele::transient-slot-definition) + (typep (find-slot-def 'mix-6 'slot1) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-6 'slot2) 'ele::persistent-slot-definition) + (typep (find-slot-def 'mix-6 'slot3) 'ele::transient-slot-definition)) + t t t t t t t t t t t t t t t t t t) + +(deftest inherit + (finishes + (defclass make-persistent2 (p-class) + ((slot2 :accessor slot2) + (slot4 :accessor slot4 :transient t)) + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'make-persistent2))) + t) + +(deftest inherit-right-slots + (values + (typep (find-slot-def 'make-persistent2 'slot1) + 'ele::persistent-slot-definition) + (typep (find-slot-def 'make-persistent2 'slot2) + 'ele::persistent-slot-definition) + (typep (find-slot-def 'make-persistent2 'slot3) + 'ele::transient-slot-definition) + (typep (find-slot-def 'make-persistent2 'slot4) + 'ele::transient-slot-definition)) + t t t t) + +(deftest initform-classes + (finishes + (defclass p-initform-test () + ((slot1 :initform 10)) + (:metaclass persistent-metaclass)) + (defclass p-initform-test-2 () + ((slot1 :initarg :slot1 :initform 10)) + (:metaclass persistent-metaclass)) + ) + t) + +(deftest initform-test + (slot-value (make-instance 'p-initform-test) 'slot1) + 10) + +(deftest initarg-test + (values + (slot-value (make-instance 'p-initform-test-2) 'slot1) + (slot-value (make-instance 'p-initform-test-2 :slot1 20) 'slot1)) + 10 20) + +(deftest no-eval-initform + (finishes + (defclass no-eval-initform () + ((slot1 :initarg :slot1 :initform (error "Shouldn't be called"))) + (:metaclass persistent-metaclass)) + (make-instance 'no-eval-initform :slot1 "something") + t) + t) + +(deftest redefclass + (progn + (defclass redef () () (:metaclass persistent-metaclass)) + (defclass redef () () (:metaclass persistent-metaclass)) + (values (subtypep 'redef 'persistent-object))) + t) -;; This should fail (principle of least surprise) -(defclass non-transient-class-slot-1 () - ((slot3 :accessor slot3 :allocation :class)) - (:metaclass persistent-metaclass)) - -;; as should this -(defclass non-transient-class-slot-2 () - ((slot3 :accessor slot3 :allocation :class :transient nil)) - (:metaclass persistent-metaclass)) - -;; but this should be fine -(defclass non-transient-class-slot-3 () - ((slot3 :accessor slot3 :allocation :class :transient t)) - (:metaclass persistent-metaclass)) - - -(defclass p-class () - ((slot1 :accessor slot1) - (slot2 :accessor slot2 :transient t) - (slot3 :accessor slot3 :allocation :class :transient t)) - (:metaclass persistent-metaclass)) - -(defclass nonp-class () - ((slot1 :accessor slot1) - (slot2 :accessor slot2) - (slot3 :accessor slot3 :allocation :class))) - -(defclass minus-p-class () - ((slot1 :accessor slot1 :transient t) - (slot2 :accessor slot2) - (slot3 :accessor slot3)) - (:metaclass persistent-metaclass)) - -;; This should fail -(defclass bad-inheritence (p-class) ()) - -;; but this should be fine -(defclass mix-1 (p-class nonp-class) () - (:metaclass persistent-metaclass)) - - -;; This should be ok -(defclass mix-2 (p-class minus-p-class) () - (:metaclass persistent-metaclass)) - -;; This should be ok -(defclass mix-3 (minus-p-class p-class) () - (:metaclass persistent-metaclass)) - -(defclass switch-transient () - ((slot1 :accessor slot1 :transient t) - (slot2 :accessor slot2)) - (:metaclass persistent-metaclass)) - -;; This should be ok -(defclass mix-4 (switch-transient p-class) () - (:metaclass persistent-metaclass)) - -;; This should be ok -(defclass mix-5 (p-class switch-transient) () - (:metaclass persistent-metaclass)) - -(defclass make-persistent () - ((slot2 :accessor slot2)) - (:metaclass persistent-metaclass)) - -;; should work -(defclass mix-6 (make-persistent p-class) () - (:metaclass persistent-metaclass)) - -(defclass make-persistent2 (p-class) - ((slot2 :accessor slot2) - (slot4 :accessor slot4 :transient t)) - (:metaclass persistent-metaclass)) - - -(defclass initform-test () - ((slot1 :initform 10))) - -(defclass p-initform-test () - ((slot1 :initform 10)) - (:metaclass persistent-metaclass)) - -(defclass p-initform-test-2 () - ((slot1 :initarg :slot1 :initform 10)) - (:metaclass persistent-metaclass)) - -(setq pf (make-instance 'p-initform-test-2)) -(slot-value pf 'slot1) -(setq pf (make-instance 'p-initform-test-2 :slot1 20)) -(slot-value pf 'slot1) +(with-open-store (*testdb-path*) + (do-tests))

1 0

[elephant-cvs] CVS update: elephant/src/utils.lisp
by blee＠common-lisp.net 04 Sep '04

04 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv12847/src Modified Files: utils.lisp Log Message: fixed macro arg (dynamic, not lexical) / typo fixed finalizer in allegro (don't close over the value or it will never be collected) Date: Sat Sep 4 10:23:30 2004 Author: blee Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.4 elephant/src/utils.lisp:1.5 --- elephant/src/utils.lisp:1.4 Thu Sep 2 16:47:31 2004 +++ elephant/src/utils.lisp Sat Sep 4 10:23:30 2004 @@ -121,8 +121,8 @@ ;; Good defaults for elephant (defmacro with-transaction ((&key transaction - (environment (controller-environment - *store-controller*)) + (environment '(controller-environment + *store-controller*)) (parent '*current-transaction*) dirty-read txn-nosync txn-nowait txn-sync @@ -135,7 +135,7 @@ :txn-nosync ,txn-nosync :txn-nowait ,txn-nowait :txn-sync ,txn-sync - :retries ,100) + :retries ,retries) ,@body)) @@ -165,15 +165,22 @@ (gethash key cache) ) +(defun make-finalizer (key cache) + #+(or cmu sbcl) + (lambda () (remhash key cache)) + #+allegro + (lambda (obj) (declare (ignore obj)) (remhash key cache)) + ) + (defun setf-cache (key cache value) #+(or cmu sbcl) (let ((w (make-weak-pointer value))) - (finalize value #'(lambda () (remhash key cache))) + (finalize value (make-finalizer key cache)) (setf (gethash key cache) w) value) #+allegro (progn - (excl:schedule-finalization value #'(lambda () (remhash key cache))) + (excl:schedule-finalization value (make-finalizer key cache)) (setf (gethash key cache) value)) #-(or cmu sbcl scl allegro) (setf (gethash key cache) value)

1 0

[elephant-cvs] CVS update: elephant/src/serializer.lisp
by blee＠common-lisp.net 04 Sep '04

04 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv12752/src Modified Files: serializer.lisp Log Message: +base-char+ => +char+ handle uninterned symbols / symbols in another package optimizations / fixes for bignums fill-pointers circularity fixes (big typo!) automatic numeric array definition types Date: Sat Sep 4 10:20:37 2004 Author: blee Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.6 elephant/src/serializer.lisp:1.7 --- elephant/src/serializer.lisp:1.6 Sun Aug 29 22:40:49 2004 +++ elephant/src/serializer.lisp Sat Sep 4 10:20:37 2004 @@ -58,7 +58,7 @@ (defconstant +persistent+ (char-code #\P)) (defconstant +single-float+ (char-code #\F)) (defconstant +double-float+ (char-code #\D)) -(defconstant +base-char+ (char-code #\c)) +(defconstant +char+ (char-code #\c)) (defconstant +pathname+ (char-code #\p)) (defconstant +positive-bignum+ (char-code #\B)) (defconstant +negative-bignum+ (char-code #\b)) @@ -66,6 +66,7 @@ (defconstant +cons+ (char-code #\C)) (defconstant +hash-table+ (char-code #\H)) (defconstant +object+ (char-code #\O)) + (defconstant +array+ (char-code #\A)) (defconstant +fill-pointer-p+ #x40) @@ -90,7 +91,11 @@ (declare (type string s) (dynamic-extent s)) (buffer-write-byte +symbol+ bs) (buffer-write-int (byte-length s) bs) - (buffer-write-string s bs))) + (buffer-write-string s bs) + (let ((package (symbol-package frob))) + (if package + (%serialize (package-name package)) + (%serialize nil))))) (string (buffer-write-byte +string+ bs) (buffer-write-int (byte-length frob) bs) @@ -107,9 +112,9 @@ (buffer-write-byte +double-float+ bs) (buffer-write-double frob bs)) (character - (buffer-write-byte +base-char+ bs) + (buffer-write-byte +char+ bs) ;; might be wide! - (buffer-write-int (char-code frob) bs)) + (buffer-write-uint (char-code frob) bs)) (pathname (let ((s (namestring frob))) (declare (type string s) (dynamic-extent s)) @@ -125,14 +130,15 @@ (buffer-write-byte +negative-bignum+ bs) (buffer-write-byte +positive-bignum+ bs)) (buffer-write-int needed bs) - (loop for i fixnum from 0 to word-size - for byte-spec = (int-byte-spec i) + (loop for i fixnum from 0 below word-size ;; this ldb is consing on CMUCL! ;; there is an OpenMCL function which should work ;; and non-cons - for the-uint of-type (unsigned-byte 32) = (ldb byte-spec num) - do - (buffer-write-uint the-uint bs)))) + do + #+(or cmu sbcl) + (buffer-write-uint (%bignum-ref num i) bs) + #+(or allegro lispworks openmcl) + (buffer-write-uint (ldb (int-byte-spec i) num) bs)))) (rational (buffer-write-byte +rational+ bs) (%serialize (numerator frob)) @@ -194,6 +200,8 @@ (loop for i fixnum from 0 below rank do (buffer-write-int (array-dimension frob i) bs))) + (when (array-has-fill-pointer-p frob) + (buffer-write-int (fill-pointer frob) bs)) (loop for i fixnum from 0 below (array-total-size frob) do (%serialize (row-major-aref frob i))))))) @@ -233,7 +241,11 @@ (buffer-read-fixnum bs)) ((= tag +nil+) nil) ((= tag +symbol+) - (intern (or (buffer-read-string bs (buffer-read-fixnum bs)) ""))) + (let ((name (buffer-read-string bs (buffer-read-fixnum bs))) + (maybe-package-name (%deserialize bs))) + (if maybe-package-name + (intern name (find-package maybe-package-name)) + (make-symbol name)))) ((= tag +string+) (buffer-read-string bs (buffer-read-fixnum bs))) ((= tag +persistent+) @@ -244,8 +256,8 @@ (buffer-read-float bs)) ((= tag +double-float+) (buffer-read-double bs)) - ((= tag +base-char+) - (code-char (buffer-read-byte bs))) + ((= tag +char+) + (code-char (buffer-read-uint bs))) ((= tag +pathname+) (parse-namestring (or (buffer-read-string bs (buffer-read-fixnum bs)) ""))) @@ -273,6 +285,7 @@ :rehash-size (%deserialize bs) :rehash-threshold (%deserialize bs)))) + (setf (gethash id *circularity-hash*) h) (loop for i fixnum from 0 below (%deserialize bs) do (setf (gethash (%deserialize bs) h) @@ -283,6 +296,7 @@ (maybe-o (gethash id *circularity-hash*))) (if maybe-o maybe-o (let ((o (make-instance (%deserialize bs)))) + (setf (gethash id *circularity-hash*) o) (loop for i fixnum from 0 below (%deserialize bs) do (setf (slot-value o (%deserialize bs)) @@ -303,6 +317,9 @@ flags)) :adjustable (/= 0 (logand +adjustable-p+ flags))))) + (when (array-has-fill-pointer-p a) + (setf (fill-pointer a) (buffer-read-int bs))) + (setf (gethash id *circularity-hash*) a) (loop for i fixnum from 0 below (array-total-size a) do (setf (row-major-aref a i) (%deserialize bs))) @@ -315,7 +332,7 @@ (type buffer-stream bs) (type fixnum length) (type boolean positive)) - (loop for i from 0 upto (/ length 4) + (loop for i from 0 below (/ length 4) for byte-spec = (int-byte-spec i) with num integer = 0 do @@ -330,22 +347,27 @@ (defvar byte-to-array-type (make-hash-table :test 'equalp)) (setf (gethash 'T array-type-to-byte) #x00) -(setf (gethash 'bit array-type-to-byte) #x01) -(setf (gethash '(unsigned-byte 2) array-type-to-byte) #x02) -(setf (gethash '(unsigned-byte 4) array-type-to-byte) #x03) -(setf (gethash '(unsigned-byte 8) array-type-to-byte) #x04) -(setf (gethash '(unsigned-byte 16) array-type-to-byte) #x05) -(setf (gethash '(unsigned-byte 32) array-type-to-byte) #x06) -(setf (gethash '(unsigned-byte 64) array-type-to-byte) #x07) -(setf (gethash '(signed-byte 8) array-type-to-byte) #x08) -(setf (gethash '(signed-byte 16) array-type-to-byte) #x09) -(setf (gethash '(signed-byte 32) array-type-to-byte) #x0A) -(setf (gethash '(signed-byte 64) array-type-to-byte) #x0B) -(setf (gethash 'character array-type-to-byte) #x0C) -(setf (gethash 'single-float array-type-to-byte) #x0D) -(setf (gethash 'double-float array-type-to-byte) #x0E) -(setf (gethash '(complex single-float) array-type-to-byte) #x0F) -(setf (gethash '(complex double-float) array-type-to-byte) #x10) +(setf (gethash 'base-char array-type-to-byte) #x01) +(setf (gethash 'character array-type-to-byte) #x02) +(setf (gethash 'single-float array-type-to-byte) #x03) +(setf (gethash 'double-float array-type-to-byte) #x04) +(setf (gethash '(complex single-float) array-type-to-byte) #x05) +(setf (gethash '(complex double-float) array-type-to-byte) #x06) +(setf (gethash 'fixnum array-type-to-byte) #x07) +(setf (gethash 'bit array-type-to-byte) #x08) +(let ((counter 8)) + (loop for i from 2 to 65 + for spec = (list 'unsigned-byte i) + for uspec = (upgraded-array-element-type spec) + unless (gethash uspec array-type-to-byte) + do + (setf (gethash uspec array-type-to-byte) (incf counter))) + (loop for i from 2 to 65 + for spec = (list 'signed-byte i) + for uspec = (upgraded-array-element-type spec) + unless (gethash uspec array-type-to-byte) + do + (setf (gethash uspec array-type-to-byte) (incf counter)))) (loop for key being the hash-key of array-type-to-byte using (hash-value value)

1 0

[elephant-cvs] CVS update: elephant/src/elephant.lisp
by blee＠common-lisp.net 04 Sep '04

04 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv12700/src Modified Files: elephant.lisp Log Message: update Date: Sat Sep 4 10:17:24 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.9 elephant/src/elephant.lisp:1.10 --- elephant/src/elephant.lisp:1.9 Thu Sep 2 16:47:53 2004 +++ elephant/src/elephant.lisp Sat Sep 4 10:17:24 2004 @@ -45,7 +45,7 @@ (:use common-lisp sleepycat) (:shadow #:with-transaction) (:export #:*store-controller* #:*current-transaction* #:*auto-commit* - #:open-store #:close-store + #:open-store #:close-store #:with-open-store #:store-controller #:open-controller #:close-controller #:with-open-controller #:controller-path #:controller-environment #:controller-db #:controller-root #:add-to-root #:get-from-root @@ -62,6 +62,7 @@ ) #+cmu (:import-from :pcl + compute-class-precedence-list validate-superclass standard-slot-definition standard-direct-slot-definition @@ -69,6 +70,7 @@ direct-slot-definition-class effective-slot-definition-class slot-definition-name + slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots @@ -91,8 +93,13 @@ (: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 @@ -100,6 +107,7 @@ direct-slot-definition-class effective-slot-definition-class slot-definition-name + slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots @@ -123,8 +131,13 @@ (: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 @@ -132,6 +145,7 @@ direct-slot-definition-class effective-slot-definition-class slot-definition-name + slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots @@ -145,6 +159,7 @@ compute-effective-slot-definition-initargs) #+openmcl (:import-from :ccl + compute-class-precedence-list validate-superclass standard-slot-definition standard-direct-slot-definition @@ -152,6 +167,7 @@ direct-slot-definition-class effective-slot-definition-class slot-definition-name + slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots @@ -173,6 +189,7 @@ %slot-definition-type) #+lispworks (:import-from :clos + compute-class-precedence-list validate-superclass standard-slot-definition standard-direct-slot-definition @@ -180,6 +197,7 @@ direct-slot-definition-class effective-slot-definition-class slot-definition-name + slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots

1 0

[elephant-cvs] CVS update: elephant/src/controller.lisp
by blee＠common-lisp.net 04 Sep '04

04 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv12648/src Modified Files: controller.lisp Log Message: fixed macros Date: Sat Sep 4 10:16:56 2004 Author: blee Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.7 elephant/src/controller.lisp:1.8 --- elephant/src/controller.lisp:1.7 Thu Sep 2 16:42:38 2004 +++ elephant/src/controller.lisp Sat Sep 4 10:16:55 2004 @@ -157,12 +157,13 @@ (setf (controller-environment sc) nil) nil) -(defmacro with-open-controller ((&optional (sc *store-controller*)) +(defmacro with-open-controller ((&optional (sc '*store-controller*)) &body body) `(unwind-protect (progn - (open-controller ,sc) - ,@body) + (let (*store-controller* (open-controller ,sc)) + (declare (special *store-controller*)) + ,@body)) (close-controller ,sc))) (defun open-store (path) @@ -170,4 +171,16 @@ (open-controller *store-controller*)) (defun close-store () - (close-controller *store-controller*)) \ No newline at end of file + (close-controller *store-controller*)) + +(defmacro with-open-store ((path) &body body) + (let ((sc (gensym))) + `(let ((,sc (make-instance 'store-controller :path ,path))) + (unwind-protect + (progn + (let ((*store-controller* ,sc)) + (declare (special *store-controller*)) + (open-controller *store-controller*) + ,@body)) + (close-controller ,sc))))) +

1 0

[elephant-cvs] CVS update: elephant/src/classes.lisp
by blee＠common-lisp.net 04 Sep '04

04 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv12530/src Modified Files: classes.lisp Log Message: initialize-instance obj : forgot to cache instances initialize-instance class => shared-initialize : reinitialize instance fixes shared-initialize obj : transients before persistents Date: Sat Sep 4 10:16:12 2004 Author: blee Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.8 elephant/src/classes.lisp:1.9 --- elephant/src/classes.lisp:1.8 Thu Sep 2 16:41:25 2004 +++ elephant/src/classes.lisp Sat Sep 4 10:16:11 2004 @@ -50,7 +50,8 @@ "Sets the OID." (if (not from-oid) (setf (oid instance) (next-oid *store-controller*)) - (setf (oid instance) from-oid))) + (setf (oid instance) from-oid)) + (cache-instance *store-controller* instance)) (defclass persistent-object (persistent) ((%persistent-slots :transient t)) @@ -58,12 +59,32 @@ classes") (:metaclass persistent-metaclass)) -(defmethod initialize-instance :around ((class persistent-metaclass) &rest args &key direct-superclasses) +#| +(defmethod compute-class-precedence-list :around ((class persistent-metaclass)) + (let ((cpl (call-next-method)) + (persistent-object (find-class 'persistent-object))) + (if (member persistent-object cpl :test #'eq) + cpl + (let ((std-obj (find-class 'standard-object)) + (ccpl (copy-list cpl))) + (loop for c on ccpl + when (eq (cadr c) std-obj) + do + (setf (cdr c) (cons persistent-object + (cons (find-class 'persistent) (cdr c)))) + (return nil)) + ccpl)))) +|# + +(defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) (let* ((persistent-metaclass (find-class 'persistent-metaclass)) + (persistent-object (find-class 'persistent-object)) (not-already-persistent (loop for superclass in direct-superclasses never (eq (class-of superclass) persistent-metaclass)))) - (if not-already-persistent - (apply #'call-next-method class :direct-superclasses (cons (find-class 'persistent-object) direct-superclasses) args) + (if (and (not (eq class persistent-object)) not-already-persistent) + (apply #'call-next-method class slot-names + :direct-superclasses (cons persistent-object + direct-superclasses) args) (call-next-method)))) (defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys) @@ -79,6 +100,8 @@ (persistent-slot-inits (if (eq slot-names t) persistent-slot-names (remove-if-not #'persistent-slot-p slot-names)))) + ;; let the implementation initialize the transient slots + (apply #'call-next-method instance transient-slot-inits initargs) ;; initialize the persistent slots (flet ((initialize-from-initarg (slot-def) (loop for initarg in initargs @@ -96,9 +119,7 @@ (let ((initfun (slot-definition-initfunction slot-def))) (when initfun (setf (slot-value-using-class class instance slot-def) - (funcall initfun)))))) - ;; let the implementation initialize the transient slots - (apply #'call-next-method instance transient-slot-inits initargs))))) + (funcall initfun)))))))))) (defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) (declare (ignore class))

1 0