From 175c318c892b0627b36fa3c4db66f59680242204 Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Fri, 26 Aug 2005 21:09:03 +0000 Subject: [PATCH] 0.9.4.6: Rewrite the test infrastructure to make it a bit more useful, without having to make major changes to the test files. Move most of run-tests.sh Lisp-side. New features: * Don't bail out at first failure (unless running with --break-on-failure) * Report failed tests at the end of the run * Tests can be marked as expected to fail on certain platforms * Tests can be named * A subset of test files to run can be specified on the command line Todo: * "Quis custodiet ipsos custodes?". Tests for the test framework. Changes to the tests: * Remove the explicit quits on success from the impure tests (handled by the test framework) * Mark some obvious cases as "expected to fail on FOO" Other: * Remove an (unrelated) fixed BUGS entry --- BUGS | 19 --- tests/alien.impure.lisp | 1 - tests/arith.impure.lisp | 1 - tests/backq.impure.lisp | 3 - tests/bit-vector.impure-cload.lisp | 3 - tests/bivalent-stream.impure.lisp | 1 - tests/callback.impure.lisp | 1 - tests/clos.impure-cload.lisp | 3 - tests/clos.impure.lisp | 1 - tests/compiler-1.impure-cload.lisp | 2 - tests/compiler.impure-cload.lisp | 3 - tests/compiler.impure.lisp | 1 - tests/compound-cons.impure.lisp | 2 - tests/condition.impure.lisp | 1 - tests/debug.impure.lisp | 268 +++++++++++++++---------------- tests/define-compiler-macro.impure.lisp | 1 - tests/defstruct.impure.lisp | 1 - tests/deftype.impure.lisp | 1 - tests/dump.impure-cload.lisp | 2 - tests/dynamic-extent.impure.lisp | 1 - tests/eucjp.impure.lisp | 1 - tests/eval.impure.lisp | 1 - tests/exhaust.impure.lisp | 1 - tests/external-format.impure.lisp | 5 +- tests/float.impure.lisp | 3 - tests/float.pure.lisp | 13 +- tests/gc.impure.lisp | 1 - tests/gray-streams.impure.lisp | 4 - tests/hash.impure.lisp | 1 - tests/info.impure.lisp | 1 - tests/interface.impure.lisp | 1 - tests/load.impure.lisp | 1 - tests/loop.impure.lisp | 1 - tests/map-tests.impure.lisp | 1 - tests/mop-3.impure-cload.lisp | 2 - tests/mop-4.impure-cload.lisp | 2 - tests/mop-5.impure-cload.lisp | 2 - tests/mop.impure-cload.lisp | 3 - tests/mop.impure.lisp | 1 - tests/package-locks.impure.lisp | 1 - tests/packages.impure.lisp | 1 - tests/pathnames.impure.lisp | 1 - tests/pprint.impure.lisp | 1 - tests/print.impure.lisp | 1 - tests/properties.impure.lisp | 1 - tests/reader.impure.lisp | 1 - tests/run-tests.lisp | 161 +++++++++++++++++++ tests/run-tests.sh | 114 ++----------- tests/seq.impure.lisp | 1 - tests/setf.impure.lisp | 1 - tests/smoke.impure.lisp | 1 - tests/static-alloc.impure.lisp | 1 - tests/stream.impure.lisp | 1 - tests/test-util.lisp | 54 +++++++ tests/threads.impure.lisp | 1 - tests/type.impure.lisp | 1 - tests/walk.impure.lisp | 3 +- version.lisp-expr | 2 +- 58 files changed, 377 insertions(+), 332 deletions(-) create mode 100644 tests/run-tests.lisp create mode 100644 tests/test-util.lisp diff --git a/BUGS b/BUGS index 38e54ee..071dde6 100644 --- a/BUGS +++ b/BUGS @@ -1393,25 +1393,6 @@ WORKAROUND: method is applicable, and yet matches neither of the method group qualifier patterns. -341: PPRINT-LOGICAL-BLOCK / PPRINT-FILL / PPRINT-LINEAR sharing detection. - (from Paul Dietz' test suite) - - CLHS on PPRINT-LINEAR and PPRINT-FILL (and PPRINT-TABULAR, though - that's slightly different) states that these functions perform - circular and shared structure detection on their object. Therefore, - - a.(let ((*print-circle* t)) - (pprint-linear *standard-output* (let ((x '(a))) (list x x)))) - should print "(#1=(A) #1#)" - - b.(let ((*print-circle* t)) - (pprint-linear *standard-output* - (let ((x (cons nil nil))) (setf (cdr x) x) x))) - should print "#1=(NIL . #1#)" - - (it is likely that the fault lies in PPRINT-LOGICAL-BLOCK, as - suggested by the suggested implementation of PPRINT-TABULAR) - 343: MOP:COMPUTE-DISCRIMINATING-FUNCTION overriding causes error Even the simplest possible overriding of COMPUTE-DISCRIMINATING-FUNCTION, suggested in the PCL implementation diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp index 8984f7d..7192ba3 100644 --- a/tests/alien.impure.lisp +++ b/tests/alien.impure.lisp @@ -126,4 +126,3 @@ (assert (typep (funcall f "HOME") '(or string null)))) ;;; success -(quit :unix-status 104) diff --git a/tests/arith.impure.lisp b/tests/arith.impure.lisp index dc11f8b..00479d4 100644 --- a/tests/arith.impure.lisp +++ b/tests/arith.impure.lisp @@ -152,4 +152,3 @@ (assert (= (64-bit-logcount (1- (ash 1 48))) 48)) (assert (= (64-bit-logcount (1- (ash 1 54))) 54)) -(sb-ext:quit :unix-status 104) diff --git a/tests/backq.impure.lisp b/tests/backq.impure.lisp index cd70cea..5fea61f 100644 --- a/tests/backq.impure.lisp +++ b/tests/backq.impure.lisp @@ -61,6 +61,3 @@ (let ((a '`(1 ,@a ,@b ,.c ,.d))) (let ((*print-circle* t)) (assert (equal (read-from-string (write-to-string a)) a)))) - -;;; success -(quit :unix-status 104) diff --git a/tests/bit-vector.impure-cload.lisp b/tests/bit-vector.impure-cload.lisp index ac2b7b3..470bf57 100644 --- a/tests/bit-vector.impure-cload.lisp +++ b/tests/bit-vector.impure-cload.lisp @@ -84,6 +84,3 @@ ;; except on machines where addressable space is likely to be ;; much bigger than physical memory (test-big-bit-vectors) - -;;; success -(sb-ext:quit :unix-status 104) diff --git a/tests/bivalent-stream.impure.lisp b/tests/bivalent-stream.impure.lisp index 56b5893..c9107f8 100644 --- a/tests/bivalent-stream.impure.lisp +++ b/tests/bivalent-stream.impure.lisp @@ -34,4 +34,3 @@ (delete-file "bivalent-stream-test.txt") -(sb-ext:quit :unix-status 104) diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp index fe25040..747ccf2 100644 --- a/tests/callback.impure.lisp +++ b/tests/callback.impure.lisp @@ -126,4 +126,3 @@ (assert (= 26 (alien-funcall foo))) -(quit :unix-status 104) diff --git a/tests/clos.impure-cload.lisp b/tests/clos.impure-cload.lisp index 9c65d58..3a2e8af 100644 --- a/tests/clos.impure-cload.lisp +++ b/tests/clos.impure-cload.lisp @@ -164,6 +164,3 @@ (make-instance 'class-with-symbol-initarg slot arg)) (assert (eql (slot-value (make-thing 1) 'slot) 1)) (assert (eql (slot-value (make-other-thing 'slot 2) 'slot) 2)) - -;;; success -(sb-ext:quit :unix-status 104) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index cbc2802..de4c435 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1179,4 +1179,3 @@ (list 1 1)))))) ;;;; success -(sb-ext:quit :unix-status 104) diff --git a/tests/compiler-1.impure-cload.lisp b/tests/compiler-1.impure-cload.lisp index 5348c91..d7db6c0 100644 --- a/tests/compiler-1.impure-cload.lisp +++ b/tests/compiler-1.impure-cload.lisp @@ -238,5 +238,3 @@ (find-class 'some-structure nil)) (eval-when (:load-toplevel) (assert (typep (find-class 'some-structure) 'class))) - -(sb-ext:quit :unix-status 104) ; success diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp index 40462d8..5e07aba 100644 --- a/tests/compiler.impure-cload.lisp +++ b/tests/compiler.impure-cload.lisp @@ -448,6 +448,3 @@ (progv '(*hannu-trap*) '() (setq *hannu-trap* t)) (assert (not *hannu-trap*)) - - -(sb-ext:quit :unix-status 104) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 79c8bb7..dd6a23b 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1068,4 +1068,3 @@ (assert (= e-count 4))))) ;;; success -(quit :unix-status 104) diff --git a/tests/compound-cons.impure.lisp b/tests/compound-cons.impure.lisp index 04ed0e9..fc15d17 100644 --- a/tests/compound-cons.impure.lisp +++ b/tests/compound-cons.impure.lisp @@ -63,5 +63,3 @@ (assert (not (subtypep 'cons '(cons structure-object number)))) (assert (subtypep '(cons null fixnum) (type-of '(nil 44)))) - -(sb-ext:quit :unix-status 104) ; success diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp index a8103a9..cdae286 100644 --- a/tests/condition.impure.lisp +++ b/tests/condition.impure.lisp @@ -47,4 +47,3 @@ '(and condition counted-condition))) ;;; success -(sb-ext:quit :unix-status 104) diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index ecf1521..6ff1481 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -125,7 +125,6 @@ '(#+(or x86 x86-64) "bogus stack frame" #-(or x86 x86-64) "undefined function")) -#-(or alpha) ; bug 346 ;;; Test for "undefined function" (undefined_tramp) working properly. ;;; Try it with and without tail call elimination, since they can have ;;; different effects. (Specifically, if undefined_tramp is incorrect @@ -140,21 +139,21 @@ (declare (optimize (speed 1) (debug 2))) ; no tail call elimination (funcall fun))) - (assert (verify-backtrace - (lambda () (test #'optimized)) - (list *undefined-function-frame* - (list '(flet test) #'optimized)))) + (with-test (:fails-on '(or :alpha)) ; bug 346 + (assert (verify-backtrace + (lambda () (test #'optimized)) + (list *undefined-function-frame* + (list '(flet test) #'optimized))))) ;; bug 353: This test fails at least most of the time for x86/linux ;; ca. 0.8.20.16. -- WHN - #-(and x86 linux) - (assert (verify-backtrace - (lambda () (test #'not-optimized)) - (list *undefined-function-frame* - (list '(flet not-optimized)) - (list '(flet test) #'not-optimized))))) - -#-alpha ; bug 346 + (with-test (:fails-on '(or (and :x86 :linux) :alpha)) + (assert (verify-backtrace + (lambda () (test #'not-optimized)) + (list *undefined-function-frame* + (list '(flet not-optimized)) + (list '(flet test) #'not-optimized)))))) + ;;; 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 @@ -176,19 +175,21 @@ (test (fun) (declare (optimize (speed 1) (debug 2))) ; no tail call elimination (funcall fun))) - (assert (verify-backtrace (lambda () (test #'optimized)) - (list '(/ 42 &rest) - (list '(flet test) #'optimized)))) - (assert (verify-backtrace (lambda () (test #'not-optimized)) - (list '(/ 42 &rest) - '((flet not-optimized)) - (list '(flet test) #'not-optimized))))) - -#-(or alpha (and x86 linux)) ; bug 61 -(progn - (defun throw-test () - (throw 'no-such-tag t)) - (assert (verify-backtrace #'throw-test '((throw-test))))) + (with-test (:fails-on '(or :alpha)) ; bug 346 + (assert (verify-backtrace (lambda () (test #'optimized)) + (list '(/ 42 &rest) + (list '(flet test) #'optimized))))) + (with-test (:fails-on '(or :alpha)) ; bug 346 + (assert (verify-backtrace (lambda () (test #'not-optimized)) + (list '(/ 42 &rest) + '((flet not-optimized)) + (list '(flet test) #'not-optimized)))))) + +(with-test (:fails-on '(or (and :x86 :linux) :alpha)) + (progn + (defun throw-test () + (throw 'no-such-tag t)) + (assert (verify-backtrace #'throw-test '((throw-test)))))) ;;; test entry point handling in backtraces @@ -225,104 +226,104 @@ (defbt 5 (&optional (opt (oops))) (list opt)) -#-(and x86 linux) -(macrolet ((with-details (bool &body body) - `(let ((sb-debug:*show-entry-point-details* ,bool)) - ,@body))) - - ;; TL-XEP - (print :tl-xep) - (with-details t - (assert (verify-backtrace #'namestring - '(((sb-c::tl-xep namestring) 0 ?))))) - (with-details nil - (assert (verify-backtrace #'namestring - '((namestring))))) - - - ;; &MORE-PROCESSOR - (with-details t - (assert (verify-backtrace (lambda () (bt.1.1 :key)) - '(((sb-c::&more-processor bt.1.1) &rest)))) - (assert (verify-backtrace (lambda () (bt.1.2 :key)) - '(((sb-c::&more-processor bt.1.2) &rest)))) - (assert (verify-backtrace (lambda () (bt.1.3 :key)) - '(((sb-c::&more-processor bt.1.3) &rest))))) - (with-details nil - (assert (verify-backtrace (lambda () (bt.1.1 :key)) - '((bt.1.1 :key)))) - (assert (verify-backtrace (lambda () (bt.1.2 :key)) - '((bt.1.2 &rest)))) - (assert (verify-backtrace (lambda () (bt.1.3 :key)) - '((bt.1.3 &rest))))) - - ;; XEP - (print :xep) - (with-details t - (assert (verify-backtrace #'bt.2.1 - '(((sb-c::xep bt.2.1) 0 ?)))) - (assert (verify-backtrace #'bt.2.2 - '(((sb-c::xep bt.2.2) &rest)))) - (assert (verify-backtrace #'bt.2.3 - '(((sb-c::xep bt.2.3) &rest))))) - (with-details nil - (assert (verify-backtrace #'bt.2.1 - '((bt.2.1)))) - (assert (verify-backtrace #'bt.2.2 - '((bt.2.2 &rest)))) - (assert (verify-backtrace #'bt.2.3 - '((bt.2.3 &rest))))) - - ;; VARARGS-ENTRY - (print :varargs-entry) - (with-details t - (assert (verify-backtrace #'bt.3.1 - '(((sb-c::varargs-entry bt.3.1) :key nil)))) - (assert (verify-backtrace #'bt.3.2 - '(((sb-c::varargs-entry bt.3.2) :key ?)))) - (assert (verify-backtrace #'bt.3.3 - '(((sb-c::varargs-entry bt.3.3) &rest))))) - (with-details nil - (assert (verify-backtrace #'bt.3.1 - '((bt.3.1 :key nil)))) - (assert (verify-backtrace #'bt.3.2 - '((bt.3.2 :key ?)))) - (assert (verify-backtrace #'bt.3.3 - '((bt.3.3 &rest))))) - - ;; HAIRY-ARG-PROCESSOR - (print :hairy-args-processor) - (with-details t - (assert (verify-backtrace #'bt.4.1 - '(((sb-c::hairy-arg-processor bt.4.1) ?)))) - (assert (verify-backtrace #'bt.4.2 - '(((sb-c::hairy-arg-processor bt.4.2) ?)))) - (assert (verify-backtrace #'bt.4.3 - '(((sb-c::hairy-arg-processor bt.4.3) &rest))))) - (with-details nil - (assert (verify-backtrace #'bt.4.1 - '((bt.4.1 ?)))) - (assert (verify-backtrace #'bt.4.2 - '((bt.4.2 ?)))) - (assert (verify-backtrace #'bt.4.3 - '((bt.4.3 &rest))))) - - ;; &OPTIONAL-PROCESSOR - (print :optional-processor) - (with-details t - (assert (verify-backtrace #'bt.5.1 - '(((sb-c::&optional-processor bt.5.1))))) - (assert (verify-backtrace #'bt.5.2 - '(((sb-c::&optional-processor bt.5.2) &rest)))) - (assert (verify-backtrace #'bt.5.3 - '(((sb-c::&optional-processor bt.5.3) &rest))))) - (with-details nil - (assert (verify-backtrace #'bt.5.1 - '((bt.5.1)))) - (assert (verify-backtrace #'bt.5.2 - '((bt.5.2 &rest)))) - (assert (verify-backtrace #'bt.5.3 - '((bt.5.3 &rest)))))) +(with-test (:fails-on '(and :x86 :linux)) + (macrolet ((with-details (bool &body body) + `(let ((sb-debug:*show-entry-point-details* ,bool)) + ,@body))) + + ;; TL-XEP + (print :tl-xep) + (with-details t + (assert (verify-backtrace #'namestring + '(((sb-c::tl-xep namestring) 0 ?))))) + (with-details nil + (assert (verify-backtrace #'namestring + '((namestring))))) + + + ;; &MORE-PROCESSOR + (with-details t + (assert (verify-backtrace (lambda () (bt.1.1 :key)) + '(((sb-c::&more-processor bt.1.1) &rest)))) + (assert (verify-backtrace (lambda () (bt.1.2 :key)) + '(((sb-c::&more-processor bt.1.2) &rest)))) + (assert (verify-backtrace (lambda () (bt.1.3 :key)) + '(((sb-c::&more-processor bt.1.3) &rest))))) + (with-details nil + (assert (verify-backtrace (lambda () (bt.1.1 :key)) + '((bt.1.1 :key)))) + (assert (verify-backtrace (lambda () (bt.1.2 :key)) + '((bt.1.2 &rest)))) + (assert (verify-backtrace (lambda () (bt.1.3 :key)) + '((bt.1.3 &rest))))) + + ;; XEP + (print :xep) + (with-details t + (assert (verify-backtrace #'bt.2.1 + '(((sb-c::xep bt.2.1) 0 ?)))) + (assert (verify-backtrace #'bt.2.2 + '(((sb-c::xep bt.2.2) &rest)))) + (assert (verify-backtrace #'bt.2.3 + '(((sb-c::xep bt.2.3) &rest))))) + (with-details nil + (assert (verify-backtrace #'bt.2.1 + '((bt.2.1)))) + (assert (verify-backtrace #'bt.2.2 + '((bt.2.2 &rest)))) + (assert (verify-backtrace #'bt.2.3 + '((bt.2.3 &rest))))) + + ;; VARARGS-ENTRY + (print :varargs-entry) + (with-details t + (assert (verify-backtrace #'bt.3.1 + '(((sb-c::varargs-entry bt.3.1) :key nil)))) + (assert (verify-backtrace #'bt.3.2 + '(((sb-c::varargs-entry bt.3.2) :key ?)))) + (assert (verify-backtrace #'bt.3.3 + '(((sb-c::varargs-entry bt.3.3) &rest))))) + (with-details nil + (assert (verify-backtrace #'bt.3.1 + '((bt.3.1 :key nil)))) + (assert (verify-backtrace #'bt.3.2 + '((bt.3.2 :key ?)))) + (assert (verify-backtrace #'bt.3.3 + '((bt.3.3 &rest))))) + + ;; HAIRY-ARG-PROCESSOR + (print :hairy-args-processor) + (with-details t + (assert (verify-backtrace #'bt.4.1 + '(((sb-c::hairy-arg-processor bt.4.1) ?)))) + (assert (verify-backtrace #'bt.4.2 + '(((sb-c::hairy-arg-processor bt.4.2) ?)))) + (assert (verify-backtrace #'bt.4.3 + '(((sb-c::hairy-arg-processor bt.4.3) &rest))))) + (with-details nil + (assert (verify-backtrace #'bt.4.1 + '((bt.4.1 ?)))) + (assert (verify-backtrace #'bt.4.2 + '((bt.4.2 ?)))) + (assert (verify-backtrace #'bt.4.3 + '((bt.4.3 &rest))))) + + ;; &OPTIONAL-PROCESSOR + (print :optional-processor) + (with-details t + (assert (verify-backtrace #'bt.5.1 + '(((sb-c::&optional-processor bt.5.1))))) + (assert (verify-backtrace #'bt.5.2 + '(((sb-c::&optional-processor bt.5.2) &rest)))) + (assert (verify-backtrace #'bt.5.3 + '(((sb-c::&optional-processor bt.5.3) &rest))))) + (with-details nil + (assert (verify-backtrace #'bt.5.1 + '((bt.5.1)))) + (assert (verify-backtrace #'bt.5.2 + '((bt.5.2 &rest)))) + (assert (verify-backtrace #'bt.5.3 + '((bt.5.3 &rest))))))) ;;;; test TRACE @@ -336,14 +337,14 @@ (assert (search "TRACE-THIS" out)) (assert (search "returned OK" out))) -#-(and ppc darwin) -;;; bug 379 -(let ((out (with-output-to-string (*trace-output*) - (trace trace-this :encapsulate nil) - (assert (eq 'ok (trace-this))) - (untrace)))) - (assert (search "TRACE-THIS" out)) - (assert (search "returned OK" out))) +(with-test (:fails-on '(and :ppc :darwin)) + ;;; bug 379 + (let ((out (with-output-to-string (*trace-output*) + (trace trace-this :encapsulate nil) + (assert (eq 'ok (trace-this))) + (untrace)))) + (assert (search "TRACE-THIS" out)) + (assert (search "returned OK" out)))) ;;;; test infinite error protection @@ -385,6 +386,3 @@ (loop while (sb-thread:thread-alive-p thread))) (disable-debugger) - -;;; success -(quit :unix-status 104) diff --git a/tests/define-compiler-macro.impure.lisp b/tests/define-compiler-macro.impure.lisp index 27527d0..d0b61a3 100644 --- a/tests/define-compiler-macro.impure.lisp +++ b/tests/define-compiler-macro.impure.lisp @@ -39,4 +39,3 @@ '(funcall #'square x) nil))) -(quit :unix-status 104) diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index abd655e..9a0a99d 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -664,4 +664,3 @@ ;;; success (format t "~&/returning success~%") -(quit :unix-status 104) diff --git a/tests/deftype.impure.lisp b/tests/deftype.impure.lisp index e236981..55a1332 100644 --- a/tests/deftype.impure.lisp +++ b/tests/deftype.impure.lisp @@ -27,4 +27,3 @@ (assert (typep 1 'key)) (assert (typep 1 'key-singleton)) -(quit :unix-status 104) diff --git a/tests/dump.impure-cload.lisp b/tests/dump.impure-cload.lisp index e7cdf57..a19094f 100644 --- a/tests/dump.impure-cload.lisp +++ b/tests/dump.impure-cload.lisp @@ -123,5 +123,3 @@ (assert (not (eq *base-string* *character-string*))) (assert (typep *base-string* 'base-string)) (assert (typep *character-string* '(vector character)))) - -(sb-ext:quit :unix-status 104) ; success diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index b8380dc..0b1b6f6 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -188,4 +188,3 @@ (bdowning-2005-iv-16) -(sb-ext:quit :unix-status 104) diff --git a/tests/eucjp.impure.lisp b/tests/eucjp.impure.lisp index d80e52a..cedc6db 100644 --- a/tests/eucjp.impure.lisp +++ b/tests/eucjp.impure.lisp @@ -84,4 +84,3 @@ 'list) (coerce o 'list)))))) ;;; success -(sb-ext:quit :unix-status 104) diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp index a7f44b7..9dfbc14 100644 --- a/tests/eval.impure.lisp +++ b/tests/eval.impure.lisp @@ -137,4 +137,3 @@ (eval '(progn (princ ".") (let ((x 42)) t) (princ ".")))))) ;;; success -(sb-ext:quit :unix-status 104) diff --git a/tests/exhaust.impure.lisp b/tests/exhaust.impure.lisp index 4a91fca..79f44a4 100644 --- a/tests/exhaust.impure.lisp +++ b/tests/exhaust.impure.lisp @@ -71,4 +71,3 @@ (assert (= exhaust-count recurse-count *count*))) ;;; OK! -(quit :unix-status 104) diff --git a/tests/external-format.impure.lisp b/tests/external-format.impure.lisp index d1a9644..c86b6ef 100644 --- a/tests/external-format.impure.lisp +++ b/tests/external-format.impure.lisp @@ -39,7 +39,9 @@ (delete-file "external-format-test.txt") #-sb-unicode -(sb-ext:quit :unix-status 104) +(progn + (test-util:report-test-status) + (sb-ext:quit :unix-status 104)) ;;; Test UTF-8 writing and reading of 1, 2, 3 and 4 octet characters with ;;; all possible offsets. Tests for buffer edge bugs. fd-stream buffers are @@ -159,4 +161,3 @@ (delete-file "external-format-test.txt") -(sb-ext:quit :unix-status 104) diff --git a/tests/float.impure.lisp b/tests/float.impure.lisp index baf2c0f..aaf7eb8 100644 --- a/tests/float.impure.lisp +++ b/tests/float.impure.lisp @@ -119,6 +119,3 @@ (defun new-pu-label-from-pu-labels (array) (setf (aref (the myarraytype array) 0) sb-ext:double-float-positive-infinity)) - -;;; success -(quit :unix-status 104) diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp index 81a10f5..cebcc4e 100644 --- a/tests/float.pure.lisp +++ b/tests/float.pure.lisp @@ -91,12 +91,13 @@ least-positive-double-float)) (assert (= 0.0 (scale-float 1.0 most-negative-fixnum))) (assert (= 0.0d0 (scale-float 1.0d0 (1- most-negative-fixnum)))) -#-(or darwin) ;; bug 372 -(progn - (assert (raises-error? (scale-float 1.0 most-positive-fixnum) - floating-point-overflow)) - (assert (raises-error? (scale-float 1.0d0 (1+ most-positive-fixnum)) - floating-point-overflow))) + +(with-test (:fails-on '(or :darwin)) ;; bug 372 + (progn + (assert (raises-error? (scale-float 1.0 most-positive-fixnum) + floating-point-overflow)) + (assert (raises-error? (scale-float 1.0d0 (1+ most-positive-fixnum)) + floating-point-overflow)))) ;;; bug found by jsnell when nfroyd tried to implement better LOGAND ;;; type derivation. diff --git a/tests/gc.impure.lisp b/tests/gc.impure.lisp index e1dd98d..07e3d98 100644 --- a/tests/gc.impure.lisp +++ b/tests/gc.impure.lisp @@ -70,4 +70,3 @@ (setq gc-happend nil)) (assert (not gc-happend))) -(sb-ext:quit :unix-status 104) diff --git a/tests/gray-streams.impure.lisp b/tests/gray-streams.impure.lisp index 0c36e79..f20c68b 100644 --- a/tests/gray-streams.impure.lisp +++ b/tests/gray-streams.impure.lisp @@ -271,7 +271,3 @@ ((eq byte :eof)) (write-byte byte our-bin-to-char-output)))) test-string)))) - -;;;; Voila! - -(quit :unix-status 104) ; success diff --git a/tests/hash.impure.lisp b/tests/hash.impure.lisp index 9afa582..a9928e3 100644 --- a/tests/hash.impure.lisp +++ b/tests/hash.impure.lisp @@ -257,4 +257,3 @@ nil)))) ;;; success -(quit :unix-status 104) diff --git a/tests/info.impure.lisp b/tests/info.impure.lisp index db2eb2a..8abd36b 100644 --- a/tests/info.impure.lisp +++ b/tests/info.impure.lisp @@ -45,4 +45,3 @@ |# ;;; success -(quit :unix-status 104) diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp index 3d757fc..22a9ace 100644 --- a/tests/interface.impure.lisp +++ b/tests/interface.impure.lisp @@ -44,4 +44,3 @@ (disassemble 'disassemble-closure) ;;;; success -(sb-ext:quit :unix-status 104) diff --git a/tests/load.impure.lisp b/tests/load.impure.lisp index fb107f4..829950c 100644 --- a/tests/load.impure.lisp +++ b/tests/load.impure.lisp @@ -68,4 +68,3 @@ (assert (equal (merge-pathnames *tmp-filename*) *saved-load-pathname*))) (delete-file *tmp-filename*)))) -(quit :unix-status 104) diff --git a/tests/loop.impure.lisp b/tests/loop.impure.lisp index 22530a5..f553ac7 100644 --- a/tests/loop.impure.lisp +++ b/tests/loop.impure.lisp @@ -32,4 +32,3 @@ (function string<))))) ;;; success -(quit :unix-status 104) diff --git a/tests/map-tests.impure.lisp b/tests/map-tests.impure.lisp index efd4ca3..ec999b5 100644 --- a/tests/map-tests.impure.lisp +++ b/tests/map-tests.impure.lisp @@ -109,4 +109,3 @@ :arg-types (list list vector)) ;;; success -(quit :unix-status 104) diff --git a/tests/mop-3.impure-cload.lisp b/tests/mop-3.impure-cload.lisp index 44b3a84..74bb0f0 100644 --- a/tests/mop-3.impure-cload.lisp +++ b/tests/mop-3.impure-cload.lisp @@ -90,5 +90,3 @@ (assert (equalp (list (testgf08 5.0) (testgf08 17)) '((real) #(integer real)))) |# - -(sb-ext:quit :unix-status 104) diff --git a/tests/mop-4.impure-cload.lisp b/tests/mop-4.impure-cload.lisp index 157424c..2923f05 100644 --- a/tests/mop-4.impure-cload.lisp +++ b/tests/mop-4.impure-cload.lisp @@ -92,5 +92,3 @@ and ;;; from mop.tst in clisp's test suite |# - -(sb-ext:quit :unix-status 104) diff --git a/tests/mop-5.impure-cload.lisp b/tests/mop-5.impure-cload.lisp index 213d5fd..f9cfec5 100644 --- a/tests/mop-5.impure-cload.lisp +++ b/tests/mop-5.impure-cload.lisp @@ -51,5 +51,3 @@ (defparameter *counter* (make-counter :start 666)) (assert (eq (funcall *counter*) *counter*)) - -(sb-ext:quit :unix-status 104) diff --git a/tests/mop.impure-cload.lisp b/tests/mop.impure-cload.lisp index 07932e0..4d98521 100644 --- a/tests/mop.impure-cload.lisp +++ b/tests/mop.impure-cload.lisp @@ -57,6 +57,3 @@ (eval '(make-instance 'person :name t)) - -;;; success -(sb-ext:quit :unix-status 104) \ No newline at end of file diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 053148e..287655a 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -430,4 +430,3 @@ (assert (eq (slot-value (make-instance 'extra-initarg) 'slot) 'extra)) ;;;; success -(sb-ext:quit :unix-status 104) diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp index 59415e3..f535e9e 100644 --- a/tests/package-locks.impure.lisp +++ b/tests/package-locks.impure.lisp @@ -478,4 +478,3 @@ package-lock-violation)) ;;; WOOT! Done. -(sb-ext:quit :unix-status 104) diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp index 0496895..ddfdf18 100644 --- a/tests/packages.impure.lisp +++ b/tests/packages.impure.lisp @@ -22,4 +22,3 @@ (package-error (c) (princ c)) (:no-error (&rest args) (error "(EXPORT :FOO) returned ~S" args))) -(sb-ext:quit :unix-status 104) diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index 07f4f31..280334b 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -358,4 +358,3 @@ actual)) ;;;; success -(quit :unix-status 104) diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp index 9c6fcee..05a7525 100644 --- a/tests/pprint.impure.lisp +++ b/tests/pprint.impure.lisp @@ -202,4 +202,3 @@ (write '#1=(#2=(#2# . #3=(#1# . #3#))) :stream s))))) ;;; success -(quit :unix-status 104) diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp index a0f67bf..8d22b9d 100644 --- a/tests/print.impure.lisp +++ b/tests/print.impure.lisp @@ -338,4 +338,3 @@ (assert (string= (format nil "~@F" 1.23) "+1.23")) ;;; success -(quit :unix-status 104) diff --git a/tests/properties.impure.lisp b/tests/properties.impure.lisp index bdfa8bc..51519d7 100644 --- a/tests/properties.impure.lisp +++ b/tests/properties.impure.lisp @@ -33,4 +33,3 @@ (assert (not (cdr *nil-that-the-compiler-cannot-constant-fold*))) ;;; success -(quit :unix-status 104) diff --git a/tests/reader.impure.lisp b/tests/reader.impure.lisp index 3a9507a..5b35f78 100644 --- a/tests/reader.impure.lisp +++ b/tests/reader.impure.lisp @@ -103,4 +103,3 @@ (assert (eq 'a (read (make-instance 'my-in-stream :last-char nil)))) ;;; success -(quit :unix-status 104) diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp new file mode 100644 index 0000000..7845a6e --- /dev/null +++ b/tests/run-tests.lisp @@ -0,0 +1,161 @@ +#+#.(cl:if (cl:find-package "ASDF") '(or) '(and)) +(load (merge-pathnames "../contrib/asdf/asdf.fasl")) + +#+#.(cl:if (cl:find-package "SB-POSIX") '(or) '(and)) +(let ((asdf:*central-registry* + (cons "../contrib/systems/" asdf:*central-registry*))) + (asdf:oos 'asdf:load-op 'sb-posix)) + +(load "test-util.lisp") + +(defpackage :run-tests + (:use :cl :test-util :sb-ext)) + +(load "assertoid.lisp") + +(in-package run-tests) + +(defvar *all-failures* nil) +(defvar *break-on-error* nil) +(defvar *accept-files* nil) + +(defun run-all () + (dolist (arg (cdr *posix-argv*)) + (cond ((string= arg "--break-on-failure") + (setf *break-on-error* t) + (setf test-util:*break-on-failure* t)) + ((string= arg "--break-on-expected-failure") + (setf test-util:*break-on-expected-failure* t)) + (t + (push (truename (parse-namestring arg)) *accept-files*)))) + (pure-runner (pure-load-files) #'load-test) + (pure-runner (pure-cload-files) #'cload-test) + (impure-runner (impure-load-files) #'load-test) + (impure-runner (impure-cload-files) #'cload-test) + (impure-runner (sh-files) #'sh-test) + (report) + (sb-ext:quit :unix-status (if (unexpected-failures) + 1 + 104))) + +(defun report () + (terpri) + (format t "Finished running tests.~%") + (cond (*all-failures* + (format t "Status:~%") + (dolist (fail (reverse *all-failures*)) + (cond ((eq (car fail) :unhandled-error) + (format t " ~20a ~a~%" + "Unhandled error" + (enough-namestring (second fail)))) + ((eq (car fail) :invalid-exit-status) + (format t " ~20a ~a~%" + "Invalid exit status:" + (enough-namestring (second fail)))) + (t + (format t " ~20a ~a / ~a~%" + (ecase (first fail) + (:expected-failure "Expected failure:") + (:unexpected-failure "Failure:") + (:unexpected-success "Unexcepted success:")) + (enough-namestring (second fail)) + (third fail)))))) + (t + (format t "All tests succeeded~%")))) + +(defun pure-runner (files test-fun) + (format t "// Running pure tests (~a)~%" test-fun) + (let ((*package* (find-package :cl-user)) + (*failures* nil)) + (setup-cl-user) + (dolist (file files) + (when (accept-test-file file) + (format t "// Running ~a~%" file) + (handler-case + (funcall test-fun file) + (error (error) + (push (list :unhandled-error file) + *all-failures*) + (when *break-on-error* + (test-util:really-invoke-debugger error)))))) + (append-failures))) + +(defun impure-runner (files test-fun) + (format t "// Running impure tests (~a)~%" test-fun) + (let ((*package* (find-package :cl-user))) + (setup-cl-user) + (dolist (file files) + (when (accept-test-file file) + (force-output) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) + (format t "// Running ~a~%" file) + (handler-case + (funcall test-fun file) + (error (error) + (push (list :unhandled-error file) *failures*) + (when *break-on-error* + (test-util:really-invoke-debugger error)))) + (report-test-status) + (sb-ext:quit :unix-status 104)) + (t + (let ((status (make-array 1 :element-type '(signed-byte 32)))) + (sb-posix:waitpid pid 0 status) + (if (and (sb-posix:wifexited (aref status 0)) + (= (sb-posix:wexitstatus (aref status 0)) + 104)) + (with-open-file (stream "test-status.lisp-expr" + :direction :input + :if-does-not-exist :error) + (append-failures (read stream))) + (push (list :invalid-exit-status file) + *all-failures*)))))))))) + +(defun append-failures (&optional (failures *failures*)) + (setf *all-failures* (append failures *all-failures*))) + +(defun unexpected-failures () + (remove-if (lambda (x) (eq (car x) :expected-failure)) *all-failures*)) + +(defun setup-cl-user () + (use-package :test-util) + (use-package :assertoid)) + +(defun load-test (file) + (load file)) + +(defun cload-test (file) + (let ((compile-name (compile-file-pathname file))) + (unwind-protect + (progn + (compile-file file) + (load compile-name)) + (ignore-errors + (delete-file compile-name))))) + +(defun sh-test (file) + ;; What? No SB-POSIX:EXECV? + (let ((process (sb-ext:run-program "/bin/sh" + (list (namestring file)) + :output *error-output*))) + (sb-ext:quit :unix-status (process-exit-code process)))) + +(defun accept-test-file (file) + (if *accept-files* + (find (truename file) *accept-files* :test #'equalp) + t)) + +(defun pure-load-files () + (directory "*.pure.lisp")) + +(defun pure-cload-files () + (directory "*.pure-cload.lisp")) + +(defun impure-load-files () + (directory "*.impure.lisp")) + +(defun impure-cload-files () + (directory "*.impure-cload.lisp")) + +(defun sh-files () + (directory "*.test.sh")) diff --git a/tests/run-tests.sh b/tests/run-tests.sh index 89bdaaa..14e8488 100644 --- a/tests/run-tests.sh +++ b/tests/run-tests.sh @@ -1,6 +1,13 @@ #!/bin/sh # Run the regression tests in this directory. +# +# Usage: run-tests.sh [--break-on-failure] [--break-on-expected-failure] [files] +# --break-on-failure Break into the debugger when a test fails +# unexpectedly +# --break-on-expected-failure Break into the debugger when any test fails +# +# If no test files are specified, runs all tests. # This software is part of the SBCL system. See the README file for # more information. @@ -20,7 +27,7 @@ # generated relative to `pwd` in the tests/ directory) so that tests # can chdir before invoking SBCL and still work. sbclstem=`pwd`/../src/runtime/sbcl -SBCL="${1:-$sbclstem --core `pwd`/../output/sbcl.core --noinform --sysinit /dev/null --userinit /dev/null --noprint --disable-debugger}" +SBCL="$sbclstem --core `pwd`/../output/sbcl.core --noinform --sysinit /dev/null --userinit /dev/null --noprint --disable-debugger" export SBCL echo /running tests on SBCL=\'$SBCL\' # more or less like SBCL, but without enough grot removed that appending @@ -30,7 +37,9 @@ echo /running tests on SBCL=\'$SBCL\' # --sysinit, so if you use it in a test, you need to add those # yourself if you want things to be clean. If many tests start using # this, we can redo it as a shell function or something so that the -# magic can be done once and only once.) +# magic can be done once and only once.). Not used in this file, but +# exists for the benefit of the *.test.sh files that can be started by +# run-tests.lisp SBCL_ALLOWING_CORE=${1:-$sbclstem} export SBCL_ALLOWING_CORE echo /with SBCL_ALLOWING_CORE=\'$SBCL_ALLOWING_CORE\' @@ -50,106 +59,17 @@ export LC_ALL # successful" path. tenfour () { if [ $1 = 104 ]; then - echo ok + echo ok else - echo test $2 failed, expected 104 return code, got $1 - exit 1 + echo test $2 failed, expected 104 return code, got $1 + exit 1 fi } -# *.pure.lisp files are ordinary Lisp code with no side effects, -# and we can run them all in a single Lisp process. -echo //running '*.pure.lisp' tests -echo //i.e. *.pure.lisp -( -echo "(progn" -echo " (progn (format t \"//loading assertoid.lisp~%\") (load \"assertoid.lisp\"))" -echo " (use-package \"ASSERTOID\")" -for f in *.pure.lisp; do - if [ -f $f ]; then - echo " (progn (format t \"//running $f test~%\") (load \"$f\"))" - fi -done -echo " (sb-ext:quit :unix-status 104)) ; Return status=success." -) | $SBCL ; tenfour $? "(pure.lisp files)" - -# *.impure.lisp files are Lisp code with side effects (e.g. doing -# DEFSTRUCT or DEFTYPE or DEFVAR, or messing with the read table). -# Each one should be LOADed in a separate invocation of Lisp, so -# that we don't need to worry about them interfering with each -# other. -echo //running '*.impure.lisp' tests -for f in *.impure.lisp; do - if [ -f $f ]; then - echo //running $f test - echo "(load \"$f\")" | $SBCL ; tenfour $? $f - fi -done - -# *.test.sh files are scripts to test stuff, typically stuff which -# can't so easily be tested within Lisp itself. A file foo.test.sh -# may be associated with other files foo*, e.g. foo.lisp, foo-1.lisp, -# or foo.pl. -echo //running '*.test.sh' tests -for f in *.test.sh; do - if [ -f $f ]; then - echo //running $f test - sh $f "$SBCL"; tenfour $? $f - fi -done - -# *.assertoids files contain ASSERTOID statements to test things -# interpreted and at various compilation levels. -echo //running '*.assertoids' tests -for f in *.assertoids; do - if [ -f $f ]; then - echo //running $f test - echo "(load \"$f\")" | $SBCL --eval '(load "assertoid.lisp")' ; tenfour $? $f - fi -done - -# *.pure-cload.lisp files want to be compiled, then loaded. They -# can all be done in the same invocation of Lisp. -echo //running '*.pure-cload.lisp' tests -for f in *.pure-cload.lisp; do - # (Actually here we LOAD each one into a separate invocation - # of Lisp just because I haven't figured out a concise way - # to LOAD them all into the same Lisp.) - if [ -f $f ]; then - echo //running $f test - $SBCL <