174 lines
5.2 KiB
Plaintext
174 lines
5.2 KiB
Plaintext
|
|
;;; Additional tests for testing the structure facilities.
|
|
;;; Greg Nuyens
|
|
|
|
(xcl-test:do-test-group "standard behavior"
|
|
:before (progn (defstruct tname a b)
|
|
(defstruct (s2 (:include tname)) c))
|
|
|
|
|
|
(xcl-test:do-test "constructor keywords"
|
|
(and (setq in (make-tname :a 3 :b '~b~))
|
|
(eq (tname-a in) 3)
|
|
(eq (tname-b in) '~b~)))
|
|
|
|
(xcl-test:do-test "prebuilt predicates"
|
|
(tname-p in))
|
|
|
|
(xcl-test:do-test "simple inheritance"
|
|
(setq sub (make-s2))
|
|
(and (tname-p sub)(s2-p sub)))
|
|
|
|
(xcl-test:do-test "#s form for constructors"
|
|
(equalp '#s(tname a 3 b 2) (make-tname :a 3 :b 2)))
|
|
|
|
(xcl-test:do-test "try named constructors"
|
|
(and (defstruct (t6 (:constructor my-make-t6)) a)
|
|
(t6-p (setq in (my-make-t6 :a 3)))
|
|
(equal (t6-a in) 3)))
|
|
|
|
(xcl-test:do-test "try the copier"
|
|
(let ((in (make-tname :a 3 :b 2))) (equalp in (copy-tname in))))
|
|
|
|
(xcl-test:do-test "setfs?"
|
|
(let ((in (make-tname)))
|
|
(setf (tname-b in) 'this)
|
|
(equal (tname-b in) 'this))))
|
|
); end of use of tname
|
|
|
|
(xcl-test:do-test "defstruct lexical inits"
|
|
(let ((var1 '~init~))
|
|
(defstruct t7 (a var1) b)
|
|
(equal var1 (t7-a (make-t7)))
|
|
(setq var1 33)
|
|
(equal 33 (t7-a (make-t7)))
|
|
(setq var1 40)
|
|
(equal 40 (t7-a (make-t7)))
|
|
(equal 99 (t7-a (make-t7 :a 99)))))
|
|
|
|
|
|
(xcl-test:do-test-group "t8 and t9 tests"
|
|
:before (progn
|
|
(defstruct t8
|
|
(a 0.0 :type short-float)
|
|
(b 'this :type symbol))
|
|
(defstruct t9
|
|
a
|
|
(b 'this :read-only t)))
|
|
|
|
(xcl-test:do-test "slot types"
|
|
(let ((in (make-t8)))
|
|
(and (setf (t8-a in) 1.2)
|
|
(setf (t8-b in) 'foo)
|
|
(equal (t8-a in) 1.2)
|
|
(equal (t8-b in) 'foo))))
|
|
|
|
(xcl-test:do-test "read-only slots"
|
|
(let ((in (make-t9)))
|
|
(and (setf (t9-a in) 1.2)
|
|
(xcl-test:expect-errors xcl:condition (setf (t9-b in) 'foo))
|
|
)))
|
|
) ; end "t8 and t9 tests"
|
|
|
|
(xcl-test:do-test "lexical init forms"
|
|
(and
|
|
(let ((a 'this))
|
|
(defstruct that (a a))))
|
|
(eq 'this (that-a (make-that))))
|
|
|
|
(xcl-test:do-test "simple vector structure"
|
|
(and (defstruct (vfoo :named (:type vector))
|
|
(bar 1.0)
|
|
(loo 2.0)
|
|
baz)
|
|
(let ((vfoo (make-vfoo :baz 'Me!)))
|
|
(and (eq (vfoo-baz vfoo) 'Me!)
|
|
(vfoo-p vfoo)))))
|
|
|
|
(xcl-test:do-test "included named vector type"
|
|
(and (defstruct (vfoo2
|
|
:named
|
|
(:type vector)
|
|
(:include vfoo)
|
|
(:initial-offset 2))
|
|
this)
|
|
(let ((vfoo2
|
|
(make-vfoo2 :bar 'one
|
|
:loo 'two
|
|
:baz 'three
|
|
:this 'four)))
|
|
(and (vfoo-p vfoo2)
|
|
(vfoo2-p vfoo2)
|
|
(eq (vfoo2-this vfoo2) 'four)
|
|
(eq (vfoo2-baz vfoo2) 'three)))))
|
|
|
|
(xcl-test:do-test "simple list structure"
|
|
(and (defstruct (lfoo :named (:type list))
|
|
(bar 1.0)
|
|
(loo 2.0)
|
|
baz)
|
|
(let ((lfoo (make-lfoo :baz 'Me!)))
|
|
(and (eq (lfoo-baz lfoo) 'Me!)
|
|
(lfoo-p lfoo)))))
|
|
|
|
(xcl-test:do-test "included named list type"
|
|
(and (defstruct (lfoo2
|
|
:named
|
|
(:type list)
|
|
(:include lfoo)
|
|
(:initial-offset 2))
|
|
this)
|
|
(let ((lfoo2
|
|
(make-lfoo2 :bar 'one
|
|
:loo 'two
|
|
:baz 'three
|
|
:this 'four)))
|
|
(and (lfoo-p lfoo2)
|
|
(lfoo2-p lfoo2)
|
|
(eq (lfoo2-this lfoo2) 'four)
|
|
(eq (lfoo2-baz lfoo2) 'three)))))
|
|
|
|
(xcl-test:do-test "simple BOA"
|
|
(and (defstruct (snake (:constructor snake-make (a b)))
|
|
a b)
|
|
(snake-p (snake-make 1 2))))
|
|
|
|
(xcl-test:do-test "not so simple BOA"
|
|
(and (defstruct (snake2 (:constructor
|
|
snake-make2
|
|
(a &optional b (c 'sea) &rest d &aux e (f 'eff))))
|
|
a (b '3) c d e f )
|
|
(snake2-p (snake-make2 1 2))))
|
|
|
|
(xcl-test:do-test "circle-printing"
|
|
(let ((*print-circle* t))
|
|
(defstruct loopy a b)
|
|
(let ((loopy (make-loopy :a '(this and that))))
|
|
(setf (loopy-b loopy) loopy)
|
|
(eq "#1-#s(loopy a (this and that) b #1#)"
|
|
(format nil "~S" loopy)))))
|
|
|
|
(xcl-test:do-test "try the inline extension"
|
|
(and (defstruct (bebop (:inline nil)) rhythm)
|
|
(let ((what (make-bebop :rhythm 'you-bet!)))
|
|
(and (eq 'you-bet! (bebop-rhythm what))
|
|
(eq 45 (setf (bebop-rhythm what) 45))
|
|
(eq 45 (bebop-rhythm what))))))
|
|
|
|
(xcl-test:do-test "try the inline extension some more"
|
|
(and (defstruct (bobep (:inline :predicate)) rhythm)
|
|
(let ((what (make-bobep :rhythm 'you-bet!)))
|
|
(and (eq 'you-bet! (bobep-rhythm what))
|
|
(eq 45 (setf (bobep-rhythm what) 45))
|
|
(eq 45 (bobep-rhythm what))))))
|
|
|
|
(xcl-test:do-test "suppressing copier and predicate"
|
|
(and (defstruct (goz (:predicate nil) (:copier nil))
|
|
a)
|
|
(not (fboundp 'goz-p))
|
|
(not (fboundp 'copy-goz))))
|
|
|
|
|
|
|
|
il:stop
|