steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

working on the test suite

cvs
Slava Pestov 2004-08-04 07:12:55 +00:00
parent 1a6b5dea98
commit f68cc94ee4
38 changed files with 464 additions and 462 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
TODO.FACTOR.txt
View File

@ -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

2
build.sh
View File

@ -1,5 +1,3 @@
rm *.o
export CC=gcc34
export CFLAGS="-pedantic -Wall -Winline -Os -march=pentium4 -fomit-frame-pointer"

2
doc/devel-guide.lyx
View File

@ -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

1
library/cross-compiler.factor
View File

@ -162,6 +162,7 @@ IN: cross-compiler
shutdown-fd
room
os-env
millis
] [
swap succ tuck primitive,
] each drop ;

1
library/platform/jvm/boot-sumo.factor
View File

@ -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

8
library/platform/jvm/unparser.factor
View File

@ -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 ;

1
library/platform/native/boot.factor
View File

@ -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"

16
library/platform/native/parse-syntax.factor
View File

@ -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 ( -- )

2
library/platform/native/parser.factor
View File

@ -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 ;

18
library/platform/native/unparser.factor
View File

@ -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.
<namespace> [ "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 )

2
library/strings.factor
View File

@ -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

14
library/test/combinators.factor
View File

@ -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

6
library/test/continuations.factor
View File

@ -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

18
library/test/format.factor
View File

@ -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

29
library/test/hashtables.factor
View File

@ -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 <hashtable> "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
[ "testhash" get hashtable? ]
unit-test
[ f ]
[ [ 1 2 | 3 ] ]
[ hashtable? ]
test-word
[ f ]
[ namestack* ]
[ hashtable? ]
test-word
[ [ 1 2 | 3 ] hashtable? ]
unit-test

30
library/test/html.factor
View File

@ -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
[
"&lt;html&gt;&amp;&apos;sgml&apos;"
] [ "<html>&'sgml'" ] [ chars>entities ] test-word
[ [ 1 1 0 0 ] ] [ [ html-attr-string ] ] [ balance>list ] test-word
] [ "<html>&'sgml'" chars>entities ] unit-test
[ "Hello world" ]
[ "Hello world" <namespace> ]
[ [ html-attr-string ] bind ] test-word
[
"Hello world" <namespace> [ html-attr-string ] bind
] unit-test
[ "<b>Hello world</b>" ]
[ "Hello world" <namespace> [ t "bold" set ] extend ]
[ [ html-attr-string ] bind ] test-word
[
"Hello world"
<namespace> [ t "bold" set ] extend
[ html-attr-string ] bind
] unit-test
[ "<i>Hello world</i>" ]
[ "Hello world" <namespace> [ t "italics" set ] extend ]
[ [ html-attr-string ] bind ] test-word
[
"Hello world" <namespace> [ t "italics" set ] extend
[ html-attr-string ] bind
] unit-test
[ "<font color=\"#ff00ff\">Hello world</font>" ]
[ "Hello world" <namespace> [ [ 255 0 255 ] "fg" set ] extend ]
[ [ html-attr-string ] bind ] test-word
[
"Hello world" <namespace> [ [ 255 0 255 ] "fg" set ] extend
[ html-attr-string ] bind
] unit-test

207
library/test/list.factor
View File

@ -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

10
library/test/lists/all.factor Normal file
View File

@ -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

27
library/test/lists/assoc.factor Normal file
View File

@ -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

28
library/test/lists/cons.factor Normal file
View File

@ -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

34
library/test/lists/destructive.factor Normal file
View File

@ -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

48
library/test/lists/java.factor Normal file
View File

@ -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

77
library/test/lists/lists.factor Normal file
View File

@ -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

10
library/test/lists/namespaces.factor Normal file
View File

@ -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

6
library/test/namespaces/all.factor Normal file
View File

@ -0,0 +1,6 @@
USE: combinators
USE: kernel
USE: test
"namespaces/namespaces" test
java? [ "namespaces/java" test ] when

57
library/test/namespaces.factor → library/test/namespaces/java.factor
View File

@ -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
<namespace> "test-namespace" set
: test-namespace ( -- )
<namespace> dup [ namespace = ] bind ;
: test-this-1 ( -- )
<namespace> 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 )
<namespace> [ "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.
<namespace> "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 ]
[ ]
[ <namespace> [ 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

45
library/test/namespaces/namespaces.factor Normal file
View File

@ -0,0 +1,45 @@
IN: scratchpad
USE: kernel
USE: namespaces
USE: test
USE: stack
USE: words
USE: vocabularies
<namespace> "test-namespace" set
: test-namespace ( -- )
<namespace> dup [ namespace = ] bind ;
: test-this-1 ( -- )
<namespace> dup [ this = ] bind ;
[ t ] [ test-namespace ] unit-test
[ t ] [ test-this-1 ] unit-test
! Object paths should not resolve further up in the namestack.
<namespace> "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 ]
[ <namespace> [ f "some-global" set "some-global" get ] bind ]
unit-test

7
library/test/prettyprint.factor
View File

@ -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

39
library/test/reader.factor
View File

@ -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

34
library/test/string.factor
View File

@ -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 <string-output-stream> "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

42
library/test/test.factor
View File

@ -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"
"continuations"
"hashtables"
"strings"
"namespaces/all"
"format"
"prettyprint"
!
"html"
"auxiliary"
"compiler"
"compiler-types"
"continuations"
"dictionary"
"format"
"hashtables"
"html"
"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 ;

2
native/factor.h
View File

@ -15,6 +15,7 @@
#include <netinet/in.h>
#include <arpa/inet.h>
#include <unistd.h>
#include <sys/time.h>
#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"

31
native/misc.c Normal file
View File

@ -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));
}

4
native/misc.h Normal file
View File

@ -0,0 +1,4 @@
void primitive_exit(void);
void primitive_os_env(void);
void primitive_eq(void);
void primitive_millis(void);

10
native/primitives.c
View File

@ -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);
}

2
native/primitives.h
View File

@ -1,5 +1,5 @@
extern XT primitives[];
#define PRIMITIVE_COUNT 90
#define PRIMITIVE_COUNT 91
CELL primitive_to_xt(CELL primitive);

15
native/run.c
View File

@ -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)));
}

40
native/string.c
View File

@ -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));