tests/defstruct.impure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   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
   6 ;;;; from CMU CL.
   7 ;;;;
   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.
  11
  12 (cl:in-package :cl-user)
  13
  14 (load "assertoid.lisp")
  15 \f
  16 ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
  17
  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))
  26
  27 ;;; basic inheritance
  28 (defstruct (astronaut (:include person)
  29                       (:conc-name astro-))
  30   helmet-size
  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)))
  38   helmet-size
  39   (favorite-beverage 'tang))
  40 (assert (eql (ancient-astronaut-age (make-ancient-astronaut :name "John")) 77))
  41
  42 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
  43 (defstruct (binop (:type list) :named (:initial-offset 2))
  44   (operator '? :type symbol)
  45   operand-1
  46   operand-2)
  47 (defstruct (annotated-binop (:type list)
  48                             (:initial-offset 3)
  49                             (:include binop))
  50   commutative associative identity)
  51 (assert (equal (make-annotated-binop :operator '*
  52                                      :operand-1 'x
  53                                      :operand-2 5
  54                                      :commutative t
  55                                      :associative t
  56                                      :identity 1)
  57                '(nil nil binop * x 5 nil nil nil t t 1)))
  58
  59 ;;; effect of :NAMED on :TYPE
  60 (defstruct (named-binop (:type list) :named)
  61   (operator '? :type symbol)
  62   operand-1
  63   operand-2)
  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)))))
  72
  73 ;;; example 1
  74 (defstruct town
  75   area
  76   watertowers
  77   (firetrucks 1 :type fixnum)
  78   population
  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
  90                                   town-watertowers
  91                                   town-firetrucks
  92                                   town-population
  93                                   town-elevation))
  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
  97
  98 ;;; example 2
  99 (defstruct (clown (:conc-name bozo-))
 100   (nose-color 'red)
 101   frizzy-hair-p
 102   polkadots)
 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))
 108   nose-color
 109   frizzy-hair-p
 110   polkadots)
 111 (assert (is-a-bozo-p (make-up-klown)))
 112
 113 ;;; success
 114 (quit :unix-status 104)