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

Merge git://factorcode.org/git/factor

release
Daniel Ehrenberg 2007-12-04 20:57:17 -05:00
parent 038d7bb534 e294eb8a49
commit 084f2bcec5
40 changed files with 400 additions and 1617 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/combinators/lib/lib-tests.factor
View File

@ -58,3 +58,5 @@ IN: temporary
[ dup array? ] [ dup vector? ] [ dup float? ] [ dup array? ] [ dup vector? ] [ dup float? ]
} || nip } || nip
] unit-test ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test

6
extra/combinators/lib/lib.factor
View File

@ -67,6 +67,12 @@ MACRO: napply ( n -- )
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline : map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
MACRO: nfirst ( n -- )
[ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
: seq>stack ( seq -- )
dup length nfirst ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ; : sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ;

1
extra/editors/editplus/authors.txt Normal file
View File

@ -0,0 +1 @@
Aaron Schaefer

12
extra/editors/editplus/editplus.factor Normal file
View File

@ -0,0 +1,12 @@
USING: editors io.launcher math.parser namespaces ;
IN: editors.editplus
: editplus ( file line -- )
[
\ editplus get-global % " -cursor " % # " " % %
] "" make run-detached ;
! Put in your .factor-boot-rc
! "c:\\Program Files\\EditPlus\\editplus.exe" \ editplus set-global
[ editplus ] edit-hook set-global

1
extra/editors/editplus/summary.txt Normal file
View File

@ -0,0 +1 @@
EditPlus editor integration

1
extra/editors/emeditor/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

10
extra/editors/emeditor/emeditor.factor Normal file
View File

@ -0,0 +1,10 @@
USING: editors io.launcher kernel math.parser namespaces ;
IN: editors.emeditor
: emeditor ( file line -- )
[
\ emeditor get-global % " /l " % #
" " % "\"" % % "\"" %
] "" make run-detached ;
[ emeditor ] edit-hook set-global

1
extra/editors/emeditor/summary.txt Normal file
View File

@ -0,0 +1 @@
EmEditor integration

1
extra/editors/ted-notepad/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
extra/editors/ted-notepad/summary.txt Normal file
View File

@ -0,0 +1 @@
TED Notepad integration

10
extra/editors/ted-notepad/ted-notepad.factor Normal file
View File

@ -0,0 +1,10 @@
USING: editors io.launcher kernel math.parser namespaces ;
IN: editors.ted-notepad
: ted-notepad ( file line -- )
[
\ ted-notepad get-global % " /l" % #
" " % %
] "" make run-detached ;
[ ted-notepad ] edit-hook set-global

1
extra/editors/ultraedit/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
extra/editors/ultraedit/summary.txt Normal file
View File

@ -0,0 +1 @@
UltraEdit editor integration

12
extra/editors/ultraedit/ultraedit.factor Normal file
View File

@ -0,0 +1,12 @@
USING: editors io.launcher kernel math.parser namespaces ;
IN: editors.ultraedit
: ultraedit ( file line -- )
[
\ ultraedit get-global % " " % swap % "/" % # "/1" %
] "" make run-detached ;
! Put the path in your .factor-boot-rc
! "K:\\Program Files (x86)\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" \ ultraedit set-global
[ ultraedit ] edit-hook set-global

6
extra/http/parser/analyzer/analyzer.factor → extra/html/parser/analyzer/analyzer.factor
View File

@ -1,5 +1,5 @@
USING: assocs http.parser kernel math sequences strings ; USING: assocs html.parser kernel math sequences strings ;
IN: http.parser.analyzer IN: html.parser.analyzer
: remove-blank-text ( vector -- vector' ) : remove-blank-text ( vector -- vector' )
[ [
@ -87,5 +87,5 @@ IN: http.parser.analyzer
! clear "/Users/erg/web/hostels.html" <file-reader> contents parse-html "Currency" "name" pick find-first-attribute-key-value ! clear "/Users/erg/web/hostels.html" <file-reader> contents parse-html "Currency" "name" pick find-first-attribute-key-value
! clear "/Users/erg/web/hostels.html" <file-reader> contents parse-html ! clear "/Users/erg/web/hostels.html" <file-reader> contents parse-html
! "Currency" "name" pick find-first-attribute-key-value ! "Currency" "name" pick find-first-attribute-key-value
! pick find-between remove-blank-text ! pick find-between remove-blank-text

2
extra/http/parser/parser-tests.factor → extra/html/parser/parser-tests.factor
View File

@ -1,4 +1,4 @@
USING: browser.parser kernel tools.test ; USING: html.parser kernel tools.test ;
IN: temporary IN: temporary
[ [

6
extra/http/parser/parser.factor → extra/html/parser/parser.factor
View File

@ -1,7 +1,7 @@
USING: arrays http.parser.utils hashtables io kernel USING: arrays html.parser.utils hashtables io kernel
namespaces prettyprint quotations namespaces prettyprint quotations
sequences splitting state-parser strings ; sequences splitting state-parser strings ;
IN: http.parser IN: html.parser
TUPLE: tag name attributes text matched? closing? ; TUPLE: tag name attributes text matched? closing? ;
@ -120,7 +120,7 @@ SYMBOL: tagstack
] unless ; ] unless ;
: parse-attributes ( -- hashtable ) : parse-attributes ( -- hashtable )
[ (parse-attributes) ] { } make >hashtable ; [ (parse-attributes) ] { } make >hashtable ;
: (parse-tag) : (parse-tag)
[ [

9
extra/http/parser/printer/printer.factor → extra/html/parser/printer/printer.factor
View File

@ -1,9 +1,9 @@
USING: assocs http.parser browser.utils combinators USING: assocs html.parser html.parser.utils combinators
continuations hashtables continuations hashtables
hashtables.private io kernel math hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting namespaces prettyprint quotations sequences splitting
state-parser strings ; state-parser strings ;
IN: http.parser.printer IN: html.parser.printer
SYMBOL: no-section SYMBOL: no-section
SYMBOL: html SYMBOL: html
@ -42,7 +42,7 @@ HOOK: print-closing-named-tag printer ( tag -- )
M: printer print-text-tag ( tag -- ) M: printer print-text-tag ( tag -- )
tag-text write ; tag-text write ;
M: printer print-comment-tag ( tag -- ) M: printer print-comment-tag ( tag -- )
"<!--" write "<!--" write
tag-text write tag-text write
"-->" write ; "-->" write ;
@ -67,7 +67,6 @@ M: printer print-closing-named-tag ( tag -- )
[ [
swap bl write "=" write ?quote write swap bl write "=" write ?quote write
] assoc-each ; ] assoc-each ;
M: src-printer print-opening-named-tag ( tag -- ) M: src-printer print-opening-named-tag ( tag -- )
"<" write "<" write
@ -102,7 +101,7 @@ SYMBOL: tablestack
[ [
V{ } clone tablestack set V{ } clone tablestack set
] with-scope ; ] with-scope ;
! { { 1 2 } { 3 4 } } ! { { 1 2 } { 3 4 } }
! H{ { table-gap { 10 10 } } } [ ! H{ { table-gap { 10 10 } } } [
! [ [ [ [ . ] with-cell ] each ] with-row ] each ! [ [ [ [ . ] with-cell ] each ] with-row ] each

2
extra/http/parser/utils/utils-tests.factor → extra/html/parser/utils/utils-tests.factor
View File

@ -2,7 +2,7 @@ USING: assocs combinators continuations hashtables
hashtables.private io kernel math hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting namespaces prettyprint quotations sequences splitting
state-parser strings tools.test ; state-parser strings tools.test ;
USING: browser.utils ; USING: html.parser.utils ;
IN: temporary IN: temporary
[ "'Rome'" ] [ "Rome" single-quote ] unit-test [ "'Rome'" ] [ "Rome" single-quote ] unit-test

4
extra/http/parser/utils/utils.factor → extra/html/parser/utils/utils.factor
View File

@ -2,8 +2,8 @@ USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting namespaces prettyprint quotations sequences splitting
state-parser strings ; state-parser strings ;
USING: http.parser ; USING: html.parser ;
IN: http.parser.utils IN: html.parser.utils
: string-parse-end? : string-parse-end?
get-next not ; get-next not ;

6
extra/parser-combinators/parser-combinators-tests.factor
View File

@ -149,9 +149,3 @@ IN: scratchpad
{ { } } [ { { } } [
"234" "1" token <+> parse list>array "234" "1" token <+> parse list>array
] unit-test ] unit-test
[ "a" "a" token <!> parse-1 ] unit-test-fails
[ t ] [ "b" "a" token <!> parse-1 >boolean ] unit-test
[ t ] [ "b" "ab" token <!> parse-1 >boolean ] unit-test

11
extra/random-tester/databank/databank.factor Normal file
View File

@ -0,0 +1,11 @@
USING: kernel math.constants ;
IN: random-tester.databank
: databank ( -- array )
{
! V{ } H{ } V{ 3 } { 3 } { } "" "asdf"
pi 1/0. -1/0. 0/0. [ ]
f t "" 0 0.0 3.14 2 -3 -7 20 3/4 -3/4 1.2/3 3.5
C{ 2 2 } C{ 1/0. 1/0. }
} ;

45
extra/random-tester/random-tester.factor Normal file
View File

@ -0,0 +1,45 @@
USING: compiler continuations io kernel math namespaces
prettyprint quotations random sequences vectors ;
USING: random-tester.databank random-tester.safe-words ;
IN: random-tester
SYMBOL: errored
SYMBOL: before
SYMBOL: after
SYMBOL: quot
TUPLE: random-tester-error ;
: setup-test ( #data #code -- data... quot )
#! Variable stack effect
>r [ databank random ] times r>
[ drop \ safe-words get random ] map >quotation ;
: test-compiler ! ( data... quot -- ... )
errored off
dup quot set
datastack clone >vector dup pop* before set
[ call ] catch drop
datastack clone after set
clear
before get [ ] each
quot get [ compile-1 ] [ errored on ] recover ;
: do-test ! ( data... quot -- )
.s flush test-compiler
errored get [
datastack after get 2dup = [
2drop
] [
[ . ] each
"--" print
[ . ] each
quot get .
random-tester-error construct-empty throw
] if
] unless clear ;
: random-test1 ( #data #code -- )
setup-test do-test ;
: random-test2 ( -- )
3 2 setup-test do-test ;

0
unmaintained/random-tester/random.factor → extra/random-tester/random/random.factor Normal file → Executable file
View File

117
extra/random-tester/safe-words/safe-words.factor Normal file
View File

@ -0,0 +1,117 @@
USING: kernel namespaces sequences sorting vocabs ;
USING: arrays assocs generic hashtables math math.intervals math.parser math.functions refs shuffle vectors words ;
IN: random-tester.safe-words
: ?-words
{
delegate
/f
bits>float bits>double
float>bits double>bits
>bignum >boolean >fixnum >float
array? integer? complex? value-ref? ref? key-ref?
interval? number?
wrapper? tuple?
[-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? valid-digits? zero? assoc? curry? vector? callstack? ! clear 3.14 [ <vector> assoc? ] compile-1
2^ not
! arrays
resize-array <array>
! assocs
(assoc-stack)
new-assoc
assoc-like
<hashtable>
all-integers? (all-integers?) ! hangs?
assoc-push-if
(clone) assoc-clone-like ! SYMBOL: foo foo dup (clone) =
} ;
: bignum-words
{
next-power-of-2 (next-power-of-2)
times
hashcode hashcode*
} ;
: initialization-words
{
init-namespaces
} ;
: stack-words
{
dup
drop 2drop 3drop
roll -roll 2swap
>r r>
} ;
: method-words
{
method-def
forget-word
} ;
: stateful-words
{
counter
gensym
} ;
: foo-words
{
set-retainstack
retainstack callstack
datastack
callstack>array
} ;
: exit-words
{
call-clear die
} ;
: bad-words ( -- array )
[
?-words %
bignum-words %
initialization-words %
stack-words %
method-words %
stateful-words %
exit-words %
foo-words %
] { } make ;
: safe-words ( -- array )
bad-words {
"alists" "arrays" "assocs" ! "bit-arrays" "byte-arrays"
! "classes" "combinators" "compiler" "continuations"
! "core-foundation" "definitions" "documents"
! "float-arrays" "generic" "graphs" "growable"
"hashtables" ! io.*
"kernel" "math"
"math.bitfields" "math.complex" "math.constants" "math.floats"
"math.functions" "math.integers" "math.intervals" "math.libm"
"math.parser" "math.ratios" "math.vectors"
! "namespaces" "quotations" "sbufs"
! "queues" "strings" "sequences"
"vectors"
! "words"
} [ words ] map concat seq-diff natural-sort ;
safe-words \ safe-words set-global
! foo dup (clone) = .
! foo dup clone = .
! f [ byte-array>bignum assoc-clone-like ] compile-1
! 2 3.14 [ construct-empty number= ] compile-1
! 3.14 [ <vector> assoc? ] compile-1
! -3 [ ] 2 [ byte-array>bignum denominator ] compile-1

95
extra/random-tester/utils/utils.factor Normal file
View File

@ -0,0 +1,95 @@
USING: arrays assocs combinators.lib continuations kernel
math math.functions namespaces quotations random sequences
sequences.private shuffle ;
IN: random-tester.utils
: %chance ( n -- ? )
100 random > ;
: 10% ( -- ? ) 10 %chance ;
: 20% ( -- ? ) 20 %chance ;
: 30% ( -- ? ) 30 %chance ;
: 40% ( -- ? ) 40 %chance ;
: 50% ( -- ? ) 50 %chance ;
: 60% ( -- ? ) 60 %chance ;
: 70% ( -- ? ) 70 %chance ;
: 80% ( -- ? ) 80 %chance ;
: 90% ( -- ? ) 90 %chance ;
: call-if ( quot ? -- ) [ call ] [ drop ] if ; inline
: with-10% ( quot -- ) 10% call-if ; inline
: with-20% ( quot -- ) 20% call-if ; inline
: with-30% ( quot -- ) 30% call-if ; inline
: with-40% ( quot -- ) 40% call-if ; inline
: with-50% ( quot -- ) 50% call-if ; inline
: with-60% ( quot -- ) 60% call-if ; inline
: with-70% ( quot -- ) 70% call-if ; inline
: with-80% ( quot -- ) 80% call-if ; inline
: with-90% ( quot -- ) 90% call-if ; inline
: random-hash-key keys random ;
: random-hash-value [ random-hash-key ] keep at ;
: do-one ( seq -- ) random call ; inline
TUPLE: p-list seq max count count-vec ;
: reset-array ( seq -- )
[ drop 0 ] over map-into ;
C: <p-list> p-list
: make-p-list ( seq n -- tuple )
>r dup length [ 1- ] keep r>
[ ^ 0 swap 2array ] keep
0 <array> <p-list> ;
: inc-seq ( seq max -- )
2dup [ < ] curry find-last over [
nipd 1+ 2over swap set-nth
1+ over length rot <slice> reset-array
] [
3drop reset-array
] if ;
: inc-count ( tuple -- )
[ p-list-count first2 >r 1+ r> 2array ] keep
set-p-list-count ;
: (get-permutation) ( seq index-seq -- newseq )
[ swap nth ] map-with ;
: get-permutation ( tuple -- seq )
[ p-list-seq ] keep p-list-count-vec (get-permutation) ;
: p-list-next ( tuple -- seq/f )
dup p-list-count first2 < [
[
[ get-permutation ] keep
[ p-list-count-vec ] keep p-list-max
inc-seq
] keep inc-count
] [
drop f
] if ;
: (permutations) ( tuple -- )
dup p-list-next [ , (permutations) ] [ drop ] if* ;
: permutations ( seq n -- seq )
make-p-list [ (permutations) ] { } make ;
: (each-permutation) ( tuple quot -- )
over p-list-next [
[ rot drop swap call ] 3keep
drop (each-permutation)
] [
2drop
] if* ; inline
: each-permutation ( seq n quot -- )
>r make-p-list r> (each-permutation) ;

25
extra/regexp/regexp.factor
View File

@ -2,6 +2,7 @@ USING: arrays combinators kernel lazy-lists math math.parser
namespaces parser parser-combinators parser-combinators.simple namespaces parser parser-combinators parser-combinators.simple
promises quotations sequences combinators.lib strings macros promises quotations sequences combinators.lib strings macros
assocs prettyprint.backend ; assocs prettyprint.backend ;
USE: io
IN: regexp IN: regexp
: or-predicates ( quots -- quot ) : or-predicates ( quots -- quot )
@ -40,7 +41,7 @@ MACRO: fast-member? ( str -- quot )
dup alpha? swap punct? or ; dup alpha? swap punct? or ;
: 'ordinary-char' ( -- parser ) : 'ordinary-char' ( -- parser )
[ "\\^*+?|(){}[" fast-member? not ] satisfy [ "\\^*+?|(){}[$" fast-member? not ] satisfy
[ [ = ] curry ] <@ ; [ [ = ] curry ] <@ ;
: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ; : 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
@ -158,23 +159,39 @@ C: <group-result> group-result
'char' <|> 'char' <|>
'character-class' <|> ; 'character-class' <|> ;
: 'interval' ( -- parser ) : 'greedy-interval' ( -- parser )
'simple' 'integer' "{" "}" surrounded-by <&> [ first2 exactly-n ] <@ 'simple' 'integer' "{" "}" surrounded-by <&> [ first2 exactly-n ] <@
'simple' 'integer' "{" ",}" surrounded-by <&> [ first2 at-least-n ] <@ <|> 'simple' 'integer' "{" ",}" surrounded-by <&> [ first2 at-least-n ] <@ <|>
'simple' 'integer' "{," "}" surrounded-by <&> [ first2 at-most-n ] <@ <|> 'simple' 'integer' "{," "}" surrounded-by <&> [ first2 at-most-n ] <@ <|>
'simple' 'integer' "," token <& 'integer' <&> "{" "}" surrounded-by <&> [ first2 first2 from-m-to-n ] <@ <|> ; 'simple' 'integer' "," token <& 'integer' <&> "{" "}" surrounded-by <&> [ first2 first2 from-m-to-n ] <@ <|> ;
: 'repetition' ( -- parser ) : 'interval' ( -- parser )
'greedy-interval'
'greedy-interval' "?" token <& [ "reluctant {}" print ] <@ <|>
'greedy-interval' "+" token <& [ "possessive {}" print ] <@ <|> ;
: 'greedy-repetition' ( -- parser )
'simple' "*" token <& [ <*> ] <@ 'simple' "*" token <& [ <*> ] <@
'simple' "+" token <& [ <+> ] <@ <|> 'simple' "+" token <& [ <+> ] <@ <|>
'simple' "?" token <& [ <?> ] <@ <|> ; 'simple' "?" token <& [ <?> ] <@ <|> ;
: 'repetition' ( -- parser )
'greedy-repetition'
'greedy-repetition' "?" token <& [ "reluctant" print ] <@ <|>
'greedy-repetition' "+" token <& [ "possessive" print ] <@ <|> ;
: 'term' ( -- parser ) : 'term' ( -- parser )
'simple' 'repetition' 'interval' <|> <|> 'simple' 'repetition' 'interval' <|> <|>
<+> [ <and-parser> ] <@ ; <+> [ <and-parser> ] <@ ;
LAZY: 'regexp' ( -- parser ) LAZY: 'regexp' ( -- parser )
'term' "|" token nonempty-list-of [ <or-parser> ] <@ ; 'term' "|" token nonempty-list-of [ <or-parser> ] <@
"^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@
&> [ "caret" print ] <@ <|>
'term' "|" token nonempty-list-of [ <or-parser> ] <@
"$" token <& [ "dollar" print ] <@ <|>
"^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@ &>
"$" token [ "caret dollar" print ] <@ <& <|> ;
TUPLE: regexp source parser ; TUPLE: regexp source parser ;

43
misc/factor.sh
View File

@ -32,12 +32,16 @@ check_ret() {
} }
check_gcc_version() { check_gcc_version() {
echo -n "Checking gcc version..."
GCC_VERSION=`gcc --version` GCC_VERSION=`gcc --version`
check_ret gcc
if [[ $GCC_VERSION == *3.3.* ]] ; then if [[ $GCC_VERSION == *3.3.* ]] ; then
echo "bad!"
echo "You have a known buggy version of gcc (3.3)" echo "You have a known buggy version of gcc (3.3)"
echo "Install gcc 3.4 or higher and try again." echo "Install gcc 3.4 or higher and try again."
exit 3 exit 3
fi fi
echo "ok."
} }
check_installed_programs() { check_installed_programs() {
@ -53,16 +57,20 @@ check_installed_programs() {
check_library_exists() { check_library_exists() {
GCC_TEST=factor-library-test.c GCC_TEST=factor-library-test.c
GCC_OUT=factor-library-test.out GCC_OUT=factor-library-test.out
echo "Checking for library $1" echo -n "Checking for library $1"
echo "int main(){return 0;}" > $GCC_TEST echo "int main(){return 0;}" > $GCC_TEST
gcc $GCC_TEST -o $GCC_OUT -l $1 gcc $GCC_TEST -o $GCC_OUT -l $1
if [[ $? -ne 0 ]] ; then if [[ $? -ne 0 ]] ; then
echo "not found!"
echo "Warning: library $1 not found." echo "Warning: library $1 not found."
echo "***Factor will compile NO_UI=1" echo "***Factor will compile NO_UI=1"
NO_UI=1 NO_UI=1
fi fi
rm -f $GCC_TEST rm -f $GCC_TEST
check_ret rm
rm -f $GCC_OUT rm -f $GCC_OUT
check_ret rm
echo "found."
} }
check_X11_libraries() { check_X11_libraries() {
@ -87,7 +95,9 @@ check_factor_exists() {
} }
find_os() { find_os() {
echo "Finding OS..."
uname_s=`uname -s` uname_s=`uname -s`
check_ret uname
case $uname_s in case $uname_s in
CYGWIN_NT-5.2-WOW64) OS=windows-nt;; CYGWIN_NT-5.2-WOW64) OS=windows-nt;;
*CYGWIN_NT*) OS=windows-nt;; *CYGWIN_NT*) OS=windows-nt;;
@ -100,11 +110,14 @@ find_os() {
} }
find_architecture() { find_architecture() {
echo "Finding ARCH..."
uname_m=`uname -m` uname_m=`uname -m`
check_ret uname
case $uname_m in case $uname_m in
i386) ARCH=x86;; i386) ARCH=x86;;
i686) ARCH=x86;; i686) ARCH=x86;;
*86) ARCH=x86;; *86) ARCH=x86;;
*86_64) ARCH=x86;;
"Power Macintosh") ARCH=ppc;; "Power Macintosh") ARCH=ppc;;
esac esac
} }
@ -115,6 +128,7 @@ write_test_program() {
} }
find_word_size() { find_word_size() {
echo "Finding WORD..."
C_WORD=factor-word-size C_WORD=factor-word-size
write_test_program write_test_program
gcc -o $C_WORD $C_WORD.c gcc -o $C_WORD $C_WORD.c
@ -142,6 +156,9 @@ echo_build_info() {
set_build_info() { set_build_info() {
if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
echo "OS: $OS"
echo "ARCH: $ARCH"
echo "WORD: $WORD"
echo "OS, ARCH, or WORD is empty. Please report this" echo "OS, ARCH, or WORD is empty. Please report this"
exit 5 exit 5
fi fi
@ -170,6 +187,7 @@ git_clone() {
} }
git_pull_factorcode() { git_pull_factorcode() {
echo "Updating the git repository from factorcode.org..."
git pull git://factorcode.org/git/factor.git git pull git://factorcode.org/git/factor.git
check_ret git check_ret git
} }
@ -203,11 +221,11 @@ get_boot_image() {
maybe_download_dlls() { maybe_download_dlls() {
if [[ $OS == windows-nt ]] ; then if [[ $OS == windows-nt ]] ; then
wget http://factorcode.org/dlls/freetype6.dll wget http://factorcode.org/dlls/freetype6.dll
check_ret check_ret wget
wget http://factorcode.org/dlls/zlib1.dll wget http://factorcode.org/dlls/zlib1.dll
check_ret check_ret wget
chmod 777 *.dll chmod 777 *.dll
check_ret check_ret chmod
fi fi
} }
@ -216,7 +234,7 @@ bootstrap() {
} }
usage() { usage() {
echo "usage: $0 install|update" echo "usage: $0 install|install-x11|update|quick-update"
} }
install() { install() {
@ -239,13 +257,26 @@ update() {
git_pull_factorcode git_pull_factorcode
make_clean make_clean
make_factor make_factor
}
update_bootstrap() {
delete_boot_images delete_boot_images
get_boot_image get_boot_image
bootstrap bootstrap
} }
refresh_image() {
./$FACTOR_BINARY -e="refresh-all save 0 USE: system exit"
}
install_libraries() {
sudo apt-get install libc6-dev libfreetype6-dev wget git-core git-doc libx11-dev glutg3-dev rlwrap
}
case "$1" in case "$1" in
install) install ;; install) install ;;
update) update ;; install-x11) install_libraries; install ;;
quick-update) update; refresh_image ;;
update) update; update_bootstrap ;;
*) usage ;; *) usage ;;
esac esac

