diff --git a/basis/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor index d30ddb423b..3b70b43a28 100644 --- a/basis/alarms/alarms-docs.factor +++ b/basis/alarms/alarms-docs.factor @@ -8,6 +8,10 @@ HELP: start-alarm { $values { "alarm" alarm } } { $description "Starts an alarm." } ; +HELP: restart-alarm +{ $values { "alarm" alarm } } +{ $description "Starts or restarts an alarm. Restarting an alarm causes the a sleep of initial delay nanoseconds before looping. An alarm's parameters may be modified and restarted with this word." } ; + HELP: stop-alarm { $values { "alarm" alarm } } { $description "Prevents an alarm from calling its quotation again. Has no effect on alarms that are not currently running." } ; @@ -56,7 +60,7 @@ ARTICLE: "alarms" "Alarms" "Create an alarm before starting it:" { $subsections } "Starting an alarm:" -{ $subsections start-alarm } +{ $subsections start-alarm restart-alarm } "Stopping an alarm:" { $subsections stop-alarm } diff --git a/basis/alarms/alarms-tests.factor b/basis/alarms/alarms-tests.factor index ffba05bccc..ed1ab632ae 100644 --- a/basis/alarms/alarms-tests.factor +++ b/basis/alarms/alarms-tests.factor @@ -44,3 +44,24 @@ IN: alarms.tests 2 seconds sleep stop-alarm 1/2 seconds sleep ] unit-test + +[ { 0 } ] [ + { 0 } + dup '[ 1 _ set-first ] 300 milliseconds later + 150 milliseconds sleep + [ restart-alarm ] [ 200 milliseconds sleep stop-alarm ] bi +] unit-test + +[ { 1 } ] [ + { 0 } + dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later + 100 milliseconds sleep restart-alarm 300 milliseconds sleep +] unit-test + +[ { 4 } ] [ + { 0 } + dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds + dup start-alarm + 700 milliseconds sleep dup restart-alarm + 700 milliseconds sleep stop-alarm 500 milliseconds sleep +] unit-test diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor index a82f367a13..866a5573bf 100644 --- a/basis/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -12,6 +12,7 @@ TUPLE: alarm interval-nanos iteration-start-nanos quotation-running? + restart? thread ; nanoseconds duration>nanoseconds >integer ; >>iteration-start-nanos ; : stop-alarm? ( alarm -- ? ) - thread>> self eq? not ; + { [ thread>> self eq? not ] [ restart?>> ] } 1|| ; DEFER: call-alarm-loop @@ -60,6 +61,15 @@ DEFER: call-alarm-loop maybe-loop-alarm ] if ; +: sleep-delay ( alarm -- ) + nano-count >>start-nanos + delay-nanos>> [ sleep ] when* ; + +: alarm-loop ( alarm -- ) + [ sleep-delay ] + [ nano-count >>iteration-start-nanos call-alarm-loop ] + [ dup restart?>> [ f >>restart? alarm-loop ] [ drop ] if ] tri ; + PRIVATE> : ( quot delay-duration/f interval-duration/f -- alarm ) @@ -70,11 +80,7 @@ PRIVATE> : start-alarm ( alarm -- ) [ - '[ - _ nano-count >>start-nanos - [ delay-nanos>> [ sleep ] when* ] - [ nano-count >>iteration-start-nanos call-alarm-loop ] bi - ] "Alarm execution" spawn + '[ _ alarm-loop ] "Alarm execution" spawn ] keep thread<< ; : stop-alarm ( alarm -- ) @@ -84,6 +90,9 @@ PRIVATE> [ [ interrupt ] when* f ] change-thread drop ] if ; +: restart-alarm ( alarm -- ) + t >>restart? [ stop-alarm ] [ start-alarm ] bi ; +