calendar: remove unnecessary effects on generics.
parent
e7d088af63
commit
89056025a7
|
@ -40,10 +40,10 @@ CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
|
||||||
|
|
||||||
GENERIC: leap-year? ( obj -- ? )
|
GENERIC: leap-year? ( obj -- ? )
|
||||||
|
|
||||||
M: integer leap-year? ( year -- ? )
|
M: integer leap-year?
|
||||||
dup 100 divisor? 400 4 ? divisor? ;
|
dup 100 divisor? 400 4 ? divisor? ;
|
||||||
|
|
||||||
M: timestamp leap-year? ( timestamp -- ? )
|
M: timestamp leap-year?
|
||||||
year>> leap-year? ;
|
year>> leap-year? ;
|
||||||
|
|
||||||
: (days-in-month) ( year month -- n )
|
: (days-in-month) ( year month -- n )
|
||||||
|
@ -121,10 +121,10 @@ GENERIC: easter ( obj -- obj' )
|
||||||
|
|
||||||
h l + 7 m * - 114 + 31 /mod 1 + ;
|
h l + 7 m * - 114 + 31 /mod 1 + ;
|
||||||
|
|
||||||
M: integer easter ( year -- timestamp )
|
M: integer easter
|
||||||
dup easter-month-day <date> ;
|
dup easter-month-day <date> ;
|
||||||
|
|
||||||
M: timestamp easter ( timestamp -- timestamp )
|
M: timestamp easter
|
||||||
clone
|
clone
|
||||||
dup year>> easter-month-day
|
dup year>> easter-month-day
|
||||||
swapd >>day swap >>month ;
|
swapd >>day swap >>month ;
|
||||||
|
@ -167,52 +167,52 @@ GENERIC: +second ( timestamp x -- timestamp )
|
||||||
{ [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
|
{ [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
|
||||||
[ 3 >>month 1 >>day ] when ;
|
[ 3 >>month 1 >>day ] when ;
|
||||||
|
|
||||||
M: integer +year ( timestamp n -- timestamp )
|
M: integer +year
|
||||||
[ + ] curry change-year adjust-leap-year ;
|
[ + ] curry change-year adjust-leap-year ;
|
||||||
|
|
||||||
M: real +year ( timestamp n -- timestamp )
|
M: real +year
|
||||||
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
|
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
|
||||||
|
|
||||||
: months/years ( n -- months years )
|
: months/years ( n -- months years )
|
||||||
12 /rem [ 1 - 12 ] when-zero swap ; inline
|
12 /rem [ 1 - 12 ] when-zero swap ; inline
|
||||||
|
|
||||||
M: integer +month ( timestamp n -- timestamp )
|
M: integer +month
|
||||||
[ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
|
[ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
|
||||||
|
|
||||||
M: real +month ( timestamp n -- timestamp )
|
M: real +month
|
||||||
[ float>whole-part swapd average-month * +day swap +month ] unless-zero ;
|
[ float>whole-part swapd average-month * +day swap +month ] unless-zero ;
|
||||||
|
|
||||||
M: integer +day ( timestamp n -- timestamp )
|
M: integer +day
|
||||||
[
|
[
|
||||||
over >date< julian-day-number + julian-day-number>date
|
over >date< julian-day-number + julian-day-number>date
|
||||||
[ >>year ] [ >>month ] [ >>day ] tri*
|
[ >>year ] [ >>month ] [ >>day ] tri*
|
||||||
] unless-zero ;
|
] unless-zero ;
|
||||||
|
|
||||||
M: real +day ( timestamp n -- timestamp )
|
M: real +day
|
||||||
[ float>whole-part swapd 24 * +hour swap +day ] unless-zero ;
|
[ float>whole-part swapd 24 * +hour swap +day ] unless-zero ;
|
||||||
|
|
||||||
: hours/days ( n -- hours days )
|
: hours/days ( n -- hours days )
|
||||||
24 /rem swap ;
|
24 /rem swap ;
|
||||||
|
|
||||||
M: integer +hour ( timestamp n -- timestamp )
|
M: integer +hour
|
||||||
[ over hour>> + hours/days [ >>hour ] dip +day ] unless-zero ;
|
[ over hour>> + hours/days [ >>hour ] dip +day ] unless-zero ;
|
||||||
|
|
||||||
M: real +hour ( timestamp n -- timestamp )
|
M: real +hour
|
||||||
float>whole-part swapd 60 * +minute swap +hour ;
|
float>whole-part swapd 60 * +minute swap +hour ;
|
||||||
|
|
||||||
: minutes/hours ( n -- minutes hours )
|
: minutes/hours ( n -- minutes hours )
|
||||||
60 /rem swap ;
|
60 /rem swap ;
|
||||||
|
|
||||||
M: integer +minute ( timestamp n -- timestamp )
|
M: integer +minute
|
||||||
[ over minute>> + minutes/hours [ >>minute ] dip +hour ] unless-zero ;
|
[ over minute>> + minutes/hours [ >>minute ] dip +hour ] unless-zero ;
|
||||||
|
|
||||||
M: real +minute ( timestamp n -- timestamp )
|
M: real +minute
|
||||||
[ float>whole-part swapd 60 * +second swap +minute ] unless-zero ;
|
[ float>whole-part swapd 60 * +second swap +minute ] unless-zero ;
|
||||||
|
|
||||||
: seconds/minutes ( n -- seconds minutes )
|
: seconds/minutes ( n -- seconds minutes )
|
||||||
60 /rem swap >integer ;
|
60 /rem swap >integer ;
|
||||||
|
|
||||||
M: number +second ( timestamp n -- timestamp )
|
M: number +second
|
||||||
[ over second>> + seconds/minutes [ >>second ] dip +minute ] unless-zero ;
|
[ over second>> + seconds/minutes [ >>second ] dip +minute ] unless-zero ;
|
||||||
|
|
||||||
: (time+) ( timestamp duration -- timestamp' duration )
|
: (time+) ( timestamp duration -- timestamp' duration )
|
||||||
|
@ -291,8 +291,7 @@ GENERIC: time- ( time1 time2 -- time3 )
|
||||||
[ neg +year 0 ] change-year drop
|
[ neg +year 0 ] change-year drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
M: timestamp <=> ( ts1 ts2 -- n )
|
M: timestamp <=> [ >gmt tuple-slots ] compare ;
|
||||||
[ >gmt tuple-slots ] compare ;
|
|
||||||
|
|
||||||
: same-day? ( ts1 ts2 -- ? )
|
: same-day? ( ts1 ts2 -- ? )
|
||||||
[ >gmt >date< <date> ] same? ;
|
[ >gmt >date< <date> ] same? ;
|
||||||
|
@ -376,8 +375,9 @@ M: duration time-
|
||||||
|
|
||||||
GENERIC: days-in-year ( obj -- n )
|
GENERIC: days-in-year ( obj -- n )
|
||||||
|
|
||||||
M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
|
M: integer days-in-year leap-year? 366 365 ? ;
|
||||||
M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
|
|
||||||
|
M: timestamp days-in-year year>> days-in-year ;
|
||||||
|
|
||||||
: days-in-month ( timestamp -- n )
|
: days-in-month ( timestamp -- n )
|
||||||
>date< drop (days-in-month) ;
|
>date< drop (days-in-month) ;
|
||||||
|
|
|
@ -52,15 +52,15 @@ MACRO: formatted ( spec -- quot )
|
||||||
|
|
||||||
GENERIC: day. ( obj -- )
|
GENERIC: day. ( obj -- )
|
||||||
|
|
||||||
M: integer day. ( n -- )
|
M: integer day.
|
||||||
number>string dup length 2 < [ bl ] when write ;
|
number>string dup length 2 < [ bl ] when write ;
|
||||||
|
|
||||||
M: timestamp day. ( timestamp -- )
|
M: timestamp day.
|
||||||
day>> day. ;
|
day>> day. ;
|
||||||
|
|
||||||
GENERIC: month. ( obj -- )
|
GENERIC: month. ( obj -- )
|
||||||
|
|
||||||
M: array month. ( pair -- )
|
M: array month.
|
||||||
first2
|
first2
|
||||||
[ month-name write bl number>string print ]
|
[ month-name write bl number>string print ]
|
||||||
[ 1 zeller-congruence ]
|
[ 1 zeller-congruence ]
|
||||||
|
@ -71,15 +71,15 @@ M: array month. ( pair -- )
|
||||||
1 + + 7 mod zero? [ nl ] [ bl ] if
|
1 + + 7 mod zero? [ nl ] [ bl ] if
|
||||||
] with each-integer nl ;
|
] with each-integer nl ;
|
||||||
|
|
||||||
M: timestamp month. ( timestamp -- )
|
M: timestamp month.
|
||||||
[ year>> ] [ month>> ] bi 2array month. ;
|
[ year>> ] [ month>> ] bi 2array month. ;
|
||||||
|
|
||||||
GENERIC: year. ( obj -- )
|
GENERIC: year. ( obj -- )
|
||||||
|
|
||||||
M: integer year. ( n -- )
|
M: integer year.
|
||||||
12 [ 1 + 2array month. nl ] with each-integer ;
|
12 [ 1 + 2array month. nl ] with each-integer ;
|
||||||
|
|
||||||
M: timestamp year. ( timestamp -- )
|
M: timestamp year.
|
||||||
year>> year. ;
|
year>> year. ;
|
||||||
|
|
||||||
: timestamp>mdtm ( timestamp -- str )
|
: timestamp>mdtm ( timestamp -- str )
|
||||||
|
|
|
@ -31,7 +31,7 @@ IN: calendar.unix
|
||||||
: timezone-name ( -- string )
|
: timezone-name ( -- string )
|
||||||
get-time zone>> ;
|
get-time zone>> ;
|
||||||
|
|
||||||
M: unix gmt-offset ( -- hours minutes seconds )
|
M: unix gmt-offset
|
||||||
get-time gmtoff>> 3600 /mod 60 /mod ;
|
get-time gmtoff>> 3600 /mod 60 /mod ;
|
||||||
|
|
||||||
: current-timeval ( -- timeval )
|
: current-timeval ( -- timeval )
|
||||||
|
|
|
@ -28,7 +28,7 @@ IN: calendar.windows
|
||||||
[ [ wSecond>> ] [ wMilliseconds>> 1000 / ] bi + ]
|
[ [ wSecond>> ] [ wMilliseconds>> 1000 / ] bi + ]
|
||||||
} cleave instant <timestamp> ;
|
} cleave instant <timestamp> ;
|
||||||
|
|
||||||
M: windows gmt-offset ( -- hours minutes seconds )
|
M: windows gmt-offset
|
||||||
TIME_ZONE_INFORMATION <struct>
|
TIME_ZONE_INFORMATION <struct>
|
||||||
dup GetTimeZoneInformation {
|
dup GetTimeZoneInformation {
|
||||||
{ TIME_ZONE_ID_INVALID [ win32-error ] }
|
{ TIME_ZONE_ID_INVALID [ win32-error ] }
|
||||||
|
|
Loading…
Reference in New Issue