calendar: remove unnecessary effects on generics.

master
John Benediktsson 2020-02-26 11:34:02 -08:00
parent 6ee821e061
commit 385c5edf1a
4 changed files with 27 additions and 27 deletions

View File

@ -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) ;

View File

@ -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 )

View File

@ -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 )

View File

@ -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 ] }