X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Funwind-to-frame-and-call.impure.lisp;h=7e56338980b6eb80a3009f2d7cd482e264ad19bf;hb=HEAD;hp=c746e5b92b8159c3e3480dd03c56b32f72e203b6;hpb=2050b7c3644ab235aaf1959795bb33e89bd571a3;p=sbcl.git

diff --git a/tests/unwind-to-frame-and-call.impure.lisp b/tests/unwind-to-frame-and-call.impure.lisp
index c746e5b..7e56338 100644
--- a/tests/unwind-to-frame-and-call.impure.lisp
+++ b/tests/unwind-to-frame-and-call.impure.lisp
@@ -14,7 +14,7 @@
 
 ;;; The debugger doesn't have any native knowledge of the interpreter
 (when (eq sb-ext:*evaluator-mode* :interpret)
-  (sb-ext:quit :unix-status 104))
+  (sb-ext:exit :code 104))
 
 (declaim (optimize debug))
 
@@ -75,7 +75,18 @@
     (signal 'restart-condition))
   foo)
 
+#+win32
+(defun decline ()
+  ;; these tests currently fail no matter whether threads are enabled or
+  ;; not, but on threaded builds the failure mode is particularly
+  ;; unfortunate.  As a workaround, opt out of running the test.
+  #+sb-thread
+  (error "this test fails with exception 0xc0000029 ~
+          (STATUS_INVALID_UNWIND_TARGET), from which we cannot currently ~
+          recover"))
+
 (defun test-restart (name)
+  #+win32 (decline)
   (setf *a* nil)
   (let ((*foo* 'x))
     (let ((*foo* 'y)
@@ -88,13 +99,13 @@
     ;; Check that the binding stack was correctly unwound.
     (assert (eql *foo* 'x))))
 
-(with-test (:name (:restart-frame :special))
+(with-test (:name (:restart-frame :special) :fails-on :win32)
   (test-restart 'restart/special))
 
-(with-test (:name (:restart-frame :optional-special))
+(with-test (:name (:restart-frame :optional-special) :fails-on :win32)
   (test-restart 'restart/optional-special))
 
-(with-test (:name (:restart-frame :normal))
+(with-test (:name (:restart-frame :normal) :fails-on :win32)
   (test-restart 'restart/normal))
 
 
@@ -129,6 +140,7 @@
   foo)
 
 (defun test-return (name)
+  #+win32 (decline)
   (setf *a* nil)
   (let ((*foo* 'x))
     (let ((*foo* 'y))
@@ -140,22 +152,23 @@
     ;; Check that the binding stack was correctly unwound.
     (assert (eql *foo* 'x))))
 
-(with-test (:name (:return-from-frame :special))
+(with-test (:name (:return-from-frame :special) :fails-on :win32)
   (test-return 'return/special))
 
-(with-test (:name (:return-from-frame :optional-special))
+(with-test (:name (:return-from-frame :optional-special) :fails-on :win32)
   (test-return 'return/optional-special))
 
-(with-test (:name (:return-from-frame :normal))
+(with-test (:name (:return-from-frame :normal) :fails-on :win32)
   (test-return 'return/normal))
 
 (defun throw-y () (throw 'y 'y))
 
 ;; Check that *CURRENT-CATCH-BLOCK* was correctly restored.
-(assert (eql (catch 'y
-               (test-return 'return/catch)
-               (throw-y))
-             'y))
+(with-test (:name :current-catch-block-restored :fails-on :win32)
+  (assert (eql (catch 'y
+                 (test-return 'return/catch)
+                 (throw-y))
+               'y)))
 
 
 ;;;; Test RETURN-FROM-FRAME with local functions
@@ -192,6 +205,7 @@
       (setf *b* (multiple-value-list (b :*c* :good))))))
 
 (defun test-locals (name)
+  #+win32 (decline)
   (handler-bind ((in-a (lambda (c)
                          (declare (ignore c))
                          (return-from-frame `(flet a :in ,name) 'x 'y)))
@@ -211,10 +225,10 @@
       (assert (equal *b* '(z))))
     (assert (eql *foo* 'x))))
 
-(with-test (:name (:return-from-frame :local-function))
+(with-test (:name (:return-from-frame :local-function) :fails-on :win32)
   (test-locals 'locals))
 
-(with-test (:name (:return-from-frame :hairy-local-function))
+(with-test (:name (:return-from-frame :hairy-local-function) :fails-on :win32)
   (test-locals 'hairy-locals))
 
 
@@ -250,6 +264,7 @@
 (defparameter *anon-4* (make-anon-4))
 
 (defun test-anon (fun var-name &optional in)
+  #+win32 (decline)
   (handler-bind ((anon-condition (lambda (c)
                                    (declare (ignore c))
                                    (return-from-frame
@@ -262,16 +277,17 @@
         (assert (eql *foo* 'y)))
       (assert (eql *foo* 'x)))))
 
-(with-test (:name (:return-from-frame :anonymous :toplevel))
+(with-test (:name (:return-from-frame :anonymous :toplevel) :fails-on :win32)
   (test-anon *anon-1* 'foo (namestring *load-truename*)))
 
-(with-test (:name (:return-from-frame :anonymous :toplevel-special))
+(with-test (:name (:return-from-frame :anonymous :toplevel-special)
+                  :fails-on :win32)
   (test-anon *anon-2* '*foo* (namestring *load-truename*)))
 
-(with-test (:name (:return-from-frame :anonymous))
+(with-test (:name (:return-from-frame :anonymous) :fails-on :win32)
   (test-anon *anon-3* 'foo 'make-anon-3))
 
-(with-test (:name (:return-from-frame :anonymous :special))
+(with-test (:name (:return-from-frame :anonymous :special) :fails-on :win32)
   (test-anon *anon-4* '*foo* 'make-anon-4))
 
 
@@ -292,6 +308,7 @@
     (push :unwind-2 *unwind-state*)))
 
 (defun test-unwind (fun wanted)
+  #+win32 (decline)
   (handler-bind ((return-condition (lambda (c)
                                      (declare (ignore c))
                                      (return-from-frame fun
@@ -308,8 +325,10 @@
           (assert (eql *foo* 'y)))
         (assert (eql *foo* 'x))))))
 
-(test-unwind 'unwind-1 '(:unwind-1))
-(test-unwind 'unwind-2 '(:unwind-2 :unwind-1))
+(with-test (:name :test-unwind-1 :fails-on :win32)
+  (test-unwind 'unwind-1 '(:unwind-1)))
+(with-test (:name :test-unwind-2 :fails-on :win32)
+  (test-unwind 'unwind-2 '(:unwind-2 :unwind-1)))
 
 ;;; Regression in 1.0.10.47 reported by James Knight