! Copyright (C) 2009, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs io.directories io.encodings.utf8
-io.files io.pathnames kernel make math.parser memoize sequences
-sets sorting summary vocabs vocabs.loader words system
-classes.algebra combinators.short-circuit fry continuations
-namespaces ;
+USING: accessors arrays assocs classes.algebra
+combinators.short-circuit continuations io.directories
+io.encodings.utf8 io.files io.pathnames kernel make math.parser
+memoize namespaces sequences sets summary system vocabs
+vocabs.loader words ;
IN: vocabs.metadata
: check-vocab ( vocab -- vocab )
vocab-append-path dup
[ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ;
-: ?delete-file ( pathname -- ) '[ _ delete-file ] ignore-errors ;
-
: set-vocab-file-contents ( seq vocab name -- )
dupd vocab-append-path [
swap [ ?delete-file ] [ swap utf8 set-file-lines ] if-empty
dup vocab-tags-path set-vocab-file-contents ;
: add-vocab-tags ( tags vocab -- )
- [ vocab-tags append prune ] keep set-vocab-tags ;
+ [ vocab-tags append members ] keep set-vocab-tags ;
: remove-vocab-tags ( tags vocab -- )
[ vocab-tags swap diff ] keep set-vocab-tags ;
: vocab-platforms ( vocab -- platforms )
dup vocab-platforms-path vocab-file-contents
- [ dup "system" lookup [ ] [ bad-platform ] ?if ] map ;
+ [ dup "system" lookup-word [ ] [ bad-platform ] ?if ] map ;
: set-vocab-platforms ( platforms vocab -- )
[ [ name>> ] map ] dip
dup vocab-platforms-path set-vocab-file-contents ;
-: supported-platform? ( vocab -- ? )
- vocab-platforms [ t ] [ [ os swap class<= ] any? ] if-empty ;
+: supported-platform? ( platforms -- ? )
+ [ t ] [ [ os swap class<= ] any? ] if-empty ;
-: unportable? ( vocab -- ? )
+: don't-load? ( vocab -- ? )
{
- [ vocab-tags "untested" swap member? ]
- [ supported-platform? not ]
+ [ vocab-tags "not loaded" swap member? ]
+ [ vocab-platforms supported-platform? not ]
} 1|| ;
-ERROR: unsupported-platform vocab ;
+: filter-don't-load ( vocabs -- vocabs' )
+ [ vocab-name don't-load? ] reject ;
+
+: don't-test? ( vocab -- ? )
+ vocab-tags "not tested" swap member? ;
+
+: filter-don't-test ( vocabs -- vocabs' )
+ [ don't-test? ] reject ;
+
+TUPLE: unsupported-platform vocab requires ;
+
+: throw-unsupported-platform ( vocab requires -- )
+ \ unsupported-platform boa throw-continue ;
M: unsupported-platform summary
drop "Current operating system not supported by this vocabulary" ;
-[ dup supported-platform? [ drop ] [ vocab-name unsupported-platform ] if ]
-check-vocab-hook set-global
+[
+ dup vocab-platforms dup supported-platform?
+ [ 2drop ] [ [ vocab-name ] dip throw-unsupported-platform ] if
+] check-vocab-hook set-global