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"))