1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
12 (cl:in-package :cl-user)
14 (load "assertoid.lisp")
16 ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
18 ;;; Type mismatch of slot default init value isn't an error until the
19 ;;; default init value is actually used. (The justification is
20 ;;; somewhat bogus, but the requirement is clear.)
21 (defstruct person age (name 007 :type string)) ; not an error until 007 used
22 (make-person :name "James") ; not an error, 007 not used
23 (assert (raises-error? (make-person) type-error))
24 ;;; FIXME: broken structure slot type checking in sbcl-0.pre7.62
25 #+nil (assert (raises-error? (setf (person-name (make-person "Q")) 1) type-error))
28 (defstruct (astronaut (:include person)
31 (favorite-beverage 'tang))
32 (let ((x (make-astronaut :name "Buzz" :helmet-size 17.5)))
33 (assert (equal (person-name x) "Buzz"))
34 (assert (equal (astro-name x) "Buzz"))
35 (assert (eql (astro-favorite-beverage x) 'tang))
36 (assert (null (astro-age x))))
37 (defstruct (ancient-astronaut (:include person (age 77)))
39 (favorite-beverage 'tang))
40 (assert (eql (ancient-astronaut-age (make-ancient-astronaut :name "John")) 77))
42 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
43 (defstruct (binop (:type list) :named (:initial-offset 2))
44 (operator '? :type symbol)
47 (defstruct (annotated-binop (:type list)
50 commutative associative identity)
51 (assert (equal (make-annotated-binop :operator '*
57 '(nil nil binop * x 5 nil nil nil t t 1)))
59 ;;; effect of :NAMED on :TYPE
60 (defstruct (named-binop (:type list) :named)
61 (operator '? :type symbol)
64 (let ((named-binop (make-named-binop :operator '+ :operand-1 'x :operand-2 5)))
65 ;; The data representation is specified to look like this.
66 (assert (equal named-binop '(named-binop + x 5)))
67 ;; A meaningful NAMED-BINOP-P is defined.
68 (assert (named-binop-p named-binop))
69 (assert (named-binop-p (copy-list named-binop)))
70 (assert (not (named-binop-p (cons 11 named-binop))))
71 (assert (not (named-binop-p (find-package :cl)))))
77 (firetrucks 1 :type fixnum)
79 (elevation 5128 :read-only t))
80 (let ((town1 (make-town :area 0 :watertowers 0)))
81 (assert (town-p town1))
82 (assert (not (town-p 1)))
83 (assert (eql (town-area town1) 0))
84 (assert (eql (town-elevation town1) 5128))
85 (assert (null (town-population town1)))
86 (setf (town-population town1) 99)
87 (assert (eql (town-population town1) 99))
88 (let ((town2 (copy-town town1)))
89 (dolist (slot-accessor-name '(town-area
94 (assert (eql (funcall slot-accessor-name town1)
95 (funcall slot-accessor-name town2))))
96 (assert (not (fboundp '(setf town-elevation)))))) ; 'cause it's :READ-ONLY
99 (defstruct (clown (:conc-name bozo-))
103 (let ((funny-clown (make-clown)))
104 (assert (eql (bozo-nose-color funny-clown) 'red)))
105 (defstruct (klown (:constructor make-up-klown)
106 (:copier clone-klown)
107 (:predicate is-a-bozo-p))
111 (assert (is-a-bozo-p (make-up-klown)))
114 (quit :unix-status 104)