Commit 868e5992 authored by pfdietz's avatar pfdietz

Modified the structure tests so that if TYPEP or SUBTYPEP don't take class...

Modified the structure tests so that if TYPEP or SUBTYPEP don't take class arguments then subsequent tests that depend on that just fail.  This prevents gcl from segfaulting when too many errors are caught.
parent 4eddbd96
......@@ -109,6 +109,29 @@
(defvar *defstruct-with-tests-names* nil
"Names of structure types defined with DEFSRUCT-WITH-TESTS.")
(defvar *subtypep-works-with-classes* t
"Becomes NIL if SUBTYPEP doesn't work with classes. We test this first to avoid
repeated test failures that cause GCL to bomb.")
(deftest subtypep-works-with-classes
(let ((c1 (find-class 'vector)))
(setq *subtypep-works-with-classes* nil)
(subtypep c1 'vector)
(subtypep 'vector c1)
(setq *subtypep-works-with-classes* t))
t)
(defvar *typep-works-with-classes* t
"Becomes NIL if TYPEP doesn't work with classes. We test this first to avoid
repeated test failures that cause GCL to bomb.")
(deftest typep-works-with-classes
(let ((c1 (find-class 'vector)))
(setq *typep-works-with-classes* nil)
(typep #(0 0) c1)
(setq *typep-works-with-classes* t))
t)
;;
;; There are a number of standardized tests for
;; structures. The following macro generates the
......@@ -398,7 +421,11 @@ do the defstruct."
,@(unless type-option
`(
(deftest ,(make-struct-test-name name 13)
(notnot (typep (,make-fn) (find-class (quote ,name))))
;; Add a guard to prevent too many exceptions from occuring
;; if TYPEP doesn't work with classes.
(if (not *typep-works-with-classes*)
:typep-busted
(notnot (typep (,make-fn) (find-class (quote ,name)))))
t)
(deftest ,(make-struct-test-name name 14)
(let ((class (find-class (quote ,name))))
......@@ -419,16 +446,20 @@ do the defstruct."
collect type)
nil)
(deftest ,(make-struct-test-name name 17)
(let ((class (find-class (quote ,name))))
(loop for type in *disjoint-types-list*
unless (and
(equalt (multiple-value-list
(subtypep* type class))
'(nil t))
(equalt (multiple-value-list
(subtypep* class type))
'(nil t)))
collect type))
;; Add a guard to prevent too many exceptions from occuring
;; if SUBTYPEP doesn't work with classes.
(if (not *subtypep-works-with-classes*)
:subtypep-busted
(let ((class (find-class (quote ,name))))
(loop for type in *disjoint-types-list*
unless (and
(equalt (multiple-value-list
(subtypep* type class))
'(nil t))
(equalt (multiple-value-list
(subtypep* class type))
'(nil t)))
collect type)))
nil)
))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment