+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: io lint kernel math tools.test ;
-IN: lint.tests
-
-! Don't write code like this
-: lint1
- [ "hi" print ] [ ] if ; ! when
-
-[ { [ [ ] if ] } ] [ \ lint1 lint ] unit-test
-
-: lint2
- 1 + ; ! 1+
-[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
-
-: lint3
- dup -rot ; ! tuck
-
-[ { [ dup -rot ] } ] [ \ lint3 lint ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays assocs combinators.lib io kernel
-macros math namespaces prettyprint quotations sequences
-vectors vocabs words html.elements slots.private tar ;
-IN: lint
-
-SYMBOL: def-hash
-SYMBOL: def-hash-keys
-
-: set-hash-vector ( val key hash -- )
- 2dup at -rot >r >r ?push r> r> set-at ;
-
-: add-word-def ( word quot -- )
- dup callable? [
- def-hash get-global set-hash-vector
- ] [
- 2drop
- ] if ;
-
-: more-defs
- {
- { [ swap >r swap r> ] -rot }
- { [ swap swapd ] -rot }
- { [ >r swap r> swap ] rot }
- { [ swapd swap ] rot }
- { [ dup swap ] over }
- { [ dup -rot ] tuck }
- { [ >r swap r> ] swapd }
- { [ nip nip ] 2nip }
- { [ drop drop ] 2drop }
- { [ drop drop drop ] 3drop }
- { [ 0 = ] zero? }
- { [ pop drop ] pop* }
- { [ [ ] if ] when }
- } [ first2 swap add-word-def ] each ;
-
-: accessor-words ( -- seq )
-{
- alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
- alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
- <displaced-alien> alien-unsigned-cell set-alien-signed-cell
- set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
- set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
- set-alien-unsigned-8 set-alien-signed-8
- alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
- set-alien-float alien-float
-} ;
-
-: trivial-defs
- {
- [ get ] [ t ] [ { } ] [ . ] [ drop f ]
- [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
- [ ">" write-html ] [ <unimplemented-typeflag> throw ]
- [ "/>" write-html ]
- } ;
-
-H{ } clone def-hash set-global
-all-words [ dup word-def add-word-def ] each
-more-defs
-
-! Remove empty word defs
-def-hash get-global [
- drop empty? not
-] assoc-subset
-
-! Remove constants [ 1 ]
-[
- drop dup length 1 = swap first number? and not
-] assoc-subset
-
-! Remove set-alien-cell, etc.
-[
- drop [ accessor-words swap seq-diff ] keep [ length ] bi@ =
-] assoc-subset
-
-! Remove trivial defs
-[
- drop trivial-defs member? not
-] assoc-subset
-
-! Remove n m shift defs
-[
- drop dup length 3 = [
- dup first2 [ number? ] both?
- swap third \ shift = and not
- ] [ drop t ] if
-] assoc-subset
-
-! Remove [ n slot ]
-[
- drop dup length 2 = [
- first2 \ slot = swap number? and not
- ] [ drop t ] if
-] assoc-subset def-hash set-global
-
-: find-duplicates
- def-hash get-global [
- nip length 1 >
- ] assoc-subset ;
-
-def-hash get-global keys def-hash-keys set-global
-
-GENERIC: lint ( obj -- seq )
-
-M: object lint ( obj -- seq )
- drop f ;
-
-: subseq/member? ( subseq/member seq -- ? )
- { [ 2dup start ] [ 2dup member? ] } || 2nip ;
-
-M: callable lint ( quot -- seq )
- def-hash-keys get [
- swap subseq/member?
- ] with subset ;
-
-M: word lint ( word -- seq )
- word-def dup callable? [ lint ] [ drop f ] if ;
-
-: word-path. ( word -- )
- [ word-vocabulary ":" ] keep unparse 3append write nl ;
-
-: (lint.) ( pair -- )
- first2 >r word-path. r> [
- bl bl bl bl
- dup .
- "-----------------------------------" print
- def-hash get at [ bl bl bl bl word-path. ] each
- nl
- ] each nl nl ;
-
-: lint. ( alist -- )
- [ (lint.) ] each ;
-
-
-GENERIC: run-lint ( obj -- obj )
-
-: (trim-self)
- def-hash get-global at* [
- dupd remove empty? not
- ] [
- drop f
- ] if ;
-
-: trim-self ( seq -- newseq )
- [ [ (trim-self) ] subset ] assoc-map ;
-
-: filter-symbols ( alist -- alist )
- [
- nip first dup def-hash get at
- [ first ] bi@ literalize = not
- ] assoc-subset ;
-
-M: sequence run-lint ( seq -- seq )
- [
- global [ dup . flush ] bind
- dup lint
- ] { } map>assoc
- trim-self
- [ second empty? not ] subset
- filter-symbols ;
-
-M: word run-lint ( word -- seq )
- 1array run-lint ;
-
-: lint-all ( -- seq )
- all-words run-lint dup lint. ;
-
-: lint-vocab ( vocab -- seq )
- words run-lint dup lint. ;
-
-: lint-word ( word -- seq )
- 1array run-lint dup lint. ;
+++ /dev/null
-Finds potential mistakes in code
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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. }
- } ;
-
+++ /dev/null
-USING: compiler continuations io kernel math namespaces
-prettyprint quotations random sequences vectors
-compiler.units ;
-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 1 head* before set
- [ call ] [ drop ] recover
- datastack after set
- clear
- before get [ ] each
- quot get [ compile-call ] [ 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 ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel math sequences namespaces hashtables words
-arrays parser compiler syntax io prettyprint optimizer
-random math.constants math.functions layouts random-tester.utils ;
-IN: random-tester
-
-! Tweak me
-: max-length 15 ; inline
-: max-value 1000000000 ; inline
-
-! varying bit-length random number
-: random-bits ( n -- int )
- random 2 swap ^ random ;
-
-: random-seq ( -- seq )
- { [ ] { } V{ } "" } random
- [ max-length random [ max-value random , ] times ] swap make ;
-
-: random-string
- [ max-length random [ max-value random , ] times ] "" make ;
-
-: special-integers ( -- seq ) \ special-integers get ;
-[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
-{ } make \ special-integers set-global
-: special-floats ( -- seq ) \ special-floats get ;
-[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
-{ } make \ special-floats set-global
-: special-complexes ( -- seq ) \ special-complexes get ;
-[
- { -1 0 1 C{ 0 1 } C{ 0 -1 } } %
- e , e neg , pi , pi neg ,
- 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
- pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
- e neg e neg rect> , e e rect> ,
-] { } make \ special-complexes set-global
-
-: random-fixnum ( -- fixnum )
- most-positive-fixnum random 1+ 50% [ neg 1- ] when >fixnum ;
-
-: random-bignum ( -- bignum )
- 400 random-bits first-bignum + 50% [ neg ] when ;
-
-: random-integer ( -- n )
- 50% [
- random-fixnum
- ] [
- 50% [ random-bignum ] [ special-integers get random ] if
- ] if ;
-
-: random-positive-integer ( -- int )
- random-integer dup 0 < [
- neg
- ] [
- dup 0 = [ 1 + ] when
- ] if ;
-
-: random-ratio ( -- ratio )
- 1000000000 dup [ random ] bi@ 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
-
-: random-float ( -- float )
- 50% [ random-ratio ] [ special-floats get random ] if
- 50%
- [ .0000000000000000001 /f ] [ 50% [ .00000000000000001 * ] when ] if
- >float ;
-
-: random-number ( -- number )
- {
- [ random-integer ]
- [ random-ratio ]
- [ random-float ]
- } do-one ;
-
-: random-complex ( -- C )
- random-number random-number rect> ;
-
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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? 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>
- } ;
-
-: 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 %
- 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
-
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: arrays assocs combinators.lib continuations kernel
-math math.functions memoize 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 ? -- ) swap when ; 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-key keys random ;
-: random-value [ random-key ] keep at ;
-
-: do-one ( seq -- ) random call ; inline
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: io lint kernel math tools.test ;
+IN: lint.tests
+
+! Don't write code like this
+: lint1
+ [ "hi" print ] [ ] if ; ! when
+
+[ { [ [ ] if ] } ] [ \ lint1 lint ] unit-test
+
+: lint2
+ 1 + ; ! 1+
+[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
+
+: lint3
+ dup -rot ; ! tuck
+
+[ { [ dup -rot ] } ] [ \ lint3 lint ] unit-test
+
--- /dev/null
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.accessors arrays assocs combinators.lib io kernel
+macros math namespaces prettyprint quotations sequences
+vectors vocabs words html.elements slots.private tar ;
+IN: lint
+
+SYMBOL: def-hash
+SYMBOL: def-hash-keys
+
+: set-hash-vector ( val key hash -- )
+ 2dup at -rot >r >r ?push r> r> set-at ;
+
+: add-word-def ( word quot -- )
+ dup callable? [
+ def-hash get-global set-hash-vector
+ ] [
+ 2drop
+ ] if ;
+
+: more-defs
+ {
+ { [ swap >r swap r> ] -rot }
+ { [ swap swapd ] -rot }
+ { [ >r swap r> swap ] rot }
+ { [ swapd swap ] rot }
+ { [ dup swap ] over }
+ { [ dup -rot ] tuck }
+ { [ >r swap r> ] swapd }
+ { [ nip nip ] 2nip }
+ { [ drop drop ] 2drop }
+ { [ drop drop drop ] 3drop }
+ { [ 0 = ] zero? }
+ { [ pop drop ] pop* }
+ { [ [ ] if ] when }
+ } [ first2 swap add-word-def ] each ;
+
+: accessor-words ( -- seq )
+{
+ alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
+ alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
+ <displaced-alien> alien-unsigned-cell set-alien-signed-cell
+ set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
+ set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
+ set-alien-unsigned-8 set-alien-signed-8
+ alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
+ set-alien-float alien-float
+} ;
+
+: trivial-defs
+ {
+ [ get ] [ t ] [ { } ] [ . ] [ drop f ]
+ [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
+ [ ">" write-html ] [ <unimplemented-typeflag> throw ]
+ [ "/>" write-html ]
+ } ;
+
+H{ } clone def-hash set-global
+all-words [ dup word-def add-word-def ] each
+more-defs
+
+! Remove empty word defs
+def-hash get-global [
+ drop empty? not
+] assoc-subset
+
+! Remove constants [ 1 ]
+[
+ drop dup length 1 = swap first number? and not
+] assoc-subset
+
+! Remove set-alien-cell, etc.
+[
+ drop [ accessor-words swap seq-diff ] keep [ length ] bi@ =
+] assoc-subset
+
+! Remove trivial defs
+[
+ drop trivial-defs member? not
+] assoc-subset
+
+! Remove n m shift defs
+[
+ drop dup length 3 = [
+ dup first2 [ number? ] both?
+ swap third \ shift = and not
+ ] [ drop t ] if
+] assoc-subset
+
+! Remove [ n slot ]
+[
+ drop dup length 2 = [
+ first2 \ slot = swap number? and not
+ ] [ drop t ] if
+] assoc-subset def-hash set-global
+
+: find-duplicates
+ def-hash get-global [
+ nip length 1 >
+ ] assoc-subset ;
+
+def-hash get-global keys def-hash-keys set-global
+
+GENERIC: lint ( obj -- seq )
+
+M: object lint ( obj -- seq )
+ drop f ;
+
+: subseq/member? ( subseq/member seq -- ? )
+ { [ 2dup start ] [ 2dup member? ] } || 2nip ;
+
+M: callable lint ( quot -- seq )
+ def-hash-keys get [
+ swap subseq/member?
+ ] with subset ;
+
+M: word lint ( word -- seq )
+ word-def dup callable? [ lint ] [ drop f ] if ;
+
+: word-path. ( word -- )
+ [ word-vocabulary ":" ] keep unparse 3append write nl ;
+
+: (lint.) ( pair -- )
+ first2 >r word-path. r> [
+ bl bl bl bl
+ dup .
+ "-----------------------------------" print
+ def-hash get at [ bl bl bl bl word-path. ] each
+ nl
+ ] each nl nl ;
+
+: lint. ( alist -- )
+ [ (lint.) ] each ;
+
+
+GENERIC: run-lint ( obj -- obj )
+
+: (trim-self)
+ def-hash get-global at* [
+ dupd remove empty? not
+ ] [
+ drop f
+ ] if ;
+
+: trim-self ( seq -- newseq )
+ [ [ (trim-self) ] subset ] assoc-map ;
+
+: filter-symbols ( alist -- alist )
+ [
+ nip first dup def-hash get at
+ [ first ] bi@ literalize = not
+ ] assoc-subset ;
+
+M: sequence run-lint ( seq -- seq )
+ [
+ global [ dup . flush ] bind
+ dup lint
+ ] { } map>assoc
+ trim-self
+ [ second empty? not ] subset
+ filter-symbols ;
+
+M: word run-lint ( word -- seq )
+ 1array run-lint ;
+
+: lint-all ( -- seq )
+ all-words run-lint dup lint. ;
+
+: lint-vocab ( vocab -- seq )
+ words run-lint dup lint. ;
+
+: lint-word ( word -- seq )
+ 1array run-lint dup lint. ;
--- /dev/null
+Finds potential mistakes in code
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+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. }
+ } ;
+
--- /dev/null
+USING: compiler continuations io kernel math namespaces
+prettyprint quotations random sequences vectors
+compiler.units ;
+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 1 head* before set
+ [ call ] [ drop ] recover
+ datastack after set
+ clear
+ before get [ ] each
+ quot get [ compile-call ] [ 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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: kernel math sequences namespaces hashtables words
+arrays parser compiler syntax io prettyprint optimizer
+random math.constants math.functions layouts random-tester.utils ;
+IN: random-tester
+
+! Tweak me
+: max-length 15 ; inline
+: max-value 1000000000 ; inline
+
+! varying bit-length random number
+: random-bits ( n -- int )
+ random 2 swap ^ random ;
+
+: random-seq ( -- seq )
+ { [ ] { } V{ } "" } random
+ [ max-length random [ max-value random , ] times ] swap make ;
+
+: random-string
+ [ max-length random [ max-value random , ] times ] "" make ;
+
+: special-integers ( -- seq ) \ special-integers get ;
+[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
+{ } make \ special-integers set-global
+: special-floats ( -- seq ) \ special-floats get ;
+[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
+{ } make \ special-floats set-global
+: special-complexes ( -- seq ) \ special-complexes get ;
+[
+ { -1 0 1 C{ 0 1 } C{ 0 -1 } } %
+ e , e neg , pi , pi neg ,
+ 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
+ pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
+ e neg e neg rect> , e e rect> ,
+] { } make \ special-complexes set-global
+
+: random-fixnum ( -- fixnum )
+ most-positive-fixnum random 1+ 50% [ neg 1- ] when >fixnum ;
+
+: random-bignum ( -- bignum )
+ 400 random-bits first-bignum + 50% [ neg ] when ;
+
+: random-integer ( -- n )
+ 50% [
+ random-fixnum
+ ] [
+ 50% [ random-bignum ] [ special-integers get random ] if
+ ] if ;
+
+: random-positive-integer ( -- int )
+ random-integer dup 0 < [
+ neg
+ ] [
+ dup 0 = [ 1 + ] when
+ ] if ;
+
+: random-ratio ( -- ratio )
+ 1000000000 dup [ random ] bi@ 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
+
+: random-float ( -- float )
+ 50% [ random-ratio ] [ special-floats get random ] if
+ 50%
+ [ .0000000000000000001 /f ] [ 50% [ .00000000000000001 * ] when ] if
+ >float ;
+
+: random-number ( -- number )
+ {
+ [ random-integer ]
+ [ random-ratio ]
+ [ random-float ]
+ } do-one ;
+
+: random-complex ( -- C )
+ random-number random-number rect> ;
+
--- /dev/null
+Doug Coleman
--- /dev/null
+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? 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>
+ } ;
+
+: 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 %
+ 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
+
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: arrays assocs combinators.lib continuations kernel
+math math.functions memoize 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 ? -- ) swap when ; 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-key keys random ;
+: random-value [ random-key ] keep at ;
+
+: do-one ( seq -- ) random call ; inline
projects / factor.git / commitdiff