X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdebug.impure.lisp;h=db05cc35a019a9f4a251e26ecd0dcf380f242fc7;hb=165f17e83d068bc971cd41f407518e600c59a905;hp=86a0de6cea94dcd4e77d8ae141e84e3cfb2f4c68;hpb=d4f4b68910a64640f9b8c67560ffd7f4d57c54b9;p=sbcl.git

diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 86a0de6..db05cc3 100644
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -345,5 +345,42 @@
   (assert (search "TRACE-THIS" out))
   (assert (search "returned OK" out)))
 
+;;;; test infinite error protection
+
+(defmacro nest-errors (n-levels error-form)
+  (if (< 0 n-levels)
+      `(handler-bind ((error (lambda (condition)
+                               (declare (ignore condition))
+                               ,error-form)))
+        (nest-errors ,(1- n-levels) ,error-form))
+      error-form))
+
+(defun erroring-debugger-hook (condition old-debugger-hook)
+  (let ((*debugger-hook* old-debugger-hook))
+    (format t "recursive condition: ~A~%" condition) (force-output)
+    (error "recursive condition: ~A" condition)))
+
+(defun test-inifinite-error-protection ()
+  ;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used
+  ;; to halt, it produces so much garbage that's hard to suppress that
+  ;; it is tested only once
+  (let ((*debugger-hook* #'erroring-debugger-hook))
+    (loop repeat 1 do
+          (let ((error-counter 0)
+                (*terminal-io* (make-broadcast-stream)))
+            (assert
+             (not (eq
+                   :normal-exit
+                   (catch 'sb-impl::toplevel-catcher
+                     (nest-errors 20 (error "infinite error ~s"
+                                            (incf error-counter)))
+                     :normal-exit))))))))
+
+(test-inifinite-error-protection)
+
+#+sb-thread
+(let ((thread (sb-thread:make-thread #'test-inifinite-error-protection)))
+  (loop while (sb-thread:thread-alive-p thread)))
+
 ;;; success
 (quit :unix-status 104)