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.
15 ;;;; properties of symbols, e.g. presence of doc strings for public symbols
17 (enable-test-parallelism)
19 (with-test (:name
(documentation :cl
) :skipped-on
(:not
:sb-doc
))
23 (when (documentation s
'function
)
27 ;;;; tests of interface machinery
29 (with-test (:name
:defthingy-fail-early
)
30 (dolist (form '((defun "hi" 3)
33 (define-modify-macro "hi" :operator
'wat
)))
34 (multiple-value-bind (exp err
) (ignore-errors (macroexpand-1 form
))
35 (assert (and (not exp
)
37 (write-to-string err
:escape nil
)))))))
39 ;; Regression from R/O space change
40 (with-test (:name
(apropos-list :smoke-test
))
41 (assert (plusp (length (apropos-list "required-foreign")))))
43 ;;; APROPOS should accept a package designator, not just a package, and
44 ;;; furthermore do the right thing when it gets a package designator.
45 ;;; (bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-17)
46 (with-test (:name
(apropos-list :package-designator
))
48 (length (apropos-list "PRINT" :cl
))
49 (length (apropos-list "PRINT")))))
50 ;;; Further, it should correctly deal with the external-only flag (bug
51 ;;; reported by cliini on #lisp IRC 2003-05-30, fixed in sbcl-0.8.0.1x
53 (with-test (:name
(apropos-list :external-only
))
54 (assert (= (length (apropos-list "" "CL"))
55 (length (apropos-list "" "CL" t
))))
57 (length (apropos-list "" "SB-VM" t
))
58 (length (apropos-list "" "SB-VM")))))
60 (with-test (:name
:apropos-symbol-values
)
62 (with-output-to-string (*standard-output
*)
63 (apropos "*print-"))))
64 (assert (search "=" string
))
65 (assert (search "PPRINT-DISPATCH" string
))))
67 ;;; TYPEP, SUBTYPEP, UPGRADED-ARRAY-ELEMENT-TYPE and
68 ;;; UPGRADED-COMPLEX-PART-TYPE should be able to deal with NIL as an
69 ;;; environment argument
70 (with-test (:name
(typep :environment nil
))
71 (typep 1 'fixnum nil
))
73 (with-test (:name
(subtypep :environment nil
))
74 (subtypep 'fixnum
'integer nil
))
76 (with-test (:name
(upgraded-array-element-type :environment nil
))
77 (upgraded-array-element-type '(mod 5) nil
))
79 (with-test (:name
(upgraded-complex-part-type :environment nil
))
80 (upgraded-complex-part-type '(single-float 0.0 1.0) nil
))
83 (with-test (:name
(documentation :sb-ext
))
84 ;; We should have documentation for our extension package:
85 (assert (documentation (find-package "SB-EXT") t
)))
87 ;;; DECLARE should not be a special operator
88 (with-test (:name
(declare :not special-operator-p
))
89 (assert (not (special-operator-p 'declare
))))
91 ;;; DOCUMENTATION should return nil, not signal slot-unbound
92 (with-test (:name
(documentation :return nil
))
93 (flet ((test (thing doc-type
)
94 (assert (eq nil
(documentation thing doc-type
)))))
97 (test (find-class 'class
) 'type
)
98 (test 'foo
'structure
)))
100 ;;; DECODE-UNIVERSAL-TIME should accept second-resolution time-zones.
101 (with-test (:name
(decode-universal-time :second-resolution
:time-zone
))
102 (macrolet ((test (ut time-zone list
)
103 (destructuring-bind (sec min hr date mon yr day tz
)
105 `(multiple-value-bind (sec min hr date mon yr day dst tz
)
106 (decode-universal-time ,ut
,time-zone
)
107 (declare (ignore dst
))
108 (assert (= sec
,sec
))
109 (assert (= min
,min
))
111 (assert (= date
,date
))
112 (assert (= mon
,mon
))
114 (assert (= day
,day
))
115 (assert (= tz
,tz
))))))
116 (test (* 86400 365) -
1/3600 (1 0 0 1 1 1901 1 -
1/3600))
117 (test (* 86400 365) 0 (0 0 0 1 1 1901 1 0))
118 (test (* 86400 365) 1/3600 (59 59 23 31 12 1900 0 1/3600))))
120 ;;; DECODE-UNIVERSAL-TIME shouldn't fail when the time is outside UNIX
121 ;;; 32-bit time_t and a timezone wasn't passed
122 (with-test (:name
(decode-universal-time :decode
0))
123 (decode-universal-time 0 nil
))
125 ;;; ENCODE-UNIVERSAL-TIME should be able to encode the universal time
126 ;;; 0 when passed a representation in a timezone where the
127 ;;; representation of 0 as a decoded time is in 1899.
128 (with-test (:name
(encode-universal-time :encode
0))
129 (encode-universal-time 0 0 23 31 12 1899 1))
131 ;;; DISASSEMBLE shouldn't fail on purified functions
132 (with-test (:name
(disassemble :purified
))
133 (disassemble 'cl
:+ :stream
(make-broadcast-stream))
134 (disassemble 'sb-ext
:run-program
:stream
(make-broadcast-stream)))
136 ;;; minimal test of GC: see stress-gc.{sh,lisp} for a more
137 ;;; comprehensive test.
138 (with-test (:name
(sb-ext:gc
:minimal
:stress
))
140 do
(checked-compile '(lambda (x) x
))
141 do
(sb-ext:gc
:full t
)))
143 ;;; On x86-64, the instruction definitions for CMP*[PS][SD] were broken
144 ;;; so that the disassembler threw an error when they were used with
145 ;;; one operand in memory.
146 (with-test (:name
(disassemble :bug-814702
))
147 ;; Quote the lambdas, because WITH-TEST produces a hairy lexical environment
148 ;; which make an interpreted lambda uncompilable.
149 (disassemble '(lambda (x)
151 (the (complex single-float
) x
)))
152 :stream
(make-broadcast-stream))
153 (disassemble '(lambda (x y
)
154 (= (the (complex single-float
) x
)
155 (the (complex single-float
) y
)))
156 :stream
(make-broadcast-stream)))
158 ;;; Data in the high bits of a fun header caused CODE-N-UNBOXED-DATA-BYTES
159 ;;; to return a ridiculously huge value.
160 (with-test (:name
(disassemble :unboxed-data
))
161 (assert (< (sb-kernel:code-n-unboxed-data-bytes
162 (sb-kernel:fun-code-header
#'expt
))
163 150))) ; The exact value is irrelevant.
166 ;; The labeler for LEA would choke on an illegal encoding
167 ;; instead of showing what it illegally encodes, such as LEA RAX, RSP
168 (with-test (:name
(disassemble :x86-lea
:illegal-op
))
169 (let ((a (coerce '(#x48
#x8D
#xC4
) '(array (unsigned-byte 8) (3)))))
170 (sb-sys:with-pinned-objects
(a)
171 (sb-disassem::disassemble-memory
(sb-sys:sap-int
(sb-sys:vector-sap a
)) 3
172 :stream
(make-broadcast-stream)))))
174 ;; Assert that disassemblies of identically-acting functions are identical
175 ;; if address printing is turned off. Should work on any backend, I think.
176 (with-test (:name
(disassemble :without-addresses
))
177 (flet ((disassembly-text (lambda-expr)
179 (let ((sb-disassem::*disassem-location-column-width
* 0)
180 (sb-ext:*disassemble-annotate
* nil
)
181 (*print-pretty
* nil
)) ; prevent function name wraparound
182 (with-output-to-string (s)
183 (disassemble lambda-expr
:stream s
)))))
184 ;; Return all except the first two lines. This is subject to change
185 ;; any time we muck with the layout unfortunately.
187 (1+ (position #\Newline string
188 :start
(1+ (position #\Newline string
))))))))
189 (let ((string1 (disassembly-text '(lambda (x) (car x
))))
190 (string2 (disassembly-text '(lambda (y) (car y
)))))
191 (assert (string= string1 string2
)))))
193 (with-test (:name
:disassemble-assembly-routine
)
194 (disassemble sb-fasl
:*assembler-routines
* :stream
(make-broadcast-stream)))
196 (with-test (:name
(sb-ext:assert-version-
>= :ok
))
197 (sb-ext:assert-version-
>= 1 1 13))
199 (with-test (:name
(sb-ext:assert-version-
>= :fails
))
201 (sb-ext:assert-version-
>= most-positive-fixnum
)))
203 (with-test (:name
:bug-1095483
)
204 (assert-error (fboundp '(cas "foo"))))
206 (with-test (:name
(time :no
*print-length
* :abbreviation
))
207 (let ((s (make-string-output-stream)))
208 (let ((*trace-output
* s
))
210 (let ((str (get-output-stream-string s
)))
211 (assert (and (>= (count #\newline str
) 4)
212 (search "bytes consed" str
))))))
214 (with-test (:name
:split-seconds-for-sleep
)
215 (assert (< (nth-value 1 (sb-impl::split-seconds-for-sleep
7.2993028420866d7
))
219 (with-test (:name
:restart-invalid-arg-counts
.1)
220 (handler-bind ((error (lambda (c)
221 (invoke-restart (find-restart 'sb-kernel
::replace-function c
) 'list
))))
222 (assert (equal (eval '(cons 324)) '(324)))))
225 (with-test (:name
:restart-invalid-arg-counts
.2)
226 (handler-bind ((error (lambda (c)
227 (invoke-restart (find-restart 'sb-kernel
::call-form c
) 123))))
228 (assert (= (eval '(cons 1)) 123))))
230 (with-test (:name
:restart-bogus-arg-to-values-list-error
231 :broken-on
(not (or :x86
:x86-64
:arm
:arm64
)))
232 (let ((fun (checked-compile `(lambda (x) (values-list x
)))))
233 (assert (equal (handler-bind ((sb-kernel::values-list-argument-error
236 (funcall fun
'(1 2 3 4 5 6 7 8 .
10))))
237 '(1 2 3 4 5 6 7 8)))))
239 (with-test (:name
:no-v0p-ex1stsp-in-build
; spelled L33t Hax0r style on purpose
240 :skipped-on
(or :sb-devel
241 :sb-xref-for-internals
))
242 (assert (null (apropos-list "VOP-EXISTSP"))))