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 (defmacro silently
(&rest things
)
15 `(let ((*standard-output
* (make-broadcast-stream))) ,@things
))
17 ;; Interpreted closure is a problem for COMPILE
18 (with-test (:name
(disassemble function
) :skipped-on
:interpreter
)
19 ;; DISASSEMBLE shouldn't fail on closures or unpurified functions
20 (defun disassemble-fun (x) x
)
21 (silently (disassemble 'disassemble-fun
)))
23 (with-test (:name
(disassemble :closure
) :skipped-on
:interpreter
)
24 (let ((x 1)) (defun disassemble-closure (y) (if y
(setq x y
) x
)))
25 (silently (disassemble 'disassemble-closure
)))
27 (defun interpreted-function-p (x) (typep x
'sb-kernel
:interpreted-function
))
29 #+(or sb-eval sb-fasteval
)
30 (with-test (:name
(disassemble :interpreted
))
31 ;; Nor should it fail on interpreted functions
32 (let ((sb-ext:*evaluator-mode
* :interpret
))
33 (eval `(defun disassemble-eval (x) x
))
34 (silently (disassemble 'disassemble-eval
)))
36 ;; disassemble-eval should still be an interpreted function.
37 ;; clhs disassemble: "(If that function is an interpreted function,
38 ;; it is first compiled but the result of this implicit compilation
39 ;; is not installed.)"
40 (assert (interpreted-function-p (symbol-function 'disassemble-eval
))))
42 (with-test (:name
(disassemble generic-function
))
43 ;; nor should it fail on generic functions or other funcallable instances
44 (defgeneric disassemble-generic
(x))
45 (silently (disassemble 'disassemble-generic
))
46 (let ((fin (make-instance 'sb-mop
:funcallable-standard-object
)))
47 (silently (disassemble fin
))))
49 ;;; while we're at it, much the same applies to
50 ;;; FUNCTION-LAMBDA-EXPRESSION:
53 (let ((x 1)) (defun fle-closure (y) (if y
(setq x y
) x
)))
55 (defclass non-standard-generic-function
(generic-function) ()
56 (:metaclass sb-mop
:funcallable-standard-class
))
57 (defmethod sb-mop:generic-function-name
((generic-function non-standard-generic-function
))
60 (with-test (:name function-lambda-expression
)
62 (nth-value 2 (function-lambda-expression x
))))
63 (assert (eql (fle-name #'fle-fun
) 'fle-fun
))
64 (assert (eql (fle-name #'fle-closure
) 'fle-closure
))
65 (assert (eql (fle-name #'disassemble-generic
) 'disassemble-generic
))
66 (function-lambda-expression
67 (make-instance 'sb-mop
:funcallable-standard-object
))
68 (function-lambda-expression
69 (make-instance 'non-standard-generic-function
))
70 (function-lambda-expression
71 (make-instance 'standard-generic-function
))
72 #+(or sb-eval sb-fasteval
)
74 (let ((sb-ext:*evaluator-mode
* :interpret
))
75 (eval `(defun fle-eval (x) x
))
76 (assert (eql (fle-name (symbol-function 'fle-eval
)) 'fle-eval
)))
78 ;; fle-eval should still be an interpreted function.
79 (assert (interpreted-function-p (symbol-function 'fle-eval
))))))
81 (with-test (:name
:nested-function-lambda-expression
)
84 (labels ((f1 (z &rest r
&key
(b (eval 'foo
)) (a 3) w
)
85 (- a w
(length r
) (f2 (/ z b
))))
88 (f (compile nil lexpr
)))
89 (assert (equal (function-lambda-expression f
) lexpr
))
90 (assert (equal (function-lambda-expression (funcall f
))
91 '(lambda (z &rest r
&key
(b (eval 'foo
)) (a 3) w
)
92 (block f1
(- a w
(length r
) (f2 (/ z b
)))))))
93 (assert (equal (function-lambda-expression
94 (nth-value 1 (funcall f
)))
95 '(lambda (w) (block f2
(* w
0.3)))))))
97 ;;; Tests of documentation on types and classes
99 (defun assert-documentation (thing doc-type expected
)
100 ;; This helper function makes ASSERT errors print THING, DOC-TYPE,
101 ;; the return value of DOCUMENTATION and EXPECTED.
102 (flet ((assert-documentation-helper (thing doc-type documentation expected
)
103 (declare (ignore thing doc-type
))
104 (equal documentation expected
)))
105 (assert (assert-documentation-helper
106 thing doc-type
(documentation thing doc-type
) expected
))))
108 (defpackage #:documentation.package
109 (:documentation
"PACKAGE"))
111 (with-test (:name
(documentation package
))
112 (assert-documentation (find-package '#:documentation.package
) t
"PACKAGE")
113 (setf (documentation (find-package '#:documentation.package
) t
) "PACKAGE2")
114 (assert-documentation (find-package '#:documentation.package
) t
"PACKAGE2"))
118 (:documentation
"FOO"))
120 (defclass documentation.funcallable-instance
()
122 (:metaclass sb-mop
:funcallable-standard-class
)
123 (:documentation
"FEZ"))
125 (defstruct bar
"BAR")
127 (define-condition baz
()
129 (:documentation
"BAZ"))
132 ((do-class (name expected
&optional structurep
)
134 (assert-documentation ',name
'type
,expected
)
135 (assert-documentation (find-class ',name
) 'type
,expected
)
136 (assert-documentation (find-class ',name
) 't
,expected
)
138 `((assert-documentation ',name
'structure
,expected
)))
140 (let ((new1 (symbol-name (gensym "NEW1")))
141 (new2 (symbol-name (gensym "NEW2")))
142 (new3 (symbol-name (gensym "NEW3")))
143 (new4 (symbol-name (gensym "NEW4"))))
144 (declare (ignorable new4
))
145 (setf (documentation ',name
'type
) new1
)
146 (assert-documentation (find-class ',name
) 'type new1
)
147 (setf (documentation (find-class ',name
) 'type
) new2
)
148 (assert-documentation (find-class ',name
) 't new2
)
149 (setf (documentation (find-class ',name
) 't
) new3
)
150 (assert-documentation ',name
'type new3
)
152 `((assert-documentation ',name
'structure new3
)
153 (setf (documentation ',name
'structure
) new4
)
154 (assert-documentation ',name
'structure new4
)))))))
156 (with-test (:name
(documentation class standard-class
))
157 (do-class foo
"FOO"))
159 (with-test (:name
(documentation class sb-mop
:funcallable-standard-class
))
160 (do-class documentation.funcallable-instance
"FEZ"))
162 (with-test (:name
(documentation struct
1))
163 (do-class bar
"BAR" t
))
165 (with-test (:name
(documentation condition
))
166 (do-class baz
"BAZ")))
168 (defclass documentation-metaclass
(standard-class)
170 (:documentation
"metaclass with methods on DOCUMENTATION."))
172 (defmethod documentation ((thing documentation-metaclass
)
174 (sb-int:awhen
(call-next-method)
175 (concatenate 'string
":" sb-int
:it
)))
177 (defmethod (setf documentation
) (new-value
178 (thing documentation-metaclass
)
180 (call-next-method (when new-value
181 (substitute #\
! #\. new-value
))
184 (defmethod sb-mop:validate-superclass
((class documentation-metaclass
)
185 (superclass standard-class
))
188 (defclass documentation-class
()
190 (:metaclass documentation-metaclass
)
191 (:documentation
"normal"))
193 (with-test (:name
(documentation :non-stanadard
:metaclass
))
194 (flet ((check (expected class-name
)
195 (let ((class (find-class class-name
)))
196 (assert-documentation class-name
'type expected
)
197 (assert-documentation class
'type expected
)
198 (assert-documentation class t expected
))))
199 ;; Make sure methods specialized on the metaclass are not bypassed
200 ;; when retrieving and modifying class documentation.
201 (check ":normal" 'documentation-class
)
202 (setf (documentation 'documentation-class
'type
) "2.")
203 (check ":2!" 'documentation-class
)
204 (setf (documentation 'documentation-class
'type
) nil
)
205 (check nil
'documentation-class
)
207 ;; Sanity check: make sure the metaclass has its own documentation
208 ;; and is not affected by the above modifications.
209 (check "metaclass with methods on DOCUMENTATION."
210 'documentation-metaclass
)))
212 (defstruct (frob (:type vector
)) "FROB")
214 (with-test (:name
(documentation struct
2))
215 (assert-documentation 'frob
'structure
"FROB")
216 (setf (documentation 'frob
'structure
) "NEW5")
217 (assert-documentation 'frob
'structure
"NEW5"))
223 (with-test (:name
(documentation type
))
224 (assert-documentation 'quux
'type
"QUUX")
225 (setf (documentation 'quux
'type
) "NEW4")
226 (assert-documentation 'quux
'type
"NEW4"))
228 (define-compiler-macro cmacro
(x)
232 (define-compiler-macro (setf cmacro
) (y x
)
233 "setf compiler macro"
237 (with-test (:name
(documentation compiler-macro
))
238 (assert-documentation 'cmacro
'compiler-macro
"compiler macro")
239 (assert-documentation '(setf cmacro
) 'compiler-macro
"setf compiler macro"))
241 (defun (setf documentation.setf
) (x)
242 "(setf foo) documentation"
245 (with-test (:name
(documentation function setf
))
246 (flet ((expect (documentation)
247 (assert-documentation
248 '(setf documentation.setf
) 'function documentation
)
249 (assert-documentation
250 #'(setf documentation.setf
) 'function documentation
)
251 (assert-documentation
252 #'(setf documentation.setf
) t documentation
)))
253 (expect "(setf foo) documentation")
254 ;; The original test checked this twice. No idea why.
255 (expect "(setf foo) documentation")
258 (setf (documentation '(setf documentation.setf
) 'function
)
259 "(setf bar) documentation")
260 (expect "(setf bar) documentation")
262 (setf (documentation #'(setf documentation.setf
) 'function
)
263 "(setf baz) documentation")
264 (expect "(setf baz) documentation")
266 (setf (documentation #'(setf documentation.setf
) t
)
267 "(setf fez) documentation")
268 (expect "(setf fez) documentation")))
270 (with-test (:name
(documentation lambda
))
271 (let ((f (lambda () "aos the zos" t
))
272 (g (sb-int:named-lambda fii
() "zoot the fruit" t
)))
273 (dolist (doc-type '(t function
))
274 (assert-documentation f doc-type
"aos the zos")
275 (assert-documentation g doc-type
"zoot the fruit"))
276 (setf (documentation f t
) "fire")
277 (assert-documentation f t
"fire")
278 (assert-documentation g t
"zoot the fruit")))
280 (with-test (:name
(documentation flet
))
282 (string= (documentation
288 "this is FLET quux")))
290 (with-test (:name
(documentation labels
))
292 (string= (documentation
300 "this is LABELS rec")))
307 (with-test (:name
(documentation :closure
))
308 (assert-documentation 'docfoo
'function
"bar")
309 (assert (string= (setf (documentation 'docfoo
'function
) "baz") "baz"))
310 (assert-documentation 'docfoo
'function
"baz")
311 (assert-documentation #'docfoo t
"baz")
312 (assert (string= (setf (documentation #'docfoo t
) "zot") "zot"))
313 (assert-documentation #'docfoo t
"zot")
314 (assert-documentation 'docfoo
'function
"zot")
315 (assert (not (setf (documentation 'docfoo
'function
) nil
)))
316 (assert-documentation 'docfoo
'function nil
))
318 (with-test (:name
(documentation :built-in-macro
) :skipped-on
(not :sb-doc
))
319 (assert (documentation 'trace
'function
)))
321 (with-test (:name
(documentation :built-in-function
) :skipped-on
(not :sb-doc
))
322 (assert (documentation 'cons
'function
)))
324 (defvar documentation.variable nil
325 "foo variable documentation")
327 (with-test (:name
(documentation variable
))
328 (assert-documentation 'documentation.variable
'variable
329 "foo variable documentation")
330 (setf (documentation 'documentation.variable
'variable
)
331 "baz variable documentation")
332 (assert-documentation 'documentation.variable
'variable
333 "baz variable documentation"))
335 (with-test (:name
(documentation :mismatch-for-function
))
339 (setf (symbol-function 'test2
) #'test
)
340 (setf (documentation 'test
'function
) "Y")
341 (assert (equal (documentation #'test t
)
342 (documentation 'test
'function
)))
343 (setf (documentation 'test2
'function
) "Z")
345 (equal (documentation 'test
'function
)
346 (documentation 'test2
'function
)))))
348 (with-test (:name
(documentation setf
:on nil
))
351 (assert (equal (setf (documentation nil
'function
) "foo") "foo"))
357 (with-test (:name
(describe generic-function
:assumed-type
))
358 ;; Signalled an error at one point
359 (let ((fun (checked-compile '(lambda ()
360 (flet ((zoo () (gogo)))
361 (defmethod gogo () nil
)
363 :allow-style-warnings t
)))
364 (handler-bind ((warning #'muffle-warning
)) ; implicit gf
365 (silently (funcall fun
)))))
367 (defmacro bug-643958-test
()
371 (with-test (:name
:bug-643958
)
372 (assert (equal "foo" (documentation 'bug-643958-test
'function
)))
373 (setf (documentation 'bug-643958-test
'function
) "bar")
374 (assert (equal "bar" (documentation 'bug-643958-test
'function
))))
376 (with-test (:name
(:endianness
:in
*features
*))
378 (or (member :big-endian
*features
*)
379 (member :little-endian
*features
*))))
381 (with-test (:name
(apropos :inherited
:bug-1364413
))
382 (let* ((package (make-package "BUGGALO" :use nil
))
383 (symbol (intern "BUGGALO" package
)))
384 (export (list symbol
) package
)
385 (let ((inherits (make-package "BUGGALO-INHERITS" :use
(list package
))))
386 (assert (= (length (apropos-list "BUGGALO" package
)) 1))
387 (assert (= (length (apropos-list "BUGGALO" inherits
)) 1))
388 (delete-package inherits
))
389 (delete-package package
)))
391 (with-test (:name
(apropos :inherited
:external-only
:bug-1364413
))
392 (let* ((package (make-package "BUGGALO" :use nil
))
393 (symbol (intern "BUGGALO" package
)))
394 (export (list symbol
) package
)
395 (let ((inherits (make-package "BUGGALO-INHERITS" :use
(list package
))))
396 (assert (= (length (apropos-list "BUGGALO" package t
)) 1))
397 (assert (= (length (apropos-list "BUGGALO" inherits t
)) 0))
398 (delete-package inherits
))
399 (delete-package package
)))
401 (with-test (:name
(apropos :once-only
))
402 (assert (= (length (apropos-list "UPDATE-INSTANCE-FOR-REDEFINED-CLASS")) 1)))
404 (defgeneric gf-arglist-1
(x &key y
))
405 (defmethod gf-arglist-1 (x &key
(y nil
) (z nil z-p
))
408 (defgeneric gf-arglist-2
(x &key y
))
409 (defmethod gf-arglist-2 ((x integer
) &key
(y nil
) ((z f
) nil z-p
)) (list x y f z-p
))
410 (defmethod gf-arglist-2 ((x string
) &key
(y nil
) ((z w
) nil z-p
)) (list x y w z-p
))
412 (defgeneric gf-arglist-3
(x &key
((:y y
))))
414 (defgeneric gf-arglist-4
(x &key
((:y z
))))
416 (defgeneric gf-arglist-5
(x &key y
))
417 (defmethod gf-arglist-5 ((x integer
) &key z
&allow-other-keys
) (list x z
))
419 (with-test (:name
(:generic-function-pretty-arglist
1))
420 (assert (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-1
)
422 (with-test (:name
(:generic-function-pretty-arglist
2))
423 (assert (or (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-2
)
425 (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-2
)
426 '(x &key y
((z f
)))))))
427 (with-test (:name
(:generic-function-pretty-arglist
3))
428 (assert (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-3
)
430 (with-test (:name
(:generic-function-pretty-arglist
4))
431 (assert (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-4
)
432 '(x &key
((:y z
))))))
433 (with-test (:name
(:generic-function-pretty-arglist
5))
434 (assert (equal (sb-pcl::generic-function-pretty-arglist
#'gf-arglist-5
)
435 '(x &key y z
&allow-other-keys
))))
437 (defgeneric traced-gf
(x))
438 (defmethod traced-gf (x) (1+ x
))
440 (with-test (:name
(trace generic-function
))
441 (assert (= (traced-gf 3) 4))
443 (let ((output (with-output-to-string (*trace-output
*)
444 (assert (= (traced-gf 3) 4)))))
445 (assert (> (length output
) 0))
446 (assert (search "0: (TRACED-GF 3)" output
))
447 (assert (search "0: TRACED-GF returned 4" output
)))
448 (assert (typep #'traced-gf
'standard-generic-function
))
450 (let ((output (with-output-to-string (*trace-output
*)
451 (assert (= (traced-gf 3) 4)))))
452 (assert (= (length output
) 0))))
455 (with-test (:name
(trace generic-function
:methods t
))
456 (trace :methods t traced-gf
)
457 (let ((output (with-output-to-string (*trace-output
*)
458 (assert (= (traced-gf 4) 5)))))
459 (assert (> (length output
) 0))
460 (assert (search "0: (TRACED-GF 4)" output
))
461 (assert (search "0: TRACED-GF returned 5" output
))
462 (assert (search "1: ((METHOD TRACED-GF (T)) 4)" output
))
463 (assert (search "1: (METHOD TRACED-GF (T)) returned 5" output
)))
465 (let ((output (with-output-to-string (*trace-output
*)
466 (assert (= (traced-gf 3) 4)))))
467 (assert (= (length output
) 0))))
469 (defmethod traced-gf :before
(x) :before
)
470 (defmethod traced-gf :after
((x integer
)) :after
)
473 (with-test (:name
(trace generic-function
:methods
:combined
))
474 (trace :methods t traced-gf
)
475 (let ((output (with-output-to-string (*trace-output
*)
476 (assert (= (traced-gf 5) 6)))))
477 (assert (> (length output
) 0))
478 (assert (search "0: (TRACED-GF 5)" output
))
479 (assert (search "0: TRACED-GF returned 6" output
))
480 (assert (search "1: ((SB-PCL::COMBINED-METHOD TRACED-GF) 5)" output
))
481 (assert (search "1: (SB-PCL::COMBINED-METHOD TRACED-GF) returned 6" output
))
482 (assert (search "2: ((METHOD TRACED-GF :BEFORE (T)) 5)" output
))
483 (assert (search "2: (METHOD TRACED-GF :BEFORE (T)) returned :BEFORE" output
))
484 (assert (search "2: ((METHOD TRACED-GF :AFTER (INTEGER)) 5)" output
))
485 (assert (search "2: (METHOD TRACED-GF :AFTER (INTEGER)) returned :AFTER" output
))
486 (assert (search "2: ((METHOD TRACED-GF (T)) 5)" output
))
487 (assert (search "2: (METHOD TRACED-GF (T)) returned 6" output
)))
489 (let ((output (with-output-to-string (*trace-output
*)
490 (assert (= (traced-gf 3) 4)))))
491 (assert (= (length output
) 0))))
493 (let* ((mf (lambda (args nms
)
494 (declare (ignore nms
))
496 (m (make-instance 'standard-method
497 :specializers
(list (find-class 'integer
))
501 (add-method #'traced-gf m
))
504 (with-test (:name
(trace generic-function
:methods
:method-function
))
505 (trace :methods t traced-gf
)
506 (let ((output (with-output-to-string (*trace-output
*)
507 (assert (= (traced-gf 5) 10)))))
508 (assert (> (length output
) 0))
509 (assert (search "0: (TRACED-GF 5)" output
))
510 (assert (search "0: TRACED-GF returned 10" output
))
511 (assert (search "1: ((SB-PCL::COMBINED-METHOD TRACED-GF) 5)" output
))
512 (assert (search "1: (SB-PCL::COMBINED-METHOD TRACED-GF) returned 10" output
))
513 (assert (search "2: ((METHOD TRACED-GF :BEFORE (T)) 5)" output
))
514 (assert (search "2: (METHOD TRACED-GF :BEFORE (T)) returned :BEFORE" output
))
515 (assert (search "2: ((METHOD TRACED-GF :AFTER (INTEGER)) 5)" output
))
516 (assert (search "2: (METHOD TRACED-GF :AFTER (INTEGER)) returned :AFTER" output
))
517 (assert (search "2: ((METHOD TRACED-GF (INTEGER)) 5)" output
))
518 (assert (search "2: (METHOD TRACED-GF (INTEGER)) returned 10" output
)))
520 (let ((output (with-output-to-string (*trace-output
*)
521 (assert (= (traced-gf 5) 10)))))
522 (assert (= (length output
) 0))))
524 (with-test (:name
:undefined-fun-macro-error
)
525 (assert (search "is a macro" (princ-to-string (make-condition 'undefined-function
:name
'cond
)))))
527 (defun testme (a b
) (values "nice" (+ a b
)))
529 (defparameter trace-this-f1
#'testme
)
530 (sb-int:encapsulate-funobj trace-this-f1
'testme
)
532 (defun funky (a b c
) (lambda (z) (values "nice" a b
(+ (incf a
) (decf c
) z
))))
534 (defparameter trace-this-f2
(funky 10 'wat
19))
535 (setf (symbol-function 'funky-closure
) trace-this-f2
)
536 (sb-int:encapsulate-funobj trace-this-f2
'trace-this-f2
)
538 (with-test (:name
:trace-funobj-encapsulation
)
539 (assert (search "returned \"nice\""
540 (with-output-to-string (*trace-output
*) (funcall trace-this-f1
1 2))))
541 (assert (search "returned \"nice\""
542 (with-output-to-string (*trace-output
*) (testme 3 4))))
543 (assert (search "returned \"nice\""
544 (with-output-to-string (*trace-output
*) (funcall trace-this-f2
1))))
545 (assert (search "returned \"nice\""
546 (with-output-to-string (*trace-output
*) (funky-closure 5)))))
548 ;;; https://bugs.launchpad.net/sbcl/+bug/1850531
549 (with-test (:name
:describe-function-not-named-by-designator
)
550 (describe (formatter "~&~A~A") (make-broadcast-stream))) ; should not crash
552 (defun test-intercepted-load (arg) (apply #'load arg
(list :foo
:bar
:allow-other-keys t
)))
553 (compile 'test-intercepted-load
)
554 (sb-int:encapsulate
'load
'interceptor
555 (compile nil
'(lambda (realfun pathname
&rest things
)
556 (if (eq pathname
:testme
)
558 (apply realfun pathname things
)))))
560 (with-test (:name
:load-encapsulatable
)
561 (assert (eq (test-intercepted-load :testme
) :yes
)))