use *SUPPRESS-PRINT-ERRORS* for backtraces and DESCRIBE
[sbcl.git] / tests / interface.impure.lisp
index 2de5766..613bc66 100644 (file)
 ;;; support for DESCRIBE tests
 (defstruct to-be-described a b)
 (defclass forward-describe-class (forward-describe-ref) (a))
+(let ((sb-ext:*evaluator-mode* :compile))
+  (eval `(let (x) (defun closure-to-describe () (incf x)))))
 
 ;;; DESCRIBE should run without signalling an error.
-(describe (make-to-be-described))
-(describe 12)
-(describe "a string")
-(describe 'symbolism)
-(describe (find-package :cl))
-(describe '(a list))
-(describe #(a vector))
+(with-test (:name (describe :no-error))
+  (describe (make-to-be-described))
+  (describe 12)
+  (describe "a string")
+  (describe 'symbolism)
+  (describe (find-package :cl))
+  (describe '(a list))
+  (describe #(a vector))
+;; bug 824974
+  (describe 'closure-to-describe))
 
 ;;; The DESCRIBE-OBJECT methods for built-in CL stuff should do
 ;;; FRESH-LINE and TERPRI neatly.
   (assert (equal "foo" (documentation 'bug-643958-test 'function)))
   (setf (documentation 'bug-643958-test 'function) "bar")
   (assert (equal "bar" (documentation 'bug-643958-test 'function))))
+
+(defclass cannot-print-this ()
+  ())
+(defmethod print-object ((oops cannot-print-this) stream)
+  (error "No go!"))
+(with-test (:name :describe-suppresses-print-errors)
+  (handler-bind ((error #'continue))
+    (with-output-to-string (s)
+      (describe (make-instance 'cannot-print-this) s))))
+(with-test (:name :backtrace-suppresses-print-errors)
+  (handler-bind ((error #'continue))
+    (with-output-to-string (s)
+      (labels ((foo (n x)
+                 (when (plusp n)
+                   (foo (1- n) x))
+                 (when (zerop n)
+                   (sb-debug:backtrace 100 s))))
+        (foo 100 (make-instance 'cannot-print-this))))))
+(with-test (:name :backtrace-and-circles)
+  (handler-bind ((error #'continue))
+    (with-output-to-string (s)
+      (labels ((foo (n x)
+                 (when (plusp n)
+                   (foo (1- n) x))
+                 (when (zerop n)
+                   (sb-debug:backtrace 100 s))))
+        (foo 100 (let ((list (list t)))
+                   (nconc list list)))))))
 \f
 ;;;; success