From 0c3d4aa7f3d5daf59289a8bc8ab48fc3be693504 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Thu, 7 May 2015 20:54:36 -0400
Subject: [PATCH] Add with-expected-failures in tests for bugs in underlying
 implementation.

---
 test/asdf-pathname-test.script        |  2 +-
 test/script-support.lisp              | 12 ++++++++-
 test/test-compile-file-failure.script | 12 ++++-----
 test/test-concatenate-source.script   | 10 ++++----
 test/test-deferred-warnings.script    | 33 +++++++++++-------------
 test/test-encodings.script            | 15 ++++++++---
 test/test-operation-classes.script    |  6 ++---
 test/test-run-program.script          |  7 +++---
 test/test-sysdef-asdf.script          |  2 +-
 test/test-try-recompiling-1.script    |  6 +----
 test/test-urls-1.script               |  1 -
 test/test-urls-2.script               |  1 -
 test/test-utilities.script            | 36 ++++++++++++++-------------
 13 files changed, 76 insertions(+), 67 deletions(-)

diff --git a/test/asdf-pathname-test.script b/test/asdf-pathname-test.script
index e7460bcd..e967420d 100644
--- a/test/asdf-pathname-test.script
+++ b/test/asdf-pathname-test.script
@@ -459,7 +459,7 @@
 (assert (directory-pathname-p (system-source-directory (find-system :test-asdf/test-source-directory-1))))
 (assert (directory-pathname-p (system-source-directory (find-system :test-asdf/test-source-directory-2))))
 
-#-gcl
+#-gcl ;; expected-failure: GCL crashes badly
 (assert (test-component-pathnames :delete-host t :support-string-pathnames nil))
 
 (test-pathname-parsing)
