Add a restart-alarm word that doesn't spawn a new thread

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 <alarm> }
 "Starting an alarm:"
-{ $subsections start-alarm }
+{ $subsections start-alarm restart-alarm }
 "Stopping an alarm:"
 { $subsections stop-alarm }
 

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
+    <alarm> dup start-alarm
+    700 milliseconds sleep dup restart-alarm
+    700 milliseconds sleep stop-alarm 500 milliseconds sleep
+] unit-test

basis/alarms/alarms.factor

@@ -12,6 +12,7 @@ TUPLE: alarm
     interval-nanos
     iteration-start-nanos
     quotation-running?
+    restart?
     thread ;
 
 <PRIVATE
@@ -33,7 +34,7 @@ M: duration >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>
 
 : <alarm> ( 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 ;
+
 <PRIVATE
 
 : (start-alarm) ( quot start-duration interval-duration -- alarm )