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

make alarms use monotonic-clock

Doug Coleman 2009-11-30 16:31:47 -06:00
parent f30230a2e4
commit 54de3addd9
3 changed files with 27 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
basis/alarms/alarms.factor
View File

@ -2,12 +2,12 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs boxes calendar USING: accessors assocs boxes calendar
combinators.short-circuit fry heaps init kernel math.order combinators.short-circuit fry heaps init kernel math.order
namespaces quotations threads ; namespaces quotations threads math monotonic-clock ;
IN: alarms IN: alarms
TUPLE: alarm TUPLE: alarm
{ quot callable initial: [ ] } { quot callable initial: [ ] }
{ time timestamp } { start integer }
interval interval
{ entry box } ; { entry box } ;
@ -19,30 +19,33 @@ SYMBOL: alarm-thread
: notify-alarm-thread ( -- ) : notify-alarm-thread ( -- )
alarm-thread get-global interrupt ; alarm-thread get-global interrupt ;
ERROR: bad-alarm-frequency frequency ; : normalize-argument ( obj -- nanoseconds )
: check-alarm ( frequency/f -- frequency/f ) >duration duration>nanoseconds >integer ;
dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
: <alarm> ( quot time frequency -- alarm ) : <alarm> ( quot start interval -- alarm )
check-alarm <box> alarm boa ; alarm new
swap dup [ normalize-argument ] when >>interval
swap dup [ normalize-argument monotonic-count + ] when >>start
swap >>quot
<box> >>entry ;
: register-alarm ( alarm -- ) : register-alarm ( alarm -- )
[ dup time>> alarms get-global heap-push* ] [ dup start>> alarms get-global heap-push* ]
[ entry>> >box ] bi [ entry>> >box ] bi
notify-alarm-thread ; notify-alarm-thread ;
: alarm-expired? ( alarm now -- ? ) : alarm-expired? ( alarm n -- ? )
[ time>> ] dip before=? ; [ start>> ] dip <= ;
: reschedule-alarm ( alarm -- ) : reschedule-alarm ( alarm -- )
dup '[ _ interval>> time+ now max ] change-time register-alarm ; dup interval>> monotonic-count + >>start register-alarm ;
: call-alarm ( alarm -- ) : call-alarm ( alarm -- )
[ entry>> box> drop ] [ entry>> box> drop ]
[ quot>> "Alarm execution" spawn drop ] [ dup interval>> [ reschedule-alarm ] [ drop ] if ]
[ dup interval>> [ reschedule-alarm ] [ drop ] if ] tri ; [ quot>> "Alarm execution" spawn drop ] tri ;
: (trigger-alarms) ( alarms now -- ) : (trigger-alarms) ( alarms n -- )
over heap-empty? [ over heap-empty? [
2drop 2drop
] [ ] [
@ -54,11 +57,11 @@ ERROR: bad-alarm-frequency frequency ;
] if ; ] if ;
: trigger-alarms ( alarms -- ) : trigger-alarms ( alarms -- )
now (trigger-alarms) ; monotonic-count (trigger-alarms) ;
: next-alarm ( alarms -- timestamp/f ) : next-alarm ( alarms -- timestamp/f )
dup heap-empty? dup heap-empty?
[ drop f ] [ heap-peek drop time>> ] if ; [ drop f ] [ heap-peek drop start>> ] if ;
: alarm-thread-loop ( -- ) : alarm-thread-loop ( -- )
alarms get-global alarms get-global
@ -75,18 +78,16 @@ ERROR: bad-alarm-frequency frequency ;
[ alarm-thread-loop t ] "Alarms" spawn-server [ alarm-thread-loop t ] "Alarms" spawn-server
alarm-thread set-global ; alarm-thread set-global ;
[ init-alarms ] "alarms" add-startup-hook [ init-alarms ] "alarms2" add-startup-hook
PRIVATE> PRIVATE>
: add-alarm ( quot time frequency -- alarm ) : add-alarm ( quot start interval -- alarm )
<alarm> [ register-alarm ] keep ; <alarm> [ register-alarm ] keep ;
: later ( quot duration -- alarm ) : later ( quot duration -- alarm ) f add-alarm ;
hence f add-alarm ;
: every ( quot duration -- alarm ) : every ( quot duration -- alarm ) dup add-alarm ;
[ hence ] keep add-alarm ;
: cancel-alarm ( alarm -- ) : cancel-alarm ( alarm -- )
entry>> [ alarms get-global heap-delete ] if-box? ; entry>> [ alarms get-global heap-delete ] if-box? ;

5
basis/calendar/calendar.factor
View File

@ -171,9 +171,10 @@ M: timestamp easter ( timestamp -- timestamp )
: microseconds ( x -- duration ) 1000000 / seconds ; : microseconds ( x -- duration ) 1000000 / seconds ;
: nanoseconds ( x -- duration ) 1000000000 / seconds ; : nanoseconds ( x -- duration ) 1000000000 / seconds ;
GENERIC: >duration ( obj -- duration ) GENERIC: >duration ( obj -- duration/f )
M: duration >duration ; M: duration >duration ;
M: integer >duration seconds ; M: real >duration seconds ;
M: f >duration ;
GENERIC: year ( obj -- n ) GENERIC: year ( obj -- n )
M: integer year ; M: integer year ;

2
basis/ui/gestures/gestures.factor
View File

@ -184,7 +184,7 @@ SYMBOL: drag-timer
: start-drag-timer ( -- ) : start-drag-timer ( -- )
hand-buttons get-global empty? [ hand-buttons get-global empty? [
[ drag-gesture ] [ drag-gesture ]
300 milliseconds hence 300 milliseconds
100 milliseconds 100 milliseconds
add-alarm drag-timer get-global >box add-alarm drag-timer get-global >box
] when ; ] when ;