tests/defstruct.impure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; While most of SBCL is derived from the CMU CL system, the test
   5 ;;;; files (like this one) were written from scratch after the fork
   6 ;;;; from CMU CL.
   7 ;;;;
   8 ;;;; This software is in the public domain and is provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  10 ;;;; more information.
  11
  12 (load "assertoid.lisp")
  13 (use-package "ASSERTOID")
  14 \f
  15 ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
  16
  17 ;;; Type mismatch of slot default init value isn't an error until the
  18 ;;; default init value is actually used. (The justification is
  19 ;;; somewhat bogus, but the requirement is clear.)
  20 (defstruct person age (name 007 :type string)) ; not an error until 007 used
  21 (make-person :name "James") ; not an error, 007 not used
  22 (assert (raises-error? (make-person) type-error))
  23 (assert (raises-error? (setf (person-name (make-person :name "Q")) 1)
  24                        type-error))
  25
  26 ;;; An &AUX variable in a boa-constructor without a default value
  27 ;;; means "do not initialize slot" and does not cause type error
  28 (declaim (notinline opaque-identity))
  29 (defun opaque-identity (x) x)
  30
  31 (defstruct (boa-saux (:constructor make-boa-saux (&aux a (b 3) (c))))
  32     (a #\! :type (integer 1 2))
  33     (b #\? :type (integer 3 4))
  34     (c #\# :type (integer 5 6)))
  35 (let ((s (make-boa-saux)))
  36   (locally (declare (optimize (safety 3))
  37                     (inline boa-saux-a))
  38     (assert (raises-error? (opaque-identity (boa-saux-a s)) type-error)))
  39   (setf (boa-saux-a s) 1)
  40   (setf (boa-saux-c s) 5)
  41   (assert (eql (boa-saux-a s) 1))
  42   (assert (eql (boa-saux-b s) 3))
  43   (assert (eql (boa-saux-c s) 5)))
  44                                         ; these two checks should be
  45                                         ; kept separated
  46 (let ((s (make-boa-saux)))
  47   (locally (declare (optimize (safety 0))
  48                     (inline boa-saux-a))
  49     (assert (eql (opaque-identity (boa-saux-a s)) 0)))
  50   (setf (boa-saux-a s) 1)
  51   (setf (boa-saux-c s) 5)
  52   (assert (eql (boa-saux-a s) 1))
  53   (assert (eql (boa-saux-b s) 3))
  54   (assert (eql (boa-saux-c s) 5)))
  55
  56 (let ((s (make-boa-saux)))
  57   (locally (declare (optimize (safety 3))
  58                     (notinline boa-saux-a))
  59     (assert (raises-error? (opaque-identity (boa-saux-a s)) type-error)))
  60   (setf (boa-saux-a s) 1)
  61   (setf (boa-saux-c s) 5)
  62   (assert (eql (boa-saux-a s) 1))
  63   (assert (eql (boa-saux-b s) 3))
  64   (assert (eql (boa-saux-c s) 5)))
  65
  66 ;;; basic inheritance
  67 (defstruct (astronaut (:include person)
  68                       (:conc-name astro-))
  69   helmet-size
  70   (favorite-beverage 'tang))
  71 (let ((x (make-astronaut :name "Buzz" :helmet-size 17.5)))
  72   (assert (equal (person-name x) "Buzz"))
  73   (assert (equal (astro-name x) "Buzz"))
  74   (assert (eql (astro-favorite-beverage x) 'tang))
  75   (assert (null (astro-age x))))
  76 (defstruct (ancient-astronaut (:include person (age 77)))
  77   helmet-size
  78   (favorite-beverage 'tang))
  79 (assert (eql (ancient-astronaut-age (make-ancient-astronaut :name "John")) 77))
  80
  81 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
  82 (defstruct (binop (:type list) :named (:initial-offset 2))
  83   (operator '? :type symbol)
  84   operand-1
  85   operand-2)
  86 (defstruct (annotated-binop (:type list)
  87                             (:initial-offset 3)
  88                             (:include binop))
  89   commutative associative identity)
  90 (assert (equal (make-annotated-binop :operator '*
  91                                      :operand-1 'x
  92                                      :operand-2 5
  93                                      :commutative t
  94                                      :associative t
  95                                      :identity 1)
  96                '(nil nil binop * x 5 nil nil nil t t 1)))
  97
  98 ;;; effect of :NAMED on :TYPE
  99 (defstruct (named-binop (:type list) :named)
 100   (operator '? :type symbol)
 101   operand-1
 102   operand-2)
 103 (let ((named-binop (make-named-binop :operator '+ :operand-1 'x :operand-2 5)))
 104   ;; The data representation is specified to look like this.
 105   (assert (equal named-binop '(named-binop + x 5)))
 106   ;; A meaningful NAMED-BINOP-P is defined.
 107   (assert (named-binop-p named-binop))
 108   (assert (named-binop-p (copy-list named-binop)))
 109   (assert (not (named-binop-p (cons 11 named-binop))))
 110   (assert (not (named-binop-p (find-package :cl)))))
 111
 112 ;;; example 1
 113 (defstruct town
 114   area
 115   watertowers
 116   (firetrucks 1 :type fixnum)
 117   population
 118   (elevation 5128 :read-only t))
 119 (let ((town1 (make-town :area 0 :watertowers 0)))
 120   (assert (town-p town1))
 121   (assert (not (town-p 1)))
 122   (assert (eql (town-area town1) 0))
 123   (assert (eql (town-elevation town1) 5128))
 124   (assert (null (town-population town1)))
 125   (setf (town-population town1) 99)
 126   (assert (eql (town-population town1) 99))
 127   (let ((town2 (copy-town town1)))
 128     (dolist (slot-accessor-name '(town-area
 129                                   town-watertowers
 130                                   town-firetrucks
 131                                   town-population
 132                                   town-elevation))
 133       (assert (eql (funcall slot-accessor-name town1)
 134                    (funcall slot-accessor-name town2))))
 135     (assert (not (fboundp '(setf town-elevation)))))) ; 'cause it's :READ-ONLY
 136
 137 ;;; example 2
 138 (defstruct (clown (:conc-name bozo-))
 139   (nose-color 'red)
 140   frizzy-hair-p
 141   polkadots)
 142 (let ((funny-clown (make-clown)))
 143   (assert (eql (bozo-nose-color funny-clown) 'red)))
 144 (defstruct (klown (:constructor make-up-klown)
 145                   (:copier clone-klown)
 146                   (:predicate is-a-bozo-p))
 147   nose-color
 148   frizzy-hair-p
 149   polkadots)
 150 (assert (is-a-bozo-p (make-up-klown)))
 151 \f
 152 ;;;; systematically testing variants of DEFSTRUCT:
 153 ;;;;   * native, :TYPE LIST, and :TYPE VECTOR
 154
 155 ;;; FIXME: things to test:
 156 ;;;   * Slot readers work.
 157 ;;;   * Slot writers work.
 158 ;;;   * Predicates work.
 159
 160 ;;; FIXME: things that would be nice to test systematically someday:
 161 ;;;   * constructors (default, boa..)
 162 ;;;   * copiers
 163 ;;;   * no type checks when (> SPEED SAFETY)
 164 ;;;   * Tests of inclusion would be good. (It's tested very lightly
 165 ;;;     above, and then tested a fair amount by the system compiling
 166 ;;;     itself.)
 167
 168 (defun string+ (&rest rest)
 169   (apply #'concatenate 'string
 170          (mapcar #'string rest)))
 171 (defun symbol+ (&rest rest)
 172   (values (intern (apply #'string+ rest))))
 173
 174 (defun accessor-name (conc-name slot-name)
 175   (symbol+ conc-name slot-name))
 176
 177 ;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions)
 178 ;;; to read and write a structure slot.
 179 (defun read-slot-notinline (conc-name slot-name instance)
 180   (funcall (accessor-name conc-name slot-name) instance))
 181 (defun write-slot-notinline (new-value conc-name slot-name instance)
 182   (funcall (fdefinition `(setf ,(accessor-name conc-name slot-name)))
 183            new-value instance))
 184
 185 ;;; Use inline expansions of slot accessors, if possible, to read and
 186 ;;; write a structure slot.
 187 (defun read-slot-inline (conc-name slot-name instance)
 188   (funcall (compile nil
 189                     `(lambda (instance)
 190                        (,(accessor-name conc-name slot-name) instance)))
 191            instance))
 192 (defun write-slot-inline (new-value conc-name slot-name instance)
 193   (funcall (compile nil
 194                     `(lambda (new-value instance)
 195                        (setf (,(accessor-name conc-name slot-name) instance)
 196                              new-value)))
 197            new-value
 198            instance))
 199
 200 ;;; Read a structure slot, checking that the inline and out-of-line
 201 ;;; accessors give the same result.
 202 (defun read-slot (conc-name slot-name instance)
 203   (let ((inline-value (read-slot-inline conc-name slot-name instance))
 204         (notinline-value (read-slot-notinline conc-name slot-name instance)))
 205     (assert (eql inline-value notinline-value))
 206     inline-value))
 207
 208 ;;; Write a structure slot, using INLINEP argument to decide
 209 ;;; on inlineness of accessor used.
 210 (defun write-slot (new-value conc-name slot-name instance inlinep)
 211   (if inlinep
 212       (write-slot-inline new-value conc-name slot-name instance)
 213       (write-slot-notinline new-value conc-name slot-name instance)))
 214
 215 ;;; bound during the tests so that we can get to it even if the
 216 ;;; debugger is having a bad day
 217 (defvar *instance*)
 218
 219 (declaim (optimize (debug 2)))
 220
 221 (defmacro test-variant (defstructname &key colontype boa-constructor-p)
 222   `(progn
 223
 224      (format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
 225
 226      (defstruct (,defstructname
 227                   ,@(when colontype `((:type ,colontype)))
 228                   ,@(when boa-constructor-p
 229                           `((:constructor ,(symbol+ "CREATE-" defstructname)
 230                              (id
 231                               &optional
 232                               (optional-test 2 optional-test-p)
 233                               &key
 234                               (home nil home-p)
 235                               (no-home-comment "Home package CL not provided.")
 236                               (comment (if home-p "" no-home-comment))
 237                               (refcount (if optional-test-p optional-test nil))
 238                               hash
 239                               weight)))))
 240
 241        ;; some ordinary tagged slots
 242        id
 243        (home nil :type package :read-only t)
 244        (comment "" :type simple-string)
 245        ;; some raw slots
 246        (weight 1.0 :type single-float)
 247        (hash 1 :type (integer 1 #.(* 3 most-positive-fixnum)) :read-only t)
 248        ;; more ordinary tagged slots
 249        (refcount 0 :type (and unsigned-byte fixnum)))
 250
 251      (format t "~&/done with DEFSTRUCT~%")
 252
 253      (let* ((cn (string+ ',defstructname "-")) ; conc-name
 254             (ctor (symbol-function ',(symbol+ (if boa-constructor-p
 255                                                "CREATE-"
 256                                                "MAKE-")
 257                                              defstructname)))
 258             (*instance* (funcall ctor
 259                                  ,@(unless boa-constructor-p
 260                                            `(:id)) "some id"
 261                                  ,@(when boa-constructor-p
 262                                          '(1))
 263                                  :home (find-package :cl)
 264                                  :hash (+ 14 most-positive-fixnum)
 265                                  ,@(unless boa-constructor-p
 266                                            `(:refcount 1)))))
 267
 268        ;; Check that ctor set up slot values correctly.
 269        (format t "~&/checking constructed structure~%")
 270        (assert (string= "some id" (read-slot cn "ID" *instance*)))
 271        (assert (eql (find-package :cl) (read-slot cn "HOME" *instance*)))
 272        (assert (string= "" (read-slot cn "COMMENT" *instance*)))
 273        (assert (= 1.0 (read-slot cn "WEIGHT" *instance*)))
 274        (assert (eql (+ 14 most-positive-fixnum)
 275                     (read-slot cn "HASH" *instance*)))
 276        (assert (= 1 (read-slot cn "REFCOUNT" *instance*)))
 277
 278        ;; There should be no writers for read-only slots.
 279        (format t "~&/checking no read-only writers~%")
 280        (assert (not (fboundp `(setf ,(symbol+ cn "HOME")))))
 281        (assert (not (fboundp `(setf ,(symbol+ cn "HASH")))))
 282        ;; (Read-only slot values are checked in the loop below.)
 283
 284        (dolist (inlinep '(t nil))
 285          (format t "~&/doing INLINEP=~S~%" inlinep)
 286          ;; Fiddle with writable slot values.
 287          (let ((new-id (format nil "~S" (random 100)))
 288                (new-comment (format nil "~X" (random 5555)))
 289                (new-weight (random 10.0)))
 290            (write-slot new-id cn "ID" *instance* inlinep)
 291            (write-slot new-comment cn "COMMENT" *instance* inlinep)
 292            (write-slot new-weight cn "WEIGHT" *instance* inlinep)
 293            (assert (eql new-id (read-slot cn "ID" *instance*)))
 294            (assert (eql new-comment (read-slot cn "COMMENT" *instance*)))
 295            ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*))
 296            ;;  (error "WEIGHT mismatch: ~S vs. ~S"
 297            ;;         new-weight (read-slot cn "WEIGHT" *instance*)))
 298            (assert (eql new-weight (read-slot cn "WEIGHT" *instance*)))))
 299        (format t "~&/done with INLINEP loop~%")
 300
 301        ;; :TYPE FOO objects don't go in the Lisp type system, so we
 302        ;; can't test TYPEP stuff for them.
 303        ;;
 304        ;; FIXME: However, when they're named, they do define
 305        ;; predicate functions, and we could test those.
 306        ,@(unless colontype
 307            `(;; Fiddle with predicate function.
 308              (let ((pred-name (symbol+ ',defstructname "-P")))
 309                (format t "~&/doing tests on PRED-NAME=~S~%" pred-name)
 310                (assert (funcall pred-name *instance*))
 311                (assert (not (funcall pred-name 14)))
 312                (assert (not (funcall pred-name "test")))
 313                (assert (not (funcall pred-name (make-hash-table))))
 314                (let ((compiled-pred
 315                       (compile nil `(lambda (x) (,pred-name x)))))
 316                  (format t "~&/doing COMPILED-PRED tests~%")
 317                  (assert (funcall compiled-pred *instance*))
 318                  (assert (not (funcall compiled-pred 14)))
 319                  (assert (not (funcall compiled-pred #()))))
 320                ;; Fiddle with TYPEP.
 321                (format t "~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype)
 322                (assert (typep *instance* ',defstructname))
 323                (assert (not (typep 0 ',defstructname)))
 324                (assert (funcall (symbol+ "TYPEP") *instance* ',defstructname))
 325                (assert (not (funcall (symbol+ "TYPEP") nil ',defstructname)))
 326                (let* ((typename ',defstructname)
 327                       (compiled-typep
 328                        (compile nil `(lambda (x) (typep x ',typename)))))
 329                  (assert (funcall compiled-typep *instance*))
 330                  (assert (not (funcall compiled-typep nil))))))))
 331
 332      (format t "~&/done with PROGN for COLONTYPE=~S~%" ',colontype)))
 333
 334 (test-variant vanilla-struct)
 335 (test-variant vector-struct :colontype vector)
 336 (test-variant list-struct :colontype list)
 337 (test-variant vanilla-struct :boa-constructor-p t)
 338 (test-variant vector-struct :colontype vector :boa-constructor-p t)
 339 (test-variant list-struct :colontype list :boa-constructor-p t)
 340
 341 \f
 342 ;;;; testing raw slots harder
 343 ;;;;
 344 ;;;; The offsets of raw slots need to be rescaled during the punning
 345 ;;;; process which is used to access them. That seems like a good
 346 ;;;; place for errors to lurk, so we'll try hunting for them by
 347 ;;;; verifying that all the raw slot data gets written successfully
 348 ;;;; into the object, can be copied with the object, and can then be
 349 ;;;; read back out (with none of it ending up bogusly outside the
 350 ;;;; object, so that it couldn't be copied, or bogusly overwriting
 351 ;;;; some other raw slot).
 352
 353 (defstruct manyraw
 354   (a (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits))
 355   (b 0.1 :type single-float)
 356   (c 0.2d0 :type double-float)
 357   (d #c(0.3 0.3) :type (complex single-float))
 358   unraw-slot-just-for-variety
 359   (e #c(0.4d0 0.4d0) :type (complex double-float))
 360   (aa (expt 2 30) :type (unsigned-byte #.sb-vm:n-word-bits))
 361   (bb 0.1 :type single-float)
 362   (cc 0.2d0 :type double-float)
 363   (dd #c(0.3 0.3) :type (complex single-float))
 364   (ee #c(0.4d0 0.4d0) :type (complex double-float)))
 365
 366 (defvar *manyraw* (make-manyraw))
 367
 368 (assert (eql (manyraw-a *manyraw*) (expt 2 30)))
 369 (assert (eql (manyraw-b *manyraw*) 0.1))
 370 (assert (eql (manyraw-c *manyraw*) 0.2d0))
 371 (assert (eql (manyraw-d *manyraw*) #c(0.3 0.3)))
 372 (assert (eql (manyraw-e *manyraw*) #c(0.4d0 0.4d0)))
 373 (assert (eql (manyraw-aa *manyraw*) (expt 2 30)))
 374 (assert (eql (manyraw-bb *manyraw*) 0.1))
 375 (assert (eql (manyraw-cc *manyraw*) 0.2d0))
 376 (assert (eql (manyraw-dd *manyraw*) #c(0.3 0.3)))
 377 (assert (eql (manyraw-ee *manyraw*) #c(0.4d0 0.4d0)))
 378
 379 (setf (manyraw-aa *manyraw*) (expt 2 31)
 380       (manyraw-bb *manyraw*) 0.11
 381       (manyraw-cc *manyraw*) 0.22d0
 382       (manyraw-dd *manyraw*) #c(0.33 0.33)
 383       (manyraw-ee *manyraw*) #c(0.44d0 0.44d0))
 384
 385 (let ((copy (copy-manyraw *manyraw*)))
 386   (assert (eql (manyraw-a copy) (expt 2 30)))
 387   (assert (eql (manyraw-b copy) 0.1))
 388   (assert (eql (manyraw-c copy) 0.2d0))
 389   (assert (eql (manyraw-d copy) #c(0.3 0.3)))
 390   (assert (eql (manyraw-e copy) #c(0.4d0 0.4d0)))
 391   (assert (eql (manyraw-aa copy) (expt 2 31)))
 392   (assert (eql (manyraw-bb copy) 0.11))
 393   (assert (eql (manyraw-cc copy) 0.22d0))
 394   (assert (eql (manyraw-dd copy) #c(0.33 0.33)))
 395   (assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0))))
 396
 397 \f
 398 ;;;; Since GC treats raw slots specially now, let's try this with more objects
 399 ;;;; and random values as a stress test.
 400
 401 (setf *manyraw* nil)
 402
 403 (defconstant +n-manyraw+ 10)
 404 (defconstant +m-manyraw+ 1000)
 405
 406 (defun check-manyraws (manyraws)
 407   (assert (eql (length manyraws) (* +n-manyraw+ +m-manyraw+)))
 408   (loop
 409       for m in (reverse manyraws)
 410       for i from 0
 411       do
 412         ;; Compare the tagged reference values with raw reffer results.
 413         (destructuring-bind (j a b c d e)
 414             (manyraw-unraw-slot-just-for-variety m)
 415           (assert (eql i j))
 416           (assert (= (manyraw-a m) a))
 417           (assert (= (manyraw-b m) b))
 418           (assert (= (manyraw-c m) c))
 419           (assert (= (manyraw-d m) d))
 420           (assert (= (manyraw-e m) e)))
 421         ;; Test the funny out-of-line OAOOM-style closures, too.
 422         (mapcar (lambda (fn value)
 423                   (assert (= (funcall fn m) value)))
 424                 (list #'manyraw-a
 425                       #'manyraw-b
 426                       #'manyraw-c
 427                       #'manyraw-d
 428                       #'manyraw-e)
 429                 (cdr (manyraw-unraw-slot-just-for-variety m)))))
 430
 431 (defstruct (manyraw-subclass (:include manyraw))
 432   (stolperstein 0 :type (unsigned-byte 32)))
 433
 434 ;;; create lots of manyraw objects, triggering GC every now and then
 435 (dotimes (y +n-manyraw+)
 436   (dotimes (x +m-manyraw+)
 437     (let ((a (random (expt 2 32)))
 438           (b (random most-positive-single-float))
 439           (c (random most-positive-double-float))
 440           (d (complex
 441               (random most-positive-single-float)
 442               (random most-positive-single-float)))
 443           (e (complex
 444               (random most-positive-double-float)
 445               (random most-positive-double-float))))
 446       (push (funcall (if (zerop (mod x 3))
 447                          #'make-manyraw-subclass
 448                          #'make-manyraw)
 449                      :unraw-slot-just-for-variety
 450                      (list (+ x (* y +m-manyraw+)) a b c d e)
 451                      :a a
 452                      :b b
 453                      :c c
 454                      :d d
 455                      :e e)
 456             *manyraw*)))
 457   (room)
 458   (sb-ext:gc))
 459 (check-manyraws *manyraw*)
 460
 461 ;;; try a full GC, too
 462 (sb-ext:gc :full t)
 463 (check-manyraws *manyraw*)
 464
 465 ;;; fasl dumper and loader also have special handling of raw slots, so
 466 ;;; dump all of them into a fasl
 467 (defmethod make-load-form ((self manyraw) &optional env)
 468   self env
 469   :sb-just-dump-it-normally)
 470 (with-open-file (s "tmp-defstruct.manyraw.lisp"
 471                  :direction :output
 472                  :if-exists :supersede)
 473   (write-string "(defun dumped-manyraws () '#.*manyraw*)" s))
 474 (compile-file "tmp-defstruct.manyraw.lisp")
 475 (delete-file "tmp-defstruct.manyraw.lisp")
 476
 477 ;;; nuke the objects and try another GC just to be extra careful
 478 (setf *manyraw* nil)
 479 (sb-ext:gc :full t)
 480
 481 ;;; re-read the dumped structures and check them
 482 (load "tmp-defstruct.manyraw.fasl")
 483 (check-manyraws (dumped-manyraws))
 484
 485 \f
 486 ;;;; miscellaneous old bugs
 487
 488 (defstruct ya-struct)
 489 (when (ignore-errors (or (ya-struct-p) 12))
 490   (error "YA-STRUCT-P of no arguments should signal an error."))
 491 (when (ignore-errors (or (ya-struct-p 'too 'many 'arguments) 12))
 492   (error "YA-STRUCT-P of three arguments should signal an error."))
 493
 494 ;;; bug 210: Until sbcl-0.7.8.32 BOA constructors had SAFETY 0
 495 ;;; declared inside on the theory that slot types were already
 496 ;;; checked, which bogusly suppressed unbound-variable and other
 497 ;;; checks within the evaluation of initforms.
 498 (defvar *bug210*)
 499 (defstruct (bug210a (:constructor bug210a ()))
 500   (slot *bug210*))
 501 (defstruct bug210b
 502   (slot *bug210*))
 503 ;;; Because of bug 210, this assertion used to fail.
 504 (assert (typep (nth-value 1 (ignore-errors (bug210a))) 'unbound-variable))
 505 ;;; Even with bug 210, these assertions succeeded.
 506 (assert (typep (nth-value 1 (ignore-errors *bug210*)) 'unbound-variable))
 507 (assert (typep (nth-value 1 (ignore-errors (make-bug210b))) 'unbound-variable))
 508
 509 ;;; In sbcl-0.7.8.53, DEFSTRUCT blew up in non-toplevel contexts
 510 ;;; because it implicitly assumed that EVAL-WHEN (COMPILE) stuff
 511 ;;; setting up compiler-layout information would run before the
 512 ;;; constructor function installing the layout was compiled. Make sure
 513 ;;; that doesn't happen again.
 514 (defun foo-0-7-8-53 () (defstruct foo-0-7-8-53 x (y :not)))
 515 (assert (not (find-class 'foo-0-7-8-53 nil)))
 516 (foo-0-7-8-53)
 517 (assert (find-class 'foo-0-7-8-53 nil))
 518 (let ((foo-0-7-8-53 (make-foo-0-7-8-53 :x :s)))
 519   (assert (eq (foo-0-7-8-53-x foo-0-7-8-53) :s))
 520   (assert (eq (foo-0-7-8-53-y foo-0-7-8-53) :not)))
 521 \f
 522 ;;; tests of behaviour of colliding accessors.
 523 (defstruct (bug127-foo (:conc-name bug127-baz-)) a)
 524 (assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
 525 (defstruct (bug127-bar (:conc-name bug127-baz-) (:include bug127-foo)) b)
 526 (assert (= (bug127-baz-a (make-bug127-bar :a 1 :b 2)) 1))
 527 (assert (= (bug127-baz-b (make-bug127-bar :a 1 :b 2)) 2))
 528 (assert (= (bug127-baz-a (make-bug127-foo :a 1)) 1))
 529
 530 (defun bug127-flurble (x)
 531   x)
 532 (defstruct bug127 flurble)
 533 (assert (= (bug127-flurble (make-bug127 :flurble 7)) 7))
 534
 535 (defstruct bug127-a b-c)
 536 (assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
 537 (defstruct (bug127-a-b (:include bug127-a)) c)
 538 (assert (= (bug127-a-b-c (make-bug127-a :b-c 9)) 9))
 539 (assert (= (bug127-a-b-c (make-bug127-a-b :b-c 11 :c 13)) 11))
 540
 541 (defstruct (bug127-e (:conc-name bug127--)) foo)
 542 (assert (= (bug127--foo (make-bug127-e :foo 3)) 3))
 543 (defstruct (bug127-f (:conc-name bug127--)) foo)
 544 (assert (= (bug127--foo (make-bug127-f :foo 3)) 3))
 545 (assert (raises-error? (bug127--foo (make-bug127-e :foo 3)) type-error))
 546
 547 ;;; FIXME: should probably do the same tests on DEFSTRUCT :TYPE
 548 \f
 549 ;;; As noted by Paul Dietz for CMUCL, :CONC-NAME handling was a little
 550 ;;; too fragile:
 551 (defstruct (conc-name-syntax :conc-name) a-conc-name-slot)
 552 (assert (eq (a-conc-name-slot (make-conc-name-syntax :a-conc-name-slot 'y))
 553             'y))
 554 ;;; and further :CONC-NAME NIL was being wrongly treated:
 555 (defpackage "DEFSTRUCT-TEST-SCRATCH")
 556 (defstruct (conc-name-nil :conc-name)
 557   defstruct-test-scratch::conc-name-nil-slot)
 558 (assert (= (defstruct-test-scratch::conc-name-nil-slot
 559             (make-conc-name-nil :conc-name-nil-slot 1)) 1))
 560 (assert (raises-error? (conc-name-nil-slot (make-conc-name-nil))
 561                        undefined-function))
 562 \f
 563 ;;; The named/typed predicates were a little fragile, in that they
 564 ;;; could throw errors on innocuous input:
 565 (defstruct (list-struct (:type list) :named) a-slot)
 566 (assert (list-struct-p (make-list-struct)))
 567 (assert (not (list-struct-p nil)))
 568 (assert (not (list-struct-p 1)))
 569 (defstruct (offset-list-struct (:type list) :named (:initial-offset 1)) a-slot)
 570 (assert (offset-list-struct-p (make-offset-list-struct)))
 571 (assert (not (offset-list-struct-p nil)))
 572 (assert (not (offset-list-struct-p 1)))
 573 (assert (not (offset-list-struct-p '(offset-list-struct))))
 574 (assert (not (offset-list-struct-p '(offset-list-struct . 3))))
 575 (defstruct (vector-struct (:type vector) :named) a-slot)
 576 (assert (vector-struct-p (make-vector-struct)))
 577 (assert (not (vector-struct-p nil)))
 578 (assert (not (vector-struct-p #())))
 579 \f
 580 ;;; bug 3d: type safety with redefined type constraints on slots
 581 (macrolet
 582     ((test (type)
 583        (let* ((base-name (intern (format nil "bug3d-~A" type)))
 584               (up-name (intern (format nil "~A-up" base-name)))
 585               (accessor (intern (format nil "~A-X" base-name)))
 586               (up-accessor (intern (format nil "~A-X" up-name)))
 587               (type-options (when type `((:type ,type)))))
 588          `(progn
 589             (defstruct (,base-name ,@type-options)
 590               x y)
 591             (defstruct (,up-name (:include ,base-name
 592                                            (x "x" :type simple-string)
 593                                            (y "y" :type simple-string))
 594                                  ,@type-options))
 595             (let ((ob (,(intern (format nil "MAKE-~A" up-name)))))
 596               (setf (,accessor ob) 0)
 597               (loop for decl in '(inline notinline)
 598                     for fun = `(lambda (s)
 599                                  (declare (optimize (safety 3))
 600                                           (,decl ,',up-accessor))
 601                                  (,',up-accessor s))
 602                     do (assert (raises-error? (funcall (compile nil fun) ob)
 603                                               type-error))))))))
 604   (test nil)
 605   (test list)
 606   (test vector))
 607
 608 (let* ((name (gensym))
 609        (form `(defstruct ,name
 610                 (x nil :type (or null (function (integer)
 611                                                 (values number &optional foo)))))))
 612   (eval (copy-tree form))
 613   (eval (copy-tree form)))
 614
 615 ;;; 322: "DEFSTRUCT :TYPE LIST predicate and improper lists"
 616 ;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP
 617 ;;; test suite.
 618 (defstruct (bug-332a (:type list) (:initial-offset 5) :named))
 619 (defstruct (bug-332b (:type list) (:initial-offset 2) :named (:include bug-332a)))
 620 (assert (not (bug-332b-p (list* nil nil nil nil nil 'foo73 nil 'tail))))
 621 (assert (not (bug-332b-p 873257)))
 622 (assert (not (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332a))))
 623 (assert (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332b)))
 624
 625 ;;; Similar test for vectors, just for good measure.
 626 (defstruct (bug-332a-aux (:type vector)
 627                          (:initial-offset 5) :named))
 628 (defstruct (bug-332b-aux (:type vector)
 629                          (:initial-offset 2) :named
 630                          (:include bug-332a-aux)))
 631 (assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 premature-end))))
 632 (assert (not (bug-332b-aux-p 873257)))
 633 (assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332a-aux))))
 634 (assert (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332b-aux)))
 635
 636 ;;; In sbcl-0.8.11.8 FBOUNDPness potential collisions of structure
 637 ;;; slot accessors signalled a condition at macroexpansion time, not
 638 ;;; when the code was actually compiled or loaded.
 639 (let ((defstruct-form '(defstruct bug-in-0-8-11-8 x)))
 640   (defun bug-in-0-8-11-8-x (z) (print "some unrelated thing"))
 641   (handler-case (macroexpand defstruct-form)
 642     (warning (c)
 643       (error "shouldn't warn just from macroexpansion here"))))
 644
 645 ;;; bug 318 symptom no 1. (rest not fixed yet)
 646 (catch :ok
 647   (handler-bind ((error (lambda (c)
 648                           ;; Used to cause stack-exhaustion
 649                           (unless (typep c 'storage-condition)
 650                             (throw :ok t)))))
 651     (eval '(progn
 652             (defstruct foo a)
 653             (setf (find-class 'foo) nil)
 654             (defstruct foo slot-1)))))
 655
 656 ;;; bug 348, evaluation order of slot writer arguments. Fixed by Gabor
 657 ;;; Melis.
 658 (defstruct bug-348 x)
 659
 660 (assert (eql -1 (let ((i (eval '-2))
 661                       (x (make-bug-348)))
 662                   (funcall #'(setf bug-348-x)
 663                            (incf i)
 664                            (aref (vector x) (incf i)))
 665                   (bug-348-x x))))
 666
 667 ;;; success
 668 (format t "~&/returning success~%")