Skip to content
Snippets Groups Projects
Commit 38b4e66d authored by pfdietz's avatar pfdietz
Browse files

Added test generators for: (1) structure objects are in a class with the

name of the structure, (2) structure classes are instances of structure-class,
(3) structure objects are instances of class structure-object.  Also,
test that TYPEP works when the type specifier is a class (this breaks currently
in gcl.)
parent 0bb76b95
No related branches found
No related tags found
No related merge requests found
...@@ -243,8 +243,8 @@ do the defstruct." ...@@ -243,8 +243,8 @@ do the defstruct."
(and (fboundp (quote ,make-fn)) (and (fboundp (quote ,make-fn))
(functionp (function ,make-fn)) (functionp (function ,make-fn))
(symbol-function (quote ,make-fn)) (symbol-function (quote ,make-fn))
,@(unless type-option (typep (,make-fn) (quote ,(if type-option struct-type
`((typep (,make-fn) (quote ,name)))) name)))
t) t)
t) t)
...@@ -263,7 +263,6 @@ do the defstruct." ...@@ -263,7 +263,6 @@ do the defstruct."
`((deftest ,(make-struct-test-name name 3) `((deftest ,(make-struct-test-name name 3)
(count-if (function ,p-fn) *universe*) (count-if (function ,p-fn) *universe*)
0))) 0)))
,@(unless type-option ,@(unless type-option
`((deftest ,(make-struct-test-name name 4) `((deftest ,(make-struct-test-name name 4)
(count-if (function (lambda (x) (typep x (quote ,name)))) (count-if (function (lambda (x) (typep x (quote ,name))))
...@@ -375,6 +374,22 @@ do the defstruct." ...@@ -375,6 +374,22 @@ do the defstruct."
when read-only when read-only
collect `(not (fboundp '(setf ,field-fn)))) collect `(not (fboundp '(setf ,field-fn))))
t) t)
t))) t)))
;; When the structure is a true structure type, check that
;; the various class relationships hold
,@(unless type-option
`(
(deftest ,(make-struct-test-name name 13)
(notnot (typep (,make-fn) (find-class (quote ,name))))
t)
(deftest ,(make-struct-test-name name 14)
(let ((class (find-class (quote ,name))))
(notnot (typep class 'structure-class)))
t)
(deftest ,(make-struct-test-name name 15)
(notnot (typep (,make-fn) 'structure-object))
t)
))
nil nil
))) )))
...@@ -199,7 +199,7 @@ ...@@ -199,7 +199,7 @@
(defstruct-with-tests (struct-test-36 (:conc-name "")) (defstruct-with-tests (struct-test-36 (:conc-name ""))
struct-test-package::st36-a36 struct-test-package::st26-b36) struct-test-package::st36-a36 struct-test-package::st26-b36)
;;; List structures ;;; List and vector structures
(defstruct-with-tests (struct-test-37 (:type list)) a37 b37 c37) (defstruct-with-tests (struct-test-37 (:type list)) a37 b37 c37)
(defstruct-with-tests (struct-test-38 (:type list) :named) a38 b38 c38) (defstruct-with-tests (struct-test-38 (:type list) :named) a38 b38 c38)
...@@ -207,13 +207,11 @@ ...@@ -207,13 +207,11 @@
(:type list) :named) (:type list) :named)
a39 b39 c39) a39 b39 c39)
;;; Vector structures
(defstruct-with-tests (struct-test-40 (:type vector)) a40 b40) (defstruct-with-tests (struct-test-40 (:type vector)) a40 b40)
(defstruct-with-tests (struct-test-41 (:type vector) :named) a41 b41) (defstruct-with-tests (struct-test-41 (:type vector) :named) a41 b41)
(defstruct-with-tests (struct-test-42 (:type (vector t))) a42 b42) (defstruct-with-tests (struct-test-42 (:type (vector t))) a42 b42)
(defstruct-with-tests (struct-test-43 (:type (vector t)) :named) a43 b43) (defstruct-with-tests (struct-test-43 (:type (vector t)) :named) a43 b43)
(defstruct-with-tests (struct-test-44 (:type list))
(a44 0 :type integer)
(b44 'a :type symbol))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment