load-all now skips vocabs tagged 'not loaded', and test-all skips vocabs tagged 'not tested'

release
Slava Pestov 2010-04-13 18:43:33 -07:00
parent da6bcbedfc
commit 7524007110
3 changed files with 23 additions and 15 deletions

View File

@ -2,11 +2,12 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators compiler.units USING: accessors arrays assocs combinators compiler.units
continuations debugger effects fry generalizations io io.files continuations debugger effects fry generalizations io io.files
io.styles kernel lexer locals macros math.parser namespaces parser io.styles kernel lexer locals macros math.parser namespaces
vocabs.parser prettyprint quotations sequences source-files splitting parser vocabs.parser prettyprint quotations sequences
stack-checker summary unicode.case vectors vocabs vocabs.loader source-files splitting stack-checker summary unicode.case
vocabs.files words tools.errors source-files.errors io.streams.string vectors vocabs vocabs.loader vocabs.files vocabs.metadata words
make compiler.errors ; tools.errors source-files.errors io.streams.string make
compiler.errors ;
IN: tools.test IN: tools.test
TUPLE: test-failure < source-file-error continuation ; TUPLE: test-failure < source-file-error continuation ;
@ -126,7 +127,7 @@ SYMBOL: forget-tests?
forget-tests? get forget-tests? get
[ [ [ forget-source ] each ] with-compilation-unit ] [ drop ] if ; [ [ [ forget-source ] each ] with-compilation-unit ] [ drop ] if ;
: run-vocab-tests ( vocab -- ) : test-vocab ( vocab -- )
vocab dup [ vocab dup [
dup source-loaded?>> [ dup source-loaded?>> [
vocab-tests vocab-tests
@ -136,6 +137,8 @@ SYMBOL: forget-tests?
] [ drop ] if ] [ drop ] if
] [ drop ] if ; ] [ drop ] if ;
: test-vocabs ( vocabs -- ) [ test-vocab ] each ;
PRIVATE> PRIVATE>
TEST: unit-test TEST: unit-test
@ -154,7 +157,6 @@ M: test-failure error. ( error -- )
: :test-failures ( -- ) test-failures get errors. ; : :test-failures ( -- ) test-failures get errors. ;
: test ( prefix -- ) : test ( prefix -- ) child-vocabs test-vocabs ;
child-vocabs [ run-vocab-tests ] each ;
: test-all ( -- ) "" test ; : test-all ( -- ) vocabs filter-don't-test test-vocabs ;

View File

@ -97,9 +97,6 @@ MEMO: all-vocabs-recursive ( -- assoc )
<PRIVATE <PRIVATE
: filter-unportable ( seq -- seq' )
[ vocab-name unportable? not ] filter ;
: collect-vocabs ( quot -- seq ) : collect-vocabs ( quot -- seq )
[ all-vocabs-recursive no-roots no-prefixes ] dip [ all-vocabs-recursive no-roots no-prefixes ] dip
gather natural-sort ; inline gather natural-sort ; inline
@ -109,7 +106,7 @@ PRIVATE>
: (load) ( prefix -- failures ) : (load) ( prefix -- failures )
[ child-vocabs-recursive no-roots no-prefixes ] [ child-vocabs-recursive no-roots no-prefixes ]
[ dup find-vocab-root [ >vocab-link prefix ] [ drop ] if ] bi [ dup find-vocab-root [ >vocab-link prefix ] [ drop ] if ] bi
filter-unportable filter-don't-load
require-all ; require-all ;
: load ( prefix -- ) : load ( prefix -- )

View File

@ -103,12 +103,21 @@ ERROR: bad-platform name ;
: supported-platform? ( platforms -- ? ) : supported-platform? ( platforms -- ? )
[ t ] [ [ os swap class<= ] any? ] if-empty ; [ t ] [ [ os swap class<= ] any? ] if-empty ;
: unportable? ( vocab -- ? ) : don't-load? ( vocab -- ? )
{ {
[ vocab-tags "untested" swap member? ] [ vocab-tags "not loaded" swap member? ]
[ vocab-platforms supported-platform? not ] [ vocab-platforms supported-platform? not ]
} 1|| ; } 1|| ;
: filter-don't-load ( vocabs -- vocabs' )
[ vocab-name don't-load? not ] filter ;
: don't-test? ( vocab -- ? )
vocab-tags "not tested" swap member? ;
: filter-don't-test ( vocabs -- vocabs' )
[ don't-test? not ] filter ;
TUPLE: unsupported-platform vocab requires ; TUPLE: unsupported-platform vocab requires ;
: unsupported-platform ( vocab requires -- ) : unsupported-platform ( vocab requires -- )