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

Revert "make alarms use new accessors" 

This reverts commit e91129ba10.
db4
Doug Coleman 2008-08-29 10:14:16 -05:00
parent 304c713954
commit 524bce2dd2
1 changed files with 20 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
basis/alarms/alarms.factor
View File

@ -1,15 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar combinators generic init USING: arrays calendar combinators generic init kernel math
kernel math namespaces sequences heaps boxes threads debugger namespaces sequences heaps boxes threads debugger quotations
quotations assocs math.order ; assocs math.order ;
IN: alarms IN: alarms
TUPLE: alarm TUPLE: alarm quot time interval entry ;
{ quot callable initial: [ ] }
{ time timestamp }
interval
{ entry box } ;
<PRIVATE <PRIVATE
@ -19,28 +15,31 @@ SYMBOL: alarm-thread
: notify-alarm-thread ( -- ) : notify-alarm-thread ( -- )
alarm-thread get-global interrupt ; alarm-thread get-global interrupt ;
ERROR: bad-alarm-frequency frequency ; : check-alarm
: check-alarm ( frequency/f -- frequency/f ) dup duration? over not or [ "Not a duration" throw ] unless
dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ; over timestamp? [ "Not a timestamp" throw ] unless
pick callable? [ "Not a quotation" throw ] unless ; inline
: <alarm> ( quot time frequency -- alarm ) : <alarm> ( quot time frequency -- alarm )
check-alarm <box> alarm boa ; check-alarm <box> alarm boa ;
: register-alarm ( alarm -- ) : register-alarm ( alarm -- )
dup dup time>> alarms get-global heap-push* dup dup alarm-time alarms get-global heap-push*
swap entry>> >box swap alarm-entry >box
notify-alarm-thread ; notify-alarm-thread ;
: alarm-expired? ( alarm now -- ? ) : alarm-expired? ( alarm now -- ? )
[ time>> ] dip before=? ; >r alarm-time r> before=? ;
: reschedule-alarm ( alarm -- ) : reschedule-alarm ( alarm -- )
dup [ swap interval>> time+ ] change-time register-alarm ; dup alarm-time over alarm-interval time+
over set-alarm-time
register-alarm ;
: call-alarm ( alarm -- ) : call-alarm ( alarm -- )
[ entry>> box> drop ] dup alarm-entry box> drop
[ quot>> "Alarm execution" spawn drop ] dup alarm-quot "Alarm execution" spawn drop
[ dup interval>> [ reschedule-alarm ] [ drop ] if ] tri ; dup alarm-interval [ reschedule-alarm ] [ drop ] if ;
: (trigger-alarms) ( alarms now -- ) : (trigger-alarms) ( alarms now -- )
over heap-empty? [ over heap-empty? [
@ -58,7 +57,7 @@ ERROR: bad-alarm-frequency frequency ;
: 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 alarm-time ] if ;
: alarm-thread-loop ( -- ) : alarm-thread-loop ( -- )
alarms get-global alarms get-global
@ -67,7 +66,7 @@ ERROR: bad-alarm-frequency frequency ;
: cancel-alarms ( alarms -- ) : cancel-alarms ( alarms -- )
[ [
heap-pop-all [ nip entry>> box> drop ] assoc-each heap-pop-all [ nip alarm-entry box> drop ] assoc-each
] when* ; ] when* ;
: init-alarms ( -- ) : init-alarms ( -- )
@ -89,4 +88,4 @@ PRIVATE>
[ hence ] keep add-alarm ; [ hence ] keep add-alarm ;
: cancel-alarm ( alarm -- ) : cancel-alarm ( alarm -- )
entry>> [ alarms get-global heap-delete ] if-box? ; alarm-entry [ alarms get-global heap-delete ] if-box? ;