calendar: cleanup some of the API by making words mutate timestamps.

Instead of ``foo-gmt``, you can now do ``foo gmt``.

If you want to not mutate, you can clone the timestamp.

diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor
index 904e788ce3d8c531d83a81da023f955338f7d913..e05b3654f785df7d660a0dea5ad6c3c4c1036b3d 100644 (file)
--- a/basis/calendar/calendar-docs.factor
+++ b/basis/calendar/calendar-docs.factor
@@ -264,25 +264,23 @@ HELP: convert-timezone
 { $description "Converts the " { $snippet "timestamp" } "'s " { $snippet "gmt-offset" } " to the GMT offset represented by the " { $snippet "duration" } "." }
 { $examples
     { $example "USING: accessors calendar prettyprint ;"
-               "gmt noon instant -5 >>hour convert-timezone gmt-offset>> hour>> ."
+               "now-gmt noon instant -5 >>hour convert-timezone gmt-offset>> hour>> ."
                "-5"
     }
 } ;
 
 HELP: >local-time
-{ $values { "timestamp" timestamp } { "timestamp'" timestamp } }
+{ $values { "timestamp" timestamp } }
 { $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." }
 { $examples
     { $example "USING: accessors calendar kernel prettyprint ;"
-               "now gmt >local-time [ gmt-offset>> ] same? ."
+               "now now-gmt >local-time [ gmt-offset>> ] same? ."
                "t"
     }
 } ;
 
-{ >local-time >local-time! } related-words
-
 HELP: >gmt
-{ $values { "timestamp" timestamp } { "timestamp'" timestamp } }
+{ $values { "timestamp" timestamp } }
 { $description "Converts the " { $snippet "timestamp" } " to the GMT timezone." }
 { $examples
     { $example "USING: accessors calendar kernel prettyprint ;"
@@ -291,7 +289,17 @@ HELP: >gmt
     }
 } ;
 
-{ >gmt >gmt! } related-words
+HELP: local-time
+{ $values { "timestamp" timestamp } }
+{ $description "Set the time zone to the computer's local timezone." }
+{ $notes "The time is not converted, if you want that then call " { $link >local-time } "." } ;
+
+HELP: gmt
+{ $values { "timestamp" timestamp } }
+{ $description "Set the time zone to GMT." }
+{ $notes "The time is not converted, if you want that then call " { $link >gmt } "." } ;
+
+{ local-time >local-time gmt >gmt convert-timezone } related-words
 
 HELP: time*
 { $values { "obj1" object } { "obj2" object } { "obj3" object } }
@@ -322,11 +330,11 @@ HELP: micros>timestamp
     }
 } ;
 
-HELP: gmt
+HELP: now-gmt
 { $values { "timestamp" timestamp } }
 { $description "Returns the time right now, but in the GMT timezone." } ;
 
-{ gmt now } related-words
+{ now now-gmt } related-words
 
 HELP: now
 { $values { "timestamp" timestamp } }
@@ -422,58 +430,58 @@ HELP: week-number
 } ;
 
 HELP: sunday
-{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $values { "timestamp" timestamp } }
 { $description "Returns the Sunday from the current week, which starts on a Sunday." } ;
 
 HELP: monday
-{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $values { "timestamp" timestamp } }
 { $description "Returns the Monday from the current week, which starts on a Sunday." } ;
 
 HELP: tuesday
-{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $values { "timestamp" timestamp } }
 { $description "Returns the Tuesday from the current week, which starts on a Sunday." } ;
 
 HELP: wednesday
-{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $values { "timestamp" timestamp } }
 { $description "Returns the Wednesday from the current week, which starts on a Sunday." } ;
 
 HELP: thursday
-{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $values { "timestamp" timestamp } }
 { $description "Returns the Thursday from the current week, which starts on a Sunday." } ;
 
 HELP: friday
-{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $values { "timestamp" timestamp } }
 { $description "Returns the Friday from the current week, which starts on a Sunday." } ;
 
 HELP: saturday
