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