\r
ERROR: I/O error: [ "primitive_read_line_fd_8" "Resource temporarily unavailable" ]\r
\r
+- prettyprinter: space after #<>, space after ~<< foo\r
- bignum=\r
- fixup-words is crusty\r
- decide if overflow is a fatal error\r
-rm *.o
-
export CC=gcc34
export CFLAGS="-pedantic -Wall -Winline -Os -march=pentium4 -fomit-frame-pointer"
: hours 60 * 60 * ;
\layout LyX-Code
-2 km .
+2 kilometers .
\layout LyX-Code
shutdown-fd
room
os-env
+ millis
] [
swap succ tuck primitive,
] each drop ;
"/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
[ "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 ;
"/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"
: 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 ]
[ CHAR: \" | CHAR: \" ]
] assoc ;
+: escape ( ch -- esc )
+ dup CHAR: u = [
+ drop unicode-escape
+ ] [
+ ascii-escape
+ ] ifte ;
+
! String literal
: parse-escape ( -- )
: 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 ;
: 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 )
] 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
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
USE: stdio
USE: test
-"Checking continuations." print
-
: callcc1-test ( x -- list )
[
"test-cc" set [ ] [
] 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
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
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
-
-[ f ]
-[ [ 1 2 | 3 ] ]
-[ hashtable? ]
-test-word
+[ "testhash" get hashtable? ]
+unit-test
[ f ]
-[ namestack* ]
-[ hashtable? ]
-test-word
+[ [ 1 2 | 3 ] hashtable? ]
+unit-test
IN: scratchpad
-USE: compiler
USE: html
USE: namespaces
USE: stdio
USE: strings
USE: test
-[ [ 1 1 0 0 ] ] [ [ chars>entities ] ] [ balance>list ] test-word
[
"<html>&'sgml'"
-] [ "<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
+++ /dev/null
-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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
+
--- /dev/null
+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
--- /dev/null
+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
+++ /dev/null
-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
-[ [ 0 1 0 0 ] ] [ [ namestack* ] ] [ balance>list ] test-word
-[ [ 0 1 0 0 ] ] [ [ namestack ] ] [ balance>list ] test-word
-[ [ 1 0 0 0 ] ] [ [ set-namestack* ] ] [ balance>list ] test-word
-[ [ 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
-
-: namespace-compile ( x -- x )
- <namespace> [ "x" set ] extend [ "x" get ] bind ; word must-compile
-
-[ 12 ] [ 12 ] [ namespace-compile ] test-word
-
-! A compiler bug in tailcalls that manifests with the namestack
-
-: namespace-tail-call-bug ( x -- x )
- dup 0 = [
- drop
- ] [
- pred <namespace> [ dup "x" set namespace-tail-call-bug ] bind
- ] ifte ; word must-compile
-
-[ 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
--- /dev/null
+USE: combinators
+USE: kernel
+USE: test
+
+"namespaces/namespaces" test
+java? [ "namespaces/java" test ] when
--- /dev/null
+IN: scratchpad
+USE: arithmetic
+USE: compiler
+USE: kernel
+USE: namespaces
+USE: stack
+USE: test
+USE: words
+USE: vocabularies
+
+[ [ 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
+[ [ 0 1 0 0 ] ] [ [ namestack* ] ] [ balance>list ] test-word
+[ [ 0 1 0 0 ] ] [ [ namestack ] ] [ balance>list ] test-word
+[ [ 1 0 0 0 ] ] [ [ set-namestack* ] ] [ balance>list ] test-word
+[ [ 1 0 0 0 ] ] [ [ set-namestack ] ] [ balance>list ] test-word
+[ [ 0 1 0 0 ] ] [ [ n> ] ] [ balance>list ] test-word
+
+: test-this-2 ( -- )
+ interpreter dup [ this = ] bind ;
+
+[ t ] [ test-this-2 ] unit-test
+
+: namespace-compile ( x -- x )
+ <namespace> [ "x" set ] extend [ "x" get ] bind ; word must-compile
+
+[ 12 ] [ 12 ] [ namespace-compile ] test-word
+
+! A compiler bug in tailcalls that manifests with the namestack
+
+: namespace-tail-call-bug ( x -- x )
+ dup 0 = [
+ drop
+ ] [
+ pred <namespace> [ dup "x" set namespace-tail-call-bug ] bind
+ ] ifte ; word must-compile
+
+[ f ] [ ] [ 10 namespace-tail-call-bug "x" get 0 = ] test-word
+
+! I did a n> in extend and forgot the obvious case
+[ t ] [ "dup" intern dup ] [ [ ] extend = ] test-word
--- /dev/null
+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
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
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 ]
[ 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 ]
[ 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
[ [ " " ] ]
[ "\e" ]
[ unparse ]
test-word
-
-"Reader tests done" print
+++ /dev/null
-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
: 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.
"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 ;
#include <netinet/in.h>
#include <arpa/inet.h>
#include <unistd.h>
+#include <sys/time.h>
#define INLINE inline static
#include "fixnum.h"
#include "bignum.h"
#include "arithmetic.h"
+#include "misc.h"
#include "string.h"
#include "fd.h"
#include "file.h"
--- /dev/null
+#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));
+}
--- /dev/null
+void primitive_exit(void);
+void primitive_os_env(void);
+void primitive_eq(void);
+void primitive_millis(void);
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)
return (CELL)primitives[primitive];
}
-
-void primitive_eq(void)
-{
- check_non_empty(env.dt);
- check_non_empty(dpeek());
- env.dt = tag_boolean(dpop() == env.dt);
-}
extern XT primitives[];
-#define PRIMITIVE_COUNT 90
+#define PRIMITIVE_COUNT 91
CELL primitive_to_xt(CELL primitive);
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)));
-}
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);
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 */
{
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));
projects / factor.git / commitdiff