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 (load "assertoid.lisp")
  13 (use-package "ASSERTOID")
  14 \f
  15 ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
  16
  17 ;;; Type mismatch of slot default init value isn't an error until the
  18 ;;; default init value is actually used. (The justification is
  19 ;;; somewhat bogus, but the requirement is clear.)
  20 (defstruct person age (name 007 :type string)) ; not an error until 007 used
  21 (make-person :name "James") ; not an error, 007 not used
  22 (assert (raises-error? (make-person) type-error))
  23 (assert (raises-error? (setf (person-name (make-person :name "Q")) 1)
  24                        type-error))
  25
  26 ;;; An &AUX variable in a boa-constructor without a default value
  27 ;;; means "do not initialize slot" and does not cause type error
  28 (defstruct (boa-saux (:constructor make-boa-saux (&aux a (b 3) (c))))
  29     (a #\! :type (integer 1 2))
  30     (b #\? :type (integer 3 4))
  31     (c #\# :type (integer 5 6)))
  32 (let ((s (make-boa-saux)))
  33   (declare (notinline identity))
  34   #+nil ; bug 235a
  35   (locally (declare (optimize (safety 3))
  36                     (inline boa-saux-a))
  37     (assert (raises-error? (identity (boa-saux-a s)) type-error)))
  38   (setf (boa-saux-a s) 1)
  39   (setf (boa-saux-c s) 5)
  40   (assert (eql (boa-saux-a s) 1))
  41   (assert (eql (boa-saux-b s) 3))
  42   (assert (eql (boa-saux-c s) 5)))
  43                                         ; these two checks should be
  44                                         ; kept separated
  45 (let ((s (make-boa-saux)))
  46   (declare (notinline identity))
  47   (locally (declare (optimize (safety 0))
  48                     (inline boa-saux-a))
  49     (assert (eql (identity (boa-saux-a s)) 0)))
  50   (setf (boa-saux-a s) 1)
  51   (setf (boa-saux-c s) 5)
  52   (assert (eql (boa-saux-a s) 1))
  53   (assert (eql (boa-saux-b s) 3))
  54   (assert (eql (boa-saux-c s) 5)))
  55
  56 ;;; basic inheritance
  57 (defstruct (astronaut (:include person)
  58                       (:conc-name astro-))
  59   helmet-size
  60   (favorite-beverage 'tang))
  61 (let ((x (make-astronaut :name "Buzz" :helmet-size 17.5)))
  62   (assert (equal (person-name x) "Buzz"))
  63   (assert (equal (astro-name x) "Buzz"))
  64   (assert (eql (astro-favorite-beverage x) 'tang))
  65   (assert (null (astro-age x))))
  66 (defstruct (ancient-astronaut (:include person (age 77)))
  67   helmet-size
  68   (favorite-beverage 'tang))
  69 (assert (eql (ancient-astronaut-age (make-ancient-astronaut :name "John")) 77))
  70
  71 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
  72 (defstruct (binop (:type list) :named (:initial-offset 2))
  73   (operator '? :type symbol)
  74   operand-1
  75   operand-2)
  76 (defstruct (annotated-binop (:type list)
  77                             (:initial-offset 3)
  78                             (:include binop))
  79   commutative associative identity)
  80 (assert (equal (make-annotated-binop :operator '*
  81                                      :operand-1 'x
  82                                      :operand-2 5
  83                                      :commutative t
  84                                      :associative t
  85                                      :identity 1)
  86                '(nil nil binop * x 5 nil nil nil t t 1)))
  87
  88 ;;; effect of :NAMED on :TYPE
  89 (defstruct (named-binop (:type list) :named)
  90   (operator '? :type symbol)
  91   operand-1
  92   operand-2)
  93 (let ((named-binop (make-named-binop :operator '+ :operand-1 'x :operand-2 5)))
  94   ;; The data representation is specified to look like this.
  95   (assert (equal named-binop '(named-binop + x 5)))
  96   ;; A meaningful NAMED-BINOP-P is defined.
  97   (assert (named-binop-p named-binop))
  98   (assert (named-binop-p (copy-list named-binop)))
  99   (assert (not (named-binop-p (cons 11 named-binop))))
 100   (assert (not (named-binop-p (find-package :cl)))))
 101
 102 ;;; example 1
 103 (defstruct town
 104   area
 105   watertowers
 106   (firetrucks 1 :type fixnum)
 107   population
 108   (elevation 5128 :read-only t))
 109 (let ((town1 (make-town :area 0 :watertowers 0)))
 110   (assert (town-p town1))
 111   (assert (not (town-p 1)))
 112   (assert (eql (town-area town1) 0))
 113   (assert (eql (town-elevation town1) 5128))
 114   (assert (null (town-population town1)))
 115   (setf (town-population town1) 99)
 116   (assert (eql (town-population town1) 99))
 117   (let ((town2 (copy-town town1)))
 118     (dolist (slot-accessor-name '(town-area
 119                                   town-watertowers
 120                                   town-firetrucks
 121                                   town-population
 122                                   town-elevation))
 123       (assert (eql (funcall slot-accessor-name town1)
 124                    (funcall slot-accessor-name town2))))
 125     (assert (not (fboundp '(setf town-elevation)))))) ; 'cause it's :READ-ONLY
 126
 127 ;;; example 2
 128 (defstruct (clown (:conc-name bozo-))
 129   (nose-color 'red)
 130   frizzy-hair-p
 131   polkadots)
 132 (let ((funny-clown (make-clown)))
 133   (assert (eql (bozo-nose-color funny-clown) 'red)))
 134 (defstruct (klown (:constructor make-up-klown)
 135                   (:copier clone-klown)
 136                   (:predicate is-a-bozo-p))
 137   nose-color
 138   frizzy-hair-p
 139   polkadots)
 140 (assert (is-a-bozo-p (make-up-klown)))
 141 \f
 142 ;;;; systematically testing variants of DEFSTRUCT:
 143 ;;;;   * native, :TYPE LIST, and :TYPE VECTOR
 144
 145 ;;; FIXME: things to test:
 146 ;;;   * Slot readers work.
 147 ;;;   * Slot writers work.
 148 ;;;   * Predicates work.
 149
 150 ;;; FIXME: things that would be nice to test systematically someday:
 151 ;;;   * constructors (default, boa..)
 152 ;;;   * copiers
 153 ;;;   * no type checks when (> SPEED SAFETY)
 154 ;;;   * Tests of inclusion would be good. (It's tested very lightly
 155 ;;;     above, and then tested a fair amount by the system compiling
 156 ;;;     itself.)
 157
 158 (defun string+ (&rest rest)
 159   (apply #'concatenate 'string
 160          (mapcar #'string rest)))
 161 (defun symbol+ (&rest rest)
 162   (values (intern (apply #'string+ rest))))
 163
 164 (defun accessor-name (conc-name slot-name)
 165   (symbol+ conc-name slot-name))
 166
 167 ;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions)
 168 ;;; to read and write a structure slot.
 169 (defun read-slot-notinline (conc-name slot-name instance)
 170   (funcall (accessor-name conc-name slot-name) instance))
 171 (defun write-slot-notinline (new-value conc-name slot-name instance)
 172   (funcall (fdefinition `(setf ,(accessor-name conc-name slot-name)))
 173            new-value instance))
 174
 175 ;;; Use inline expansions of slot accessors, if possible, to read and
 176 ;;; write a structure slot.
 177 (defun read-slot-inline (conc-name slot-name instance)
 178   (funcall (compile nil
 179                     `(lambda (instance)
 180                        (,(accessor-name conc-name slot-name) instance)))
 181            instance))
 182 (defun write-slot-inline (new-value conc-name slot-name instance)
 183   (funcall (compile nil
 184                     `(lambda (new-value instance)
 185                        (setf (,(accessor-name conc-name slot-name) instance)
 186                              new-value)))
 187            new-value
 188            instance))
 189
 190 ;;; Read a structure slot, checking that the inline and out-of-line
 191 ;;; accessors give the same result.
 192 (defun read-slot (conc-name slot-name instance)
 193   (let ((inline-value (read-slot-inline conc-name slot-name instance))
 194         (notinline-value (read-slot-notinline conc-name slot-name instance)))
 195     (assert (eql inline-value notinline-value))
 196     inline-value))
 197
 198 ;;; Write a structure slot, using INLINEP argument to decide
 199 ;;; on inlineness of accessor used.
 200 (defun write-slot (new-value conc-name slot-name instance inlinep)
 201   (if inlinep
 202       (write-slot-inline new-value conc-name slot-name instance)
 203       (write-slot-notinline new-value conc-name slot-name instance)))
 204
 205 ;;; bound during the tests so that we can get to it even if the
 206 ;;; debugger is having a bad day
 207 (defvar *instance*)
 208
 209 (defmacro test-variant (defstructname &key colontype boa-constructor-p)
 210   `(progn
 211
 212      (format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
 213
 214      (defstruct (,defstructname
 215                   ,@(when colontype `((:type ,colontype)))
 216                   ,@(when boa-constructor-p
 217                           `((:constructor ,(symbol+ "CREATE-" defstructname)
 218                              (id
 219                               &optional
 220                               (optional-test 2 optional-test-p)
 221                               &key
 222                               (home nil home-p)
 223                               (no-home-comment "Home package CL not provided.")
 224                               (comment (if home-p "" no-home-comment))
 225                               (refcount (if optional-test-p optional-test nil))
 226                               hash
 227                               weight)))))
 228
 229        ;; some ordinary tagged slots
 230        id
 231        (home nil :type package :read-only t)
 232        (comment "" :type simple-string)
 233        ;; some raw slots
 234        (weight 1.0 :type single-float)
 235        (hash 1 :type (integer 1 #.(* 3 most-positive-fixnum)) :read-only t)
 236        ;; more ordinary tagged slots
 237        (refcount 0 :type (and unsigned-byte fixnum)))
 238
 239      (format t "~&/done with DEFSTRUCT~%")
 240
 241      (let* ((cn (string+ ',defstructname "-")) ; conc-name
 242             (ctor (symbol-function ',(symbol+ (if boa-constructor-p
 243                                                "CREATE-"
 244                                                "MAKE-")
 245                                              defstructname)))
 246             (*instance* (funcall ctor
 247                                  ,@(unless boa-constructor-p
 248                                            `(:id)) "some id"
 249                                  ,@(when boa-constructor-p
 250                                          '(1))
 251                                  :home (find-package :cl)
 252                                  :hash (+ 14 most-positive-fixnum)
 253                                  ,@(unless boa-constructor-p
 254                                            `(:refcount 1)))))
 255
 256        ;; Check that ctor set up slot values correctly.
 257        (format t "~&/checking constructed structure~%")
 258        (assert (string= "some id" (read-slot cn "ID" *instance*)))
 259        (assert (eql (find-package :cl) (read-slot cn "HOME" *instance*)))
 260        (assert (string= "" (read-slot cn "COMMENT" *instance*)))
 261        (assert (= 1.0 (read-slot cn "WEIGHT" *instance*)))
 262        (assert (eql (+ 14 most-positive-fixnum)
 263                     (read-slot cn "HASH" *instance*)))
 264        (assert (= 1 (read-slot cn "REFCOUNT" *instance*)))
 265
 266        ;; There should be no writers for read-only slots.
 267        (format t "~&/checking no read-only writers~%")
 268        (assert (not (fboundp `(setf ,(symbol+ cn "HOME")))))
 269        (assert (not (fboundp `(setf ,(symbol+ cn "HASH")))))
 270        ;; (Read-only slot values are checked in the loop below.)
 271
 272        (dolist (inlinep '(t nil))
 273          (format t "~&/doing INLINEP=~S~%" inlinep)
 274          ;; Fiddle with writable slot values.
 275          (let ((new-id (format nil "~S" (random 100)))
 276                (new-comment (format nil "~X" (random 5555)))
 277                (new-weight (random 10.0)))
 278            (write-slot new-id cn "ID" *instance* inlinep)
 279            (write-slot new-comment cn "COMMENT" *instance* inlinep)
 280            (write-slot new-weight cn "WEIGHT" *instance* inlinep)
 281            (assert (eql new-id (read-slot cn "ID" *instance*)))
 282            (assert (eql new-comment (read-slot cn "COMMENT" *instance*)))
 283            ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*))
 284            ;;  (error "WEIGHT mismatch: ~S vs. ~S"
 285            ;;         new-weight (read-slot cn "WEIGHT" *instance*)))
 286            (assert (eql new-weight (read-slot cn "WEIGHT" *instance*)))))
 287        (format t "~&/done with INLINEP loop~%")
 288
 289        ;; :TYPE FOO objects don't go in the Lisp type system, so we
 290        ;; can't test TYPEP stuff for them.
 291        ;;
 292        ;; FIXME: However, when they're named, they do define
 293        ;; predicate functions, and we could test those.
 294        ,@(unless colontype
 295            `(;; Fiddle with predicate function.
 296              (let ((pred-name (symbol+ ',defstructname "-P")))
 297                (format t "~&/doing tests on PRED-NAME=~S~%" pred-name)
 298                (assert (funcall pred-name *instance*))
 299                (assert (not (funcall pred-name 14)))
 300                (assert (not (funcall pred-name "test")))
 301                (assert (not (funcall pred-name (make-hash-table))))
 302                (let ((compiled-pred
 303                       (compile nil `(lambda (x) (,pred-name x)))))
 304                  (format t "~&/doing COMPILED-PRED tests~%")
 305                  (assert (funcall compiled-pred *instance*))
 306                  (assert (not (funcall compiled-pred 14)))
 307                  (assert (not (funcall compiled-pred #()))))
 308                ;; Fiddle with TYPEP.
 309                (format t "~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype)
 310                (assert (typep *instance* ',defstructname))
 311                (assert (not (typep 0 ',defstructname)))
 312                (assert (funcall (symbol+ "TYPEP") *instance* ',defstructname))
 313                (assert (not (funcall (symbol+ "TYPEP") nil ',defstructname)))
 314                (let* ((typename ',defstructname)
 315                       (compiled-typep
 316                        (compile nil `(lambda (x) (typep x ',typename)))))
 317                  (assert (funcall compiled-typep *instance*))
 318                  (assert (not (funcall compiled-typep nil))))))))
 319
 320      (format t "~&/done with PROGN for COLONTYPE=~S~%" ',colontype)))
 321
 322 (test-variant vanilla-struct)
 323 (test-variant vector-struct :colontype vector)
 324 (test-variant list-struct :colontype list)
 325 (test-variant vanilla-struct :boa-constructor-p t)
 326 (test-variant vector-struct :colontype vector :boa-constructor-p t)
 327 (test-variant list-struct :colontype list :boa-constructor-p t)
 328
 329 \f
 330 ;;;; testing raw slots harder
 331 ;;;;
 332 ;;;; The offsets of raw slots need to be rescaled during the punning
 333 ;;;; process which is used to access them. That seems like a good
 334 ;;;; place for errors to lurk, so we'll try hunting for them by
 335 ;;;; verifying that all the raw slot data gets written successfully
 336 ;;;; into the object, can be copied with the object, and can then be
 337 ;;;; read back out (with none of it ending up bogusly outside the
 338 ;;;; object, so that it couldn't be copied, or bogusly overwriting
 339 ;;;; some other raw slot).
 340
 341 (defstruct manyraw
 342   (a (expt 2 30) :type (unsigned-byte 32))
 343   (b 0.1 :type single-float)
 344   (c 0.2d0 :type double-float)
 345   (d #c(0.3 0.3) :type (complex single-float))
 346   unraw-slot-just-for-variety
 347   (e #c(0.4d0 0.4d0) :type (complex double-float))
 348   (aa (expt 2 30) :type (unsigned-byte 32))
 349   (bb 0.1 :type single-float)
 350   (cc 0.2d0 :type double-float)
 351   (dd #c(0.3 0.3) :type (complex single-float))
 352   (ee #c(0.4d0 0.4d0) :type (complex double-float)))
 353
 354 (defvar *manyraw* (make-manyraw))
 355
 356 (assert (eql (manyraw-a *manyraw*) (expt 2 30)))
 357 (assert (eql (manyraw-b *manyraw*) 0.1))
 358 (assert (eql (manyraw-c *manyraw*) 0.2d0))
 359 (assert (eql (manyraw-d *manyraw*) #c(0.3 0.3)))
 360 (assert (eql (manyraw-e *manyraw*) #c(0.4d0 0.4d0)))
 361 (assert (eql (manyraw-aa *manyraw*) (expt 2 30)))
 362 (assert (eql (manyraw-bb *manyraw*) 0.1))
 363 (assert (eql (manyraw-cc *manyraw*) 0.2d0))
 364 (assert (eql (manyraw-dd *manyraw*) #c(0.3 0.3)))
 365 (assert (eql (manyraw-ee *manyraw*) #c(0.4d0 0.4d0)))
 366
 367 (setf (manyraw-aa *manyraw*) (expt 2 31)
 368       (manyraw-bb *manyraw*) 0.11
 369       (manyraw-cc *manyraw*) 0.22d0
 370       (manyraw-dd *manyraw*) #c(0.33 0.33)
 371       (manyraw-ee *manyraw*) #c(0.44d0 0.44d0))
 372
 373 (let ((copy (copy-manyraw *manyraw*)))
 374   (assert (eql (manyraw-a copy) (expt 2 30)))
 375   (assert (eql (manyraw-b copy) 0.1))
 376   (assert (eql (manyraw-c copy) 0.2d0))
 377   (assert (eql (manyraw-d copy) #c(0.3 0.3)))
 378   (assert (eql (manyraw-e copy) #c(0.4d0 0.4d0)))
 379   (assert (eql (manyraw-aa copy) (expt 2 31)))
 380   (assert (eql (manyraw-bb copy) 0.11))
 381   (assert (eql (manyraw-cc copy) 0.22d0))
 382   (assert (eql (manyraw-dd copy) #c(0.33 0.33)))
 383   (assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0))))
 384 \f
 385 ;;;; miscellaneous old bugs
 386
 387 (defstruct ya-struct)
 388 (when (ignore-errors (or (ya-struct-p) 12))
 389   (error "YA-STRUCT-P of no arguments should signal an error."))
 390 (when (ignore-errors (or (ya-struct-p 'too 'many 'arguments) 12))
 391   (error "YA-STRUCT-P of three arguments should signal an error."))
 392
 393 ;;; bug 210: Until sbcl-0.7.8.32 BOA constructors had SAFETY 0
 394 ;;; declared inside on the theory that slot types were already
 395 ;;; checked, which bogusly suppressed unbound-variable and other
 396 ;;; checks within the evaluation of initforms.
 397 (defvar *bug210*)
 398 (defstruct (bug210a (:constructor bug210a ()))
 399   (slot *bug210*))
 400 (defstruct bug210b
 401   (slot *bug210*))
 402 ;;; Because of bug 210, this assertion used to fail.
 403 (assert (typep (nth-value 1 (ignore-errors (bug210a))) 'unbound-variable))
 404 ;;; Even with bug 210, these assertions succeeded.
 405 (assert (typep (nth-value 1 (ignore-errors *bug210*)) 'unbound-variable))
 406 (assert (typep (nth-value 1 (ignore-errors (make-bug210b))) 'unbound-variable))
 407
 408 ;;; In sbcl-0.7.8.53, DEFSTRUCT blew up in non-toplevel contexts
 409 ;;; because it implicitly assumed that EVAL-WHEN (COMPILE) stuff
 410 ;;; setting up compiler-layout information would run before the
 411 ;;; constructor function installing the layout was compiled. Make sure
 412 ;;; that doesn't happen again.
 413 (defun foo-0-7-8-53 () (defstruct foo-0-7-8-53 x (y :not)))
 414 (assert (not (find-class 'foo-0-7-8-53 nil)))
 415 (foo-0-7-8-53)
 416 (assert (find-class 'foo-0-7-8-53 nil))
 417 (let ((foo-0-7-8-53 (make-foo-0-7-8-53 :x :s)))
 418   (assert (eq (foo-0-7-8-53-x foo-0-7-8-53) :s))
 419   (assert (eq (foo-0-7-8-53-y foo-0-7-8-53) :not)))
 420 \f
 421 ;;; tests of behaviour of colliding accessors.
 422 (defstruct (bug127-foo (:conc-name bug127-baz-)) a)
 423 (assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
 424 (defstruct (bug127-bar (:conc-name bug127-baz-) (:include bug127-foo)) b)
 425 (assert (= (bug127-baz-a (make-bug127-bar :a 1 :b 2)) 1))
 426 (assert (= (bug127-baz-b (make-bug127-bar :a 1 :b 2)) 2))
 427 (assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
 428
 429 (defun bug127-flurble (x)
 430   x)
 431 (defstruct bug127 flurble)
 432 (assert (= (bug127-flurble (make-bug127 :flurble 7)) 7))
 433
 434 (defstruct bug127-a b-c)
 435 (assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
 436 (defstruct (bug127-a-b (:include bug127-a)) c)
 437 (assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
 438 (assert (= (bug127-a-b-c (make-bug127-a-b :b-c 11 :c 13)) 11))
 439
 440 (defstruct (bug127-e (:conc-name bug127--)) foo)
 441 (assert (= (bug127--foo (make-bug127-e :foo 3)) 3))
 442 (defstruct (bug127-f (:conc-name bug127--)) foo)
 443 (assert (= (bug127--foo (make-bug127-f :foo 3)) 3))
 444 (assert (raises-error? (bug127--foo (make-bug127-e :foo 3)) type-error))
 445
 446 ;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE
 447 \f
 448 ;;; As noted by Paul Dietz for CMUCL, :CONC-NAME handling was a little
 449 ;;; too fragile:
 450 (defstruct (conc-name-syntax :conc-name) a-conc-name-slot)
 451 (assert (eq (a-conc-name-slot (make-conc-name-syntax :a-conc-name-slot 'y))
 452             'y))
 453 ;;; and further :CONC-NAME NIL was being wrongly treated:
 454 (defpackage "DEFSTRUCT-TEST-SCRATCH")
 455 (defstruct (conc-name-nil :conc-name)
 456   defstruct-test-scratch::conc-name-nil-slot)
 457 (assert (= (defstruct-test-scratch::conc-name-nil-slot
 458             (make-conc-name-nil :conc-name-nil-slot 1)) 1))
 459 (assert (raises-error? (conc-name-nil-slot (make-conc-name-nil))
 460                        undefined-function))
 461 \f
 462 ;;; success
 463 (format t "~&/returning success~%")
 464 (quit :unix-status 104)