diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 2aeb3099ac..2523841aaf 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -57,7 +57,7 @@ millis >r default-image-name "output-image" set-global -"math help handbook compiler tools ui ui.tools io" "include" set-global +"math help handbook compiler random tools ui ui.tools io" "include" set-global "" "exclude" set-global parse-command-line diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index b854b4ef0d..7a8fe5d735 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -261,7 +261,7 @@ cell 8 = [ : compiled-fixnum* fixnum* ; : test-fixnum* - (random) >fixnum (random) >fixnum + 32 random-bits >fixnum 32 random-bits >fixnum 2dup [ fixnum* ] 2keep compiled-fixnum* = [ 2drop ] [ "Oops" throw ] if ; @@ -271,7 +271,7 @@ cell 8 = [ : compiled-fixnum>bignum fixnum>bignum ; : test-fixnum>bignum - (random) >fixnum + 32 random-bits >fixnum dup [ fixnum>bignum ] keep compiled-fixnum>bignum = [ drop ] [ "Oops" throw ] if ; @@ -280,7 +280,7 @@ cell 8 = [ : compiled-bignum>fixnum bignum>fixnum ; : test-bignum>fixnum - 5 random [ drop (random) ] map product >bignum + 5 random [ drop 32 random-bits ] map product >bignum dup [ bignum>fixnum ] keep compiled-bignum>fixnum = [ drop ] [ "Oops" throw ] if ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index 61e09d894e..0b3123c87b 100755 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -33,7 +33,7 @@ IN: heaps.tests : random-alist ( n -- alist ) [ [ - (random) dup number>string swap set + 32 random-bits dup number>string swap set ] times ] H{ } make-assoc ; diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor old mode 100644 new mode 100755 index 7132860e1c..b61e002526 --- a/extra/bootstrap/random/random.factor +++ b/extra/bootstrap/random/random.factor @@ -1,4 +1,6 @@ -USING: vocabs.loader sequences system ; +USING: vocabs.loader sequences system +random random.mersenne-twister combinators init +namespaces ; "random.mersenne-twister" require @@ -6,3 +8,6 @@ USING: vocabs.loader sequences system ; { [ windows? ] [ "random.windows" require ] } { [ unix? ] [ "random.unix" require ] } } cond + +[ millis random-generator set-global ] +"generator.random" add-init-hook diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 457b0bea11..7347363e5b 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -59,31 +59,29 @@ SYMBOL: m PRIVATE> -: julian-day-number ( year month day -- n ) +:: julian-day-number ( year month day -- n ) #! Returns a composite date number #! Not valid before year -4800 - [ - 14 pick - 12 /i a set - pick 4800 + a get - y set - over 12 a get * + 3 - m set - 2nip 153 m get * 2 + 5 /i + 365 y get * + - y get 4 /i + y get 100 /i - y get 400 /i + 32045 - - ] with-scope ; + [let* | a [ 14 month - 12 /i ] + y [ year 4800 + a - ] + m [ month 12 a * + 3 - ] | + day 153 m * 2 + 5 /i + 365 y * + + y 4 /i + y 100 /i - y 400 /i + 32045 - + ] ; -: julian-day-number>date ( n -- year month day ) +:: julian-day-number>date ( n -- year month day ) #! Inverse of julian-day-number - [ - 32044 + a set - 4 a get * 3 + 146097 /i b set - a get 146097 b get * 4 /i - c set - 4 c get * 3 + 1461 /i d set - c get 1461 d get * 4 /i - e set - 5 e get * 2 + 153 /i m set - 100 b get * d get + 4800 - - m get 10 /i + m get 3 + - 12 m get 10 /i * - - e get 153 m get * 2 + 5 /i - 1+ - ] with-scope ; + [let* | a [ n 32044 + ] + b [ 4 a * 3 + 146097 /i ] + c [ a 146097 b * 4 /i - ] + d [ 4 c * 3 + 1461 /i ] + e [ c 1461 d * 4 /i - ] + m [ 5 e * 2 + 153 /i ] | + 100 b * d + 4800 - + m 10 /i + m 3 + + 12 m 10 /i * - + e 153 m * 2 + 5 /i - 1+ + ] ; : >date< ( timestamp -- year month day ) { year>> month>> day>> } get-slots ; diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index acbae2fcd3..1609b9f260 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -9,13 +9,14 @@ T{ windows-calendar } calendar-backend set-global : TIME_ZONE_ID_INVALID HEX: ffffffff ; inline M: windows-calendar gmt-offset ( -- hours minutes seconds ) - "TIME_ZONE_INFORMATION" - dup GetTimeZoneInformation { - { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] } - { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ] - [ TIME_ZONE_INFORMATION-Bias 60 / neg ] } - { [ dup TIME_ZONE_ID_DAYLIGHT = ] [ - [ TIME_ZONE_INFORMATION-Bias 60 / neg ] - [ TIME_ZONE_INFORMATION-DaylightBias ] bi - ] } - } cond ; + 0 0 0 ; + ! "TIME_ZONE_INFORMATION" + ! dup GetTimeZoneInformation { + ! { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] } + ! { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ] + ! [ TIME_ZONE_INFORMATION-Bias 60 / neg ] } + ! { [ dup TIME_ZONE_ID_DAYLIGHT = ] [ + ! [ TIME_ZONE_INFORMATION-Bias 60 / neg ] + ! [ TIME_ZONE_INFORMATION-DaylightBias ] bi + ! ] } + ! } cond ; diff --git a/extra/circular/circular-tests.factor b/extra/circular/circular-tests.factor old mode 100644 new mode 100755 index 8ca4574885..9023ab1dba --- a/extra/circular/circular-tests.factor +++ b/extra/circular/circular-tests.factor @@ -9,7 +9,6 @@ circular strings ; [ CHAR: t ] [ "test" 0 swap nth ] unit-test [ "test" ] [ "test" >string ] unit-test -[ "test" 5 swap nth ] must-fail [ CHAR: e ] [ "test" 5 swap nth-unsafe ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } [ ] like ] unit-test @@ -18,10 +17,13 @@ circular strings ; [ [ 3 1 2 ] ] [ { 1 2 3 } -100 over change-circular-start [ ] like ] unit-test [ "fob" ] [ "foo" CHAR: b 2 pick set-nth >string ] unit-test -[ "foo" CHAR: b 3 rot set-nth ] must-fail [ "boo" ] [ "foo" CHAR: b 3 pick set-nth-unsafe >string ] unit-test [ "ornact" ] [ "factor" 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test [ "bcd" ] [ 3 "abcd" [ over push-circular ] each >string ] unit-test [ { 0 0 } ] [ { 0 0 } -1 over change-circular-start >array ] unit-test + +! This no longer fails +! [ "test" 5 swap nth ] must-fail +! [ "foo" CHAR: b 3 rot set-nth ] must-fail diff --git a/extra/circular/circular.factor b/extra/circular/circular.factor old mode 100644 new mode 100755 index 8760e26586..08deb004e8 --- a/extra/circular/circular.factor +++ b/extra/circular/circular.factor @@ -18,9 +18,9 @@ M: circular length circular-seq length ; M: circular virtual@ circular-wrap circular-seq ; -M: circular nth bounds-check virtual@ nth ; +M: circular nth virtual@ nth ; -M: circular set-nth bounds-check virtual@ set-nth ; +M: circular set-nth virtual@ set-nth ; : change-circular-start ( n circular -- ) #! change start to (start + n) mod length diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index eb6dae2a0a..6fd38e74b2 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -56,7 +56,7 @@ TUPLE: pipe in out ; "\\\\.\\pipe\\factor-" % pipe counter # "-" % - (random) # + 32 random-bits # "-" % millis # ] "" make ; diff --git a/extra/random/mersenne-twister/mersenne-twister-tests.factor b/extra/random/mersenne-twister/mersenne-twister-tests.factor old mode 100644 new mode 100755 index afd9d085b6..49bf4ad3f3 --- a/extra/random/mersenne-twister/mersenne-twister-tests.factor +++ b/extra/random/mersenne-twister/mersenne-twister-tests.factor @@ -1,7 +1,6 @@ USING: kernel math random namespaces random.mersenne-twister sequences tools.test ; IN: random.mersenne-twister.tests -USE: tools.walker : check-random ( max -- ? ) dup >r random 0 r> between? ; @@ -17,11 +16,11 @@ USE: tools.walker [ f ] [ 1234 [ make-100-randoms make-100-randoms = ] test-rng ] unit-test [ 1333075495 ] [ - 0 [ 1000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng + 0 [ 1000 [ drop random-generator get random-32 drop ] each random-generator get random-32 ] test-rng ] unit-test [ 1575309035 ] [ - 0 [ 10000 [ drop \ random get random-32 drop ] each \ random get random-32 ] test-rng + 0 [ 10000 [ drop random-generator get random-32 drop ] each random-generator get random-32 ] test-rng ] unit-test diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 79101c083e..73f241a370 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -3,9 +3,8 @@ ! mersenne twister based on ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c -USING: arrays kernel math namespaces sequences -system init new-slots accessors -math.ranges combinators.cleave circular random ; +USING: arrays kernel math namespaces sequences system init +new-slots accessors math.ranges combinators.cleave random ; IN: random.mersenne-twister \ random set-global ] "random" add-init-hook diff --git a/extra/random/random.factor b/extra/random/random.factor old mode 100644 new mode 100755 index bbf54e21eb..0d8b137fc5 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -15,16 +15,14 @@ GENERIC: random-32 ( tuple -- r ) : (random-bytes) ( tuple n -- byte-array ) [ drop random-32 ] with map >c-uint-array ; -DEFER: random +SYMBOL: random-generator : random-bytes ( n -- r ) [ 4 /mod zero? [ 1+ ] unless - \ random get swap (random-bytes) + random-generator get swap (random-bytes) ] keep head ; -: random-bits ( n -- r ) 2^ random ; - : random ( seq -- elt ) dup empty? [ drop f @@ -35,5 +33,7 @@ DEFER: random ] keep nth ] if ; +: random-bits ( n -- r ) 2^ random ; + : with-random ( tuple quot -- ) - \ random swap with-variable ; inline + random-generator swap with-variable ; inline