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

tuple-slots word

slava 2006-11-12 17:56:07 +00:00
parent 86ce41eba9
commit 318b86a530
3 changed files with 10 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
contrib/calendar/calendar.factor
View File

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

2
contrib/furnace/responder.factor
View File

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

6
library/generic/tuple.factor
View File

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