[elephant-cvs] CVS update: elephant/tests/mop-tests.lisp
blee at common-lisp.net
blee at common-lisp.net
Sat Sep 4 08:24:23 UTC 2004
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))
More information about the Elephant-cvs
mailing list