1 ;;;; tests for problems in the interface presented to the user/programmer
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 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
16 (load "test-util.lisp")
17 (load "compiler-test-util.lisp")
18 (use-package :test-util
)
20 ;;;; properties of symbols, e.g. presence of doc strings for public symbols
22 ;;; FIXME: It would probably be good to require here that every
23 ;;; external symbol either has a doc string or has some good excuse
24 ;;; (like being an accessor for a structure which has a doc string).
26 ;;;; tests of interface machinery
28 ;;; APROPOS should accept a package designator, not just a package, and
29 ;;; furthermore do the right thing when it gets a package designator.
30 ;;; (bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-17)
31 (with-test (:name
(apropos-list :package-designator
))
33 (length (apropos-list "PRINT" :cl
))
34 (length (apropos-list "PRINT")))))
35 ;;; Further, it should correctly deal with the external-only flag (bug
36 ;;; reported by cliini on #lisp IRC 2003-05-30, fixed in sbcl-0.8.0.1x
38 (with-test (:name
(apropos-list :external-only
))
39 (assert (= (length (apropos-list "" "CL"))
40 (length (apropos-list "" "CL" t
))))
42 (length (apropos-list "" "SB-VM" t
))
43 (length (apropos-list "" "SB-VM")))))
45 ;;; DESCRIBE shouldn't fail on rank-0 arrays (bug reported and fixed
46 ;;; by Lutz Euler sbcl-devel 2002-12-03)
47 (with-test (:name
(describe array
:rank
0))
49 (assert (plusp (length (with-output-to-string (stream)
50 (describe array stream
)))))))
53 (test #2a
((1 2) (3 4)))))
55 ;;; TYPEP, SUBTYPEP, UPGRADED-ARRAY-ELEMENT-TYPE and
56 ;;; UPGRADED-COMPLEX-PART-TYPE should be able to deal with NIL as an
57 ;;; environment argument
58 (with-test (:name
(typep :environment nil
))
59 (typep 1 'fixnum nil
))
61 (with-test (:name
(subtypep :environment nil
))
62 (subtypep 'fixnum
'integer nil
))
64 (with-test (:name
(upgraded-array-element-type :environment nil
))
65 (upgraded-array-element-type '(mod 5) nil
))
67 (with-test (:name
(upgraded-complex-part-type :environment nil
))
68 (upgraded-complex-part-type '(single-float 0.0 1.0) nil
))
71 (with-test (:name
(documentation :sb-ext
))
72 ;; We should have documentation for our extension package:
73 (assert (documentation (find-package "SB-EXT") t
)))
75 ;; This is trying to assert that you didn't mistakenly write
76 ;; "#!+sb-doc (important-form)" in source code
77 ;; but it's an absolutely terrible test, because it is nothing more
78 ;; than a change detector. There are two possible improvements:
79 ;; 1. eliminate the change-detection nature of the test by documenting
80 ;; all functions in CL, so that the magic constant goes away.
81 ;; This would still be an indirect test.
82 ;; 2. stop littering up the source code with #!+sb-doc,
83 ;; always write docstrings, and have 'make-target-2-load.lisp' remove them
84 ;; if desired. This would eliminate >1100 reader conditionals,
85 ;; comprising nearly 68% of all reader conditionals in SBCL source.
87 (with-test (:name
(documentation :cl
))
91 (when (documentation s
'function
)
95 ;;; DECLARE should not be a special operator
96 (with-test (:name
(declare :not special-operator-p
))
97 (assert (not (special-operator-p 'declare
))))
99 ;;; WITH-TIMEOUT should accept more than one form in its body.
100 (with-test (:name
(sb-ext:with-timeout
:forms
))
101 (handler-bind ((sb-ext:timeout
#'continue
))
102 (sb-ext:with-timeout
3
106 ;;; SLEEP should not cons except on 32-bit platforms when
107 ;;; (> (mod seconds 1) (* most-positive-fixnum 1e-9))
108 (with-test (:name
(sleep :non-consing
) :fails-on
:win32
109 :skipped-on
:interpreter
)
110 (handler-case (sb-ext:with-timeout
5
111 (ctu:assert-no-consing
(sleep 0.00001s0
))
112 (locally (declare (notinline sleep
))
113 (ctu:assert-no-consing
(sleep 0.00001s0
))
114 (ctu:assert-no-consing
(sleep 0.00001d0
))
115 (ctu:assert-no-consing
(sleep 1/100000003))))
118 ;;; Changes to make SLEEP cons less led to SLEEP
119 ;;; not sleeping at all on 32-bit platforms when
120 ;;; (> (mod seconds 1) (* most-positive-fixnum 1e-9)).
121 (with-test (:name
(sleep :bug-1194673
))
129 ;;; SLEEP should work with large integers as well
130 (with-test (:name
(sleep :pretty-much-forever
))
133 (sb-ext:with-timeout
1
134 (sleep (ash 1 (* 2 sb-vm
:n-word-bits
))))
138 ;;; DOCUMENTATION should return nil, not signal slot-unbound
139 (with-test (:name
(documentation :return nil
))
140 (flet ((test (thing doc-type
)
141 (assert (eq nil
(documentation thing doc-type
)))))
144 (test (find-class 'class
) 'type
)
145 (test 'foo
'structure
)))
147 ;;; DECODE-UNIVERSAL-TIME should accept second-resolution time-zones.
148 (with-test (:name
(decode-universal-time :second-resolution
:time-zone
))
149 (macrolet ((test (ut time-zone list
)
150 (destructuring-bind (sec min hr date mon yr day tz
)
152 `(multiple-value-bind (sec min hr date mon yr day dst tz
)
153 (decode-universal-time ,ut
,time-zone
)
154 (declare (ignore dst
))
155 (assert (= sec
,sec
))
156 (assert (= min
,min
))
158 (assert (= date
,date
))
159 (assert (= mon
,mon
))
161 (assert (= day
,day
))
162 (assert (= tz
,tz
))))))
163 (test (* 86400 365) -
1/3600 (1 0 0 1 1 1901 1 -
1/3600))
164 (test (* 86400 365) 0 (0 0 0 1 1 1901 1 0))
165 (test (* 86400 365) 1/3600 (59 59 23 31 12 1900 0 1/3600))))
167 ;;; DECODE-UNIVERSAL-TIME shouldn't fail when the time is outside UNIX
168 ;;; 32-bit time_t and a timezone wasn't passed
169 (with-test (:name
(decode-universal-time :decode
0))
170 (decode-universal-time 0 nil
))
172 ;;; ENCODE-UNIVERSAL-TIME should be able to encode the universal time
173 ;;; 0 when passed a representation in a timezone where the
174 ;;; representation of 0 as a decoded time is in 1899.
175 (with-test (:name
(encode-universal-time :encode
0))
176 (encode-universal-time 0 0 23 31 12 1899 1))
178 ;;; DISASSEMBLE shouldn't fail on purified functions
179 (with-test (:name
(disassemble :purified
))
180 (disassemble 'cl
:+ :stream
(make-broadcast-stream))
181 (disassemble 'sb-ext
:run-program
:stream
(make-broadcast-stream)))
183 ;;; minimal test of GC: see stress-gc.{sh,lisp} for a more
184 ;;; comprehensive test.
185 (with-test (:name
(sb-ext:gc
:minimal
:stress
))
187 do
(compile nil
'(lambda (x) x
))
188 do
(sb-ext:gc
:full t
)))
190 ;;; On x86-64, the instruction definitions for CMP*[PS][SD] were broken
191 ;;; so that the disassembler threw an error when they were used with
192 ;;; one operand in memory.
193 (with-test (:name
(disassemble :bug-814702
))
194 ;; Quote the lambdas, because WITH-TEST produces a hairy lexical environment
195 ;; which make an interpreted lambda uncompilable.
196 (disassemble '(lambda (x)
198 (the (complex single-float
) x
)))
199 :stream
(make-broadcast-stream))
200 (disassemble '(lambda (x y
)
201 (= (the (complex single-float
) x
)
202 (the (complex single-float
) y
)))
203 :stream
(make-broadcast-stream)))
206 ;; The labeler for LEA would choke on an illegal encoding
207 ;; instead of showing what it illegally encodes, such as LEA RAX, RSP
208 (with-test (:name
(disassemble :x86-lea
:illegal-op
))
209 (let ((a (coerce '(#x48
#x8D
#xC4
) '(array (unsigned-byte 8) (3)))))
210 (sb-sys:with-pinned-objects
(a)
211 (sb-disassem::disassemble-memory
(sb-sys:sap-int
(sb-sys:vector-sap a
)) 3
212 :stream
(make-broadcast-stream)))))
214 ;; Assert that disassemblies of identically-acting functions are identical
215 ;; if address printing is turned off. Should work on any backend, I think.
216 (with-test (:name
(disassemble :without-addresses
))
217 (flet ((disassembly-text (lambda-expr)
219 (let ((sb-disassem::*disassem-location-column-width
* 0)
220 (*print-pretty
* nil
)) ; prevent function name wraparound
221 (with-output-to-string (s)
222 (disassemble lambda-expr
:stream s
)))))
223 ;; Return all except the first two lines. This is subject to change
224 ;; any time we muck with the layout unfortunately.
226 (1+ (position #\Newline string
227 :start
(1+ (position #\Newline string
))))))))
228 (let ((string1 (disassembly-text '(lambda (x) (car x
))))
229 (string2 (disassembly-text '(lambda (y) (car y
)))))
230 (assert (string= string1 string2
)))))
232 (with-test (:name
:disassemble-assembly-routine
)
235 (sb-vm::map-allocated-objects
236 (lambda (obj type size
)
237 (declare (ignore size
))
238 (when (= type sb-vm
:code-header-widetag
)
241 (assert code
) ; found something to disassemble
242 (sb-disassem:disassemble-code-component code
243 :stream
(make-broadcast-stream))))
245 ;;; This tests that the x86-64 disasembler does not crash
246 ;;; on LEA with a rip-relative operand and no label.
247 (with-test (:name
:disassemble-no-labels
248 :skipped-on
'(not :x86-64
))
251 (with-output-to-string (stream)
252 ;; A smallish function whose code happens to contain
253 ;; the thing under test.
254 (disassemble 'sb-impl
::inspector
:stream stream
))
256 (line (find "; = L0" lines
:test
'search
)))
257 (assert (search "LEA " line
)) ; verify our test precondition
258 ;; Now just disassemble without labels and see that we don't crash
259 (disassemble 'sb-impl
::inspector
261 :stream
(make-broadcast-stream))))
263 ;;; Check that SLEEP called with ratios (with no common factors with
264 ;;; 1000000000, and smaller than 1/1000000000) works more or less as
266 (with-test (:name
(sleep ratio
))
267 (let ((fun0a (checked-compile '(lambda () (sleep 1/7))))
268 (fun0b (checked-compile '(lambda () (sleep 1/100000000000000000000000000))))
269 (fun1 (checked-compile '(lambda (x) (sleep x
))))
270 (start-time (get-universal-time)))
272 (sleep 1/100000000000000000000000000)
276 (funcall fun1
1/100000000000000000000000000)
277 (assert (< (- (get-universal-time) start-time
) 2))))
279 (with-test (:name
(sb-ext:assert-version-
>= :ok
))
280 (sb-ext:assert-version-
>= 1 1 13))
282 (with-test (:name
(sb-ext:assert-version-
>= :fails
))
284 (sb-ext:assert-version-
>= most-positive-fixnum
)))
286 (with-test (:name
:bug-1095483
)
287 (assert-error (fboundp '(cas "foo"))))