-{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
+{ $values { "timestamp" timestamp } }
 { $description "Returns the Saturday from the current week, which starts on a Sunday." } ;
 
 { sunday monday tuesday wednesday thursday friday saturday } related-words
 
 HELP: midnight
-{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
-{ $description "Returns a new timestamp that represents the day at midnight, or the beginning of the day." } ;
+{ $values { "timestamp" timestamp } }
+{ $description "Sets the timestamp to represent the day at midnight, or the beginning of the day." } ;
 
 HELP: noon
-{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
-{ $description "Returns a new timestamp that represents the day at noon, or the middle of the day." } ;
+{ $values { "timestamp" timestamp } }
+{ $description "Sets the timestamp to represent the day at noon, or the middle of the day." } ;
 
 HELP: today
 { $values { "timestamp" timestamp } }
-{ $description "Returns a timestamp that represents today at midnight." } ;
+{ $description "Sets the timestamp to represents today at midnight." } ;
 
 HELP: start-of-month
-{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
-{ $description "Returns a new timestamp with the day set to one." } ;
+{ $values { "timestamp" timestamp } }
+{ $description "Sets the timestamp with the day set to one." } ;
 
 HELP: start-of-week
-{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
-{ $description "Returns a new timestamp where the day of the week is Sunday." } ;
+{ $values { "timestamp" timestamp } }
+{ $description "Sets the timestamp with the day of the week set to Sunday." } ;
 
 HELP: start-of-year
-{ $values { "object" object } { "new-timestamp" timestamp } }
-{ $description "Returns a new timestamp with the month and day set to one, or January 1 of the input timestamp, given a year or a timestamp." } ;
+{ $values { "object" object } { "timestamp" timestamp } }
+{ $description "Sets the timestamp with the month and day set to one, or January 1 of the input timestamp, given a year or a timestamp." } ;
 
 HELP: time-since-midnight
 { $values { "timestamp" timestamp } { "duration" duration } }

diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor
index d5383e7c688250930e7eeb24bfff02a821fa0d10..e2616ad4506f4db482af4ed19e3a5b37bce8d26f 100644 (file)
--- a/basis/calendar/calendar-tests.factor
+++ b/basis/calendar/calendar-tests.factor
@@ -169,10 +169,6 @@ IN: calendar
 { 4 12 } [ 2009 easter [ month>> ] [ day>> ] bi ] unit-test
 { 4 2 } [ 1961 easter [ month>> ] [ day>> ] bi ] unit-test
 
-{ f } [ now dup midnight eq? ] unit-test
-{ f } [ now dup easter eq? ] unit-test
-{ f } [ now dup start-of-year eq? ] unit-test
-
 { t } [ 1325376000 unix-time>timestamp 2012 <year-gmt> = ] unit-test
 { t } [ 1356998399 unix-time>timestamp 2013 <year-gmt> 1 seconds time- = ] unit-test
 
@@ -188,16 +184,12 @@ IN: calendar
     2008 2 29 <date> =
 ] unit-test
 
-{ f } [
-    2020 <year-gmt> dup 10000 >>second [ >gmt ] bi@ eq?
-] unit-test
-
 { t } [
-    2020 <year-gmt> dup 10000 >>second [ >gmt! ] bi@ eq?
+    2020 <year-gmt> dup 10000 >>second [ >gmt ] bi@ eq?
 ] unit-test
 
 { 0 }
-[ gmt gmt-offset>> duration>seconds ] unit-test
+[ now-gmt gmt-offset>> duration>seconds ] unit-test
 
 ! am
 [ now 30 am ] [ not-in-interval? ] must-fail-with
@@ -214,17 +206,6 @@ IN: calendar
 { 53 } [ 2004 weeks-in-week-year ] unit-test
 { 52 } [ 2013 weeks-in-week-year ] unit-test
 
-{ f } [ now dup start-of-day eq? ] unit-test
-{ f } [ now dup end-of-day eq? ] unit-test
-{ t } [ now dup end-of-day! eq? ] unit-test
-{ f } [ now dup start-of-month eq? ] unit-test
-{ f } [ now dup end-of-month eq? ] unit-test
-{ f } [ now dup start-of-year eq? ] unit-test
-{ f } [ now dup end-of-year eq? ] unit-test
-
-{ f } [ now dup midnight eq? ] unit-test
-{ t } [ now dup midnight! eq? ] unit-test
-
 {
     T{ timestamp { year 2019 } { month 11 } { day 4 } }
 } [ 2019 308 year-ordinal>timestamp >gmt midnight ] unit-test
@@ -322,19 +303,6 @@ IN: calendar
     v- sum
 ] unit-test
 
-{ 1 2 3 } [
-    2020 1 1 <date-gmt> 1 2 3 set-time >time<
-] unit-test
-
-{ f } [
-    2020 1 1 <date-gmt> dup 1 2 3 set-time eq?
-] unit-test
-
-{ t } [
-    2020 1 1 <date-gmt> dup 1 2 3 set-time! eq?
-] unit-test
-
-
 {
     {
         T{ timestamp { year 2020 } { month 3 } { day 1 } }
@@ -344,7 +312,7 @@ IN: calendar
         T{ timestamp { year 2020 } { month 3 } { day 29 } }
     }
 } [
-    2020 march-gmt 5 <iota> [ sunday-of-month ] with map
+    2020 march gmt 5 <iota> [ sunday-of-month ] with map
 ] unit-test
 
 
@@ -357,7 +325,7 @@ IN: calendar
         T{ timestamp { year 2020 } { month 2 } { day 29 } }
     }
 } [
-    2020 february-gmt 5 <iota> [ saturday-of-month ] with map
+    2020 february gmt 5 <iota> [ saturday-of-month ] with map
 ] unit-test
 
 
@@ -371,5 +339,5 @@ IN: calendar
         T{ timestamp { year 2021 } { month 1 } { day 4 } }
     }
 } [
-    2020 december-gmt 5 <iota> [ monday-of-month ] with map
+    2020 december gmt 5 <iota> [ monday-of-month ] with map
 ] unit-test

diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index 0752750f961c1d8b3a23158f4812cc69ed9dc8ff..10ba894709620ef069b83de2f71be8dd8e4168e5 100644 (file)
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays classes.tuple combinators
-combinators.short-circuit kernel locals math math.functions
-math.intervals math.order math.parser sequences
+combinators.short-circuit kernel literals math math.functions
+math.intervals math.order math.parser math.statistics sequences
 sequences.rotated slots.syntax splitting system vocabs
 vocabs.loader ;
 FROM: math.ranges => [a..b) ;
@@ -15,7 +15,7 @@ ERROR: not-in-interval value interval ;
 
 HOOK: gmt-offset os ( -- hours minutes seconds )
 
-HOOK: gmt os ( -- timestamp )
+HOOK: now-gmt os ( -- timestamp )
 
 TUPLE: duration
     { year real }
@@ -38,7 +38,13 @@ TUPLE: timestamp
     { second real }
     { gmt-offset duration } ;
 
+<PRIVATE
+<<
 CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
+>>
+CONSTANT: days-until $[ day-counts cum-sum0 ]
+
+PRIVATE>
 
 GENERIC: leap-year? ( obj -- ? )
 
@@ -127,30 +133,21 @@ M: integer easter
     dup easter-month-day <date> ;
 
 M: timestamp easter
-    clone
     dup year>> easter-month-day
     swapd >>day swap >>month ;
 
 : >date< ( timestamp -- year month day )
     [ year>> ] [ month>> ] [ day>> ] tri ;
 
+: set-date ( timestamp year month day -- timestamp )
+    [ >>year ] [ >>month ] [ >>day ] tri* ;
+
 : >time< ( timestamp -- hour minute second )
     [ hour>> ] [ minute>> ] [ second>> ] tri ;
 
