Rename two genesis functions
[sbcl.git] / tests / interface.impure.lisp
blob30c690956d2bd034b9761b4e0853c7ffa5c01265
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
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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)))
32 #+sb-eval
33 (eval-when (:compile-toplevel :load-toplevel :execute)
34 (import 'sb-eval:interpreted-function-p))
35 #+sb-fasteval
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:
61 (defun fle-fun (x) x)
63 (let ((x 1)) (defun fle-closure (y) (if y (setq x y) x)))
65 (with-test (:name :function-lambda-expression)
66 (flet ((fle-name (x)
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)
78 (progn
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 (assert-no-signal
95 (silently (describe (make-instance 'generic-function)))
96 warning)
97 (assert-signal
98 (silently (describe (make-instance 'standard-generic-function)))
99 warning))
101 ;;; DESCRIBE should run without signalling an error.
102 (with-test (:name (describe :no-error))
103 (silently
104 (describe (make-to-be-described))
105 (describe 12)
106 (describe "a string")
107 (describe 'symbolism)
108 (describe (find-package :cl))
109 (describe '(a list))
110 (describe #(a vector))
111 ;; bug 824974
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
123 (gethash 11 h) 121)
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)
133 (write-char #\x s)
134 (describe i s))))
135 (macrolet ((check (form)
136 `(or ,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)))))))))
147 (with-test (:name (describe :argument-precedence-order))
148 ;; Argument precedence order information is only interesting for two
149 ;; or more required parameters.
150 (assert (not (search "Argument precedence order"
151 (with-output-to-string (stream)
152 (describe #'class-name stream)))))
153 (assert (search "Argument precedence order"
154 (with-output-to-string (stream)
155 (describe #'add-method stream)))))
158 ;;; Tests of documentation on types and classes
160 (defun assert-documentation (thing doc-type expected)
161 ;; This helper function makes ASSERT errors print THING, DOC-TYPE,
162 ;; the return value of DOCUMENTATION and EXPECTED.
163 (flet ((assert-documentation-helper (thing doc-type documentation expected)
164 (declare (ignore thing doc-type))
165 (equal documentation expected)))
166 (assert (assert-documentation-helper
167 thing doc-type (documentation thing doc-type) expected))))
169 (defpackage #:documentation.package
170 (:documentation "PACKAGE"))
172 (with-test (:name (documentation package))
173 (assert-documentation (find-package '#:documentation.package) t "PACKAGE")
174 (setf (documentation (find-package '#:documentation.package) t) "PACKAGE2")
175 (assert-documentation (find-package '#:documentation.package) t "PACKAGE2"))
177 (defclass foo ()
179 (:documentation "FOO"))
181 (defclass documentation.funcallable-instance ()
183 (:metaclass sb-mop:funcallable-standard-class)
184 (:documentation "FEZ"))
186 (defstruct bar "BAR")
188 (define-condition baz ()
190 (:documentation "BAZ"))
192 (macrolet
193 ((do-class (name expected &optional structurep)
194 `(progn
195 (assert-documentation ',name 'type ,expected)
196 (assert-documentation (find-class ',name) 'type ,expected)
197 (assert-documentation (find-class ',name) 't ,expected)
198 ,@(when structurep
199 `((assert-documentation ',name 'structure ,expected)))
201 (let ((new1 (symbol-name (gensym "NEW1")))
202 (new2 (symbol-name (gensym "NEW2")))
203 (new3 (symbol-name (gensym "NEW3")))
204 (new4 (symbol-name (gensym "NEW4"))))
205 (declare (ignorable new4))
206 (setf (documentation ',name 'type) new1)
207 (assert-documentation (find-class ',name) 'type new1)
208 (setf (documentation (find-class ',name) 'type) new2)
209 (assert-documentation (find-class ',name) 't new2)
210 (setf (documentation (find-class ',name) 't) new3)
211 (assert-documentation ',name 'type new3)
212 ,@(when structurep
213 `((assert-documentation ',name 'structure new3)
214 (setf (documentation ',name 'structure) new4)
215 (assert-documentation ',name 'structure new4)))))))
217 (with-test (:name (documentation class standard-class))
218 (do-class foo "FOO"))
220 (with-test (:name (documentation class sb-mop:funcallable-standard-class))
221 (do-class documentation.funcallable-instance "FEZ"))
223 (with-test (:name (documentation struct 1))
224 (do-class bar "BAR" t))
226 (with-test (:name (documentation condition))
227 (do-class baz "BAZ")))
229 (defclass documentation-metaclass (standard-class)
231 (:documentation "metaclass with methods on DOCUMENTATION."))
233 (defmethod documentation ((thing documentation-metaclass)
234 (doc-type (eql 't)))
235 (sb-int:awhen (call-next-method)
236 (concatenate 'string ":" sb-int:it)))
238 (defmethod (setf documentation) (new-value
239 (thing documentation-metaclass)
240 (doc-type (eql 't)))
241 (call-next-method (when new-value
242 (substitute #\! #\. new-value))
243 thing doc-type))
245 (defmethod sb-mop:validate-superclass ((class documentation-metaclass)
246 (superclass standard-class))
249 (defclass documentation-class ()
251 (:metaclass documentation-metaclass)
252 (:documentation "normal"))
254 (with-test (:name (documentation :non-stanadard :metaclass))
255 (flet ((check (expected class-name)
256 (let ((class (find-class class-name)))
257 (assert-documentation class-name 'type expected)
258 (assert-documentation class 'type expected)
259 (assert-documentation class t expected))))
260 ;; Make sure methods specialized on the metaclass are not bypassed
261 ;; when retrieving and modifying class documentation.
262 (check ":normal" 'documentation-class)
263 (setf (documentation 'documentation-class 'type) "2.")
264 (check ":2!" 'documentation-class)
265 (setf (documentation 'documentation-class 'type) nil)
266 (check nil 'documentation-class)
268 ;; Sanity check: make sure the metaclass has its own documentation
269 ;; and is not affected by the above modifications.
270 (check "metaclass with methods on DOCUMENTATION."
271 'documentation-metaclass)))
273 (defstruct (frob (:type vector)) "FROB")
275 (with-test (:name (documentation struct 2))
276 (assert-documentation 'frob 'structure "FROB")
277 (setf (documentation 'frob 'structure) "NEW5")
278 (assert-documentation 'frob 'structure "NEW5"))
280 (deftype quux ()
281 "QUUX"
284 (with-test (:name (documentation type))
285 (assert-documentation 'quux 'type "QUUX")
286 (setf (documentation 'quux 'type) "NEW4")
287 (assert-documentation 'quux 'type "NEW4"))
289 (define-compiler-macro cmacro (x)
290 "compiler macro"
293 (define-compiler-macro (setf cmacro) (y x)
294 "setf compiler macro"
295 (declare (ignore x))
298 (with-test (:name (documentation compiler-macro))
299 (assert-documentation 'cmacro 'compiler-macro "compiler macro")
300 (assert-documentation '(setf cmacro) 'compiler-macro "setf compiler macro"))
302 (defun (setf documentation.setf) (x)
303 "(setf foo) documentation"
306 (with-test (:name (documentation function setf))
307 (flet ((expect (documentation)
308 (assert-documentation
309 '(setf documentation.setf) 'function documentation)
310 (assert-documentation
311 #'(setf documentation.setf) 'function documentation)
312 (assert-documentation
313 #'(setf documentation.setf) t documentation)))
314 (expect "(setf foo) documentation")
315 ;; The original test checked this twice. No idea why.
316 (expect "(setf foo) documentation")
318 ;; Modification
319 (setf (documentation '(setf documentation.setf) 'function)
320 "(setf bar) documentation")
321 (expect "(setf bar) documentation")
323 (setf (documentation #'(setf documentation.setf) 'function)
324 "(setf baz) documentation")
325 (expect "(setf baz) documentation")
327 (setf (documentation #'(setf documentation.setf) t)
328 "(setf fez) documentation")
329 (expect "(setf fez) documentation")))
331 (with-test (:name (documentation lambda))
332 (let ((f (lambda () "aos the zos" t))
333 (g (sb-int:named-lambda fii () "zoot the fruit" t)))
334 (dolist (doc-type '(t function))
335 (assert-documentation f doc-type "aos the zos")
336 (assert-documentation g doc-type "zoot the fruit"))
337 (setf (documentation f t) "fire")
338 (assert-documentation f t "fire")
339 (assert-documentation g t "zoot the fruit")))
341 (with-test (:name (documentation flet))
342 (assert
343 (string= (documentation
344 (flet ((quux (x)
345 "this is FLET quux"
346 (/ x 2)))
347 #'quux)
349 "this is FLET quux")))
351 (with-test (:name (documentation labels))
352 (assert
353 (string= (documentation
354 (labels ((rec (x)
355 "this is LABELS rec"
356 (if (plusp x)
357 (* x (rec (1- x)))
358 1)))
359 #'rec)
361 "this is LABELS rec")))
363 (let ((x 1))
364 (defun docfoo (y)
365 "bar"
366 (incf x y)))
368 (with-test (:name (documentation :closure))
369 (assert-documentation 'docfoo 'function "bar")
370 (assert (string= (setf (documentation 'docfoo 'function) "baz") "baz"))
371 (assert-documentation 'docfoo 'function "baz")
372 (assert-documentation #'docfoo t "baz")
373 (assert (string= (setf (documentation #'docfoo t) "zot") "zot"))
374 (assert-documentation #'docfoo t "zot")
375 (assert-documentation 'docfoo 'function "zot")
376 (assert (not (setf (documentation 'docfoo 'function) nil)))
377 (assert-documentation 'docfoo 'function nil))
379 (with-test (:name (documentation :built-in-macro) :skipped-on '(not :sb-doc))
380 (assert (documentation 'trace 'function)))
382 (with-test (:name (documentation :built-in-function) :skipped-on '(not :sb-doc))
383 (assert (documentation 'cons 'function)))
385 (defvar documentation.variable nil
386 "foo variable documentation")
388 (with-test (:name (documentation variable))
389 (assert-documentation 'documentation.variable 'variable
390 "foo variable documentation")
391 (setf (documentation 'documentation.variable 'variable)
392 "baz variable documentation")
393 (assert-documentation 'documentation.variable 'variable
394 "baz variable documentation"))
396 (with-test (:name (documentation :mismatch-for-function))
397 (defun test ()
399 nil)
400 (setf (symbol-function 'test2) #'test)
401 (setf (documentation 'test 'function) "Y")
402 (assert (equal (documentation #'test t)
403 (documentation 'test 'function)))
404 (setf (documentation 'test2 'function) "Z")
405 (assert (not
406 (equal (documentation 'test 'function)
407 (documentation 'test2 'function)))))
409 (with-test (:name (documentation setf :on nil))
410 (assert
411 (handler-case
412 (assert (equal (setf (documentation nil 'function) "foo") "foo"))
413 (style-warning () t)
414 (:no-error (x)
415 (declare (ignore x))
416 nil))))
418 (with-test (:name (describe generic-function :assumed-type))
419 ;; Signalled an error at one point
420 (let ((fun (checked-compile '(lambda ()
421 (flet ((zoo () (gogo)))
422 (defmethod gogo () nil)
423 (describe 'gogo)))
424 :allow-style-warnings t)))
425 (handler-bind ((warning #'muffle-warning)) ; implicit gf
426 (silently (funcall fun)))))
428 (defmacro bug-643958-test ()
429 "foo"
430 :ding!)
432 (with-test (:name :bug-643958)
433 (assert (equal "foo" (documentation 'bug-643958-test 'function)))
434 (setf (documentation 'bug-643958-test 'function) "bar")
435 (assert (equal "bar" (documentation 'bug-643958-test 'function))))
437 (defclass cannot-print-this ()
439 (defmethod print-object ((oops cannot-print-this) stream)
440 (error "No go!"))
441 (with-test (:name :describe-suppresses-print-errors)
442 (handler-bind ((error #'continue))
443 (with-output-to-string (s)
444 (describe (make-instance 'cannot-print-this) s))))
445 (with-test (:name :backtrace-suppresses-print-errors)
446 (handler-bind ((error #'continue))
447 (with-output-to-string (s)
448 (labels ((foo (n x)
449 (when (plusp n)
450 (foo (1- n) x))
451 (when (zerop n)
452 (sb-debug:print-backtrace :count 100 :stream s))))
453 (foo 100 (make-instance 'cannot-print-this))))))
454 (with-test (:name :backtrace-and-circles)
455 (handler-bind ((error #'continue))
456 (with-output-to-string (s)
457 (labels ((foo (n x)
458 (when (plusp n)
459 (foo (1- n) x))
460 (when (zerop n)
461 (sb-debug:print-backtrace :count 100 :stream s))))
462 (foo 100 (let ((list (list t)))
463 (nconc list list)))))))
465 (with-test (:name :endianness-in-features)
466 (assert
467 (or (member :big-endian *features*)
468 (member :little-endian *features*))))
470 (with-test (:name (trace generic-function))
471 (defgeneric traced-gf (x))
472 (defmethod traced-gf (x) (1+ x))
473 (assert (= (traced-gf 3) 4))
474 (trace traced-gf)
475 (let ((output (with-output-to-string (*trace-output*)
476 (assert (= (traced-gf 3) 4)))))
477 (assert (> (length output) 0)))
478 (assert (typep #'traced-gf 'standard-generic-function))
479 (untrace traced-gf)
480 (let ((output (with-output-to-string (*trace-output*)
481 (assert (= (traced-gf 3) 4)))))
482 (assert (= (length output) 0))))
484 (with-test (:name (apropos :inherited :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)) 1))
490 (assert (= (length (apropos-list "BUGGALO" inherits)) 1))
491 (delete-package inherits))
492 (delete-package package)))
494 (with-test (:name (apropos :inherited :external-only :bug-1364413))
495 (let* ((package (make-package "BUGGALO" :use nil))
496 (symbol (intern "BUGGALO" package)))
497 (export (list symbol) package)
498 (let ((inherits (make-package "BUGGALO-INHERITS" :use (list package))))
499 (assert (= (length (apropos-list "BUGGALO" package t)) 1))
500 (assert (= (length (apropos-list "BUGGALO" inherits t)) 0))
501 (delete-package inherits))
502 (delete-package package)))
504 (with-test (:name (apropos :once-only))
505 (assert (= (length (apropos-list "UPDATE-INSTANCE-FOR-REDEFINED-CLASS")) 1)))
507 (defgeneric gf-arglist-1 (x &key y))
508 (defmethod gf-arglist-1 (x &key (y nil) (z nil z-p))
509 (list x y z z-p))
511 (defgeneric gf-arglist-2 (x &key y))
512 (defmethod gf-arglist-2 ((x integer) &key (y nil) ((z f) nil z-p)) (list x y f z-p))
513 (defmethod gf-arglist-2 ((x string) &key (y nil) ((z w) nil z-p)) (list x y w z-p))
515 (defgeneric gf-arglist-3 (x &key ((:y y))))
517 (defgeneric gf-arglist-4 (x &key ((:y z))))
519 (defgeneric gf-arglist-5 (x &key y))
520 (defmethod gf-arglist-5 ((x integer) &key z &allow-other-keys) (list x z))
522 (with-test (:name (:generic-function-pretty-arglist 1))
523 (assert (equal (sb-pcl::generic-function-pretty-arglist #'gf-arglist-1)
524 '(x &key y z))))
525 (with-test (:name (:generic-function-pretty-arglist 2))
526 (assert (or (equal (sb-pcl::generic-function-pretty-arglist #'gf-arglist-2)
527 '(x &key y ((z w))))
528 (equal (sb-pcl::generic-function-pretty-arglist #'gf-arglist-2)
529 '(x &key y ((z f)))))))
530 (with-test (:name (:generic-function-pretty-arglist 3))
531 (assert (equal (sb-pcl::generic-function-pretty-arglist #'gf-arglist-3)
532 '(x &key y))))
533 (with-test (:name (:generic-function-pretty-arglist 4))
534 (assert (equal (sb-pcl::generic-function-pretty-arglist #'gf-arglist-4)
535 '(x &key ((:y z))))))
536 (with-test (:name (:generic-function-pretty-arglist 5))
537 (assert (equal (sb-pcl::generic-function-pretty-arglist #'gf-arglist-5)
538 '(x &key y z &allow-other-keys))))
539 ;;;; success