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))