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 "(setf foo) documentation"
23 (assert (string= (documentation '(setf foo
) 'function
)
24 "(setf foo) documentation"))
25 (assert (string= (documentation #'(setf foo
) 'function
)
26 "(setf foo) documentation"))
28 (assert (string= (documentation '(setf foo
) 'function
)
29 "(setf foo) documentation"))
30 (assert (string= (documentation #'(setf foo
) 'function
)
31 "(setf foo) documentation"))
33 (with-test (:name
:disassemble
)
34 ;;; DISASSEMBLE shouldn't fail on closures or unpurified functions
35 (defun disassemble-fun (x) x
)
36 (disassemble 'disassemble-fun
)
38 (let ((x 1)) (defun disassemble-closure (y) (if y
(setq x y
) x
)))
39 (disassemble 'disassemble-closure
)
43 ;; Nor should it fail on interpreted functions
44 (let ((sb-ext:*evaluator-mode
* :interpret
))
45 (eval `(defun disassemble-eval (x) x
))
46 (disassemble 'disassemble-eval
))
48 ;; disassemble-eval should still be an interpreted function.
49 ;; clhs disassemble: "(If that function is an interpreted function,
50 ;; it is first compiled but the result of this implicit compilation
51 ;; is not installed.)"
52 (assert (sb-eval:interpreted-function-p
#'disassemble-eval
)))
54 ;; nor should it fail on generic functions or other funcallable instances
55 (defgeneric disassemble-generic
(x))
56 (disassemble 'disassemble-generic
)
57 (let ((fin (make-instance 'sb-mop
:funcallable-standard-object
)))
60 ;;; while we're at it, much the same applies to
61 ;;; FUNCTION-LAMBDA-EXPRESSION:
64 (let ((x 1)) (defun fle-closure (y) (if y
(setq x y
) x
)))
66 (with-test (:name
:function-lambda-expression
)
68 (nth-value 2 (function-lambda-expression x
))))
69 (assert (eql (fle-name #'fle-fun
) 'fle-fun
))
70 (assert (eql (fle-name #'fle-closure
) 'fle-closure
))
71 (assert (eql (fle-name #'disassemble-generic
) 'disassemble-generic
))
72 (function-lambda-expression
73 (make-instance 'sb-mop
:funcallable-standard-object
))
74 (function-lambda-expression
75 (make-instance 'generic-function
))
76 (function-lambda-expression
77 (make-instance 'standard-generic-function
))
80 (let ((sb-ext:*evaluator-mode
* :interpret
))
81 (eval `(defun fle-eval (x) x
))
82 (assert (eql (fle-name #'fle-eval
) 'fle-eval
)))
84 ;; fle-eval should still be an interpreted function.
85 (assert (sb-eval:interpreted-function-p
#'fle-eval
)))))
88 ;;; support for DESCRIBE tests
89 (defstruct to-be-described a b
)
90 (defclass forward-describe-class
(forward-describe-ref) (a))
91 (let ((sb-ext:*evaluator-mode
* :compile
))
92 (eval `(let (x) (defun closure-to-describe () (incf x
)))))
94 (with-test (:name
:describe-empty-gf
)
95 (describe (make-instance 'generic-function
))
96 (describe (make-instance 'standard-generic-function
)))
98 ;;; DESCRIBE should run without signalling an error.
99 (with-test (:name
(describe :no-error
))
100 (describe (make-to-be-described))
102 (describe "a string")
103 (describe 'symbolism
)
104 (describe (find-package :cl
))
106 (describe #(a vector
))
108 (describe 'closure-to-describe
))
110 ;;; The DESCRIBE-OBJECT methods for built-in CL stuff should do
111 ;;; FRESH-LINE and TERPRI neatly.
112 (dolist (i (list (make-to-be-described :a
14) 12 "a string"
113 #0a0
#(1 2 3) #2a
((1 2) (3 4)) 'sym
:keyword
114 (find-package :keyword
) (list 1 2 3)
115 nil
(cons 1 2) (make-hash-table)
116 (let ((h (make-hash-table)))
117 (setf (gethash 10 h
) 100
120 (make-condition 'simple-error
)
121 (make-condition 'simple-error
:format-control
"fc")
122 #'car
#'make-to-be-described
(lambda (x) (+ x
11))
123 (constantly 'foo
) #'(setf to-be-described-a
)
124 #'describe-object
(find-class 'to-be-described
)
125 (find-class 'forward-describe-class
)
126 (find-class 'forward-describe-ref
) (find-class 'cons
)))
127 (let ((s (with-output-to-string (s)
130 (macrolet ((check (form)
132 (error "misbehavior in DESCRIBE of ~S:~% ~S" i
',form
))))
133 (check (char= #\x
(char s
0)))
134 ;; one leading #\NEWLINE from FRESH-LINE or the like, no more
135 (check (char= #\newline
(char s
1)))
136 (check (char/= #\newline
(char s
2)))
137 ;; one trailing #\NEWLINE from TERPRI or the like, no more
138 (let ((n (length s
)))
139 (check (char= #\newline
(char s
(- n
1))))
140 (check (char/= #\newline
(char s
(- n
2))))))))
143 ;;; Tests of documentation on types and classes
146 (:documentation
"FOO"))
147 (defstruct bar
"BAR")
148 (define-condition baz
()
150 (:documentation
"BAZ"))
154 (defstruct (frob (:type vector
)) "FROB")
156 ((do-class (name expected
&optional structurep
)
158 (assert (string= (documentation ',name
'type
) ,expected
))
159 (assert (string= (documentation (find-class ',name
) 'type
) ,expected
))
160 (assert (string= (documentation (find-class ',name
) 't
) ,expected
))
162 `((assert (string= (documentation ',name
'structure
) ,expected
))))
163 (let ((new1 (symbol-name (gensym "NEW1")))
164 (new2 (symbol-name (gensym "NEW2")))
165 (new3 (symbol-name (gensym "NEW3")))
166 (new4 (symbol-name (gensym "NEW4"))))
167 (declare (ignorable new4
))
168 (setf (documentation ',name
'type
) new1
)
169 (assert (string= (documentation (find-class ',name
) 'type
) new1
))
170 (setf (documentation (find-class ',name
) 'type
) new2
)
171 (assert (string= (documentation (find-class ',name
) 't
) new2
))
172 (setf (documentation (find-class ',name
) 't
) new3
)
173 (assert (string= (documentation ',name
'type
) new3
))
175 `((assert (string= (documentation ',name
'structure
) new3
))
176 (setf (documentation ',name
'structure
) new4
)
177 (assert (string= (documentation ',name
'structure
) new4
))))))))
179 (do-class bar
"BAR" t
)
180 (do-class baz
"BAZ"))
182 (assert (string= (documentation 'quux
'type
) "QUUX"))
183 (setf (documentation 'quux
'type
) "NEW4")
184 (assert (string= (documentation 'quux
'type
) "NEW4"))
186 (assert (string= (documentation 'frob
'structure
) "FROB"))
187 (setf (documentation 'frob
'structure
) "NEW5")
188 (assert (string= (documentation 'frob
'structure
) "NEW5"))
190 (define-compiler-macro cmacro
(x)
194 (define-compiler-macro (setf cmacro
) (y x
)
195 "setf compiler macro"
198 (with-test (:name
(documentation compiler-macro
))
199 (unless (equal "compiler macro"
200 (documentation 'cmacro
'compiler-macro
))
201 (error "got ~S for cmacro"
202 (documentation 'cmacro
'compiler-macro
)))
203 (unless (equal "setf compiler macro"
204 (documentation '(setf cmacro
) 'compiler-macro
))
205 (error "got ~S for setf macro" (documentation '(setf cmacro
) 'compiler-macro
))))
207 (with-test (:name
(documentation lambda
))
208 (let ((f (lambda () "aos the zos" t
))
209 (g (sb-int:named-lambda fii
() "zoot the fruit" t
)))
210 (dolist (doc-type '(t function
))
211 (assert (string= (documentation f doc-type
) "aos the zos"))
212 (assert (string= (documentation g doc-type
) "zoot the fruit")))
213 (setf (documentation f t
) "fire")
214 (assert (string= (documentation f t
) "fire"))
215 (assert (string= (documentation g t
) "zoot the fruit"))))
217 (with-test (:name
(documentation flet
))
219 (string= (documentation
225 "this is FLET quux")))
227 (with-test (:name
(documentation labels
))
229 (string= (documentation
237 "this is LABELS rec")))
244 (with-test (:name
(documentation :closure
))
245 (assert (string= (documentation 'docfoo
'function
) "bar"))
246 (assert (string= (setf (documentation 'docfoo
'function
) "baz") "baz"))
247 (assert (string= (documentation 'docfoo
'function
) "baz"))
248 (assert (string= (documentation #'docfoo t
) "baz"))
249 (assert (string= (setf (documentation #'docfoo t
) "zot") "zot"))
250 (assert (string= (documentation #'docfoo t
) "zot"))
251 (assert (string= (documentation 'docfoo
'function
) "zot"))
252 (assert (not (setf (documentation 'docfoo
'function
) nil
)))
253 (assert (not (documentation 'docfoo
'function
))))
255 (with-test (:name
(documentation :built-in-macro
) :skipped-on
'(not :sb-doc
))
256 (assert (documentation 'trace
'function
)))
258 (with-test (:name
(documentation :built-in-function
) :skipped-on
'(not :sb-doc
))
259 (assert (documentation 'cons
'function
)))
261 (with-test (:name
:describe-generic-function-with-assumed-type
)
262 ;; Signalled an error at one point
263 (flet ((zoo () (gogo)))
264 (defmethod gogo () nil
)
267 (defmacro bug-643958-test
()
271 (with-test (:name
:bug-643958
)
272 (assert (equal "foo" (documentation 'bug-643958-test
'function
)))
273 (setf (documentation 'bug-643958-test
'function
) "bar")
274 (assert (equal "bar" (documentation 'bug-643958-test
'function
))))
276 (defclass cannot-print-this
()
278 (defmethod print-object ((oops cannot-print-this
) stream
)
280 (with-test (:name
:describe-suppresses-print-errors
)
281 (handler-bind ((error #'continue
))
282 (with-output-to-string (s)
283 (describe (make-instance 'cannot-print-this
) s
))))
284 (with-test (:name
:backtrace-suppresses-print-errors
)
285 (handler-bind ((error #'continue
))
286 (with-output-to-string (s)
291 (sb-debug:backtrace
100 s
))))
292 (foo 100 (make-instance 'cannot-print-this
))))))
293 (with-test (:name
:backtrace-and-circles
)
294 (handler-bind ((error #'continue
))
295 (with-output-to-string (s)
300 (sb-debug:backtrace
100 s
))))
301 (foo 100 (let ((list (list t
)))
302 (nconc list list
)))))))
304 (with-test (:name
:endianness-in-features
)
306 (or (member :big-endian
*features
*)
307 (member :little-endian
*features
*))))
309 (with-test (:name
:function-documentation-mismatch
)
313 (setf (symbol-function 'test2
) #'test
)
314 (setf (documentation 'test
'function
) "Y")
315 (assert (equal (documentation #'test t
)
316 (documentation 'test
'function
)))
317 (setf (documentation 'test2
'function
) "Z")
319 (equal (documentation 'test
'function
)
320 (documentation 'test2
'function
)))))
322 (with-test (:name
:setf-documentation-on-nil
)
325 (assert (equal (setf (documentation nil
'function
) "foo") "foo"))
331 (with-test (:name
(trace generic-function
))
332 (defgeneric traced-gf
(x))
333 (defmethod traced-gf (x) (1+ x
))
334 (assert (= (traced-gf 3) 4))
336 (let ((output (with-output-to-string (*trace-output
*)
337 (assert (= (traced-gf 3) 4)))))
338 (assert (> (length output
) 0)))
339 (assert (typep #'traced-gf
'standard-generic-function
))
341 (let ((output (with-output-to-string (*trace-output
*)
342 (assert (= (traced-gf 3) 4)))))
343 (assert (= (length output
) 0))))