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