Merge commit 'erg/master'
Slava Pestov
commit
964495e354
|
|
@ -58,3 +58,5 @@ IN: temporary
|
|||
[ dup array? ] [ dup vector? ] [ dup float? ]
|
||||
} || nip
|
||||
] unit-test
|
||||
|
||||
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test
|
||||
|
|
|
|||
|
|
@ -67,6 +67,12 @@ MACRO: napply ( n -- )
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Aaron Schaefer
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1 @@
|
|||
EditPlus editor integration
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1 @@
|
|||
EmEditor integration
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
TED Notepad integration
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
UltraEdit editor integration
|
||||
|
|
@ -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
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
USING: assocs http.parser kernel math sequences strings ;
|
||||
IN: http.parser.analyzer
|
||||
USING: assocs html.parser kernel math sequences strings ;
|
||||
IN: html.parser.analyzer
|
||||
|
||||
: 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
|
||||
! "Currency" "name" pick find-first-attribute-key-value
|
||||
! pick find-between remove-blank-text
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: browser.parser kernel tools.test ;
|
||||
USING: html.parser kernel tools.test ;
|
||||
IN: temporary
|
||||
|
||||
[
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
USING: arrays http.parser.utils hashtables io kernel
|
||||
USING: arrays html.parser.utils hashtables io kernel
|
||||
namespaces prettyprint quotations
|
||||
sequences splitting state-parser strings ;
|
||||
IN: http.parser
|
||||
IN: html.parser
|
||||
|
||||
TUPLE: tag name attributes text matched? closing? ;
|
||||
|
||||
|
|
@ -120,7 +120,7 @@ SYMBOL: tagstack
|
|||
] unless ;
|
||||
|
||||
: parse-attributes ( -- hashtable )
|
||||
[ (parse-attributes) ] { } make >hashtable ;
|
||||
[ (parse-attributes) ] { } make >hashtable ;
|
||||
|
||||
: (parse-tag)
|
||||
[
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
USING: assocs http.parser browser.utils combinators
|
||||
USING: assocs html.parser html.parser.utils combinators
|
||||
continuations hashtables
|
||||
hashtables.private io kernel math
|
||||
namespaces prettyprint quotations sequences splitting
|
||||
state-parser strings ;
|
||||
IN: http.parser.printer
|
||||
IN: html.parser.printer
|
||||
|
||||
SYMBOL: no-section
|
||||
SYMBOL: html
|
||||
|
|
@ -42,7 +42,7 @@ HOOK: print-closing-named-tag printer ( tag -- )
|
|||
M: printer print-text-tag ( tag -- )
|
||||
tag-text write ;
|
||||
|
||||
M: printer print-comment-tag ( tag -- )
|
||||
M: printer print-comment-tag ( tag -- )
|
||||
"<!--" write
|
||||
tag-text write
|
||||
"-->" write ;
|
||||
|
|
@ -67,7 +67,6 @@ M: printer print-closing-named-tag ( tag -- )
|
|||
[
|
||||
swap bl write "=" write ?quote write
|
||||
] assoc-each ;
|
||||
|
||||
|
||||
M: src-printer print-opening-named-tag ( tag -- )
|
||||
"<" write
|
||||
|
|
@ -102,7 +101,7 @@ SYMBOL: tablestack
|
|||
[
|
||||
V{ } clone tablestack set
|
||||
] with-scope ;
|
||||
|
||||
|
||||
! { { 1 2 } { 3 4 } }
|
||||
! H{ { table-gap { 10 10 } } } [
|
||||
! [ [ [ [ . ] with-cell ] each ] with-row ] each
|
||||
|
|
@ -2,7 +2,7 @@ USING: assocs combinators continuations hashtables
|
|||
hashtables.private io kernel math
|
||||
namespaces prettyprint quotations sequences splitting
|
||||
state-parser strings tools.test ;
|
||||
USING: browser.utils ;
|
||||
USING: html.parser.utils ;
|
||||
IN: temporary
|
||||
|
||||
[ "'Rome'" ] [ "Rome" single-quote ] unit-test
|
||||
|
|
@ -2,8 +2,8 @@ USING: assocs circular combinators continuations hashtables
|
|||
hashtables.private io kernel math
|
||||
namespaces prettyprint quotations sequences splitting
|
||||
state-parser strings ;
|
||||
USING: http.parser ;
|
||||
IN: http.parser.utils
|
||||
USING: html.parser ;
|
||||
IN: html.parser.utils
|
||||
|
||||
: string-parse-end?
|
||||
get-next not ;
|
||||
|
|
@ -149,9 +149,3 @@ IN: scratchpad
|
|||
{ { } } [
|
||||
"234" "1" token <+> parse list>array
|
||||
] 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
|
||||
|
||||
|
|
|
|||
|
|
@ -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. }
|
||||
} ;
|
||||
|
||||
|
|
@ -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
0
unmaintained/random-tester/random.factor → extra/random-tester/random/random.factor
Normal file → Executable 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
|
||||
|
||||
|
|
@ -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) ;
|
||||
|
||||
|
||||
|
|
@ -2,6 +2,7 @@ USING: arrays combinators kernel lazy-lists math math.parser
|
|||
namespaces parser parser-combinators parser-combinators.simple
|
||||
promises quotations sequences combinators.lib strings macros
|
||||
assocs prettyprint.backend ;
|
||||
USE: io
|
||||
IN: regexp
|
||||
|
||||
: or-predicates ( quots -- quot )
|
||||
|
|
@ -40,7 +41,7 @@ MACRO: fast-member? ( str -- quot )
|
|||
dup alpha? swap punct? or ;
|
||||
|
||||
: 'ordinary-char' ( -- parser )
|
||||
[ "\\^*+?|(){}[" fast-member? not ] satisfy
|
||||
[ "\\^*+?|(){}[$" fast-member? not ] satisfy
|
||||
[ [ = ] curry ] <@ ;
|
||||
|
||||
: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
|
||||
|
|
@ -158,23 +159,39 @@ C: <group-result> group-result
|
|||
'char' <|>
|
||||
'character-class' <|> ;
|
||||
|
||||
: 'interval' ( -- parser )
|
||||
: 'greedy-interval' ( -- parser )
|
||||
'simple' 'integer' "{" "}" surrounded-by <&> [ first2 exactly-n ] <@
|
||||
'simple' 'integer' "{" ",}" surrounded-by <&> [ first2 at-least-n ] <@ <|>
|
||||
'simple' 'integer' "{," "}" surrounded-by <&> [ first2 at-most-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 <& [ <?> ] <@ <|> ;
|
||||
|
||||
: 'repetition' ( -- parser )
|
||||
'greedy-repetition'
|
||||
'greedy-repetition' "?" token <& [ "reluctant" print ] <@ <|>
|
||||
'greedy-repetition' "+" token <& [ "possessive" print ] <@ <|> ;
|
||||
|
||||
: 'term' ( -- parser )
|
||||
'simple' 'repetition' 'interval' <|> <|>
|
||||
<+> [ <and-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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -32,12 +32,16 @@ check_ret() {
|
|||
}
|
||||
|
||||
check_gcc_version() {
|
||||
echo -n "Checking gcc version..."
|
||||
GCC_VERSION=`gcc --version`
|
||||
check_ret gcc
|
||||
if [[ $GCC_VERSION == *3.3.* ]] ; then
|
||||
echo "bad!"
|
||||
echo "You have a known buggy version of gcc (3.3)"
|
||||
echo "Install gcc 3.4 or higher and try again."
|
||||
exit 3
|
||||
fi
|
||||
echo "ok."
|
||||
}
|
||||
|
||||
check_installed_programs() {
|
||||
|
|
@ -53,16 +57,20 @@ check_installed_programs() {
|
|||
check_library_exists() {
|
||||
GCC_TEST=factor-library-test.c
|
||||
GCC_OUT=factor-library-test.out
|
||||
echo "Checking for library $1"
|
||||
echo -n "Checking for library $1"
|
||||
echo "int main(){return 0;}" > $GCC_TEST
|
||||
gcc $GCC_TEST -o $GCC_OUT -l $1
|
||||
if [[ $? -ne 0 ]] ; then
|
||||
echo "not found!"
|
||||
echo "Warning: library $1 not found."
|
||||
echo "***Factor will compile NO_UI=1"
|
||||
NO_UI=1
|
||||
fi
|
||||
rm -f $GCC_TEST
|
||||
check_ret rm
|
||||
rm -f $GCC_OUT
|
||||
check_ret rm
|
||||
echo "found."
|
||||
}
|
||||
|
||||
check_X11_libraries() {
|
||||
|
|
@ -87,7 +95,9 @@ check_factor_exists() {
|
|||
}
|
||||
|
||||
find_os() {
|
||||
echo "Finding OS..."
|
||||
uname_s=`uname -s`
|
||||
check_ret uname
|
||||
case $uname_s in
|
||||
CYGWIN_NT-5.2-WOW64) OS=windows-nt;;
|
||||
*CYGWIN_NT*) OS=windows-nt;;
|
||||
|
|
@ -100,11 +110,14 @@ find_os() {
|
|||
}
|
||||
|
||||
find_architecture() {
|
||||
echo "Finding ARCH..."
|
||||
uname_m=`uname -m`
|
||||
check_ret uname
|
||||
case $uname_m in
|
||||
i386) ARCH=x86;;
|
||||
i686) ARCH=x86;;
|
||||
*86) ARCH=x86;;
|
||||
*86_64) ARCH=x86;;
|
||||
"Power Macintosh") ARCH=ppc;;
|
||||
esac
|
||||
}
|
||||
|
|
@ -115,6 +128,7 @@ write_test_program() {
|
|||
}
|
||||
|
||||
find_word_size() {
|
||||
echo "Finding WORD..."
|
||||
C_WORD=factor-word-size
|
||||
write_test_program
|
||||
gcc -o $C_WORD $C_WORD.c
|
||||
|
|
@ -142,6 +156,9 @@ echo_build_info() {
|
|||
|
||||
set_build_info() {
|
||||
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"
|
||||
exit 5
|
||||
fi
|
||||
|
|
@ -170,6 +187,7 @@ git_clone() {
|
|||
}
|
||||
|
||||
git_pull_factorcode() {
|
||||
echo "Updating the git repository from factorcode.org..."
|
||||
git pull git://factorcode.org/git/factor.git
|
||||
check_ret git
|
||||
}
|
||||
|
|
@ -203,11 +221,11 @@ get_boot_image() {
|
|||
maybe_download_dlls() {
|
||||
if [[ $OS == windows-nt ]] ; then
|
||||
wget http://factorcode.org/dlls/freetype6.dll
|
||||
check_ret
|
||||
check_ret wget
|
||||
wget http://factorcode.org/dlls/zlib1.dll
|
||||
check_ret
|
||||
check_ret wget
|
||||
chmod 777 *.dll
|
||||
check_ret
|
||||
check_ret chmod
|
||||
fi
|
||||
}
|
||||
|
||||
|
|
@ -216,7 +234,7 @@ bootstrap() {
|
|||
}
|
||||
|
||||
usage() {
|
||||
echo "usage: $0 install|update"
|
||||
echo "usage: $0 install|install-x11|update|quick-update"
|
||||
}
|
||||
|
||||
install() {
|
||||
|
|
@ -239,13 +257,26 @@ update() {
|
|||
git_pull_factorcode
|
||||
make_clean
|
||||
make_factor
|
||||
}
|
||||
|
||||
update_bootstrap() {
|
||||
delete_boot_images
|
||||
get_boot_image
|
||||
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
|
||||
install) install ;;
|
||||
update) update ;;
|
||||
install-x11) install_libraries; install ;;
|
||||
quick-update) update; refresh_image ;;
|
||||
update) update; update_bootstrap ;;
|
||||
*) usage ;;
|
||||
esac
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
} } ;
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue