tests/dump.impure-cload.lisp

   1 ;;;; tests related to the way objects are dumped into fasl files
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (eval-when (:compile-toplevel :load-toplevel :execute)
  15   (load "compiler-test-util.lisp"))
  16
  17 (declaim (optimize (debug 3) (speed 2) (space 1)))
  18 (declaim (muffle-conditions compiler-note))
  19
  20 ;;; this would fail an AVER in NOTE-POTENTIAL-CIRCULARITY
  21 (defparameter *circular-2d-array* #1=#2A((a b) (#1# x)))
  22
  23 ;;; Don Geddis reported this test case 25 December 1999 on a CMU CL
  24 ;;; mailing list: dumping circular lists caused the compiler to enter
  25 ;;; an infinite loop. Douglas Crosher reported a patch 27 Dec 1999.
  26 ;;; The patch was tested on SBCL by Martin Atzmueller 2 Nov 2000, and
  27 ;;; merged in sbcl-0.6.8.11.
  28 (defun q-dg1999-1 () (dolist (x '#1=("A" "B" . #1#)) (progn x)))
  29 (defun q-dg1999-2 () (dolist (x '#1=("C" "D" . #1#)) (progn x)))
  30 (defun q-dg1999-3 () (dolist (x '#1=("E" "F" . #1#)) (progn x)))
  31 (defun q-dg1999-4 () (dolist (x '#1=("C" "D" . #1#)) (progn x)))
  32 (defun useful-dg1999 (keys)
  33   (declare (type list keys))
  34   (loop
  35       for c in '#1=("Red" "Blue" . #1#)
  36       for key in keys))
  37
  38 ;;; sbcl-0.6.11.25 or so had DEF!STRUCT/MAKE-LOAD-FORM/HOST screwed up
  39 ;;; so that the compiler couldn't dump pathnames.
  40 (format t "Now the compiler can dump pathnames again: ~S ~S~%" #p"" #p"/x/y/z")
  41
  42 (eval-when (:compile-toplevel :load-toplevel :execute)
  43   (defstruct foo x y)
  44   (defmethod make-load-form ((foo foo) &optional env)
  45     (declare (ignore env))
  46     ;; an extremely meaningless MAKE-LOAD-FORM method whose only point
  47     ;; is to exercise the mechanism a little bit
  48     (values `(make-foo :x (list ',(foo-x foo)))
  49             `(setf (foo-y ,foo) ',foo))))
  50
  51 (defparameter *foo*
  52   #.(make-foo :x "X" :y "Y"))
  53
  54 (assert (equalp (foo-x *foo*) '("X")))
  55 (assert (locally (declare (notinline eql)) ; noise suppression
  56                  (eql (foo-y *foo*) *foo*)))
  57
  58 ;;; Logical pathnames should be dumpable, too, but what does it mean?
  59 ;;; As of sbcl-0.7.7.16, we've taken dumping the host part to mean
  60 ;;; dumping a reference to the name of the host (much as dumping a
  61 ;;; symbol involves dumping a reference to the name of its package).
  62 (eval-when (:compile-toplevel :load-toplevel :execute)
  63   (setf (logical-pathname-translations "MY-LOGICAL-HOST")
  64         (list '("**;*.*.*" "/tmp/*.*"))))
  65
  66 (defparameter *path* #p"MY-LOGICAL-HOST:FOO;BAR.LISP")
  67
  68 ;;; Non-SIMPLE-ARRAY VECTORs should be dumpable, though they can lose
  69 ;;; their complex attributes.
  70
  71 (defparameter *string* #.(make-array 3 :initial-element #\a
  72                                        :fill-pointer 2
  73                                        :element-type 'character))
  74
  75 ;;; SBCL 0.7.8 incorrectly read high bits of (COMPLEX DOUBLE-FLOAT)
  76 ;;; components as unsigned bytes.
  77 (defparameter *numbers*
  78   '(-1s0 -1f0 -1d0 -1l0
  79     #c(-1s0 -1s0) #c(-1f0 -1f0) #c(-1d0 -1d0) #c(-1l0 -1l0)))
  80 \f
  81 ;;; tests for MAKE-LOAD-FORM-SAVING-SLOTS
  82 (eval-when (:compile-toplevel :load-toplevel :execute)
  83   (defstruct savable-structure
  84     (a nil :type symbol)
  85     (b nil :type symbol :read-only t)
  86     (c nil :read-only t)
  87     (d 0 :type fixnum)
  88     (e 17 :type (unsigned-byte 32) :read-only t))
  89   (defmethod make-load-form ((s savable-structure) &optional env)
  90     (make-load-form-saving-slots s :environment env)))
  91 (defparameter *savable-structure*
  92   #.(make-savable-structure :a t :b 'frob :c 1 :d 39 :e 19))
  93 (assert (eql (savable-structure-a *savable-structure*) t))
  94 (assert (eql (savable-structure-b *savable-structure*) 'frob))
  95 (assert (eql (savable-structure-c *savable-structure*) 1))
  96 (assert (eql (savable-structure-d *savable-structure*) 39))
  97 (assert (eql (savable-structure-e *savable-structure*) 19))
  98
  99 ;;; null :SLOT-NAMES /= unsupplied
 100 (eval-when (:compile-toplevel :load-toplevel :execute)
 101   (defclass savable-class ()
 102     ((a :initform t :initarg :a)))
 103   (defmethod make-load-form ((s savable-class) &optional env)
 104     (make-load-form-saving-slots s :environment env :slot-names '())))
 105 (defparameter *savable-class*
 106   #.(make-instance 'savable-class :a 3))
 107 (assert (not (slot-boundp *savable-class* 'a)))
 108
 109 \f
 110 ;;; ensure that we can dump and reload specialized arrays whose element
 111 ;;; size is smaller than a byte (caused a few problems circa SBCL
 112 ;;; 0.8.14.4)
 113
 114 (defvar *1-bit* #.(make-array 5 :element-type 'bit :initial-element 0))
 115 (defvar *2-bit* #.(make-array 5 :element-type '(unsigned-byte 2) :initial-element 0))
 116 (defvar *4-bit* #.(make-array 5 :element-type '(unsigned-byte 4) :initial-element 1))
 117 \f
 118 ;;; tests for constant coalescing (and absence of such) in the
 119 ;;; presence of strings.
 120 (progn
 121   (defvar *character-string-1* #.(make-string 5 :initial-element #\a))
 122   (defvar *character-string-2* #.(make-string 5 :initial-element #\a))
 123   (assert (eq *character-string-1* *character-string-2*))
 124   (assert (typep *character-string-1* '(simple-array character (5)))))
 125
 126 (progn
 127   (defvar *base-string-1*
 128     #.(make-string 5 :initial-element #\b :element-type 'base-char))
 129   (defvar *base-string-2*
 130     #.(make-string 5 :initial-element #\b :element-type 'base-char))
 131   (assert (eq *base-string-1* *base-string-2*))
 132   (assert (typep *base-string-1* '(simple-base-string 5))))
 133
 134 #-#.(cl:if (cl:subtypep 'cl:character 'cl:base-char) '(and) '(or))
 135 (progn
 136   (defvar *base-string*
 137     #.(make-string 5 :element-type 'base-char :initial-element #\x))
 138   (defvar *character-string*
 139     #.(make-string 5 :initial-element #\x))
 140   (assert (not (eq *base-string* *character-string*)))
 141   (assert (typep *base-string* 'base-string))
 142   (assert (typep *character-string* '(vector character))))
 143
 144 ;; Preparation for more MAKE-LOAD-FORM tests
 145 (eval-when (:compile-toplevel :load-toplevel :execute)
 146
 147  (locally
 148   ;; this file's global SPEED proclamation generates a lot of unwanted noise
 149   (declare (optimize (speed 1)))
 150   (defstruct airport
 151     name code
 152     (latitude nil :type double-float)
 153     (longitude nil :type double-float))
 154
 155   (defmethod make-load-form ((self airport) &optional env)
 156     (make-load-form-saving-slots self :environment env))
 157
 158   (defun compute-airports (n)
 159     (let ((a (make-array n)))
 160       (dotimes (i n a)
 161         (setf (aref a i) (make-airport :code (format nil "~36,3,'0R" i)
 162                                        :name (format nil "airport~d" i)
 163                                        :latitude (+ 40 (/ i 1000.0d0))
 164                                        :longitude (+  100 (/ i 1000.0d0)))))))
 165   (defstruct s1
 166     (w 0 :type sb-ext:word)
 167     (sf 0f0 :type single-float)
 168     (df 0d0 :type double-float)
 169     (csf #c(0f0 0f0) :type (complex single-float))
 170     (cdf #c(0d0 0d0) :type (complex double-float))
 171     (kids nil)
 172     (friends nil))
 173
 174   (defstruct s2
 175     (id)
 176     (friends)
 177     (parent))
 178
 179   (defmethod make-load-form ((self s1) &optional env)
 180     (declare (ignore env))
 181     (ecase (s1-w self)
 182       (1
 183        ;; return gratuitously modified expressions
 184        (multiple-value-bind (alloc init)
 185            (make-load-form-saving-slots self)
 186          (values (list 'progn alloc) (list 'progn init))))
 187       (2
 188        ;; omit the (complex double-float) slot
 189        (make-load-form-saving-slots self
 190                                     ;; nonexistent names are ignored
 191                                     :slot-names '(w sf df csf bogus
 192                                                   kids friends)))
 193       (3
 194        (make-load-form-saving-slots self)))) ; normal
 195
 196   (defmethod make-load-form ((self s2) &optional env)
 197     (declare (ignore env))
 198     (make-load-form-saving-slots self))
 199
 200   (defun compute-tangled-stuff ()
 201     (flet ((circular-list (x)
 202              (let ((list (list x)))
 203                (rplacd list list))))
 204       (let* ((a (make-s1 :w 1
 205                          :sf 1.25f-9
 206                          :df 1048d50
 207                          :csf #c(8.45f1 -9.35f2)
 208                          :cdf #c(-5.430005d10 2.875d0)))
 209              (b (make-s1 :w 2
 210                          :sf 2f0
 211                          :df 3d0
 212                          :csf #c(4f0 5f0)
 213                          :cdf #c(6d0 7d0)))
 214              (c (make-s1 :w 3
 215                          :sf -2f0
 216                          :df -3d0
 217                          :csf #c(-4f0 -5f0)
 218                          :cdf #c(-6d0 -7d0)))
 219              (k1 (make-s2 :id 'b-kid1 :parent b))
 220              (k2 (make-s2 :id 'c-kid1 :parent c)))
 221         (setf (s2-friends k1) (list k2)
 222               (s2-friends k2) (list k1))
 223         (setf (s1-kids b) (list k1 (make-s2 :id 'b-kid2 :parent b))
 224               (s1-kids c) (list k2)
 225               (s1-friends a) (list* b c (circular-list a))
 226               (s1-friends b) (list c a)
 227               (s1-friends c) (list a b))
 228         (list a b c))))
 229
 230 )) ; end EVAL-WHEN
 231
 232 (defun load-form-is-default-mlfss-p (object)
 233   (multiple-value-bind (creation-form init-form)
 234       (make-load-form object)
 235     (multiple-value-bind (ss-creation-form ss-init-form)
 236         (make-load-form-saving-slots object)
 237       (and (equal creation-form ss-creation-form)
 238            (equal init-form ss-init-form)))))
 239
 240 ;; Redefine the MAKE-LOAD-FORM method on FOO.
 241 (remove-method #'make-load-form (find-method #'make-load-form nil (list 'foo)))
 242 (defvar *foo-save-slots* nil)
 243 (defmethod make-load-form ((self foo) &optional env)
 244   (declare (ignore env))
 245   (if (eq *foo-save-slots* :all)
 246       (make-load-form-saving-slots self)
 247       (make-load-form-saving-slots self :slot-names *foo-save-slots*)))
 248 (with-test (:name :load-form-canonical-p)
 249   (let ((foo (make-foo :x 'x :y 'y)))
 250     (flet ((assert-canonical (slots)
 251              (let ((*foo-save-slots* slots))
 252                (assert (load-form-is-default-mlfss-p foo)))))
 253       (assert-canonical :all)
 254       (assert-canonical '(x y)) ; specifying all slots explicitly is still canonical
 255       (assert-canonical '(y x)))
 256     ;; specifying only one slot is not canonical
 257     (let ((*foo-save-slots* '(x)))
 258       (assert (not (load-form-is-default-mlfss-p foo))))))
 259
 260 ;; A huge constant vector. This took 9 seconds to compile (on a MacBook Pro)
 261 ;; prior to the optimization for using fops to dump.
 262 ;; This assertion is simply whether it comes out correctly, not the time taken.
 263 (defparameter *airport-vector* #.(compute-airports 4000))
 264
 265 ;; a tangled forest of structures,
 266 (defparameter *metadata* '#.(compute-tangled-stuff))
 267
 268 (with-test (:name :make-load-form-huge-vector)
 269   (assert (equalp (compute-airports (length (the vector *airport-vector*)))
 270                   *airport-vector*)))
 271
 272 (with-test (:name :make-load-form-circular-hair)
 273   (let ((testcase (compute-tangled-stuff)))
 274     (declare (optimize (speed 1)))
 275     ;; MAKE-LOAD-FORM discards the value of the CDF slot of one structure.
 276     ;; This probably isn't something "reasonable" to do, but it indicates
 277     ;; that SB-FASL::FOP-STRUCT was correctly not used.
 278     (setf (s1-cdf (second testcase)) #c(0d0 0d0))
 279     (assert (string= (write-to-string testcase :circle t :pretty nil)
 280                      (write-to-string *metadata* :circle t :pretty nil)))))
 281
 282 (eval-when (:compile-toplevel :load-toplevel :execute)
 283   (defclass twp ()
 284     ((node-name :initarg :name :accessor node-name)
 285      (parent :accessor node-parent :initform nil)
 286      (children :initarg :children :accessor node-children)))
 287
 288   (defmethod print-object ((self twp) stream)
 289     (declare (optimize (speed 0))) ; silence noise
 290     (format stream "#<Node ~A~@[->~A~]>"
 291             (node-name self)
 292             (handler-case (mapcar 'node-name (node-children self))
 293               (unbound-slot () nil))))
 294
 295   (defmethod make-load-form ((x twp) &optional environment)
 296     (declare (ignore environment))
 297     (values
 298      ;; creation form
 299      `(make-instance ',(class-of x)
 300                      ,@(if (slot-boundp x 'children)
 301                            `(:children ',(slot-value x 'children))))
 302      ;; initialization form
 303      `(setf (node-parent ',x) ',(slot-value x 'parent))))
 304
 305   (defun make-tree-from-spec (node-class specs)
 306     (let ((tree (make-hash-table)))
 307       (dolist (node-name (remove-duplicates (apply #'append specs)))
 308         (setf (gethash node-name tree)
 309               (make-instance node-class :name node-name)))
 310       (dolist (node-spec specs)
 311         (let ((par (gethash (car node-spec) tree))
 312               (kids (mapcar (lambda (x) (gethash x tree)) (cdr node-spec))))
 313           (dolist (kid kids)
 314             (assert (not (node-parent kid)))
 315             (setf (slot-value kid 'parent) par))
 316           (setf (slot-value par 'children) kids)))
 317       (values (gethash 'root tree)))))
 318
 319 (defun verify-tree (node)
 320   (dolist (kid (if (slot-boundp node 'children) (node-children node) nil))
 321     (unless (eq (node-parent kid) node)
 322       (error "Node ~S shoud have ~S as parent but has ~S~%"
 323              (node-name kid)
 324              (node-name node)
 325              (node-parent kid)))
 326     (verify-tree kid)))
 327
 328 (defvar *x*
 329   #.(make-tree-from-spec
 330       'twp
 331       '((root a b c f)
 332         (a x y)
 333         (b p q r s)
 334         (c d e g))))
 335
 336 (with-test (:name :tree-with-parent-hand-made-load-form)
 337   (verify-tree *x*))
 338
 339 (eval-when (:compile-toplevel :load-toplevel :execute)
 340   (defclass twp2 (twp) ())
 341   (defmethod make-load-form ((x twp2) &optional environment)
 342     (declare (ignore environment))
 343     (make-load-form-saving-slots x)))
 344
 345 ;; Track the make-load-form FOPs as they fly by at load-time.
 346 (defvar *call-tracker* nil)
 347 (dolist (fop-name '(sb-fasl::fop-instance))
 348   (let* ((index (position fop-name sb-fasl::**fop-funs**
 349                           :key
 350                           (lambda (x) (and (functionp x) (sb-kernel:%fun-name x)))))
 351          (fun (aref sb-fasl::**fop-funs** index)))
 352     (setf (aref sb-fasl::**fop-funs** index)
 353           (lambda (&rest args)
 354             (push fop-name *call-tracker*)
 355             (apply fun args)))))
 356
 357 ;; Same as *X* but the MAKE-LOAD-FORM method is different
 358 (defvar *y*
 359   #.(make-tree-from-spec
 360       'twp2
 361       '((root a b c f)
 362         (a x y)
 363         (b p q r s)
 364         (c d e g))))
 365
 366 (assert (= 14 (count 'sb-fasl::fop-instance *call-tracker*)))
 367
 368 (with-test (:name :tree-with-parent-m-l-f-s-s)
 369   (verify-tree *y*))
 370
 371 (eval-when (:compile-toplevel :load-toplevel :execute)
 372   (defclass class-with-shared-slot ()
 373     ((a-slot :allocation :class :initarg :a :accessor thing-a)))
 374   (defmethod make-load-form ((self class-with-shared-slot) &optional environment)
 375     (declare (ignore environment))
 376     (make-load-form-saving-slots self :slot-names '(a-slot))))
 377
 378 (defvar *fool1* (make-instance 'class-with-shared-slot :a 42))
 379 (defvar *fool2* #.(let ((i (make-instance 'class-with-shared-slot)))
 380                     (slot-makunbound i 'a-slot)
 381                     i))
 382
 383 ;; The CLHS writeup is slightly ambiguous about what to with unbound
 384 ;; standard-object slots. Assuming that "initialized" and "uninitialized"
 385 ;; correspond to slots for which SLOT-BOUNDP would return T
 386 ;; and NIL respectively, the meaning of
 387 ;;  "initialized slots in object are initialized ..."
 388 ;; can only mean that you write values into slots of the reconstructed
 389 ;; object that were bound in the compile-time object.
 390 ;;
 391 ;; However "Uninitialized slots in object are not initialized" has two
 392 ;; opposing meanings depending on whether the verb is "are" which
 393 ;; expresses state versus "are [not] initialized" which expresses inaction.
 394 ;; For a similar grammatical construction, DEFINE-METHOD-COMBINATION
 395 ;; says in the "Short Form" description that:
 396 ;;   "that method serves as the effective method and operator is not called."
 397 ;; In that sentence "is [not] called" means that "calling" does NOT happen.
 398 ;; Analogously, "is [not] initialized" would imply that initializing
 399 ;; does NOT happen; it does NOT imply that "uninitializing" DOES happen.
 400 ;;
 401 ;; It seems though, that "are [not] initialized" actually means
 402 ;; SHALL be made to become uninitialized. This is based on the Notes
 403 ;; below the main description referencing SLOT-MAKUNBOUND.
 404 ;; (Though muddied by use of weasel-words "could" and "might")
 405 ;;
 406 ;; Ultimately the two end states (doing something / not doing something)
 407 ;; agree when the slot is local to the object, and no behavior is imparted
 408 ;; by ALLOCATE-INSTANCE to cause slots to be other than unbound.
 409 ;; This tests the edge case: that we DO call slot-makunbound.
 410 (with-test (:name :mlfss-slot-makunbound)
 411   (assert (not (slot-boundp *fool1* 'a-slot))))
 412
 413 (defun try-literal-layout () #.(sb-kernel:find-layout 'class-with-shared-slot))
 414 (with-test (:name :dump-std-obj-literal-layout)
 415   (assert (eq (try-literal-layout)
 416               (sb-kernel:find-layout 'class-with-shared-slot))))
 417
 418 (defparameter *some-hash-table*
 419   #.(let ((ht (make-hash-table)))
 420       (setf (gethash 'first ht) :a)
 421       (setf (gethash 'second ht) :b)
 422       ht))
 423 ;;; In the interest of producing repeatable results from externalized
 424 ;;; hash-tables, the make-load-form method iterates in such a way that
 425 ;;; the k/v vector should be ordered the same as it originally was.
 426 ;;; This also has implications on the order of items in each bucket
 427 ;;; when there are collisions.
 428 (with-test (:name :reconstructed-hash-table)
 429   (let ((pairs (sb-impl::hash-table-pairs *some-hash-table*)))
 430     (assert (eq (aref pairs 2) 'first))
 431     (assert (eq (aref pairs 4) 'second))))
 432
 433 (defun int= (a b) (= (the integer a) (the integer b)))
 434 (define-hash-table-test int= sb-impl::number-sxhash)
 435 (defun get-sync-hash-table () #.(make-hash-table :synchronized t))
 436 (with-test (:name :dump-hash-tables)
 437   ;; Don't lose the :synchronized option.
 438   (assert (hash-table-synchronized-p (get-sync-hash-table)))
 439   ;; Disallow nonstandard hash that disagrees with test.
 440   (assert-error (make-load-form (make-hash-table :test 'int= :hash-function 'sxhash)))
 441   ;; Allow nonstandard test as long as it was registered
 442   (assert (make-load-form (make-hash-table :test 'int=))))
 443
 444 (defun list-coalescing-test-fun-1 ()
 445   (declare (optimize (debug 1)))
 446   ;; base coalesces with base, non-base coalesces with non-base
 447   (values '#.`(foo ,(coerce "a" 'base-string))
 448           '#.`(foo ,(coerce "a" '(array character)))
 449           '#.`(foo ,(coerce "a" 'base-string))
 450           '#.`(foo ,(coerce "a" '(array character)))))
 451
 452 (defun list-coalescing-test-fun-2 ()
 453   (declare (optimize (debug 1)))
 454   (values '#.`(foo ,(coerce "a" '(array character)))
 455           '#.`(foo ,(coerce "a" 'base-string))))
 456
 457 (with-test (:name :more-code-constant-coalescing
 458                   :skipped-on (:not :sb-unicode))
 459   (let ((l1 (ctu:find-code-constants #'list-coalescing-test-fun-1))
 460         (l2 (ctu:find-code-constants #'list-coalescing-test-fun-2)))
 461     (assert (equal (length l1) 2))
 462     (assert (equal (length l2) 2))
 463     (multiple-value-bind (c1 c2 c3 c4) (list-coalescing-test-fun-1)
 464       (assert (typep (second c1) 'simple-base-string))
 465       (assert (typep (second c2) 'sb-kernel:simple-character-string))
 466       (assert (typep (second c3) 'simple-base-string))
 467       (assert (typep (second c4) 'sb-kernel:simple-character-string)))
 468     (assert (or (equal l1 l2)
 469                 (equal l1 (reverse l2))))))
 470
 471 (defun cons-on-list-p (cons list)
 472   (assert (consp cons))
 473   (loop for cdr on list thereis (eq cons cdr)))
 474
 475 (defun constant-folding-cdr-test-fun ()
 476   (let ((list '(a b c)))
 477     (dolist (x (list list (cdr list) (cddr list)))
 478       (assert (cons-on-list-p x list)))))
 479
 480 (with-test (:name (:cdr-eq-detection :lp1583753))
 481   (constant-folding-cdr-test-fun))
 482
 483 (locally
 484     (declare (optimize (debug 2) (safety 3)))
 485   (defconstant +consy-constant+ (if (boundp '+consy-constant+) (symbol-value '+consy-constant+) '(message-id CAOrNaszM=eSufoqA4KFVNq4CUpjSJym-ktQnufQgj7a5g2sHmg@mail.gmail.com)))
 486   (defun test-constant-identity (x)
 487     (list '(message-id CAOrNaszM=eSufoqA4KFVNq4CUpjSJym-ktQnufQgj7a5g2sHmg@mail.gmail.com)
 488           (eq x +consy-constant+))))
 489
 490 (with-test (:name (defconstant :reference :identity))
 491   (let ((z (eval `(test-constant-identity ,(intern "+CONSY-CONSTANT+")))))
 492     (assert (equal (car z) +consy-constant+))
 493     (assert (cadr z))))
 494
 495 (macrolet ((expand ()
 496              (declare (muffle-conditions compiler-note)) ; why is DECLAIM not enough?
 497              `(progn
 498                 ,@(loop for i from 0 below sb-vm:n-word-bits
 499                         collect
 500                         `(sb-int:defconstant-eqx ,(intern (format nil "MYSAP~d" i))
 501                              ,(sb-sys:int-sap (ash 1 i))
 502                            #'sb-sys:sap=)))))
 503   (expand))
 504 (with-test (:name :dump-sap)
 505   (dotimes (i sb-vm:n-word-bits)
 506     (let ((s (intern (format nil "MYSAP~d" i))))
 507       (assert (= (sb-sys:sap-int (symbol-value s))
 508                  (ash 1 i))))))
 509
 510 (eval-when (:compile-toplevel :load-toplevel)
 511   (defstruct monkey
 512     (x t)
 513     (y 1 :type fixnum)
 514     (data (cons 1 2))
 515     (str "hi"))
 516
 517   (defmethod make-load-form ((self monkey) &optional e)
 518     (make-load-form-saving-slots self :slot-names '(data) :environment e)))
 519
 520 (defvar *amonkey* #.(make-monkey :x nil :y 3 :data '(ok)))
 521 (eval-when (:compile-toplevel) (makunbound '*amonkey*))
 522 (with-test (:name :dump-monkey)
 523   (let ((a *amonkey*))
 524     (assert (sb-kernel::unbound-marker-p (monkey-x a)))
 525     (assert (sb-kernel::unbound-marker-p (monkey-y a)))
 526     (assert (sb-kernel::unbound-marker-p (monkey-str a)))
 527     (assert (equal (monkey-data a) '(ok)))))
 528
 529 (defun use-numeric-vector-a ()
 530   #.(make-array 5 :element-type '(signed-byte 8) :initial-contents '(90 100 5 -2 3)))
 531
 532 (defun use-numeric-vector-b ()
 533   #.(make-array 5 :element-type '(signed-byte 8) :initial-contents '(90 100 5 -2 3)))
 534
 535 (with-test (:name :coalesce-numeric-arrays)
 536   (assert (eq (use-numeric-vector-a) (use-numeric-vector-b))))
 537
 538 (eval-when (:compile-toplevel :load-toplevel :execute)
 539 (defstruct person id)
 540 (defstruct (spy (:include person (id "   " :type (simple-string 2)))) gadgetry)
 541 (defmethod make-load-form ((self spy) &optional environment)
 542   (declare (ignore environment))
 543   (make-load-form-saving-slots self)))
 544
 545 (defvar *agent* #.(let ((s (make-spy :id "86" :gadgetry '(shoe-phone))))
 546                     (setf (person-id s) "max")
 547                     s))
 548
 549 ;;; If lp#1969318 is fixed, then *AGENT* should not be reconstructed
 550 ;;; from its load form, let alone dumped in the first place.
 551 ;;; But thankfully we trap the read of the ID slot.
 552 (with-test (:name :illegal-typed-slot-value)
 553   (assert-error (spy-id *agent*)))
 554
 555 (defun eq-cdr-constants-coalescing ()
 556   (values
 557    '(a (x . #1=(c)) #1# a)
 558    '(b (x . #2=(c)) #2# b)))
 559
 560 (with-test (:name :eq-cdr-constants-coalescing)
 561   (multiple-value-bind (a b)
 562       (funcall 'eq-cdr-constants-coalescing)
 563     (assert (eq (cdadr a) (caddr a)))
 564     (assert (eq (cdadr b) (caddr b)))))
 565
 566 (with-test (:name :circularity-within-non-simple-array)
 567   (let ((a #.(make-array 2 :adjustable t
 568                            :initial-element '#1=(#1#))))
 569     (assert (eq (aref (opaque-identity a) 0)
 570                 (car (aref (opaque-identity a) 0))))
 571     (assert (eq (aref (opaque-identity a) 0)
 572                 (aref (opaque-identity a) 1)))))
 573
 574 (with-test (:name :non-simple-array-constant-folding)
 575   (let ((x #.(make-array 10 :fill-pointer 5)))
 576     (assert (= (array-total-size x)
 577                (array-total-size (opaque-identity x))))))