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")
19 (defmacro silently
(&rest things
)
20 `(let ((*standard-output
* (make-broadcast-stream))) ,@things
))
22 ;; Interpreted closure is a problem for COMPILE
23 (with-test (:name
:disassemble
:skipped-on
:interpreter
)
24 ;;; DISASSEMBLE shouldn't fail on closures or unpurified functions
25 (defun disassemble-fun (x) x
)
26 (silently (disassemble 'disassemble-fun
)))
28 (with-test (:name
:disassemble-closure
:skipped-on
:interpreter
)
29 (let ((x 1)) (defun disassemble-closure (y) (if y
(setq x y
) x
)))
30 (silently (disassemble 'disassemble-closure
)))
33 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
34 (import 'sb-eval
:interpreted-function-p
))
36 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
37 (import 'sb-interpreter
:interpreted-function-p
))
39 #+(or sb-eval sb-fasteval
)
40 (with-test (:name
:disassemble-interpreted
)
41 ;; Nor should it fail on interpreted functions
42 (let ((sb-ext:*evaluator-mode
* :interpret
))
43 (eval `(defun disassemble-eval (x) x
))
44 (silently (disassemble 'disassemble-eval
)))
46 ;; disassemble-eval should still be an interpreted function.
47 ;; clhs disassemble: "(If that function is an interpreted function,
48 ;; it is first compiled but the result of this implicit compilation
49 ;; is not installed.)"
50 (assert (interpreted-function-p (symbol-function 'disassemble-eval
))))
52 (with-test (:name
:disassemble-generic
)
53 ;; nor should it fail on generic functions or other funcallable instances
54 (defgeneric disassemble-generic
(x))
55 (silently (disassemble 'disassemble-generic
))
56 (let ((fin (make-instance 'sb-mop
:funcallable-standard-object
)))
57 (silently (disassemble fin
))))
59 ;;; while we're at it, much the same applies to
60 ;;; FUNCTION-LAMBDA-EXPRESSION:
63 (let ((x 1)) (defun fle-closure (y) (if y
(setq x y
) x
)))
65 (with-test (:name
:function-lambda-expression
)
67 (nth-value 2 (function-lambda-expression x
))))
68 (assert (eql (fle-name #'fle-fun
) 'fle-fun
))
69 (assert (eql (fle-name #'fle-closure
) 'fle-closure
))
70 (assert (eql (fle-name #'disassemble-generic
) 'disassemble-generic
))
71 (function-lambda-expression
72 (make-instance 'sb-mop
:funcallable-standard-object
))
73 (function-lambda-expression
74 (make-instance 'generic-function
))
75 (function-lambda-expression
76 (make-instance 'standard-generic-function
))
77 #+(or sb-eval sb-fasteval
)
79 (let ((sb-ext:*evaluator-mode
* :interpret
))
80 (eval `(defun fle-eval (x) x
))
81 (assert (eql (fle-name (symbol-function 'fle-eval
)) 'fle-eval
)))
83 ;; fle-eval should still be an interpreted function.
84 (assert (interpreted-function-p (symbol-function 'fle-eval
))))))
87 ;;; support for DESCRIBE tests
88 (defstruct to-be-described a b
)
89 (defclass forward-describe-class
(forward-describe-ref) (a))
90 (let ((sb-ext:*evaluator-mode
* :compile
))
91 (eval `(let (x) (defun closure-to-describe () (incf x
)))))
93 (with-test (:name
:describe-empty-gf
)
94 (silently (describe (make-instance 'generic-function
)))
95 (silently (describe (make-instance 'standard-generic-function
))))
97 ;;; DESCRIBE should run without signalling an error.
98 (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
145 (defun assert-documentation (thing doc-type expected
)
146 ;; This helper function makes ASSERT errors print THING, DOC-TYPE,
147 ;; the return value of DOCUMENTATION and EXPECTED.
148 (flet ((assert-documentation-helper (thing doc-type documentation expected
)
149 (declare (ignore thing doc-type
))
150 (equal documentation expected
)))
151 (assert (assert-documentation-helper
152 thing doc-type
(documentation thing doc-type
) expected
))))
154 (defpackage #:documentation.package
155 (:documentation
"PACKAGE"))
157 (with-test (:name
(documentation package
))
158 (assert-documentation (find-package '#:documentation.package
) t
"PACKAGE")
159 (setf (documentation (find-package '#:documentation.package
) t
) "PACKAGE2")
160 (assert-documentation (find-package '#:documentation.package
) t
"PACKAGE2"))
164 (:documentation
"FOO"))
166 (defclass documentation.funcallable-instance
()
168 (:metaclass sb-mop
:funcallable-standard-class
)
169 (:documentation
"FEZ"))
171 (defstruct bar
"BAR")
173 (define-condition baz
()
175 (:documentation
"BAZ"))
178 ((do-class (name expected
&optional structurep
)
180 (assert-documentation ',name
'type
,expected
)
181 (assert-documentation (find-class ',name
) 'type
,expected
)
182 (assert-documentation (find-class ',name
) 't
,expected
)
184 `((assert-documentation ',name
'structure
,expected
)))
186 (let ((new1 (symbol-name (gensym "NEW1")))
187 (new2 (symbol-name (gensym "NEW2")))
188 (new3 (symbol-name (gensym "NEW3")))
189 (new4 (symbol-name (gensym "NEW4"))))
190 (declare (ignorable new4
))
191 (setf (documentation ',name
'type
) new1
)
192 (assert-documentation (find-class ',name
) 'type new1
)
193 (setf (documentation (find-class ',name
) 'type
) new2
)
194 (assert-documentation (find-class ',name
) 't new2
)
195 (setf (documentation (find-class ',name
) 't
) new3
)
196 (assert-documentation ',name
'type new3
)
198 `((assert-documentation ',name
'structure new3
)
199 (setf (documentation ',name
'structure
) new4
)
200 (assert-documentation ',name
'structure new4
)))))))
202 (with-test (:name
(documentation class standard-class
))
203 (do-class foo
"FOO"))
205 (with-test (:name
(documentation class sb-mop
:funcallable-standard-class
))
206 (do-class documentation.funcallable-instance
"FEZ"))
208 (with-test (:name
(documentation struct
1))
209 (do-class bar
"BAR" t
))
211 (with-test (:name
(documentation condition
))
212 (do-class baz
"BAZ")))
214 (defstruct (frob (:type vector
)) "FROB")
216 (with-test (:name
(documentation struct
2))
217 (assert-documentation 'frob
'structure
"FROB")
218 (setf (documentation 'frob
'structure
) "NEW5")
219 (assert-documentation 'frob
'structure
"NEW5"))
225 (with-test (:name
(documentation type
))
226 (assert-documentation 'quux
'type
"QUUX")
227 (setf (documentation 'quux
'type
) "NEW4")
228 (assert-documentation 'quux
'type
"NEW4"))
230 (define-compiler-macro cmacro
(x)
234 (define-compiler-macro (setf cmacro
) (y x
)
235 "setf compiler macro"
239 (with-test (:name
(documentation compiler-macro
))
240 (assert-documentation 'cmacro
'compiler-macro
"compiler macro")
241 (assert-documentation '(setf cmacro
) 'compiler-macro
"setf compiler macro"))
243 (defun (setf documentation.setf
) (x)
244 "(setf foo) documentation"
247 (with-test (:name
(documentation function setf
))
248 (flet ((expect (documentation)
249 (assert-documentation
250 '(setf documentation.setf
) 'function documentation
)
251 (assert-documentation
252 #'(setf documentation.setf
) 'function documentation
)
253 (assert-documentation
254 #'(setf documentation.setf
) t documentation
)))
255 (expect "(setf foo) documentation")
256 ;; The original test checked this twice. No idea why.
257 (expect "(setf foo) documentation")
260 (setf (documentation '(setf documentation.setf
) 'function
)
261 "(setf bar) documentation")
262 (expect "(setf bar) documentation")
264 (setf (documentation #'(setf documentation.setf
) 'function
)
265 "(setf baz) documentation")
266 (expect "(setf baz) documentation")
268 (setf (documentation #'(setf documentation.setf
) t
)
269 "(setf fez) documentation")
270 (expect "(setf fez) documentation")))
272 (with-test (:name
(documentation lambda
))
273 (let ((f (lambda () "aos the zos" t
))
274 (g (sb-int:named-lambda fii
() "zoot the fruit" t
)))
275 (dolist (doc-type '(t function
))
276 (assert-documentation f doc-type
"aos the zos")
277 (assert-documentation g doc-type
"zoot the fruit"))
278 (setf (documentation f t
) "fire")
279 (assert-documentation f t
"fire")
280 (assert-documentation g t
"zoot the fruit")))
282 (with-test (:name
(documentation flet
))
284 (string= (documentation
290 "this is FLET quux")))
292 (with-test (:name
(documentation labels
))
294 (string= (documentation
302 "this is LABELS rec")))
309 (with-test (:name
(documentation :closure
))
310 (assert-documentation 'docfoo
'function
"bar")
311 (assert (string= (setf (documentation 'docfoo
'function
) "baz") "baz"))
312 (assert-documentation 'docfoo
'function
"baz")
313 (assert-documentation #'docfoo t
"baz")
314 (assert (string= (setf (documentation #'docfoo t
) "zot") "zot"))
315 (assert-documentation #'docfoo t
"zot")
316 (assert-documentation 'docfoo
'function
"zot")
317 (assert (not (setf (documentation 'docfoo
'function
) nil
)))
318 (assert-documentation 'docfoo
'function nil
))
320 (with-test (:name
(documentation :built-in-macro
) :skipped-on
'(not :sb-doc
))
321 (assert (documentation 'trace
'function
)))
323 (with-test (:name
(documentation :built-in-function
) :skipped-on
'(not :sb-doc
))
324 (assert (documentation 'cons
'function
)))
326 (defvar documentation.variable nil
327 "foo variable documentation")
329 (with-test (:name
(documentation variable
))
330 (assert-documentation 'documentation.variable
'variable
331 "foo variable documentation")
332 (setf (documentation 'documentation.variable
'variable
)
333 "baz variable documentation")
334 (assert-documentation 'documentation.variable
'variable
335 "baz variable documentation"))
337 (with-test (:name
(documentation :mismatch-for-function
))
341 (setf (symbol-function 'test2
) #'test
)
342 (setf (documentation 'test
'function
) "Y")
343 (assert (equal (documentation #'test t
)
344 (documentation 'test
'function
)))
345 (setf (documentation 'test2
'function
) "Z")
347 (equal (documentation 'test
'function
)
348 (documentation 'test2
'function
)))))
350 (with-test (:name
(documentation setf
:on nil
))
353 (assert (equal (setf (documentation nil
'function
) "foo") "foo"))
359 (with-test (:name
:describe-generic-function-with-assumed-type
)
360 ;; Signalled an error at one point
361 (flet ((zoo () (gogo)))
362 (defmethod gogo () nil
)
363 (silently (describe 'gogo
))))
365 (defmacro bug-643958-test
()
369 (with-test (:name
:bug-643958
)
370 (assert (equal "foo" (documentation 'bug-643958-test
'function
)))
371 (setf (documentation 'bug-643958-test
'function
) "bar")
372 (assert (equal "bar" (documentation 'bug-643958-test
'function
))))
374 (defclass cannot-print-this
()
376 (defmethod print-object ((oops cannot-print-this
) stream
)
378 (with-test (:name
:describe-suppresses-print-errors
)
379 (handler-bind ((error #'continue
))
380 (with-output-to-string (s)
381 (describe (make-instance 'cannot-print-this
) s
))))
382 (with-test (:name
:backtrace-suppresses-print-errors
)
383 (handler-bind ((error #'continue
))
384 (with-output-to-string (s)
389 (sb-debug:print-backtrace
:count
100 :stream s
))))
390 (foo 100 (make-instance 'cannot-print-this
))))))
391 (with-test (:name
:backtrace-and-circles
)
392 (handler-bind ((error #'continue
))
393 (with-output-to-string (s)
398 (sb-debug:print-backtrace
:count
100 :stream s
))))
399 (foo 100 (let ((list (list t
)))
400 (nconc list list
)))))))
402 (with-test (:name
:endianness-in-features
)
404 (or (member :big-endian
*features
*)
405 (member :little-endian
*features
*))))
407 (with-test (:name
(trace generic-function
))
408 (defgeneric traced-gf
(x))
409 (defmethod traced-gf (x) (1+ x
))
410 (assert (= (traced-gf 3) 4))
412 (let ((output (with-output-to-string (*trace-output
*)
413 (assert (= (traced-gf 3) 4)))))
414 (assert (> (length output
) 0)))
415 (assert (typep #'traced-gf
'standard-generic-function
))
417 (let ((output (with-output-to-string (*trace-output
*)
418 (assert (= (traced-gf 3) 4)))))
419 (assert (= (length output
) 0))))
421 (with-test (:name
(apropos :inherited
:bug-1364413
))
422 (let* ((package (make-package "BUGGALO" :use nil
))
423 (symbol (intern "BUGGALO" package
)))
424 (export (list symbol
) package
)
425 (let ((inherits (make-package "BUGGALO-INHERITS" :use
(list package
))))
426 (assert (= (length (apropos-list "BUGGALO" package
)) 1))
427 (assert (= (length (apropos-list "BUGGALO" inherits
)) 1))
428 (delete-package inherits
))
429 (delete-package package
)))
431 (with-test (:name
(apropos :inherited
:external-only
:bug-1364413
))
432 (let* ((package (make-package "BUGGALO" :use nil
))
433 (symbol (intern "BUGGALO" package
)))
434 (export (list symbol
) package
)
435 (let ((inherits (make-package "BUGGALO-INHERITS" :use
(list package
))))
436 (assert (= (length (apropos-list "BUGGALO" package t
)) 1))
437 (assert (= (length (apropos-list "BUGGALO" inherits t
)) 0))
438 (delete-package inherits
))
439 (delete-package package
)))
441 (with-test (:name
(apropos :once-only
))
442 (assert (= (length (apropos-list "UPDATE-INSTANCE-FOR-REDEFINED-CLASS")) 1)))
444 (defgeneric gf-arglist-1
(x &key y
))
445 (defmethod gf-arglist-1 (x &key
(y nil
) (z nil z-p
))
448 (defgeneric gf-arglist-2
(x &key y
))
449 (defmethod gf-arglist-2 ((x integer
) &key
(y nil
) ((z f
) nil z-p
)) (list x y f z-p
))
450 (defmethod gf-arglist-2 ((x string
) &key
(y nil
) ((z w
) nil z-p
)) (list x y w z-p
))
452 (defgeneric gf-arglist-3
(x &key
((:y y
))))
454 (defgeneric gf-arglist-4
(x &key
((:y z
))))
456 (defgeneric gf-arglist-5
(x &key y
))
457 (defmethod gf-arglist-5 ((x integer
) &key z
&allow-other-keys
) (list x z
))
459 (with-test (:name
(:generic-function-pretty-arglist
1))
460 (assert (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-1
)
462 (with-test (:name
(:generic-function-pretty-arglist
2))
463 (assert (or (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-2
)
465 (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-2
)
466 '(x &key y
((z f
)))))))
467 (with-test (:name
(:generic-function-pretty-arglist
3))
468 (assert (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-3
)
470 (with-test (:name
(:generic-function-pretty-arglist
4))
471 (assert (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-4
)
472 '(x &key
((:y z
))))))
473 (with-test (:name
(:generic-function-pretty-arglist
5))
474 (assert (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-5
)
475 '(x &key y z
&allow-other-keys
))))