mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-06 02:40:26 -08:00
Code Issues Projects Releases Packages Wiki Activity

tests: improve some tests

Browse source 
- 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 2020-04-14 13:41:56 +02:00
parent 34cd3dc221
commit 735d49bfd1
2 changed files with 114 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

89
src/tests/normal-tests/compiler.lsp
View file

@ -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*))))))
(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)

38
src/tests/normal-tests/metaobject-protocol.lsp
View file

@ -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,6 +619,7 @@ 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
@ -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))))