;;; void conflicted with derived type
(declaim (inline bug-316075))
+#-win32 ;kludge: This reader conditional masks a bug, but allows the test
+ ;to fail cleanly.
(sb-alien:define-alien-routine bug-316075 void (result char :out))
-(with-test (:name bug-316075)
+(with-test (:name bug-316075 :fails-on :win32)
+ #+win32 (error "fail")
(handler-bind ((warning #'error))
(compile nil '(lambda () (multiple-value-list (bug-316075))))))
(verify (signed 16) #x003f8042 #x-7fbe)
(verify (signed 16) #x003f7042 #x7042)))
-(with-test (:name :bug-654485)
+(with-test (:name :bug-654485 :fails-on :win32)
;; DEBUG 2 used to prevent let-conversion of the open-coded ALIEN-FUNCALL body,
;; which in turn led the dreaded %SAP-ALIEN note.
(handler-case
(compiler-note (n)
(error "bad note: ~A" n))))
-(with-test (:name :bug-721087)
+(with-test (:name :bug-721087 :fails-on :win32)
(assert (typep nil '(alien c-string)))
(assert (not (typep nil '(alien (c-string :not-null t)))))
(assert (eq :ok
(defmethod compute-test ((x symbol) (y symbol))
'symbol)
-(compute-test 1 2)
+(test-util:with-test (:name :compute-test :fails-on :win32)
+ (compute-test 1 2)
-;;; Check that we actually interrupted something.
-(assert (equal (list #'compute-test) *interrupted-gfs*))
+ ;; Check that we actually interrupted something.
+ (assert (equal (list #'compute-test) *interrupted-gfs*)))
(defun bug-308914-storage (x)
(the (simple-array flt (*)) (bug-308914-unknown x)))
-(with-test (:name :bug-308914-workaround)
+(with-test (:name :bug-308914-workaround :fails-on :win32)
;; This used to hang in ORDER-UVL-SETS.
(handler-case
(with-timeout 10
(declare (ignore x y k1))
t))))))
-(with-test (:name :bug-309448)
+(with-test (:name :bug-309448 :fails-on :win32)
;; Like all tests trying to verify that something doesn't blow up
;; compile-times this is bound to be a bit brittle, but at least
;; here we try to establish a decent baseline.
(define-condition my-stream-error-1-0-9 (stream-error) ())
(define-condition parse-foo-error-1-0-9 (parse-error) ())
(define-condition read-bar-error-1-0-9 (reader-error) ())
-(let (;; instances created initializing all the slots specified in
- ;; ANSI CL
- (parse-foo-error-1-0-9 (make-condition 'parse-foo-error-1-0-9
- :stream *standard-input*))
- (read-foo-error-1-0-9 (make-condition 'read-bar-error-1-0-9
- :stream *standard-input*))
- (my-stream-error-1-0-9 (make-condition 'my-stream-error-1-0-9
- :stream *standard-input*)))
- ;; should be printable
- (dolist (c (list
- my-stream-error-1-0-9
- parse-foo-error-1-0-9
- read-foo-error-1-0-9))
- ;; whether escaped or not
- (dolist (*print-escape* '(nil t))
- (write c :stream (make-string-output-stream)))))
+(with-test (:name :printable-conditions :fails-on :win32)
+ (let (;; instances created initializing all the slots specified in
+ ;; ANSI CL
+ (parse-foo-error-1-0-9 (make-condition 'parse-foo-error-1-0-9
+ :stream *standard-input*))
+ (read-foo-error-1-0-9 (make-condition 'read-bar-error-1-0-9
+ :stream *standard-input*))
+ (my-stream-error-1-0-9 (make-condition 'my-stream-error-1-0-9
+ :stream *standard-input*)))
+ ;; should be printable
+ (dolist (c (list
+ my-stream-error-1-0-9
+ parse-foo-error-1-0-9
+ read-foo-error-1-0-9))
+ ;; whether escaped or not
+ (dolist (*print-escape* '(nil t))
+ (write c :stream (make-string-output-stream))))))
;;; Reported by Michael Weber: restart computation in :TEST-FUNCTION used to
;;; cause infinite recursion.
(sb-ext:run-program "sleep" (list (format nil "~D" seconds))
:search t :wait t))
-(with-test (:name (:deadline :run-program :trivial))
+(with-test (:name (:deadline :run-program :trivial) :fails-on :win32)
(assert-timeout (sb-sys:with-deadline (:seconds 1)
(run-sleep 3))))
-(with-test (:name (:deadline :defer-deadline-1))
+(with-test (:name (:deadline :defer-deadline-1) :fails-on :win32)
(let ((n 0)
(final nil))
(handler-case
(assert (= n 2))
(assert final)))
-(with-test (:name (:deadline :defer-deadline-2))
+(with-test (:name (:deadline :defer-deadline-2) :fails-on :win32)
(let ((n 0)
(final nil))
(handler-case
(assert (plusp n))
(assert (not final))))
-(with-test (:name (:deadline :cancel-deadline))
+(with-test (:name (:deadline :cancel-deadline) :fails-on :win32)
(let ((n 0)
(final nil))
(handler-case
(setq ok t)))
(assert ok))))
-(with-test (:name (:exhaust :alien-stack) :skipped-on '(not :c-stack-is-control-stack))
+(with-test (:name (:exhaust :alien-stack)
+ :skipped-on '(not :c-stack-is-control-stack)
+ :fails-on :win32)
(let ((ok nil))
(labels ((exhaust-alien-stack (i)
(with-alien ((integer-array (array int 500)))
(write-byte #xe0 s)
(dotimes (i 40)
(write-sequence a s))))
-(with-test (:name (:character-decode-large :attempt-resync))
+(with-test (:name (:character-decode-large :attempt-resync)
+ :fails-on :win32)
(with-open-file (s *test-path* :direction :input
:external-format :utf-8)
(let ((count 0))
(with-open-file (s *test-path* :external-format :utf-32be)
(assert (string= " ???? " (read-line s))))))
-(with-test (:name :invalid-external-format)
+(with-test (:name :invalid-external-format :fails-on :win32)
(labels ((test-error (e)
(assert (typep e 'error))
(unless (equal "Undefined external-format: :BAD-FORMAT"
;;; given only safe characters in the namestring, NATIVE-PATHNAME will
;;; never error, and NATIVE-NAMESTRING on the result will return the
;;; original namestring.
-(with-test (:name :random-native-namestrings)
+(with-test (:name :random-native-namestrings :fails-on :win32)
(let ((safe-chars
(coerce
(cons #\Newline
;;;; fork/exec, so that no lisp is on the stack. This is our known-good
;;;; number.
-(run "/bin/sh" "run-compiler.sh" "-sbcl-pic"
- "stack-alignment-offset.c" "-o" "stack-alignment-offset")
+#-win32
+(progn
+ (run "/bin/sh" "run-compiler.sh" "-sbcl-pic"
+ "stack-alignment-offset.c" "-o" "stack-alignment-offset")
-(defparameter *good-offset*
- (parse-integer (run "./stack-alignment-offset"
- (princ-to-string *required-alignment*))))
+ (defparameter *good-offset*
+ (parse-integer (run "./stack-alignment-offset"
+ (princ-to-string *required-alignment*))))
-;;;; Build the tool again, this time as a shared object, and load it
+ ;; Build the tool again, this time as a shared object, and load it
-(run "/bin/sh" "run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
- "stack-alignment-offset.c" "-o" "stack-alignment-offset.so")
+ (run "/bin/sh" "run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
+ "stack-alignment-offset.c" "-o" "stack-alignment-offset.so")
-(load-shared-object (truename "stack-alignment-offset.so"))
+ (load-shared-object (truename "stack-alignment-offset.so"))
-(define-alien-routine stack-alignment-offset int (alignment int))
-(define-alien-routine trampoline int (callback (function int)))
+ (define-alien-routine stack-alignment-offset int (alignment int))
+ (define-alien-routine trampoline int (callback (function int))))
;;;; Now get the offset by calling from lisp, first with a regular foreign function
;;;; call, then with an intervening callback.
-(with-test (:name :regular)
+(with-test (:name :regular :fails-on :win32)
(assert (= *good-offset* (stack-alignment-offset *required-alignment*))))
-(with-test (:name :callback)
+(with-test (:name :callback :fails-on :win32)
(assert (= *good-offset* (trampoline (alien-lambda int ()
(stack-alignment-offset *required-alignment*))))))
-(delete-file "stack-alignment-offset")
-(delete-file "stack-alignment-offset.so")
+(when (probe-file "stack-alignment-offset.so")
+ (delete-file "stack-alignment-offset")
+ (delete-file "stack-alignment-offset.so"))
;;;; success!
(assert (not (special-operator-p 'declare)))
;;; WITH-TIMEOUT should accept more than one form in its body.
-(with-test (:name :with-timeout-forms)
+(with-test (:name :with-timeout-forms :fails-on :win32)
(handler-bind ((sb-ext:timeout #'continue))
(sb-ext:with-timeout 3
(sleep 2)
*loaded-pathname* *loaded-truename*)
(load ,load-argument :print t :verbose t)
(assert (and (= (1+ ,before) *counter*)
+ #-win32 ;kludge
(equal ,(if pathname `(merge-pathnames ,pathname))
*loaded-pathname*)
+ #-win32 ;kludge
(equal ,(if pathname `(merge-pathnames ,truename))
*loaded-truename*))))))
(invoke-restart 'sb-fasl::object)))))
(load-and-assert spec fasl fasl))))
-(with-test (:name :bug-332)
+(with-test (:name :bug-332 :fails-on :win32)
(flet ((stimulate-sbcl ()
(let ((filename (format nil "/tmp/~A.lisp" (gensym))))
;; create a file which redefines a structure incompatibly
;;; some things SBCL-0.6.9 used not to parse correctly:
;;;
;;; SBCL used to throw an error saying there's no translation.
-(with-test (:name (:logical-pathname 1))
+(with-test (:name (:logical-pathname 1) :fails-on :win32)
(assert (equal (namestring (translate-logical-pathname "demo0:file.lisp"))
"/tmp/file.lisp")))
"/tmp/**/foo.lisp"))))
;;; That should be correct:
-(with-test (:name (:logical-pathname 4))
+(with-test (:name (:logical-pathname 4) :fails-on :win32)
(assert (equal (namestring (translate-logical-pathname "demo1:foo.lisp"))
"/tmp/foo.lisp")))
;;; Check for absolute/relative path confusion:
-(with-test (:name (:logical-pathname 5))
+(with-test (:name (:logical-pathname 5) :fails-on :win32)
(assert (not (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
"tmp/rel/foo.lisp")))
(assert (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
;;; there's some code in this section which should be attributed
;;; to something in the ANSI spec, but I don't know what code it is
;;; or what section of the specification has the related code.
-(with-test (:name (:logical-pathname 14))
+(with-test (:name (:logical-pathname 14) :fails-on :win32)
(setf (logical-pathname-translations "test0")
'(("**;*.*.*" "/library/foo/**/")))
(assert (equal (namestring (translate-logical-pathname
;;; ANSI section 19.3.1.1.5 specifies that translation to a filesystem
;;; which doesn't have versions should ignore the version slot. CMU CL
;;; didn't ignore this as it should, but we do.
-(with-test (:name (:logical-pathname 15))
+(with-test (:name (:logical-pathname 15) :fails-on :win32)
(assert (equal (namestring (translate-logical-pathname
"test0:foo;bar;baz;mum.quux.3"))
"/library/foo/foo/bar/baz/mum.quux")))
\f
;;; ensure read/print consistency (or print-not-readable-error) on
;;; pathnames:
-(with-test (:name :print/read-consistency)
+(with-test (:name :print/read-consistency :fails-on :win32)
(let ((pathnames (list
(make-pathname :name "foo" :type "txt" :version :newest)
(make-pathname :name "foo" :type "txt" :version 1)
\f
;;; we got (truename "/") wrong for about 6 months. Check that it's
;;; still right.
-(with-test (:name :root-truename)
+(with-test (:name :root-truename :fails-on :win32)
(let ((pathname (truename "/")))
(assert (equalp pathname #p"/"))
(assert (equal (pathname-directory pathname) '(:absolute)))))
(assert (string= (write-to-string pathname :readably t) "#P\"SYS:**;*\""))))
\f
;;; reported by James Y Knight on sbcl-devel 2006-05-17
-(with-test (:name :merge-back)
+(with-test (:name :merge-back :fails-on :win32)
(let ((p1 (make-pathname :directory '(:relative "bar")))
(p2 (make-pathname :directory '(:relative :back "foo"))))
(assert (equal (merge-pathnames p1 p2)
(assert (equal (make-pathname :directory '(:absolute))
(read-from-string "#p\"\\\\\\\\\""))))
-(with-test (:name :load-logical-pathname-translations)
+(with-test (:name :load-logical-pathname-translations :fails-on :win32)
(let* ((cwd (truename "."))
(foo (merge-pathnames "llpnt-foo.translations" cwd))
(bar (merge-pathnames "llpnt-bar.translations" cwd))
(ignore-errors (delete-file bar))
(setf (logical-pathname-translations "SYS") translations))))
-(with-test (:name :tilde-expansion)
+(with-test (:name :tilde-expansion :fails-on :win32)
(assert (equal '(:absolute :home "foo") (pathname-directory "~/foo/bar.txt")))
(assert (equal '(:absolute (:home "jdoe") "quux") (pathname-directory "~jdoe/quux/")))
(assert (equal "~/foo/x" (namestring (make-pathname :directory '(:absolute :home "foo")
;; * / :WILD
(assert (equal (pathname-directory #p"\\*/") '(:relative "*"))))
-(with-test (:name :ensure-directories-exist-with-odd-d-p-d)
+(with-test (:name :ensure-directories-exist-with-odd-d-p-d
+ :fails-on :win32)
(let ((*default-pathname-defaults* #p"/tmp/foo"))
(ensure-directories-exist "/")))
;;; bug 350: bignum printing so memory-hungry that heap runs out
;;; -- just don't stall here forever on a slow box
-(handler-case
- (with-timeout 10
- (print (ash 1 1000000)))
- (timeout ()
- (print 'timeout!)))
+(with-test (:name bug-350 :fails-on :win32)
+ (handler-case
+ (with-timeout 10
+ (print (ash 1 1000000)))
+ (timeout ()
+ (print 'timeout!))))
;;; bug 371: bignum print/read inconsistency
(defvar *bug-371* -7043009959286724629649270926654940933664689003233793014518979272497911394287216967075767325693021717277238746020477538876750544587281879084559996466844417586093291189295867052594478662802691926547232838591510540917276694295393715934079679531035912244103731582711556740654671309980075069010778644542022/670550434139267031632063192770201289106737062379324644110801846820471752716238484923370056920388400273070254958650831435834503195629325418985020030706879602898158806736813101434594805676212779217311897830937606064579213895527844045511878668289820732425014254579493444623868748969110751636786165152601)
;; (sometimes the handler will manage to WAIT3 a process before
;; run-tests WAITPIDs it).
-(with-test (:name :run-program-cat-1)
+(with-test (:name :run-program-cat-1 :skipped-on :win32)
(let* ((process (sb-ext:run-program "/bin/cat" '() :wait nil
:output :stream :input :stream))
(out (process-input process))
(assert (= (read-byte in) i)))
(process-close process))))
-(with-test (:name :run-program-cat-2 :skipped-on '(not :sb-thread))
+(with-test (:name :run-program-cat-2 :skipped-on '(or (not :sb-thread) :win32))
;; Tests that reading from a FIFO is interruptible.
(let* ((process (sb-ext:run-program "/bin/cat" '()
:wait nil
:start2 start :end2 end)
seq))
-(with-test (:name :run-program-cat-3)
+(with-test (:name :run-program-cat-3 :skipped-on :win32)
;; User-defined binary input and output streams.
(let ((in (make-instance 'buffer-stream))
(out (make-instance 'buffer-stream))
(assert (= 0 (read-sequence (make-array 8) out)))
(assert (equalp buf data)))))
-(with-test (:name :run-program-cat-4)
+(with-test (:name :run-program-cat-4 :skipped-on :win32)
;; Null broadcast stream as output
(let* ((process (sb-ext:run-program "/bin/cat" '() :wait nil
:output (make-broadcast-stream)
(require :sb-posix)
-(defun make-pipe ()
- (multiple-value-bind (in out) (sb-posix:pipe)
- (let ((input (sb-sys:make-fd-stream in
- :input t
- :external-format :ascii
- :buffering :none :name "in"))
- (output (sb-sys:make-fd-stream out
- :output t
- :external-format :ascii
- :buffering :none :name "out")))
- (make-two-way-stream input output))))
-
-(defparameter *cat-in-pipe* (make-pipe))
-(defparameter *cat-in* (make-synonym-stream '*cat-in-pipe*))
-(defparameter *cat-out-pipe* (make-pipe))
-(defparameter *cat-out* (make-synonym-stream '*cat-out-pipe*))
-
-(with-test (:name :run-program-cat-5)
+#-win32
+(progn
+ (defun make-pipe ()
+ (multiple-value-bind (in out) (sb-posix:pipe)
+ (let ((input (sb-sys:make-fd-stream in
+ :input t
+ :external-format :ascii
+ :buffering :none :name "in"))
+ (output (sb-sys:make-fd-stream out
+ :output t
+ :external-format :ascii
+ :buffering :none :name "out")))
+ (make-two-way-stream input output))))
+
+ (defparameter *cat-in-pipe* (make-pipe))
+ (defparameter *cat-in* (make-synonym-stream '*cat-in-pipe*))
+ (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)
(let ((cat (run-program "/bin/cat" nil :input *cat-in* :output *cat-out*
:wait nil)))
(dolist (test '("This is a test!"
;;; buffering of stdin and stdout depends on their TTYness, and ed isn't sufficiently
;;; agressive about flushing them. So, here's another test using :PTY.
+#-win32 ( ;; kludge: It would be nicer to disable individual test cases,
+ ;; but we are not using WITH-TEST yet here.
+
(defparameter *tmpfile* "run-program-ed-test.tmp")
(with-open-file (f *tmpfile*
(assert (equal "baz" (read-line f)))))
(delete-file *tmpfile*))
+) ;; #-win32
+
;; Around 1.0.12 there was a regression when :INPUT or :OUTPUT was a
;; pathname designator. Since these use the same code, it should
;; suffice to test just :INPUT.
;;; This used to crash on Darwin and trigger recursive lock errors on
;;; every platform.
-(with-test (:name (:run-program :stress))
+(with-test (:name (:run-program :stress) :fails-on :win32)
;; Do it a hundred times in batches of 10 so that with a low limit
;; of the number of processes the test can have a chance to pass.
(loop
("It would be nice if this didn't crash.")
:wait nil :output nil)))))
-(with-test (:name (:run-program :pty-stream))
+(with-test (:name (:run-program :pty-stream) :fails-on :win32)
(assert (equal "OK"
(subseq
(with-output-to-string (s)
;; We can't check for the signal itself since run-program.c resets the
;; forked process' signal mask to defaults. But the default is `stop'
;; of which we can be notified asynchronously by providing a status hook.
-(with-test (:name (:run-program :inherit-stdin))
+(with-test (:name (:run-program :inherit-stdin) :fails-on :win32)
(let (stopped)
(flet ((status-hook (proc)
(case (sb-ext:process-status proc)
;; 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))
+(with-test (:name (:run-program :clean-exit-after-encoding-error)
+ :fails-on :win32)
(let ((had-error-p nil))
(flet ((barf (&optional (format :default))
(with-output-to-string (stream)
(error (e)
(princ-to-string e))))))
+#-win32
(with-test (:name (:run-program :if-input-does-not-exist))
(let ((file (pathname (sb-posix:mktemp "rpXXXXXX"))))
(assert (null (sb-ext:run-program "/bin/cat" '() :input file)))
(use-package :test-util)
-(with-test (:name (:async-unwind :specials))
+(with-test (:name (:async-unwind :specials) :fails-on :win32)
(let ((*x0* nil) (*x1* nil) (*x2* nil) (*x3* nil) (*x4* nil))
(declare (special *x0* *x1* *x2* *x3* *x4*))
(loop repeat 10 do
(require :sb-posix)
-(with-test (:name (:signal :errno))
+(with-test (:name (:signal :errno) :fails-on :win32)
(let* (saved-errno
(returning nil)
(timer (make-timer (lambda ()
(loop repeat 1000000000)
(assert (= saved-errno (sb-unix::get-errno)))))
-(with-test (:name :handle-interactive-interrupt)
+(with-test (:name :handle-interactive-interrupt :fails-on :win32)
(assert (eq :condition
(handler-case
(sb-thread::kill-safely
type-error))
(assert (raises-error? (with-open-file (s "/dev/zero")
(read-byte s))
- type-error))
+ #-win32 type-error
+ #+win32 sb-int:simple-file-error))
;;; bidirectional streams getting confused about their position
(let ((p "bidirectional-stream-test"))
(with-open-file (s p :direction :output :if-exists :supersede)
;;; CLOSING a non-new streams should not delete them, and superseded
;;; files should be restored.
-(let ((test "test-file-for-close-should-not-delete"))
- (macrolet ((test-mode (mode)
- `(progn
- (catch :close-test-exit
- (with-open-file (f test :direction :output :if-exists ,mode)
- (write-line "test" f)
- (throw :close-test-exit t)))
- (assert (and (probe-file test) ,mode)))))
- (unwind-protect
- (progn
- (with-open-file (f test :direction :output)
- (write-line "test" f))
- (test-mode :append)
- (test-mode :overwrite)
- ;; FIXME: We really should recover supersede files as well, according to
- ;; CLOSE in CLHS, but at the moment we don't.
- ;; (test-mode :supersede)
- (test-mode :rename)
- (test-mode :rename-and-delete))
- (when (probe-file test)
- (delete-file test)))))
+(with-test (:name test-file-for-close-should-not-delete :fails-on :win32)
+ (let ((test "test-file-for-close-should-not-delete"))
+ (macrolet ((test-mode (mode)
+ `(progn
+ (catch :close-test-exit
+ (with-open-file (f test :direction :output :if-exists ,mode)
+ (write-line "test" f)
+ (throw :close-test-exit t)))
+ (assert (and (probe-file test) ,mode)))))
+ (unwind-protect
+ (progn
+ (with-open-file (f test :direction :output)
+ (write-line "test" f))
+ (test-mode :append)
+ (test-mode :overwrite)
+ ;; FIXME: We really should recover supersede files as well, according to
+ ;; CLOSE in CLHS, but at the moment we don't.
+ ;; (test-mode :supersede)
+ (test-mode :rename)
+ (test-mode :rename-and-delete))
+ (when (probe-file test)
+ (delete-file test))))))
;;; test for read-write invariance of signed bytes, from Bruno Haible
;;; cmucl-imp 2004-09-06
;;; 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)
+(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))
(stream (process-output process))
(read-char-no-hang stream)
(assert (< (- (get-universal-time) time) 2)))))
-#-win32
(require :sb-posix)
-
+#-win32
(with-test (:name :interrupt-open :skipped-on :win32)
(let ((fifo nil)
(to 0))
(ignore-errors (delete-file fifo))))))
#-win32
-(require :sb-posix)
(with-test (:name :overeager-character-buffering :skipped-on :win32)
(let ((fifo nil)
(proc nil))
;;; immediately be completely filled for normal files, and that the
;;; buffer-fill routine is responsible for figuring out when we've
;;; reached EOF.
-(with-test (:name (stream listen-vs-select))
+(with-test (:name (stream listen-vs-select) :fails-on :win32)
(let ((listen-testfile-name "stream.impure.lisp.testqfile")
;; If non-NIL, size (in bytes) of the file that will exercise
;; the LISTEN problem.
output))
output))
-(run "/bin/sh" "run-compiler.sh"
- "-sbcl-pic" "-sbcl-shared"
- "-O3" "-I" "../src/runtime/"
- "swap-lispobjs.c" "-o" "swap-lispobjs.so")
+(with-test (:name :swap-lispobjs/prepare :broken-on :win32)
+ (run "/bin/sh" "run-compiler.sh"
+ "-sbcl-pic" "-sbcl-shared"
+ "-O3" "-I" "../src/runtime/"
+ "swap-lispobjs.c" "-o" "swap-lispobjs.so")
-(load-shared-object (truename "swap-lispobjs.so"))
+ (load-shared-object (truename "swap-lispobjs.so"))
-(define-alien-routine try-to-zero-with-swap-lispobjs int
- (lispobj-adress unsigned-long))
+ (define-alien-routine try-to-zero-with-swap-lispobjs int
+ (lispobj-adress unsigned-long)))
-(with-test (:name :swap-lispobjs)
+(with-test (:name :swap-lispobjs :fails-on :win32)
(let ((x (cons 13 27)))
(try-to-zero-with-swap-lispobjs
(logandc2 (sb-kernel:get-lisp-obj-address x)
sb-vm:lowtag-mask))
(assert (equal x (cons 0 27)))))
-(delete-file "swap-lispobjs.so")
+(when (probe-file "swap-lispobjs.so")
+ (delete-file "swap-lispobjs.so"))
(assert (and (null value)
error))))
-(with-test (:name (:wait-for :basics))
+(with-test (:name (:wait-for :basics) :fails-on :win32)
(assert (not (sb-ext:wait-for nil :timeout 0.1)))
(assert (eql 42 (sb-ext:wait-for 42)))
(let ((n 0))
(assert (eql 100 (sb-ext:wait-for (when (= 100 (incf n))
n))))))
-(with-test (:name (:wait-for :deadline))
+(with-test (:name (:wait-for :deadline) :fails-on :win32)
(assert (eq :ok
(sb-sys:with-deadline (:seconds 10)
(assert (not (sb-ext:wait-for nil :timeout 0.1)))
(error "oops"))
(sb-sys:deadline-timeout () :deadline)))))
-(with-test (:name (:condition-wait :timeout :one-thread))
+(with-test (:name (:condition-wait :timeout :one-thread) :fails-on :win32)
(let ((mutex (make-mutex))
(waitqueue (make-waitqueue)))
(assert (not (with-mutex (mutex)
(unless (eql 50 ok)
(error "Wanted 50, got ~S" ok)))))
-(with-test (:name (:wait-on-semaphore :timeout :one-thread))
+(with-test (:name (:wait-on-semaphore :timeout :one-thread) :fails-on :win32)
(let ((sem (make-semaphore))
(n 0))
(signal-semaphore sem 10)
;; 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))
\f
;; 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)))
\f
;;;; Test RETURN-FROM-FRAME with local functions
(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))
\f
(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))
\f
(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
projects / sbcl.git / commitdiff