diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor
index c6dea08d18..e45f76d7df 100644
--- a/basis/tools/test/test.factor
+++ b/basis/tools/test/test.factor
@@ -1,95 +1,146 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces arrays prettyprint sequences kernel
-vectors quotations words parser assocs combinators continuations
-debugger io io.styles io.files vocabs vocabs.loader source-files
-compiler.units summary stack-checker effects tools.vocabs fry ;
+USING: accessors arrays assocs combinators compiler.units
+continuations debugger effects fry generalizations io io.files
+io.styles kernel lexer locals macros math.parser namespaces
+parser prettyprint quotations sequences source-files splitting
+stack-checker summary unicode.case vectors vocabs vocabs.loader words
+tools.vocabs tools.errors source-files.errors io.streams.string make ;
 IN: tools.test
 
-SYMBOL: failures
+TUPLE: test-failure < source-file-error experiment continuation ;
 
-: <failure> ( error what -- triple )
-    error-continuation get 3array ;
+SYMBOL: passed-tests
+SYMBOL: failed-tests
 
-: failure ( error what -- )
+<PRIVATE
+
+: <test-failure> ( error experiment file line# -- triple )
+    test-failure new
+        swap >>line#
+        swap >>file
+        swap >>experiment
+        swap >>error
+        error-continuation get >>continuation ;
+
+: failure ( error experiment file line# -- )
     "--> test failed!" print
-    <failure> failures get push ;
+    <test-failure> failed-tests get push ;
 
-SYMBOL: this-test
+: success ( experiment -- ) passed-tests get push ;
 
-: (unit-test) ( what quot -- )
-    swap dup . flush this-test set
-    failures get [
-        [ this-test get failure ] recover
-    ] [
-        call
-    ] if ; inline
+: file-failure ( error file -- )
+    [ f ] [ f ] bi* failure ;
 
-: unit-test ( output input -- )
-    [ 2array ] 2keep '[
-        _ { } _ with-datastack swap >array assert=
-    ] (unit-test) ;
+:: (unit-test) ( output input -- error ? )
+    [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; inline
 
 : short-effect ( effect -- pair )
     [ in>> length ] [ out>> length ] bi 2array ;
 
-: must-infer-as ( effect quot -- )
-    [ 1quotation ] dip '[ _ infer short-effect ] unit-test ;
+:: (must-infer-as) ( effect quot -- error ? )
+    [ quot infer short-effect effect assert= f f ] [ t ] recover ; inline
 
-: must-infer ( word/quot -- )
-    dup word? [ 1quotation ] when
-    '[ _ infer drop ] [ ] swap unit-test ;
+:: (must-infer) ( word/quot -- error ? )
+    word/quot dup word? [ '[ _ execute ] ] when :> quot
+    [ quot infer drop f f ] [ t ] recover ; inline
 
-: must-fail-with ( quot pred -- )
-    [ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ;
+SINGLETON: did-not-fail
 
-: must-fail ( quot -- )
-    [ drop t ] must-fail-with ;
+M: did-not-fail summary drop "Did not fail" ;
 
-: (run-test) ( vocab -- )
+:: (must-fail-with) ( quot pred -- error ? )
+    [ quot call did-not-fail t ]
+    [ dup pred call [ drop f f ] [ t ] if ] recover ; inline
+
+:: (must-fail) ( quot -- error ? )
+    [ quot call did-not-fail t ] [ drop f f ] recover ; inline
+
+: experiment-title ( word -- string )
+    "(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ;
+
+MACRO: <experiment> ( word -- )
+    [ stack-effect in>> length dup ]
+    [ name>> experiment-title ] bi
+    '[ _ ndup _ narray _ prefix ] ;
+
+: experiment. ( seq -- )
+    [ first write ": " write ] [ rest . ] bi ;
+
+:: experiment ( word: ( -- error ? ) file line# -- )
+    word <experiment> :> e
+    e experiment.
+    word execute [ e file line# failure ] [ drop e success ] if ; inline
+
+: parse-test ( accum word -- accum )
+    literalize parsed
+    file get dup [ path>> ] when parsed
+    lexer get line>> parsed
+    \ experiment parsed ; inline
+
+<<
+
+SYNTAX: TEST:
+    scan
+    [ create-in ]
+    [ "(" ")" surround search '[ _ parse-test ] ] bi
+    define-syntax ;
+
+>>
+
+: run-test-file ( path -- )
+    [ run-file ] [ swap file-failure ] recover ;
+
+: collect-results ( quot -- failed passed )
+    [
+        V{ } clone failed-tests set
+        V{ } clone passed-tests set
+        call
+        failed-tests get
+        passed-tests get
+    ] with-scope ; inline
+
+: run-vocab-tests ( vocab -- )
     dup vocab source-loaded?>> [
-        vocab-tests [ run-file ] each
+        vocab-tests [ run-test-file ] each
     ] [ drop ] if ;
 
-: run-test ( vocab -- failures )
-    V{ } clone [
-        failures [
-            [ (run-test) ] [ swap failure ] recover
-        ] with-variable
-    ] keep ;
+: traceback-button. ( failure -- )
+    "[" write [ "Traceback" ] dip continuation>> write-object "]" print ;
 
-: failure. ( triple -- )
-    dup second .
-    dup first print-error
-    "Traceback" swap third write-object ;
+PRIVATE>
 
-: test-failures. ( assoc -- )
+TEST: unit-test
+TEST: must-infer-as
+TEST: must-infer
+TEST: must-fail-with
+TEST: must-fail
+
+M: test-failure summary
+    [ experiment>> experiment. ] with-string-writer ;
+
+M: test-failure error. ( error -- )
+    [ call-next-method ]
+    [ traceback-button. ]
+    bi ;
+
+: results. ( failed passed -- )
     [
-        nl
         [
-            "==== ALL TESTS PASSED" print
-        ] [
-            "==== FAILING TESTS:" print
-            [
-                swap vocab-heading.
-                [ failure. nl ] each
-            ] assoc-each
-        ] if-empty
-    ] [
-        "==== NOTHING TO TEST" print
-    ] if* ;
+            [ length # " tests failed, " % ]
+            [ length # " tests passed." % ]
+            bi*
+        ] "" make print nl
+    ] [ drop errors. ] 2bi ;
 
-: run-tests ( prefix -- failures )
-    child-vocabs [ f ] [
-        [ dup run-test ] { } map>assoc
-        [ second empty? not ] filter
-    ] if-empty ;
+: run-tests ( prefix -- failed passed )
+    [ child-vocabs [ run-vocab-tests ] each ] collect-results ;
 
 : test ( prefix -- )
-    run-tests test-failures. ;
+    run-tests results. ;
 
-: run-all-tests ( -- failures )
+: run-all-tests ( -- failed passed )
     "" run-tests ;
 
 : test-all ( -- )
-    run-all-tests test-failures. ;
+    run-all-tests results. ;