-: set-time! ( timestamp hours minutes seconds -- timestamp )
+: set-time ( timestamp hour minute second -- timestamp )
     [ >>hour ] [ >>minute ] [ >>second ] tri* ;
 
-: set-time ( timestamp hours minutes seconds -- timestamp )
-    [ clone ] 3dip set-time! ;
-
-: time>hms ( str -- hms-seq )
-    ":" split [ string>number ] map
-    3 0 pad-tail ;
-
-: time>offset ( str -- hms-seq )
-    "-" ?head [ time>hms ] dip
-    [ [ neg ] map ] when ;
-
 : years ( x -- duration ) instant swap >>year ;
 : bienniums ( x -- duration ) instant swap 2 * >>year ;
 : trienniums ( x -- duration ) instant swap 3 * >>year ;
@@ -309,48 +306,53 @@ M: duration <=> [ duration>years ] compare ;
 
 DEFER: time-
 
+: gmt ( timestamp -- timestamp )
+    instant >>gmt-offset ; inline
+
+: local-time ( timestamp -- timestamp )
+    gmt-offset-duration >>gmt-offset ; inline
+
 : convert-timezone ( timestamp duration -- timestamp )
     [ over gmt-offset>> time- (time+) drop ] [ >>gmt-offset ] bi ;
 
-: >local-time! ( timestamp -- timestamp )
+: >local-time ( timestamp -- timestamp )
     gmt-offset-duration convert-timezone ;
 
