1 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors calendar kernel math quotations system threads ;
9 { quot callable initial: [ ] }
18 GENERIC: >nanoseconds ( obj -- duration/f )
20 M: real >nanoseconds >integer ;
21 M: duration >nanoseconds duration>nanoseconds >integer ;
23 : delay-nanos ( timer -- n )
24 delay-nanos>> 0 or nano-count + ;
26 : interval-nanos ( timer -- n/f )
27 [ next-nanos>> nano-count over - ] [ interval-nanos>> ] bi
28 [ dupd [ mod ] [ swap - ] bi + + ] [ 2drop f ] if* ;
30 : next-nanos ( timer -- timer n/f )
31 dup thread>> self eq? [ dup next-nanos>> ] [ f ] if ;
33 : run-timer ( timer -- timer )
34 dup interval-nanos >>next-nanos
35 t >>quotation-running?
37 f >>quotation-running? ;
39 : timer-loop ( timer -- )
46 ] while* dup thread>> self eq? [ f >>thread ] when drop ;
48 : ?interrupt ( thread timer -- )
49 quotation-running?>> [ drop ] [ [ interrupt ] when* ] if ;
53 ERROR: timer-already-started timer ;
55 : <timer> ( quot delay-duration/f interval-duration/f -- timer )
57 swap >nanoseconds >>interval-nanos
58 swap >nanoseconds >>delay-nanos
61 : start-timer ( timer -- )
62 dup thread>> [ timer-already-started ] when
63 dup delay-nanos >>next-nanos
64 dup '[ _ timer-loop ] "Timer" <thread>
65 [ >>thread drop ] [ (spawn) ] bi ;
67 : stop-timer ( timer -- )
68 [ f ] change-thread ?interrupt ;
70 : restart-timer ( timer -- )
72 dup delay-nanos >>next-nanos
73 [ thread>> ] [ ?interrupt ] bi
80 : (start-timer) ( quot start-duration interval-duration -- timer )
81 <timer> [ start-timer ] keep ; inline
85 : every ( quot interval-duration -- timer )
86 f swap (start-timer) ;
88 : later ( quot delay-duration -- timer )
91 : delayed-every ( quot duration -- timer )