Commit 253c9b1f authored by pfdietz's avatar pfdietz

Began adding structure tests using DEFSTRUCT-WITH-TESTS macro, which builds 9...

Began adding structure tests using DEFSTRUCT-WITH-TESTS macro, which builds 9 tests for each structure definition.
parent 306d0691
......@@ -7,43 +7,44 @@
(declaim (optimize (safety 3)))
(defun make-struct-test-name (structure-name n)
(declare (type (or string symbol character) structure-name)
(type fixnum n))
;; (declare (type (or string symbol character) structure-name)
;; (type fixnum n))
(assert (typep structure-name '(or string symbol character)))
(assert (typep n 'fixnum))
(setf structure-name (string structure-name))
(intern (concatenate 'string
structure-name
"-STRUCT-TEST-"
(princ-to-string n))
:cl-test))
"/"
(princ-to-string n))))
(defun make-struct-p-fn (structure-name)
(assert (typep structure-name '(or string symbol character)))
(setf structure-name (string structure-name))
(intern (concatenate 'string
structure-name
"-P")
:cl-test))
"-P")))
(defun make-struct-copy-fn (structure-name)
(setf structure-name (string structure-name))
(intern (concatenate 'string
"COPY-"
structure-name)
:cl-test))
(assert (typep structure-name '(or string symbol character)))
(setf structure-name (string structure-name))
(intern (concatenate 'string
"COPY-"
structure-name)))
(defun make-struct-field-fn (structure-name field-name)
(defun make-struct-field-fn (conc-name field-name)
"Make field accessor for a field in a structure"
(setf structure-name (string structure-name))
(assert (typep conc-name '(or string symbol character)))
(assert (typep field-name '(or string symbol character)))
(setf conc-name (string conc-name))
(setf field-name (string field-name))
(intern (concatenate 'string
structure-name "-" field-name)
:cl-test))
(intern (concatenate 'string conc-name field-name)))
(defun make-struct-make-fn (structure-name)
"Make the make- function for a structure"
(assert (typep structure-name '(or string symbol character)))
(setf structure-name (string structure-name))
(intern (concatenate 'string
"MAKE-" structure-name)
:cl-test))
"MAKE-" structure-name)))
(defun create-instance-of-type (type)
"Return an instance of a type. Signal an error if
......@@ -94,6 +95,14 @@
(create-instance-of-type (second type)))
(t (error "Cannot generate element for type ~S~%" type))))
(defun find-option (option-list option &optional default)
(loop for opt in option-list
when (or (eq opt option)
(and (consp opt)
(eq (car opt) option)))
return opt
finally (return default)))
;;
;; There are a number of standardized tests for
;; structures. The following macro generates the
......@@ -104,26 +113,78 @@
(name-and-options &body slot-descriptions-and-documentation)
"Construct standardized tests for a defstruct, and also
do the defstruct."
(let* ((doc-string
(when (and (consp slot-descriptions-and-documentation)
(stringp (car slot-descriptions-and-documentation)))
(car slot-descriptions-and-documentation)))
(defstruct-with-tests-fun name-and-options
slot-descriptions-and-documentation))
(defun defstruct-with-tests-fun (name-and-options
slot-descriptions-and-documentation)
;; Function called from macro defstruct-with-tests
(let* (
;; Either NIL or the documentation string for the structure
(doc-string
(when (and (consp slot-descriptions-and-documentation)
(stringp (car slot-descriptions-and-documentation)))
(car slot-descriptions-and-documentation)))
;; The list of slot descriptions that follows either the
;; name and options or the doc string
(slot-descriptions
(if doc-string (cdr slot-descriptions-and-documentation)
slot-descriptions-and-documentation))
;; The name of the structure (should be a symbol)
(name (if (consp name-and-options)
(car name-and-options)
name-and-options))
;; The options list, or NIL if there were no options
(options (if (consp name-and-options)
(cdr name-and-options)
nil))
;; List of symbols that are the names of the slots
(slot-names
(loop
for x in slot-descriptions collect
(if (consp x) (car x) x)))
;; Symbol obtained by prepending MAKE- to the name symbol
(make-fn (make-struct-make-fn name))
(p-fn (make-struct-p-fn name))
(copy-fn (make-struct-copy-fn name))
;; The :predicate option entry from OPTIONS, or NIL if none
(predicate-option (find-option options :predicate))
;; The name of the -P function, either the default or the
;; one specified in the :predicate option
(p-fn (cond
((or (eq predicate-option :predicate)
(null (cdr predicate-option)))
(make-struct-p-fn name))
((cadr predicate-option) (cadr predicate-option))
(t nil)))
;; The :copier option, or NIL if no such option specified
(copier-option (find-option options :copier))
;; The name of the copier function, either the default or
;; one speciefied in the :copier option
(copy-fn (cond
((or (eq copier-option :copier)
(null (cdr copier-option)))
(make-struct-copy-fn name))
((cadr copier-option) (cadr copier-option))
(t nil)))
;; The :conc-name option, or NIL if none specified
(conc-option (find-option options :conc-name))
;; String to be prepended to slot names to get the
;; slot accessor function
(conc-prefix (cond
((null conc-option)
(concatenate 'string (string name) "-"))
((or (eq conc-option :conc-name)
(null (cadr conc-option)))
"")
(t (string (cadr conc-option)))))
;; a list of initial values
(initial-value-alist
(loop
......@@ -136,97 +197,118 @@ do the defstruct."
(cdr slot-desc)
nil)))
(when (and (consp slot-attrs)
(not (keywordp slot-attrs)))
(not (keywordp (car slot-attrs))))
(pop slot-attrs))
(let ((type (getf slot-attrs :type)))
(if type
(cons slot-name (create-instance-of-type type))
(cons slot-name (gensym)))))))
)
`(eval-when (compile load eval)
(defstruct ,name-and-options
,@slot-descriptions-and-documentation)
;; Test that structure is of the correct type
(deftest ,(make-struct-test-name name 1)
(not (not (typep (,make-fn) (quote ,name))))
t)
;; Test that the -P predicate exists
(deftest ,(make-struct-test-name name 2)
(not (not (,p-fn (,make-fn))))
t)
;; Test that the elements of *universe* are not
;; of this type
(deftest ,(make-struct-test-name name 3)
(count-if (function ,p-fn) *universe*)
0)
(deftest ,(make-struct-test-name name 4)
(count-if (function (lambda (x) (typep x (quote ,name))))
*universe*)
0)
;; Check that the fields can be read after being initialized
(deftest ,(make-struct-test-name name 5)
,(let ((inits nil)
(tests nil)
(var (gensym "X")))
(loop
for (slot-name . initval) in initial-value-alist
do
(setf inits
(list* (intern (string slot-name) "KEYWORD")
(list 'quote initval)
inits))
(push `(eql (quote ,initval)
(,(make-struct-field-fn name slot-name)
,var))
tests))
`(let ((,var (,(make-struct-make-fn name) . ,inits)))
(and ,@tests t)))
t)
;; Check that two invocations return different structures
(deftest ,(make-struct-test-name name 6)
,(let ((make-fn (make-struct-make-fn name)))
`(eqt (,make-fn) (,make-fn)))
nil)
;; Check that we can setf the fields
(deftest ,(make-struct-test-name name 7)
,(let* ((var (gensym "X"))
(var2 (gensym "T"))
(tests
(loop
for (slot-name . initval) in initial-value-alist
collect
(let ((field-fn (make-struct-field-fn name slot-name)))
`(let ((,var2 (quote ,initval)))
(setf (,field-fn ,var) ,var2)
(eql (,field-fn ,var) ,var2))))))
`(let ((,var (,(make-struct-make-fn name))))
(and ,@tests t)))
t)
;; Check that the copy function properly copies fields
(deftest ,(make-struct-test-name name 8)
,(let* ((var (gensym "X"))
(var2 (gensym "Y")))
`(let ((,var (,(make-struct-make-fn name)
,@(loop
for (slot-name . initval) in initial-value-alist
nconc (list (intern (string slot-name) "KEYWORD")
`(quote ,initval))))))
(let ((,var2 (,(make-struct-copy-fn name) ,var)))
(and
(not (eql ,var ,var2))
,@(loop
for (slot-name . initval) in initial-value-alist
collect
(let ((fn (make-struct-field-fn name slot-name)))
`(eql (,fn ,var) (,fn ,var2))))
t))))
t)
)))
;; Build the tests in an eval-when form
`(eval-when (compile load eval)
(defstruct ,name-and-options
,@slot-descriptions-and-documentation)
;; Test that structure is of the correct type
(deftest ,(make-struct-test-name name 1)
(and (functionp (function ,make-fn))
(symbol-function (quote ,make-fn))
(notnot (typep (,make-fn) (quote ,name))))
t)
;; Test that the predicate exists
,@(when p-fn
`((deftest ,(make-struct-test-name name 2)
(and (functionp (function ,p-fn))
(symbol-function (quote ,p-fn))
(notnot (,p-fn (,make-fn))))
t)))
;; Test that the elements of *universe* are not
;; of this type
(deftest ,(make-struct-test-name name 3)
(count-if (function ,p-fn) *universe*)
0)
(deftest ,(make-struct-test-name name 4)
(count-if (function (lambda (x) (typep x (quote ,name))))
*universe*)
0)
;; Check that the fields can be read after being initialized
(deftest ,(make-struct-test-name name 5)
,(let ((inits nil)
(tests nil)
(var (gensym "X")))
(loop
for (slot-name . initval) in initial-value-alist
do
(setf inits
(list* (intern (string slot-name) "KEYWORD")
(list 'quote initval)
inits))
(push `(eqlt (quote ,initval)
(,(make-struct-field-fn conc-prefix slot-name)
,var))
tests))
`(let ((,var (,make-fn . ,inits)))
(and ,@tests t)))
t)
;; Check that two invocations return different structures
(deftest ,(make-struct-test-name name 6)
(eqt (,make-fn) (,make-fn))
nil)
;; Check that we can setf the fields
(deftest ,(make-struct-test-name name 7)
,(let* ((var (gensym "X"))
(var2 (gensym "T"))
(tests
(loop
for (slot-name . initval) in initial-value-alist
for slot-desc in slot-descriptions
unless (and (consp slot-desc)
(getf (cddr slot-desc) :read-only))
collect
(let ((field-fn (make-struct-field-fn conc-prefix
slot-name)))
`(let ((,var2 (quote ,initval)))
(setf (,field-fn ,var) ,var2)
(eqlt (,field-fn ,var) ,var2))))))
`(let ((,var (,make-fn)))
(and ,@tests t)))
t)
;; Check that the copy function exists
,@(when copy-fn
`((deftest ,(make-struct-test-name name 8)
(and (functionp (function ,copy-fn))
(symbol-function (quote ,copy-fn))
t)
t)))
;; Check that the copy function properly copies fields
,@(when copy-fn
`((deftest ,(make-struct-test-name name 9)
,(let* ((var (gensym "X"))
(var2 (gensym "Y")))
`(let ((,var (,make-fn
,@(loop
for (slot-name . initval)
in initial-value-alist
nconc (list (intern (string slot-name)
"KEYWORD")
`(quote ,initval))))))
(let ((,var2 (,copy-fn ,var)))
(and
(not (eqlt ,var ,var2))
,@(loop
for (slot-name . nil) in initial-value-alist
collect
(let ((fn (make-struct-field-fn conc-prefix
slot-name)))
`(eqlt (,fn ,var) (,fn ,var2))))
t))))
t)))
)))
......@@ -23,25 +23,117 @@
;; Fields have appropriate values
(deftest structure-2-1
(let ((s (make-s-2)))
(not (not
(and
(eql (s-2-f1 s) 0)
(eqt (s-2-f2 s) 'a)
(eql (s-2-f3 s) 1.21)
(eql (s-2-f4 s) #\d)
(equal (s-2-f5 s) '(a b))
(eql (s-2-f6 s) *s-2-f6-counter*)))))
(let ((*s-2-f6-counter* 0))
(let ((s (make-s-2)))
(and
(eqlt (s-2-f1 s) 0)
(eqt (s-2-f2 s) 'a)
(= (s-2-f3 s) 1.21)
(eqlt (s-2-f4 s) #\d)
(equalt (s-2-f5 s) '(a b))
(eqlt (s-2-f6 s) *s-2-f6-counter*)
(eqlt *s-2-f6-counter* 1))))
t)
;; Two successive invocations of make-s-2 return different objects
(deftest structure-2-2
(eqt (s-2-f5 (make-s-2))
(s-2-f5 (make-s-2)))
(let ((*s-2-f6-counter* 0))
(eqt (s-2-f5 (make-s-2))
(s-2-f5 (make-s-2))))
nil)
;; Creation with various fields does the right thing
(deftest structure-2-3
(let* ((*s-2-f6-counter* 0)
(s (make-s-2 :f1 17)))
(and
(eqlt (s-2-f1 s) 17)
(eqt (s-2-f2 s) 'a)
(= (s-2-f3 s) 1.21)
(eqlt (s-2-f4 s) #\d)
(equalt (s-2-f5 s) '(a b))
(eqlt (s-2-f6 s) *s-2-f6-counter*)
(eqlt *s-2-f6-counter* 1)))
t)
(deftest structure-2-4
(let* ((*s-2-f6-counter* 0)
(s (make-s-2 :f2 'z)))
(and
(eqlt (s-2-f1 s) 0)
(eqt (s-2-f2 s) 'z)
(= (s-2-f3 s) 1.21)
(eqlt (s-2-f4 s) #\d)
(equalt (s-2-f5 s) '(a b))
(eqlt (s-2-f6 s) *s-2-f6-counter*)
(eqlt *s-2-f6-counter* 1)))
t)
(deftest structure-2-5
(let* ((*s-2-f6-counter* 0)
(s (make-s-2 :f3 1.0)))
(and
(eqlt (s-2-f1 s) 0)
(eqt (s-2-f2 s) 'a)
(= (s-2-f3 s) 1.0)
(eqlt (s-2-f4 s) #\d)
(equalt (s-2-f5 s) '(a b))
(eqlt (s-2-f6 s) *s-2-f6-counter*)
(eqlt *s-2-f6-counter* 1)))
t)
(deftest structure-2-6
(let* ((*s-2-f6-counter* 0)
(s (make-s-2 :f4 #\z)))
(and
(eqlt (s-2-f1 s) 0)
(eqt (s-2-f2 s) 'a)
(= (s-2-f3 s) 1.21)
(eqlt (s-2-f4 s) #\z)
(equalt (s-2-f5 s) '(a b))
(eqlt (s-2-f6 s) *s-2-f6-counter*)
(eqlt *s-2-f6-counter* 1)))
t)
(deftest structure-2-7
(let* ((*s-2-f6-counter* 0)
(s (make-s-2 :f5 '(c d e))))
(and
(eqlt (s-2-f1 s) 0)
(eqt (s-2-f2 s) 'a)
(= (s-2-f3 s) 1.21)
(eqlt (s-2-f4 s) #\d)
(equalt (s-2-f5 s) '(c d e))
(eqlt (s-2-f6 s) *s-2-f6-counter*)
(eqlt *s-2-f6-counter* 1)))
t)
(deftest structure-2-8
(let* ((*s-2-f6-counter* 0)
(s (make-s-2 :f6 10)))
(and
(eqlt (s-2-f1 s) 0)
(eqt (s-2-f2 s) 'a)
(= (s-2-f3 s) 1.21)
(eqlt (s-2-f4 s) #\d)
(equalt (s-2-f5 s) '(a b))
(eqlt (s-2-f6 s) 10)
(eqlt *s-2-f6-counter* 0)))
t)
;;; Tests using the defstruct-with-tests infrastructure
(defstruct-with-tests struct-test-03 a b c d)
(defstruct-with-tests (struct-test-04) a b c)
(defstruct-with-tests (struct-test-05 :constructor) a05 b05 c05)
(defstruct-with-tests (struct-test-06 (:constructor)) a06 b06 c06)
(defstruct-with-tests (struct-test-07 :conc-name) a07 b07)
(defstruct-with-tests (struct-test-08 (:conc-name)) a08 b08)
(defstruct-with-tests (struct-test-09 (:conc-name nil)) a09 b09)
(defstruct-with-tests (struct-test-10 (:conc-name "")) a10 b10)
(defstruct-with-tests (struct-test-11 (:conc-name "BLAH-")) a11 b11)
;;; More to come...
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