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 (load "compiler-test-util.lisp")
  14 (use-package "ASSERTOID")
  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
  24 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
  25 (assert-error (make-person) type-error)
  26 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
  27 (assert-error (setf (person-name (make-person :name "Q")) 1)
  28               type-error)
  29
  30 ;;; An &AUX variable in a boa-constructor without a default value
  31 ;;; means "do not initialize slot" and does not cause type error
  32 (declaim (notinline opaque-identity))
  33 (defun opaque-identity (x) x)
  34
  35 (with-test (:name :defstruct-boa-typecheck)
  36   (defstruct (boa-saux (:constructor make-boa-saux (&aux a (b 3) (c))))
  37     (a #\! :type (integer 1 2))
  38     (b #\? :type (integer 3 4))
  39     (c #\# :type (integer 5 6)))
  40   (let ((s (make-boa-saux)))
  41     (locally (declare (optimize (safety 3))
  42                       (inline boa-saux-a))
  43       (assert-error (opaque-identity (boa-saux-a s)) type-error))
  44     (setf (boa-saux-a s) 1)
  45     (setf (boa-saux-c s) 5)
  46     (assert (eql (boa-saux-a s) 1))
  47     (assert (eql (boa-saux-b s) 3))
  48     (assert (eql (boa-saux-c s) 5))))
  49                                         ; these two checks should be
  50                                         ; kept separated
  51
  52 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
  53 (with-test (:name :defstruct-boa-no-error)
  54  (let ((s (make-boa-saux)))
  55    (locally (declare (optimize (safety 0))
  56                      (inline boa-saux-a))
  57      (assert (eql (opaque-identity (boa-saux-a s)) 0)))
  58    (setf (boa-saux-a s) 1)
  59    (setf (boa-saux-c s) 5)
  60    (assert (eql (boa-saux-a s) 1))
  61    (assert (eql (boa-saux-b s) 3))
  62    (assert (eql (boa-saux-c s) 5))))
  63
  64 (with-test (:name :defstruct-boa-typecheck.2)
  65   (let ((s (make-boa-saux)))
  66     (locally (declare (optimize (safety 3))
  67                       (notinline boa-saux-a))
  68       (assert-error (opaque-identity (boa-saux-a s)) type-error))
  69     (setf (boa-saux-a s) 1)
  70     (setf (boa-saux-c s) 5)
  71     (assert (eql (boa-saux-a s) 1))
  72     (assert (eql (boa-saux-b s) 3))
  73     (assert (eql (boa-saux-c s) 5))))
  74
  75 ;;; basic inheritance
  76 (defstruct (astronaut (:include person)
  77                       (:conc-name astro-))
  78   helmet-size
  79   (favorite-beverage 'tang))
  80 (let ((x (make-astronaut :name "Buzz" :helmet-size 17.5)))
  81   (assert (equal (person-name x) "Buzz"))
  82   (assert (equal (astro-name x) "Buzz"))
  83   (assert (eql (astro-favorite-beverage x) 'tang))
  84   (assert (null (astro-age x))))
  85 (defstruct (ancient-astronaut (:include person (age 77)))
  86   helmet-size
  87   (favorite-beverage 'tang))
  88 (assert (eql (ancient-astronaut-age (make-ancient-astronaut :name "John")) 77))
  89
  90 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
  91 (defstruct (binop (:type list) :named (:initial-offset 2))
  92   (operator '? :type symbol)
  93   operand-1
  94   operand-2)
  95 (defstruct (annotated-binop (:type list)
  96                             (:initial-offset 3)
  97                             (:include binop))
  98   commutative associative identity)
  99 (assert (equal (make-annotated-binop :operator '*
 100                                      :operand-1 'x
 101                                      :operand-2 5
 102                                      :commutative t
 103                                      :associative t
 104                                      :identity 1)
 105                '(nil nil binop * x 5 nil nil nil t t 1)))
 106
 107 ;;; effect of :NAMED on :TYPE
 108 (defstruct (named-binop (:type list) :named)
 109   (operator '? :type symbol)
 110   operand-1
 111   operand-2)
 112 (let ((named-binop (make-named-binop :operator '+ :operand-1 'x :operand-2 5)))
 113   ;; The data representation is specified to look like this.
 114   (assert (equal named-binop '(named-binop + x 5)))
 115   ;; A meaningful NAMED-BINOP-P is defined.
 116   (assert (named-binop-p named-binop))
 117   (assert (named-binop-p (copy-list named-binop)))
 118   (assert (not (named-binop-p (cons 11 named-binop))))
 119   (assert (not (named-binop-p (find-package :cl)))))
 120
 121 ;;; example 1
 122 (defstruct town
 123   area
 124   watertowers
 125   (firetrucks 1 :type fixnum)
 126   population
 127   (elevation 5128 :read-only t))
 128 (let ((town1 (make-town :area 0 :watertowers 0)))
 129   (assert (town-p town1))
 130   (assert (not (town-p 1)))
 131   (assert (eql (town-area town1) 0))
 132   (assert (eql (town-elevation town1) 5128))
 133   (assert (null (town-population town1)))
 134   (setf (town-population town1) 99)
 135   (assert (eql (town-population town1) 99))
 136   (let ((town2 (copy-town town1)))
 137     (dolist (slot-accessor-name '(town-area
 138                                   town-watertowers
 139                                   town-firetrucks
 140                                   town-population
 141                                   town-elevation))
 142       (assert (eql (funcall slot-accessor-name town1)
 143                    (funcall slot-accessor-name town2))))
 144     (assert (not (fboundp '(setf town-elevation)))))) ; 'cause it's :READ-ONLY
 145
 146 ;;; example 2
 147 (defstruct (clown (:conc-name bozo-))
 148   (nose-color 'red)
 149   frizzy-hair-p
 150   polkadots)
 151 (let ((funny-clown (make-clown)))
 152   (assert (eql (bozo-nose-color funny-clown) 'red)))
 153 (defstruct (klown (:constructor make-up-klown)
 154                   (:copier clone-klown)
 155                   (:predicate is-a-bozo-p))
 156   nose-color
 157   frizzy-hair-p
 158   polkadots)
 159 (assert (is-a-bozo-p (make-up-klown)))
 160 \f
 161 ;;;; systematically testing variants of DEFSTRUCT:
 162 ;;;;   * native, :TYPE LIST, and :TYPE VECTOR
 163
 164 ;;; FIXME: things to test:
 165 ;;;   * Slot readers work.
 166 ;;;   * Slot writers work.
 167 ;;;   * Predicates work.
 168
 169 ;;; FIXME: things that would be nice to test systematically someday:
 170 ;;;   * constructors (default, boa..)
 171 ;;;   * copiers
 172 ;;;   * no type checks when (> SPEED SAFETY)
 173 ;;;   * Tests of inclusion would be good. (It's tested very lightly
 174 ;;;     above, and then tested a fair amount by the system compiling
 175 ;;;     itself.)
 176
 177 (defun string+ (&rest rest)
 178   (apply #'concatenate 'string
 179          (mapcar #'string rest)))
 180 (defun symbol+ (&rest rest)
 181   (values (intern (apply #'string+ rest))))
 182
 183 (defun accessor-name (conc-name slot-name)
 184   (symbol+ conc-name slot-name))
 185
 186 ;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions)
 187 ;;; to read and write a structure slot.
 188 (defun read-slot-notinline (conc-name slot-name instance)
 189   (funcall (accessor-name conc-name slot-name) instance))
 190 (defun write-slot-notinline (new-value conc-name slot-name instance)
 191   (funcall (fdefinition `(setf ,(accessor-name conc-name slot-name)))
 192            new-value instance))
 193
 194 ;;; Use inline expansions of slot accessors, if possible, to read and
 195 ;;; write a structure slot.
 196 (defun read-slot-inline (conc-name slot-name instance)
 197   (funcall (compile nil
 198                     `(lambda (instance)
 199                        (,(accessor-name conc-name slot-name) instance)))
 200            instance))
 201 (defun write-slot-inline (new-value conc-name slot-name instance)
 202   (funcall (compile nil
 203                     `(lambda (new-value instance)
 204                        (setf (,(accessor-name conc-name slot-name) instance)
 205                              new-value)))
 206            new-value
 207            instance))
 208
 209 ;;; Read a structure slot, checking that the inline and out-of-line
 210 ;;; accessors give the same result.
 211 (defun read-slot (conc-name slot-name instance)
 212   (let ((inline-value (read-slot-inline conc-name slot-name instance))
 213         (notinline-value (read-slot-notinline conc-name slot-name instance)))
 214     (assert (eql inline-value notinline-value))
 215     inline-value))
 216
 217 ;;; Write a structure slot, using INLINEP argument to decide
 218 ;;; on inlineness of accessor used.
 219 (defun write-slot (new-value conc-name slot-name instance inlinep)
 220   (if inlinep
 221       (write-slot-inline new-value conc-name slot-name instance)
 222       (write-slot-notinline new-value conc-name slot-name instance)))
 223
 224 ;;; bound during the tests so that we can get to it even if the
 225 ;;; debugger is having a bad day
 226 (defvar *instance*)
 227
 228 (declaim (optimize (debug 2)))
 229
 230 (defmacro test-variant (defstructname &key colontype boa-constructor-p)
 231   `(progn
 232
 233      (format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
 234
 235      (defstruct (,defstructname
 236                   ,@(when colontype `((:type ,colontype)))
 237                   ,@(when boa-constructor-p
 238                           `((:constructor ,(symbol+ "CREATE-" defstructname)
 239                              (id
 240                               &optional
 241                               (optional-test 2 optional-test-p)
 242                               &key
 243                               (home nil home-p)
 244                               (no-home-comment "Home package CL not provided.")
 245                               (comment (if home-p "" no-home-comment))
 246                               (refcount (if optional-test-p optional-test nil))
 247                               hash
 248                               weight)))))
 249
 250        ;; some ordinary tagged slots
 251        id
 252        (home nil :type package :read-only t)
 253        (comment "" :type simple-string)
 254        ;; some raw slots
 255        (weight 1.0 :type single-float)
 256        (hash 1 :type (integer 1 #.(* 3 most-positive-fixnum)) :read-only t)
 257        ;; more ordinary tagged slots
 258        (refcount 0 :type (and unsigned-byte fixnum)))
 259
 260      (format t "~&/done with DEFSTRUCT~%")
 261
 262      (let* ((cn (string+ ',defstructname "-")) ; conc-name
 263             (ctor (symbol-function ',(symbol+ (if boa-constructor-p
 264                                                "CREATE-"
 265                                                "MAKE-")
 266                                              defstructname)))
 267             (*instance* (funcall ctor
 268                                  ,@(unless boa-constructor-p
 269                                            `(:id)) "some id"
 270                                  ,@(when boa-constructor-p
 271                                          '(1))
 272                                  :home (find-package :cl)
 273                                  :hash (+ 14 most-positive-fixnum)
 274                                  ,@(unless boa-constructor-p
 275                                            `(:refcount 1)))))
 276
 277        ;; Check that ctor set up slot values correctly.
 278        (format t "~&/checking constructed structure~%")
 279        (assert (string= "some id" (read-slot cn "ID" *instance*)))
 280        (assert (eql (find-package :cl) (read-slot cn "HOME" *instance*)))
 281        (assert (string= "" (read-slot cn "COMMENT" *instance*)))
 282        (assert (= 1.0 (read-slot cn "WEIGHT" *instance*)))
 283        (assert (eql (+ 14 most-positive-fixnum)
 284                     (read-slot cn "HASH" *instance*)))
 285        (assert (= 1 (read-slot cn "REFCOUNT" *instance*)))
 286
 287        ;; There should be no writers for read-only slots.
 288        (format t "~&/checking no read-only writers~%")
 289        (assert (not (fboundp `(setf ,(symbol+ cn "HOME")))))
 290        (assert (not (fboundp `(setf ,(symbol+ cn "HASH")))))
 291        ;; (Read-only slot values are checked in the loop below.)
 292
 293        (dolist (inlinep '(t nil))
 294          (format t "~&/doing INLINEP=~S~%" inlinep)
 295          ;; Fiddle with writable slot values.
 296          (let ((new-id (format nil "~S" (random 100)))
 297                (new-comment (format nil "~X" (random 5555)))
 298                (new-weight (random 10.0)))
 299            (write-slot new-id cn "ID" *instance* inlinep)
 300            (write-slot new-comment cn "COMMENT" *instance* inlinep)
 301            (write-slot new-weight cn "WEIGHT" *instance* inlinep)
 302            (assert (eql new-id (read-slot cn "ID" *instance*)))
 303            (assert (eql new-comment (read-slot cn "COMMENT" *instance*)))
 304            ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*))
 305            ;;  (error "WEIGHT mismatch: ~S vs. ~S"
 306            ;;         new-weight (read-slot cn "WEIGHT" *instance*)))
 307            (assert (eql new-weight (read-slot cn "WEIGHT" *instance*)))))
 308        (format t "~&/done with INLINEP loop~%")
 309
 310        ;; :TYPE FOO objects don't go in the Lisp type system, so we
 311        ;; can't test TYPEP stuff for them.
 312        ;;
 313        ;; FIXME: However, when they're named, they do define
 314        ;; predicate functions, and we could test those.
 315        ,@(unless colontype
 316            `(;; Fiddle with predicate function.
 317              (let ((pred-name (symbol+ ',defstructname "-P")))
 318                (format t "~&/doing tests on PRED-NAME=~S~%" pred-name)
 319                (assert (funcall pred-name *instance*))
 320                (assert (not (funcall pred-name 14)))
 321                (assert (not (funcall pred-name "test")))
 322                (assert (not (funcall pred-name (make-hash-table))))
 323                (let ((compiled-pred
 324                       (compile nil `(lambda (x) (,pred-name x)))))
 325                  (format t "~&/doing COMPILED-PRED tests~%")
 326                  (assert (funcall compiled-pred *instance*))
 327                  (assert (not (funcall compiled-pred 14)))
 328                  (assert (not (funcall compiled-pred #()))))
 329                ;; Fiddle with TYPEP.
 330                (format t "~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype)
 331                (assert (typep *instance* ',defstructname))
 332                (assert (not (typep 0 ',defstructname)))
 333                (assert (funcall (symbol+ "TYPEP") *instance* ',defstructname))
 334                (assert (not (funcall (symbol+ "TYPEP") nil ',defstructname)))
 335                (let* ((typename ',defstructname)
 336                       (compiled-typep
 337                        (compile nil `(lambda (x) (typep x ',typename)))))
 338                  (assert (funcall compiled-typep *instance*))
 339                  (assert (not (funcall compiled-typep nil))))))))
 340
 341      (format t "~&/done with PROGN for COLONTYPE=~S~%" ',colontype)))
 342
 343 (test-variant vanilla-struct)
 344 (test-variant vector-struct :colontype vector)
 345 (test-variant list-struct :colontype list)
 346 (test-variant vanilla-struct :boa-constructor-p t)
 347 (test-variant vector-struct :colontype vector :boa-constructor-p t)
 348 (test-variant list-struct :colontype list :boa-constructor-p t)
 349
 350 \f
 351 ;;;; testing raw slots harder
 352 ;;;;
 353 ;;;; The offsets of raw slots need to be rescaled during the punning
 354 ;;;; process which is used to access them. That seems like a good
 355 ;;;; place for errors to lurk, so we'll try hunting for them by
 356 ;;;; verifying that all the raw slot data gets written successfully
 357 ;;;; into the object, can be copied with the object, and can then be
 358 ;;;; read back out (with none of it ending up bogusly outside the
 359 ;;;; object, so that it couldn't be copied, or bogusly overwriting
 360 ;;;; some other raw slot).
 361
 362 (defstruct manyraw
 363   (a (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits))
 364   (b 0.1 :type single-float)
 365   (c 0.2d0 :type double-float)
 366   (d #c(0.3 0.3) :type (complex single-float))
 367   unraw-slot-just-for-variety
 368   (e #c(0.4d0 0.4d0) :type (complex double-float))
 369   (aa (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits))
 370   (bb 0.1 :type single-float)
 371   (cc 0.2d0 :type double-float)
 372   (dd #c(0.3 0.3) :type (complex single-float))
 373   (ee #c(0.4d0 0.4d0) :type (complex double-float)))
 374
 375 (defvar *manyraw* (make-manyraw))
 376
 377 (assert (eql (manyraw-a *manyraw*) (expt 2 30)))
 378 (assert (eql (manyraw-b *manyraw*) 0.1))
 379 (assert (eql (manyraw-c *manyraw*) 0.2d0))
 380 (assert (eql (manyraw-d *manyraw*) #c(0.3 0.3)))
 381 (assert (eql (manyraw-e *manyraw*) #c(0.4d0 0.4d0)))
 382 (assert (eql (manyraw-aa *manyraw*) (expt 2 30)))
 383 (assert (eql (manyraw-bb *manyraw*) 0.1))
 384 (assert (eql (manyraw-cc *manyraw*) 0.2d0))
 385 (assert (eql (manyraw-dd *manyraw*) #c(0.3 0.3)))
 386 (assert (eql (manyraw-ee *manyraw*) #c(0.4d0 0.4d0)))
 387
 388 (setf (manyraw-aa *manyraw*) (expt 2 31)
 389       (manyraw-bb *manyraw*) 0.11
 390       (manyraw-cc *manyraw*) 0.22d0
 391       (manyraw-dd *manyraw*) #c(0.33 0.33)
 392       (manyraw-ee *manyraw*) #c(0.44d0 0.44d0))
 393
 394 (let ((copy (copy-manyraw *manyraw*)))
 395   (assert (eql (manyraw-a copy) (expt 2 30)))
 396   (assert (eql (manyraw-b copy) 0.1))
 397   (assert (eql (manyraw-c copy) 0.2d0))
 398   (assert (eql (manyraw-d copy) #c(0.3 0.3)))
 399   (assert (eql (manyraw-e copy) #c(0.4d0 0.4d0)))
 400   (assert (eql (manyraw-aa copy) (expt 2 31)))
 401   (assert (eql (manyraw-bb copy) 0.11))
 402   (assert (eql (manyraw-cc copy) 0.22d0))
 403   (assert (eql (manyraw-dd copy) #c(0.33 0.33)))
 404   (assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0))))
 405
 406 \f
 407 ;;;; Since GC treats raw slots specially now, let's try this with more objects
 408 ;;;; and random values as a stress test.
 409
 410 (setf *manyraw* nil)
 411
 412 (defconstant +n-manyraw+ 10)
 413 (defconstant +m-manyraw+ 1000)
 414
 415 (defun check-manyraws (manyraws)
 416   (assert (eql (length manyraws) (* +n-manyraw+ +m-manyraw+)))
 417   (loop
 418       for m in (reverse manyraws)
 419       for i from 0
 420       do
 421         ;; Compare the tagged reference values with raw reffer results.
 422         (destructuring-bind (j a b c d e)
 423             (manyraw-unraw-slot-just-for-variety m)
 424           (assert (eql i j))
 425           (assert (= (manyraw-a m) a))
 426           (assert (= (manyraw-b m) b))
 427           (assert (= (manyraw-c m) c))
 428           (assert (= (manyraw-d m) d))
 429           (assert (= (manyraw-e m) e)))
 430         ;; Test the funny out-of-line OAOOM-style closures, too.
 431         (mapcar (lambda (fn value)
 432                   (assert (= (funcall fn m) value)))
 433                 (list #'manyraw-a
 434                       #'manyraw-b
 435                       #'manyraw-c
 436                       #'manyraw-d
 437                       #'manyraw-e)
 438                 (cdr (manyraw-unraw-slot-just-for-variety m)))))
 439
 440 (defstruct (manyraw-subclass (:include manyraw))
 441   (stolperstein 0 :type (unsigned-byte 32)))
 442
 443 ;;; create lots of manyraw objects, triggering GC every now and then
 444 (dotimes (y +n-manyraw+)
 445   (dotimes (x +m-manyraw+)
 446     (let ((a (random (expt 2 32)))
 447           (b (random most-positive-single-float))
 448           (c (random most-positive-double-float))
 449           (d (complex
 450               (random most-positive-single-float)
 451               (random most-positive-single-float)))
 452           (e (complex
 453               (random most-positive-double-float)
 454               (random most-positive-double-float))))
 455       (push (funcall (if (zerop (mod x 3))
 456                          #'make-manyraw-subclass
 457                          #'make-manyraw)
 458                      :unraw-slot-just-for-variety
 459                      (list (+ x (* y +m-manyraw+)) a b c d e)
 460                      :a a
 461                      :b b
 462                      :c c
 463                      :d d
 464                      :e e)
 465             *manyraw*)))
 466   (room)
 467   (sb-ext:gc))
 468 (with-test (:name :defstruct-raw-slot-gc)
 469   (check-manyraws *manyraw*))
 470
 471 ;;; try a full GC, too
 472 (sb-ext:gc :full t)
 473 (with-test (:name (:defstruct-raw-slot-gc :full))
 474   (check-manyraws *manyraw*))
 475
 476 ;;; fasl dumper and loader also have special handling of raw slots, so
 477 ;;; dump all of them into a fasl
 478 (defmethod make-load-form ((self manyraw) &optional env)
 479   self env
 480   :sb-just-dump-it-normally)
 481 (with-open-file (s "tmp-defstruct.manyraw.lisp"
 482                  :direction :output
 483                  :if-exists :supersede)
 484   (write-string "(defun dumped-manyraws () '#.*manyraw*)" s))
 485 (compile-file "tmp-defstruct.manyraw.lisp")
 486 (delete-file "tmp-defstruct.manyraw.lisp")
 487
 488 ;;; nuke the objects and try another GC just to be extra careful
 489 (setf *manyraw* nil)
 490 (sb-ext:gc :full t)
 491
 492 ;;; re-read the dumped structures and check them
 493 (load "tmp-defstruct.manyraw.fasl")
 494 (with-test (:name (:defstruct-raw-slot load))
 495   (check-manyraws (dumped-manyraws)))
 496
 497 \f
 498 ;;;; miscellaneous old bugs
 499
 500 (defstruct ya-struct)
 501 (when (ignore-errors (or (ya-struct-p) 12))
 502   (error "YA-STRUCT-P of no arguments should signal an error."))
 503 (when (ignore-errors (or (ya-struct-p 'too 'many 'arguments) 12))
 504   (error "YA-STRUCT-P of three arguments should signal an error."))
 505
 506 ;;; bug 210: Until sbcl-0.7.8.32 BOA constructors had SAFETY 0
 507 ;;; declared inside on the theory that slot types were already
 508 ;;; checked, which bogusly suppressed unbound-variable and other
 509 ;;; checks within the evaluation of initforms.
 510 (defvar *bug210*)
 511 (defstruct (bug210a (:constructor bug210a ()))
 512   (slot *bug210*))
 513 (defstruct bug210b
 514   (slot *bug210*))
 515 ;;; Because of bug 210, this assertion used to fail.
 516 (assert (typep (nth-value 1 (ignore-errors (bug210a))) 'unbound-variable))
 517 ;;; Even with bug 210, these assertions succeeded.
 518 (assert (typep (nth-value 1 (ignore-errors *bug210*)) 'unbound-variable))
 519 (assert (typep (nth-value 1 (ignore-errors (make-bug210b))) 'unbound-variable))
 520
 521 ;;; In sbcl-0.7.8.53, DEFSTRUCT blew up in non-toplevel contexts
 522 ;;; because it implicitly assumed that EVAL-WHEN (COMPILE) stuff
 523 ;;; setting up compiler-layout information would run before the
 524 ;;; constructor function installing the layout was compiled. Make sure
 525 ;;; that doesn't happen again.
 526 (defun foo-0-7-8-53 () (defstruct foo-0-7-8-53 x (y :not)))
 527 (assert (not (find-class 'foo-0-7-8-53 nil)))
 528 (foo-0-7-8-53)
 529 (assert (find-class 'foo-0-7-8-53 nil))
 530 (let ((foo-0-7-8-53 (make-foo-0-7-8-53 :x :s)))
 531   (assert (eq (foo-0-7-8-53-x foo-0-7-8-53) :s))
 532   (assert (eq (foo-0-7-8-53-y foo-0-7-8-53) :not)))
 533 \f
 534 ;;; tests of behaviour of colliding accessors.
 535 (defstruct (bug127-foo (:conc-name bug127-baz-)) a)
 536 (assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
 537 (defstruct (bug127-bar (:conc-name bug127-baz-) (:include bug127-foo)) b)
 538 (assert (= (bug127-baz-a (make-bug127-bar :a 1 :b 2)) 1))
 539 (assert (= (bug127-baz-b (make-bug127-bar :a 1 :b 2)) 2))
 540 (assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
 541
 542 (defun bug127-flurble (x)
 543   x)
 544 (defstruct bug127 flurble)
 545 (assert (= (bug127-flurble (make-bug127 :flurble 7)) 7))
 546
 547 (defstruct bug127-a b-c)
 548 (assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
 549 (defstruct (bug127-a-b (:include bug127-a)) c)
 550 (assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
 551 (assert (= (bug127-a-b-c (make-bug127-a-b :b-c 11 :c 13)) 11))
 552
 553 (defstruct (bug127-e (:conc-name bug127--)) foo)
 554 (assert (= (bug127--foo (make-bug127-e :foo 3)) 3))
 555 (defstruct (bug127-f (:conc-name bug127--)) foo)
 556 (assert (= (bug127--foo (make-bug127-f :foo 3)) 3))
 557 (assert-error (bug127--foo (make-bug127-e :foo 3)) type-error)
 558
 559 ;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE
 560 \f
 561 ;;; As noted by Paul Dietz for CMUCL, :CONC-NAME handling was a little
 562 ;;; too fragile:
 563 (defstruct (conc-name-syntax :conc-name) a-conc-name-slot)
 564 (assert (eq (a-conc-name-slot (make-conc-name-syntax :a-conc-name-slot 'y))
 565             'y))
 566 ;;; and further :CONC-NAME NIL was being wrongly treated:
 567 (defpackage "DEFSTRUCT-TEST-SCRATCH")
 568 (defstruct (conc-name-nil :conc-name)
 569   defstruct-test-scratch::conc-name-nil-slot)
 570 (assert (= (defstruct-test-scratch::conc-name-nil-slot
 571             (make-conc-name-nil :conc-name-nil-slot 1)) 1))
 572 (assert-error (conc-name-nil-slot (make-conc-name-nil))
 573               undefined-function)
 574 \f
 575 ;;; The named/typed predicates were a little fragile, in that they
 576 ;;; could throw errors on innocuous input:
 577 (defstruct (list-struct (:type list) :named) a-slot)
 578 (assert (list-struct-p (make-list-struct)))
 579 (assert (not (list-struct-p nil)))
 580 (assert (not (list-struct-p 1)))
 581 (defstruct (offset-list-struct (:type list) :named (:initial-offset 1)) a-slot)
 582 (assert (offset-list-struct-p (make-offset-list-struct)))
 583 (assert (not (offset-list-struct-p nil)))
 584 (assert (not (offset-list-struct-p 1)))
 585 (assert (not (offset-list-struct-p '(offset-list-struct))))
 586 (assert (not (offset-list-struct-p '(offset-list-struct . 3))))
 587 (defstruct (vector-struct (:type vector) :named) a-slot)
 588 (assert (vector-struct-p (make-vector-struct)))
 589 (assert (not (vector-struct-p nil)))
 590 (assert (not (vector-struct-p #())))
 591 \f
 592
 593 ;;; bug 3d: type safety with redefined type constraints on slots
 594 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
 595 (macrolet
 596     ((test (type)
 597        (let* ((base-name (intern (format nil "bug3d-~A" type)))
 598               (up-name (intern (format nil "~A-up" base-name)))
 599               (accessor (intern (format nil "~A-X" base-name)))
 600               (up-accessor (intern (format nil "~A-X" up-name)))
 601               (type-options (when type `((:type ,type)))))
 602          `(progn
 603             (defstruct (,base-name ,@type-options)
 604               x y)
 605             (defstruct (,up-name (:include ,base-name
 606                                   (x "x" :type simple-string)
 607                                   (y "y" :type simple-string))
 608                                  ,@type-options))
 609             (let ((ob (,(intern (format nil "MAKE-~A" up-name)))))
 610               (setf (,accessor ob) 0)
 611               (loop for decl in '(inline notinline)
 612                     for fun = `(lambda (s)
 613                                  (declare (optimize (safety 3))
 614                                           (,decl ,',up-accessor))
 615                                  (,',up-accessor s))
 616                     do (assert-error (funcall (compile nil fun) ob)
 617                                      type-error)))))))
 618   (test nil)
 619   (test list)
 620   (test vector))
 621
 622 (let* ((name (gensym))
 623        (form `(defstruct ,name
 624                 (x nil :type (or null (function (integer)
 625                                                 (values number &optional foo)))))))
 626   (eval (copy-tree form))
 627   (eval (copy-tree form)))
 628
 629 ;;; 322: "DEFSTRUCT :TYPE LIST predicate and improper lists"
 630 ;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP
 631 ;;; test suite.
 632 (defstruct (bug-332a (:type list) (:initial-offset 5) :named))
 633 (defstruct (bug-332b (:type list) (:initial-offset 2) :named (:include bug-332a)))
 634 (assert (not (bug-332b-p (list* nil nil nil nil nil 'foo73 nil 'tail))))
 635 (assert (not (bug-332b-p 873257)))
 636 (assert (not (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332a))))
 637 (assert (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332b)))
 638
 639 ;;; Similar test for vectors, just for good measure.
 640 (defstruct (bug-332a-aux (:type vector)
 641                          (:initial-offset 5) :named))
 642 (defstruct (bug-332b-aux (:type vector)
 643                          (:initial-offset 2) :named
 644                          (:include bug-332a-aux)))
 645 (assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 premature-end))))
 646 (assert (not (bug-332b-aux-p 873257)))
 647 (assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332a-aux))))
 648 (assert (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332b-aux)))
 649
 650 ;;; In sbcl-0.8.11.8 FBOUNDPness potential collisions of structure
 651 ;;; slot accessors signalled a condition at macroexpansion time, not
 652 ;;; when the code was actually compiled or loaded.
 653 (let ((defstruct-form '(defstruct bug-in-0-8-11-8 x)))
 654   (defun bug-in-0-8-11-8-x (z) (print "some unrelated thing"))
 655   (handler-case (macroexpand defstruct-form)
 656     (warning (c)
 657       (error "shouldn't warn just from macroexpansion here"))))
 658
 659 ;;; bug 318 symptom no 1. (rest not fixed yet)
 660 (catch :ok
 661   (handler-bind ((error (lambda (c)
 662                           ;; Used to cause stack-exhaustion
 663                           (unless (typep c 'storage-condition)
 664                             (throw :ok t)))))
 665     (eval '(progn
 666             (defstruct foo a)
 667             (setf (find-class 'foo) nil)
 668             (defstruct foo slot-1)))))
 669
 670 ;;; bug 348, evaluation order of slot writer arguments. Fixed by Gabor
 671 ;;; Melis.
 672 (defstruct bug-348 x)
 673
 674 (assert (eql -1 (let ((i (eval '-2))
 675                       (x (make-bug-348)))
 676                   (funcall #'(setf bug-348-x)
 677                            (incf i)
 678                            (aref (vector x) (incf i)))
 679                   (bug-348-x x))))
 680
 681 ;;; obsolete instance trapping
 682 ;;;
 683 ;;; FIXME: Both error conditions below should possibly be instances
 684 ;;; of the same class. (Putting this FIXME here, since this is the only
 685 ;;; place where they appear together.)
 686
 687 (with-test (:name :obsolete-defstruct/print-object)
 688   (eval '(defstruct born-to-change))
 689   (let ((x (make-born-to-change)))
 690     (handler-bind ((error 'continue))
 691       (eval '(defstruct born-to-change slot)))
 692     (assert (eq :error
 693                 (handler-case
 694                     (princ-to-string x)
 695                   (sb-pcl::obsolete-structure ()
 696                     :error))))))
 697
 698 (with-test (:name :obsolete-defstruct/typep)
 699   (eval '(defstruct born-to-change-2))
 700   (let ((x (make-born-to-change-2)))
 701     (handler-bind ((error 'continue))
 702       (eval '(defstruct born-to-change-2 slot)))
 703       (assert (eq :error2
 704                   (handler-case
 705                       (typep x (find-class 'standard-class))
 706                     (sb-kernel:layout-invalid ()
 707                       :error2))))))
 708
 709 ;; EQUALP didn't work for structures with float slots (reported by
 710 ;; Vjacheslav Fyodorov).
 711 (defstruct raw-slot-equalp-bug
 712   (b 0s0 :type single-float)
 713   c
 714   (a 0d0 :type double-float))
 715
 716 (defstruct raw-slot-equalp-bug-2
 717   (b (complex 1d0) :type (complex double-float))
 718   (x (complex 1d0) :type (complex double-float))
 719   c
 720   (a 1s0 :type single-float))
 721
 722 (with-test (:name :raw-slot-equalp)
 723   (assert (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0)
 724                   (make-raw-slot-equalp-bug :a 1d0 :b 2s0)))
 725   (assert (equalp (make-raw-slot-equalp-bug :a 1d0 :b 0s0)
 726                   (make-raw-slot-equalp-bug :a 1d0 :b -0s0)))
 727   (assert (not (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0)
 728                        (make-raw-slot-equalp-bug :a 1d0 :b 3s0))))
 729   (assert (not (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0)
 730                        (make-raw-slot-equalp-bug :a 2d0 :b 2s0))))
 731   (assert (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0)
 732                   (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0)))
 733   (assert (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 0s0)
 734                   (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a -0s0)))
 735   (assert (not (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0)
 736                        (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 3s0))))
 737   (assert (not (equalp (make-raw-slot-equalp-bug-2 :b (complex 1d0) :a 2s0)
 738                        (make-raw-slot-equalp-bug-2 :b (complex 2d0) :a 2s0)))))
 739
 740 ;;; Check that all slot types (non-raw and raw) can be initialized with
 741 ;;; constant arguments.
 742 (defstruct constant-arg-inits
 743   (a 42 :type t)
 744   (b 1 :type fixnum)
 745   (c 2 :type sb-vm:word)
 746   (d 3.0 :type single-float)
 747   (e 4.0d0 :type double-float)
 748   (f #c(5.0 5.0) :type (complex single-float))
 749   (g #c(6.0d0 6.0d0) :type (complex double-float)))
 750 (defun test-constant-arg-inits ()
 751   (let ((foo (make-constant-arg-inits)))
 752     (declare (dynamic-extent foo))
 753     (assert (eql 42 (constant-arg-inits-a foo)))
 754     (assert (eql 1 (constant-arg-inits-b foo)))
 755     (assert (eql 2 (constant-arg-inits-c foo)))
 756     (assert (eql 3.0 (constant-arg-inits-d foo)))
 757     (assert (eql 4.0d0 (constant-arg-inits-e foo)))
 758     (assert (eql #c(5.0 5.0) (constant-arg-inits-f foo)))
 759     (assert (eql #c(6.0d0 6.0d0) (constant-arg-inits-g foo)))))
 760 (make-constant-arg-inits)
 761
 762 ;;; bug reported by John Morrison, 2008-07-22 on sbcl-devel
 763 (defstruct (raw-slot-struct-with-unknown-init (:constructor make-raw-slot-struct-with-unknown-init ()))
 764  (x (#:unknown-function) :type double-float))
 765 \f
 766 ;;; Some checks for the behavior of incompatibly redefining structure
 767 ;;; classes.  We don't actually check that our detection of
 768 ;;; "incompatible" is comprehensive, only that if an incompatible
 769 ;;; definition is processed, we do various things.
 770 (defmacro with-files ((&rest vars) &body body)
 771   "Evaluate BODY with VARS bound to a number of filenames, then
 772 delete the files at the end."
 773   (let* ((paths (loop for var in vars
 774                       as index upfrom 0
 775                       collect (make-pathname
 776                                    :case :common
 777                                    :name (format nil
 778                                                  "DEFSTRUCT-REDEF-TEST-~D"
 779                                                  index)
 780                                    :type "LISP")))
 781          (binding-spec (mapcar
 782                         (lambda (var path) `(,var ,path)) vars paths)))
 783     (labels ((frob (n)
 784                `((unwind-protect
 785                      (progn
 786                        ,@(if (plusp n)
 787                              (frob (1- n))
 788                              body))
 789                    (delete-file ,(elt paths n))))))
 790       `(let ,binding-spec
 791          ,@(frob (1- (length vars)))))))
 792
 793 (defun noclobber (pathspec &rest forms)
 794   "Write FORMS to the file named by PATHSPEC, erroring if
 795 PATHSPEC already names an existing file."
 796   (with-open-file (*standard-output* pathspec :direction :output
 797                                      :if-exists :error)
 798     (print '(in-package "CL-USER"))
 799     (mapc #'print forms)))
 800
 801 (defun compile-file-assert (file &optional (want-error-p t) (want-warning-p t))
 802   "Compile FILE and assert some things about the results."
 803   (multiple-value-bind (fasl errors-p warnings-p)
 804       (compile-file file)
 805     (assert fasl)
 806     (assert (eq errors-p want-error-p))
 807     (assert (eq warnings-p want-warning-p))
 808     fasl))
 809
 810 (defun continue-from-incompatible-defstruct-error (error)
 811   "Invoke the CONTINUE restart for an incompatible DEFSTRUCT
 812 redefinition."
 813   ;; FIXME: want distinct error type for incompatible defstruct.
 814   (when (search "attempt to redefine" (simple-condition-format-control error))
 815     (when (find-restart 'continue)
 816       (invoke-restart 'continue))))
 817
 818 (defun recklessly-continue-from-incompatible-defstruct-error (error)
 819   "Invoke the RECKLESSLY-CONTINUE restart for an incompatible DEFSTRUCT
 820 redefinition."
 821   ;; FIXME: want distinct error type for incompatible defstruct.
 822   (when (search "attempt to redefine" (simple-condition-format-control error))
 823     (when (find-restart 'sb-kernel::recklessly-continue)
 824       (invoke-restart 'sb-kernel::recklessly-continue))))
 825
 826 (defun assert-is (predicate instance)
 827   (assert (funcall predicate instance)))
 828
 829 ;;; It used to call the predicate function, but out-of-line predicate
 830 ;;; functions now don't signal layout-invalid, just like inlined
 831 ;;; predicates didn't signal it.
 832 (defun assert-invalid (instance)
 833   (declare (notinline typep))
 834   (assert (typep (nth-value 1 (ignore-errors (typep instance 'structure-object)))
 835                  'sb-kernel::layout-invalid)))
 836
 837 ;; Don't try to understand this macro; just look at its expansion.
 838 (defmacro with-defstruct-redefinition-test (name
 839                                             (&rest defstruct-form-bindings)
 840                                             (&rest path-form-specs)
 841                                             handler-function
 842                                             &body body)
 843   (labels ((make-defstruct-form (&key class-name super-name slots)
 844              (let* ((predicate-name
 845                      (read-from-string (format nil "~A-p" class-name)))
 846                     (constructor-name
 847                      (read-from-string (format nil "make-~A" class-name))))
 848                `(values
 849                  '(defstruct (,class-name
 850                              (:constructor ,constructor-name)
 851                              ,@(when super-name
 852                                  `((:include ,super-name))))
 853                     ,@slots)
 854                  ',constructor-name
 855                  ',predicate-name)))
 856            (frob (bindspecs classno)
 857              (if bindspecs
 858                  `((multiple-value-bind ,(first (first bindspecs))
 859                        ,(apply #'make-defstruct-form (rest (first bindspecs)))
 860                      (declare (ignorable ,@(first (first bindspecs))))
 861                      ,@(frob (rest bindspecs) (1+ classno))))
 862                  `((with-files ,(mapcar #'first path-form-specs)
 863                      ,@(mapcar (lambda (path-form) `(noclobber ,@path-form))
 864                                path-form-specs)
 865                      (handler-bind
 866                          ((simple-error ',handler-function))
 867                        ,@body))))))
 868     `(with-test (:name ,name)
 869       ,(first (frob defstruct-form-bindings 0)))))
 870
 871 ;; When eyeballing these, it's helpful to see when various things are
 872 ;; happening.
 873 (setq *compile-verbose* t *load-verbose* t)
 874 \f
 875 ;;; Tests begin.
 876 ;; Base case: recklessly-continue.
 877 (with-defstruct-redefinition-test :defstruct/recklessly
 878     (((defstruct ctor pred) :class-name redef-test-1 :slots (a))
 879      ((defstruct*) :class-name redef-test-1 :slots (a b)))
 880     ((path1 defstruct)
 881      (path2 defstruct*))
 882     recklessly-continue-from-incompatible-defstruct-error
 883   (load path1)
 884   (let ((instance (funcall ctor)))
 885     (load path2)
 886     (assert-is pred instance)))
 887
 888 ;; Base case: continue (i.e., invalidate instances).
 889 (with-defstruct-redefinition-test :defstruct/continue
 890     (((defstruct ctor) :class-name redef-test-2 :slots (a))
 891      ((defstruct*) :class-name redef-test-2 :slots (a b)))
 892     ((path1 defstruct)
 893      (path2 defstruct*))
 894     continue-from-incompatible-defstruct-error
 895   (load path1)
 896   (let ((instance (funcall ctor)))
 897     (load path2)
 898     (assert-invalid instance)))
 899
 900 ;; Compiling a file with an incompatible defstruct should emit a
 901 ;; warning and an error, but the fasl should be loadable.
 902 (with-defstruct-redefinition-test :defstruct/compile-file-should-warn
 903     (((defstruct) :class-name redef-test-3 :slots (a))
 904      ((defstruct*) :class-name redef-test-3 :slots (a b)))
 905     ((path1 defstruct)
 906      (path2 defstruct*))
 907     continue-from-incompatible-defstruct-error
 908   (load path1)
 909   (load (compile-file-assert path2)))
 910
 911 ;; After compiling a file with an incompatible DEFSTRUCT, load the
 912 ;; fasl and ensure that an old instance remains valid.
 913 (with-defstruct-redefinition-test :defstruct/compile-file-reckless
 914     (((defstruct ctor pred) :class-name redef-test-4 :slots (a))
 915      ((defstruct*) :class-name redef-test-4 :slots (a b)))
 916     ((path1 defstruct)
 917      (path2 defstruct*))
 918     recklessly-continue-from-incompatible-defstruct-error
 919   (load path1)
 920   (let ((instance (funcall ctor)))
 921     (load (compile-file-assert path2))
 922     (assert-is pred instance)))
 923
 924 ;; After compiling a file with an incompatible DEFSTRUCT, load the
 925 ;; fasl and ensure that an old instance has become invalid.
 926 (with-defstruct-redefinition-test :defstruct/compile-file-continue
 927     (((defstruct ctor) :class-name redef-test-5 :slots (a))
 928      ((defstruct*) :class-name redef-test-5 :slots (a b)))
 929     ((path1 defstruct)
 930      (path2 defstruct*))
 931     continue-from-incompatible-defstruct-error
 932   (load path1)
 933   (let ((instance (funcall ctor)))
 934     (load (compile-file-assert path2))
 935     (assert-invalid instance)))
 936 \f
 937 ;;; Subclasses.
 938 ;; Ensure that recklessly continuing DT(expected)T to instances of
 939 ;; subclasses.  (This is a case where recklessly continuing is
 940 ;; actually dangerous, but we don't care.)
 941 (with-defstruct-redefinition-test :defstruct/subclass-reckless
 942     (((defstruct ignore pred1) :class-name redef-test-6 :slots (a))
 943      ((substruct ctor pred2) :class-name redef-test-6-sub
 944                              :super-name redef-test-6 :slots (z))
 945      ((defstruct*) :class-name redef-test-6 :slots (a b)))
 946     ((path1 defstruct substruct)
 947      (path2 defstruct* substruct))
 948     recklessly-continue-from-incompatible-defstruct-error
 949   (load path1)
 950   (let ((instance (funcall ctor)))
 951     (load (compile-file-assert path2))
 952     (assert-is pred1 instance)
 953     (assert-is pred2 instance)))
 954
 955 ;; Ensure that continuing invalidates instances of subclasses.
 956 (with-defstruct-redefinition-test :defstruct/subclass-continue
 957     (((defstruct) :class-name redef-test-7 :slots (a))
 958      ((substruct ctor) :class-name redef-test-7-sub
 959                             :super-name redef-test-7 :slots (z))
 960      ((defstruct*) :class-name redef-test-7 :slots (a b)))
 961     ((path1 defstruct substruct)
 962      (path2 defstruct* substruct))
 963     continue-from-incompatible-defstruct-error
 964   (load path1)
 965   (let ((instance (funcall ctor)))
 966     (load (compile-file-assert path2))
 967     (assert-invalid instance)))
 968
 969 ;; Reclkessly continuing doesn't invalidate instances of subclasses.
 970 (with-defstruct-redefinition-test :defstruct/subclass-in-other-file-reckless
 971     (((defstruct ignore pred1) :class-name redef-test-8 :slots (a))
 972      ((substruct ctor pred2) :class-name redef-test-8-sub
 973                              :super-name redef-test-8 :slots (z))
 974      ((defstruct*) :class-name redef-test-8 :slots (a b)))
 975     ((path1 defstruct)
 976      (path2 substruct)
 977      (path3 defstruct*))
 978     recklessly-continue-from-incompatible-defstruct-error
 979   (load path1)
 980   (load path2)
 981   (let ((instance (funcall ctor)))
 982     (load (compile-file-assert path3))
 983     (assert-is pred1 instance)
 984     (assert-is pred2 instance)))
 985
 986 ;; This is an icky case: when a subclass is defined in a separate
 987 ;; file, CONTINUE'ing from LOAD of a file containing an incompatible
 988 ;; superclass definition leaves the predicates and accessors into the
 989 ;; subclass in a bad way until the subclass form is evaluated.
 990 (with-defstruct-redefinition-test :defstruct/subclass-in-other-file-continue
 991     (((defstruct ignore) :class-name redef-test-9 :slots (a))
 992      ((substruct ctor) :class-name redef-test-9-sub
 993                              :super-name redef-test-9 :slots (z))
 994      ((defstruct*) :class-name redef-test-9 :slots (a b)))
 995     ((path1 defstruct)
 996      (path2 substruct)
 997      (path3 defstruct*))
 998     continue-from-incompatible-defstruct-error
 999   (load path1)
1000   (load path2)
1001   (let ((instance (funcall ctor)))
1002     (load (compile-file-assert path3))
1003     ;; At this point, the instance of the subclass will not count as
1004     ;; an instance of the superclass or of the subclass, but PRED2's
1005     ;; predicate will error with "an obsolete structure accessor
1006     ;; function was called".
1007     (assert-invalid instance)
1008     (format t "~&~A~%" (nth-value 1 (ignore-errors (funcall pred2 instance))))
1009     ;; After loading PATH2, we'll get the desired LAYOUT-INVALID error.
1010     (load path2)
1011     (assert-invalid instance)))
1012
1013 ;; Some other subclass wrinkles have to do with splitting definitions
1014 ;; accross files and compiling and loading things in a funny order.
1015 (with-defstruct-redefinition-test
1016     :defstruct/subclass-in-other-file-funny-operation-order-continue
1017     (((defstruct ignore pred1) :class-name redef-test-10 :slots (a))
1018      ((substruct ctor pred2) :class-name redef-test-10-sub
1019                              :super-name redef-test-10 :slots (z))
1020      ((defstruct*) :class-name redef-test-10 :slots (a b)))
1021     ((path1 defstruct)
1022      (path2 substruct)
1023      (path3 defstruct*))
1024     continue-from-incompatible-defstruct-error
1025   (load path1)
1026   (load path2)
1027   (let ((instance (funcall ctor)))
1028     ;; First we clobber the compiler's layout for the superclass.
1029     (compile-file-assert path3)
1030     ;; Then we recompile the subclass definition (which generates a
1031     ;; warning about the compiled layout for the superclass being
1032     ;; incompatible with the loaded layout, because we haven't loaded
1033     ;; path3 since recompiling).
1034     (compile-file path2)
1035     ;; Ugh.  I don't want to think about loading these in the wrong
1036     ;; order.
1037     (load (compile-file-pathname path3))
1038     (load (compile-file-pathname path2))
1039     (assert-invalid instance)
1040     (assert-invalid instance)))
1041
1042 (with-defstruct-redefinition-test
1043     :defstruct/subclass-in-other-file-funny-operation-order-continue
1044     (((defstruct ignore pred1) :class-name redef-test-11 :slots (a))
1045      ((substruct ctor pred2) :class-name redef-test-11-sub
1046                              :super-name redef-test-11 :slots (z))
1047      ((defstruct*) :class-name redef-test-11 :slots (a b)))
1048     ((path1 defstruct)
1049      (path2 substruct)
1050      (path3 defstruct*))
1051     continue-from-incompatible-defstruct-error
1052   (load path1)
1053   (load path2)
1054   (let ((instance (funcall ctor)))
1055     ;; This clobbers the compiler's layout for REDEF-TEST-11.
1056     (compile-file-assert path3)
1057     ;; This recompiles REDEF-TEST-11-SUB, using the new REDEF-TEST-11
1058     ;; compiler-layout.
1059     (load (compile-file-pathname path2))
1060     ;; Note that because we haven't loaded PATH3, we haven't clobbered
1061     ;; the class's layout REDEF-TEST-11, so REDEF-11's predicate will
1062     ;; still work.  That's probably bad.
1063     (assert-is pred1 instance)
1064     (assert-is pred2 instance)))
1065
1066 (with-test (:name :raw-slot/circle-subst)
1067   ;; CIRCLE-SUBSTS used %INSTANCE-REF on raw slots
1068   (multiple-value-bind (list n)
1069       (eval '(progn
1070               (defstruct raw-slot/circle-subst
1071                 (x 0.0 :type single-float))
1072               (read-from-string "((#1=#S(raw-slot/circle-subst :x 2.7158911)))")))
1073     (destructuring-bind ((struct)) list
1074       (assert (raw-slot/circle-subst-p struct))
1075       (assert (eql 2.7158911 (raw-slot/circle-subst-x struct)))
1076       (assert (eql 45 n)))))
1077
1078 (defstruct (bug-3b (:constructor make-bug-3b (&aux slot)))
1079   (slot nil :type string))
1080
1081 (with-test (:name :bug-3b)
1082   (handler-case
1083       (progn
1084         (bug-3b-slot (make-bug-3b))
1085         (error "fail"))
1086     (type-error (e)
1087       (assert (eq 'string (type-error-expected-type e)))
1088       (assert (zerop (type-error-datum e))))))
1089
1090 (with-test (:name :defstruct-copier-typechecks-argument)
1091   (copy-person (make-astronaut :name "Neil"))
1092   (assert-error (copy-astronaut (make-person :name "Fred"))))
1093
1094 (with-test (:name :bug-528807)
1095   (let ((*evaluator-mode* :compile))
1096     (handler-bind ((style-warning #'error))
1097       (eval `(defstruct (bug-528807 (:constructor make-528807 (&aux x)))
1098                (x nil :type fixnum))))))
1099
1100 (with-test (:name :bug-520607)
1101   (assert-error
1102    (eval '(defstruct (typed-struct (:type list) (:predicate typed-struct-p))
1103            (a 42 :type fixnum))))
1104   ;; NIL is ok, though.
1105   (eval '(defstruct (typed-struct (:type list) (:predicate nil))
1106           (a 42 :type fixnum)))
1107
1108   ;; (:predicate) is not ok because absence of the argument does not mean
1109   ;; that the value of the option is NIL, as it must be for :typed un-:named.
1110   ;; ":predicate
1111   ;;  This option takes one argument ...
1112   ;;  If the argument is not supplied ... the name of the predicate is made
1113   ;;  by concatenating the name of the structure to the string "-P"
1114   ;;  If the argument is provided and is nil, no predicate is defined.
1115   ;;  ... if :type is supplied and :named is not supplied, then :predicate
1116   ;;  must either be unsupplied or have the value nil."
1117   ;;
1118   ;; The last piece says that the entire option must be unsupplied
1119   ;; or else "have the value NIL", and is preceded by a description of the
1120   ;; precise manner in which absence of an argument is not the same as nil.
1121   ;;
1122   (assert-error
1123    (eval '(defstruct (typed-struct2 (:type list) (:predicate))
1124            (a 42 :type fixnum)))))
1125
1126 (with-test (:name (:boa-supplied-p &optional))
1127   (handler-bind ((warning #'error))
1128     (eval `(defstruct (boa-supplied-p.1 (:constructor make-boa-supplied-p.1
1129                                             (&optional (bar t barp))))
1130              bar
1131              barp)))
1132   (let ((b1 (make-boa-supplied-p.1))
1133         (b2 (make-boa-supplied-p.1 t)))
1134     (assert (eq t (boa-supplied-p.1-bar b1)))
1135     (assert (eq t (boa-supplied-p.1-bar b2)))
1136     (assert (eq nil (boa-supplied-p.1-barp b1)))
1137     (assert (eq t (boa-supplied-p.1-barp b2)))))
1138
1139 (with-test (:name (:boa-supplied-p &key))
1140   (handler-bind ((warning #'error))
1141     (eval `(defstruct (boa-supplied-p.2 (:constructor make-boa-supplied-p.2
1142                                             (&key (bar t barp))))
1143              bar
1144              barp)))
1145   (let ((b1 (make-boa-supplied-p.2))
1146         (b2 (make-boa-supplied-p.2 :bar t)))
1147     (assert (eq t (boa-supplied-p.2-bar b1)))
1148     (assert (eq t (boa-supplied-p.2-bar b2)))
1149     (assert (eq nil (boa-supplied-p.2-barp b1)))
1150     (assert (eq t (boa-supplied-p.2-barp b2)))))
1151
1152 (defstruct structure-with-predicate)
1153 (defclass class-to-be-redefined () ())
1154 (let ((x (make-instance 'class-to-be-redefined)))
1155   (defun function-trampoline (fun) (funcall fun x)))
1156
1157 (with-test (:name (:struct-predicate :obsolete-instance))
1158   (defclass class-to-be-redefined () ((a :initarg :a :initform 1)))
1159   (function-trampoline #'structure-with-predicate-p))
1160
1161 (with-test (:name (:defstruct :not-toplevel-silent))
1162   (let ((sb-ext:*evaluator-mode* :compile))
1163     (handler-bind ((warning #'error))
1164      (eval `(let ()
1165               (defstruct defstruct-no-warning-not-at-toplevel bar))))))
1166
1167 (with-test (:name :bug-941102)
1168   (let ((test `((defstruct bug-941102)
1169                  (setf (find-class 'bug-941102-alias) (find-class 'bug-941102))
1170                  (setf (find-class 'bug-941102-alias) nil))))
1171     (multiple-value-bind (warn fail) (ctu:file-compile test :load t)
1172       (assert (not warn))
1173       (assert (not fail)))
1174     (multiple-value-bind (warn2 fail2) (ctu:file-compile test)
1175       (assert (not warn2))
1176       (assert (not fail2)))))
1177
1178 (with-test (:name (:defstruct :constant-slot-names))
1179   (defstruct defstruct-constant-slot-names t)
1180   (assert (= 3 (defstruct-constant-slot-names-t
1181                 (make-defstruct-constant-slot-names :t 3)))))
1182
1183 (with-test (:name (:defstruct :bogus-inherited-slot-specs))
1184   (defstruct flopsie a b c)
1185   (assert
1186    (handler-case (macroexpand '(defstruct (mopsie (:include flopsie (a 3) (z 9))) q))
1187      (error (c)
1188        (search "slot name Z not present" (write-to-string c :escape nil)))
1189      (:no-error (x) x nil)))
1190   (assert
1191    (handler-case (macroexpand '(defstruct (mopsie (:include flopsie (a 3) (a 'a))) q))
1192      (error (c)
1193        (search "slot name A specified more than once" (write-to-string c :escape nil)))
1194      (:no-error (x) x nil))))
1195
1196 (assert-error
1197  (defstruct bogus-aux.1 (:constructor make-bogus-aux.1 (&aux (a b c)))))
1198
1199 (with-test (:name (:defstruct :lexical-default))
1200   (let ((x 0)) (defstruct lexical-default (a (incf x)))
1201     (assert (= (lexical-default-a (make-lexical-default))
1202                x
1203                1))))
1204
1205 (with-test (:name (:defstruct :find-defstruct-description))
1206   (assert (null (sb-kernel:find-defstruct-description 'not-foo nil)))
1207
1208   (assert-error (sb-kernel:find-defstruct-description 'not-foo t)))
1209
1210 (defstruct (a-named-struct :named (:type vector)) a b c)
1211 (defstruct (a-kid-struct :named (:type vector) (:include a-named-struct)) n)
1212 (with-test (:name (:defstruct :named-typed-struct-subtype-pred))
1213   (let ((par (make-a-named-struct :b 6))
1214         (kid (make-a-kid-struct :n 5)))
1215     (assert (a-named-struct-p par))
1216     (assert (a-named-struct-p kid))
1217     (assert (not (a-kid-struct-p par)))
1218     (assert (a-kid-struct-p kid))))
1219
1220 (with-test (:name :defstruct-parse-strictly)
1221   (dolist (form
1222            '((defstruct (s :conc-name (:conc-name b1-)) x y)
1223              (defstruct (s :copier :copier) x y)
1224              (defstruct (s (:include) (:include)) x y)
1225              (defstruct (s (:initial-offset 2) (:initial-offset nil)) x y)
1226              (defstruct (s (:predicate nil) (:predicate foolp)) x y)
1227              (defstruct (s (:type list) (:type vector)) x y)
1228              ;; The :NAMED option requires that SYMBOL be a subtype of the
1229              ;; *supplied* element type (not the upgraded element-type).
1230              ;; Defining a subtype of the structure places another symbol in
1231              ;; the vector, and we can't anticipate what that will be.
1232              ;; [Though in practice it is somewhere between unlikely and
1233              ;; impossible that an implementation would be able to specialize
1234              ;; on only one particular symbol and not also allow any symbol]
1235              (defstruct (s (:type (vector (or (eql s) integer))) :named) x y)
1236              ))
1237     (assert-error (macroexpand form))))