89
unmaintained/alarms/alarms.factor
View File

@ -1,89 +0,0 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays calendar concurrency generic kernel math
namespaces sequences threads ;
IN: alarms-internals
! for now a V{ }, eventually a min-heap to store alarms
SYMBOL: alarms
SYMBOL: alarm-receiver
SYMBOL: alarm-looper
TUPLE: alarm time quot ;
: add-alarm ( alarm -- )
alarms get-global push ;
: remove-alarm ( alarm -- )
alarms get-global remove alarms set-global ;
: handle-alarm ( alarm -- )
dup delegate {
{ "register" [ add-alarm ] }
{ "unregister" [ remove-alarm ] }
} case ;
: expired-alarms ( -- seq )
now alarms get-global
[ alarm-time compare-timestamps 0 > ] subset-with ;
: unexpired-alarms ( -- seq )
now alarms get-global
[ alarm-time compare-timestamps 0 <= ] subset-with ;
: call-alarm ( alarm -- )
alarm-quot spawn drop ;
: do-alarms ( -- )
alarms get-global expired-alarms
[ call-alarm ] each
unexpired-alarms alarms set-global ;
: alarm-receive-loop ( -- )
receive dup alarm? [ handle-alarm ] [ drop ] if
alarm-receive-loop ;
: start-alarm-receiver ( -- )
[
alarm-receive-loop
] spawn alarm-receiver set-global ;
: alarm-loop ( -- )
alarms get-global empty? [
do-alarms
] unless 100 sleep alarm-loop ;
: start-alarm-looper ( -- )
[
alarm-loop
] spawn alarm-looper set-global ;
: send-alarm ( alarm -- )
over set-delegate
alarm-receiver get-global send ;
: start-alarm-daemon ( -- process )
alarms get-global [
V{ } clone alarms set-global
start-alarm-looper
start-alarm-receiver
] unless ;
start-alarm-daemon
IN: alarms
: register-alarm ( alarm -- )
"register" send-alarm ;
: unregister-alarm ( alarm -- )
"unregister" send-alarm ;
: change-alarm ( alarm-old alarm-new -- )
"register" send-alarm
"unregister" send-alarm ;
! Example:
! now 5 seconds +dt [ "hi" print flush ] <alarm> register-alarm

