From f68cc94ee409fe8825e841a2c9a5c7be188c5f8c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Aug 2004 07:12:55 +0000 Subject: [PATCH] working on the test suite --- TODO.FACTOR.txt | 1 + build.sh | 2 - doc/devel-guide.lyx | 2 +- library/cross-compiler.factor | 1 + library/platform/jvm/boot-sumo.factor | 1 + library/platform/jvm/unparser.factor | 8 + library/platform/native/boot.factor | 1 + library/platform/native/parse-syntax.factor | 16 +- library/platform/native/parser.factor | 2 +- library/platform/native/unparser.factor | 18 +- library/strings.factor | 2 + library/test/combinators.factor | 14 +- library/test/continuations.factor | 6 +- library/test/format.factor | 18 +- library/test/hashtables.factor | 29 +-- library/test/html.factor | 30 +-- library/test/list.factor | 207 ------------------ library/test/lists/all.factor | 10 + library/test/lists/assoc.factor | 27 +++ library/test/lists/cons.factor | 28 +++ library/test/lists/destructive.factor | 34 +++ library/test/lists/java.factor | 48 ++++ library/test/lists/lists.factor | 77 +++++++ library/test/lists/namespaces.factor | 10 + library/test/namespaces/all.factor | 6 + .../java.factor} | 57 +---- library/test/namespaces/namespaces.factor | 45 ++++ library/test/prettyprint.factor | 7 - library/test/reader.factor | 39 +--- library/test/string.factor | 34 --- library/test/test.factor | 42 ++-- native/factor.h | 2 + native/misc.c | 31 +++ native/misc.h | 4 + native/primitives.c | 10 +- native/primitives.h | 2 +- native/run.c | 15 -- native/string.c | 40 +++- 38 files changed, 464 insertions(+), 462 deletions(-) delete mode 100644 library/test/list.factor create mode 100644 library/test/lists/all.factor create mode 100644 library/test/lists/assoc.factor create mode 100644 library/test/lists/cons.factor create mode 100644 library/test/lists/destructive.factor create mode 100644 library/test/lists/java.factor create mode 100644 library/test/lists/lists.factor create mode 100644 library/test/lists/namespaces.factor create mode 100644 library/test/namespaces/all.factor rename library/test/{namespaces.factor => namespaces/java.factor} (53%) create mode 100644 library/test/namespaces/namespaces.factor delete mode 100644 library/test/string.factor create mode 100644 native/misc.c create mode 100644 native/misc.h diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 1f3aae6750..be8dfb1379 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -2,6 +2,7 @@ ERROR: I/O error: [ "primitive_read_line_fd_8" "Resource temporarily unavailable" ] +- prettyprinter: space after #<>, space after ~<< foo - bignum= - fixup-words is crusty - decide if overflow is a fatal error diff --git a/build.sh b/build.sh index 335db6cef2..056f96997c 100644 --- a/build.sh +++ b/build.sh @@ -1,5 +1,3 @@ -rm *.o - export CC=gcc34 export CFLAGS="-pedantic -Wall -Winline -Os -march=pentium4 -fomit-frame-pointer" diff --git a/doc/devel-guide.lyx b/doc/devel-guide.lyx index b6d9eed6d6..1ccc2b7db0 100644 --- a/doc/devel-guide.lyx +++ b/doc/devel-guide.lyx @@ -333,7 +333,7 @@ For example, lets assume we are designing some software for an aircraft : hours 60 * 60 * ; \layout LyX-Code -2 km . +2 kilometers . \layout LyX-Code diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor index e5ec964a48..04c9849b01 100644 --- a/library/cross-compiler.factor +++ b/library/cross-compiler.factor @@ -162,6 +162,7 @@ IN: cross-compiler shutdown-fd room os-env + millis ] [ swap succ tuck primitive, ] each drop ; diff --git a/library/platform/jvm/boot-sumo.factor b/library/platform/jvm/boot-sumo.factor index 8628bc8654..944f391601 100644 --- a/library/platform/jvm/boot-sumo.factor +++ b/library/platform/jvm/boot-sumo.factor @@ -95,6 +95,7 @@ USE: parser "/library/debugger.factor" run-resource ! debugger "/library/platform/jvm/listener.factor" run-resource ! listener "/library/test/test.factor" run-resource ! test +"/library/platform/jvm/test.factor" run-resource ! test "/library/ansi.factor" run-resource ! ansi "/library/telnetd.factor" run-resource ! telnetd diff --git a/library/platform/jvm/unparser.factor b/library/platform/jvm/unparser.factor index 54c3313440..2d8d055183 100644 --- a/library/platform/jvm/unparser.factor +++ b/library/platform/jvm/unparser.factor @@ -38,6 +38,14 @@ USE: strings [ "int" "int" ] "java.lang.Integer" "toString" jinvoke-static ; +: >bin ( num -- string ) + #! Convert a number to its binary representation. + 2 >base ; + +: >oct ( num -- string ) + #! Convert a number to its octal representation. + 8 >base ; + : >hex ( num -- string ) #! Convert a number to its hexadecimal representation. 16 >base ; diff --git a/library/platform/native/boot.factor b/library/platform/native/boot.factor index ce6de3d482..bce37d9b79 100644 --- a/library/platform/native/boot.factor +++ b/library/platform/native/boot.factor @@ -79,6 +79,7 @@ primitives, "/library/words.factor" "/library/math/math-combinators.factor" "/library/math/namespace-math.factor" + "/library/test/test.factor" "/library/platform/native/arithmetic.factor" "/library/platform/native/errors.factor" "/library/platform/native/io-internals.factor" diff --git a/library/platform/native/parse-syntax.factor b/library/platform/native/parse-syntax.factor index d3fabad47c..c5898cbc84 100644 --- a/library/platform/native/parse-syntax.factor +++ b/library/platform/native/parse-syntax.factor @@ -84,7 +84,14 @@ USE: unparser : IN: scan dup "use" cons@ "in" set ; parsing ! \x -: escape ( ch -- esc ) +: unicode-escape ( -- esc ) + #! Read \u.... + next-ch digit> 16 * + next-ch digit> + 16 * + next-ch digit> + 16 * + next-ch digit> + ; + +: ascii-escape ( ch -- esc ) [ [ CHAR: e | CHAR: \e ] [ CHAR: n | CHAR: \n ] @@ -97,6 +104,13 @@ USE: unparser [ CHAR: \" | CHAR: \" ] ] assoc ; +: escape ( ch -- esc ) + dup CHAR: u = [ + drop unicode-escape + ] [ + ascii-escape + ] ifte ; + ! String literal : parse-escape ( -- ) diff --git a/library/platform/native/parser.factor b/library/platform/native/parser.factor index f65321b93d..11f9e34a22 100644 --- a/library/platform/native/parser.factor +++ b/library/platform/native/parser.factor @@ -102,7 +102,7 @@ USE: unparser : parsed| ( obj -- ) #! Some ugly ugly code to handle [ a | b ] expressions. - >r dup nreverse last* r> swap set-cdr swons ; + >r nreverse dup last* r> swap set-cdr swons ; : expect-] ( -- ) scan "]" = not [ "Expected ]" throw ] when ; diff --git a/library/platform/native/unparser.factor b/library/platform/native/unparser.factor index 466ab165ad..5c28f2739f 100644 --- a/library/platform/native/unparser.factor +++ b/library/platform/native/unparser.factor @@ -52,8 +52,24 @@ USE: vocabularies : unparse-integer ( num -- str ) <% integer- integer% %> ; +: >base ( num radix -- string ) + #! Convert a number to a string in a certain base. + [ "base" set unparse-integer ] bind ; + +: >bin ( num -- string ) + #! Convert a number to its binary representation. + 2 >base ; + +: >oct ( num -- string ) + #! Convert a number to its octal representation. + 8 >base ; + +: >hex ( num -- string ) + #! Convert a number to its hexadecimal representation. + 16 >base ; + : unparse-str ( str -- str ) - #! Not done + #! Escapes not done <% CHAR: " % % CHAR: " % %> ; : unparse-word ( word -- str ) diff --git a/library/strings.factor b/library/strings.factor index 8a7b8ccfcf..b3ba392697 100644 --- a/library/strings.factor +++ b/library/strings.factor @@ -122,6 +122,8 @@ USE: stack ] ifte ; : split ( string split -- list ) + #! Split the string at each occurrence of split, and push a + #! list of the pieces. 2dup index-of dup -1 = [ 2drop dup str-length 0 = [ drop f diff --git a/library/test/combinators.factor b/library/test/combinators.factor index eb854c3445..535467d16f 100644 --- a/library/test/combinators.factor +++ b/library/test/combinators.factor @@ -1,18 +1,8 @@ IN: scratchpad -USE: arithmetic USE: combinators USE: kernel -USE: lists USE: stack -USE: stdio USE: test -USE: words -! Tests the combinators. - -"Checking combinators." print - -[ ] [ 3 ] [ [ ] cond ] test-word -[ t ] [ 4 ] [ [ [ 1 = ] [ ] [ 4 = ] [ drop t ] [ 2 = ] [ ] ] cond ] test-word - -[ [ 1 2 3 ] ] [ [ 1 4 2 5 3 6 ] [ 4 < ] ] [ subset ] test-word +[ ] [ 3 [ ] cond ] unit-test +[ t ] [ 4 [ [ 1 = ] [ ] [ 4 = ] [ drop t ] [ 2 = ] [ ] ] cond ] unit-test diff --git a/library/test/continuations.factor b/library/test/continuations.factor index d3c4697b2a..5e23b01556 100644 --- a/library/test/continuations.factor +++ b/library/test/continuations.factor @@ -9,8 +9,6 @@ USE: stack USE: stdio USE: test -"Checking continuations." print - : callcc1-test ( x -- list ) [ "test-cc" set [ ] [ @@ -28,5 +26,5 @@ USE: test ] bind ] callcc0 "x" get 5 = ; -[ t ] [ ] [ 10 callcc1-test 10 count = ] test-word -[ t ] [ ] [ callcc-namespace-test ] test-word +[ t ] [ 10 callcc1-test 10 count = ] unit-test +[ t ] [ callcc-namespace-test ] unit-test diff --git a/library/test/format.factor b/library/test/format.factor index ad267189ba..b54eadf211 100644 --- a/library/test/format.factor +++ b/library/test/format.factor @@ -1,16 +1,10 @@ IN: scratchpad -USE: compiler USE: format -USE: namespaces -USE: stdio USE: test -"Testing formatting words." print - -[ [ 2 1 0 0 ] ] [ [ decimal-places ] ] [ balance>list ] test-word -[ "123" ] [ "123" ] [ 2 decimal-places ] test-word -[ "123.12" ] [ "123.12" ] [ 2 decimal-places ] test-word -[ "123.123" ] [ "123.123" ] [ 5 decimal-places ] test-word -[ "123" ] [ "123.123" ] [ 0 decimal-places ] test-word - -"Formatting tests done." print +[ "123" ] [ "123" 2 decimal-places ] unit-test +[ "123.12" ] [ "123.12" 2 decimal-places ] unit-test +[ "123.123" ] [ "123.123" 5 decimal-places ] unit-test +[ "123" ] [ "123.123" 0 decimal-places ] unit-test +[ "05" ] [ "5" 2 digits ] unit-test +[ "666" ] [ "666" 2 digits ] unit-test diff --git a/library/test/hashtables.factor b/library/test/hashtables.factor index 295688cc0b..d1ea6fe5a1 100644 --- a/library/test/hashtables.factor +++ b/library/test/hashtables.factor @@ -1,41 +1,28 @@ IN: scratchpad USE: arithmetic -USE: combinators -USE: compiler USE: hashtables USE: kernel USE: lists USE: logic USE: namespaces USE: stack -USE: stdio -USE: strings USE: test - -"Checking hashtables" print +USE: vectors 16 "testhash" set -: silly-key/value dup sq swap ; +: silly-key/value dup dup * swap ; 1000 [ silly-key/value "testhash" get set-hash ] times* [ f ] -[ 1000 count ] -[ [ silly-key/value "testhash" get hash = not ] subset ] -test-word +[ 1000 count [ silly-key/value "testhash" get hash = not ] subset ] +unit-test [ t ] -[ "testhash" get ] -[ hashtable? ] -test-word - -[ f ] -[ [ 1 2 | 3 ] ] -[ hashtable? ] -test-word +[ "testhash" get hashtable? ] +unit-test [ f ] -[ namestack* ] -[ hashtable? ] -test-word +[ [ 1 2 | 3 ] hashtable? ] +unit-test diff --git a/library/test/html.factor b/library/test/html.factor index dcafde5cac..d2227bfffd 100644 --- a/library/test/html.factor +++ b/library/test/html.factor @@ -1,5 +1,4 @@ IN: scratchpad -USE: compiler USE: html USE: namespaces USE: stdio @@ -7,25 +6,30 @@ USE: streams USE: strings USE: test -[ [ 1 1 0 0 ] ] [ [ chars>entities ] ] [ balance>list ] test-word [ "<html>&'sgml'" -] [ "&'sgml'" ] [ chars>entities ] test-word - -[ [ 1 1 0 0 ] ] [ [ html-attr-string ] ] [ balance>list ] test-word +] [ "&'sgml'" chars>entities ] unit-test [ "Hello world" ] -[ "Hello world" ] -[ [ html-attr-string ] bind ] test-word +[ + "Hello world" [ html-attr-string ] bind +] unit-test [ "Hello world" ] -[ "Hello world" [ t "bold" set ] extend ] -[ [ html-attr-string ] bind ] test-word +[ + "Hello world" + [ t "bold" set ] extend + [ html-attr-string ] bind +] unit-test [ "Hello world" ] -[ "Hello world" [ t "italics" set ] extend ] -[ [ html-attr-string ] bind ] test-word +[ + "Hello world" [ t "italics" set ] extend + [ html-attr-string ] bind +] unit-test [ "Hello world" ] -[ "Hello world" [ [ 255 0 255 ] "fg" set ] extend ] -[ [ html-attr-string ] bind ] test-word +[ + "Hello world" [ [ 255 0 255 ] "fg" set ] extend + [ html-attr-string ] bind +] unit-test diff --git a/library/test/list.factor b/library/test/list.factor deleted file mode 100644 index c5e306fe58..0000000000 --- a/library/test/list.factor +++ /dev/null @@ -1,207 +0,0 @@ -IN: scratchpad -USE: arithmetic -USE: combinators -USE: compiler -USE: kernel -USE: lists -USE: logic -USE: namespaces -USE: stack -USE: stdio -USE: strings -USE: test - -"Checking list words." print - -! OUTPUT INPUT WORD -[ [ 2 1 0 0 ] ] [ [ 2list ] ] [ balance>list ] test-word -[ [ 1 2 ] ] [ 1 2 ] [ 2list ] test-word -[ [ 3 1 0 0 ] ] [ [ 3list ] ] [ balance>list ] test-word -[ [ 1 2 3 ] ] [ 1 2 3 ] [ 3list ] test-word -[ [ 2 1 0 0 ] ] [ [ 2rlist ] ] [ balance>list ] test-word -[ [ 2 1 ] ] [ 1 2 ] [ 2rlist ] test-word - -[ [ 2 1 0 0 ] ] [ [ append ] ] [ balance>list ] test-word -[ [ ] ] [ [ ] [ ] ] [ append ] test-word -[ [ 1 ] ] [ [ 1 ] [ ] ] [ append ] test-word -[ [ 2 ] ] [ [ ] [ 2 ] ] [ append ] test-word -[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] ] [ append ] test-word - -[ [ 2 0 0 0 ] ] [ [ append@ ] ] [ balance>list ] test-word -[ [ 1 2 3 4 ] ] [ [ 3 4 ] [ 1 2 ] ] [ "x" set "x" append@ "x" get ] test-word - -[ [ 1 1 0 0 ] ] [ [ array>list ] ] [ balance>list ] test-word -[ [ ] ] [ [ ] ] [ array>list ] test-word -[ [ 1 2 3 ] ] [ [ 1 2 3 ] ] [ array>list ] test-word - -[ [ 2 0 0 0 ] ] [ [ add@ ] ] [ balance>list ] test-word -[ [ 1 2 3 4 ] ] [ 4 [ 1 2 3 ] ] [ "x" set "x" add@ "x" get ] test-word - -[ [ 1 1 0 0 ] ] [ [ car ] ] [ balance>list ] test-word -[ 1 ] [ [ 1 | 2 ] ] [ car ] test-word -[ [ 1 1 0 0 ] ] [ [ cdr ] ] [ balance>list ] test-word -[ 2 ] [ [ 1 | 2 ] ] [ cdr ] test-word - -[ [ 1 1 0 0 ] ] [ [ clone-list ] ] [ balance>list ] test-word -[ [ ] ] [ [ ] ] [ clone-list ] test-word -[ [ 1 2 | 3 ] ] [ [ 1 2 | 3 ] ] [ clone-list ] test-word -[ [ 1 2 3 4 ] ] [ [ 1 2 3 4 ] ] [ clone-list ] test-word - -: clone-list-actually-clones? ( list1 list2 -- ) - [ clone-list ] dip ! we don't want to mutate literals - [ dup clone-list ] dip nappend = not ; - -[ t ] [ [ 1 2 ] [ 3 4 ] ] [ clone-list-actually-clones? ] test-word - -[ [ 2 1 0 0 ] ] [ [ cons ] ] [ balance>list ] test-word -[ [ 1 | 2 ] ] [ 1 2 ] [ cons ] test-word -[ [ 1 ] ] [ 1 f ] [ cons ] test-word - -[ [ 2 1 0 0 ] ] [ [ contains ] ] [ balance>list ] test-word -[ f ] [ 3 [ ] ] [ contains ] test-word -[ f ] [ 3 [ 1 2 ] ] [ contains ] test-word -[ [ 1 2 ] ] [ 1 [ 1 2 ] ] [ contains ] test-word -[ [ 2 ] ] [ 2 [ 1 2 ] ] [ contains ] test-word -[ [ 2 | 3 ] ] [ 3 [ 1 2 | 3 ] ] [ contains ] do-not-test-word - -[ [ 2 0 0 0 ] ] [ [ cons@ ] ] [ balance>list ] test-word -[ [ 1 ] ] [ 1 f ] [ "x" set "x" cons@ "x" get ] test-word -[ [ 1 | 2 ] ] [ 1 2 ] [ "x" set "x" cons@ "x" get ] test-word -[ [ 1 2 ] ] [ 1 [ 2 ] ] [ "x" set "x" cons@ "x" get ] test-word - -[ [ 1 1 0 0 ] ] [ [ count ] ] [ balance>list ] do-not-test-word -[ [ ] ] [ 0 ] [ count ] test-word -[ [ ] ] [ -10 ] [ count ] test-word -[ [ ] ] [ -inf ] [ count ] test-word -[ [ 0 1 2 3 ] ] [ 4 ] [ count ] test-word - -[ [ 2 1 0 0 ] ] [ [ nth ] ] [ balance>list ] test-word -[ 1 ] [ -1 [ 1 2 ] ] [ nth ] test-word -[ 1 ] [ 0 [ 1 2 ] ] [ nth ] test-word -[ 2 ] [ 1 [ 1 2 ] ] [ nth ] test-word - -[ [ 1 1 0 0 ] ] [ [ last* ] ] [ balance>list ] test-word -[ [ 3 ] ] [ [ 3 ] ] [ last* ] test-word -[ [ 3 ] ] [ [ 1 2 3 ] ] [ last* ] test-word -[ [ 3 | 4 ] ] [ [ 1 2 3 | 4 ] ] [ last* ] test-word - -[ [ 1 1 0 0 ] ] [ [ last ] ] [ balance>list ] test-word -[ 3 ] [ [ 3 ] ] [ last ] test-word -[ 3 ] [ [ 1 2 3 ] ] [ last ] test-word -[ 3 ] [ [ 1 2 3 | 4 ] ] [ last ] test-word - -[ [ 1 1 0 0 ] ] [ [ length ] ] [ balance>list ] test-word -[ 0 ] [ [ ] ] [ length ] test-word -[ 3 ] [ [ 1 2 3 ] ] [ length ] test-word - -! CMU CL bombs on (length '(1 2 3 . 4)) -![ 3 ] [ [ 1 2 3 | 4 ] ] [ length ] test-word - -[ [ 1 1 0 0 ] ] [ [ list? ] ] [ balance>list ] test-word -[ t ] [ f ] [ list? ] test-word -[ f ] [ t ] [ list? ] test-word -[ t ] [ [ 1 2 ] ] [ list? ] test-word -[ f ] [ [ 1 | 2 ] ] [ list? ] test-word - -: clone-and-nappend ( list list -- list ) - [ clone-list ] 2apply nappend ; - -[ [ ] ] [ [ ] [ ] ] [ clone-and-nappend ] test-word -[ [ 1 ] ] [ [ 1 ] [ ] ] [ clone-and-nappend ] test-word -[ [ 2 ] ] [ [ ] [ 2 ] ] [ clone-and-nappend ] test-word -[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] ] [ clone-and-nappend ] test-word - -: clone-and-nreverse ( list -- list ) - clone-list nreverse ; - -[ [ 1 1 0 0 ] ] [ [ nreverse ] ] [ balance>list ] test-word -[ [ ] ] [ [ ] ] [ clone-and-nreverse ] test-word -[ [ 1 ] ] [ [ 1 ] ] [ clone-and-nreverse ] test-word -[ [ 3 2 1 ] ] [ [ 1 2 3 ] ] [ clone-and-nreverse ] test-word - -[ 1 2 3 ] clone-list "x" set [ 4 5 6 ] clone-list "y" set - -[ [ 2 1 0 0 ] ] [ [ nappend ] ] [ balance>list ] test-word -[ [ 4 5 6 ] ] [ "x" get "y" get ] [ nappend drop "y" get ] test-word - -[ 1 2 3 ] clone-list "x" set [ 4 5 6 ] clone-list "y" set - -[ [ 1 2 3 4 5 6 ] ] [ "x" get "y" get ] [ nappend drop "x" get ] test-word - -[ 2 ] [ 1 [ 1 2 3 ] ] [ next ] test-word -[ 1 ] [ 3 [ 1 2 3 ] ] [ next ] test-word -[ 1 ] [ 4 [ 1 2 3 ] ] [ next ] test-word - -[ [ 1 1 0 0 ] ] [ [ cons? ] ] [ balance>list ] test-word -[ f ] [ f ] [ cons? ] test-word -[ f ] [ t ] [ cons? ] test-word -[ t ] [ [ t | f ] ] [ cons? ] test-word - -[ [ 2 1 0 0 ] ] [ [ remove ] ] [ balance>list ] test-word -[ [ ] ] [ 1 [ ] ] [ remove ] test-word -[ [ ] ] [ 1 [ 1 ] ] [ remove ] test-word -[ [ 3 1 1 ] ] [ 2 [ 3 2 1 2 1 ] ] [ remove ] test-word - -[ [ 1 1 0 0 ] ] [ [ reverse ] ] [ balance>list ] test-word -[ [ ] ] [ [ ] ] [ reverse ] test-word -[ [ 1 ] ] [ [ 1 ] ] [ reverse ] test-word -[ [ 3 2 1 ] ] [ [ 1 2 3 ] ] [ reverse ] test-word - -[ [ 2 0 0 0 ] ] [ [ set-car ] ] [ balance>list ] test-word -[ "a" | "b" ] clone-list "x" set -[ [ 1 | "b" ] ] [ 1 "x" get ] [ set-car "x" get ] test-word - -[ [ 2 0 0 0 ] ] [ [ set-cdr ] ] [ balance>list ] test-word -[ "a" | "b" ] clone-list "x" set -[ [ "a" | 2 ] ] [ 2 "x" get ] [ set-cdr "x" get ] test-word - -[ [ 2 2 0 0 ] ] [ [ [ < ] partition ] ] [ balance>list ] test-word -[ [ -5 3 1 ] [ -2 4 4 -2 ] ] -[ 2 [ 1 -2 3 4 -5 4 -2 ] ] -[ [ swap / ratio? ] partition ] test-word - -[ [ 2 2 0 0 ] ] [ [ [ nip string? ] partition ] ] [ balance>list ] test-word -[ [ "d" "c" ] [ 2 1 ] ] -[ f [ 1 2 "c" "d" ] ] -[ [ nip string? ] partition ] test-word - -[ [ 1 1 0 0 ] ] [ [ num-sort ] ] [ balance>list ] test-word -[ [ 1 1 0 0 ] ] [ [ str-sort ] ] [ balance>list ] test-word - -[ [ 2 1 0 0 ] ] [ [ swons ] ] [ balance>list ] test-word -[ [ 1 | 2 ] ] [ 2 1 ] [ swons ] test-word -[ [ 1 ] ] [ f 1 ] [ swons ] test-word - -[ [ 2 1 0 0 ] ] [ [ tree-contains? ] ] [ balance>list ] test-word -[ f ] [ 3 [ ] ] [ tree-contains? ] test-word -[ f ] [ 3 [ 1 [ 3 ] 2 ] ] [ tree-contains? not ] test-word -[ f ] [ 1 [ [ [ 1 ] ] 2 ] ] [ tree-contains? not ] test-word -[ f ] [ 2 [ 1 2 ] ] [ tree-contains? not ] test-word -[ f ] [ 3 [ 1 2 | 3 ] ] [ tree-contains? not ] test-word - -[ [ 1 2 0 0 ] ] [ [ uncons ] ] [ balance>list ] test-word -[ 1 2 ] [ [ 1 | 2 ] ] [ uncons ] test-word -[ 1 [ 2 ] ] [ [ 1 2 ] ] [ uncons ] test-word - -[ [ 2 1 0 0 ] ] [ [ unique ] ] [ balance>list ] test-word -[ [ 1 2 3 ] ] [ 1 [ 2 3 ] ] [ unique ] test-word -[ [ 1 2 3 ] ] [ 1 [ 1 2 3 ] ] [ unique ] test-word -[ [ 1 2 3 ] ] [ 2 [ 1 2 3 ] ] [ unique ] test-word - -[ [ 1 1 0 0 ] ] [ [ unit ] ] [ balance>list ] test-word -[ [ [ [ ] ] ] ] [ [ ] ] [ unit unit ] test-word - -[ [ 1 2 0 0 ] ] [ [ unswons ] ] [ balance>list ] test-word -[ 1 2 ] [ [ 2 | 1 ] ] [ unswons ] test-word -[ [ 2 ] 1 ] [ [ 1 2 ] ] [ unswons ] test-word - - -[ [ 1 1 0 0 ] ] [ [ deep-clone ] ] [ balance>list ] test-word - -: deep-clone-test ( x -- x y ) - dup deep-clone dup car 5 swap set-car ; - -[ [ [ 1 | 2 ] ] [ [ 5 | 2 ] ] ] [ [ [ 1 | 2 ] ] ] -[ deep-clone-test ] test-word - -"List checks passed." print diff --git a/library/test/lists/all.factor b/library/test/lists/all.factor new file mode 100644 index 0000000000..f0a6dee813 --- /dev/null +++ b/library/test/lists/all.factor @@ -0,0 +1,10 @@ +USE: combinators +USE: kernel +USE: test + +"lists/cons" test +"lists/lists" test +"lists/assoc" test +"lists/destructive" test +"lists/namespaces" test +java? [ "lists/java" test ] when diff --git a/library/test/lists/assoc.factor b/library/test/lists/assoc.factor new file mode 100644 index 0000000000..68f87f23f9 --- /dev/null +++ b/library/test/lists/assoc.factor @@ -0,0 +1,27 @@ +IN: scratchpad +USE: lists +USE: namespaces +USE: test + +[ + [ "monkey" | 1 ] + [ "banana" | 2 ] + [ "Java" | 3 ] + [ t | "true" ] + [ f | "false" ] + [ [ 1 2 ] | [ 2 1 ] ] +] "assoc" set + +[ t ] [ "assoc" get assoc? ] unit-test +[ f ] [ [ 1 2 3 | 4 ] assoc? ] unit-test +[ f ] [ "assoc" assoc? ] unit-test + +[ f ] [ "monkey" f assoc ] unit-test +[ f ] [ "donkey" "assoc" get assoc ] unit-test +[ 1 ] [ "monkey" "assoc" get assoc ] unit-test +[ "false" ] [ f "assoc" get assoc ] unit-test +[ [ 2 1 ] ] [ [ 1 2 ] "assoc" get assoc ] unit-test + +"is great" "Java" "assoc" get set-assoc "assoc" set + +[ "is great" ] [ "Java" "assoc" get assoc ] unit-test diff --git a/library/test/lists/cons.factor b/library/test/lists/cons.factor new file mode 100644 index 0000000000..1249bac4b1 --- /dev/null +++ b/library/test/lists/cons.factor @@ -0,0 +1,28 @@ +IN: scratchpad +USE: lists +USE: test + +[ f ] [ f cons? ] unit-test +[ f ] [ t cons? ] unit-test +[ t ] [ [ t | f ] cons? ] unit-test + +[ [ 1 | 2 ] ] [ 1 2 cons ] unit-test +[ [ 1 ] ] [ 1 f cons ] unit-test + +[ [ 1 | 2 ] ] [ 2 1 swons ] unit-test +[ [ 1 ] ] [ f 1 swons ] unit-test + +[ [ [ [ ] ] ] ] [ [ ] unit unit ] unit-test + +[ 1 ] [ [ 1 | 2 ] car ] unit-test +[ 2 ] [ [ 1 | 2 ] cdr ] unit-test + +[ 1 2 ] [ [ 1 | 2 ] uncons ] unit-test +[ 1 [ 2 ] ] [ [ 1 2 ] uncons ] unit-test + +[ 1 2 ] [ [ 2 | 1 ] unswons ] unit-test +[ [ 2 ] 1 ] [ [ 1 2 ] unswons ] unit-test + +[ [ 1 2 ] ] [ 1 2 2list ] unit-test +[ [ 1 2 3 ] ] [ 1 2 3 3list ] unit-test +[ [ 2 1 ] ] [ 1 2 2rlist ] unit-test diff --git a/library/test/lists/destructive.factor b/library/test/lists/destructive.factor new file mode 100644 index 0000000000..6dc8bd84bf --- /dev/null +++ b/library/test/lists/destructive.factor @@ -0,0 +1,34 @@ +IN: scratchpad +USE: lists +USE: namespaces +USE: stack +USE: test + +[ "a" | "b" ] clone-list "x" set +[ [ 1 | "b" ] ] [ 1 "x" get set-car "x" get ] unit-test + +[ "a" | "b" ] clone-list "x" set +[ [ "a" | 2 ] ] [ 2 "x" get set-cdr "x" get ] unit-test + +: clone-and-nappend ( list list -- list ) + swap clone-list swap clone-list nappend ; + +[ [ ] ] [ [ ] [ ] clone-and-nappend ] unit-test +[ [ 1 ] ] [ [ 1 ] [ ] clone-and-nappend ] unit-test +[ [ 2 ] ] [ [ ] [ 2 ] clone-and-nappend ] unit-test +[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] clone-and-nappend ] unit-test + +: clone-and-nreverse ( list -- list ) + clone-list nreverse ; + +[ [ ] ] [ [ ] clone-and-nreverse ] unit-test +[ [ 1 ] ] [ [ 1 ] clone-and-nreverse ] unit-test +[ [ 3 2 1 ] ] [ [ 1 2 3 ] clone-and-nreverse ] unit-test + +[ 1 2 3 ] clone-list "x" set [ 4 5 6 ] clone-list "y" set + +[ [ 4 5 6 ] ] [ "x" get "y" get nappend drop "y" get ] unit-test + +[ 1 2 3 ] clone-list "x" set [ 4 5 6 ] clone-list "y" set + +[ [ 1 2 3 4 5 6 ] ] [ "x" get "y" get ] [ nappend drop "x" get ] test-word diff --git a/library/test/lists/java.factor b/library/test/lists/java.factor new file mode 100644 index 0000000000..295fde8781 --- /dev/null +++ b/library/test/lists/java.factor @@ -0,0 +1,48 @@ +USE: arithmetic +USE: compiler +USE: lists +USE: stack +USE: strings +USE: test + +[ [ 2 1 0 0 ] ] [ [ 2list ] ] [ balance>list ] test-word +[ [ 3 1 0 0 ] ] [ [ 3list ] ] [ balance>list ] test-word +[ [ 2 1 0 0 ] ] [ [ 2rlist ] ] [ balance>list ] test-word +[ [ 2 1 0 0 ] ] [ [ append ] ] [ balance>list ] test-word +[ [ 2 0 0 0 ] ] [ [ append@ ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ array>list ] ] [ balance>list ] test-word +[ [ 2 0 0 0 ] ] [ [ add@ ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ car ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ cdr ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ clone-list ] ] [ balance>list ] test-word +[ [ 2 1 0 0 ] ] [ [ cons ] ] [ balance>list ] test-word +[ [ 2 1 0 0 ] ] [ [ contains ] ] [ balance>list ] test-word +[ [ 2 0 0 0 ] ] [ [ cons@ ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ count ] ] [ balance>list ] do-not-test-word +[ [ 2 1 0 0 ] ] [ [ nth ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ last* ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ last ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ length ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ list? ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ nreverse ] ] [ balance>list ] test-word +[ [ 2 1 0 0 ] ] [ [ nappend ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ cons? ] ] [ balance>list ] test-word +[ [ 2 1 0 0 ] ] [ [ remove ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ reverse ] ] [ balance>list ] test-word +[ [ 2 0 0 0 ] ] [ [ set-car ] ] [ balance>list ] test-word +[ [ 2 0 0 0 ] ] [ [ set-cdr ] ] [ balance>list ] test-word +[ [ 2 2 0 0 ] ] [ [ [ < ] partition ] ] [ balance>list ] test-word +[ [ 2 2 0 0 ] ] [ [ [ nip string? ] partition ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ num-sort ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ str-sort ] ] [ balance>list ] test-word +[ [ 2 1 0 0 ] ] [ [ swons ] ] [ balance>list ] test-word +[ [ 2 1 0 0 ] ] [ [ tree-contains? ] ] [ balance>list ] test-word +[ [ 1 2 0 0 ] ] [ [ uncons ] ] [ balance>list ] test-word +[ [ 2 1 0 0 ] ] [ [ unique ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ unit ] ] [ balance>list ] test-word +[ [ 1 2 0 0 ] ] [ [ unswons ] ] [ balance>list ] test-word +[ [ 1 1 0 0 ] ] [ [ deep-clone ] ] [ balance>list ] test-word + +[ [ ] ] [ [ ] ] [ array>list ] test-word +[ [ 1 2 3 ] ] [ [ 1 2 3 ] ] [ array>list ] test-word + diff --git a/library/test/lists/lists.factor b/library/test/lists/lists.factor new file mode 100644 index 0000000000..127113e7d6 --- /dev/null +++ b/library/test/lists/lists.factor @@ -0,0 +1,77 @@ +IN: scratchpad +USE: arithmetic +USE: kernel +USE: lists +USE: logic +USE: namespaces +USE: stack +USE: test + +[ [ ] ] [ [ ] [ ] append ] unit-test +[ [ 1 ] ] [ [ 1 ] [ ] append ] unit-test +[ [ 2 ] ] [ [ ] [ 2 ] append ] unit-test +[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] append ] unit-test +[ [ 1 2 3 | 4 ] ] [ [ 1 2 3 ] 4 append ] unit-test + +[ [ ] ] [ [ ] clone-list ] unit-test +[ [ 1 2 | 3 ] ] [ [ 1 2 | 3 ] clone-list ] unit-test +[ [ 1 2 3 4 ] ] [ [ 1 2 3 4 ] clone-list ] unit-test + +: clone-list-actually-clones? ( list1 list2 -- ) + >r clone-list ! we don't want to mutate literals + dup clone-list r> nappend = not ; + +[ t ] [ [ 1 2 ] [ 3 4 ] clone-list-actually-clones? ] unit-test + +[ f ] [ 3 [ ] contains ] unit-test +[ f ] [ 3 [ 1 2 ] contains ] unit-test +[ [ 1 2 ] ] [ 1 [ 1 2 ] contains ] unit-test +[ [ 2 ] ] [ 2 [ 1 2 ] contains ] unit-test + +[ 1 ] [ -1 [ 1 2 ] nth ] unit-test +[ 1 ] [ 0 [ 1 2 ] nth ] unit-test +[ 2 ] [ 1 [ 1 2 ] nth ] unit-test + +[ [ 3 ] ] [ [ 3 ] last* ] unit-test +[ [ 3 ] ] [ [ 1 2 3 ] last* ] unit-test +[ [ 3 | 4 ] ] [ [ 1 2 3 | 4 ] last* ] unit-test + +[ 3 ] [ [ 3 ] last ] unit-test +[ 3 ] [ [ 1 2 3 ] last ] unit-test +[ 3 ] [ [ 1 2 3 | 4 ] last ] unit-test + +[ 0 ] [ [ ] length ] unit-test +[ 3 ] [ [ 1 2 3 ] length ] unit-test + +[ t ] [ f list? ] unit-test +[ f ] [ t list? ] unit-test +[ t ] [ [ 1 2 ] list? ] unit-test +[ f ] [ [ 1 | 2 ] list? ] unit-test + +[ 2 ] [ 1 [ 1 2 3 ] next ] unit-test +[ 1 ] [ 3 [ 1 2 3 ] next ] unit-test +[ 1 ] [ 4 [ 1 2 3 ] next ] unit-test + +[ [ ] ] [ 1 [ ] remove ] unit-test +[ [ ] ] [ 1 [ 1 ] remove ] unit-test +[ [ 3 1 1 ] ] [ 2 [ 3 2 1 2 1 ] remove ] unit-test + +[ [ ] ] [ [ ] reverse ] unit-test +[ [ 1 ] ] [ [ 1 ] reverse ] unit-test +[ [ 3 2 1 ] ] [ [ 1 2 3 ] reverse ] unit-test + +[ [ 1 2 3 ] ] [ 1 [ 2 3 ] unique ] unit-test +[ [ 1 2 3 ] ] [ 1 [ 1 2 3 ] unique ] unit-test +[ [ 1 2 3 ] ] [ 2 [ 1 2 3 ] unique ] unit-test + +[ f ] [ 3 [ ] tree-contains? ] unit-test +[ f ] [ 3 [ 1 [ 3 ] 2 ] tree-contains? not ] unit-test +[ f ] [ 1 [ [ [ 1 ] ] 2 ] tree-contains? not ] unit-test +[ f ] [ 2 [ 1 2 ] tree-contains? not ] unit-test +[ f ] [ 3 [ 1 2 | 3 ] tree-contains? not ] unit-test + +[ [ ] ] [ 0 count ] unit-test +[ [ ] ] [ -10 count ] unit-test +[ [ 0 1 2 3 ] ] [ 4 count ] unit-test + +[ [ 1 2 3 ] ] [ [ 1 4 2 5 3 6 ] [ 4 < ] subset ] unit-test diff --git a/library/test/lists/namespaces.factor b/library/test/lists/namespaces.factor new file mode 100644 index 0000000000..2a1e4bdcdc --- /dev/null +++ b/library/test/lists/namespaces.factor @@ -0,0 +1,10 @@ +IN: scratchpad +USE: lists +USE: namespaces +USE: test + +[ [ 1 2 3 4 ] ] [ [ 3 4 ] [ 1 2 ] ] [ "x" set "x" append@ "x" get ] test-word +[ [ 1 2 3 4 ] ] [ 4 [ 1 2 3 ] ] [ "x" set "x" add@ "x" get ] test-word +[ [ 1 ] ] [ 1 f ] [ "x" set "x" cons@ "x" get ] test-word +[ [ 1 | 2 ] ] [ 1 2 ] [ "x" set "x" cons@ "x" get ] test-word +[ [ 1 2 ] ] [ 1 [ 2 ] ] [ "x" set "x" cons@ "x" get ] test-word diff --git a/library/test/namespaces/all.factor b/library/test/namespaces/all.factor new file mode 100644 index 0000000000..bad3ac0068 --- /dev/null +++ b/library/test/namespaces/all.factor @@ -0,0 +1,6 @@ +USE: combinators +USE: kernel +USE: test + +"namespaces/namespaces" test +java? [ "namespaces/java" test ] when diff --git a/library/test/namespaces.factor b/library/test/namespaces/java.factor similarity index 53% rename from library/test/namespaces.factor rename to library/test/namespaces/java.factor index e0238bc25f..0a37e5a127 100644 --- a/library/test/namespaces.factor +++ b/library/test/namespaces/java.factor @@ -1,23 +1,13 @@ IN: scratchpad USE: arithmetic -USE: combinators USE: compiler -USE: inspector USE: kernel -USE: lists -USE: logic USE: namespaces -USE: random USE: stack -USE: stdio -USE: strings USE: test USE: words USE: vocabularies -"Namespace tests." print - -[ t ] [ global [ "global" get ] bind global ] [ = ] test-word [ [ 1 0 0 0 ] ] [ [ >n ] ] [ balance>list ] test-word [ [ 1 1 0 0 ] ] [ [ get ] ] [ balance>list ] test-word [ [ 2 0 0 0 ] ] [ [ set ] ] [ balance>list ] test-word @@ -27,24 +17,10 @@ USE: vocabularies [ [ 1 0 0 0 ] ] [ [ set-namestack ] ] [ balance>list ] test-word [ [ 0 1 0 0 ] ] [ [ n> ] ] [ balance>list ] test-word - "test-namespace" set - -: test-namespace ( -- ) - dup [ namespace = ] bind ; - -: test-this-1 ( -- ) - dup [ this = ] bind ; - : test-this-2 ( -- ) interpreter dup [ this = ] bind ; -[ t ] [ ] [ test-namespace ] test-word -[ t ] [ ] [ test-this-1 ] test-word -[ t ] [ ] [ test-this-2 ] test-word - -! These stress-test a lot of code. -global describe -"vocabularies" get describe +[ t ] [ test-this-2 ] unit-test : namespace-compile ( x -- x ) [ "x" set ] extend [ "x" get ] bind ; word must-compile @@ -62,36 +38,5 @@ global describe [ f ] [ ] [ 10 namespace-tail-call-bug "x" get 0 = ] test-word -! Object paths should not resolve further up in the namestack. - - "test-namespace" set -[ f ] -[ [ "test-namespace" "test-namespace" ] ] -[ object-path ] -test-word - -[ f ] -[ [ "alalal" "boobobo" "bah" ] ] -[ object-path ] -test-word - -[ t ] -[ this [ ] ] -[ object-path = ] -test-word - -[ t ] -[ "test-word" intern [ "global" "vocabularies" "test" "test-word" ] ] -[ object-path = ] -test-word - -10 "some-global" set -[ f ] -[ ] -[ [ f "some-global" set "some-global" get ] bind ] -test-word - ! I did a n> in extend and forgot the obvious case [ t ] [ "dup" intern dup ] [ [ ] extend = ] test-word - -"Namespace tests passed." print diff --git a/library/test/namespaces/namespaces.factor b/library/test/namespaces/namespaces.factor new file mode 100644 index 0000000000..e1c1ebf0fb --- /dev/null +++ b/library/test/namespaces/namespaces.factor @@ -0,0 +1,45 @@ +IN: scratchpad +USE: kernel +USE: namespaces +USE: test +USE: stack +USE: words +USE: vocabularies + + "test-namespace" set + +: test-namespace ( -- ) + dup [ namespace = ] bind ; + +: test-this-1 ( -- ) + dup [ this = ] bind ; + +[ t ] [ test-namespace ] unit-test +[ t ] [ test-this-1 ] unit-test + +! Object paths should not resolve further up in the namestack. + + "test-namespace" set +[ f ] +[ [ "test-namespace" "test-namespace" ] object-path ] +unit-test + +[ f ] +[ [ "alalal" "boobobo" "bah" ] object-path ] +unit-test + +[ t ] +[ this [ ] object-path = ] +unit-test + +[ t ] +[ + "test-word" intern + [ "vocabularies" "test" "test-word" ] object-path + = +] unit-test + +10 "some-global" set +[ f ] +[ [ f "some-global" set "some-global" get ] bind ] +unit-test diff --git a/library/test/prettyprint.factor b/library/test/prettyprint.factor index 4ad70e9ed5..c3933c00b8 100644 --- a/library/test/prettyprint.factor +++ b/library/test/prettyprint.factor @@ -1,14 +1,7 @@ IN: scratchpad USE: lists USE: prettyprint -USE: stdio USE: test USE: vocabularies -"Checking prettyprinter." print - -! This was broken due to uninterned words having a null vocabulary. -[ #:uninterned ] prettyprint - -! Now do a little benchmark [ vocabs [ words [ see ] each ] each ] time diff --git a/library/test/reader.factor b/library/test/reader.factor index 5c8bbb677b..9c83697401 100644 --- a/library/test/reader.factor +++ b/library/test/reader.factor @@ -1,16 +1,8 @@ IN: scratchpad USE: parser -USE: stdio USE: test USE: unparser -"Reader tests" print - -![ [ one [ two [ three ] four ] five ] ] -![ "one [ two [ three ] four ] five" ] -![ parse ] -!test-word - [ [ 1 [ 2 [ 3 ] 4 ] 5 ] ] [ "1\n[\n2\n[\n3\n]\n4\n]\n5" ] [ parse ] @@ -21,31 +13,21 @@ test-word [ parse ] test-word -![ [ "hello world" ] ] -![ "\"hello world\"" ] -![ parse ] -!test-word +[ [ "hello world" ] ] +[ "\"hello world\"" ] +[ parse ] +test-word [ [ "\n\r\t\\" ] ] [ "\"\\n\\r\\t\\\\\"" ] [ parse ] test-word -![ [ "hello\nworld" x y z ] ] -![ "\"hello\\nworld\" x y z" ] -![ parse ] -!test-word - [ "hello world" ] [ "IN: scratchpad : hello \"hello world\" ;" ] [ parse call "USE: scratchpad hello" eval ] test-word -[ 1 2 ] -[ "IN: scratchpad ~<< my-swap a b -- b a >>~" ] -[ parse call 2 1 "USE: scratchpad my-swap" eval ] -test-word - [ ] [ "! This is a comment, people." ] [ parse call ] @@ -61,17 +43,6 @@ test-word [ unparse ] test-word -! Make sure parseObject() preserves doc comments. -[ "( this is a comment )\n" ] -[ "( this is a comment )" ] -[ - interpreter - [ "java.lang.String" "factor.FactorInterpreter" ] - "factor.FactorReader" "parseObject" - jinvoke-static - unparse -] test-word - ! Test escapes [ [ " " ] ] @@ -93,5 +64,3 @@ test-word [ "\e" ] [ unparse ] test-word - -"Reader tests done" print diff --git a/library/test/string.factor b/library/test/string.factor deleted file mode 100644 index ac1b59b5ff..0000000000 --- a/library/test/string.factor +++ /dev/null @@ -1,34 +0,0 @@ -IN: scratchpad -USE: compiler -USE: namespaces -USE: stdio -USE: streams -USE: strings -USE: test -USE: words -USE: vocabularies - -"Testing string words." print - -[ [ 2 1 0 0 ] ] [ [ fill ] ] [ balance>list ] test-word -[ " " ] [ 9 " " ] [ fill ] test-word -[ "" ] [ 0 "X" ] [ fill ] test-word - -: strstream-test ( -- ) - 1024 "strstream" set - "Hello " "strstream" get fwrite - "world." "strstream" get fwrite - "strstream" get stream>str ; - -[ "Hello world." ] [ ] [ strstream-test ] test-word - -[ [ 1 1 0 0 ] ] [ [ cat ] ] [ balance>list ] test-word -[ "abc" ] [ [ "a" "b" "c" ] ] [ cat ] test-word - -[ [ 1 1 0 0 ] ] [ [ str-length ] ] [ balance>list ] test-word -"str-length" [ "strings" ] search must-compile - -[ [ 1 1 0 0 ] ] [ [ >char ] ] [ balance>list ] test-word -">char" [ "strings" ] search must-compile - -"String tests done." print diff --git a/library/test/test.factor b/library/test/test.factor index fc570bd5f6..6f6777c340 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -22,21 +22,16 @@ USE: vocabularies : assert ( t -- ) [ "Assertion failed!" throw ] unless ; -: assert= ( x y -- ) - = assert ; +: print-test ( input output -- ) + "TESTING: " write 2list . ; -: must-compile ( word -- ) - "compile" get [ - "Checking if " write dup write " was compiled" print - dup compile - worddef compiled? assert - ] [ - drop - ] ifte ; +: unit-test ( output input -- ) + 2dup print-test + swap >r >r clear r> call datastack vector>list r> = assert ; : test-word ( output input word -- ) - 3dup 3list . - append expand assert= ; + #! Old-style test. + append unit-test ; : do-not-test-word ( output input word -- ) #! Flag for tests that are known not to work. @@ -55,34 +50,33 @@ USE: vocabularies "Running Factor test suite..." print "vocabularies" get [ f "scratchpad" set ] bind [ - "assoc" - "auxiliary" + "lists/all" "combinators" - "compiler" - "compiler-types" "continuations" - "dictionary" - "format" "hashtables" + "strings" + "namespaces/all" + "format" + "prettyprint" + ! "html" + "auxiliary" + "compiler" + "compiler-types" + "dictionary" "httpd" "inference" - "list" "math" "miscellaneous" - "namespaces" "parse-number" - "prettyprint" "primitives" "random" "reader" "recompile" "stack" - "string" "tail" "types" "vectors" ] [ test - ] each - "All tests passed." print ; + ] each ; diff --git a/native/factor.h b/native/factor.h index 4b8a970268..33770f175e 100644 --- a/native/factor.h +++ b/native/factor.h @@ -15,6 +15,7 @@ #include #include #include +#include #define INLINE inline static @@ -43,6 +44,7 @@ typedef unsigned char BYTE; #include "fixnum.h" #include "bignum.h" #include "arithmetic.h" +#include "misc.h" #include "string.h" #include "fd.h" #include "file.h" diff --git a/native/misc.c b/native/misc.c new file mode 100644 index 0000000000..b04d351e9b --- /dev/null +++ b/native/misc.c @@ -0,0 +1,31 @@ +#include "factor.h" + +void primitive_exit(void) +{ + exit(to_fixnum(env.dt)); +} + +void primitive_os_env(void) +{ + char* name = to_c_string(untag_string(env.dt)); + char* value = getenv(name); + if(value == NULL) + env.dt = F; + else + env.dt = tag_object(from_c_string(getenv(name))); +} + +void primitive_eq(void) +{ + check_non_empty(env.dt); + check_non_empty(dpeek()); + env.dt = tag_boolean(dpop() == env.dt); +} + +void primitive_millis(void) +{ + struct timeval t; + gettimeofday(&t,NULL); + dpush(env.dt); + env.dt = tag_object(bignum(t.tv_sec * 1000 + t.tv_usec/1000)); +} diff --git a/native/misc.h b/native/misc.h new file mode 100644 index 0000000000..5f3abab192 --- /dev/null +++ b/native/misc.h @@ -0,0 +1,4 @@ +void primitive_exit(void); +void primitive_os_env(void); +void primitive_eq(void); +void primitive_millis(void); diff --git a/native/primitives.c b/native/primitives.c index 1cd9789589..608a24eadc 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -90,7 +90,8 @@ XT primitives[] = { primitive_flush_fd, /* 86 */ primitive_shutdown_fd, /* 87 */ primitive_room, /* 88 */ - primitive_os_env /* 89 */ + primitive_os_env, /* 89 */ + primitive_millis /* 90 */ }; CELL primitive_to_xt(CELL primitive) @@ -100,10 +101,3 @@ CELL primitive_to_xt(CELL primitive) return (CELL)primitives[primitive]; } - -void primitive_eq(void) -{ - check_non_empty(env.dt); - check_non_empty(dpeek()); - env.dt = tag_boolean(dpop() == env.dt); -} diff --git a/native/primitives.h b/native/primitives.h index 3d76ad2d0e..6fc29e47e3 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,5 +1,5 @@ extern XT primitives[]; -#define PRIMITIVE_COUNT 90 +#define PRIMITIVE_COUNT 91 CELL primitive_to_xt(CELL primitive); diff --git a/native/run.c b/native/run.c index 6e20009ca1..8c2e7381cc 100644 --- a/native/run.c +++ b/native/run.c @@ -121,18 +121,3 @@ void primitive_setenv(void) env.user[e] = value; env.dt = dpop(); } - -void primitive_exit(void) -{ - exit(to_fixnum(env.dt)); -} - -void primitive_os_env(void) -{ - char* name = to_c_string(untag_string(env.dt)); - char* value = getenv(name); - if(value == NULL) - env.dt = F; - else - env.dt = tag_object(from_c_string(getenv(name))); -} diff --git a/native/string.c b/native/string.c index cc78257c44..5b851bb6c0 100644 --- a/native/string.c +++ b/native/string.c @@ -157,7 +157,7 @@ void primitive_string_hashcode(void) env.dt = tag_object(bignum(untag_string(env.dt)->hashcode)); } -INLINE CELL index_of_ch(CELL index, STRING* string, CELL ch) +CELL index_of_ch(CELL index, STRING* string, CELL ch) { if(index < 0) range_error(tag_object(string),index,string->capacity); @@ -172,12 +172,36 @@ INLINE CELL index_of_ch(CELL index, STRING* string, CELL ch) return -1; } -INLINE CELL index_of_str(CELL index, STRING* string, STRING* substring) +INLINE FIXNUM index_of_str(FIXNUM index, STRING* string, STRING* substring) { - if(substring->capacity != 1) - fatal_error("index_of_str not supported yet",substring); + CELL i = index; + CELL limit = string->capacity - substring->capacity; + CELL scan; - return index_of_ch(index,string,string_nth(substring,0)); + if(substring->capacity == 1) + return index_of_ch(index,string,string_nth(substring,0)); + + if(substring->capacity > string->capacity) + return -1; + +outer: if(i <= limit) + { + for(scan = 0; scan < substring->capacity; scan++) + { + if(string_nth(string,i + scan) + != string_nth(substring,scan)) + { + i++; + goto outer; + } + } + + /* We reached here and every char in the substring matched */ + return i; + } + + /* We reached here and nothing matched */ + return -1; } /* index string substring -- index */ @@ -185,12 +209,14 @@ void primitive_index_of(void) { CELL ch = env.dt; STRING* string; - CELL index; + FIXNUM index; CELL result; check_non_empty(ch); string = untag_string(dpop()); index = to_fixnum(dpop()); - if(TAG(ch) == FIXNUM_TYPE) + if(index < 0 || index > string->capacity) + range_error(tag_object(string),index,string->capacity); + else if(TAG(ch) == FIXNUM_TYPE) result = index_of_ch(index,string,to_fixnum(ch)); else result = index_of_str(index,string,untag_string(ch)); -- 2.34.1