3 ;;;; This software is part of the SBCL system. See the README file for
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
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
16 #-interleaved-raw-slots
(invoke-restart 'run-tests
::skip-file
)
18 ;;; More tests of raw slots can be found in 'defstruct.impure.lisp'
19 ;;; Since those are all passing, it's fair to say that interleaving works.
20 ;;; But we want also to test what happens in a very specific case that
21 ;;; is difficult to provoke, when a structure contains enough slots that
22 ;;; its raw bitmap is a bignum and the bignum is moved during GC.
24 (macrolet ((defbiggy ()
26 ,@(loop for i from
1 to
62
27 collect
`(,(sb-int:symbolicate
"SLOT" (write-to-string i
))
28 0 :type
,(if (> i
60) 'sb-ext
:word t
))))))
31 (assert (typep (sb-kernel:layout-raw-slot-metadata
32 (sb-kernel::find-layout
'biggy
)) 'bignum
))
37 ;; This test offers "anecdotal evidence" that it works to have
38 ;; a bignum for raw slot metadata, *and* that the bignum could be
39 ;; transported by GC, leaving a forwarding pointer,
40 ;; before transporting an instance of an object whose layout
43 ;; Without extra augmentation of the GC code [such as printf("got here!")]
44 ;; there is no visible means of determining that this works,
45 ;; aside from GC not crashing.
46 ;; Additionally, the test does not work - which is to say, the GC behavior
47 ;; is different and the desired effect can't be observed - when placed in
48 ;; a WITH-TEST or any other toplevel "noise"; but even without that,
49 ;; the test is brittle.
50 ;; With some extra annotation (printf of otherwise), the line
51 ;; of code in positive_bignum_logbitp() is seen to be reached 63 times
52 ;; in each test run, corresponding to the 63 slots (counting the layout)
53 ;; in each structure instance, times two structure instances.
55 ;; Run it twice to make sure things really worked.
57 (let ((*y
* (make-biggy))
58 (*x
* (sb-kernel:layout-raw-slot-metadata
59 (sb-kernel::find-layout
'biggy
))))
61 (princ 'did-pass-1
) (terpri)
64 (let ((*y
* (make-biggy))
65 (*x
* (sb-kernel:layout-raw-slot-metadata
66 (sb-kernel::find-layout
'biggy
))))
68 (princ 'did-pass-2
) (terpri)
71 ;; Test the C bignum bit extractor.
72 ;; Surprisingly, there was a bug in it, unrelated to forwarding
73 ;; pointers that remained dormant until the randomized
74 ;; HUGE-MANYRAW test in 'defstruct.impure.lisp' found it.
75 (defun c-bignum-logbitp (index bignum
)
76 (assert (typep bignum
'bignum
))
77 (sb-sys:with-pinned-objects
(bignum)
78 (alien-funcall (extern-alien "positive_bignum_logbitp"
79 (function long int long
))
81 (- (sb-kernel:get-lisp-obj-address bignum
)
82 sb-vm
:other-pointer-lowtag
))))
84 (with-test (:name
:c-bignum-logbitp
)
87 (let ((num (ash 1 i
)))
88 (when (typep num
'bignum
)
90 (assert (= (c-bignum-logbitp j num
)
91 (if (logbitp j num
) 1 0)))))))
93 (let ((max (ash 1 768)))
95 (let ((num (random max
)))
96 (when (typep num
'bignum
)
97 (dotimes (j (* (sb-bignum:%bignum-length num
)
99 (assert (= (c-bignum-logbitp j num
)
100 (if (logbitp j num
) 1 0)))))))))
102 ;; for testing the comparator
104 (df 1d0
:type double-float
) ; index 1
106 (sf 1f0
:type single-float
) ; index 3
107 (cdf #c
(1d0 1d0
) :type
(complex double-float
)) ; indices 4 and 5
109 (csf #c
(2f0 2f0
) :type
(complex single-float
)) ; index 7
110 (w 0 :type sb-ext
:word
) ; index 8
113 (defvar *afoo
* (make-foo1))
114 (with-test (:name
:tagged-slot-iterator-macro
)
115 (setf (sb-kernel:%instance-ref
*afoo
* 10) 'magic
)
117 (sb-kernel:do-instance-tagged-slot
(i *afoo
*)
118 (push `(,i
,(sb-kernel:%instance-ref
*afoo
* i
)) l
))
119 (assert (oddp (sb-kernel:%instance-length
*afoo
*)))
120 (assert (= (sb-kernel:layout-length
(sb-kernel:layout-of
*afoo
*))
121 (1- (sb-kernel:%instance-length
*afoo
*))))
122 (assert (equalp (nreverse l
)
123 `((0 ,(sb-kernel:find-layout
'foo1
))
127 ;; slots 1 through 10 exist, to keep total
128 ;; object length EVEN.
131 (defvar *anotherfoo
* (make-foo1))
133 (with-test (:name
:structure-obj-equalp-raw-slots
)
134 ;; these structures are EQUALP even though one of them
135 ;; has a word of junk in its padding slot, as could happen
136 ;; if the structure was stack-allocated (I think)
137 (assert (equalp *anotherfoo
* *afoo
*)))