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.
14 (load "assertoid.lisp")
15 (load "test-util.lisp")
16 (use-package "ASSERTOID")
17 (use-package "TEST-UTIL")
20 ;; Interpreted closure is a problem for COMPILE
21 (with-test (:name
:disassemble
:skipped-on
:interpreter
)
22 ;;; DISASSEMBLE shouldn't fail on closures or unpurified functions
23 (defun disassemble-fun (x) x
)
24 (disassemble 'disassemble-fun
))
26 (with-test (:name
:disassemble-closure
:skipped-on
:interpreter
)
27 (let ((x 1)) (defun disassemble-closure (y) (if y
(setq x y
) x
)))
28 (disassemble 'disassemble-closure
))
31 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
32 (import 'sb-eval
:interpreted-function-p
))
34 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
35 (import 'sb-interpreter
:interpreted-function-p
))
37 #+(or sb-eval sb-fasteval
)
38 (with-test (:name
:disassemble-interpreted
)
39 ;; Nor should it fail on interpreted functions
40 (let ((sb-ext:*evaluator-mode
* :interpret
))
41 (eval `(defun disassemble-eval (x) x
))
42 (disassemble 'disassemble-eval
))
44 ;; disassemble-eval should still be an interpreted function.
45 ;; clhs disassemble: "(If that function is an interpreted function,
46 ;; it is first compiled but the result of this implicit compilation
47 ;; is not installed.)"
48 (assert (interpreted-function-p #'disassemble-eval
)))
50 (with-test (:name
:disassemble-generic
)
51 ;; nor should it fail on generic functions or other funcallable instances
52 (defgeneric disassemble-generic
(x))
53 (disassemble 'disassemble-generic
)
54 (let ((fin (make-instance 'sb-mop
:funcallable-standard-object
)))
57 ;;; while we're at it, much the same applies to
58 ;;; FUNCTION-LAMBDA-EXPRESSION:
61 (let ((x 1)) (defun fle-closure (y) (if y
(setq x y
) x
)))
63 (with-test (:name
:function-lambda-expression
)
65 (nth-value 2 (function-lambda-expression x
))))
66 (assert (eql (fle-name #'fle-fun
) 'fle-fun
))
67 (assert (eql (fle-name #'fle-closure
) 'fle-closure
))
68 (assert (eql (fle-name #'disassemble-generic
) 'disassemble-generic
))
69 (function-lambda-expression
70 (make-instance 'sb-mop
:funcallable-standard-object
))
71 (function-lambda-expression
72 (make-instance 'generic-function
))
73 (function-lambda-expression
74 (make-instance 'standard-generic-function
))
75 #+(or sb-eval sb-fasteval
)
77 (let ((sb-ext:*evaluator-mode
* :interpret
))
78 (eval `(defun fle-eval (x) x
))
79 (assert (eql (fle-name #'fle-eval
) 'fle-eval
)))
81 ;; fle-eval should still be an interpreted function.
82 (assert (interpreted-function-p #'fle-eval
)))))
85 ;;; support for DESCRIBE tests
86 (defstruct to-be-described a b
)
87 (defclass forward-describe-class
(forward-describe-ref) (a))
88 (let ((sb-ext:*evaluator-mode
* :compile
))
89 (eval `(let (x) (defun closure-to-describe () (incf x
)))))
91 (with-test (:name
:describe-empty-gf
)
92 (describe (make-instance 'generic-function
))
93 (describe (make-instance 'standard-generic-function
)))
95 ;;; DESCRIBE should run without signalling an error.
96 (with-test (:name
(describe :no-error
))
97 (describe (make-to-be-described))
100 (describe 'symbolism
)
101 (describe (find-package :cl
))
103 (describe #(a vector
))
105 (describe 'closure-to-describe
))
107 ;;; The DESCRIBE-OBJECT methods for built-in CL stuff should do
108 ;;; FRESH-LINE and TERPRI neatly.
109 (dolist (i (list (make-to-be-described :a
14) 12 "a string"
110 #0a0
#(1 2 3) #2a
((1 2) (3 4)) 'sym
:keyword
111 (find-package :keyword
) (list 1 2 3)
112 nil
(cons 1 2) (make-hash-table)
113 (let ((h (make-hash-table)))
114 (setf (gethash 10 h
) 100
117 (make-condition 'simple-error
)
118 (make-condition 'simple-error
:format-control
"fc")
119 #'car
#'make-to-be-described
(lambda (x) (+ x
11))
120 (constantly 'foo
) #'(setf to-be-described-a
)
121 #'describe-object
(find-class 'to-be-described
)
122 (find-class 'forward-describe-class
)
123 (find-class 'forward-describe-ref
) (find-class 'cons
)))
124 (let ((s (with-output-to-string (s)
127 (macrolet ((check (form)
129 (error "misbehavior in DESCRIBE of ~S:~% ~S" i
',form
))))
130 (check (char= #\x
(char s
0)))
131 ;; one leading #\NEWLINE from FRESH-LINE or the like, no more
132 (check (char= #\newline
(char s
1)))
133 (check (char/= #\newline
(char s
2)))
134 ;; one trailing #\NEWLINE from TERPRI or the like, no more
135 (let ((n (length s
)))
136 (check (char= #\newline
(char s
(- n
1))))
137 (check (char/= #\newline
(char s
(- n
2))))))))
140 ;;; Tests of documentation on types and classes
142 (defun assert-documentation (thing doc-type expected
)
143 ;; This helper function makes ASSERT errors print THING, DOC-TYPE,
144 ;; the return value of DOCUMENTATION and EXPECTED.
145 (flet ((assert-documentation-helper (thing doc-type documentation expected
)
146 (declare (ignore thing doc-type
))
147 (equal documentation expected
)))
148 (assert (assert-documentation-helper
149 thing doc-type
(documentation thing doc-type
) expected
))))
151 (defpackage #:documentation.package
152 (:documentation
"PACKAGE"))
154 (with-test (:name
(documentation package
))
155 (assert-documentation (find-package '#:documentation.package
) t
"PACKAGE")
156 (setf (documentation (find-package '#:documentation.package
) t
) "PACKAGE2")
157 (assert-documentation (find-package '#:documentation.package
) t
"PACKAGE2"))
161 (:documentation
"FOO"))
163 (defclass documentation.funcallable-instance
()
165 (:metaclass sb-mop
:funcallable-standard-class
)
166 (:documentation
"FEZ"))
168 (defstruct bar
"BAR")
170 (define-condition baz
()
172 (:documentation
"BAZ"))
175 ((do-class (name expected
&optional structurep
)
177 (assert-documentation ',name
'type
,expected
)
178 (assert-documentation (find-class ',name
) 'type
,expected
)
179 (assert-documentation (find-class ',name
) 't
,expected
)
181 `((assert-documentation ',name
'structure
,expected
)))
183 (let ((new1 (symbol-name (gensym "NEW1")))
184 (new2 (symbol-name (gensym "NEW2")))
185 (new3 (symbol-name (gensym "NEW3")))
186 (new4 (symbol-name (gensym "NEW4"))))
187 (declare (ignorable new4
))
188 (setf (documentation ',name
'type
) new1
)
189 (assert-documentation (find-class ',name
) 'type new1
)
190 (setf (documentation (find-class ',name
) 'type
) new2
)
191 (assert-documentation (find-class ',name
) 't new2
)
192 (setf (documentation (find-class ',name
) 't
) new3
)
193 (assert-documentation ',name
'type new3
)
195 `((assert-documentation ',name
'structure new3
)
196 (setf (documentation ',name
'structure
) new4
)
197 (assert-documentation ',name
'structure new4
)))))))
199 (with-test (:name
(documentation class standard-class
))
200 (do-class foo
"FOO"))
202 (with-test (:name
(documentation class sb-mop
:funcallable-standard-class
))
203 (do-class documentation.funcallable-instance
"FEZ"))
205 (with-test (:name
(documentation struct
1))
206 (do-class bar
"BAR" t
))
208 (with-test (:name
(documentation condition
))
209 (do-class baz
"BAZ")))
211 (defstruct (frob (:type vector
)) "FROB")
213 (with-test (:name
(documentation struct
2))
214 (assert-documentation 'frob
'structure
"FROB")
215 (setf (documentation 'frob
'structure
) "NEW5")
216 (assert-documentation 'frob
'structure
"NEW5"))
222 (with-test (:name
(documentation type
))
223 (assert-documentation 'quux
'type
"QUUX")
224 (setf (documentation 'quux
'type
) "NEW4")
225 (assert-documentation 'quux
'type
"NEW4"))
227 (define-compiler-macro cmacro
(x)
231 (define-compiler-macro (setf cmacro
) (y x
)
232 "setf compiler macro"
236 (with-test (:name
(documentation compiler-macro
))
237 (assert-documentation 'cmacro
'compiler-macro
"compiler macro")
238 (assert-documentation '(setf cmacro
) 'compiler-macro
"setf compiler macro"))
240 (defun (setf documentation.setf
) (x)
241 "(setf foo) documentation"
244 (with-test (:name
(documentation function setf
))
245 (flet ((expect (documentation)
246 (assert-documentation
247 '(setf documentation.setf
) 'function documentation
)
248 (assert-documentation
249 #'(setf documentation.setf
) 'function documentation
)
250 (assert-documentation
251 #'(setf documentation.setf
) t documentation
)))
252 (expect "(setf foo) documentation")
253 ;; The original test checked this twice. No idea why.
254 (expect "(setf foo) documentation")
257 (setf (documentation '(setf documentation.setf
) 'function
)
258 "(setf bar) documentation")
259 (expect "(setf bar) documentation")
261 (setf (documentation #'(setf documentation.setf
) 'function
)
262 "(setf baz) documentation")
263 (expect "(setf baz) documentation")
265 (setf (documentation #'(setf documentation.setf
) t
)
266 "(setf fez) documentation")
267 (expect "(setf fez) documentation")))
269 (with-test (:name
(documentation lambda
))
270 (let ((f (lambda () "aos the zos" t
))
271 (g (sb-int:named-lambda fii
() "zoot the fruit" t
)))
272 (dolist (doc-type '(t function
))
273 (assert-documentation f doc-type
"aos the zos")
274 (assert-documentation g doc-type
"zoot the fruit"))
275 (setf (documentation f t
) "fire")
276 (assert-documentation f t
"fire")
277 (assert-documentation g t
"zoot the fruit")))
279 (with-test (:name
(documentation flet
))
281 (string= (documentation
287 "this is FLET quux")))
289 (with-test (:name
(documentation labels
))
291 (string= (documentation
299 "this is LABELS rec")))
306 (with-test (:name
(documentation :closure
))
307 (assert-documentation 'docfoo
'function
"bar")
308 (assert (string= (setf (documentation 'docfoo
'function
) "baz") "baz"))
309 (assert-documentation 'docfoo
'function
"baz")
310 (assert-documentation #'docfoo t
"baz")
311 (assert (string= (setf (documentation #'docfoo t
) "zot") "zot"))
312 (assert-documentation #'docfoo t
"zot")
313 (assert-documentation 'docfoo
'function
"zot")
314 (assert (not (setf (documentation 'docfoo
'function
) nil
)))
315 (assert-documentation 'docfoo
'function nil
))
317 (with-test (:name
(documentation :built-in-macro
) :skipped-on
'(not :sb-doc
))
318 (assert (documentation 'trace
'function
)))
320 (with-test (:name
(documentation :built-in-function
) :skipped-on
'(not :sb-doc
))
321 (assert (documentation 'cons
'function
)))
323 (defvar documentation.variable nil
324 "foo variable documentation")
326 (with-test (:name
(documentation variable
))
327 (assert-documentation 'documentation.variable
'variable
328 "foo variable documentation")
329 (setf (documentation 'documentation.variable
'variable
)
330 "baz variable documentation")
331 (assert-documentation 'documentation.variable
'variable
332 "baz variable documentation"))
334 (with-test (:name
(documentation :mismatch-for-function
))
338 (setf (symbol-function 'test2
) #'test
)
339 (setf (documentation 'test
'function
) "Y")
340 (assert (equal (documentation #'test t
)
341 (documentation 'test
'function
)))
342 (setf (documentation 'test2
'function
) "Z")
344 (equal (documentation 'test
'function
)
345 (documentation 'test2
'function
)))))
347 (with-test (:name
(documentation setf
:on nil
))
350 (assert (equal (setf (documentation nil
'function
) "foo") "foo"))
356 (with-test (:name
:describe-generic-function-with-assumed-type
)
357 ;; Signalled an error at one point
358 (flet ((zoo () (gogo)))
359 (defmethod gogo () nil
)
362 (defmacro bug-643958-test
()
366 (with-test (:name
:bug-643958
)
367 (assert (equal "foo" (documentation 'bug-643958-test
'function
)))
368 (setf (documentation 'bug-643958-test
'function
) "bar")
369 (assert (equal "bar" (documentation 'bug-643958-test
'function
))))
371 (defclass cannot-print-this
()
373 (defmethod print-object ((oops cannot-print-this
) stream
)
375 (with-test (:name
:describe-suppresses-print-errors
)
376 (handler-bind ((error #'continue
))
377 (with-output-to-string (s)
378 (describe (make-instance 'cannot-print-this
) s
))))
379 (with-test (:name
:backtrace-suppresses-print-errors
)
380 (handler-bind ((error #'continue
))
381 (with-output-to-string (s)
386 (sb-debug:print-backtrace
:count
100 :stream s
))))
387 (foo 100 (make-instance 'cannot-print-this
))))))
388 (with-test (:name
:backtrace-and-circles
)
389 (handler-bind ((error #'continue
))
390 (with-output-to-string (s)
395 (sb-debug:print-backtrace
:count
100 :stream s
))))
396 (foo 100 (let ((list (list t
)))
397 (nconc list list
)))))))
399 (with-test (:name
:endianness-in-features
)
401 (or (member :big-endian
*features
*)
402 (member :little-endian
*features
*))))
404 (with-test (:name
(trace generic-function
))
405 (defgeneric traced-gf
(x))
406 (defmethod traced-gf (x) (1+ x
))
407 (assert (= (traced-gf 3) 4))
409 (let ((output (with-output-to-string (*trace-output
*)
410 (assert (= (traced-gf 3) 4)))))
411 (assert (> (length output
) 0)))
412 (assert (typep #'traced-gf
'standard-generic-function
))
414 (let ((output (with-output-to-string (*trace-output
*)
415 (assert (= (traced-gf 3) 4)))))
416 (assert (= (length output
) 0))))
418 (with-test (:name
(apropos :inherited
:bug-1364413
))
419 (let* ((package (make-package "BUGGALO" :use nil
))
420 (symbol (intern "BUGGALO" package
)))
421 (export (list symbol
) package
)
422 (let ((inherits (make-package "BUGGALO-INHERITS" :use
(list package
))))
423 (assert (= (length (apropos-list "BUGGALO" package
)) 1))
424 (assert (= (length (apropos-list "BUGGALO" inherits
)) 1))
425 (delete-package inherits
))
426 (delete-package package
)))
428 (with-test (:name
(apropos :inherited
:external-only
:bug-1364413
))
429 (let* ((package (make-package "BUGGALO" :use nil
))
430 (symbol (intern "BUGGALO" package
)))
431 (export (list symbol
) package
)
432 (let ((inherits (make-package "BUGGALO-INHERITS" :use
(list package
))))
433 (assert (= (length (apropos-list "BUGGALO" package t
)) 1))
434 (assert (= (length (apropos-list "BUGGALO" inherits t
)) 0))
435 (delete-package inherits
))
436 (delete-package package
)))
438 (with-test (:name
(apropos :once-only
))
439 (assert (= (length (apropos-list "UPDATE-INSTANCE-FOR-REDEFINED-CLASS")) 1)))