5
unmaintained/alarms/load.factor
View File

@ -1,5 +0,0 @@
REQUIRES: libs/calendar libs/concurrency ;
PROVIDE: libs/alarms
{ +files+ {
"alarms.factor"
} } ;

9
unmaintained/random-tester/load.factor
View File

@ -1,9 +0,0 @@
REQUIRES: libs/lazy-lists libs/null-stream libs/shuffle ;
PROVIDE: apps/random-tester
{ +files+ {
"utils.factor"
"random.factor"
"random-tester.factor"
"random-tester2.factor"
"type.factor"
} } ;

301
unmaintained/random-tester/random-tester.factor
View File

@ -1,301 +0,0 @@
USING: kernel math math-internals memory sequences namespaces errors
assocs words arrays parser compiler syntax io
quotations tools prettyprint optimizer inference ;
IN: random-tester
! n-foo>bar -- list of words of type 'foo' that take n parameters
! and output a 'bar'
! Math vocabulary words
: 1-x>y
{
1+ 1- >bignum >digit >fixnum abs absq arg
bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech
cosh cot coth denominator double>bits exp float>bits floor imaginary
log neg numerator real sec ! next-power-of-2
sech sgn sin sinh sq sqrt tan tanh truncate
} ;
: 1-x>y-throws
{
recip log2
asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
} ;
: 2-x>y ( -- seq ) { * + - /f max min polar> bitand bitor bitxor align } ;
: 2-x>y-throws ( -- seq ) { / /i mod rem } ;
: 1-integer>x
{
1+ 1- >bignum >digit >fixnum abs absq arg
bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech
cosh cot coth denominator exp floor imaginary
log neg next-power-of-2 numerator real sec
sech sgn sin sinh sq sqrt tan tanh truncate
} ;
: 1-ratio>x
{
1+ 1- >bignum >digit >fixnum abs absq arg ceiling
cis conjugate cos cosec cosech
cosh cot coth exp floor imaginary
log neg next-power-of-2 real sec
sech sgn sin sinh sq sqrt tan tanh truncate
} ;
: 1-float>x ( -- seq )
{
1+ 1- >bignum >digit >fixnum abs absq arg
ceiling cis conjugate cos cosec cosech
cosh cot coth double>bits exp float>bits floor imaginary
log neg real sec ! next-power-of-2
sech sgn sin sinh sq sqrt tan tanh truncate
} ;
: 1-complex>x
{
1+ 1- abs absq arg conjugate cos cosec cosech
cosh cot coth exp imaginary log neg real
sec sech sin sinh sq sqrt tan tanh
} ;
: 1-integer>x-throws
{
recip log2
asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
} ;
: 1-ratio>x-throws
{
recip
asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
} ;
: 1-integer>integer
{
1+ 1- >bignum >digit >fixnum abs absq bitnot ceiling conjugate
denominator floor imaginary
neg next-power-of-2 numerator real sgn sq truncate
} ;
: 1-ratio>ratio
{ 1+ 1- >digit abs absq conjugate neg real sq } ;
: 1-float>float
{
1+ 1- >digit abs absq arg ceiling
conjugate exp floor neg real sq truncate
} ;
: 1-complex>complex
{
1+ 1- abs absq arg conjugate cosec cosech cosh cot coth exp log
neg sech sin sinh sq sqrt tanh
} ;
: 2-integer>x { * + - /f max min polar> bitand bitor bitxor align } ;
: 2-ratio>x { * + - /f max min polar> } ;
: 2-float>x { float+ float- float* float/f + - * /f max min polar> } ;
: 2-complex>x { * + - /f } ;
: 2-integer>integer { * + - max min bitand bitor bitxor align } ;
: 2-ratio>ratio { * + - max min } ;
: 2-float>float { float* float+ float- float/f max min /f + - } ;
: 2-complex>complex { * + - /f } ;
SYMBOL: last-quot
SYMBOL: first-arg
SYMBOL: second-arg
: 0-runtime-check ( quot -- )
#! Checks the runtime only, not the compiler
#! Evaluates the quotation twice and makes sure the results agree
[ last-quot set ] keep
[ call ] keep
call
! 2dup swap unparse write " " write unparse print flush
= [ last-quot get . "problem in runtime" throw ] unless ;
: 1-runtime-check ( quot -- )
#! Checks the runtime only, not the compiler
#! Evaluates the quotation twice and makes sure the results agree
#! For quotations that are given one argument
[ last-quot set first-arg set ] 2keep
[ call ] 2keep
call
2dup swap unparse write " " write unparse print flush
= [ "problem in runtime" throw ] unless ;
: 1-interpreted-vs-compiled-check ( x quot -- )
#! Checks the runtime output vs the compiler output
#! quot: ( x -- y )
2dup swap unparse write " " write . flush
[ last-quot set first-arg set ] 2keep
[ call ] 2keep compile-1
2dup swap unparse write " " write unparse print flush
= [ "problem in math1" throw ] unless ;
: 2-interpreted-vs-compiled-check ( x y quot -- )
#! Checks the runtime output vs the compiler output
#! quot: ( x y -- z )
.s flush
[ last-quot set first-arg set second-arg set ] 3keep
[ call ] 3keep compile-1
2dup swap unparse write " " write unparse print flush
= [ "problem in math2" throw ] unless ;
: 0-interpreted-vs-compiled-check-catch ( quot -- )
#! Check the runtime output vs the compiler output for words that throw
#!
dup .
[ last-quot set ] keep
[ catch [ "caught: " write dup print-error ] when* ] keep
[ compile-1 ] catch [ nip "caught: " write dup print-error ] when*
= [ "problem in math3" throw ] unless ;
: 1-interpreted-vs-compiled-check-catch ( quot -- )
#! Check the runtime output vs the compiler output for words that throw
2dup swap unparse write " " write .
! "." write
[ last-quot set first-arg set ] 2keep
[ catch [ nip "caught: " write dup print-error ] when* ] 2keep
[ compile-1 ] catch [ 2nip "caught: " write dup print-error ] when*
= [ "problem in math4" throw ] unless ;
: 2-interpreted-vs-compiled-check-catch ( quot -- )
#! Check the runtime output vs the compiler output for words that throw
! 3dup rot unparse write " " write swap unparse write " " write .
"." write
[ last-quot set first-arg set second-arg set ] 3keep
[ catch [ 2nip "caught: " write dup print-error ] when* ] 3keep
[ compile-1 ] catch [ 2nip nip "caught: " write dup print-error ] when*
= [ "problem in math5" throw ] unless ;
! RANDOM QUOTATIONS TO TEST
: random-1-integer>x-quot ( -- quot ) 1-integer>x random 1quotation ;
: random-1-ratio>x-quot ( -- quot ) 1-ratio>x random 1quotation ;
: random-1-float>x-quot ( -- quot ) 1-float>x random 1quotation ;
: random-1-complex>x-quot ( -- quot ) 1-complex>x random 1quotation ;
: test-1-integer>x ( -- )
random-integer random-1-integer>x-quot 1-interpreted-vs-compiled-check ;
: test-1-ratio>x ( -- )
random-ratio random-1-ratio>x-quot 1-interpreted-vs-compiled-check ;
: test-1-float>x ( -- )
random-float random-1-float>x-quot 1-interpreted-vs-compiled-check ;
: test-1-complex>x ( -- )
random-complex random-1-complex>x-quot 1-interpreted-vs-compiled-check ;
: random-1-float>float-quot ( -- obj ) 1-float>float random 1quotation ;
: random-2-float>float-quot ( -- obj ) 2-float>float random 1quotation ;
: nrandom-2-float>float-quot ( -- obj )
[
5
[
{
[ 2-float>float random , random-float , ]
[ 1-float>float random , ]
} do-one
] times
2-float>float random ,
] [ ] make ;
: test-1-float>float ( -- )
random-float random-1-float>float-quot 1-interpreted-vs-compiled-check ;
: test-2-float>float ( -- )
random-float random-float random-2-float>float-quot
2-interpreted-vs-compiled-check ;
: test-n-2-float>float ( -- )
random-float random-float nrandom-2-float>float-quot
2-interpreted-vs-compiled-check ;
: test-1-integer>x-runtime ( -- )
random-integer random-1-integer>x-quot 1-runtime-check ;
: random-1-integer>x-throws-quot ( -- obj ) 1-integer>x-throws random 1quotation ;
: random-1-ratio>x-throws-quot ( -- obj ) 1-ratio>x-throws random 1quotation ;
: test-1-integer>x-throws ( -- obj )
random-integer random-1-integer>x-throws-quot
1-interpreted-vs-compiled-check-catch ;
: test-1-ratio>x-throws ( -- obj )
random-ratio random-1-ratio>x-throws-quot
1-interpreted-vs-compiled-check-catch ;
: test-2-integer>x-throws ( -- )
[
random-integer , random-integer ,
2-x>y-throws random ,
] [ ] make 2-interpreted-vs-compiled-check-catch ;
! : test-^-ratio ( -- )
! [
! random-ratio , random-ratio , \ ^ ,
! ] [ ] make interp-compile-check-catch ;
: test-0-float?-when
[
random-number , \ dup , \ float? , 1-float>x random 1quotation , \ when ,
] [ ] make 0-runtime-check ;
: test-1-integer?-when
random-integer [
\ dup , \ integer? , 1-integer>x random 1quotation , \ when ,
] [ ] make 1-interpreted-vs-compiled-check ;
: test-1-ratio?-when
random-ratio [
\ dup , \ ratio? , 1-ratio>x random 1quotation , \ when ,
] [ ] make 1-interpreted-vs-compiled-check ;
: test-1-float?-when
random-float [
\ dup , \ float? , 1-float>x random 1quotation , \ when ,
] [ ] make 1-interpreted-vs-compiled-check ;
: test-1-complex?-when
random-complex [
\ dup , \ complex? , 1-complex>x random 1quotation , \ when ,
] [ ] make 1-interpreted-vs-compiled-check ;
: many-word-test ( -- )
#! defines words a1000 down to a0, which does a trivial addition
"random-tester-scratchpad" vocabularies get delete-at
"random-tester-scratchpad" set-in
"a0" "random-tester-scratchpad" create [ 1 1 + ] define-compound
100 [
[ 1+ "a" swap unparse append "random-tester-scratchpad" create ] keep
"a" swap unparse append [ parse ] catch [ :1 ] when define-compound
] each ;
: compile-loop ( -- )
10 [ many-word-test "a100" parse first compile ] times ;
: random-test
"----" print
{
test-1-integer>x
test-1-ratio>x
test-1-float>x
test-1-complex>x
test-1-integer>x-throws
test-1-ratio>x-throws
test-1-float>float
test-2-float>float
! test-n-2-float>float
test-1-integer>x-runtime
! test-0-float?-when
test-1-integer?-when
test-1-ratio?-when
test-1-float?-when
test-1-complex?-when
! full-gc
! code-gc
} random dup . execute nl ;

