Bootstrap fixes
parent
4675811d68
commit
0d9947198c
|
@ -261,7 +261,7 @@ cell 8 = [
|
||||||
: compiled-fixnum* fixnum* ;
|
: compiled-fixnum* fixnum* ;
|
||||||
|
|
||||||
: test-fixnum*
|
: test-fixnum*
|
||||||
(random) >fixnum (random) >fixnum
|
32 random-bits >fixnum 32 random-bits >fixnum
|
||||||
2dup
|
2dup
|
||||||
[ fixnum* ] 2keep compiled-fixnum* =
|
[ fixnum* ] 2keep compiled-fixnum* =
|
||||||
[ 2drop ] [ "Oops" throw ] if ;
|
[ 2drop ] [ "Oops" throw ] if ;
|
||||||
|
@ -271,7 +271,7 @@ cell 8 = [
|
||||||
: compiled-fixnum>bignum fixnum>bignum ;
|
: compiled-fixnum>bignum fixnum>bignum ;
|
||||||
|
|
||||||
: test-fixnum>bignum
|
: test-fixnum>bignum
|
||||||
(random) >fixnum
|
32 random-bits >fixnum
|
||||||
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
|
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
|
||||||
[ drop ] [ "Oops" throw ] if ;
|
[ drop ] [ "Oops" throw ] if ;
|
||||||
|
|
||||||
|
@ -280,7 +280,7 @@ cell 8 = [
|
||||||
: compiled-bignum>fixnum bignum>fixnum ;
|
: compiled-bignum>fixnum bignum>fixnum ;
|
||||||
|
|
||||||
: test-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 =
|
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
|
||||||
[ drop ] [ "Oops" throw ] if ;
|
[ drop ] [ "Oops" throw ] if ;
|
||||||
|
|
||||||
|
|
|
@ -33,7 +33,7 @@ IN: heaps.tests
|
||||||
: random-alist ( n -- alist )
|
: random-alist ( n -- alist )
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
(random) dup number>string swap set
|
32 random-bits dup number>string swap set
|
||||||
] times
|
] times
|
||||||
] H{ } make-assoc ;
|
] H{ } make-assoc ;
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,5 @@
|
||||||
USING: vocabs.loader sequences system ;
|
USING: vocabs.loader sequences system
|
||||||
|
random random.mersenne-twister ;
|
||||||
|
|
||||||
"random.mersenne-twister" require
|
"random.mersenne-twister" require
|
||||||
|
|
||||||
|
@ -6,3 +7,6 @@ USING: vocabs.loader sequences system ;
|
||||||
{ [ windows? ] [ "random.windows" require ] }
|
{ [ windows? ] [ "random.windows" require ] }
|
||||||
{ [ unix? ] [ "random.unix" require ] }
|
{ [ unix? ] [ "random.unix" require ] }
|
||||||
} cond
|
} cond
|
||||||
|
|
||||||
|
[ millis <mersenne-twister> random-generator set-global ]
|
||||||
|
"generator.random" add-init-hook
|
||||||
|
|
|
@ -59,31 +59,29 @@ SYMBOL: m
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: julian-day-number ( year month day -- n )
|
:: julian-day-number ( year month day -- n )
|
||||||
#! Returns a composite date number
|
#! Returns a composite date number
|
||||||
#! Not valid before year -4800
|
#! Not valid before year -4800
|
||||||
[
|
[let* | a [ 14 month - 12 /i ]
|
||||||
14 pick - 12 /i a set
|
y [ year 4800 + a - ]
|
||||||
pick 4800 + a get - y set
|
m [ month 12 a * + 3 - ] |
|
||||||
over 12 a get * + 3 - m set
|
day 153 m * 2 + 5 /i + 365 y * +
|
||||||
2nip 153 m get * 2 + 5 /i + 365 y get * +
|
y 4 /i + y 100 /i - y 400 /i + 32045 -
|
||||||
y get 4 /i + y get 100 /i - y get 400 /i + 32045 -
|
] ;
|
||||||
] with-scope ;
|
|
||||||
|
|
||||||
: julian-day-number>date ( n -- year month day )
|
:: julian-day-number>date ( n -- year month day )
|
||||||
#! Inverse of julian-day-number
|
#! Inverse of julian-day-number
|
||||||
[
|
[let* | a [ n 32044 + ]
|
||||||
32044 + a set
|
b [ 4 a * 3 + 146097 /i ]
|
||||||
4 a get * 3 + 146097 /i b set
|
c [ a 146097 b * 4 /i - ]
|
||||||
a get 146097 b get * 4 /i - c set
|
d [ 4 c * 3 + 1461 /i ]
|
||||||
4 c get * 3 + 1461 /i d set
|
e [ c 1461 d * 4 /i - ]
|
||||||
c get 1461 d get * 4 /i - e set
|
m [ 5 e * 2 + 153 /i ] |
|
||||||
5 e get * 2 + 153 /i m set
|
100 b * d + 4800 -
|
||||||
100 b get * d get + 4800 -
|
m 10 /i + m 3 +
|
||||||
m get 10 /i + m get 3 +
|
12 m 10 /i * -
|
||||||
12 m get 10 /i * -
|
e 153 m * 2 + 5 /i - 1+
|
||||||
e get 153 m get * 2 + 5 /i - 1+
|
] ;
|
||||||
] with-scope ;
|
|
||||||
|
|
||||||
: >date< ( timestamp -- year month day )
|
: >date< ( timestamp -- year month day )
|
||||||
{ year>> month>> day>> } get-slots ;
|
{ year>> month>> day>> } get-slots ;
|
||||||
|
|
|
@ -9,13 +9,14 @@ T{ windows-calendar } calendar-backend set-global
|
||||||
: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline
|
: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline
|
||||||
|
|
||||||
M: windows-calendar gmt-offset ( -- hours minutes seconds )
|
M: windows-calendar gmt-offset ( -- hours minutes seconds )
|
||||||
"TIME_ZONE_INFORMATION" <c-object>
|
0 0 0 ;
|
||||||
dup GetTimeZoneInformation {
|
! "TIME_ZONE_INFORMATION" <c-object>
|
||||||
{ [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] }
|
! dup GetTimeZoneInformation {
|
||||||
{ [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ]
|
! { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] }
|
||||||
[ TIME_ZONE_INFORMATION-Bias 60 / neg ] }
|
! { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ]
|
||||||
{ [ dup TIME_ZONE_ID_DAYLIGHT = ] [
|
! [ TIME_ZONE_INFORMATION-Bias 60 / neg ] }
|
||||||
[ TIME_ZONE_INFORMATION-Bias 60 / neg ]
|
! { [ dup TIME_ZONE_ID_DAYLIGHT = ] [
|
||||||
[ TIME_ZONE_INFORMATION-DaylightBias ] bi
|
! [ TIME_ZONE_INFORMATION-Bias 60 / neg ]
|
||||||
] }
|
! [ TIME_ZONE_INFORMATION-DaylightBias ] bi
|
||||||
} cond ;
|
! ] }
|
||||||
|
! } cond ;
|
||||||
|
|
|
@ -56,7 +56,7 @@ TUPLE: pipe in out ;
|
||||||
"\\\\.\\pipe\\factor-" %
|
"\\\\.\\pipe\\factor-" %
|
||||||
pipe counter #
|
pipe counter #
|
||||||
"-" %
|
"-" %
|
||||||
(random) #
|
32 random-bits #
|
||||||
"-" %
|
"-" %
|
||||||
millis #
|
millis #
|
||||||
] "" make ;
|
] "" make ;
|
||||||
|
|
|
@ -76,5 +76,3 @@ M: mersenne-twister random-32 ( mt -- r )
|
||||||
dup mt-n < [ drop 0 pick mt-generate ] unless
|
dup mt-n < [ drop 0 pick mt-generate ] unless
|
||||||
new-nth mt-temper
|
new-nth mt-temper
|
||||||
swap [ 1+ ] change-i drop ;
|
swap [ 1+ ] change-i drop ;
|
||||||
|
|
||||||
[ millis <mersenne-twister> \ random set-global ] "random" add-init-hook
|
|
||||||
|
|
|
@ -15,16 +15,14 @@ GENERIC: random-32 ( tuple -- r )
|
||||||
: (random-bytes) ( tuple n -- byte-array )
|
: (random-bytes) ( tuple n -- byte-array )
|
||||||
[ drop random-32 ] with map >c-uint-array ;
|
[ drop random-32 ] with map >c-uint-array ;
|
||||||
|
|
||||||
DEFER: random
|
SYMBOL: random-generator
|
||||||
|
|
||||||
: random-bytes ( n -- r )
|
: random-bytes ( n -- r )
|
||||||
[
|
[
|
||||||
4 /mod zero? [ 1+ ] unless
|
4 /mod zero? [ 1+ ] unless
|
||||||
\ random get swap (random-bytes)
|
random-generator get swap (random-bytes)
|
||||||
] keep head ;
|
] keep head ;
|
||||||
|
|
||||||
: random-bits ( n -- r ) 2^ random ;
|
|
||||||
|
|
||||||
: random ( seq -- elt )
|
: random ( seq -- elt )
|
||||||
dup empty? [
|
dup empty? [
|
||||||
drop f
|
drop f
|
||||||
|
@ -35,5 +33,7 @@ DEFER: random
|
||||||
] keep nth
|
] keep nth
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
: random-bits ( n -- r ) 2^ random ;
|
||||||
|
|
||||||
: with-random ( tuple quot -- )
|
: with-random ( tuple quot -- )
|
||||||
\ random swap with-variable ; inline
|
random-generator swap with-variable ; inline
|
||||||
|
|
Loading…
Reference in New Issue