diff --git a/contrib/calendar/calendar.factor b/contrib/calendar/calendar.factor index 70415eb1b5..3679bb4347 100644 --- a/contrib/calendar/calendar.factor +++ b/contrib/calendar/calendar.factor @@ -29,10 +29,8 @@ TUPLE: dt year month day hour minute second ; #! length of average month in days 30.41666666666667 ; -: time>array ( dt -- vec ) tuple>array 2 tail ; - : compare-timestamps ( tuple tuple -- n ) - [ time>array ] 2apply <=> ; + [ tuple-slots ] 2apply <=> ; SYMBOL: a SYMBOL: b @@ -173,12 +171,12 @@ M: number +second ( timestamp n -- timestamp ) [ = [ "invalid timestamp" throw ] unless ] keep ; : array>dt ( vec -- dt ) { dt f } swap append >tuple ; -: +dts ( dt dt -- dt ) [ time>array ] 2apply v+ array>dt ; +: +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ; : dt>years ( dt -- x ) #! Uses average month/year length since dt loses calendar #! data - time>array + tuple-slots { 1 12 365.2425 8765.82 525949.2 31556952.0 } [ / ] 2map sum ; : dt>months ( dt -- x ) dt>years 12 * ; @@ -208,10 +206,10 @@ M: number +second ( timestamp n -- timestamp ) unix-1970 millis 1000 /f seconds +dt ; : timestamp- ( timestamp timestamp -- dt ) - [ >gmt time>array ] 2apply v- array>dt ; + [ >gmt tuple-slots ] 2apply v- array>dt ; : now ( -- timestamp ) gmt >local-time ; -: before ( dt -- -dt ) time>array [ neg ] map array>dt ; +: before ( dt -- -dt ) tuple-slots [ neg ] map array>dt ; : from-now ( dt -- timestamp ) now swap +dt ; : ago ( dt -- timestamp ) before from-now ; diff --git a/contrib/furnace/responder.factor b/contrib/furnace/responder.factor index 43d11ae46b..44ec893e06 100644 --- a/contrib/furnace/responder.factor +++ b/contrib/furnace/responder.factor @@ -87,7 +87,7 @@ SYMBOL: request-params : service-post ( url -- ) "response" get swap service-request ; : explode-tuple ( tuple -- ) - dup tuple>array 2 tail swap class "slot-names" word-prop + dup tuple-slots swap class "slot-names" word-prop [ set ] 2each ; SYMBOL: model diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 3d934e320d..9ffbb201e9 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -45,7 +45,7 @@ IN: generic : delegate-slots { { 3 object delegate set-delegate } } ; -: tuple-slots ( class slots -- ) +: define-tuple-slots ( class slots -- ) 2dup "slot-names" set-word-prop 2dup length 2 + "tuple-size" set-word-prop dupd 4 simple-slots @@ -80,7 +80,7 @@ TUPLE: check-tuple class ; dup tuple-predicate dup \ tuple bootstrap-word "superclass" set-word-prop dup define-class - dup r> tuple-slots + dup r> define-tuple-slots default-constructor ; M: tuple clone @@ -106,6 +106,8 @@ GENERIC: tuple>array ( tuple -- array ) M: tuple tuple>array (clone) array-type become ; +: tuple-slots ( tuple -- seq ) tuple>array 2 tail ; + ! Definition protocol M: tuple-class forget dup "constructor" word-prop forget forget-class ;