steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

time -> >time<, date -> >date< to avoid conflict with time in test vocab

release
erg 2006-09-01 15:53:21 +00:00
parent 72a6678623
commit e2e53a0374
1 changed files with 9 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
contrib/calendar/calendar.factor
View File

@ -8,6 +8,9 @@ TUPLE: dt year month day hour minute second ;
SYMBOL: gmt-offset SYMBOL: gmt-offset
7 gmt-offset set-global 7 gmt-offset set-global
FUNCTION: time_t time ( time_t* tloc ) ;
FUNCTION: tm* localtime ( time_t* clock ) ;
: month-names : month-names
{ {
"Not a month" "January" "February" "March" "April" "May" "June" "Not a month" "January" "February" "March" "April" "May" "June"
@ -81,12 +84,12 @@ SYMBOL: m
[ set-timestamp-minute ] keep [ set-timestamp-minute ] keep
set-timestamp-hour ; set-timestamp-hour ;
: date ( timestamp -- year month day ) : >date< ( timestamp -- year month day )
[ timestamp-year ] keep [ timestamp-year ] keep
[ timestamp-month ] keep [ timestamp-month ] keep
timestamp-day ; timestamp-day ;
: time ( timestamp -- hour minute second ) : >time< ( timestamp -- hour minute second )
[ timestamp-hour ] keep [ timestamp-hour ] keep
[ timestamp-minute ] keep [ timestamp-minute ] keep
timestamp-second ; timestamp-second ;
@ -121,7 +124,7 @@ GENERIC: +second ( timestamp x -- timestamp )
dup 100 mod zero? 400 4 ? mod zero? ; dup 100 mod zero? 400 4 ? mod zero? ;
: adjust-leap-year ( timestamp -- timestamp ) : adjust-leap-year ( timestamp -- timestamp )
dup date 29 = swap 2 = and swap leap-year? not and [ dup >date< 29 = swap 2 = and swap leap-year? not and [
dup >r timestamp-year 3 1 r> [ set-date ] keep dup >r timestamp-year 3 1 r> [ set-date ] keep
] when ; ] when ;
@ -140,8 +143,8 @@ M: real +month ( timestamp n -- timestamp )
M: integer +day ( timestamp n -- timestamp ) M: integer +day ( timestamp n -- timestamp )
swap [ swap [
date julian-day-number + julian-day-number>timestamp >date< julian-day-number + julian-day-number>timestamp
] keep swap >r time r> [ set-time ] keep ; ] keep swap >r >time< r> [ set-time ] keep ;
M: real +day ( timestamp n -- timestamp ) M: real +day ( timestamp n -- timestamp )
float>whole-part rot swap 24 * +hour swap +day ; float>whole-part rot swap 24 * +hour swap +day ;
@ -245,7 +248,7 @@ M: number +second ( timestamp n -- timestamp )
: day-of-year ( timestamp -- n ) : day-of-year ( timestamp -- n )
[ [
[ timestamp-year leap-year? ] keep [ timestamp-year leap-year? ] keep
[ date 3array ] keep timestamp-year 3 1 3array <=> [ >date< 3array ] keep timestamp-year 3 1 3array <=>
0 >= and 1 0 ? 0 >= and 1 0 ?
] keep ] keep
[ timestamp-month day-counts swap head-slice sum + ] keep [ timestamp-month day-counts swap head-slice sum + ] keep