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
))
95 (silently (describe (make-instance 'generic-function
)))
98 (silently (describe (make-instance 'standard-generic-function
)))
101 ;;; DESCRIBE should run without signalling an error.
102 (with-test (:name
(describe :no-error
))
104 (describe (make-to-be-described))
106 (describe "a string")
107 (describe 'symbolism
)
108 (describe (find-package :cl
))
110 (describe #(a vector
))
112 (describe 'closure-to-describe
)))
114 ;;; The DESCRIBE-OBJECT methods for built-in CL stuff should do
115 ;;; FRESH-LINE and TERPRI neatly.
116 (with-test (:name
(describe fresh-line terpri
))
117 (dolist (i (list (make-to-be-described :a
14) 12 "a string"
118 #0a0
#(1 2 3) #2a
((1 2) (3 4)) 'sym
:keyword
119 (find-package :keyword
) (list 1 2 3)
120 nil
(cons 1 2) (make-hash-table)
121 (let ((h (make-hash-table)))
122 (setf (gethash 10 h
) 100
125 (make-condition 'simple-error
)
126 (make-condition 'simple-error
:format-control
"fc")
127 #'car
#'make-to-be-described
(lambda (x) (+ x
11))
128 (constantly 'foo
) #'(setf to-be-described-a
)
129 #'describe-object
(find-class 'to-be-described
)
130 (find-class 'forward-describe-class
)
131 (find-class 'forward-describe-ref
) (find-class 'cons
)))
132 (let ((s (with-output-to-string (s)
135 (macrolet ((check (form)
137 (error "misbehavior in DESCRIBE of ~S:~% ~S" i
',form
))))
138 (check (char= #\x
(char s
0)))
139 ;; one leading #\NEWLINE from FRESH-LINE or the like, no more
140 (check (char= #\newline
(char s
1)))
141 (check (char/= #\newline
(char s
2)))
142 ;; one trailing #\NEWLINE from TERPRI or the like, no more
143 (let ((n (length s
)))
144 (check (char= #\newline
(char s
(- n
1))))
145 (check (char/= #\newline
(char s
(- n
2)))))))))
148 ;;; Tests of documentation on types and classes
150 (defun assert-documentation (thing doc-type expected
)
151 ;; This helper function makes ASSERT errors print THING, DOC-TYPE,
152 ;; the return value of DOCUMENTATION and EXPECTED.
153 (flet ((assert-documentation-helper (thing doc-type documentation expected
)
154 (declare (ignore thing doc-type
))
155 (equal documentation expected
)))
156 (assert (assert-documentation-helper
157 thing doc-type
(documentation thing doc-type
) expected
))))
159 (defpackage #:documentation.package
160 (:documentation
"PACKAGE"))
162 (with-test (:name
(documentation package
))
163 (assert-documentation (find-package '#:documentation.package
) t
"PACKAGE")
164 (setf (documentation (find-package '#:documentation.package
) t
) "PACKAGE2")
165 (assert-documentation (find-package '#:documentation.package
) t
"PACKAGE2"))
169 (:documentation
"FOO"))
171 (defclass documentation.funcallable-instance
()
173 (:metaclass sb-mop
:funcallable-standard-class
)
174 (:documentation
"FEZ"))
176 (defstruct bar
"BAR")
178 (define-condition baz
()
180 (:documentation
"BAZ"))
183 ((do-class (name expected
&optional structurep
)
185 (assert-documentation ',name
'type
,expected
)
186 (assert-documentation (find-class ',name
) 'type
,expected
)
187 (assert-documentation (find-class ',name
) 't
,expected
)
189 `((assert-documentation ',name
'structure
,expected
)))
191 (let ((new1 (symbol-name (gensym "NEW1")))
192 (new2 (symbol-name (gensym "NEW2")))
193 (new3 (symbol-name (gensym "NEW3")))
194 (new4 (symbol-name (gensym "NEW4"))))
195 (declare (ignorable new4
))
196 (setf (documentation ',name
'type
) new1
)
197 (assert-documentation (find-class ',name
) 'type new1
)
198 (setf (documentation (find-class ',name
) 'type
) new2
)
199 (assert-documentation (find-class ',name
) 't new2
)
200 (setf (documentation (find-class ',name
) 't
) new3
)
201 (assert-documentation ',name
'type new3
)
203 `((assert-documentation ',name
'structure new3
)
204 (setf (documentation ',name
'structure
) new4
)
205 (assert-documentation ',name
'structure new4
)))))))
207 (with-test (:name
(documentation class standard-class
))
208 (do-class foo
"FOO"))
210 (with-test (:name
(documentation class sb-mop
:funcallable-standard-class
))
211 (do-class documentation.funcallable-instance
"FEZ"))
213 (with-test (:name
(documentation struct
1))
214 (do-class bar
"BAR" t
))
216 (with-test (:name
(documentation condition
))
217 (do-class baz
"BAZ")))
219 (defclass documentation-metaclass
(standard-class)
221 (:documentation
"metaclass with methods on DOCUMENTATION."))
223 (defmethod documentation ((thing documentation-metaclass
)
225 (sb-int:awhen
(call-next-method)
226 (concatenate 'string
":" sb-int
:it
)))
228 (defmethod (setf documentation
) (new-value
229 (thing documentation-metaclass
)
231 (call-next-method (when new-value
232 (substitute #\
! #\. new-value
))
235 (defmethod sb-mop:validate-superclass
((class documentation-metaclass
)
236 (superclass standard-class
))
239 (defclass documentation-class
()
241 (:metaclass documentation-metaclass
)
242 (:documentation
"normal"))
244 (with-test (:name
(documentation :non-stanadard
:metaclass
))
245 (flet ((check (expected class-name
)
246 (let ((class (find-class class-name
)))
247 (assert-documentation class-name
'type expected
)
248 (assert-documentation class
'type expected
)
249 (assert-documentation class t expected
))))
250 ;; Make sure methods specialized on the metaclass are not bypassed
251 ;; when retrieving and modifying class documentation.
252 (check ":normal" 'documentation-class
)
253 (setf (documentation 'documentation-class
'type
) "2.")
254 (check ":2!" 'documentation-class
)
255 (setf (documentation 'documentation-class
'type
) nil
)
256 (check nil
'documentation-class
)
258 ;; Sanity check: make sure the metaclass has its own documentation
259 ;; and is not affected by the above modifications.
260 (check "metaclass with methods on DOCUMENTATION."
261 'documentation-metaclass
)))
263 (defstruct (frob (:type vector
)) "FROB")
265 (with-test (:name
(documentation struct
2))
266 (assert-documentation 'frob
'structure
"FROB")
267 (setf (documentation 'frob
'structure
) "NEW5")
268 (assert-documentation 'frob
'structure
"NEW5"))
274 (with-test (:name
(documentation type
))
275 (assert-documentation 'quux
'type
"QUUX")
276 (setf (documentation 'quux
'type
) "NEW4")
277 (assert-documentation 'quux
'type
"NEW4"))
279 (define-compiler-macro cmacro
(x)
283 (define-compiler-macro (setf cmacro
) (y x
)
284 "setf compiler macro"
288 (with-test (:name
(documentation compiler-macro
))
289 (assert-documentation 'cmacro
'compiler-macro
"compiler macro")
290 (assert-documentation '(setf cmacro
) 'compiler-macro
"setf compiler macro"))
292 (defun (setf documentation.setf
) (x)
293 "(setf foo) documentation"
296 (with-test (:name
(documentation function setf
))
297 (flet ((expect (documentation)
298 (assert-documentation
299 '(setf documentation.setf
) 'function documentation
)
300 (assert-documentation
301 #'(setf documentation.setf
) 'function documentation
)
302 (assert-documentation
303 #'(setf documentation.setf
) t documentation
)))
304 (expect "(setf foo) documentation")
305 ;; The original test checked this twice. No idea why.
306 (expect "(setf foo) documentation")
309 (setf (documentation '(setf documentation.setf
) 'function
)
310 "(setf bar) documentation")
311 (expect "(setf bar) documentation")
313 (setf (documentation #'(setf documentation.setf
) 'function
)
314 "(setf baz) documentation")
315 (expect "(setf baz) documentation")
317 (setf (documentation #'(setf documentation.setf
) t
)
318 "(setf fez) documentation")
319 (expect "(setf fez) documentation")))
321 (with-test (:name
(documentation lambda
))
322 (let ((f (lambda () "aos the zos" t
))
323 (g (sb-int:named-lambda fii
() "zoot the fruit" t
)))
324 (dolist (doc-type '(t function
))
325 (assert-documentation f doc-type
"aos the zos")
326 (assert-documentation g doc-type
"zoot the fruit"))
327 (setf (documentation f t
) "fire")
328 (assert-documentation f t
"fire")
329 (assert-documentation g t
"zoot the fruit")))
331 (with-test (:name
(documentation flet
))
333 (string= (documentation
339 "this is FLET quux")))
341 (with-test (:name
(documentation labels
))
343 (string= (documentation
351 "this is LABELS rec")))
358 (with-test (:name
(documentation :closure
))
359 (assert-documentation 'docfoo
'function
"bar")
360 (assert (string= (setf (documentation 'docfoo
'function
) "baz") "baz"))
361 (assert-documentation 'docfoo
'function
"baz")
362 (assert-documentation #'docfoo t
"baz")
363 (assert (string= (setf (documentation #'docfoo t
) "zot") "zot"))
364 (assert-documentation #'docfoo t
"zot")
365 (assert-documentation 'docfoo
'function
"zot")
366 (assert (not (setf (documentation 'docfoo
'function
) nil
)))
367 (assert-documentation 'docfoo
'function nil
))
369 (with-test (:name
(documentation :built-in-macro
) :skipped-on
'(not :sb-doc
))
370 (assert (documentation 'trace
'function
)))
372 (with-test (:name
(documentation :built-in-function
) :skipped-on
'(not :sb-doc
))
373 (assert (documentation 'cons
'function
)))
375 (defvar documentation.variable nil
376 "foo variable documentation")
378 (with-test (:name
(documentation variable
))
379 (assert-documentation 'documentation.variable
'variable
380 "foo variable documentation")
381 (setf (documentation 'documentation.variable
'variable
)
382 "baz variable documentation")
383 (assert-documentation 'documentation.variable
'variable
384 "baz variable documentation"))
386 (with-test (:name
(documentation :mismatch-for-function
))
390 (setf (symbol-function 'test2
) #'test
)
391 (setf (documentation 'test
'function
) "Y")
392 (assert (equal (documentation #'test t
)
393 (documentation 'test
'function
)))
394 (setf (documentation 'test2
'function
) "Z")
396 (equal (documentation 'test
'function
)
397 (documentation 'test2
'function
)))))
399 (with-test (:name
(documentation setf
:on nil
))
402 (assert (equal (setf (documentation nil
'function
) "foo") "foo"))
408 (with-test (:name
(describe generic-function
:assumed-type
))
409 ;; Signalled an error at one point
410 (let ((fun (checked-compile '(lambda ()
411 (flet ((zoo () (gogo)))
412 (defmethod gogo () nil
)
414 :allow-style-warnings t
)))
415 (handler-bind ((warning #'muffle-warning
)) ; implicit gf
416 (silently (funcall fun
)))))
418 (defmacro bug-643958-test
()
422 (with-test (:name
:bug-643958
)
423 (assert (equal "foo" (documentation 'bug-643958-test
'function
)))
424 (setf (documentation 'bug-643958-test
'function
) "bar")
425 (assert (equal "bar" (documentation 'bug-643958-test
'function
))))
427 (defclass cannot-print-this
()
429 (defmethod print-object ((oops cannot-print-this
) stream
)
431 (with-test (:name
:describe-suppresses-print-errors
)
432 (handler-bind ((error #'continue
))
433 (with-output-to-string (s)
434 (describe (make-instance 'cannot-print-this
) s
))))
435 (with-test (:name
:backtrace-suppresses-print-errors
)
436 (handler-bind ((error #'continue
))
437 (with-output-to-string (s)
442 (sb-debug:print-backtrace
:count
100 :stream s
))))
443 (foo 100 (make-instance 'cannot-print-this
))))))
444 (with-test (:name
:backtrace-and-circles
)
445 (handler-bind ((error #'continue
))
446 (with-output-to-string (s)
451 (sb-debug:print-backtrace
:count
100 :stream s
))))
452 (foo 100 (let ((list (list t
)))
453 (nconc list list
)))))))
455 (with-test (:name
:endianness-in-features
)
457 (or (member :big-endian
*features
*)
458 (member :little-endian
*features
*))))
460 (with-test (:name
(trace generic-function
))
461 (defgeneric traced-gf
(x))
462 (defmethod traced-gf (x) (1+ x
))
463 (assert (= (traced-gf 3) 4))
465 (let ((output (with-output-to-string (*trace-output
*)
466 (assert (= (traced-gf 3) 4)))))
467 (assert (> (length output
) 0)))
468 (assert (typep #'traced-gf
'standard-generic-function
))
470 (let ((output (with-output-to-string (*trace-output
*)
471 (assert (= (traced-gf 3) 4)))))
472 (assert (= (length output
) 0))))
474 (with-test (:name
(apropos :inherited
:bug-1364413
))
475 (let* ((package (make-package "BUGGALO" :use nil
))
476 (symbol (intern "BUGGALO" package
)))
477 (export (list symbol
) package
)
478 (let ((inherits (make-package "BUGGALO-INHERITS" :use
(list package
))))
479 (assert (= (length (apropos-list "BUGGALO" package
)) 1))
480 (assert (= (length (apropos-list "BUGGALO" inherits
)) 1))
481 (delete-package inherits
))
482 (delete-package package
)))
484 (with-test (:name
(apropos :inherited
:external-only
:bug-1364413
))
485 (let* ((package (make-package "BUGGALO" :use nil
))
486 (symbol (intern "BUGGALO" package
)))
487 (export (list symbol
) package
)
488 (let ((inherits (make-package "BUGGALO-INHERITS" :use
(list package
))))
489 (assert (= (length (apropos-list "BUGGALO" package t
)) 1))
490 (assert (= (length (apropos-list "BUGGALO" inherits t
)) 0))
491 (delete-package inherits
))
492 (delete-package package
)))
494 (with-test (:name
(apropos :once-only
))
495 (assert (= (length (apropos-list "UPDATE-INSTANCE-FOR-REDEFINED-CLASS")) 1)))
497 (defgeneric gf-arglist-1
(x &key y
))
498 (defmethod gf-arglist-1 (x &key
(y nil
) (z nil z-p
))
501 (defgeneric gf-arglist-2
(x &key y
))
502 (defmethod gf-arglist-2 ((x integer
) &key
(y nil
) ((z f
) nil z-p
)) (list x y f z-p
))
503 (defmethod gf-arglist-2 ((x string
) &key
(y nil
) ((z w
) nil z-p
)) (list x y w z-p
))
505 (defgeneric gf-arglist-3
(x &key
((:y y
))))
507 (defgeneric gf-arglist-4
(x &key
((:y z
))))
509 (defgeneric gf-arglist-5
(x &key y
))
510 (defmethod gf-arglist-5 ((x integer
) &key z
&allow-other-keys
) (list x z
))
512 (with-test (:name
(:generic-function-pretty-arglist
1))
513 (assert (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-1
)
515 (with-test (:name
(:generic-function-pretty-arglist
2))
516 (assert (or (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-2
)
518 (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-2
)
519 '(x &key y
((z f
)))))))
520 (with-test (:name
(:generic-function-pretty-arglist
3))
521 (assert (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-3
)
523 (with-test (:name
(:generic-function-pretty-arglist
4))
524 (assert (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-4
)
525 '(x &key
((:y z
))))))
526 (with-test (:name
(:generic-function-pretty-arglist
5))
527 (assert (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-5
)
528 '(x &key y z
&allow-other-keys
))))