186
unmaintained/random-tester/random-tester2.factor
View File

@ -1,186 +0,0 @@
USING: compiler errors inference interpreter io kernel math
memory namespaces prettyprint random-tester sequences tools
quotations words arrays definitions generic graphs
hashtables byte-arrays assocs network ;
IN: random-tester2
: dangerous-words ( -- array )
{
die
set-walker-hook exit
>r r> ndrop
set-callstack set-word set-word-prop
set-catchstack set-namestack set-retainstack
set-continuation-retain continuation-catch
set-continuation-name catchstack retainstack
set-no-math-method-generic
set-no-math-method-right
set-check-method-class
set-check-create-name
set-pathname-string
set-check-create-vocab
set-check-method-generic
<check-create> check-create?
reset-generic forget-class
create forget-word forget-vocab forget
forget-methods forget-predicate
remove-word-prop empty-method
continue-with <continuation>
define-compound define make-generic
define-method define-predicate-class
define-tuple-class define-temp define-tuple-slots
define-writer define-predicate define-generic
(define-union-class)
define-declared define-class
define-union-class define-inline
?make-generic define-reader define-slot define-slots
define-typecheck define-slot-word define-union-class
define-simple-generic with-methods define-constructor
predicate-word condition-continuation define-symbol
tuple-predicate (sort-classes)
stdio
close readln read1 read read-until
stream-read stream-readln stream-read1 lines
contents stream-copy stream-flush
lines-loop
stream-format set-line-reader-cr
<client-stream> <server> <client>
<duplex-stream> <file-writer> <file-reader>
<style-stream> style-stream default-constructor
init-namespaces plain-writer
with-datastack <quotation> datastack-underflow.
(delegates) simple-slot , # %
<continuation> continue-with set-delegate
callcc0 callcc1
:r :s :c
(next-power-of-2) (^) d>w/w w>h/h millis
(random) ^n integer, first-bignum
most-positive-fixnum ^ init-random next-power-of-2
most-negative-fixnum
clear-assoc build-graph
set-word-def set-word-name
set-word-props
set set-axis set-delegate set-global set-restart-obj
gensym random
double>bits float>bits >bignum
class-predicates delete (delete) memq?
prune join concat group at+
normalize norm vneg vmax vmin v- v+ [v-]
times repeat (repeat)
supremum infimum at norm-sq
product sum curry remove-all member? subseq?
! O(n) on bignums
(add-vertex) (prune) (split) digits>integer
substitute ?head ?tail add-vertex all? base> closure
drop-prefix
find-last-sep format-column head? index index*
last-index mismatch push-new remove-vertex reset-props
seq-quot-uses sequence= split split, split1 start
start* string-lines string>integer tail? v.
stack-picture
! allot crashes
at+ natural-sort
# % (delegates) +@ , . .s <continuation>
<quotation> <word> be> bin> callstack changed-word
changed-words continue-with counter dec
global
hex> inc le> namespace namestack nest oct> off
on parent-dir path+
simple-slot simple-slots string>number tabular-output
unxref-word xref-word xref-words vocabularies
with-datastack
bind if-graph ! 0 >n ! GCs
move-backward move-forward open-slice (open-slice) ! infinite loop
(assoc-stack) ! infinite loop
case ! 100000000000 t case ! takes a long time
} ;
: safe-words ( -- array )
dangerous-words {
"arrays" "assocs" "bit-arrays" "byte-arrays"
"errors" "generic" "graphs" "hashtables" "io"
"kernel" "math" "namespaces" "quotations" "sbufs"
"queues" "strings" "sequences" "vectors" "words"
} [ words ] map concat seq-diff natural-sort ;
safe-words \ safe-words set-global
: databank ( -- array )
{
! V{ } H{ } V{ 3 } { 3 } { } "" "asdf"
pi 1/0. -1/0. 0/0. [ ]
f t "" 0 0.0 3.14 2 -3 -7 20 3/4 -3/4 1.2/3 3.5
C{ 2 2 } C{ 1/0. 1/0. }
} ;
: setup-test ( #data #code -- data... quot )
#! variable stack effect
>r [ databank random ] times r>
[ drop \ safe-words get random ] map >quotation ;
SYMBOL: before
SYMBOL: after
SYMBOL: quot
SYMBOL: err
err off
: test-compiler ( data... quot -- ... )
err off
dup quot set
datastack clone dup pop* before set
[ call ] catch drop datastack clone after set
clear
before get [ ] each
quot get [ compile-1 ] [ err on ] recover ;
: do-test ( data... quot -- )
.s flush test-compiler
err get [
datastack after get 2dup = [
2drop
] [
[ . ] each
"--" print [ . ] each quot get .
"not =" throw
] if
] unless
clear ;
: random-test* ( #data #code -- )
setup-test do-test ;
: run-random-tester2
100000000000000 [ 6 3 random-test* ] times ;
! A worthwhile test that has not been run extensively
1000 [ drop gensym ] map "syms" set-global
: fooify-test
"syms" get-global random
2000 random >quotation
over set-word-def
100 random zero? [ code-gc ] when
compile fooify-test ;

218
unmaintained/random-tester/type.factor
View File

@ -1,218 +0,0 @@
USING: arrays errors generic hashtables io kernel lazy-lists math
memory modules namespaces null-stream prettyprint random-tester2
quotations sequences strings
tools vectors words ;
IN: random-tester
: inert ;
TUPLE: inert-object ;
: inputs ( -- seq )
{
0 -1 -1000000000000000000000000 2
inert
-29/2
1000000000000000000000000000000/1111111111111111111111111111111111
3/4
-1000000000000000000000000/111111111111111111
-3.14 1/0. 0.0 -1/0. 3.14 0/0.
20102101010100110110
C{ 1 -1 }
W{ 55 }
{ }
f t
""
"asdf"
[ ]
! DLL" libm.dylib"
! ALIEN: 1
T{ inert-object f }
}
[
H{ { 1 2 } { "asdf" "foo" } } clone ,
H{ } clone ,
V{ 1 0 65536 } clone ,
V{ } clone ,
SBUF" " clone ,
B{ } clone ,
?{ } clone ,
] { } make append ;
TUPLE: success quot inputs outputs input-types output-types ;
SYMBOL: err
SYMBOL: last-time
SYMBOL: quot
SYMBOL: output
SYMBOL: input
SYMBOL: silent
t silent set-global
: test-quot ( input quot -- success/f )
! 2dup swap . . flush
! dup [ hash+ ] = [ 2dup . . flush ] when
err off
quot set input set
silent get [
quot get last-time get = [
quot get
dup . flush
last-time set
] unless
] unless
[
clear
input get >vector set-datastack quot get
[ [ [ call ] { } make drop ] with-null-stream ]
[ err on ] recover
datastack clone output set
] with-saved-datastack
err get [
f
] [
quot get input get output get
2dup [ [ type ] map ] 2apply <success>
] if ;
: test-inputs ( word -- seq )
[
[ word-input-count inputs swap ] keep
1quotation [
test-quot [ , ] when*
] curry each-permutation
] { } make ;
: >types ( quot -- seq )
map concat prune natural-sort ;
: >output-types ( seq -- seq )
#! input seq is the result of test-inputs
[ success-output-types ] >types ;
: >input-types ( seq -- seq )
#! input seq is the result of test-inputs
[ success-input-types ] >types ;
TUPLE: typed quot inputs outputs ;
: successes>typed ( seq -- typed )
dup empty? [
drop f { } clone { } clone <typed>
] [
[ first success-quot ] keep
[ >input-types ] keep >output-types <typed>
] if ;
: word>type-check ( word -- tuple )
[
dup test-inputs
successes>typed ,
] curry [ with-saved-datastack ] { } make first ;
: type>name ( n -- string )
dup integer? [
{
"fixnum"
"bignum"
"word"
"obj"
"ratio"
"float"
"complex"
"wrapper"
"array"
"boolean"
"hashtable"
"vector"
"string"
"sbuf"
"quotation"
"dll"
"alien"
"tuple"
} nth
] when ;
: replace-subseqs ( seq new old -- seq )
[
swapd split1 [ append swap add ] [ nip ] if*
] 2each ;
: type-array>name ( seq -- seq )
{
{ "object" { 0 1 2 4 5 6 7 8 9 10 11 12 13 14 15 16 17 } }
{ "seq3" { 0 1 8 9 11 12 13 14 } }
{ "seq2" { 0 8 9 11 12 13 14 } }
{ "seq" { 8 9 11 12 13 14 } }
{ "number" { 0 1 4 5 6 } }
{ "real" { 0 1 4 5 } }
{ "rational" { 0 1 4 } }
{ "integer" { 0 1 } }
{ "float/complex" { 5 6 } }
{ "word/f" { 2 9 } }
} flip first2 replace-subseqs [ type>name ] map ;
: buggy?
[ word>type-check ] catch [
drop f
] [
2array [ [ type-array>name ] map ] map
[ [ length 1 = ] all? ] all? not
] if ;
: variable-stack-effect?
[ word>type-check ] catch nip ;
: find-words ( quot -- seq )
\ safe-words get
[
word-input-count 3 <=
] subset swap subset ;
: find-safe ( -- seq ) [ buggy? not ] find-words ;
: find-buggy ( -- seq ) [ buggy? ] find-words ;
: test-word ( output input word -- ? )
1quotation test-quot dup [
success-outputs sequence=
] [
nip
] if ;
: word-finder ( inputs outputs -- seq )
swap safe-words
[ >r 2dup r> test-word ] subset 2nip ;
: (enumeration-test)
[
[ stack-effect effect-in length ] catch [ 4 < ] unless
] subset [ [ test-inputs successes>typed , ] each ] { } make ;
! full-gc finds corrupted memory faster
: enumeration-test ( -- seq )
[
\ safe-words get
f silent set
(enumeration-test)
] with-scope ;
: array>all-quots ( seq n -- seq )
[
[ 1+ [ >quotation , ] each-permutation ] each-with
] { } make ;
: array>all ( seq n -- seq )
dupd array>all-quots append ;
: quot-finder ( inputs outputs -- seq )
swap safe-words 2 array>all
[
3 [ >quotation >r 2dup r> [ test-quot ] keep
swap [ , ] [ drop ] if ] each-permutation
] { } make ;
: word-frequency ( -- alist )
all-words [ dup usage length 2array ] map sort-values ;

77
unmaintained/random-tester/utils.factor
View File

@ -1,77 +0,0 @@
USING: generic kernel math sequences namespaces errors
assocs words arrays parser compiler syntax io
quotations optimizer inference shuffle tools prettyprint ;
IN: random-tester
: word-input-count ( word -- n )
[ stack-effect effect-in length ] [ 2drop 0 ] recover ;
: type-error? ( exception -- ? )
[ swap execute or ] curry
>r { no-method? no-math-method? } f r> reduce ;
! HASHTABLES
: random-hash-entry ( hash -- key value )
[ keys random dup ] keep at ;
: coin-flip ( -- bool ) 2 random zero? ;
: do-one ( seq -- ) random call ; inline
: nzero-array ( seq -- )
dup length >r 0 r> [ pick set-nth ] each-with drop ;
: zero-array ( n -- seq ) [ drop 0 ] map ;
TUPLE: p-list seq max count count-vec ;
: make-p-list ( seq n -- tuple )
>r dup length [ 1- ] keep r>
[ ^ 0 swap 2array ] keep
zero-array <p-list> ;
: inc-seq ( seq max -- )
2dup [ < ] curry find-last over -1 = [
3drop nzero-array
] [
nipd 1+ 2over swap set-nth
1+ over length rot <slice> nzero-array
] if ;
: inc-count ( tuple -- )
[ p-list-count first2 >r 1+ r> 2array ] keep
set-p-list-count ;
: get-permutation ( tuple -- seq )
[ p-list-seq ] keep p-list-count-vec [ swap nth ] map-with ;
: p-list-next ( tuple -- seq/f )
dup p-list-count first2 < [
[
[ get-permutation ] keep
[ p-list-count-vec ] keep p-list-max
inc-seq
] keep inc-count
] [
drop f
] if ;
: (permutations) ( tuple -- )
dup p-list-next [ , (permutations) ] [ drop ] if* ;
: permutations ( seq n -- seq )
make-p-list [ (permutations) ] { } make ;
: (each-permutation) ( tuple quot -- )
over p-list-next [
[ rot drop swap call ] 3keep
drop (each-permutation)
] [
2drop
] if* ; inline
: each-permutation ( seq n quot -- )
>r make-p-list r> (each-permutation) ;
SYMBOL: saved-datastack
: with-saved-datastack
>r datastack saved-datastack set r> call
saved-datastack get set-datastack ; inline

10
unmaintained/regexp/load.factor
View File

@ -1,10 +0,0 @@
REQUIRES: libs/memoize ;
PROVIDE: libs/regexp
{ +files+ {
"tables.factor"
"regexp.factor"
} } { +tests+ {
"test/regexp.factor"
"test/tables.factor"
} } ;

501
unmaintained/regexp/regexp.factor
View File

@ -1,501 +0,0 @@
USING: arrays errors generic assocs io kernel math
memoize namespaces kernel sequences strings tables
vectors ;
USE: interpreter
USE: prettyprint
USE: test
IN: regexp-internals
SYMBOL: trans-table
SYMBOL: eps
SYMBOL: start-state
SYMBOL: final-state
SYMBOL: paren-count
SYMBOL: currentstate
SYMBOL: stack
SYMBOL: bot
SYMBOL: eot
SYMBOL: alternation
SYMBOL: lparen
SYMBOL: rparen
: regexp-init ( -- )
0 paren-count set
-1 currentstate set
V{ } clone stack set
<vector-table> final-state over add-column trans-table set ;
: paren-underflow? ( -- )
paren-count get 0 < [ "too many rparen" throw ] when ;
: unbalanced-paren? ( -- )
paren-count get 0 > [ "neesds closing paren" throw ] when ;
: inc-paren-count ( -- )
paren-count [ 1+ ] change ;
: dec-paren-count ( -- )
paren-count [ 1- ] change paren-underflow? ;
: push-stack ( n -- ) stack get push ;
: next-state ( -- n )
currentstate [ 1+ ] change currentstate get ;
: current-state ( -- n ) currentstate get ;
: set-trans-table ( row col data -- )
<entry> trans-table get set-value ;
: add-trans-table ( row col data -- )
<entry> trans-table get add-value ;
: data-stack-slice ( token -- seq )
stack get reverse [ index ] keep cut reverse dup pop* stack set reverse ;
: find-start-state ( table -- n )
start-state t rot find-by-column first ;
: find-final-state ( table -- n )
final-state t rot find-by-column first ;
: final-state? ( row table -- ? )
get-row final-state swap key? ;
: switch-rows ( r1 r2 -- )
[ 2array [ trans-table get get-row ] each ] 2keep
2array [ trans-table get set-row ] each ;
: set-table-prop ( prop s table -- )
pick over add-column table-rows
[
pick rot member? [
pick t swap rot set-at
] [
drop
] if
] assoc-each 2drop ;
: add-numbers ( n obj -- obj )
dup sequence? [
[ + ] map-with
] [
dup number? [ + ] [ nip ] if
] if ;
: increment-cols ( n row -- )
! n row
dup [ >r pick r> add-numbers swap pick set-at ] assoc-each 2drop ;
: complex-count ( c -- ci-cr+1 )
>rect swap - 1+ ;
: copy-rows ( c1 -- )
#! copy rows to the bottom with a new row-name c1_range higher
[ complex-count ] keep trans-table get table-rows ! 2 C{ 0 1 } rows
[ drop [ over real >= ] keep pick imaginary <= and ] assoc-subset nip
[ clone [ >r over r> increment-cols ] keep swap pick + trans-table get set-row ] assoc-each ! 2
currentstate get 1+ dup pick + 1- rect> push-stack
currentstate [ + ] change ;
! s1 final f ! s1 eps s2 ! output s0,s3
: apply-concat ( seq -- )
! "Concat: " write dup .
dup pop over pop swap
over imaginary final-state f set-trans-table
2dup >r imaginary eps r> real add-trans-table
>r real r> imaginary rect> swap push ;
! swap 0, 4 so 0 is incoming
! ! s1 final f ! s3 final f ! s4 e s0 ! s4 e s2 ! s1 e s5 ! s3 e s5
! ! s5 final t ! s4,s5 push
SYMBOL: saved-state
: apply-alternation ( seq -- )
! "Alternation: " print
dup pop over pop* over pop swap
next-state trans-table get add-row
>r >rect >r saved-state set current-state r> rect> r>
! 4,1 2,3
over real saved-state get trans-table get swap-rows
saved-state get start-state t set-trans-table
over real start-state f set-trans-table
over imaginary final-state f set-trans-table
dup imaginary final-state f set-trans-table
over real saved-state get eps rot add-trans-table
dup real saved-state get eps rot add-trans-table
imaginary eps next-state add-trans-table
imaginary eps current-state add-trans-table
current-state final-state t set-trans-table
saved-state get current-state rect> swap push ;
! s1 final f ! s1 e s0 ! s2 e s0 ! s2 e s3 ! s1 e s3 ! s3 final t
: apply-kleene-closure ( -- )
! "Apply kleene closure" print
stack get pop
next-state trans-table get add-row
>rect >r [ saved-state set ] keep current-state
[ trans-table get swap-rows ] keep r> rect>
dup imaginary final-state f set-trans-table
dup imaginary eps pick real add-trans-table
saved-state get eps pick real add-trans-table
saved-state get eps next-state add-trans-table
imaginary eps current-state add-trans-table
current-state final-state t add-trans-table
saved-state get current-state rect> push-stack ;
: apply-plus-closure ( -- )
! "Apply plus closure" print
stack get peek copy-rows
apply-kleene-closure stack get apply-concat ;
: apply-alternation? ( seq -- ? )
dup length dup 3 < [
2drop f
] [
2 - swap nth alternation =
] if ;
: apply-concat? ( seq -- ? )
dup length dup 2 < [
2drop f
] [
2 - swap nth complex?
] if ;
: (apply) ( slice -- slice )
dup length 1 > [
{
{ [ dup apply-alternation? ]
[ [ apply-alternation ] keep (apply) ] }
{ [ dup apply-concat? ]
[ [ apply-concat ] keep (apply) ] }
} cond
] when ;
: apply-til-last ( tokens -- slice )
data-stack-slice (apply) ;
: maybe-concat ( -- )
stack get apply-concat? [ stack get apply-concat ] when ;
: maybe-concat-loop ( -- )
stack get length maybe-concat stack get length > [
maybe-concat-loop
] when ;
: create-nontoken-nfa ( tok -- )
next-state swap next-state <entry>
[ trans-table get set-value ] keep
entry-value final-state t set-trans-table
current-state [ 1- ] keep rect> push-stack ;
! stack gets: alternation C{ 0 1 }
: apply-question-closure ( -- )
alternation push-stack
eps create-nontoken-nfa stack get apply-alternation ;
! {2} exactly twice, {2,} 2 or more, {2,4} exactly 2,3,4 times
! : apply-bracket-closure ( c1 -- )
! ;
SYMBOL: character-class
SYMBOL: brace
SYMBOL: escaped-character
SYMBOL: octal
SYMBOL: hex
SYMBOL: control
SYMBOL: posix
: addto-character-class ( char -- )
;
: make-escaped ( char -- )
{
! TODO: POSIX character classes (US-ASCII only)
! TODO: Classes for Unicode blocks and categories
! { CHAR: { [ ] } ! left brace
{ CHAR: \\ [ ] } ! backaslash
{ CHAR: 0 [ ] } ! octal \0n \0nn \0mnn (0 <= m <= 3, 0 <= n <= 7)
{ CHAR: x [ ] } ! \xhh
{ CHAR: u [ ] } ! \uhhhh
{ CHAR: t [ ] } ! tab \u0009
{ CHAR: n [ ] } ! newline \u000a
{ CHAR: r [ ] } ! carriage-return \u000d
{ CHAR: f [ ] } ! form-feed \u000c
{ CHAR: a [ ] } ! alert (bell) \u0007
{ CHAR: e [ ] } ! escape \u001b
{ CHAR: c [ ] } ! control character corresoding to X in \cX
{ CHAR: d [ ] } ! [0-9]
{ CHAR: D [ ] } ! [^0-9]
{ CHAR: s [ ] } ! [ \t\n\x0B\f\r]
{ CHAR: S [ ] } ! [^\s]
{ CHAR: w [ ] } ! [a-zA-Z_0-9]
{ CHAR: W [ ] } ! [^\w]
{ CHAR: b [ ] } ! a word boundary
{ CHAR: B [ ] } ! a non-word boundary
{ CHAR: A [ ] } ! the beginning of input
{ CHAR: G [ ] } ! the end of the previous match
{ CHAR: Z [ ] } ! the end of the input but for the
! final terminator, if any
{ CHAR: z [ ] } ! the end of the input
} case ;
: handle-character-class ( char -- )
{
{ [ \ escaped-character get ] [ make-escaped \ escaped-character off ] }
{ [ dup CHAR: ] = ] [ \ character-class off ] }
{ [ t ] [ addto-character-class ] }
} cond ;
: parse-token ( char -- )
{
! { [ \ character-class get ] [ ] }
! { [ \ escaped-character get ] [ ] }
! { [ dup CHAR: [ = ] [ \ character-class on ] }
! { [ dup CHAR: \\ = ] [ drop \ escaped-character on ] }
! { [ dup CHAR: ^ = ] [ ] }
! { [ dup CHAR: $ = ] [ ] }
! { [ dup CHAR: { = ] [ ] }
! { [ dup CHAR: } = ] [ ] }
{ [ dup CHAR: | = ]
[ drop maybe-concat-loop alternation push-stack ] }
{ [ dup CHAR: * = ]
[ drop apply-kleene-closure ] }
{ [ dup CHAR: + = ]
[ drop apply-plus-closure ] }
{ [ dup CHAR: ? = ]
[ drop apply-question-closure ] }
{ [ dup CHAR: ( = ]
[ drop inc-paren-count lparen push-stack ] }
{ [ dup CHAR: ) = ]
[
drop dec-paren-count lparen apply-til-last
stack get push-all
] } ! apply
{ [ dup bot = ] [ push-stack ] }
{ [ dup eot = ]
[
drop unbalanced-paren? maybe-concat-loop bot apply-til-last
dup length 1 = [
pop real start-state t set-trans-table
] [
drop
] if
] }
{ [ t ] [ create-nontoken-nfa ] }
} cond ;
: cut-at-index ( i string ch -- i subseq )
-rot [ index* ] 2keep >r >r [ 1+ ] keep r> swap r> subseq ;
: parse-character-class ( index string -- new-index obj )
2dup >r 1+ r> nth CHAR: ] = [ >r 1+ r> ] when
cut-at-index ;
: (parse-regexp) ( str -- )
dup length [
2dup swap character-class get [
parse-character-class
"CHARACTER CLASS: " write .
character-class off
nip ! adjust index
] [
nth parse-token
] if
] repeat ;
: parse-regexp ( str -- )
bot parse-token
! [ "parsing: " write dup ch>string . parse-token ] each
[ parse-token ] each
! (parse-regexp)
eot parse-token ;
: push-all-diff ( seq seq -- diff )
[ swap seq-diff ] 2keep push-all ;
: prune-sort ( vec -- vec )
prune natural-sort >vector ;
SYMBOL: ttable
SYMBOL: transition
SYMBOL: check-list
SYMBOL: initial-check-list
SYMBOL: result
: init-find ( data state table -- )
ttable set
dup sequence? [ clone >vector ] [ V{ } clone [ push ] keep ] if
[ check-list set ] keep clone initial-check-list set
V{ } clone result set
transition set ;
: (find-next-state) ( -- )
check-list get [
[
ttable get get-row transition get swap at*
[ dup sequence? [ % ] [ , ] if ] [ drop ] if
] each
] { } make
result get push-all-diff
check-list set
result get prune-sort result set ;
: (find-next-state-recursive) ( -- )
check-list get empty? [ (find-next-state) (find-next-state-recursive) ] unless ;
: find-epsilon-closure ( state table -- vec )
eps -rot init-find
(find-next-state-recursive) result get initial-check-list get append natural-sort ;
: find-next-state ( data state table -- vec )
find-epsilon-closure check-list set
V{ } clone result set transition set
(find-next-state) result get ttable get find-epsilon-closure ;
: filter-cols ( vec -- vec )
#! remove info columns state-state, eps, final
clone start-state over delete-at eps over delete-at
final-state over delete-at ;
SYMBOL: old-table
SYMBOL: new-table
SYMBOL: todo-states
SYMBOL: transitions
: init-nfa>dfa ( table -- )
<vector-table> new-table set
[ table-columns clone filter-cols keys transitions set ] keep
dup [ find-start-state ] keep find-epsilon-closure
V{ } clone [ push ] keep todo-states set
old-table set ;
: create-row ( state table -- )
2dup row-exists?
[ 2drop ] [ [ add-row ] 2keep drop todo-states get push ] if ;
: (nfa>dfa) ( -- )
todo-states get dup empty? [
pop transitions get [
2dup swap old-table get find-next-state
dup empty? [
3drop
] [
dup new-table get create-row
<entry> new-table get set-value
] if
] each-with
] unless* todo-states get empty? [ (nfa>dfa) ] unless ;
: nfa>dfa ( table -- table )
init-nfa>dfa
(nfa>dfa)
start-state old-table get find-start-state
new-table get set-table-prop
final-state old-table get find-final-state
new-table get [ set-table-prop ] keep ;
SYMBOL: regexp
SYMBOL: text
SYMBOL: matches
SYMBOL: partial-matches
TUPLE: partial-match index row count ;
! a state is a vector
! state is a key in a hashtable. the value is a hashtable of transition states
: save-partial-match ( index row -- )
1 <partial-match> dup partial-match-index
\ partial-matches get set-at ;
: inc-partial-match ( partial-match -- )
[ partial-match-count 1+ ] keep set-partial-match-count ;
: check-final-state ( partial-match -- )
dup partial-match-row regexp get final-state? [
clone dup partial-match-index matches get set-at
] [
drop
] if ;
: check-trivial-match ( row regexp -- )
dupd final-state? [
>r 0 r> 0 <partial-match>
0 matches get set-at
] [
drop
] if ;
: update-partial-match ( char partial-match -- )
tuck partial-match-row regexp get get-row at* [
over set-partial-match-row
inc-partial-match
] [
drop
partial-match-index partial-matches get delete-at
] if ;
: regexp-step ( index char start-state -- )
! check partial-matches
over \ partial-matches get
[ nip update-partial-match ] assoc-each-with
! check new match
at* [
save-partial-match
] [
2drop
] if
partial-matches get values [ check-final-state ] each ;
: regexp-match ( text regexp -- seq )
#! text is the haystack
#! regexp is a table describing the needle
H{ } clone \ matches set
H{ } clone \ partial-matches set
dup regexp set
>r dup text set r>
[ find-start-state ] keep
2dup check-trivial-match
get-row
swap [ length ] keep
[ pick regexp-step ] 2each drop
matches get values [
[ partial-match-index ] keep
partial-match-count dupd + text get <slice>
] map ;
IN: regexp
MEMO: make-regexp ( str -- table )
[
regexp-init
parse-regexp
trans-table get nfa>dfa
] with-scope ;
! TODO: make compatible with
! http://java.sun.com/j2se/1.4.2/docs/api/java/util/regex/Pattern.html
! Greedy
! Match the longest possible string, default
! a+
! Reluctant
! Match on shortest possible string
! / in vi does this (find next)
! a+?
! Possessive
! Match only when the entire text string matches
! a++

111
unmaintained/regexp/tables.factor
View File

@ -1,111 +0,0 @@
USING: errors generic kernel namespaces
sequences vectors assocs ;
IN: tables
TUPLE: table rows columns ;
TUPLE: entry row-key column-key value ;
GENERIC: add-value ( entry table -- )
C: table ( -- obj )
H{ } clone over set-table-rows
H{ } clone over set-table-columns ;
: (add-row) ( row-key table -- row )
2dup table-rows at* [
2nip
] [
drop H{ } clone [ -rot table-rows set-at ] keep
] if ;
: add-row ( row-key table -- )
(add-row) drop ;
: add-column ( column-key table -- )
t -rot table-columns set-at ;
: set-row ( row row-key table -- )
table-rows set-at ;
: lookup-row ( row-key table -- row/f ? )
table-rows at* ;
: row-exists? ( row-key table -- ? )
lookup-row nip ;
: lookup-column ( column-key table -- column/f ? )
table-columns at* ;
: column-exists? ( column-key table -- ? )
lookup-column nip ;
TUPLE: no-row key ;
TUPLE: no-column key ;
: get-row ( row-key table -- row )
dupd lookup-row [
nip
] [
drop <no-row> throw
] if ;
: get-column ( column-key table -- column )
dupd lookup-column [
nip
] [
drop <no-column> throw
] if ;
: get-value ( row-key column-key table -- obj ? )
swapd lookup-row [
at*
] [
2drop f f
] if ;
: (set-value) ( entry table -- value column-key row )
[ >r entry-column-key r> add-column ] 2keep
dupd >r entry-row-key r> (add-row)
>r [ entry-value ] keep entry-column-key r> ;
: set-value ( entry table -- )
(set-value) set-at ;
: swap-rows ( row-key1 row-key2 table -- )
[ tuck get-row >r get-row r> ] 3keep
>r >r rot r> r> [ set-row ] keep set-row ;
: member?* ( obj obj -- bool )
2dup = [ 2drop t ] [ member? ] if ;
: find-by-column ( column-key data table -- seq )
swapd 2dup lookup-column 2drop
[
table-rows [
pick swap at* [
>r pick r> member?* [ , ] [ drop ] if
] [
2drop
] if
] assoc-each
] { } make 2nip ;
TUPLE: vector-table ;
C: vector-table ( -- obj )
<table> over set-delegate ;
: add-hash-vector ( value key hash -- )
2dup at* [
dup vector? [
2nip push
] [
V{ } clone [ push ] keep
-rot >r >r [ push ] keep r> r> set-at
] if
] [
drop set-at
] if ;
M: vector-table add-value ( entry table -- )
(set-value) add-hash-vector ;

30
unmaintained/regexp/test/regexp.factor
View File

@ -1,30 +0,0 @@
USING: kernel sequences namespaces errors io math tables arrays generic hashtables vectors strings parser ;
USING: prettyprint test ;
USING: regexp-internals regexp ;
[ "dog" ] [ "dog" "cat|dog" make-regexp regexp-match first >string ] unit-test
[ "cat" ] [ "cat" "cat|dog" make-regexp regexp-match first >string ] unit-test
[ "a" ] [ "a" "a|b|c" make-regexp regexp-match first >string ] unit-test
[ "" ] [ "" "a*" make-regexp regexp-match first >string ] unit-test
[ "aaaa" ] [ "aaaa" "a*" make-regexp regexp-match first >string ] unit-test
[ "aaaa" ] [ "aaaa" "a+" make-regexp regexp-match first >string ] unit-test
[ t ] [ "" "a+" make-regexp regexp-match empty? ] unit-test
[ "cadog" ] [ "cadog" "ca(t|d)og" make-regexp regexp-match first >string ] unit-test
[ "catog" ] [ "catog" "ca(t|d)og" make-regexp regexp-match first >string ] unit-test
[ "cadog" ] [ "abcadoghi" "ca(t|d)og" make-regexp regexp-match first >string ] unit-test
[ t ] [ "abcatdoghi" "ca(t|d)og" make-regexp regexp-match empty? ] unit-test
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" "a+b+c+d+e+f+g+h+i+j+k+l+m+n+o+p+q+r+s+t+u+v+w+x+y+z+" make-regexp regexp-match first >string ] unit-test
[ "aabbccddeeffgghhiijjkkllmmnnooppqqrrssttuuvvwwxxyyzz" ] [ "aabbccddeeffgghhiijjkkllmmnnooppqqrrssttuuvvwwxxyyzz" "a+b+c+d+e+f+g+h+i+j+k+l+m+n+o+p+q+r+s+t+u+v+w+x+y+z+" make-regexp regexp-match first >string ] unit-test
[ t ] [ "aabbccddeeffgghhiijjkkllmmnnooppqqrrssttuuvvwwxxyy" "a+b+c+d+e+f+g+h+i+j+k+l+m+n+o+p+q+r+s+t+u+v+w+x+y+z+" make-regexp regexp-match empty? ] unit-test
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" "a*b*c*d*e*f*g*h*i*j*k*l*m*n*o*p*q*r*s*t*u*v*w*x*y*z*" make-regexp regexp-match first >string ] unit-test
[ "" ] [ "" "a*b*c*d*e*f*g*h*i*j*k*l*m*n*o*p*q*r*s*t*u*v*w*x*y*z*" make-regexp regexp-match first >string ] unit-test
[ "az" ] [ "az" "a*b*c*d*e*f*g*h*i*j*k*l*m*n*o*p*q*r*s*t*u*v*w*x*y*z*" make-regexp regexp-match first >string ] unit-test
[ t ] [ "abc" "a?b?c?" make-regexp regexp-match length 3 = ] unit-test
[ "ac" ] [ "ac" "a?b?c?" make-regexp regexp-match first >string ] unit-test
[ "" ] [ "" "a?b?c?" make-regexp regexp-match first >string ] unit-test
[ t ] [ "aabc" "a?b?c?" make-regexp regexp-match length 4 = ] unit-test
[ "abbbccdefefffeffe" ] [ "abbbccdefefffeffe" "(a?b*c+d(e|f)*)+" make-regexp regexp-match first >string ] unit-test
[ t ] [ "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" make-regexp regexp-match length 29 = ] unit-test

49
unmaintained/regexp/test/tables.factor
View File

@ -1,49 +0,0 @@
USING: kernel tables test ;
: test-table
<table>
"a" "c" "z" <entry> over set-value
"a" "o" "y" <entry> over set-value
"a" "l" "x" <entry> over set-value
"b" "o" "y" <entry> over set-value
"b" "l" "x" <entry> over set-value
"b" "s" "u" <entry> over set-value ;
[
T{ table f
H{
{ "a" H{ { "l" "x" } { "c" "z" } { "o" "y" } } }
{ "b" H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
}
H{ { "l" t } { "s" t } { "c" t } { "o" t } } }
] [ test-table ] unit-test
[ "x" t ] [ "a" "l" test-table get-value ] unit-test
[ "har" t ] [
"a" "z" "har" <entry> test-table [ set-value ] keep
>r "a" "z" r> get-value
] unit-test
: vector-test-table
<vector-table>
"a" "c" "z" <entry> over add-value
"a" "c" "r" <entry> over add-value
"a" "o" "y" <entry> over add-value
"a" "l" "x" <entry> over add-value
"b" "o" "y" <entry> over add-value
"b" "l" "x" <entry> over add-value
"b" "s" "u" <entry> over add-value ;
[
T{ vector-table
T{ table f
H{
{ "a"
H{ { "l" "x" } { "c" V{ "z" "r" } } { "o" "y" } } }
{ "b"
H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
}
H{ { "l" t } { "s" t } { "c" t } { "o" t } } }
}
] [ vector-test-table ] unit-test