Commit b139d5c9 authored by pfdietz's avatar pfdietz
Browse files

Removed the 'works-with-classes' hack now that gcl's bug has been fixed. ...

Removed the 'works-with-classes' hack now that gcl's bug has been fixed.  Added tests for doc strings (which may be nil).
parent b9299a4e
...@@ -109,16 +109,17 @@ ...@@ -109,16 +109,17 @@
(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 (defvar *subtypep-works-with-classes* t
"Becomes NIL if SUBTYPEP doesn't work with classes. We test this first to avoid "Becomes NIL if SUBTYPEP doesn't work with classes. We test this first to avoid
repeated test failures that cause GCL to bomb.") repeated test failures that cause GCL to bomb.")
(deftest subtypep-works-with-classes (deftest subtypep-works-with-classes
(let ((c1 (find-class 'vector))) (let ((c1 (find-class 'vector)))
(setq *subtypep-works-with-classes* nil) ;; (setq *subtypep-works-with-classes* nil)
(subtypep c1 'vector) (subtypep c1 'vector)
(subtypep 'vector c1) (subtypep 'vector c1)
(setq *subtypep-works-with-classes* t)) ;; (setq *subtypep-works-with-classes* t))
t) t)
(defvar *typep-works-with-classes* t (defvar *typep-works-with-classes* t
...@@ -127,10 +128,11 @@ ...@@ -127,10 +128,11 @@
(deftest typep-works-with-classes (deftest typep-works-with-classes
(let ((c1 (find-class 'vector))) (let ((c1 (find-class 'vector)))
(setq *typep-works-with-classes* nil) ;; (setq *typep-works-with-classes* nil)
(typep #(0 0) c1) (typep #(0 0) c1)
(setq *typep-works-with-classes* t)) ;; (setq *typep-works-with-classes* t))
t) t)
|#
;; ;;
;; There are a number of standardized tests for ;; There are a number of standardized tests for
...@@ -421,11 +423,7 @@ do the defstruct." ...@@ -421,11 +423,7 @@ do the defstruct."
,@(unless type-option ,@(unless type-option
`( `(
(deftest ,(make-struct-test-name name 13) (deftest ,(make-struct-test-name name 13)
;; Add a guard to prevent too many exceptions from occuring (notnot (typep (,make-fn) (find-class (quote ,name))))
;; 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))))
...@@ -446,23 +444,32 @@ do the defstruct." ...@@ -446,23 +444,32 @@ do the defstruct."
collect type) collect type)
nil) nil)
(deftest ,(make-struct-test-name name 17) (deftest ,(make-struct-test-name name 17)
;; Add a guard to prevent too many exceptions from occuring (let ((class (find-class (quote ,name))))
;; if SUBTYPEP doesn't work with classes. (loop for type in *disjoint-types-list*
(if (not *subtypep-works-with-classes*) unless (and
:subtypep-busted (equalt (multiple-value-list
(let ((class (find-class (quote ,name)))) (subtypep* type class))
(loop for type in *disjoint-types-list* '(nil t))
unless (and (equalt (multiple-value-list
(equalt (multiple-value-list (subtypep* class type))
(subtypep* type class)) '(nil t)))
'(nil t)) collect type))
(equalt (multiple-value-list
(subtypep* class type))
'(nil t)))
collect type)))
nil) nil)
)) ))
;;; Documentation tests
,(when doc-string
`(deftest ,(make-struct-test-name name 18)
(let ((doc (documentation ',name 'structure)))
(or (null doc) (equalt doc ',doc-string)))
t))
,(when (and doc-string (not type-option))
`(deftest ,(make-struct-test-name name 19)
(let ((doc (documentation ',name 'type)))
(or (null doc) (equalt doc ',doc-string)))
t))
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