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