-: >local-time ( timestamp -- timestamp' )
-    clone >local-time! ;
-
-: >gmt! ( timestamp -- timestamp )
+: >gmt ( timestamp -- timestamp )
     instant convert-timezone ;
 
-: >gmt ( timestamp -- timestamp' )
-    clone >gmt! ;
+M: timestamp <=> [ clone >gmt tuple-slots ] compare ;
 
-M: timestamp <=> [ >gmt tuple-slots ] compare ;
+<PRIVATE
+
+: same-times? ( timestamp1 timestamp2 quot -- ? )
+    [ clone >gmt ] prepose same? ; inline
+
+PRIVATE>
 
 : same-year? ( ts1 ts2 -- ? )
-    [ >gmt slots{ year } ] same? ;
+    [ slots{ year } ] same-times? ;
 
 : quarter ( timestamp -- [1,4] )
-    month>> 3 /mod [ drop 1 + ] unless-zero ; inline
+    month>> 3 /i 1 + ; inline
 
 : same-quarter? ( ts1 ts2 -- ? )
-    [ >gmt [ year>> ] [ quarter ] bi 2array ] same? ;
+    [ [ year>> ] [ quarter ] bi 2array ] same-times? ;
 
 : same-month? ( ts1 ts2 -- ? )
-    [ >gmt slots{ year month } ] same? ;
+    [ slots{ year month } ] same-times? ;
 
 :: (day-of-year) ( year month day -- n )
-    day-counts month head-slice sum day +
-    year leap-year? [
-        year month day <date>
-        year 3 1 <date>
-        after=? [ 1 + ] when
-    ] when ;
+    month days-until nth day + {
+        [ year leap-year? ]
+        [ month 3 >= ]
+    } 0&& [ 1 + ] when ;
 
 : day-of-year ( timestamp -- n )
     >date< (day-of-year) ;
 
 : same-day? ( ts1 ts2 -- ? )
-    [ >gmt slots{ year month day } ] same? ;
+    [ slots{ year month day } ] same-times? ;
 
 : (day-of-week) ( year month day -- n )
     ! Zeller Congruence
@@ -378,21 +380,21 @@ DEFER: end-of-year
     } case ;
 
 : same-week? ( ts1 ts2 -- ? )
-    [ >gmt [ year>> ] [ week-number ] bi 2array ] same? ;
+    [ [ year>> ] [ week-number ] bi 2array ] same-times? ;
 
 : same-hour? ( ts1 ts2 -- ? )
-    [ >gmt slots{ year month day hour } ] same? ;
+    [ slots{ year month day hour } ] same-times? ;
 
 : same-minute? ( ts1 ts2 -- ? )
-    [ >gmt slots{ year month day hour minute } ] same? ;
+    [ slots{ year month day hour minute } ] same-times? ;
 
 : same-second? ( ts1 ts2 -- ? )
-    [ >gmt slots{ year month day hour minute second } ] same? ;
+    [ slots{ year month day hour minute second } ] same-times? ;
 
 <PRIVATE
 
 : (time-) ( timestamp timestamp -- n )
-    [ >gmt ] bi@
+    [ clone >gmt ] bi@
     [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
     [ >time< [ [ 3600 * ] [ 60 * ] bi* ] dip + + ] bi@ - + ;
 
@@ -437,27 +439,22 @@ M: duration time-
     1970 <year-gmt> ; inline
 
 : millis>timestamp ( x -- timestamp )
-    [ unix-1970 ] dip 1000 / +second ;
+    unix-1970 swap 1000 / +second ;
 
 : timestamp>millis ( timestamp -- n )
     unix-1970 (time-) 1000 * >integer ;
 
 : micros>timestamp ( x -- timestamp )
-    [ unix-1970 ] dip 1000000 / +second ;
+    unix-1970 swap 1000000 / +second ;
 
 : timestamp>micros ( timestamp -- n )
     unix-1970 (time-) 1000000 * >integer ;
 
 : now ( -- timestamp )
-    gmt gmt-offset-duration (time+) >>gmt-offset ;
-
-: now-gmt ( -- timestamp ) gmt ;
+    now-gmt gmt-offset-duration (time+) >>gmt-offset ;
 
 : hence ( duration -- timestamp ) now swap time+ ;
-: hence-gmt ( duration -- timestamp ) now-gmt swap time+ ;
-
 : ago ( duration -- timestamp ) now swap time- ;
-: ago-gmt ( duration -- timestamp ) now-gmt swap time- ;
 
 GENERIC: days-in-year ( obj -- n )
 
@@ -468,136 +465,120 @@ M: timestamp days-in-year year>> days-in-year ;
 : days-in-month ( timestamp -- n )
     >date< drop (days-in-month) ;
 
-: midnight! ( timestamp -- timestamp ) 0 0 0 set-time! ; inline
-: midnight ( timestamp -- new-timestamp ) clone midnight! ; inline
-: midnight-gmt! ( timestamp -- timestamp ) 0 0 0 set-time! instant >>gmt-offset ; inline
-: midnight-gmt ( timestamp -- new-timestamp ) clone midnight-gmt! ; inline
-
-: noon! ( timestamp -- timestamp ) 12 0 0 set-time! ; inline
-: noon ( timestamp -- new-timestamp ) clone noon! ; inline
-: noon-gmt! ( timestamp -- timestamp ) 12 0 0 set-time! instant >>gmt-offset ; inline
-: noon-gmt ( timestamp -- new-timestamp ) clone noon-gmt! ; inline
-
-: today ( -- timestamp ) now midnight! ; inline
-: today-gmt ( -- timestamp ) now midnight-gmt! ; inline
-: tomorrow ( -- timestamp ) 1 days hence midnight! ; inline
-: tomorrow-gmt ( -- timestamp ) 1 days hence midnight-gmt! ; inline
-: overtomorrow ( -- timestamp ) 2 days hence midnight! ; inline
-: overtomorrow-gmt ( -- timestamp ) 2 days hence midnight-gmt! ; inline
-: yesterday ( -- timestamp ) 1 days ago midnight! ; inline
-: yesterday-gmt ( -- timestamp ) 1 days ago midnight-gmt! ; inline
-: ereyesterday ( -- timestamp ) 2 days ago midnight! ; inline
-: ereyesterday-gmt ( -- timestamp ) 2 days ago midnight-gmt! ; inline
-
-: start-of-day! ( timestamp -- timestamp ) midnight! ; inline
-: start-of-day ( object -- new-timestamp ) midnight ; inline
-
-: end-of-day! ( timestamp -- timestamp )
-    23 >>hour 59 >>minute 59+999/1000 >>second ; inline
+: midnight ( timestamp -- timestamp ) 0 0 0 set-time ; inline
+: noon ( timestamp -- timestamp ) 12 0 0 set-time ; inline
+
+: today ( -- timestamp ) now midnight ; inline
+: tomorrow ( -- timestamp ) 1 days hence midnight ; inline
+: overtomorrow ( -- timestamp ) 2 days hence midnight ; inline
+: yesterday ( -- timestamp ) 1 days ago midnight ; inline
+: ereyesterday ( -- timestamp ) 2 days ago midnight ; inline
 
-: end-of-day ( object -- new-timestamp )
-    clone end-of-day! ; inline
+ALIAS: start-of-day midnight
+
+: end-of-day ( timestamp -- timestamp )
+    23 >>hour 59 >>minute 59+999/1000 >>second ; inline
 
-: start-of-month ( timestamp -- new-timestamp )
+: start-of-month ( timestamp -- timestamp )
     midnight 1 >>day ; inline
 
-: end-of-month ( timestamp -- new-timestamp )
+: end-of-month ( timestamp -- timestamp )
     [ end-of-day ] [ days-in-month ] bi >>day ;
 
-: start-of-quarter ( timestamp -- new-timestamp )
+: start-of-quarter ( timestamp -- timestamp )
     [ start-of-day ] [ quarter 1 - 3 * ] bi >>month ; inline
 
-: end-of-quarter ( timestamp -- new-timestamp )
-    [ clone ] [ quarter 1 - 3 * 3 + ] bi >>month end-of-month ; inline
+: end-of-quarter ( timestamp -- timestamp )
+    dup quarter 1 - 3 * 3 + >>month end-of-month ; inline
 
-: first-day-of-month ( object -- new-timestamp )
-    clone 1 >>day ;
+: first-day-of-month ( timestamp -- timestamp )
+    1 >>day ;
 
-: last-day-of-month ( object -- new-timestamp )
-    clone dup days-in-month >>day ; inline
+: last-day-of-month ( timestamp -- timestamp )
+    dup days-in-month >>day ; inline
 
-GENERIC: first-day-of-year ( object -- new-timestamp )
+GENERIC: first-day-of-year ( object -- timestamp )
 M: timestamp first-day-of-year first-day-of-month 1 >>month ;
 M: integer first-day-of-year <year> ;
 
-GENERIC: last-day-of-year ( object -- new-timestamp )
-M: timestamp last-day-of-year clone 12 >>month 31 >>day ;
+GENERIC: last-day-of-year ( object -- timestamp )
+M: timestamp last-day-of-year 12 >>month 31 >>day ;
 M: integer last-day-of-year 12 31 <date> ;
 
-GENERIC: first-day-of-decade ( object -- new-timestamp )
+GENERIC: first-day-of-decade ( object -- timestamp )
 M: timestamp first-day-of-decade first-day-of-year [ dup 10 mod - ] change-year ;
 M: integer first-day-of-decade first-day-of-year [ dup 10 mod - ] change-year ;
 
-GENERIC: last-day-of-decade ( object -- new-timestamp )
+GENERIC: last-day-of-decade ( object -- timestamp )
 M: timestamp last-day-of-decade last-day-of-year [ dup 10 mod - 9 + ] change-year ;
 M: integer last-day-of-decade last-day-of-year [ dup 10 mod - 9 + ] change-year ;
 
-GENERIC: first-day-of-century ( object -- new-timestamp )
+GENERIC: first-day-of-century ( object -- timestamp )
 M: timestamp first-day-of-century first-day-of-year [ dup 100 mod - ] change-year ;
 M: integer first-day-of-century first-day-of-year [ dup 100 mod - ] change-year ;
 
-GENERIC: last-day-of-century ( object -- new-timestamp )
+GENERIC: last-day-of-century ( object -- timestamp )
 M: timestamp last-day-of-century last-day-of-year [ dup 100 mod - 99 + ] change-year ;
 M: integer last-day-of-century last-day-of-year [ dup 100 mod - 99 + ] change-year ;
 
-GENERIC: first-day-of-millennium ( object -- new-timestamp )
+GENERIC: first-day-of-millennium ( object -- timestamp )
 M: timestamp first-day-of-millennium first-day-of-year [ dup 1000 mod - ] change-year ;
 M: integer first-day-of-millennium first-day-of-year [ dup 1000 mod - ] change-year ;
 
-GENERIC: last-day-of-millennium ( object -- new-timestamp )
+GENERIC: last-day-of-millennium ( object -- timestamp )
 M: timestamp last-day-of-millennium last-day-of-year [ dup 1000 mod - 999 + ] change-year ;
 M: integer last-day-of-millennium last-day-of-year [ dup 1000 mod - 999 + ] change-year ;
 
-: start-of-year ( object -- new-timestamp )
-    first-day-of-year start-of-day! ;
+: start-of-year ( object -- timestamp )
+    first-day-of-year start-of-day ;
 
-: end-of-year ( object -- new-timestamp )
-    last-day-of-year end-of-day! ;
+: end-of-year ( object -- timestamp )
+    last-day-of-year end-of-day ;
 
-: start-of-decade ( object -- new-timestamp )
-    first-day-of-decade start-of-day! ;
+: start-of-decade ( object -- timestamp )
+    first-day-of-decade start-of-day ;
 
-: end-of-decade ( object -- new-timestamp )
-    last-day-of-decade end-of-day! ;
+: end-of-decade ( object -- timestamp )
+    last-day-of-decade end-of-day ;
 
-: end-of-century ( object -- new-timestamp )
-    last-day-of-century end-of-day! ;
+: end-of-century ( object -- timestamp )
+    last-day-of-century end-of-day ;
 
-: start-of-millennium ( object -- new-timestamp )
-    first-day-of-millennium start-of-day! ;
+: start-of-millennium ( object -- timestamp )
+    first-day-of-millennium start-of-day ;
 
-: end-of-millennium ( object -- new-timestamp )
-    last-day-of-millennium end-of-day! ;
+: end-of-millennium ( object -- timestamp )
+    last-day-of-millennium end-of-day ;
 
-: start-of-hour ( timestamp -- new-timestamp ) clone 0 >>minute 0 >>second ;
-: end-of-hour ( timestamp -- new-timestamp ) clone 59 >>minute 59+999/1000 >>second ;
+: start-of-hour ( timestamp -- timestamp ) 0 >>minute 0 >>second ;
+: end-of-hour ( timestamp -- timestamp ) 59 >>minute 59+999/1000 >>second ;
 
-: start-of-minute ( timestamp -- new-timestamp ) clone 0 >>second ;
-: end-of-minute ( timestamp -- new-timestamp ) clone 59+999/1000 >>second ;
+: start-of-minute ( timestamp -- timestamp ) 0 >>second ;
+: end-of-minute ( timestamp -- timestamp ) 59+999/1000 >>second ;
 
-GENERIC: start-of-second ( object -- new-timestamp )
-M: timestamp start-of-second clone [ floor ] change-second ;
+GENERIC: start-of-second ( object -- timestamp )
+M: timestamp start-of-second [ floor ] change-second ;
 M: real start-of-second floor ;
 
-GENERIC: end-of-second ( object -- new-timestamp )
-M: timestamp end-of-second clone [ floor 999/1000 + ] change-second ;
+GENERIC: end-of-second ( object -- timestamp )
+M: timestamp end-of-second [ floor 999/1000 + ] change-second ;
 M: real end-of-second floor 999/1000 + ;
 
 <PRIVATE
 
-: day-offset ( timestamp m -- new-timestamp n )
+: day-offset ( timestamp m -- timestamp n )
     over day-of-week - ; inline
 
 : day-this-week ( timestamp n -- new-timestamp )
     day-offset days time+ ;
 
-: closest-day ( timestamp n -- new-timestamp )
+: closest-day ( timestamp n -- timestamp )
     [ dup day-of-week ] dip
     { 0 1 2 3 -3 -2 -1 }
     rot 7 swap - <rotated> nth days time+ ;
 
 :: nth-day-this-month ( timestamp n day -- new-timestamp )
-    timestamp start-of-month day day-this-week
+    timestamp clone start-of-month day day-this-week
     dup timestamp [ month>> ] same?
     [ 1 weeks time+ ] unless
     n [ weeks time+ ] unless-zero ;
@@ -630,84 +611,37 @@ M: integer october 10 1 <date> ;
 M: integer november 11 1 <date> ;
 M: integer december 12 1 <date> ;
 
-M: timestamp january clone 1 >>month ;
-M: timestamp february clone 2 >>month ;
-M: timestamp march clone 3 >>month ;
-M: timestamp april clone 4 >>month ;
-M: timestamp may clone 5 >>month ;
-M: timestamp june clone 6 >>month ;
-M: timestamp july clone 7 >>month ;
-M: timestamp august clone 8 >>month ;
-M: timestamp september clone 9 >>month ;
-M: timestamp october clone 10 >>month ;
-M: timestamp november clone 11 >>month ;
-M: timestamp december clone 12 >>month ;
-
-GENERIC: january-gmt ( obj -- timestamp )
-GENERIC: february-gmt ( obj -- timestamp )
-GENERIC: march-gmt ( obj -- timestamp )
-GENERIC: april-gmt ( obj -- timestamp )
-GENERIC: may-gmt ( obj -- timestamp )
-GENERIC: june-gmt ( obj -- timestamp )
-GENERIC: july-gmt ( obj -- timestamp )
-GENERIC: august-gmt ( obj -- timestamp )
-GENERIC: september-gmt ( obj -- timestamp )
-GENERIC: october-gmt ( obj -- timestamp )
-GENERIC: november-gmt ( obj -- timestamp )
-GENERIC: december-gmt ( obj -- timestamp )
-
-M: integer january-gmt 1 1 <date-gmt> ;
-M: integer february-gmt 2 1 <date-gmt> ;
-M: integer march-gmt 3 1 <date-gmt> ;
-M: integer april-gmt 4 1 <date-gmt> ;
-M: integer may-gmt 5 1 <date-gmt> ;
-M: integer june-gmt 6 1 <date-gmt> ;
-M: integer july-gmt 7 1 <date-gmt> ;
-M: integer august-gmt 8 1 <date-gmt> ;
-M: integer september-gmt 9 1 <date-gmt> ;
-M: integer october-gmt 10 1 <date-gmt> ;
-M: integer november-gmt 11 1 <date-gmt> ;
-M: integer december-gmt 12 1 <date-gmt> ;
-
-M: timestamp january-gmt >gmt 1 >>month ;
-M: timestamp february-gmt >gmt 2 >>month ;
-M: timestamp march-gmt >gmt 3 >>month ;
-M: timestamp april-gmt >gmt 4 >>month ;
-M: timestamp may-gmt >gmt 5 >>month ;
-M: timestamp june-gmt >gmt 6 >>month ;
-M: timestamp july-gmt >gmt 7 >>month ;
-M: timestamp august-gmt >gmt 8 >>month ;
-M: timestamp september-gmt >gmt 9 >>month ;
-M: timestamp october-gmt >gmt 10 >>month ;
-M: timestamp november-gmt >gmt 11 >>month ;
-M: timestamp december-gmt >gmt 12 >>month ;
-
-: closest-sunday ( timestamp -- new-timestamp ) 0 closest-day ;
-: closest-monday ( timestamp -- new-timestamp ) 1 closest-day ;
-: closest-tuesday ( timestamp -- new-timestamp ) 2 closest-day ;
-: closest-wednesday ( timestamp -- new-timestamp ) 3 closest-day ;
-: closest-thursday ( timestamp -- new-timestamp ) 4 closest-day ;
-: closest-friday ( timestamp -- new-timestamp ) 5 closest-day ;
-: closest-saturday ( timestamp -- new-timestamp ) 6 closest-day ;
-
-: sunday ( timestamp -- new-timestamp ) 0 day-this-week ;
-: monday ( timestamp -- new-timestamp ) 1 day-this-week ;
-: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ;
-: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ;
-: thursday ( timestamp -- new-timestamp ) 4 day-this-week ;
-: friday ( timestamp -- new-timestamp ) 5 day-this-week ;
-: saturday ( timestamp -- new-timestamp ) 6 day-this-week ;
-
-: sunday-gmt ( timestamp -- new-timestamp ) sunday >gmt! ;
-: monday-gmt ( timestamp -- new-timestamp ) monday >gmt! ;
-: tuesday-gmt ( timestamp -- new-timestamp ) tuesday >gmt! ;
-: wednesday-gmt ( timestamp -- new-timestamp ) wednesday >gmt! ;
-: thursday-gmt ( timestamp -- new-timestamp ) thursday >gmt! ;
-: friday-gmt ( timestamp -- new-timestamp ) friday >gmt! ;
-: saturday-gmt ( timestamp -- new-timestamp ) saturday >gmt! ;
-
-: first-day-of-week ( object -- new-timestamp ) sunday ; inline
-: last-day-of-week ( object -- new-timestamp ) saturday ; inline
+M: timestamp january 1 >>month ;
+M: timestamp february 2 >>month ;
+M: timestamp march 3 >>month ;
+M: timestamp april 4 >>month ;
+M: timestamp may 5 >>month ;
+M: timestamp june 6 >>month ;
+M: timestamp july 7 >>month ;
+M: timestamp august 8 >>month ;
+M: timestamp september 9 >>month ;
+M: timestamp october 10 >>month ;
+M: timestamp november 11 >>month ;
+M: timestamp december 12 >>month ;
+
+: closest-sunday ( timestamp -- timestamp ) 0 closest-day ;
+: closest-monday ( timestamp -- timestamp ) 1 closest-day ;
+: closest-tuesday ( timestamp -- timestamp ) 2 closest-day ;
+: closest-wednesday ( timestamp -- timestamp ) 3 closest-day ;
+: closest-thursday ( timestamp -- timestamp ) 4 closest-day ;
+: closest-friday ( timestamp -- timestamp ) 5 closest-day ;
+: closest-saturday ( timestamp -- timestamp ) 6 closest-day ;
+
+: sunday ( timestamp -- timestamp ) 0 day-this-week ;
+: monday ( timestamp -- timestamp ) 1 day-this-week ;
+: tuesday ( timestamp -- timestamp ) 2 day-this-week ;
+: wednesday ( timestamp -- timestamp ) 3 day-this-week ;
+: thursday ( timestamp -- timestamp ) 4 day-this-week ;
+: friday ( timestamp -- timestamp ) 5 day-this-week ;
+: saturday ( timestamp -- timestamp ) 6 day-this-week ;
+
+ALIAS: first-day-of-week sunday
+ALIAS: last-day-of-week saturday
 
 : day< ( quot -- new-timestamp ) keep over before=? [ 7 days time- ] when ; inline
 : day<= ( quot -- new-timestamp ) keep over before? [ 7 days time- ] when ; inline
@@ -770,18 +704,18 @@ M: timestamp december-gmt >gmt 12 >>month ;
 : friday? ( timestamp -- ? ) day-of-week 5 = ;
 : saturday? ( timestamp -- ? ) day-of-week 6 = ;
 
-: january? ( obj -- timestamp ) month>> 1 = ;
-: february? ( obj -- timestamp ) month>> 2 = ;
-: march? ( obj -- timestamp ) month>> 3  = ;
-: april? ( obj -- timestamp ) month>> 4 = ;
-: may? ( obj -- timestamp ) month>> 5 = ;
-: june? ( obj -- timestamp ) month>> 6 = ;
-: july? ( obj -- timestamp ) month>> 7 = ;
-: august? ( obj -- timestamp ) month>> 8 = ;
-: september? ( obj -- timestamp ) month>> 9 = ;
-: october? ( obj -- timestamp ) month>> 10 = ;
-: november? ( obj -- timestamp ) month>> 11 = ;
-: december? ( obj -- timestamp ) month>> 12 = ;
+: january? ( obj -- ? ) month>> 1 = ;
+: february? ( obj -- ? ) month>> 2 = ;
+: march? ( obj -- ? ) month>> 3  = ;
+: april? ( obj -- ? ) month>> 4 = ;
+: may? ( obj -- ? ) month>> 5 = ;
+: june? ( obj -- ? ) month>> 6 = ;
+: july? ( obj -- ? ) month>> 7 = ;
+: august? ( obj -- ? ) month>> 8 = ;
+: september? ( obj -- ? ) month>> 9 = ;
+: october? ( obj -- ? ) month>> 10 = ;
+: november? ( obj -- ? ) month>> 11 = ;
+: december? ( obj -- ? ) month>> 12 = ;
 
 GENERIC: weekend? ( obj -- ? )
 M: timestamp weekend? day-of-week weekend? ;
@@ -838,23 +772,23 @@ CONSTANT: weekday-offsets { 0 0 1 2 3 4 5 }
 : last-friday-of-month ( timestamp -- new-timestamp ) last-day-of-month friday<= ;
 : last-saturday-of-month ( timestamp -- new-timestamp ) last-day-of-month saturday<= ;
 
-: start-of-week ( timestamp -- new-timestamp )
-    sunday midnight! ;
+: start-of-week ( timestamp -- timestamp )
+    sunday midnight ;
 
-: end-of-week ( timestamp -- new-timestamp )
-    saturday end-of-day! ;
+: end-of-week ( timestamp -- timestamp )
+    saturday end-of-day ;
 
-: o'clock ( timestamp n -- new-timestamp )
+: o'clock ( timestamp n -- timestamp )
     [ midnight ] dip >>hour ;
 
-: am ( timestamp n -- new-timestamp )
+: am ( timestamp n -- timestamp )
     0 12 [a,b] check-interval o'clock ;
 
-: pm ( timestamp n -- new-timestamp )
+: pm ( timestamp n -- timestamp )
     0 12 [a,b] check-interval 12 + o'clock ;
 
 : time-since-midnight ( timestamp -- duration )
-    dup midnight time- ; inline
+    dup clone midnight time- ; inline
 
 : since-1970 ( duration -- timestamp )
     unix-1970 time+ ; inline

diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor
index f86e5c043b98aa45317e060cae34dff552cc1cef..3fbe252511a474a8a728d8c596e298bfef3ca18f 100644 (file)
--- a/basis/calendar/unix/unix.factor
+++ b/basis/calendar/unix/unix.factor
@@ -40,5 +40,5 @@ M: unix gmt-offset
 : system-micros ( -- n )
     current-timeval timeval>micros ;
 
-M: unix gmt
+M: unix now-gmt
     current-timeval timeval>unix-time ;

diff --git a/basis/calendar/windows/windows.factor b/basis/calendar/windows/windows.factor
index 09227c6afbe72baaa3a0d0369b05349e376332af..dea9f7257ea2b3cfd08260cf87ae52cf8fe39033 100644 (file)
--- a/basis/calendar/windows/windows.factor
+++ b/basis/calendar/windows/windows.factor
@@ -37,5 +37,5 @@ M: windows gmt-offset
         { TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] }
     } case neg 60 /mod 0 ;
 
