mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2025-12-06 02:40:26 -08:00
tests: improve some tests
- extend tests for make-instances-obsolete - add a metastability test for the standard-method finalization - fix tests which assume that metaclasses are finalized eagerly
This commit is contained in:
Daniel Kochmański
parent
34cd3dc221
commit
735d49bfd1
2 changed files with 114 additions and 21 deletions
|
|
@ -413,32 +413,89 @@
|
|||
(undefined-function (c) t)
|
||||
(serious-condition (c) nil))))
|
||||
|
||||
|
||||
;;; Date: 29/11/2009 (P. Costanza)
|
||||
;;; Fixed: 29/11/2009 (Juanjo)
|
||||
;;; Description:
|
||||
;;;
|
||||
;;; Updating of instances is not triggered by MAKE-INSTANCES-OBSOLETE.
|
||||
;;;
|
||||
(ext:with-clean-symbols (*update-guard* class-a class-a-b)
|
||||
(ext:with-clean-symbols (class-a class-a-b class-a-c class-a-x)
|
||||
(test cmp.0020.make-instances-obsolete
|
||||
(defparameter *update-guard* nil)
|
||||
(defclass class-a () ((b :accessor class-a-b :initarg :b)))
|
||||
(let ((*a* (make-instance 'class-a :b 2)))
|
||||
(defclass class-a ()
|
||||
((b :accessor class-a-b :initarg :b)
|
||||
(c :accessor class-a-c :initarg :c)))
|
||||
(let ((instance (make-instance 'class-a :b 2 :c 3))
|
||||
(update-guard nil))
|
||||
(defmethod update-instance-for-redefined-class :before
|
||||
((instance standard-object) added-slots discarded-slots property-list
|
||||
&rest initargs)
|
||||
(setf *update-guard* t))
|
||||
(is-true
|
||||
(and (null *update-guard*)
|
||||
(progn (class-a-b *a*) (null *update-guard*))
|
||||
(progn (make-instances-obsolete (find-class 'class-a))
|
||||
(null *update-guard*))
|
||||
(progn (class-a-b *a*) *update-guard*)
|
||||
(progn (setf *update-guard* nil)
|
||||
(defclass class-a () ((b :accessor class-a-b :initarg :b)))
|
||||
(class-a-b *a*)
|
||||
*update-guard*))))))
|
||||
((instance standard-object) added-slots discarded-slots property-list
|
||||
&rest initargs)
|
||||
(setf update-guard t))
|
||||
(macrolet ((check-situation (change-form trigger-form result doc)
|
||||
`(progn
|
||||
(setf update-guard nil)
|
||||
,change-form
|
||||
(is (and (null update-guard)
|
||||
(progn ,trigger-form
|
||||
(eq update-guard ,result)))
|
||||
,doc))))
|
||||
(check-situation
|
||||
(make-instances-obsolete (find-class 'class-a))
|
||||
(class-a-b instance)
|
||||
t
|
||||
"Direct call to MAKE-INSTANCES-OBSOLETE doesn't work.")
|
||||
(check-situation
|
||||
(defclass class-a ()
|
||||
((b :accessor class-a-b :initarg :b)))
|
||||
(class-a-b instance)
|
||||
t
|
||||
"Removing a slot does not obsolete class instances.")
|
||||
(check-situation
|
||||
(defclass class-a ()
|
||||
((b :accessor class-a-b :initarg :b)
|
||||
(c :accessor class-a-c :initarg :c)))
|
||||
(class-a-b instance)
|
||||
t
|
||||
"Adding a slot does not obsolete class instances.")
|
||||
(check-situation
|
||||
(defclass class-a ()
|
||||
((c :accessor class-a-c :initarg :c)
|
||||
(b :accessor class-a-b :initarg :b)))
|
||||
(class-a-b instance)
|
||||
t
|
||||
"Shuffling slots does not obsolete class instances.")
|
||||
(check-situation
|
||||
(defclass class-a ()
|
||||
((c :accessor class-a-c :initarg :c :allocation :class)
|
||||
(b :accessor class-a-b :initarg :b)))
|
||||
(class-a-b instance)
|
||||
t
|
||||
"Changing slot allocation does not obsolete class instances.")
|
||||
(check-situation
|
||||
(defclass class-a ()
|
||||
((b :accessor class-a-b :initarg :b)
|
||||
(c :accessor class-a-c :initarg :c)))
|
||||
(class-a-b instance)
|
||||
t
|
||||
"Redefining class does not obsolete class instances.")
|
||||
(check-situation
|
||||
(defclass class-a ()
|
||||
((b :accessor class-a-b :initarg :b)
|
||||
(c :accessor class-a-c :initarg :c)))
|
||||
(class-a-b instance)
|
||||
nil
|
||||
"Without a change system should not make instances obsolete.")
|
||||
(check-situation
|
||||
(defclass class-a ()
|
||||
((b :accessor class-a-x :initarg :b)
|
||||
(c :accessor class-a-c :initarg :c)))
|
||||
(class-a-x instance)
|
||||
nil
|
||||
"Changing accessors should not make instances obsolete.")
|
||||
;; The old accessor is removed (the generic function).
|
||||
(signals error (class-a-b instance)
|
||||
"Reader method is not removed after redefinition.")
|
||||
(is (fboundp 'class-a-b)
|
||||
"Redefining a class removes generic functions.")))))
|
||||
|
||||
;;; Date: 25/03/2009 (R. Toy)
|
||||
;;; Fixed: 4/12/2009 (Juanjo)
|
||||
|
|
|
|||
|
|
@ -149,9 +149,11 @@
|
|||
"DEFCLASS allows additional options which should be handled by ~
|
||||
the metaclass")
|
||||
(is
|
||||
(equal (eval '(progn
|
||||
(equal (eval '(let ((*aux* 5))
|
||||
(declare (special *aux*))
|
||||
(defclass fee ()
|
||||
((a :initform *aux* :initarg :a)))
|
||||
(make-instance 'faa)
|
||||
(setf (documentation (first (clos:class-slots (find-class 'fee))) t)
|
||||
#1="hola")
|
||||
(documentation (first (clos:class-slots (find-class 'fee))) t)))
|
||||
|
|
@ -221,6 +223,7 @@ the metaclass")
|
|||
((slot-0 :initform 2 :reader slot-2)))
|
||||
(defclass fee-3 (fee-1 fee-2)
|
||||
((slot-0 :initform 3 :accessor c-slot-0)))
|
||||
(make-instance 'fee-3) ; finalizes inheritance
|
||||
(flet ((accessors (class)
|
||||
(list (class-name class)
|
||||
(mapcar #'clos:slot-definition-readers (clos:class-slots class))
|
||||
|
|
@ -616,10 +619,11 @@ the metaclass")
|
|||
(defclass c (a b) ())
|
||||
(defmethod f ((o a)))
|
||||
(defmethod f ((o b)))
|
||||
(make-instance 'c) ; finalizes inheritance
|
||||
(test mop.0020.c-a-m-disambiguation
|
||||
(finishes
|
||||
(clos:compute-applicable-methods-using-classes
|
||||
#'f (list (find-class 'c))))))
|
||||
(clos:compute-applicable-methods-using-classes
|
||||
#'f (list (find-class 'c))))))
|
||||
|
||||
;;; Bug #46
|
||||
;;;
|
||||
|
|
@ -718,3 +722,35 @@ the metaclass")
|
|||
(defmethod clos:compute-class-precedence-list ((class meta))
|
||||
(cons (find-class 'hack) (call-next-method)))
|
||||
(defclass test-class () () (:metaclass meta))))))
|
||||
|
||||
;;; Date 2020-04-14
|
||||
;;; Description
|
||||
;;;
|
||||
;;; This is a local regression (never commited to the repository),
|
||||
;;; which signals "function class-a-c undefined" when redefining a
|
||||
;;; class after removing a slot.
|
||||
(ext:with-clean-symbols (class-a class-a-b class-a-c)
|
||||
(test mop.0028.local-regression
|
||||
(defclass class-a ()
|
||||
((b :accessor class-a-b :initarg :b)
|
||||
(c :accessor class-a-c :initarg :c)))
|
||||
(defclass class-a ()
|
||||
((b :accessor class-a-b :initarg :b)))
|
||||
(defclass class-a ()
|
||||
((b :accessor class-a-b :initarg :b)
|
||||
(c :accessor class-a-c :initarg :c)))
|
||||
(defclass class-a ()
|
||||
((b :accessor class-a-b :initarg :b)
|
||||
(c :accessor class-a-c :initarg :c)))))
|
||||
|
||||
;;; Date 2020-04-16
|
||||
;;; Description
|
||||
;;;
|
||||
;;; When finializing the standard-method metaclass we had
|
||||
;;; encountered a metastability issue when regenerating the
|
||||
;;; standard accessors (which implies removing them first as
|
||||
;;; specified in MOP), where METHOD-GENERIC-FUNCTION is invoked
|
||||
;;; from ADD-DIRECT-METHOD after specialization on the
|
||||
;;; STANDARD-METHOD is removed.
|
||||
(test mop.0029.standard-method-metastability
|
||||
(finishes (clos:finalize-inheritance (find-class 'standard-method))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue