1 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays calendar combinators generic init
4 kernel math namespaces sequences heaps boxes threads
5 quotations assocs math.order ;
9 { quot callable initial: [ ] }
19 : notify-alarm-thread ( -- )
20 alarm-thread get-global interrupt ;
22 ERROR: bad-alarm-frequency frequency ;
23 : check-alarm ( frequency/f -- frequency/f )
24 dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ;
26 : <alarm> ( quot time frequency -- alarm )
27 check-alarm <box> alarm boa ;
29 : register-alarm ( alarm -- )
30 dup dup time>> alarms get-global heap-push*
34 : alarm-expired? ( alarm now -- ? )
35 [ time>> ] dip before=? ;
37 : reschedule-alarm ( alarm -- )
38 dup [ swap interval>> time+ now max ] change-time register-alarm ;
40 : call-alarm ( alarm -- )
42 [ quot>> "Alarm execution" spawn drop ]
43 [ dup interval>> [ reschedule-alarm ] [ drop ] if ] tri ;
45 : (trigger-alarms) ( alarms now -- )
49 over heap-peek drop over alarm-expired? [
50 over heap-pop drop call-alarm (trigger-alarms)
56 : trigger-alarms ( alarms -- )
57 now (trigger-alarms) ;
59 : next-alarm ( alarms -- timestamp/f )
61 [ drop f ] [ heap-peek drop time>> ] if ;
63 : alarm-thread-loop ( -- )
65 dup next-alarm sleep-until
68 : cancel-alarms ( alarms -- )
70 heap-pop-all [ nip entry>> box> drop ] assoc-each
74 alarms global [ cancel-alarms <min-heap> ] change-at
75 [ alarm-thread-loop t ] "Alarms" spawn-server
76 alarm-thread set-global ;
78 [ init-alarms ] "alarms" add-init-hook
82 : add-alarm ( quot time frequency -- alarm )
83 <alarm> [ register-alarm ] keep ;
85 : later ( quot duration -- alarm )
88 : every ( quot duration -- alarm )
89 [ hence ] keep add-alarm ;
91 : cancel-alarm ( alarm -- )
92 entry>> [ alarms get-global heap-delete ] if-box? ;