-M: windows gmt
+M: windows now-gmt
     SYSTEMTIME <struct> [ GetSystemTime ] keep SYSTEMTIME>timestamp ;

diff --git a/basis/furnace/cache/cache.factor b/basis/furnace/cache/cache.factor
index abb41867a36f63f2efdaa51810d3c70e9cb398b4..a43f74ffab7cef11d17e673442b92e27e1d0778b 100644 (file)
--- a/basis/furnace/cache/cache.factor
+++ b/basis/furnace/cache/cache.factor
@@ -22,7 +22,7 @@ server-state f
 
 : expire-state ( class -- )
     new
-        -1/0. gmt timestamp>micros [a,b] >>expires
+        -1/0. now-gmt timestamp>micros [a,b] >>expires
     delete-tuples ;
 
 TUPLE: server-state-manager < filter-responder timeout ;

diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor
index e00c3e2b416b4a1e1435669e1b70ddf4c1ffd711..5690545268eb9dbbb081aa572d0d20f67b1aee90 100644 (file)
--- a/basis/smtp/smtp.factor
+++ b/basis/smtp/smtp.factor
@@ -193,7 +193,7 @@ ERROR: invalid-header-string string ;
         "<" %
         64 random-bits #
         "-" %
-        gmt timestamp>micros #
+        now-gmt timestamp>micros #
         "@" %
         smtp-config get domain>> [ host-name ] unless* %
         ">" %

