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 \f
 113 ;;;; systematically testing variants of DEFSTRUCT:
 114 ;;;;   * native, :TYPE LIST, and :TYPE VECTOR
 115
 116 ;;; FIXME: things to test:
 117 ;;;   * Slot readers work.
 118 ;;;   * Slot writers work.
 119 ;;;   * Predicates work.
 120
 121 ;;; FIXME: things that would be nice to test systematically someday:
 122 ;;;   * constructors (default, boa..)
 123 ;;;   * copiers
 124 ;;;   * no type checks when (> SPEED SAFETY)
 125 ;;;   * Tests of inclusion would be good. (It's tested very lightly
 126 ;;;     above, and then tested a fair amount by the system compiling
 127 ;;;     itself.)
 128
 129 (defun string+ (&rest rest)
 130   (apply #'concatenate 'string
 131          (mapcar #'string rest)))
 132 (defun symbol+ (&rest rest)
 133   (values (intern (apply #'string+ rest))))
 134
 135 (defun accessor-name (conc-name slot-name)
 136   (symbol+ conc-name slot-name))
 137
 138 ;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions)
 139 ;;; to read and write a structure slot.
 140 (defun read-slot-notinline (conc-name slot-name instance)
 141   (funcall (accessor-name conc-name slot-name) instance))
 142 (defun write-slot-notinline (new-value conc-name slot-name instance)
 143   (funcall (fdefinition `(setf ,(accessor-name conc-name slot-name)))
 144            new-value instance))
 145
 146 ;;; Use inline expansions of slot accessors, if possible, to read and
 147 ;;; write a structure slot.
 148 (defun read-slot-inline (conc-name slot-name instance)
 149   (funcall (compile nil
 150                     `(lambda (instance)
 151                        (,(accessor-name conc-name slot-name) instance)))
 152            instance))
 153 (defun write-slot-inline (new-value conc-name slot-name instance)
 154   (funcall (compile nil
 155                     `(lambda (new-value instance)
 156                        (setf (,(accessor-name conc-name slot-name) instance)
 157                              new-value)))
 158            new-value
 159            instance))
 160
 161 ;;; Read a structure slot, checking that the inline and out-of-line
 162 ;;; accessors give the same result.
 163 (defun read-slot (conc-name slot-name instance)
 164   (let ((inline-value (read-slot-inline conc-name slot-name instance))
 165         (notinline-value (read-slot-notinline conc-name slot-name instance)))
 166     (assert (eql inline-value notinline-value))
 167     inline-value))
 168
 169 ;;; Write a structure slot, using INLINEP argument to decide
 170 ;;; on inlineness of accessor used.
 171 (defun write-slot (new-value conc-name slot-name instance inlinep)
 172   (if inlinep
 173       (write-slot-inline new-value conc-name slot-name instance)
 174       (write-slot-notinline new-value conc-name slot-name instance)))
 175
 176 ;;; bound during the tests so that we can get to it even if the
 177 ;;; debugger is having a bad day
 178 (defvar *instance*)
 179
 180 (defmacro test-variant (defstructname &key colontype)
 181   `(progn
 182
 183      (format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
 184
 185      (defstruct (,defstructname
 186                   ,@(when colontype `((:type ,colontype))))
 187        ;; some ordinary tagged slots
 188        id
 189        (home nil :type package :read-only t)
 190        (comment "" :type simple-string)
 191        ;; some raw slots
 192        (weight 1.0 :type single-float)
 193        (hash 1 :type (integer 1 #.(* 3 most-positive-fixnum)) :read-only t)
 194        ;; more ordinary tagged slots
 195        (refcount 0 :type (and unsigned-byte fixnum)))
 196
 197      (format t "~&/done with DEFSTRUCT~%")
 198
 199      (let* ((cn (string+ ',defstructname "-")) ; conc-name
 200             (ctor (symbol-function (symbol+ "MAKE-" ',defstructname)))
 201             (*instance* (funcall ctor
 202                                  :id "some id"
 203                                  :home (find-package :cl)
 204                                  :hash (+ 14 most-positive-fixnum)
 205                                  :refcount 1)))
 206
 207        ;; Check that ctor set up slot values correctly.
 208        (format t "~&/checking constructed structure~%")
 209        (assert (string= "some id" (read-slot cn "ID" *instance*)))
 210        (assert (eql (find-package :cl) (read-slot cn "HOME" *instance*)))
 211        (assert (string= "" (read-slot cn "COMMENT" *instance*)))
 212        (assert (= 1.0 (read-slot cn "WEIGHT" *instance*)))
 213        (assert (eql (+ 14 most-positive-fixnum)
 214                     (read-slot cn "HASH" *instance*)))
 215        (assert (= 1 (read-slot cn "REFCOUNT" *instance*)))
 216
 217        ;; There should be no writers for read-only slots.
 218        (format t "~&/checking no read-only writers~%")
 219        (assert (not (fboundp `(setf ,(symbol+ cn "HOME")))))
 220        (assert (not (fboundp `(setf ,(symbol+ cn "HASH")))))
 221        ;; (Read-only slot values are checked in the loop below.)
 222
 223        (dolist (inlinep '(t nil))
 224          (format t "~&/doing INLINEP=~S~%" inlinep)
 225          ;; Fiddle with writable slot values.
 226          (let ((new-id (format nil "~S" (random 100)))
 227                (new-comment (format nil "~X" (random 5555)))
 228                (new-weight (random 10.0)))
 229            (write-slot new-id cn "ID" *instance* inlinep)
 230            (write-slot new-comment cn "COMMENT" *instance* inlinep)
 231            (write-slot new-weight cn "WEIGHT" *instance* inlinep)
 232            (assert (eql new-id (read-slot cn "ID" *instance*)))
 233            (assert (eql new-comment (read-slot cn "COMMENT" *instance*)))
 234            ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*))
 235            ;;  (error "WEIGHT mismatch: ~S vs. ~S"
 236            ;;         new-weight (read-slot cn "WEIGHT" *instance*)))
 237            (assert (eql new-weight (read-slot cn "WEIGHT" *instance*)))))
 238        (format t "~&/done with INLINEP loop~%")
 239
 240        ;; :TYPE FOO objects don't go in the Lisp type system, so we
 241        ;; can't test TYPEP stuff for them.
 242        ;;
 243        ;; FIXME: However, when they're named, they do define
 244        ;; predicate functions, and we could test those.
 245        ,@(unless colontype
 246            `(;; Fiddle with predicate function.
 247              (let ((pred-name (symbol+ ',defstructname "-P")))
 248                (format t "~&/doing tests on PRED-NAME=~S~%" pred-name)
 249                (assert (funcall pred-name *instance*))
 250                (assert (not (funcall pred-name 14)))
 251                (assert (not (funcall pred-name "test")))
 252                (assert (not (funcall pred-name (make-hash-table))))
 253                (let ((compiled-pred
 254                       (compile nil `(lambda (x) (,pred-name x)))))
 255                  (format t "~&/doing COMPILED-PRED tests~%")
 256                  (assert (funcall compiled-pred *instance*))
 257                  (assert (not (funcall compiled-pred 14)))
 258                  (assert (not (funcall compiled-pred #()))))
 259                ;; Fiddle with TYPEP.
 260                (format t "~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype)
 261                (assert (typep *instance* ',defstructname))
 262                (assert (not (typep 0 ',defstructname)))
 263                (assert (funcall (symbol+ "TYPEP") *instance* ',defstructname))
 264                (assert (not (funcall (symbol+ "TYPEP") nil ',defstructname)))
 265                (let* ((typename ',defstructname)
 266                       (compiled-typep
 267                        (compile nil `(lambda (x) (typep x ',typename)))))
 268                  (assert (funcall compiled-typep *instance*))
 269                  (assert (not (funcall compiled-typep nil))))))))
 270
 271      (format t "~&/done with PROGN for COLONTYPE=~S~%" ',colontype)))
 272
 273 (test-variant vanilla-struct)
 274 (test-variant vector-struct :colontype vector)
 275 (test-variant list-struct :colontype list)
 276 \f
 277 ;;;; testing raw slots harder
 278 ;;;;
 279 ;;;; The offsets of raw slots need to be rescaled during the punning
 280 ;;;; process which is used to access them. That seems like a good
 281 ;;;; place for errors to lurk, so we'll try hunting for them by
 282 ;;;; verifying that all the raw slot data gets written successfully
 283 ;;;; into the object, can be copied with the object, and can then be
 284 ;;;; read back out (with none of it ending up bogusly outside the
 285 ;;;; object, so that it couldn't be copied, or bogusly overwriting
 286 ;;;; some other raw slot).
 287
 288 (defstruct manyraw
 289   (a (expt 2 30) :type (unsigned-byte 32))
 290   (b 0.1 :type single-float)
 291   (c 0.2d0 :type double-float)
 292   (d #c(0.3 0.3) :type (complex single-float))
 293   unraw-slot-just-for-variety
 294   (e #c(0.4d0 0.4d0) :type (complex double-float))
 295   (aa (expt 2 30) :type (unsigned-byte 32))
 296   (bb 0.1 :type single-float)
 297   (cc 0.2d0 :type double-float)
 298   (dd #c(0.3 0.3) :type (complex single-float))
 299   (ee #c(0.4d0 0.4d0) :type (complex double-float)))
 300
 301 (defvar *manyraw* (make-manyraw))
 302
 303 (assert (eql (manyraw-a *manyraw*) (expt 2 30)))
 304 (assert (eql (manyraw-b *manyraw*) 0.1))
 305 (assert (eql (manyraw-c *manyraw*) 0.2d0))
 306 (assert (eql (manyraw-d *manyraw*) #c(0.3 0.3)))
 307 (assert (eql (manyraw-e *manyraw*) #c(0.4d0 0.4d0)))
 308 (assert (eql (manyraw-aa *manyraw*) (expt 2 30)))
 309 (assert (eql (manyraw-bb *manyraw*) 0.1))
 310 (assert (eql (manyraw-cc *manyraw*) 0.2d0))
 311 (assert (eql (manyraw-dd *manyraw*) #c(0.3 0.3)))
 312 (assert (eql (manyraw-ee *manyraw*) #c(0.4d0 0.4d0)))
 313
 314 (setf (manyraw-aa *manyraw*) (expt 2 31)
 315       (manyraw-bb *manyraw*) 0.11
 316       (manyraw-cc *manyraw*) 0.22d0
 317       (manyraw-dd *manyraw*) #c(0.33 0.33)
 318       (manyraw-ee *manyraw*) #c(0.44d0 0.44d0))
 319
 320 (let ((copy (copy-manyraw *manyraw*)))
 321   (assert (eql (manyraw-aa copy) (expt 2 31)))
 322   (assert (eql (manyraw-bb copy) 0.11))
 323   (assert (eql (manyraw-cc copy) 0.22d0))
 324   (assert (eql (manyraw-dd copy) #c(0.33 0.33)))
 325   (assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0))))
 326 \f
 327 ;;; success
 328 (format t "~&/returning success~%")
 329 (quit :unix-status 104)