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 ;;; DISASSEMBLE shouldn't fail on closures or unpurified functions
34 (defun disassemble-fun (x) x
)
35 (disassemble 'disassemble-fun
)
37 (let ((x 1)) (defun disassemble-closure (y) (if y
(setq x y
) x
)))
38 (disassemble 'disassemble-closure
)
42 ;; Nor should it fail on interpreted functions
43 (let ((sb-ext:*evaluator-mode
* :interpret
))
44 (eval `(defun disassemble-eval (x) x
))
45 (disassemble 'disassemble-eval
))
47 ;; disassemble-eval should still be an interpreted function.
48 ;; clhs disassemble: "(If that function is an interpreted function,
49 ;; it is first compiled but the result of this implicit compilation
50 ;; is not installed.)"
51 (assert (sb-eval:interpreted-function-p
#'disassemble-eval
)))
53 ;; nor should it fail on generic functions or other funcallable instances
54 (defgeneric disassemble-generic
(x))
55 (disassemble 'disassemble-generic
)
56 (let ((fin (sb-mop:make-instance
'sb-mop
:funcallable-standard-object
)))
59 ;;; while we're at it, much the same applies to
60 ;;; FUNCTION-LAMBDA-EXPRESSION:
62 (function-lambda-expression #'fle-fun
)
64 (let ((x 1)) (defun fle-closure (y) (if y
(setq x y
) x
)))
65 (function-lambda-expression #'fle-closure
)
69 ;; Nor should it fail on interpreted functions
70 (let ((sb-ext:*evaluator-mode
* :interpret
))
71 (eval `(defun fle-eval (x) x
))
72 (function-lambda-expression #'fle-eval
))
74 ;; fle-eval should still be an interpreted function.
75 (assert (sb-eval:interpreted-function-p
#'fle-eval
)))
77 ;; nor should it fail on generic functions or other funcallable instances
78 (defgeneric fle-generic
(x))
79 (function-lambda-expression #'fle-generic
)
80 (let ((fin (sb-mop:make-instance
'sb-mop
:funcallable-standard-object
)))
81 (function-lambda-expression fin
))
83 ;;; support for DESCRIBE tests
84 (defstruct to-be-described a b
)
85 (defclass forward-describe-class
(forward-describe-ref) (a))
86 (let ((sb-ext:*evaluator-mode
* :compile
))
87 (eval `(let (x) (defun closure-to-describe () (incf x
)))))
89 ;;; DESCRIBE should run without signalling an error.
90 (with-test (:name
(describe :no-error
))
91 (describe (make-to-be-described))
95 (describe (find-package :cl
))
97 (describe #(a vector
))
99 (describe 'closure-to-describe
))
101 ;;; The DESCRIBE-OBJECT methods for built-in CL stuff should do
102 ;;; FRESH-LINE and TERPRI neatly.
103 (dolist (i (list (make-to-be-described :a
14) 12 "a string"
104 #0a0
#(1 2 3) #2a
((1 2) (3 4)) 'sym
:keyword
105 (find-package :keyword
) (list 1 2 3)
106 nil
(cons 1 2) (make-hash-table)
107 (let ((h (make-hash-table)))
108 (setf (gethash 10 h
) 100
111 (make-condition 'simple-error
)
112 (make-condition 'simple-error
:format-control
"fc")
113 #'car
#'make-to-be-described
(lambda (x) (+ x
11))
114 (constantly 'foo
) #'(setf to-be-described-a
)
115 #'describe-object
(find-class 'to-be-described
)
116 (find-class 'forward-describe-class
)
117 (find-class 'forward-describe-ref
) (find-class 'cons
)))
118 (let ((s (with-output-to-string (s)
121 (macrolet ((check (form)
123 (error "misbehavior in DESCRIBE of ~S:~% ~S" i
',form
))))
124 (check (char= #\x
(char s
0)))
125 ;; one leading #\NEWLINE from FRESH-LINE or the like, no more
126 (check (char= #\newline
(char s
1)))
127 (check (char/= #\newline
(char s
2)))
128 ;; one trailing #\NEWLINE from TERPRI or the like, no more
129 (let ((n (length s
)))
130 (check (char= #\newline
(char s
(- n
1))))
131 (check (char/= #\newline
(char s
(- n
2))))))))
134 ;;; Tests of documentation on types and classes
137 (:documentation
"FOO"))
138 (defstruct bar
"BAR")
139 (define-condition baz
()
141 (:documentation
"BAZ"))
145 (defstruct (frob (:type vector
)) "FROB")
147 ((do-class (name expected
&optional structurep
)
149 (assert (string= (documentation ',name
'type
) ,expected
))
150 (assert (string= (documentation (find-class ',name
) 'type
) ,expected
))
151 (assert (string= (documentation (find-class ',name
) 't
) ,expected
))
153 `((assert (string= (documentation ',name
'structure
) ,expected
))))
154 (let ((new1 (symbol-name (gensym "NEW1")))
155 (new2 (symbol-name (gensym "NEW2")))
156 (new3 (symbol-name (gensym "NEW3")))
157 (new4 (symbol-name (gensym "NEW4"))))
158 (declare (ignorable new4
))
159 (setf (documentation ',name
'type
) new1
)
160 (assert (string= (documentation (find-class ',name
) 'type
) new1
))
161 (setf (documentation (find-class ',name
) 'type
) new2
)
162 (assert (string= (documentation (find-class ',name
) 't
) new2
))
163 (setf (documentation (find-class ',name
) 't
) new3
)
164 (assert (string= (documentation ',name
'type
) new3
))
166 `((assert (string= (documentation ',name
'structure
) new3
))
167 (setf (documentation ',name
'structure
) new4
)
168 (assert (string= (documentation ',name
'structure
) new4
))))))))
170 (do-class bar
"BAR" t
)
171 (do-class baz
"BAZ"))
173 (assert (string= (documentation 'quux
'type
) "QUUX"))
174 (setf (documentation 'quux
'type
) "NEW4")
175 (assert (string= (documentation 'quux
'type
) "NEW4"))
177 (assert (string= (documentation 'frob
'structure
) "FROB"))
178 (setf (documentation 'frob
'structure
) "NEW5")
179 (assert (string= (documentation 'frob
'structure
) "NEW5"))
181 (define-compiler-macro cmacro
(x)
185 (define-compiler-macro (setf cmacro
) (y x
)
186 "setf compiler macro"
189 (with-test (:name
(documentation compiler-macro
))
190 (unless (equal "compiler macro"
191 (documentation 'cmacro
'compiler-macro
))
192 (error "got ~S for cmacro"
193 (documentation 'cmacro
'compiler-macro
)))
194 (unless (equal "setf compiler macro"
195 (documentation '(setf cmacro
) 'compiler-macro
))
196 (error "got ~S for setf macro" (documentation '(setf cmacro
) 'compiler-macro
))))
198 (with-test (:name
(documentation lambda
))
199 (let ((f (lambda () "aos the zos" t
))
200 (g (sb-int:named-lambda fii
() "zoot the fruit" t
)))
201 (dolist (doc-type '(t function
))
202 (assert (string= (documentation f doc-type
) "aos the zos"))
203 (assert (string= (documentation g doc-type
) "zoot the fruit")))
204 (setf (documentation f t
) "fire")
205 (assert (string= (documentation f t
) "fire"))
206 (assert (string= (documentation g t
) "zoot the fruit"))))
208 (with-test (:name
(documentation flet
))
210 (string= (documentation
216 "this is FLET quux")))
218 (with-test (:name
(documentation labels
))
220 (string= (documentation
228 "this is LABELS rec")))
235 (with-test (:name
(documentation closure
))
236 (assert (string= (documentation 'docfoo
'function
) "bar"))
237 (assert (string= (setf (documentation 'docfoo
'function
) "baz") "baz"))
238 (assert (string= (documentation 'docfoo
'function
) "baz"))
239 (assert (string= (documentation #'docfoo t
) "baz"))
240 (assert (string= (setf (documentation #'docfoo t
) "zot") "zot"))
241 (assert (string= (documentation #'docfoo t
) "zot"))
242 (assert (string= (documentation 'docfoo
'function
) "zot"))
243 (assert (not (setf (documentation 'docfoo
'function
) nil
)))
244 (assert (not (documentation 'docfoo
'function
))))
246 (with-test (:name
(documentation built-in-macro
) :skipped-on
'(not :sb-doc
))
247 (assert (documentation 'trace
'function
)))
249 (with-test (:name
(documentation built-in-function
) :skipped-on
'(not :sb-doc
))
250 (assert (documentation 'cons
'function
)))
252 (with-test (:name
:describe-generic-function-with-assumed-type
)
253 ;; Signalled an error at one point
254 (flet ((zoo () (gogo)))
255 (defmethod gogo () nil
)
258 (defmacro bug-643958-test
()
262 (with-test (:name
:bug-643958
)
263 (assert (equal "foo" (documentation 'bug-643958-test
'function
)))
264 (setf (documentation 'bug-643958-test
'function
) "bar")
265 (assert (equal "bar" (documentation 'bug-643958-test
'function
))))
267 (defclass cannot-print-this
()
269 (defmethod print-object ((oops cannot-print-this
) stream
)
271 (with-test (:name
:describe-suppresses-print-errors
)
272 (handler-bind ((error #'continue
))
273 (with-output-to-string (s)
274 (describe (make-instance 'cannot-print-this
) s
))))
275 (with-test (:name
:backtrace-suppresses-print-errors
)
276 (handler-bind ((error #'continue
))
277 (with-output-to-string (s)
282 (sb-debug:backtrace
100 s
))))
283 (foo 100 (make-instance 'cannot-print-this
))))))
284 (with-test (:name
:backtrace-and-circles
)
285 (handler-bind ((error #'continue
))
286 (with-output-to-string (s)
291 (sb-debug:backtrace
100 s
))))
292 (foo 100 (let ((list (list t
)))
293 (nconc list list
)))))))
295 (with-test (:name
:endianness-in-features
)
297 (or (member :big-endian
*features
*)
298 (member :little-endian
*features
*))))
300 (with-test (:name
:function-documentation-mismatch
)
304 (setf (symbol-function 'test2
) #'test
)
305 (setf (documentation 'test
'function
) "Y")
306 (assert (equal (documentation #'test t
)
307 (documentation 'test
'function
)))
308 (setf (documentation 'test2
'function
) "Z")
310 (equal (documentation 'test
'function
)
311 (documentation 'test2
'function
)))))
313 (with-test (:name
:setf-documentation-on-nil
)
316 (assert (equal (setf (documentation nil
'function
) "foo") "foo"))