diff --git a/basis/uuid/uuid.factor b/basis/uuid/uuid.factor
index 21b60feffc139d0fcdcc960adcf9f2382379a5f7..5c34a8c8c65b65120fa287c7b280323c05fa2a3d 100644 (file)
--- a/basis/uuid/uuid.factor
+++ b/basis/uuid/uuid.factor
@@ -11,7 +11,7 @@ IN: uuid
     ! 0x01b21dd213814000L is the number of 100-ns intervals
     ! between the UUID epoch 1582-10-15 00:00:00 and the
     ! Unix epoch 1970-01-01 00:00:00.
-    gmt timestamp>micros 10 * 0x01b21dd213814000 +
+    now-gmt timestamp>micros 10 * 0x01b21dd213814000 +
     [ -48 shift 0x0fff bitand ]
     [ -32 shift 0xffff bitand ]
     [ 0xffffffff bitand ]

diff --git a/extra/ci/run-process/run-process.factor b/extra/ci/run-process/run-process.factor
index 425afdf18f9b0da4664e8f764bfc886a1a748b50..67c2693e1ea1fe187e96ba7d80a19868412f25bf 100644 (file)
--- a/extra/ci/run-process/run-process.factor
+++ b/extra/ci/run-process/run-process.factor
@@ -13,7 +13,7 @@ TUPLE: process-autopsy
 : ci-run-process ( process -- timestamp os-envs cwd uid euid gid egid out elapsed os-envs' process )
     [
         [
-            gmt os-envs current-directory get
+            now-gmt os-envs current-directory get
             real-user-id effective-user-id
             real-group-id effective-group-id
         ] dip [
@@ -71,4 +71,4 @@ TUPLE: process-autopsy
             bl bl out>> "out" tag-payload print nl
         ]
         [ drop ";AUTOPSY>" print ]
-    } cleave ;
\ No newline at end of file
+    } cleave ;