diff --git a/test/script-support.lisp b/test/script-support.lisp
index 705d780d..39731bbe 100644
--- a/test/script-support.lisp
+++ b/test/script-support.lisp
@@ -15,7 +15,7 @@ Some constraints:
   (:export
    #:asym #:acall #:asymval
    #:*test-directory* #:*asdf-directory* #:*build-directory* #:*implementation*
-   #:deftest #:is #:signals
+   #:deftest #:is #:signals #:errors #:with-expected-failure
    #:assert-compare #:assert-equal #:assert-pathname-equal #:assert-pathnames-equal
    #:hash-table->alist
    #:load-asdf #:maybe-compile-asdf
@@ -132,6 +132,16 @@ Some constraints:
      (format *error-output* "~&Checking whether ~S signals error ~S~%" ',sexp ',condition)
      (finish-output *error-output*)
      (assert-equal ',condition (type-of (nth-value 1 (ignore-errors ,sexp))))))
+(defmacro with-expected-failure ((&optional condition) &body body)
+  `(call-with-expected-failure ,condition (lambda () ,@body)))
+(defun call-with-expected-failure (condition thunk)
+  (if condition
+      (handler-case (funcall thunk)
+        (:no-error (&rest x) (declare (ignore x)) (error "Unexpected success: ~A" condition))
+        (t (x) (declare (ignore x)) t))
+      (funcall thunk)))
+
+
 
 ;;; Helpful for debugging
 (defun pathname-components (p)
diff --git a/test/test-compile-file-failure.script b/test/test-compile-file-failure.script
index 1cb0e307..bab990f3 100644
--- a/test/test-compile-file-failure.script
+++ b/test/test-compile-file-failure.script
@@ -9,9 +9,9 @@
 	      t)
           (compile-file-error () nil)))
 
-#-gcl
-(assert (handler-case
-            (let ((*compile-file-failure-behaviour* :error))
-              (load-system 'test-compile-file-failure :force t)
-              nil)
-          (compile-file-error () t)))
+(with-expected-failure (#+gcl "GCL failure to report compile-file error")
+  (assert (handler-case
+              (let ((*compile-file-failure-behaviour* :error))
+                (load-system 'test-compile-file-failure :force t)
+                nil)
+            (compile-file-error () t))))
diff --git a/test/test-concatenate-source.script b/test/test-concatenate-source.script
index 2571ecd7..be49f2b2 100644
--- a/test/test-concatenate-source.script
+++ b/test/test-concatenate-source.script
@@ -16,11 +16,11 @@
 (assert-pathnames-equal
  (input-files mcso sys)
  (loop :for n :in '(3 1 2) :collect (test-source (format nil "file~D.lisp" n))))
-#-xcl ;; xcl has buggy translate-pathname
-(assert-pathname-equal
- (output-file mcso sys)
- (apply-output-translations
-  (resolve-output "asdf/test/test-concatenate-source--all-systems.lisp")))
+(with-expected-failure (#+xcl "xcl has buggy translate-pathname")
+  (assert-pathname-equal
+   (output-file mcso sys)
+   (apply-output-translations
+    (resolve-output "asdf/test/test-concatenate-source--all-systems.lisp"))))
 (assert-pathnames-equal
  (output-files mcso sys)
  (input-files mccso sys))
diff --git a/test/test-deferred-warnings.script b/test/test-deferred-warnings.script
index 110f842a..adab6258 100644
--- a/test/test-deferred-warnings.script
+++ b/test/test-deferred-warnings.script
@@ -76,27 +76,24 @@
 
 (load-system :use-setf-then-defun-foo)
 
-;;#+clozure (format t "~S~%" asdf/lisp-build::*warnings*)
-;;#+clozure (trace load compile-file check-deferred-warnings check-lisp-compile-warnings)
-
 ;; FIXME: on CCL, the defmacro warning is found while loading the defmacro fasl.
 ;; We should probably beef up the detection in reify-deferred-warnings,
 ;; possibly file a bug.
-#-clozure
-(assert
- (handler-case
-     (load-system :use-then-defmacro-foo :force t)
-   ((or compile-file-error compile-warned-error) () t)
-   ;;(t (c) (DBG :utdf0 c))
-   (:no-error (&rest values) (DBG :utdf1 values) nil)))
-
-#-clozure
-(assert
- (handler-case
-     (load-system :use-setf-then-defsetf-foo :force t)
-   ((or compile-file-error compile-warned-error) () t)
-   ;;(t (c) (DBG :ustdf0 c))
-   (:no-error (&rest values) (DBG :ustdf1 values) nil)))
+(with-expected-failure (#+clozure "CCL warns while loading, not compiling")
+  (assert
+   (handler-case
+       (load-system :use-then-defmacro-foo :force t)
+     ((or compile-file-error compile-warned-error) () t)
+     ;;(t (c) (DBG :utdf0 c))
+     (:no-error (&rest values) (DBG :utdf1 values) nil))))
+
+(with-expected-failure (#+clozure "CCL warns while loading, not compiling")
+  (assert
+   (handler-case
+       (load-system :use-setf-then-defsetf-foo :force t)
+     ((or compile-file-error compile-warned-error) () t)
+     ;;(t (c) (DBG :ustdf0 c))
+     (:no-error (&rest values) (DBG :ustdf1 values) nil))))
 
 (errors #+(or allegro clozure) compile-file-error
         #+(or cmu scl) compile-warned-error
diff --git a/test/test-encodings.script b/test/test-encodings.script
index 0d9aa54d..28458802 100644
--- a/test/test-encodings.script
+++ b/test/test-encodings.script
@@ -77,15 +77,22 @@
 
 
 (load-system :asdf-encodings)
-#-lispworks
-(with-encoding-test (:latin-2)
-  (def-test-system :test-encoding-implicit-autodetect
-    :components ((:file "lambda"))))
+
+(with-expected-failure (#+lispworks "LispWorks doesn't have LATIN-2"
+                        #+ecl "ECL recently broke its encoding support") ;; Check that it indeed still is broken before we punt.
+  (with-encoding-test (:latin-2)
+    (def-test-system :test-encoding-implicit-autodetect
+      :components ((:file "lambda")))))
+
+#+ecl
+(leave-test "ECL recently broke its encoding support" 0)
+
 #+sbcl
 (with-encoding-test (:koi8-r)
   (def-test-system :test-encoding-explicit-koi8-r
     :components ((:file "lambda" :encoding :koi8-r))))
 
+
 (with-encoding-test (:utf-8)
   (def-test-system :test-file-encoding-u8
     :encoding :latin-1
diff --git a/test/test-operation-classes.script b/test/test-operation-classes.script
index e780f327..bbcf83ca 100644
--- a/test/test-operation-classes.script
+++ b/test/test-operation-classes.script
@@ -52,9 +52,9 @@
 (signals operation-definition-warning
          (make-instance 'my-unupdated-operation))
 
-#-gcl
-(signals operation-definition-error
-         (make-instance 'my-incoherent-operation))
+(with-expected-failure (#+gcl "GCL has trouble with CLOS?")
+  (signals operation-definition-error
+           (make-instance 'my-incoherent-operation)))
 
 (assert (make-instance 'my-good-operation))
 
diff --git a/test/test-run-program.script b/test/test-run-program.script
index 227b1f53..db7f42d8 100644
--- a/test/test-run-program.script
+++ b/test/test-run-program.script
@@ -37,7 +37,8 @@
 
 #+os-unix
 (progn
-  (chdir *test-directory*)
+  (with-expected-failure (#+xcl "no chdir")
+    (chdir *test-directory*))
 
   (DBG "Testing good shell command in current directory via run-shell-command")
   (assert-equal 0 (run-shell-command "./good-shell-command"))
@@ -70,7 +71,6 @@
        (let ((*verbose-out* s))
          (run-shell-command "echo ~A 1" "ok")))))
    ok1)
-  #-ecl
   (assert-equal
    (dewindowize
     (stripln
@@ -182,8 +182,7 @@ Testing run-program
   (assert-equal (nl "Hello World") (run-program '("echo" "Hello World") :output :string))
   (assert-equal (nl "Hello World") (run-program "echo Hello World" :output :string))
 
-  ;; Test that run-program fails properly with an
-  ;; empty program string
+  ;; Test that run-program fails properly with an empty program string
   #+(or clozure (and allegro os-unix) cmu (and lispworks os-unix) sbcl scl)
   (signals error (run-program '("") :output :lines))
 
diff --git a/test/test-sysdef-asdf.script b/test/test-sysdef-asdf.script
index 63cae219..1c1a2a87 100644
--- a/test/test-sysdef-asdf.script
+++ b/test/test-sysdef-asdf.script
@@ -50,7 +50,7 @@
 ;; But if we cheat on our version, that should work
 (setf asdf::*asdf-version* "3.0")
 (asdf::clear-defined-system "asdf")
-#-xcl ;; XCL has trouble with the ASDF upgrade
+#-xcl ;; expected-failure: XCL has trouble with the ASDF upgrade
 (load-system :asdf)
 (assert-pathname-equal (subpathname *asdf-directory* "asdf.asd")
 		       (system-source-file (find-system :asdf)))
diff --git a/test/test-try-recompiling-1.script b/test/test-try-recompiling-1.script
index d2cc4658..6b3565ec 100644
--- a/test/test-try-recompiling-1.script
+++ b/test/test-try-recompiling-1.script
@@ -2,8 +2,6 @@
 
 ;;; test asdf:try-recompiling restart
 
-
-
 (defparameter *caught-error* nil)
 
 (delete-file-if-exists (test-fasl "try-recompiling-1"))
@@ -17,9 +15,7 @@
                    :asdf)
                 (assert (eq mode :external))
                 (let ((restart (find-restart name c)))
-                  #+(or)
-                  ;; debug
-                  (print (list c restart (compute-restarts c)))
+                  ;;(DBG :foo c restart (compute-restarts c))
                   (when restart
                     (invoke-restart restart)))))))
   (oos 'load-op 'try-recompiling-1))
diff --git a/test/test-urls-1.script b/test/test-urls-1.script
index 0da1d9bf..9d5a5283 100644
--- a/test/test-urls-1.script
+++ b/test/test-urls-1.script
@@ -1,6 +1,5 @@
 ;;; -*- Lisp -*-
 
-
 #+scl
 (require :http-library)
 
diff --git a/test/test-urls-2.script b/test/test-urls-2.script
index f7b1435b..37e39580 100644
--- a/test/test-urls-2.script
+++ b/test/test-urls-2.script
@@ -1,6 +1,5 @@
 ;;; -*- Lisp -*-
 
-
 #+scl
 (require :http-library)
 
diff --git a/test/test-utilities.script b/test/test-utilities.script
index 5002cbff..2e0f0bfd 100644
--- a/test/test-utilities.script
+++ b/test/test-utilities.script
@@ -7,12 +7,14 @@
     :output '(:string :stripped t))
    :ensure-directory t))
 
-(chdir *asdf-directory*)
-(assert (pathname-equal *asdf-directory* (getcwd)))
-(assert (pathname-equal *asdf-directory* (getcwd-from-run-program)))
-(assert (probe-file* "asdf.asd"))
-
-(chdir *test-directory*)
+(with-expected-failure (#+xcl "chdir unsupported")
+  (chdir *asdf-directory*)
+  (assert (pathname-equal *asdf-directory* (getcwd)))
+  (assert (pathname-equal *asdf-directory* (getcwd-from-run-program)))
+  (assert (probe-file* "asdf.asd")))
+
+(with-expected-failure (#+xcl "chdir unsupported")
+  (chdir *test-directory*))
 (assert (pathname-equal *test-directory* (getcwd)))
 (assert (pathname-equal *test-directory* (getcwd-from-run-program)))
 (assert (probe-file* "test-utilities.script"))
@@ -319,17 +321,17 @@
   (assert-equal (read-file-lines pn2) '("Hello, World"))
   (delete-file pn2))
 
-#-gcl ;; BUG in GCL compiling the WTF internal loop. Works if loaded without compiling.
-(assert
- (not (probe-file
-       (let ((s 'outer-s))
-         (with-temporary-file (:stream s :pathname p :direction :io :prefix "WTF3")
-           (assert (open-stream-p s))
-           (println "Same thing with :close-stream" s)
-           :close-stream
-           (assert-equal s 'outer-s) ;; the stream s (1) has been closed and (2) is no longer in scope.
-           (assert-equal (read-file-lines p) '("Same thing with :close-stream"))
-           p)))))
+(with-expected-failure (#+gcl "BUG in GCL compiling the WTF internal loop. Works if loaded without compiling.")
+  (assert
+   (not (probe-file
+         (let ((s 'outer-s))
+           (with-temporary-file (:stream s :pathname p :direction :io :prefix "WTF3")
+             (assert (open-stream-p s))
+             (println "Same thing with :close-stream" s)
+             :close-stream
+             (assert-equal s 'outer-s) ;; the stream s (1) has been closed and (2) is no longer in scope.
+             (assert-equal (read-file-lines p) '("Same thing with :close-stream"))
+             p))))))
 
 (DBG :ensure-gethash)
 (let ((h (make-hash-table :test 'equal)))
-- 
GitLab