Commit 868e5992 authored by pfdietz's avatar pfdietz
Browse files

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 @@ ...@@ -109,6 +109,29 @@
(defvar *defstruct-with-tests-names* nil (defvar *defstruct-with-tests-names* nil
"Names of structure types defined with DEFSRUCT-WITH-TESTS.") "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 ;; There are a number of standardized tests for
;; structures. The following macro generates the ;; structures. The following macro generates the
...@@ -398,7 +421,11 @@ do the defstruct." ...@@ -398,7 +421,11 @@ do the defstruct."
,@(unless type-option ,@(unless type-option
`( `(
(deftest ,(make-struct-test-name name 13) (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) t)
(deftest ,(make-struct-test-name name 14) (deftest ,(make-struct-test-name name 14)
(let ((class (find-class (quote ,name)))) (let ((class (find-class (quote ,name))))
...@@ -419,16 +446,20 @@ do the defstruct." ...@@ -419,16 +446,20 @@ do the defstruct."
collect type) collect type)
nil) nil)
(deftest ,(make-struct-test-name name 17) (deftest ,(make-struct-test-name name 17)
(let ((class (find-class (quote ,name)))) ;; Add a guard to prevent too many exceptions from occuring
(loop for type in *disjoint-types-list* ;; if SUBTYPEP doesn't work with classes.
unless (and (if (not *subtypep-works-with-classes*)
(equalt (multiple-value-list :subtypep-busted
(subtypep* type class)) (let ((class (find-class (quote ,name))))
'(nil t)) (loop for type in *disjoint-types-list*
(equalt (multiple-value-list unless (and
(subtypep* class type)) (equalt (multiple-value-list
'(nil t))) (subtypep* type class))
collect type)) '(nil t))
(equalt (multiple-value-list
(subtypep* class type))
'(nil t)))
collect type)))
nil) 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