diff --git a/extra/irc/messages/base/base.factor b/extra/irc/messages/base/base.factor
index 9ba613f2fae22df57c504a77895f403fb7fe4503..e79431a9fdb1ee60bfd81f297ffc8b8165f1b383 100644 (file)
--- a/extra/irc/messages/base/base.factor
+++ b/extra/irc/messages/base/base.factor
@@ -51,7 +51,7 @@ M: irc-message post-process-irc-message drop ;
 
 GENERIC: fill-irc-message-slots ( irc-message -- )
 M: irc-message fill-irc-message-slots
-    gmt >>timestamp
+    now-gmt >>timestamp
     {
         [ process-irc-trailing ]
         [ process-irc-prefix ]

diff --git a/extra/key-logger/key-logger.factor b/extra/key-logger/key-logger.factor
index fd04d3a15da087218f91d823900c7f3f7bb283bf..c4b48a2de33a7c7a3c33b3e8c9847b9dddceb6b1 100644 (file)
--- a/extra/key-logger/key-logger.factor
+++ b/extra/key-logger/key-logger.factor
@@ -12,7 +12,7 @@ CONSTANT: path "resource:key-log.txt"
 : update-key-caps-state ( -- )
     read-keyboard keys>>
     path binary [
-        [ gmt unix-1970 time- duration>nanoseconds >integer ]
+        [ now-gmt unix-1970 time- duration>nanoseconds >integer ]
         [ bit-array>integer ] bi*
         [ 8 >be write ] bi@ flush
     ] with-file-appender ;

diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor
index 730a819e98926b29ccb50d27fc9921d47dc68cc6..c425890c402bc05e8a921798157ea8763fd70793 100644 (file)
--- a/extra/managed-server/chat/chat.factor
+++ b/extra/managed-server/chat/chat.factor
@@ -76,7 +76,7 @@ Displays the documentation for a command."
 Shows the list of connected users."
 "who" add-command
 
-[ drop gmt timestamp>rfc822 send-line ]
+[ drop now-gmt timestamp>rfc822 send-line ]
 "Syntax: /time
 Returns the current GMT time." "time" add-command
 

diff --git a/extra/webapps/irc-log/irc-log.factor b/extra/webapps/irc-log/irc-log.factor
index f0a8baa53d208c7561afaf2698dd4f210f460669..74805f91e860b11ec0920eeea7f74fc9cec23eeb 100644 (file)
--- a/extra/webapps/irc-log/irc-log.factor
+++ b/extra/webapps/irc-log/irc-log.factor
@@ -8,7 +8,7 @@ IN: webapps.irc-log
 TUPLE: irclog-app < dispatcher ;
 
 : irc-link ( channel -- string )
-    gmt -7 hours convert-timezone >date<
+    now-gmt -7 hours convert-timezone >date<
     [ unparse 2 tail ] 2dip
     "http://bespin.org/~nef/logs/%s/%02s.%02d.%02d"
     sprintf ;

diff --git a/extra/zoneinfo/zoneinfo.factor b/extra/zoneinfo/zoneinfo.factor
index 33373493e9377aaf8b4f5ce680be81af9174e88c..ac7a02a9a383efdcec6aac317e11430cdac638f1 100644 (file)
--- a/extra/zoneinfo/zoneinfo.factor
+++ b/extra/zoneinfo/zoneinfo.factor
@@ -221,14 +221,20 @@ ERROR: unknown-last-day string ;
         [ [ string>year ] bi@ ]
     } cond ;
 
+: parse-hms ( str -- hms-seq )
+    ":" split [ string>number ] map 3 0 pad-tail ;
+
+: parse-offset ( str -- hms-seq )
+    "-" ?head [ parse-hms ] dip [ [ neg ] map ] when ;
+
 ! XXX: Don't just drop the s/u, e.g. 2:00:00s
 : zone-time ( timestamp time -- timestamp' )
     [ Letter? ] split-tail drop
-    time>offset first3 set-time ;
+    parse-offset first3 set-time ;
 
 : hm>duration ( str -- duration )
     ":" split1 "0" or [ string>number ] bi@
-    [ instant ] 2dip 0 set-time! ;
+    [ instant ] 2dip 0 set-time ;
 
 : rule>timestamp-rest ( timestamp zone -- from )
     {
@@ -275,4 +281,4 @@ ERROR: unknown-last-day string ;
     ] keep zip ;
 
 : chicago-zones ( -- interval-map ) "America/Chicago" name>zones ;
- : us-rules ( -- rules ) "US" name>rules ;
\ No newline at end of file
+ : us-rules ( -- rules ) "US" name>rules ;