common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Enable disabled tests in windows

Browse source
This commit is contained in:
Stas Boukarev 2026-02-18 03:18:28 +03:00
parent fe4abcce7c
commit 0d9ac5eeaa
33 changed files with 107 additions and 155 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
tests/alien.impure.lisp
View file

@ -271,11 +271,9 @@
(declaim (inline bug-316075))
;; KLUDGE: This win32 reader conditional masks a bug, but allows the
;; test to fail cleanly.
#-win32
(locally (declare (muffle-conditions style-warning))
(sb-alien:define-alien-routine bug-316075 void (result char :out)))
(with-test (:name :bug-316075 :fails-on :win32)
#+win32 (error "fail")
(with-test (:name :bug-316075)
(checked-compile '(lambda () (multiple-value-list (bug-316075)))))
;;; Bug #316325: "return values of alien calls assumed truncated to
@ -330,7 +328,7 @@
(values (alien-funcall sys-execv1 program argv))))
:allow-notes nil))
(with-test (:name :bug-721087 :fails-on :win32)
(with-test (:name :bug-721087)
(assert (typep nil '(alien c-string)))
(assert (not (typep nil '(alien (c-string :not-null t)))))
(assert (eq :ok
@ -338,8 +336,8 @@
(posix-getenv nil)
(type-error (e)
(when (and (null (type-error-datum e))
(equal (type-error-expected-type e)
'(alien (c-string :not-null t))))
#-win32 (equal (type-error-expected-type e)
'(alien (c-string :not-null t))))
:ok))))))
(with-test (:name :make-alien-string)

3
tests/backtrace.impure.lisp
View file

@ -210,8 +210,7 @@
(list `(flet test :in ,*p*) #'not-optimized)))))
(with-test (:name (:backtrace :interrupted-condition-wait)
:skipped-on (not :sb-thread)
:broken-on :sb-safepoint) ;; unreliable
:skipped-on (not :sb-thread))
(let ((m (sb-thread:make-mutex))
(q (sb-thread:make-waitqueue)))
(assert-backtrace

3
tests/bug-1180102.impure.lisp
View file

@ -36,8 +36,7 @@
(test sb-thread:*current-thread*)))
(with-test (:name (:make-thread :interrupt-with :make-thread :bug-1180102)
:skipped-on (not :sb-thread)
:broken-on :sb-safepoint)
:skipped-on (not :sb-thread))
(fresh-line)
(write-string "; ")
(force-output)

3
tests/clos-cache.impure.lisp
View file

@ -98,8 +98,7 @@
sb-thread:*current-thread* e)
(sb-ext:exit :code 1))))
(with-test (:name :clos-cache-test
:broken-on :sb-safepoint)
(with-test (:name :clos-cache-test)
#+sb-thread
(let ((threads (loop repeat 32
collect (sb-thread:make-thread 'test-loop))))

3
tests/clos-interrupts.impure.lisp
View file

@ -78,8 +78,7 @@
'symbol)
(test-util:with-test (:name :compute-test
:skipped-on (not :sb-thread)
:broken-on :win32)
:skipped-on (not :sb-thread))
(compute-test 1 2)
;; Check that we actually interrupted something.

3
tests/concurrent-syscalls.impure.lisp
View file

@ -17,8 +17,7 @@
(abort-thread)))))))
;; (nanosleep -1 0) does not fail on FreeBSD
(with-test (:name (:exercising-concurrent-syscalls)
:broken-on :win32)
(with-test (:name (:exercising-concurrent-syscalls))
(let* (#-freebsd
(nanosleep-errno (progn
(sb-unix:nanosleep -1 0)

3
tests/condition-notify.pure.lisp
View file

@ -26,8 +26,7 @@
;;; exactly once, but on Linux I've seen threads print more than once, which
;;; unquestionably indicates spurious wakeup.
(defparameter nthreads 10)
(with-test (:name (:condition-variable :notify-multiple)
:broken-on :win32)
(with-test (:name (:condition-variable :notify-multiple))
(flet ((tester (name notify-fun)
(format t "~&Exercising ~A~%" name)
(let ((queue (make-waitqueue :name "queue"))

6
tests/deadlock.impure.lisp
View file

@ -107,8 +107,7 @@
:deadlock))))
(assert (eq :ok (join-thread t1)))))
(with-test (:name (:deadlock-detection :interrupts)
:broken-on :win32)
(with-test (:name (:deadlock-detection :interrupts))
(let* ((m1 (sb-thread:make-mutex :name "M1"))
(m2 (sb-thread:make-mutex :name "M2"))
(t1-can-go (sb-thread:make-semaphore :name "T1 can go"))
@ -278,8 +277,7 @@
;;; This encounters the "backing off for retry" error if attempting
;;; to start too many threads.
(defparameter *max-runnable-threads* #+x86-64 100 #-x86-64 5)
(with-test (:name :gc-deadlock
:broken-on :win32)
(with-test (:name :gc-deadlock)
#+nil (write-line "WARNING: THIS TEST WILL HANG ON FAILURE!")
;; Prior to 0.9.16.46 thread exit potentially deadlocked the
;; GC due to *all-threads-lock* and session lock. On earlier

4
tests/external-format.pure.lisp
View file

@ -308,9 +308,9 @@
(assert (eq (read-char s nil s) s)))))
;; Output routines must return the written element
(with-test (:name :output-routine-retval :skipped-on :win32)
(with-test (:name :output-routine-retval)
(dolist (x sb-impl::*output-routines*)
(with-open-file (f "/dev/null" :direction :output :if-exists :overwrite)
(with-open-file (f #-win32 "/dev/null" #+win32 "nul" :direction :output :if-exists :overwrite)
(let ((arg (if (eq (car x) 'character) #\z 99))
(fun (symbol-function (third x))))
(assert (eql arg (funcall fun f arg)))))))

3
tests/filesys.impure.lisp
View file

@ -81,7 +81,8 @@
(do-open 'append "foobar")))
#+sb-thread
(with-test (:name (probe-file :thread-safety))
(with-test (:name (probe-file :thread-safety)
:skipped-on :win32)
(let* ((filename (merge-pathnames "probe-file" *scratchdir*))
(threads (list (sb-thread:make-thread
(lambda ()

2
tests/fin-threadsafety.pure.lisp
View file

@ -30,7 +30,7 @@
;;; fruitful to concentrate their efforts around this test...
(with-test (:name (:funcallable-instances)
:broken-on (and :sb-safepoint (not :c-stack-is-control-stack)))
:broken-on (and :sb-safepoint :ppc))
;; the funcallable-instance implementation used not to be threadsafe
;; against setting the funcallable-instance function to a closure
;; (because the code and lexenv were set separately).

2
tests/finalize.impure.lisp
View file

@ -1,4 +1,4 @@
#+(or sb-safepoint interpreter) (invoke-restart 'run-tests::skip-file)
#+interpreter (invoke-restart 'run-tests::skip-file)
(defvar *tmp* 0.0) ; don't remove - used by the setq below
(defglobal *count* 0)

8
tests/gc-threads.impure.lisp
View file

@ -1,7 +1,7 @@
#-sb-thread (invoke-restart 'run-tests::skip-file)
(with-test (:name (:two-threads-running-gc)
:broken-on :sb-safepoint)
)
(let (a-done b-done)
(make-join-thread (lambda ()
(dotimes (i 100)
@ -21,8 +21,7 @@
(compile 'waste)
(with-test (:name (:one-thread-runs-gc-while-other-conses)
:broken-on :win32)
(with-test (:name (:one-thread-runs-gc-while-other-conses))
(loop for i below 100 do
(princ "!")
(force-output)
@ -33,8 +32,7 @@
(sb-ext:gc)))
(defparameter *aaa* nil)
(with-test (:name (:one-thread-runs-gc-while-other-conses :again)
:broken-on :win32)
(with-test (:name (:one-thread-runs-gc-while-other-conses :again))
(loop for i below 100 do
(princ "!")
(force-output)

4
tests/gc.impure.lisp
View file

@ -16,7 +16,7 @@
(defvar *weak-vect* (make-weak-vector 8))
(defmacro wvref (v i) `(sb-int:weak-vector-ref ,v ,i))
(with-test (:name :weak-vector
:fails-on :win32)
:fails-on (and :c-stack-is-control-stack :win32))
(let ((a *weak-vect*)
(random-symbol (make-symbol "FRED")))
(flet ((x ()
@ -536,6 +536,6 @@
(assert (search "modify a read-only object" err))))
(with-test (:name :time-measures
:skipped-on (:not (:and (:or :linux :darwin) :sb-thread)))
:skipped-on (:not (:and (:or :linux :darwin) :sb-thread)))
(assert (plusp (sb-thread::thread-sum-stw-pause sb-thread:*current-thread*)))
(assert (plusp (sb-thread::thread-gc-virtual-time sb-thread:*current-thread*))))

5
tests/hash-cache.pure.lisp
View file

@ -1,7 +1,4 @@
;;; FIXME: Since timeouts do not work on Windows this would loop
;;; forever.
(with-test (:name (:hash-cache :interrupt)
:skipped-on (or :win32 :sb-safepoint))
(with-test (:name (:hash-cache :interrupt))
(let* ((type1 (random-type 500))
(type2 (random-type 500))
(wanted (subtypep type1 type2)))

3
tests/input-manifest.lisp-expr
View file

@ -125,7 +125,8 @@
("sb-sprof.impure.lisp" "contrib/sb-sprof.fasl"
"../contrib/sb-sprof/test.lisp" "../contrib/sb-sprof/graph.lisp")
("signals.impure.lisp" "contrib/sb-posix.fasl")
("stream.impure.lisp" "contrib/sb-posix.fasl")
("stream.impure.lisp" "contrib/sb-posix.fasl" "tests/zero")
("stream.pure.lisp" "tests/zero")
("threads-2.impure.lisp"
"tests/alloca.so"
"tests/threads-foreign.so")

3
tests/interrupt-atomic-incf.impure.lisp
View file

@ -12,8 +12,7 @@
(unless (typep i 'fixnum)
(error "!!!!!!!!!!!")))
(with-test (:name (interrupt-thread :interrupt-ATOMIC-INCF)
:broken-on :win32)
(with-test (:name (interrupt-thread :interrupt-ATOMIC-INCF))
(let ((c (make-thread
(lambda ()
(handler-bind ((error #'(lambda (cond)

6
tests/interrupt-consing.impure.lisp
View file

@ -4,8 +4,7 @@
(defun alloc-stuff () (copy-list '(1 2 3 4 5)))
(with-test (:name (:interrupt-thread :interrupt-consing-child)
:broken-on :win32)
(with-test (:name (:interrupt-thread :interrupt-consing-child))
(let* ((thread (make-thread (lambda () (loop (alloc-stuff)))))
(killer (make-thread
(lambda ()
@ -22,8 +21,7 @@
(sb-ext:gc :full t))
#+(or x86 x86-64) ;; x86oid-only, see internal commentary.
(with-test (:name (:interrupt-thread :interrupt-consing-child :again)
:broken-on :win32)
(with-test (:name (:interrupt-thread :interrupt-consing-child :again))
(symbol-macrolet ((pseudoatomic-bits
(sb-sys:sap-int (sb-vm::current-thread-offset-sap
sb-vm::thread-pseudo-atomic-bits-slot))))

1
tests/join-thread-timeout.impure.lisp
View file

@ -1,7 +1,6 @@
(use-package "SB-THREAD")
(with-test (:name (:join-thread :timeout)
:broken-on :sb-safepoint
:skipped-on (or (not :sb-thread) :gc-stress))
(macrolet ((delta-t () '(/ (- (get-internal-real-time) begin)
internal-time-units-per-second)))

3
tests/kill-non-lisp-thread.impure.lisp
View file

@ -38,8 +38,7 @@
(define-alien-routine kill-non-lisp-thread void)
(with-test (:name :kill-non-lisp-thread
:broken-on :win32)
(with-test (:name :kill-non-lisp-thread)
(let ((sem (sb-thread:make-semaphore)))
(push (lambda ()
(sb-thread:signal-semaphore sem))

3
tests/load.impure.lisp
View file

@ -387,8 +387,7 @@
;; entirely by the fasl interpreter - which exacerbated the problem.
;; A meager attempt at a fix of mutex-guarding ALLOCATE-CODE-OBJECT did not
;; resolve the deadlock, and was not ideal anyway.
(with-test (:name :parallel-fasl-load
:skipped-on :sb-safepoint)
(with-test (:name :parallel-fasl-load)
#+sb-thread
(with-scratch-file (fasl "fasl")
(let ((ready nil))

2
tests/mutex.impure.lisp
View file

@ -20,7 +20,7 @@
(wait-for-threads (list kid1 kid2))))))
(with-test (:name (interrupt-thread :interrupt-mutex-acquisition)
:broken-on :win32)
)
(let ((lock (make-mutex :name "loctite"))
child)
(with-mutex (lock)

3
tests/profile.pure.lisp
View file

@ -83,8 +83,7 @@
;;; and I really don't care why but since this file is allegedly "pure",
;;; its death kills all the remaining tests.
(with-test (:name (profile :threads)
:skipped-on :cheneygc
:broken-on :win32)
:skipped-on :cheneygc)
(profile #.(package-name cl:*package*))
;; This used to signal an error with threads
(let* ((n #+sb-thread 5 #-sb-thread 1)

19
tests/run-program.impure.lisp
View file

@ -47,7 +47,7 @@
(process-close process))))
(with-test (:name (run-program :cat 2)
:skipped-on (or (not :sb-thread) :win32))
:skipped-on (not :sb-thread))
;; Tests that reading from a FIFO is interruptible.
(let* ((process (run-program "cat" '() :search t
:wait nil :output :stream :input :stream))
@ -166,7 +166,7 @@
(defparameter *cat-out-pipe* (make-pipe))
(defparameter *cat-out* (make-synonym-stream '*cat-out-pipe*)))
(with-test (:name (run-program :cat 5) :fails-on :win32)
(with-test (:name (run-program :cat 5) :skipped-on :win32)
(let ((cat (run-program "cat" nil :search t :input *cat-in* :output *cat-out*
:wait nil)))
(dolist (test '("This is a test!"
@ -256,7 +256,7 @@
#-sb-thread (loop repeat 10 collect (start-run))))))
(with-test (:name (run-program :pty-stream)
:fails-on :win32
:skipped-on :win32
:broken-on :darwin)
(let (process
stream)
@ -304,14 +304,17 @@
;; Check that in when you do run-program with :wait t that causes
;; encoding error, it does not affect the following run-program
(with-test (:name (run-program :clean-exit-after-encoding-error)
:fails-on :win32)
(with-test (:name (run-program :clean-exit-after-encoding-error))
(let ((had-error-p nil))
(flet ((barf (&optional (format :default))
(with-output-to-string (stream)
(run-program "perl"
'("-e" "print \"\\x20\\xfe\\xff\\x0a\"")
:search t
(run-program (sb-ext:posix-getenv "SBCL_RUNTIME")
'("--core"
(sb-ext:posix-getenv "SBCL_CORE")
"--disable-ldb" "--noinform" "--no-sysinit" "--no-userinit" "--noprint" "--disable-debugger"
"--eval"
"(mapc (lambda (b) (write-byte b *standard-output*)) '(#x20 #xfe #xff #x0))"
"--quit" )
:output stream
:external-format format)))
(no-barf ()

3
tests/session.impure.lisp
View file

@ -45,8 +45,7 @@
(sb-thread:join-thread thr1)
(sb-thread:join-thread thr2)))
(with-test (:name (:debugger-no-hang-on-session-lock-if-interrupted)
:broken-on :win32)
(with-test (:name (:debugger-no-hang-on-session-lock-if-interrupted))
(sb-debug::enable-debugger)
(let ((main-thread sb-thread:*current-thread*))
(make-join-thread

25
tests/stream.impure.lisp
View file

@ -123,9 +123,8 @@
(assert-error (read-byte (make-string-input-stream "abc"))
type-error))
(with-test (:name (:default :element-type read-byte error)
:skipped-on :win32)
(assert-error (with-open-file (s "/dev/zero")
(with-test (:name (:default :element-type read-byte error))
(assert-error (with-open-file (s #-win32 "/dev/zero" #+win32 "nul")
(read-byte s))
type-error))
@ -654,9 +653,14 @@
;;; READ-CHAR-NO-HANG on bivalent streams (as returned by RUN-PROGRAM)
;;; was wrong. CSR managed to promote the wrongness to all streams in
;;; the 1.0.32.x series, breaking slime instantly.
(with-test (:name (read-char :no-hang-after unread-char) :skipped-on :win32)
(let* ((process (run-program "/bin/sh" '("-c" "echo a && sleep 10")
:output :stream :wait nil))
(with-test (:name (read-char :no-hang-after unread-char))
(let* ((process #-win32 (run-program "/bin/sh" '("-c" "echo a && sleep 10")
:output :stream :wait nil)
#+win32 (run-program
"cmd.exe" '("/c" "(echo a) && (%SystemRoot%\\System32\\timeout 10 > nul )")
:external-format '(:default :newline :crlf)
:search t
:input t :output :stream :wait nil))
(stream (process-output process))
(char (read-char stream)))
(assert (char= char #\a))
@ -855,9 +859,8 @@
(assert (listen cs))))
(delete-file file)))
(with-test (:name :read-sequence-end
:skipped-on :win32)
(assert (= (with-open-file (s "/dev/zero")
(with-test (:name :read-sequence-end)
(assert (= (with-open-file (s (or #+win32 "zero" "/dev/zero"))
(read-sequence (make-string 4096) s :start 9))
4096)))
@ -1052,8 +1055,8 @@
(test-justification ctor)
(test-pretty-printing ctor)))))
(with-test (:name :form-tracking-set-file-position :skipped-on :win32)
(with-open-file (s "/dev/zero" :class 'sb-int:form-tracking-stream)
(with-test (:name :form-tracking-set-file-position)
(with-open-file (s (or #+win32 "zero" "/dev/zero") :class 'sb-int:form-tracking-stream)
(assert (eql (read-char s) (code-char 0)))
(assert (equal (sb-impl::line/col-from-charpos
s (sb-impl::form-tracking-stream-current-char-pos s))

5
tests/stream.pure.lisp
View file

@ -536,13 +536,12 @@
(close syn) ; no error
(assert (eql (read-char *some-stream*) #\o)))))
(with-test (:name :read-sequence-displaced-offset
:skipped-on :win32)
(with-test (:name :read-sequence-displaced-offset)
(let* ((d (make-array 3 :element-type '(unsigned-byte 8)
:initial-element 1))
(x (make-array 1 :element-type '(unsigned-byte 8) :displaced-to d
:displaced-index-offset 1)))
(with-open-file (s "/dev/zero" :element-type '(unsigned-byte 8))
(with-open-file (s (or #+win32 "zero" "/dev/zero") :element-type '(unsigned-byte 8))
(assert (= (read-sequence x s) 1))
(assert (equalp d #(1 0 1)))
(assert (equalp x #(0))))))

1
tests/test-util.lisp
View file

@ -130,7 +130,6 @@
#-sb-thread (error "can't make-kill-thread ~s" args)
#+sb-thread
(let ((thread (apply #'sb-thread:make-thread args)))
#-win32 ;; poor thread interruption on safepoints
(when (boundp '*threads-to-kill*)
(push thread *threads-to-kill*))
thread))

23
tests/threads-2.impure.lisp
View file

@ -103,8 +103,7 @@
;;; Here we test that interrupting TRY-SEMAPHORE does not leave a
;;; semaphore in a bad state.
(with-test (:name (try-semaphore :interrupt-safe)
:broken-on :win32)
(with-test (:name (try-semaphore :interrupt-safe))
(flet ((make-threads (count fn)
(loop repeat count collect (make-thread fn)))
(kill-thread (thread)
@ -158,8 +157,7 @@
;; (d) waiting on a lock, (e) some code which we hope is likely to be
;; in pseudo-atomic
(with-test (:name (interrupt-thread :more-basics)
:broken-on :win32)
(with-test (:name (interrupt-thread :more-basics))
(let ((child (test-interrupt (lambda () (loop)))))
(terminate-thread child)))
@ -185,18 +183,17 @@
(with-test (:name (interrupt-thread :interrupt-foreign-loop)
;; This feature is explicitly unsupported on Win32.
:broken-on :win32)
:skipped-on :win32)
(test-interrupt #'loop-forever :quit))
(with-test (:name (interrupt-thread :interrupt-sleep)
:broken-on :win32)
(with-test (:name (interrupt-thread :interrupt-sleep))
(let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
(terminate-thread child)
(wait-for-threads (list child))))
(defvar *runningp* nil)
(with-test (:name (interrupt-thread :no-nesting) :broken-on :win32)
(with-test (:name (interrupt-thread :no-nesting))
(let ((thread (make-thread (lambda ()
(catch 'xxx
(loop))))))
@ -210,7 +207,7 @@
(throw 'xxx *runningp*)))
(assert (not (join-thread thread)))))
(with-test (:name (interrupt-thread :nesting) :broken-on :win32)
(with-test (:name (interrupt-thread :nesting))
(let ((thread (make-thread (lambda ()
(catch 'xxx
(loop))))))
@ -225,8 +222,7 @@
(throw 'xxx *runningp*)))
(assert (join-thread thread))))
(with-test (:name :all-threads-have-abort-restart
:broken-on :win32)
(with-test (:name :all-threads-have-abort-restart)
;; This test can fail with without the extra semaphore.
;; See also TEST-INTERRUPT in test-util for further explanation.
(let* ((sem (make-semaphore))
@ -305,8 +301,7 @@
(decf sb-vm::*binding-stack-pointer* binding-pointer-delta))))
#+(or x86 x86-64 riscv loongarch64) ;the only platforms with a *binding-stack-pointer* variable
(with-test (:name (:binding-stack-gc-safety)
:broken-on :win32)
(with-test (:name (:binding-stack-gc-safety))
(let (threads)
(unwind-protect
(progn
@ -498,7 +493,7 @@
(assert (eq t (funcall with lock)))))))
(with-test (:name :interrupt-io-unnamed-pipe
:broken-on :win32)
:skipped-on :win32)
(let (result)
(labels
((reader (fd)

14
tests/threads.pure.lisp
View file

@ -42,8 +42,7 @@
;;; Terminating a thread that's waiting for the terminal.
(with-test (:name (:terminate-thread :get-foreground)
:skipped-on (not :sb-thread)
:broken-on :win32)
:skipped-on (not :sb-thread))
(let ((thread (make-thread (lambda ()
(sb-thread:get-foreground)))))
(sleep 1)
@ -59,8 +58,7 @@
;;; to loop over a condition-wait.
(with-test (:name :without-interrupts+condition-wait
:skipped-on (not :sb-thread)
:broken-on :win32)
:skipped-on (not :sb-thread))
(let* ((lock (make-mutex))
(queue (make-waitqueue))
(actually-wakeup nil)
@ -86,8 +84,7 @@
;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
(with-test (:name :without-interrupts+grab-mutex
:skipped-on (not :sb-thread)
:broken-on :win32)
:skipped-on (not :sb-thread))
(let* ((lock (make-mutex))
(bar (progn (grab-mutex lock) nil))
(thread (make-thread (lambda ()
@ -204,7 +201,7 @@
(with-test (:name :symbol-value-in-thread.3
:skipped-on (not :sb-thread)
:broken-on :sb-safepoint)
)
(let* ((parent *current-thread*)
(semaphore (make-semaphore))
(running t)
@ -412,8 +409,7 @@
(assert (find 0 values))))))
(with-test (:name (wait-on-semaphore semaphore-notification :lp-1038034)
:skipped-on (not :sb-thread)
:broken-on :sb-safepoint)
:skipped-on (not :sb-thread))
;; Test robustness of semaphore acquisition and notification with
;; asynchronous thread termination... Which we know is currently
;; fragile.

40
tests/timer.impure.lisp
View file

@ -59,20 +59,20 @@
time)
(loop until finishedp)))
(with-test (:name (:timer :deferrables-blocked) :skipped-on :win32)
(with-test (:name (:timer :deferrables-blocked))
(make-and-schedule-and-wait (lambda ()
(check-deferrables-blocked-or-lose 0))
(random 0.1))
(check-deferrables-unblocked-or-lose 0))
(with-test (:name (:timer :deferrables-unblocked) :skipped-on :win32)
(with-test (:name (:timer :deferrables-unblocked))
(make-and-schedule-and-wait (lambda ()
(sb-sys:with-interrupts
(check-deferrables-unblocked-or-lose 0)))
(random 0.1))
(check-deferrables-unblocked-or-lose 0))
(with-test (:name (:timer :deferrables-unblocked :unwind) :skipped-on :win32)
(with-test (:name (:timer :deferrables-unblocked :unwind))
(catch 'xxx
(make-and-schedule-and-wait (lambda ()
(check-deferrables-blocked-or-lose 0)
@ -87,7 +87,7 @@
(with-test (:name (:timer :relative)
:fails-on (and :sparc :linux)
:skipped-on (or :win32 :gc-stress))
:skipped-on :gc-stress)
(let* ((has-run-p nil)
(timer (make-timer (lambda () (setq has-run-p t))
:name "simple timer")))
@ -100,7 +100,7 @@
(with-test (:name (:timer :absolute)
:fails-on (and :sparc :linux)
:skipped-on (or :win32 :gc-stress))
:skipped-on :gc-stress)
(let* ((has-run-p nil)
(timer (make-timer (lambda () (setq has-run-p t))
:name "simple timer")))
@ -131,8 +131,7 @@
(schedule-timer timer 0.1)))
(with-test (:name (:timer :repeat-and-unschedule)
:fails-on (and :sparc :linux)
:skipped-on :win32)
:fails-on (and :sparc :linux))
(let* ((run-count 0)
timer)
(setq timer
@ -146,7 +145,7 @@
(assert (not (timer-scheduled-p timer)))
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
(with-test (:name (:timer :reschedule) :skipped-on :win32)
(with-test (:name (:timer :reschedule))
(let* ((has-run-p nil)
(timer (make-timer (lambda ()
(setq has-run-p t)))))
@ -156,14 +155,14 @@
(assert has-run-p)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
(with-test (:name (:timer :stress) :skipped-on :win32)
(with-test (:name (:timer :stress))
(let ((time (1+ (get-universal-time))))
(loop repeat 200 do
(schedule-timer (make-timer (lambda ())) time :absolute-p t))
(sleep 2)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
(with-test (:name (:timer :stress2) :skipped-on :win32)
(with-test (:name (:timer :stress2))
(let ((time (1+ (get-universal-time)))
(n 0))
(loop for time-n from time upto (+ 1/10 time) by (/ 1/10 200)
@ -172,32 +171,31 @@
(sleep 2)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
(with-test (:name (:with-timeout :timeout) :skipped-on :win32)
(with-test (:name (:with-timeout :timeout))
(assert (raises-timeout-p
(sb-ext:with-timeout 0.2
(sleep 1)))))
(with-test (:name (:with-timeout :fall-through)
:skipped-on (or :win32 :gc-stress))
:skipped-on :gc-stress)
(assert (not (raises-timeout-p
(sb-ext:with-timeout 0.3
(sleep 0.1))))))
(with-test (:name (:with-timeout :nested-timeout-smaller) :skipped-on :win32)
(with-test (:name (:with-timeout :nested-timeout-smaller))
(assert(raises-timeout-p
(sb-ext:with-timeout 10
(sb-ext:with-timeout 0.5
(sleep 2))))))
(with-test (:name (:with-timeout :nested-timeout-bigger) :skipped-on :win32)
(with-test (:name (:with-timeout :nested-timeout-bigger))
(assert(raises-timeout-p
(sb-ext:with-timeout 0.5
(sb-ext:with-timeout 2
(sleep 2))))))
(with-test (:name (:with-timeout :many-at-the-same-time)
:skipped-on (not :sb-thread)
:broken-on :win32)
:skipped-on (not :sb-thread))
(let ((ok t))
(let ((threads (loop repeat 10 collect
(sb-thread:make-thread
@ -218,7 +216,7 @@
;;; before they ran) and dying threads were open interrupts.
(with-test (:name (:timer :parallel-unschedule)
:skipped-on (not :sb-thread)
:broken-on (or :ppc :win32))
:broken-on :ppc)
(let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
(other nil))
(flet ((flop ()
@ -246,8 +244,7 @@
;;;;
;;;; Used to have problems in genereal, see comment on (:TIMER
;;;; :PARALLEL-UNSCHEDULE).
(with-test (:name (:timer :schedule-stress)
:broken-on :win32)
(with-test (:name (:timer :schedule-stress))
(flet ((test ()
(let* ((slow-timers
(loop for i from 1 upto 1
@ -272,10 +269,7 @@
(with-test (:name (:timer :threaded-stress)
:skipped-on (not :sb-thread)
:broken-on :x86
:fails-on :win32)
#+win32
(error "fixme")
:broken-on :x86)
(let ((barrier (sb-thread:make-semaphore))
(goal 100))
(flet ((wait-for-goal ()

46
tests/unwind-to-frame-and-call.impure.lisp
View file

@ -75,18 +75,7 @@
(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)
@ -99,13 +88,13 @@
;; Check that the binding stack was correctly unwound.
(assert (eql *foo* 'x))))
(with-test (:name (:restart-frame :special) :fails-on :win32)
(with-test (:name (:restart-frame :special))
(test-restart 'restart/special))
(with-test (:name (:restart-frame :optional-special) :fails-on :win32)
(with-test (:name (:restart-frame :optional-special))
(test-restart 'restart/optional-special))
(with-test (:name (:restart-frame :normal) :fails-on :win32)
(with-test (:name (:restart-frame :normal))
(test-restart 'restart/normal))
@ -140,7 +129,6 @@
foo)
(defun test-return (name)
#+win32 (decline)
(setf *a* nil)
(let ((*foo* 'x))
(let ((*foo* 'y))
@ -152,19 +140,19 @@
;; Check that the binding stack was correctly unwound.
(assert (eql *foo* 'x))))
(with-test (:name (:return-from-frame :special) :fails-on :win32)
(with-test (:name (:return-from-frame :special))
(test-return 'return/special))
(with-test (:name (:return-from-frame :optional-special) :fails-on :win32)
(with-test (:name (:return-from-frame :optional-special))
(test-return 'return/optional-special))
(with-test (:name (:return-from-frame :normal) :fails-on :win32)
(with-test (:name (:return-from-frame :normal))
(test-return 'return/normal))
(defun throw-y () (throw 'y 'y))
;; Check that *CURRENT-CATCH-BLOCK* was correctly restored.
(with-test (:name :current-catch-block-restored :fails-on :win32)
(with-test (:name :current-catch-block-restored)
(assert (eql (catch 'y
(test-return 'return/catch)
(throw-y))
@ -205,7 +193,6 @@
(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)))
@ -225,10 +212,10 @@
(assert (equal *b* '(z))))
(assert (eql *foo* 'x))))
(with-test (:name (:return-from-frame :local-function) :fails-on :win32)
(with-test (:name (:return-from-frame :local-function))
(test-locals 'locals))
(with-test (:name (:return-from-frame :hairy-local-function) :fails-on :win32)
(with-test (:name (:return-from-frame :hairy-local-function))
(test-locals 'hairy-locals))
@ -264,7 +251,6 @@
(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
@ -279,17 +265,16 @@
(defvar *p* (namestring (if sb-c::*merge-pathnames* *load-truename* *load-pathname*)))
(with-test (:name (:return-from-frame :anonymous :toplevel) :fails-on :win32)
(with-test (:name (:return-from-frame :anonymous :toplevel))
(test-anon *anon-1* 'foo *p*))
(with-test (:name (:return-from-frame :anonymous :toplevel-special)
:fails-on :win32)
(with-test (:name (:return-from-frame :anonymous :toplevel-special))
(test-anon *anon-2* '*foo* *p*))
(with-test (:name (:return-from-frame :anonymous) :fails-on :win32)
(with-test (:name (:return-from-frame :anonymous))
(test-anon *anon-3* 'foo 'make-anon-3))
(with-test (:name (:return-from-frame :anonymous :special) :fails-on :win32)
(with-test (:name (:return-from-frame :anonymous :special))
(test-anon *anon-4* '*foo* 'make-anon-4))
@ -310,7 +295,6 @@
(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
@ -327,9 +311,9 @@
(assert (eql *foo* 'y)))
(assert (eql *foo* 'x))))))
(with-test (:name :test-unwind-1 :fails-on :win32)
(with-test (:name :test-unwind-1)
(test-unwind 'unwind-1 '(:unwind-1)))
(with-test (:name :test-unwind-2 :fails-on :win32)
(with-test (:name :test-unwind-2)
(test-unwind 'unwind-2 '(:unwind-2 :unwind-1)))
;;; Regression in 1.0.10.47 reported by James Knight

BIN
tests/zero Normal file
View file

Binary file not shown.