diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor
index 43385b911d..0d76e6f50d 100644
--- a/extra/combinators/lib/lib-tests.factor
+++ b/extra/combinators/lib/lib-tests.factor
@@ -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
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index 3f49da7cb3..fe11fd1338 100644
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -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 ;
diff --git a/extra/random-tester/databank/databank.factor b/extra/random-tester/databank/databank.factor
new file mode 100644
index 0000000000..45ee779372
--- /dev/null
+++ b/extra/random-tester/databank/databank.factor
@@ -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. }
+ } ;
+
diff --git a/extra/random-tester/random-tester.factor b/extra/random-tester/random-tester.factor
new file mode 100644
index 0000000000..f8aa0f29b5
--- /dev/null
+++ b/extra/random-tester/random-tester.factor
@@ -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 ;
diff --git a/unmaintained/random-tester/random.factor b/extra/random-tester/random/random.factor
old mode 100644
new mode 100755
similarity index 100%
rename from unmaintained/random-tester/random.factor
rename to extra/random-tester/random/random.factor
diff --git a/extra/random-tester/safe-words/safe-words.factor b/extra/random-tester/safe-words/safe-words.factor
new file mode 100644
index 0000000000..9bc87a9c5a
--- /dev/null
+++ b/extra/random-tester/safe-words/safe-words.factor
@@ -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
+
diff --git a/extra/random-tester/utils/utils.factor b/extra/random-tester/utils/utils.factor
new file mode 100644
index 0000000000..ef3d66ad2d
--- /dev/null
+++ b/extra/random-tester/utils/utils.factor
@@ -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) ;
+
+
diff --git a/misc/factor.sh b/misc/factor.sh
index 7511b3d83d..dfea2415f3 100755
--- a/misc/factor.sh
+++ b/misc/factor.sh
@@ -250,7 +250,7 @@ update() {
}
install_libraries() {
- sudo apt-get install libc6-dev libfreetype6-dev wget git-core git-doc libx11-dev glutg3-dev
+ sudo apt-get install libc6-dev libfreetype6-dev wget git-core git-doc libx11-dev glutg3-dev rlwrap
}
case "$1" in
diff --git a/unmaintained/random-tester/load.factor b/unmaintained/random-tester/load.factor
deleted file mode 100644
index ba69545e3b..0000000000
--- a/unmaintained/random-tester/load.factor
+++ /dev/null
@@ -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"
-} } ;
diff --git a/unmaintained/random-tester/random-tester.factor b/unmaintained/random-tester/random-tester.factor
deleted file mode 100644
index 649ca9d345..0000000000
--- a/unmaintained/random-tester/random-tester.factor
+++ /dev/null
@@ -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 ;
-
diff --git a/unmaintained/random-tester/random-tester2.factor b/unmaintained/random-tester/random-tester2.factor
deleted file mode 100644
index 8a49830f12..0000000000
--- a/unmaintained/random-tester/random-tester2.factor
+++ /dev/null
@@ -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 ;
-
diff --git a/unmaintained/random-tester/type.factor b/unmaintained/random-tester/type.factor
deleted file mode 100644
index bda0284c47..0000000000
--- a/unmaintained/random-tester/type.factor
+++ /dev/null
@@ -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 ;
-
diff --git a/unmaintained/random-tester/utils.factor b/unmaintained/random-tester/utils.factor
deleted file mode 100644
index e699d53f22..0000000000
--- a/unmaintained/random-tester/utils.factor
+++ /dev/null
@@ -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