September 2004 - elephant-cvs@common-lisp.net

[elephant-cvs] CVS update: elephant/tests/elephant-tests.lisp elephant/tests/mop-tests.lisp 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-serv27360/tests Modified Files: elephant-tests.lisp mop-tests.lisp testserializer.lisp Log Message: fixed imports Date: Sat Sep 4 11:16:11 2004 Author: blee Index: elephant/tests/elephant-tests.lisp diff -u elephant/tests/elephant-tests.lisp:1.1 elephant/tests/elephant-tests.lisp:1.2 --- elephant/tests/elephant-tests.lisp:1.1 Sat Sep 4 10:24:30 2004 +++ elephant/tests/elephant-tests.lisp Sat Sep 4 11:16:11 2004 @@ -43,24 +43,34 @@ (defpackage elephant-tests (:nicknames ele-tests :ele-tests) (:use common-lisp elephant rt) + (:import-from :ele + *out-buf* + serialize + deserialize + buffer-stream-buffer) #+cmu (:import-from :pcl + finalize-inheritance slot-definition-name class-slots) #+sbcl (:import-from :sb-mop + finalize-inheritance slot-definition-name class-slots) #+allegro (:import-from :clos + finalize-inheritance slot-definition-name class-slots) #+openmcl (:import-from :ccl + finalize-inheritance slot-definition-name class-slots) #+lispworks (:import-from :clos + finalize-inheritance slot-definition-name class-slots) ) Index: elephant/tests/mop-tests.lisp diff -u elephant/tests/mop-tests.lisp:1.3 elephant/tests/mop-tests.lisp:1.4 --- elephant/tests/mop-tests.lisp:1.3 Sat Sep 4 10:24:23 2004 +++ elephant/tests/mop-tests.lisp Sat Sep 4 11:16:11 2004 @@ -1,12 +1,4 @@ (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 Index: elephant/tests/testserializer.lisp diff -u elephant/tests/testserializer.lisp:1.3 elephant/tests/testserializer.lisp:1.4 --- elephant/tests/testserializer.lisp:1.3 Sat Sep 4 10:25:07 2004 +++ elephant/tests/testserializer.lisp Sat Sep 4 11:16:11 2004 @@ -1,8 +1,4 @@ (in-package :ele-tests) -(import 'ele::*out-buf*) -(import 'ele::serialize) -(import 'ele::deserialize) -(import 'ele::buffer-stream-buffer) (defun in-out-value (var) (serialize var *out-buf*)

1 0

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

04 Sep '04

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv22981 Modified Files: Makefile Log Message: back to Linux default Date: Sat Sep 4 11:03:38 2004 Author: blee Index: elephant/Makefile diff -u elephant/Makefile:1.2 elephant/Makefile:1.3 --- elephant/Makefile:1.2 Thu Sep 2 09:03:51 2004 +++ elephant/Makefile Sat Sep 4 11:03:37 2004 @@ -7,13 +7,13 @@ SHELL=/bin/sh UNAME:=$(shell uname -s) -# *BSD users will probably want -DBLIBDIR=/usr/local/lib/db42 -DBINCDIR=/usr/local/include/db42 +DB42DIR=/usr/local/BerkeleyDB.4.2 +DBLIBDIR=$(DB42DIR)/lib/ +DBINCDIR=$(DB42DIR)/include/ -#DB42DIR=/usr/local/BerkeleyDB.4.2 -#DBLIBDIR=$(DB42DIR)/lib/ -#DBINCDIR=$(DB42DIR)/include/ +# *BSD users will probably want +#DBLIBDIR=/usr/local/lib/db42 +#DBINCDIR=/usr/local/include/db42 INSTALLDIR=/usr/local/share/common-lisp/elephant-0.1/

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-serv22085/src Modified Files: serializer.lisp Log Message: really fixed the array types (hopefully!) Date: Sat Sep 4 10:59:40 2004 Author: blee Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.7 elephant/src/serializer.lisp:1.8 --- elephant/src/serializer.lisp:1.7 Sat Sep 4 10:20:37 2004 +++ elephant/src/serializer.lisp Sat Sep 4 10:59:40 2004 @@ -355,19 +355,23 @@ (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) + +(defun type= (t1 t2) + (and (subtypep t1 t2) (subtypep t2 t1))) + (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) + when (type= spec uspec) do - (setf (gethash uspec array-type-to-byte) (incf counter))) + (setf (gethash spec 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) + when (type= spec uspec) do - (setf (gethash uspec array-type-to-byte) (incf counter)))) + (setf (gethash spec 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/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