1 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors calendar combinators.short-circuit fry kernel
4 math math.functions quotations system threads typed ;
8 { quot callable initial: [ ] }
19 GENERIC: >nanoseconds ( obj -- duration/f )
21 M: real >nanoseconds >integer ;
22 M: duration >nanoseconds duration>nanoseconds >integer ;
24 TYPED: set-next-timer-time ( timer: timer -- timer )
25 ! start + delay + ceiling((now - (start + delay)) / interval) * interval
28 over delay-nanos>> [ - ] when*
29 over interval-nanos>> / ceiling
30 over interval-nanos>> *
32 over delay-nanos>> [ + ] when*
33 >>iteration-start-nanos ;
35 TYPED: stop-timer? ( timer: timer -- ? )
36 { [ thread>> self eq? not ] [ restart?>> ] } 1|| ; inline
38 DEFER: call-timer-loop
40 TYPED: loop-timer ( timer: timer -- )
42 [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi <
43 [ set-next-timer-time ] dip
44 [ dup iteration-start-nanos>> ] [ 0 ] if
45 0 or sleep-until call-timer-loop ;
47 TYPED: maybe-loop-timer ( timer: timer -- )
48 dup { [ stop-timer? ] [ interval-nanos>> not ] } 1||
49 [ drop ] [ loop-timer ] if ;
51 TYPED: call-timer-loop ( timer: timer -- )
56 [ t >>quotation-running? drop ]
58 [ f >>quotation-running? drop ] tri
63 TYPED: sleep-delay ( timer: timer -- )
67 nano-count >>start-nanos
68 delay-nanos>> [ sleep ] when*
71 TYPED: timer-loop ( timer: timer -- )
73 [ nano-count >>iteration-start-nanos call-timer-loop ]
74 [ dup restart?>> [ f >>restart? timer-loop ] [ drop ] if ] tri ;
78 : <timer> ( quot delay-duration/f interval-duration/f -- timer )
80 swap >nanoseconds >>interval-nanos
81 swap >nanoseconds >>delay-nanos
84 : start-timer ( timer -- )
86 '[ _ timer-loop ] "Timer execution" spawn
89 : stop-timer ( timer -- )
90 dup quotation-running?>> [
93 [ [ interrupt ] when* f ] change-thread drop
96 : restart-timer ( timer -- )
98 dup quotation-running?>> [
101 dup thread>> [ nip interrupt ] [ start-timer ] if*
106 : (start-timer) ( quot start-duration interval-duration -- timer )
107 <timer> [ start-timer ] keep ; inline
111 : every ( quot interval-duration -- timer )
112 [ f ] dip (start-timer) ;
114 : later ( quot delay-duration -- timer )
117 : delayed-every ( quot duration -- timer )
120 : nanos-since ( nano-count -- nanos )
121 [ nano-count ] dip - ;