Clean up vocabs.loader and add littledan's unit test feature

core/bootstrap/stage1.factor

@@ -38,7 +38,7 @@ vocabs.loader system ;
 
     [
         "resource:core/bootstrap/stage2.factor"
-        dup ?resource-path exists? [
+        dup resource-exists? [
             run-file
         ] [
             "Cannot find " write write "." print

core/compiler/test/redefine/redefine-tests.factor

@@ -1,287 +0,0 @@
-USING: compiler definitions generic assocs inference math
-namespaces parser tools.test words kernel sequences arrays io
-effects tools.test compiler.units inference.state ;
-IN: temporary
-
-DEFER: x-1
-DEFER: x-2
-
-[ [ f ] { } map>assoc modify-code-heap ] recompile-hook [
-    "IN: temporary USE: math GENERIC: x-1 ( x -- y ) M: integer x-1 ;" eval
-    "IN: temporary : x-2 3 x-1 ;" eval
-
-    [ t ] [
-        { x-2 } compile
-
-        \ x-2 word-xt
-
-        { x-1 } compile
-
-        \ x-2 word-xt =
-    ] unit-test
-] with-variable
-
-DEFER: b
-DEFER: c
-
-[ ] [ "IN: temporary : a 1 2 ; : b a a ;" eval ] unit-test
-
-[ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test
-
-{ 0 4 } [ b ] must-infer-as
-
-[ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test
-
-[ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test
-
-{ 0 6 } [ b ] must-infer-as
-
-\ b word-xt "b-xt" set
-
-[ ] [ "IN: temporary : c b ;" eval ] unit-test
-
-[ t ] [ "b-xt" get \ b word-xt = ] unit-test
-
-\ c word-xt "c-xt" set
-
-[ ] [ "IN: temporary : a 1 2 4 ;" eval ] unit-test
-
-[ t ] [ "c-xt" get \ c word-xt = ] unit-test
-
-[ 1 2 4 1 2 4 ] [ "USE: temporary c" eval ] unit-test
-
-[ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test
-
-{ 0 4 } [ c ] must-infer-as
-
-[ f ] [ "c-xt" get \ c word-xt = ] unit-test
-
-[ 1 2 1 2 ] [ "USE: temporary c" eval ] unit-test
-
-[ ] [ "IN: temporary : d 3 ; inline" eval ] unit-test
-
-[ ] [ "IN: temporary : e d d ;" eval ] unit-test
-
-[ 3 3 ] [ "USE: temporary e" eval ] unit-test
-
-[ ] [ "IN: temporary : d 4 ; inline" eval ] unit-test
-
-[ 4 4 ] [ "USE: temporary e" eval ] unit-test
-
-DEFER: x-3
-
-[ ] [ "IN: temporary : x-3 3 ;" eval ] unit-test
-
-DEFER: x-4
-
-[ ] [ "IN: temporary : x-4 x-3 ;" eval ] unit-test
-
-[ t ] [ \ x-4 compiled? ] unit-test
-
-[ ] [ "IN: temporary USE: sequences : x-3 { } [ ] each ;" eval ] unit-test
-
-[ f ] [ \ x-3 compiled? ] unit-test
-
-[ f ] [ \ x-4 compiled? ] unit-test
-
-[ ] [ "IN: temporary USING: kernel sequences ; : x-3 { } [ drop ] each ;" eval ] unit-test
-
-[ t ] [ \ x-3 compiled? ] unit-test
-
-[ t ] [ \ x-4 compiled? ] unit-test
-
-[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test
-
-DEFER: g-test-1
-
-DEFER: g-test-3
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 sq ;" eval ] unit-test
-
-[ ] [ "IN: temporary : g-test-2 ( -- y ) 3 g-test-1 ;" eval ] unit-test
-
-[ ] [ "IN: temporary : g-test-3 ( -- y ) g-test-2 ;" eval ] unit-test
-
-[ 25 ] [ 5 g-test-1 ] unit-test
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 ;" eval ] unit-test
-
-[ 5 ] [ 5 g-test-1 ] unit-test
-
-[ t ] [
-    \ g-test-3 word-xt
-
-    "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 3 + ;" eval
-
-    \ g-test-3 word-xt =
-] unit-test
-
-DEFER: g-test-5
-
-[ ] [ "IN: temporary : g-test-4 ( -- y ) 3 g-test-1 ; inline" eval ] unit-test
-
-[ ] [ "IN: temporary : g-test-5 ( -- y ) g-test-4 ;" eval ] unit-test
-
-[ 6 ] [ g-test-5 ] unit-test
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 10 + ;" eval ] unit-test
-
-[ 13 ] [ g-test-5 ] unit-test
-
-DEFER: g-test-6
-
-[ ] [ "IN: temporary USING: arrays kernel ; GENERIC: g-test-6 ( x -- y ) M: array g-test-6 drop 123 g-test-1 ;" eval ] unit-test
-
-DEFER: g-test-7
-
-[ ] [ "IN: temporary : g-test-7 { } g-test-6 ;" eval ] unit-test
-
-[ 133 ] [ g-test-7 ] unit-test
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 15 + ;" eval ] unit-test
-
-[ 138 ] [ g-test-7 ] unit-test
-
-USE: macros
-
-DEFER: macro-test-3
-
-[ ] [ "IN: temporary USING: macros math ; : macro-test-1 sq ;" eval ] unit-test
-
-[ ] [ "IN: temporary USING: macros arrays quotations ; MACRO: macro-test-2 ( n word -- quot ) <array> >quotation ;" eval ] unit-test
-
-[ ] [ "IN: temporary : macro-test-3 2 \\ macro-test-1 macro-test-2 ;" eval ] unit-test
-
-[ 625 ] [ 5 macro-test-3 ] unit-test
-
-[ ] [ "IN: temporary USING: macros arrays quotations kernel math ; MACRO: macro-test-2 ( n word -- quot ) 2drop [ 3 + ] ;" eval ] unit-test
-
-[ 8 ] [ 5 macro-test-3 ] unit-test
-
-USE: hints
-
-DEFER: hints-test-2
-
-[ ] [ "IN: temporary USING: math hints ; : hints-test-1 3 + ; HINTS: hints-test-1 fixnum ;" eval ] unit-test
-
-[ ] [ "IN: temporary : hints-test-2 5 hints-test-1 ;" eval ] unit-test
-
-[ 8 ] [ hints-test-2 ] unit-test
-
-[ ] [ "IN: temporary USE: math : hints-test-1 5 + ;" eval ] unit-test
-
-[ 10 ] [ hints-test-2 ] unit-test
-
-DEFER: inline-then-not-inline-test-1
-DEFER: inline-then-not-inline-test-2
-
-[ ] [ "IN: temporary : inline-then-not-inline-test-1 1 2 3 ; inline" eval ] unit-test
-
-[ ] [ "IN: temporary : inline-then-not-inline-test-2 inline-then-not-inline-test-1 ;" eval ] unit-test
-
-[ 1 2 3 ] [ inline-then-not-inline-test-2 ] unit-test
-
-\ inline-then-not-inline-test-2 word-xt "a" set
-
-[ ] [ "IN: temporary : inline-then-not-inline-test-1 6 6 9 ;" eval ] unit-test
-
-[ f ] [ \ inline-then-not-inline-test-2 word-xt "a" get = ] unit-test
-
-[ 6 6 9 ] [ inline-then-not-inline-test-2 ] unit-test
-
-DEFER: generic-then-not-generic-test-1
-DEFER: generic-then-not-generic-test-2
-
-[ ] [ "IN: temporary GENERIC: generic-then-not-generic-test-1 ( a -- b )" eval ] unit-test
-
-[ ] [ "IN: temporary USE: math M: integer generic-then-not-generic-test-1 sq ;" eval ] unit-test
-
-[ ] [ "IN: temporary : generic-then-not-generic-test-2 3 generic-then-not-generic-test-1 ;" eval ] unit-test
-
-[ 9 ] [ generic-then-not-generic-test-2 ] unit-test
-
-[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test
-
-[ 4 ] [ generic-then-not-generic-test-2 ] unit-test
-
-DEFER: foldable-test-1
-DEFER: foldable-test-2
-
-[ ] [ "IN: temporary : foldable-test-1 3 ; foldable" eval ] unit-test
-
-[ ] [ "IN: temporary : foldable-test-2 foldable-test-1 ;" eval ] unit-test
-
-[ +inlined+ ] [ \ foldable-test-2 \ foldable-test-1 compiled-usage at ] unit-test
-
-[ 3 ] [ foldable-test-2 ] unit-test
-
-[ ] [ "IN: temporary : foldable-test-1 4 ; foldable" eval ] unit-test
-
-[ 4 ] [ foldable-test-2 ] unit-test
-
-DEFER: flushable-test-2
-
-[ ] [ "IN: temporary USE: kernel : flushable-test-1 drop 3 ; flushable" eval ] unit-test
-
-[ ] [ "IN: temporary USE: kernel : flushable-test-2 V{ } dup flushable-test-1 drop ;" eval ] unit-test
-
-[ V{ } ] [ flushable-test-2 ] unit-test
-
-[ ] [ "IN: temporary USING: kernel sequences ; : flushable-test-1 3 over push ;" eval ] unit-test
-
-[ V{ 3 } ] [ flushable-test-2 ] unit-test
-
-: ax ;
-: bx ax ;
-[ \ bx forget ] with-compilation-unit
-
-[ f ] [ \ bx \ ax compiled-usage key? ] unit-test
-
-DEFER: defer-redefine-test-2
-
-[ ] [ "IN: temporary DEFER: defer-redefine-test-1" eval ] unit-test
-
-[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test
-
-[ defer-redefine-test-2 ] must-fail
-
-[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test
-
-[ 2 1 ] [ defer-redefine-test-2 ] unit-test
-
-! Cross-referencing issue
-: compiled-xref-a ;
-
-: compiled-xref-c ; inline
-
-GENERIC: compiled-xref-b ( a -- b )
-
-TUPLE: c-1 ;
-
-M: c-1 compiled-xref-b compiled-xref-a compiled-xref-c ;
-
-TUPLE: c-2 ;
-
-M: c-2 compiled-xref-b drop 3 ;
-
-[ t ] [
-    \ compiled-xref-a compiled-crossref get key?
-] unit-test
-
-[ ] [
-    [
-        \ compiled-xref-a forget
-    ] with-compilation-unit
-] unit-test
-
-[ f ] [
-    \ compiled-xref-a compiled-crossref get key?
-] unit-test
-
-[ ] [
-    "IN: temporary : compiled-xref-c ; FORGET: { c-2 compiled-xref-b }" eval
-] unit-test
-
-[ f ] [
-    \ compiled-xref-a compiled-crossref get key?
-] unit-test

core/io/files/files.factor

@@ -96,6 +96,9 @@ TUPLE: no-parent-directory path ;
 : ?resource-path ( path -- newpath )
     "resource:" ?head [ resource-path ] when ;
 
+: resource-exists? ( path -- ? )
+    ?resource-path exists? ;
+
 : make-directories ( path -- )
     normalize-pathname right-trim-separators {
         { [ dup "." = ] [ ] }

core/optimizer/optimizer.factor

@@ -4,11 +4,8 @@ USING: kernel namespaces optimizer.backend optimizer.def-use
 optimizer.known-words optimizer.math inference.class ;
 IN: optimizer
 
-SYMBOL: optimize-count
-
 : optimize-1 ( node -- newnode ? )
     [
-        global [ optimize-count inc ] bind
         H{ } clone class-substitutions set
         H{ } clone literal-substitutions set
         H{ } clone value-substitutions set

core/parser/parser.factor

@@ -479,7 +479,7 @@ SYMBOL: interactive-vocabs
     [ [ parse-file call ] keep ] assert-depth drop ;
 
 : ?run-file ( path -- )
-    dup ?resource-path exists? [ run-file ] [ drop ] if ;
+    dup resource-exists? [ run-file ] [ drop ] if ;
 
 : bootstrap-file ( path -- )
     [ parse-file % ] [ run-file ] if-bootstrapping ;

core/source-files/source-files.factor

@@ -26,7 +26,7 @@ uses definitions ;
         rot source-file-checksum
         (source-modified?)
     ] [
-        ?resource-path exists?
+        resource-exists?
     ] ?if ;
 
 : record-modified ( source-file -- )

core/vocabs/loader/loader.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces splitting sequences io.files kernel assocs
 words vocabs definitions parser continuations inspector debugger
@@ -15,45 +15,59 @@ V{
     "resource:work"
 } clone vocab-roots set-global
 
-! No such thing as current directory on Windows CE
+: vocab-dir ( vocab -- dir )
-wince? [ "." vocab-roots get push ] unless
+    vocab-name "." split "/" join ;
 
 : vocab-dir+ ( vocab str/f -- path )
     >r vocab-name "." split r>
     [ >r dup peek r> append add ] when*
     "/" join ;
 
-: vocab-dir ( vocab -- dir )
+: vocab-path+ ( vocab path -- newpath )
-    f vocab-dir+ ;
+    swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
 
-: vocab-source ( vocab -- path )
+: vocab-source-path ( vocab -- path/f )
-    ".factor" vocab-dir+ ;
+    dup ".factor" vocab-dir+ vocab-path+ ;
 
-: vocab-docs ( vocab -- path )
+: vocab-docs-path ( vocab -- path/f )
-    "-docs.factor" vocab-dir+ ;
+    dup "-docs.factor" vocab-dir+ vocab-path+ ;
 
-: vocab-tests ( vocab -- path )
+: vocab-dir? ( root name -- ? )
-    "-tests.factor" vocab-dir+ ;
+    over [
+        ".factor" vocab-dir+ path+ resource-exists?
+    ] [
+        2drop f
+    ] if ;
 
 : find-vocab-root ( vocab -- path/f )
-    vocab-dir vocab-roots get
+    vocab-roots get swap [ vocab-dir? ] curry find nip ;
-    swap [ path+ ?resource-path exists? ] curry find nip ;
 
 M: string vocab-root
     dup vocab [ vocab-root ] [ find-vocab-root ] ?if ;
 
 M: vocab-link vocab-root
-    dup vocab-link-root [ ] [ vocab-link-name vocab-root ] ?if ;
+    vocab-link-root ;
+
+: vocab-tests ( vocab -- tests )
+    dup vocab-root [
+        [
+            f >vocab-link dup
+
+            dup "-tests.factor" vocab-dir+ vocab-path+
+            dup resource-exists? [ , ] [ drop ] if
+
+            dup vocab-dir "test" path+ vocab-path+ dup
+            ?resource-path directory keys [ ".factor" tail? ] subset
+            [ path+ , ] with each
+        ] { } make
+    ] [ drop f ] if ;
 
 : vocab-files ( vocab -- seq )
-    [
+    f >vocab-link [
-        dup vocab-root dup [
+        dup vocab-source-path [ , ] when*
-            swap
+        dup vocab-docs-path [ , ] when*
-            2dup vocab-source path+ ,
+        vocab-tests %
-            2dup vocab-docs path+ ,
+    ] { } make ;
-            2dup vocab-tests path+ ,
-        ] when 2drop
-    ] { } make [ ?resource-path exists? ] subset ;
 
 TUPLE: no-vocab name ;
 
@@ -67,42 +81,36 @@ SYMBOL: load-help?
 
 : source-wasn't-loaded f swap set-vocab-source-loaded? ;
 
-: load-source ( root name -- )
+: load-source ( vocab-link -- )
     [ source-wasn't-loaded ] keep
-    [ vocab-source path+ bootstrap-file ] keep
+    [ vocab-source-path bootstrap-file ] keep
     source-was-loaded ;
 
 : docs-were-loaded t swap set-vocab-docs-loaded? ;
 
 : docs-weren't-loaded f swap set-vocab-docs-loaded? ;
 
-: load-docs ( root name -- )
+: load-docs ( vocab-link -- )
     load-help? get [
         [ docs-weren't-loaded ] keep
-        [ vocab-docs path+ ?run-file ] keep
+        [ vocab-docs-path ?run-file ] keep
         docs-were-loaded
-    ] [ 2drop ] if ;
+    ] [ drop ] if ;
 
-: amend-vocab-from-root ( root name -- vocab )
+: create-vocab-with-root ( vocab-link -- vocab )
-    dup vocab-source-loaded? [ 2dup load-source ] unless
+    dup vocab-name create-vocab
-    dup vocab-docs-loaded? [ 2dup load-docs ] unless
+    swap vocab-root over set-vocab-root ;
-    nip vocab ;
-
-: load-vocab-from-root ( root name -- )
-    2dup vocab-source path+ ?resource-path exists? [
-        2dup create-vocab set-vocab-root
-        2dup load-source load-docs
-    ] [
-        nip no-vocab
-    ] if ;
 
 : reload ( name -- )
     [
-        dup find-vocab-root dup [
+        f >vocab-link
-            swap load-vocab-from-root
+        dup vocab-root [
-        ] [
+            dup vocab-source-path resource-exists? [
-            drop no-vocab
+                create-vocab-with-root
-        ] if
+                dup load-source
+                load-docs
+            ] [ no-vocab ] if
+        ] [ no-vocab ] if
     ] with-compiler-errors ;
 
 : require ( vocab -- )
@@ -122,18 +130,6 @@ SYMBOL: load-help?
     [ nip ] assoc-subset
     [ nip source-modified? ] assoc-subset keys ; inline
 
-: vocab-path+ ( vocab path -- newpath )
-    swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
-
-: vocab-source-path ( vocab -- path/f )
-    dup vocab-source vocab-path+ ;
-
-: vocab-tests-path ( vocab -- path/f )
-    dup vocab-tests vocab-path+ ;
-
-: vocab-docs-path ( vocab -- path/f )
-    dup vocab-docs vocab-path+ ;
-
 : modified-sources ( vocabs -- seq )
     [ vocab-source-path ] modified ;
 
@@ -151,7 +147,7 @@ SYMBOL: load-help?
 : vocab-heading. ( vocab -- )
     nl
     "==== " write
-    dup vocab-name swap f >vocab-link write-object ":" print
+    dup vocab-name swap vocab write-object ":" print
     nl ;
 
 : load-error. ( triple -- )
@@ -187,8 +183,10 @@ SYMBOL: load-help?
 GENERIC: (load-vocab) ( name -- vocab )
 
 M: vocab (load-vocab)
-    dup vocab-root
+    dup vocab-root [
-    [ swap vocab-name amend-vocab-from-root ] when* ;
+        dup vocab-source-loaded? [ dup load-source ] unless
+        dup vocab-docs-loaded? [ dup load-docs ] unless
+    ] when ;
 
 M: string (load-vocab)
     [ ".private" ?tail drop reload ] keep vocab ;

core/vocabs/vocabs.factor

@@ -96,8 +96,16 @@ M: vocab-link hashcode*
 
 M: vocab-link vocab-name vocab-link-name ;
 
-: >vocab-link ( name root -- vocab )
+GENERIC# >vocab-link 1 ( name root -- vocab )
-    over vocab dup [ 2nip ] [ drop <vocab-link> ] if ;
+
+M: vocab >vocab-link drop ;
+
+M: vocab-link >vocab-link drop ;
+
+M: string >vocab-link
+    over vocab dup [ 2nip ] [
+        drop [ dup vocab-root ] unless* <vocab-link>
+    ] if ;
 
 UNION: vocab-spec vocab vocab-link ;
 

extra/furnace/furnace.factor

@@ -189,7 +189,7 @@ SYMBOL: model
     swap [ render-template ] with-slots ;
 
 : browse-webapp-source ( vocab -- )
-    <a f >vocab-link browser-link-href =href a>
+    <a vocab browser-link-href =href a>
         "Browse source" write
     </a> ;
 

extra/tools/browser/browser.factor

@@ -72,13 +72,6 @@ M: vocab-link summary vocab-summary ;
 : set-vocab-authors ( authors vocab -- )
     dup vocab-authors-path set-vocab-file-contents ;
 
-: vocab-dir? ( root name -- ? )
-    over [
-        vocab-source path+ ?resource-path exists?
-    ] [
-        2drop f
-    ] if ;
-
 : subdirs ( dir -- dirs )
     directory [ second ] subset keys natural-sort ;
 
@@ -96,10 +89,8 @@ M: vocab-link summary vocab-summary ;
         vocabs-in-dir
     ] with each ;
 
-: sane-vocab-roots "." vocab-roots get remove ;
-
 : all-vocabs ( -- assoc )
-    sane-vocab-roots [
+    vocab-roots get [
         dup [ "" vocabs-in-dir ] { } make
     ] { } map>assoc ;
 
@@ -153,9 +144,9 @@ MEMO: all-vocabs-seq ( -- seq )
     [ vocab ] map ;
 
 : all-child-vocabs ( prefix -- assoc )
-    sane-vocab-roots [
+    vocab-roots get [
-        dup pick dupd (all-child-vocabs)
+        over dupd dupd (all-child-vocabs)
-        [ swap >vocab-link ] with map
+        swap [ >vocab-link ] curry map
     ] { } map>assoc
     f rot unrooted-child-vocabs 2array add ;
 

extra/tools/test/test-docs.factor

@@ -36,7 +36,12 @@ ARTICLE: "tools.test" "Unit testing"
 $nl
 "For example, if you were developing a word for computing symbolic derivatives, your unit tests would apply the word to certain input functions, comparing the results against the correct values. While the passing of these tests would not guarantee the algorithm is correct, it would at least ensure that what used to work keeps working, in that as soon as something breaks due to a change in another part of your program, failing tests will let you know."
 $nl
-"Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } "-tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details."
+"Unit tests for a vocabulary are placed in test files in the same directory as the vocabulary source file (see " { $link "vocabs.loader" } "). Two possibilities are supported:"
+{ $list
+    { "Tests can be placed in a file named " { $snippet { $emphasis "vocab" } "-tests.factor" } "." }
+    { "Tests can be placed in files in the " { $snippet "test" } " subdirectory." }
+}
+"The latter is used for vocabularies with more extensive test suites."
 $nl
 "If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run."
 { $subsection "tools.test.write" }

extra/tools/test/test.factor

@@ -53,18 +53,12 @@ SYMBOL: this-test
 
 : (run-test) ( vocab -- )
     dup vocab-source-loaded? [
-        vocab-tests-path dup [
+        [ "temporary" forget-vocab ] with-compilation-unit
-            dup ?resource-path exists? [
+        vocab-tests dup [ run-file ] each
-                [
+        [
-                    "temporary" forget-vocab
+            dup [ forget-source ] each
-                ] with-compilation-unit
+            "temporary" forget-vocab
-                dup run-file
+        ] with-compilation-unit
-                [
-                    dup forget-source
-                    "temporary" forget-vocab
-                ] with-compilation-unit
-            ] when
-        ] when
     ] when drop ;
 
 : run-test ( vocab -- failures )