X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdebug.impure.lisp;h=a4c6114d3418b95959922a3b207c3d7a3113f1ed;hb=f066ad2b0b89c016ab9ceaac6de0758e4eb4c1fb;hp=308d3d66a3a8a4760cdc94ff9dfe147e55cd59e6;hpb=69fe69971242dba6905e9c55f8ce6a9a93c9e403;p=sbcl.git

diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 308d3d6..a4c6114 100644
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -61,16 +61,18 @@
 ;;; argument of PRINT might be SB-IMPL::OBJECT or SB-KERNEL::OBJ or
 ;;; whatever. But we do know the general structure that a correct
 ;;; answer should have, so we can safely do a lot of checks.)
-(destructuring-bind (object-sym &optional-sym stream-sym) (get-arglist #'print)
-  (assert (symbolp object-sym))
-  (assert (eql &optional-sym '&optional))
-  (assert (symbolp stream-sym)))
-(destructuring-bind (dest-sym control-sym &rest-sym format-args-sym)
-    (get-arglist #'format)
-  (assert (symbolp dest-sym))
-  (assert (symbolp control-sym))
-  (assert (eql &rest-sym '&rest))
-  (assert (symbolp format-args-sym)))
+(with-test (:name :predefined-functions-1)
+  (destructuring-bind (object-sym &optional-sym stream-sym) (get-arglist #'print)
+    (assert (symbolp object-sym))
+    (assert (eql &optional-sym '&optional))
+    (assert (symbolp stream-sym))))
+(with-test (:name :predefined-functions-2)
+  (destructuring-bind (dest-sym control-sym &rest-sym format-args-sym)
+      (get-arglist #'format)
+    (assert (symbolp dest-sym))
+    (assert (symbolp control-sym))
+    (assert (eql &rest-sym '&rest))
+    (assert (symbolp format-args-sym))))
 
 ;;; Check for backtraces generally being correct.  Ensure that the
 ;;; actual backtrace finishes (doesn't signal any errors on its own),
@@ -171,6 +173,19 @@
                    (list '(flet not-optimized))
                    (list '(flet test) #'not-optimized))))))
 
+(with-test (:name :backtrace-interrupted-condition-wait
+            :skipped-on '(not :sb-thread))
+  (let ((m (sb-thread:make-mutex))
+        (q (sb-thread:make-waitqueue)))
+    (assert (verify-backtrace
+            (lambda ()
+              (sb-thread:with-mutex (m)
+                (handler-bind ((timeout (lambda (c)
+                                          (error "foo"))))
+                  (with-timeout 0.1
+                    (sb-thread:condition-wait q m)))))
+            `((sb-thread:condition-wait ,q ,m))))))
+
 ;;; Division by zero was a common error on PPC. It depended on the
 ;;; return function either being before INTEGER-/-INTEGER in memory,
 ;;; or more than MOST-POSITIVE-FIXNUM bytes ahead. It also depends on
@@ -356,9 +371,10 @@
 (write-line "//compile nil")
 (defvar *compile-nil-error* (compile nil '(lambda (x) (cons (when x (error "oops")) nil))))
 (defvar *compile-nil-non-tc* (compile nil '(lambda (y) (cons (funcall *compile-nil-error* y) nil))))
-(assert (verify-backtrace (lambda () (funcall *compile-nil-non-tc* 13))
-                          '(((lambda (x)) 13)
-                            ((lambda (y)) 13))))
+(with-test (:name (:compile nil))
+  (assert (verify-backtrace (lambda () (funcall *compile-nil-non-tc* 13))
+                            '(((lambda (x)) 13)
+                              ((lambda (y)) 13)))))
 
 (with-test (:name :clos-slot-typecheckfun-named)
   (assert
@@ -417,12 +433,13 @@
       1
       (* n (trace-fact (1- n)))))
 
-(let ((out (with-output-to-string (*trace-output*)
-             (trace trace-this)
-             (assert (eq 'ok (trace-this)))
-             (untrace))))
-  (assert (search "TRACE-THIS" out))
-  (assert (search "returned OK" out)))
+(with-test (:name (trace :simple))
+  (let ((out (with-output-to-string (*trace-output*)
+               (trace trace-this)
+               (assert (eq 'ok (trace-this)))
+               (untrace))))
+    (assert (search "TRACE-THIS" out))
+    (assert (search "returned OK" out))))
 
 ;;; bug 379
 ;;; This is not a WITH-TEST :FAILS-ON PPC DARWIN since there are
@@ -477,6 +494,21 @@
                                 (notany #'sb-debug::stack-allocated-p (cdr frame))))
                          (dx-arg-backtrace dx-arg))))))
 
+(with-test (:name :bug-795245)
+  (assert
+   (eq :ok
+       (catch 'done
+         (handler-bind
+             ((error (lambda (e)
+                       (declare (ignore e))
+                       (handler-case
+                           (sb-debug:backtrace 100 (make-broadcast-stream))
+                         (error ()
+                           (throw 'done :error))
+                         (:no-error ()
+                           (throw 'done :ok))))))
+           (apply '/= nil 1 2 nil))))))
+
 ;;;; test infinite error protection
 
 (defmacro nest-errors (n-levels error-form)
@@ -510,14 +542,17 @@
                      :normal-exit)))))))
   (write-line "--END OF H-B-A-B--"))
 
-(enable-debugger)
-
-(test-inifinite-error-protection)
+(with-test (:name infinite-error-protection)
+  (enable-debugger)
+  (test-inifinite-error-protection))
 
-#+sb-thread
-(let ((thread (sb-thread:make-thread #'test-inifinite-error-protection)))
-  (loop while (sb-thread:thread-alive-p thread)))
+(with-test (:name (infinite-error-protection :thread)
+                  :skipped-on '(not :sb-thread))
+  (enable-debugger)
+  (let ((thread (sb-thread:make-thread #'test-inifinite-error-protection)))
+    (loop while (sb-thread:thread-alive-p thread))))
 
+;; unconditional, in case either previous left it enabled
 (disable-debugger)
 
 (write-line "/debug.impure.lisp done")