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